[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-manual-2, updated. release_1-9-9-8
|
From: |
Neil Jerram |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-manual-2, updated. release_1-9-9-84-g26b9f90 |
|
Date: |
Sat, 10 Apr 2010 12:34:47 +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=26b9f9090073c896762af3125af54958e153f8f2
The branch, wip-manual-2 has been updated
via 26b9f9090073c896762af3125af54958e153f8f2 (commit)
via 96ec2c9c65468b1404865371d19342d6badb0be9 (commit)
via 2860ff4675cf1a47c28e1defe094894622d046b9 (commit)
via 92a61010bd04dfa81ac94b32e40d0e7a6c932845 (commit)
via 474060a23ccd7db9784a99912ec505f796ac12e5 (commit)
via cd038da5467d6e4cc2f04a4ebd0f915b62359781 (commit)
via 54e53aa4301bcb8aaff0a5dfd4af044ee693f235 (commit)
via 7c4aad9cc7143ea7c1a7ce3c143ca0581cace5b5 (commit)
via c1b7c940eca528d8875bc9bd00fba1a885b4dddb (commit)
via 92e19ec06d490a95e9550c634c922f67e42140d6 (commit)
via 0becb8f316137e6823b2652a33b7212e02722782 (commit)
via 01ad5a7ba9edb5d8c96567ed80ea1a34019c5338 (commit)
via 4551e860f02244ffb3858c941319f1613bac40e4 (commit)
via b577bc90bbaadfac508acc809e59b983db33b7aa (commit)
via 1606312f9a1200950336d485bd29866c0f8e3942 (commit)
via 6c76da4c32dd8a2c1f38d51df6e58dcc0b7cee11 (commit)
via e39d0b76684ae8e6f2bffa511e28ff2c2d44a106 (commit)
via 1a461493a33d44f41a7d5245df142ef000c09db3 (commit)
via 9225df3c551c9b28cf16f5c4aab8cf1183f44577 (commit)
via 8f44138ac6c91d9e20c3557ee6e5389900a7730e (commit)
via de9df04a0ce8b87e5843b0fcdfcf105437618492 (commit)
via e48a2f8705623e23c21dca5bb38ab437d82b39e4 (commit)
via f5318d8b188c6636d1f593bb1d2690ba1b0a42e4 (commit)
via 4d75554d0a2ed446c1fd7a75f5b69355c5109bcc (commit)
via d53e5a7edb091255c5026d6e194f4885a32e769d (commit)
via fb53c347a6794b2b8fd7419269633b1f28e31b25 (commit)
via a34a2022c8a1e363faaeef2f0d3fb9c1eb9a6f12 (commit)
via b9264dc5f3c2c9341852b898bd3eb8587dbd20f3 (commit)
via 71725997c756e11e434983a8a19b4b205dc4265a (commit)
via dcc69bab8c410a15529f9b7bcaf05cc138b23438 (commit)
via 119682690ff5f6f5eb25272f1a1b34ac3a7d6746 (commit)
via 897bf7b0f756e7a5e8c016f7cf77ca84d135a1db (commit)
via 6d30df5dbd4080c08d606c9f2b21672d47f04203 (commit)
via 43cd9cec2320b0fad4e04410226b319918a57f35 (commit)
via 726b8ba3fd5de26d5eb8c6567cc0b15bc1a7193e (commit)
via 7b702b5391fb54114307636934e4d28101655093 (commit)
via a587d6a97338a0fd62173e60581ff07f55ec2042 (commit)
via 92d33877d9f8523eaebab75373a30f161e6cc1e8 (commit)
via 8ecd1943ef7bbef67b83b0502da1527e3b7a7133 (commit)
via e275b8a220f39b5a1ff9644ac21796a12e4d0c9a (commit)
via 28828f40eb8ea7e10e35aa1e83ebf37449350c08 (commit)
via cedf24d8bda2439fa0b6de74a6fa4b8105d96004 (commit)
via 0ecd70a2714c184b57aa92c6c061c0ee7b51df79 (commit)
via bd7131d3adf60b98837bd8bc3711ec7cf9069569 (commit)
via 2115b8eb408d8f965d3c0d28cb087e55f0eb5daf (commit)
via 1b10152215db2ed381bd63c8c234eb44eb7ed414 (commit)
via 3ffd1ba96e986581d97079308fc15ef1fc933cdb (commit)
via d26383f427245e088401f53af64b44062750925e (commit)
via 9d031d4d575ac8f343a5d984cb02cd374577c5a9 (commit)
via 6128f34c4b6ae713c4dddc38093aafe7260ccab6 (commit)
via 2533f10b40cdab357140347fe05e291f02bb5cb5 (commit)
via d38b431ace4b01e5da9cb09bb6341277f2974160 (commit)
via 655aadf4b09c40f4c7854e4325e8809fcb7cb36b (commit)
via 0eedfa5cab71cef05e2b9f06d6286d3b8f04ca59 (commit)
via 4e974a1a6d2c0d749bc87bf1b77a519da3e1fe85 (commit)
via 4f08d0b50fffd3d35ea5be430e6ae4251ea53baa (commit)
via a5e95abe9b502e4c08d6762b1f4754fa9cdf2371 (commit)
via f60c2c4e100b36e5ec2616ba7940280b57d952b9 (commit)
via 98dcf051e00bb0b36b932b60e5bdce584f2acde4 (commit)
via 83a7b43bf2bf445af9d2611252deaacb4de7095e (commit)
via 1f51e2757c0c6fc4a963c6f46578241e84be871e (commit)
via 3785c5b27645c5b0c5124b1bfc31533f80764856 (commit)
via dca9a4d68556479a25d0e26fb8ac45c0f872efcd (commit)
via 1ea8aa7d8e980ce0dc17938058d4665b0c1193b9 (commit)
via df0f529585e55007e2a2226f624b55e986722d37 (commit)
via 165a8643ae1c9e8d8eceba2e33a9586e9863ea8c (commit)
via a2c6904911577b51c2486ad7115a4311524d4a96 (commit)
via 7f10a113c5f370071647c23b21b912ecceef3a50 (commit)
via 8a73a6d2943ee081fa0497cd37abcc2f72ca9164 (commit)
via 6ffd4131ffa11d0a91cc555641f40457fd2ba7d0 (commit)
via 1fc8dcc7ac6a83ae6586e02491784954e3be94ef (commit)
via a6e60a9571711cf90ec9cf547125cb1495e58bca (commit)
via fbda9ef1b24d70edd3ebab0f9e8a29b8fdfba852 (commit)
via d6ed9b92c5a9bcc6d7a5203034a78c15553d1b0c (commit)
via e4955559c6f541c32811c5caaa9b0224abb2c85a (commit)
via ef7e4ba373fbd68ea87c4ba1541a58b38bec12b3 (commit)
via f4c79b3c08b4b16f504a049b2ef14a238e94508f (commit)
via 54eb59cf4948482461e41f73c0a5b1f9c7081326 (commit)
via 5595bd76414e50834b293ead7fd67a54fe56c563 (commit)
via d12f974b4389f11a2f5fe47f6ca786514cb3bbc9 (commit)
via dd1464bf38c5e2dc71652b62f63e4bcf93179a14 (commit)
via 3023e7b0c90081f0060cb78a4a534ed7cd77c9bf (commit)
via 087aa6aa312a8d0af51fa9b2f7bfc1332ad97338 (commit)
via b0abbaa74a036242a8d727432c82ee95a6bf5a8b (commit)
via 71fada0b6d6106b173bc06b2de5959b039c909e8 (commit)
via 17ed90df4896a0648d5b6f0171a45ba181cbd68f (commit)
via 718815d7618fe7766f3620538917849ccc93f36f (commit)
via 44602b08680ad6422dd88780c23540c0632bcc68 (commit)
via 89607fab50ed88dff3b6fb5310a6753da8dbaa97 (commit)
via 462bcfd03847a568b34074ba6fcf4f7f4de3c0fc (commit)
via dbf499823f29dcb3329eec8e00ff22762f6b5d49 (commit)
via f7cea64566407151de4ff665ec787fca927b908f (commit)
via db5034ab89426edacf5229e7e6b37cb0495cd287 (commit)
via 9823fd399c4addd852409c20e3112e62dca0a937 (commit)
via deec8986ff889724a6fa3fdd9d5e7221473956fe (commit)
via d3b5628c6de88ee08787aab5b1af96f913b77ed4 (commit)
via f11871d6c557e706b80e7fa6c0c1f1da854fe1c4 (commit)
via 7e08f8a6c16ef88ecca8895e81219b040593c212 (commit)
via 42ee0d00ba61e51a5b4a9f2d59e6f95b52e49dbf (commit)
via 42cb9b03111ccddb4abcf25004c4bd8bd069390f (commit)
via 5c43d9c78388a3545bbd841f6ab37f6c3adfb4a7 (commit)
via 8137c9d5e7c176d04c5bd81afa00186268df16bc (commit)
via 9d832dda456c84551034a3624470281222a72099 (commit)
via 0f7e6c56cd3d1a070ea4b469368d9c2f6f492538 (commit)
via 06dcb9dfb663169ce612bca241e5438c73bfa5c6 (commit)
via 01c0082fae4ce3b0c09f003a2141c38cfc062d74 (commit)
via 32ce4058db1adc319dabf6f93143cb367f7456fc (commit)
via 9f0745183605c4f2997b95c421637678ca5e5e2a (commit)
via c6a32a2cd59190dcf17c7fb3022588f56079a03e (commit)
via 8fc43b12c71789030d9058fea8b6eff5490dec27 (commit)
via a6cd35551023d72703cf05a98e42e9dd6a75d48f (commit)
via 5c606217a4bdd2e918d224b12fe576eff4e561c7 (commit)
via 5af3378aab5b32bd82bd93d9a789c97e553a1356 (commit)
via ba7e7139b3adbf4cf7683edc31097535d3cd7e56 (commit)
via 1caa6341b0832ebe2173ba16d6132fa79b042d9e (commit)
via bd5a75dcd8436ebe077c9ce52300d013e9519d94 (commit)
via c02924d02b4b78998b380deb20a4fd2d5fc3cfbb (commit)
via e2cf8eb921a4dd12af5024861e2b2bfc0b90a1ed (commit)
via b7ecadca7b84a5c9229001354f7b902ef94b5ac5 (commit)
via 83a7171bf369d67a5cbb48568ba9727600e72a11 (commit)
via eddd16d782343fbc10818e4f2ee706774921f051 (commit)
via 2150e9a84a9e0e9f83fa7af2c08c274ebcd9b1c2 (commit)
via 2b2746a831b5f74773d6eec91d2c30d43831e826 (commit)
via bbb2ecd1d1966766aa5f3fed7d5084b46cf1e8a7 (commit)
via dec84a0a6e164d7c92982ea78c27e85df56ed477 (commit)
via 87bc7c81650fef2ee8bc83bceab6ea565a47f2b5 (commit)
via d332d84610f1ae8dacd546d974287c9279a64428 (commit)
via 1c242b37f0dda6e82e3cafecd6f28a7df1841d77 (commit)
via c45de346fd40a296b6c2519af1c807df968b9e05 (commit)
via f5147c84a2228b5f23608aba4319b3fa4b7a432c (commit)
via 54096be7528be999a5eb1b393922c331880128ae (commit)
via 05c51bcff5604d520c9335cfbf91eb4bf84003ed (commit)
via a5c96cb99dc060a254887e2182f01911a4a19d77 (commit)
via da7497e0fd5d8a95f3918ec820eab3feeb75237d (commit)
via dc327575a8564257d8b84d835d72bc4fe098ba46 (commit)
via 3278efd3fa3fc106da5c5b704b26f35e5ec16ac4 (commit)
via b8ed3de36e56bff0ffab2000b9ba55c585a4bc0e (commit)
via d900a8557db21641413db8995a7cdc1453adbe1f (commit)
via 69c9600678e67a51b258f2e3cfe1b5e0f842b45d (commit)
via d524964774508a2cf3ad6ad1cd7b08bec6c7eeb0 (commit)
via a2f7536db02edeb7edb66c2deba83bf22eb9e2ca (commit)
via adbdfd6d2418b1404af48d480c2273f501517d6e (commit)
via 416f26c7534a018c59f1c8d888dc9153f42d86d1 (commit)
via e10cf6b9c7e54c79db4de74584f1b0b65847d4fc (commit)
via d296431516dbf14535fc6eaba551fede19c09772 (commit)
via b8af64db76bc602517be300128be0dfb67fac89f (commit)
via da7fa082e80b2c3989c90031ee5356e5b65bd00b (commit)
via 1371fe9b149da699320567e5160160169ecdb0be (commit)
via b3950ad6d88c5675dadb74c8ce5668daaa1b8692 (commit)
via 35ac785286a527449b9866b4b9adb78a41e545a7 (commit)
via ce4c9a6d00a647892e25d24d703f328afb4be9c3 (commit)
via 0404c97dc904272ec8a55cacbe639dc52de2830e (commit)
via c8df99730a6d2eaaaa6bd1216c4c7394a691ee7f (commit)
via 211fcbc8cdfb0834a6675dc8454994472ed7ce3f (commit)
via 3ccee39194a2ae967eb12dd9c0adceeddb305646 (commit)
via 29366989cf19c844c8d46e456da03466db534ddf (commit)
via 9a1c6f1f0c6b07725a240160b79acc54303d7891 (commit)
via 078014374c066f03975bd0ef008877c5236c75ec (commit)
via 6d804376e94d17cf013a415c4bd98d632f7a91b9 (commit)
via ac644098bf1573cfbb4ee032e6cd32a23ca168b6 (commit)
via cee1d22c3c10b1892c82a5758ef69cd6fc9aba31 (commit)
via 76e3816281cf6c406ef6f01907ce29401c8ff455 (commit)
via 2d026f04cc581915f62b1f2f3be2f27026ee383e (commit)
via f828ab4f30b974c0f839fb6df9590c16907b7a0a (commit)
via 47ae4ac8f478b09bc33ab05d896826bc8f6dd2f1 (commit)
via 747022e4cb5faef6e0a2c73f046bacd93bb99ab8 (commit)
via 0bc8874c0461d532ca0251cf20af9bc5193b3cfa (commit)
via eaefabee34506324ecb1470ac5a4ba774381d038 (commit)
via ea6b18e82f3ac2122d07c80bc0f320ea839a25b6 (commit)
via f5b1f76af492f3c398527ee040e8bf09fc438a9a (commit)
via 706a705eca032f84562ec84ac439b3d4a7ca8c66 (commit)
via 1e7a0337f1180343ca2f81557bfdeb78e23cd532 (commit)
via 5ef71027e49ba870556be194e177fa09b2ff306a (commit)
via 26e6f99fc3543cd4aa24d2d96126ae025f61ab28 (commit)
via 6e84cb95b18d81ef7a8490cccdfb08d3f88116ea (commit)
via 07a0c7d5d9523936d5fe4cac595bd75859416c9e (commit)
via bcbbba866b56460d097dba17e0dbb0c53d9f9211 (commit)
via 67a78ddd8381ccf098b52659897a4d40806a0928 (commit)
via 6360c1d4c1f7d3bb43afa4f71d1d92bbf37fd845 (commit)
via b50511b4753240ddeb9f0823c9401d8ad32ae055 (commit)
via e084b27e7913acf6e9414d1ff46f0bd9442e71fd (commit)
via d7c53a86954e16f1d6c76cab2c41889ba9133488 (commit)
via bb0229b51d53c10164f58cebbeeed85cd9dfe0b8 (commit)
via 27bd1deced05d096915d47c6ea46d3b22d692e19 (commit)
via 8da6ab34bd23f27eb257936925cf81e89c26ff4e (commit)
via c08899ff24932b96573093d490160591e446b8a0 (commit)
via f3a8d1b745285a9667041c09f4ac6d5ff738570f (commit)
via 2ac16429ab5a3e894f242a50a84526e8bd7d2391 (commit)
via b5e9f3f97ebad910b932736f7b65bbf98083dd49 (commit)
via 21ec0bd9077b2fc109f1f425462eca37ef4a34e1 (commit)
via d69531e21326dbec935da6ead29335f2cccf1a3f (commit)
via ac1ef09bfee23177052aa157f8cb049ae8dbd64e (commit)
via dde9c5a431c67a16febf000d011172c65883f49b (commit)
via 44d70904a6ae93e0a844dedf65b2f84dc93a5048 (commit)
via 691b9ec196203fa5d6da3530d5355b2f73e707d1 (commit)
via dbd9532e89d8aaed76fbaaa3a11388f6a4e9aefe (commit)
via 127f5c624d16f33da72a56e75a38912e06346113 (commit)
via f353687c688d20c9e8f42383d7f2e820a8834159 (commit)
via d2add8ae1164e2bd482a5c419e3c90211a8a312a (commit)
via a104b81cc40b5ff321605ca3731103bbd0e98894 (commit)
via f75c5849cdc6c863616facbb22b28d08da3fc09f (commit)
via 3ef9fa53f9e2b5fc1d0419a94432318e9ca9d650 (commit)
via 04af4c4c5221c082905d52eb5ad3829ed681d097 (commit)
via 2bfa4d5ccd3294988c0e64ec464493a4e9facd1d (commit)
via 56d288b8445be2d3b2e23a95d4943a11b291e724 (commit)
via 2b386ab09f8b583ba0547bf06ebc57c78c3bea51 (commit)
via 8a8da78d97ffe779a1baa1098ed9497c5021759e (commit)
via 44d3d1114447ee619bc9a900afb410273b56aae2 (commit)
via 3ea159afc5c476e06148cf5fc2a1fb77267326f6 (commit)
via 3474222a65b7d4cc02b43bcd8abcadbc7ec5258f (commit)
via 25bc75c4316497c95b1c3fc17f1678ac47d32041 (commit)
via 2fe5eb561c02ceda6e9244e14c68b2072fb94eb5 (commit)
via 40ff484d80ef3bf3706262e6fcc5178e8239f60d (commit)
via 55ae00ea73e5698d64c31118717c15e6dd9cafe7 (commit)
via 61cd9dc907b8a09990b14e9aeac7e20fe77cecc6 (commit)
via 60b6a84f0f2d8d43491835a518463f4a8273bf87 (commit)
via 4adf9a7e2750593e444a2c7d950e194294242896 (commit)
via acbccb0c834e3d28d14c60c98c730969edcdfbcc (commit)
via 524aa8ae6830d0f471f0c86431d5da87c8a0a534 (commit)
via dad6817f7d9581264891c6ad8954369d01f3d0b7 (commit)
via bde92e6b3bbd15c7abaf29bc0557041b88df8d74 (commit)
via 0c368d2b2811fb856c9551e7ad217f8e5636024f (commit)
via d8873dfe4754daf031a6709738bd31afa8edb443 (commit)
via 269479e31f70d40a82b75be87c1b2a7363c85696 (commit)
via 997659f898d94abccdcba3c444b84e3c6f6e963e (commit)
via babfc7b2c3fce452aa12fed8d89cd3fbc81e8cc8 (commit)
via 1d1cae0e2e063d9a36e7d600f87cf3d6eaf940f3 (commit)
via 217167c6b2e6e400306c8cb4a0bff86c17eef28c (commit)
via adaf86ec49959f6df55947cf69ac98d6bf1074f7 (commit)
via 69f90b0b051e77257a753f1ee7ae6a18a1147c78 (commit)
via a670e672119ac2fb2f6a5b09e0908c07fd7864eb (commit)
via df685ee46b672c9fe1c3fa813e9406a8dcde9b81 (commit)
via 04ea6fb504b7339f0432b88b8137e5ac455d2309 (commit)
via 5cbf2e1d7b3d744d92e279801f07aa05d1799da3 (commit)
via 22ec6a31eda1f06270fbba4b6aae45bb81de0631 (commit)
via 30a700c8c12aeaefe3cd5fb85ea3c1b7059705bf (commit)
via 61cbfff50979136f03ab161711edc5eb21145609 (commit)
via 9b2a2a391a96070af3e69335f069302f3a08d44a (commit)
via b9c100d008bbaa19406fdee3058a5c35dba07499 (commit)
via 9b7ca73cfe4d6f82811d5dac8706237690834287 (commit)
via c6601f1077b079d04a377164dbe1fb70bb2b0979 (commit)
via 2d9260d12c5b2ecfa29f86c94eeec9ae21cd908e (commit)
via 88fed05d033263aafd119133aee47cd8028128ae (commit)
via 282d128cb4553cd7541bbbd3b0cf6f3b3f223ef7 (commit)
via 1bf78495e90d65911c9e012764deab589640f883 (commit)
via 1c297a3850b0b4466e5b986168c02f455c49cb1b (commit)
via 4f66bcdeff1f5e3d1dd44d745188b91942b04d33 (commit)
via 17d819d4c43701e0e0e92f6c2001343d4730db83 (commit)
via 3435f3c07c27c62fcd0a6112243a27ea4ae7b462 (commit)
via 663212bbc66b616cca9ba55d9992e2fb339d8250 (commit)
via d27a7811db7947bb9bba536303702c8906219165 (commit)
via 0515661235e3c17935b918565c70145d7895d37e (commit)
via 80e22004bd01a719578997f333aa09d907a450e4 (commit)
via c612ed59ab3ba92a0b778d30f21c493341160df2 (commit)
via 75383ddbd77d5981e5ab4ac72818b96d391c9e22 (commit)
via 70ea39f70f54e82fc38204ac5f7768505cc37dff (commit)
via 9a396cbdbea984f8265e760f64414e8e712e49ab (commit)
via 37371ea1ba160e2eb61fb3415024ef8e79b2e502 (commit)
via 4d9130a5b733e844e42f27f209e148fa64f731be (commit)
via d8b04f04e90882f3903092ea85038a9e3cd10d39 (commit)
via 827dc8dcb61dcbdd62ad1ae41b98d65ecd8d5b66 (commit)
via 20aafae22a4f11289b65dba685495a808ebd6b07 (commit)
via ab4779ffcfb463201d46459e06b9188dd5f1cbda (commit)
via 52fd9639fdeee068434342e1bdb8693b05ecac5c (commit)
via 75c242a256c273ab0690397df4277d44f01946e6 (commit)
via e03b7f73e2927178f2d9485320435edb6260c311 (commit)
via bb190ddbba216251f2a8490adf9feadf0dbb7104 (commit)
via 227eff6a77dd58d64775fe91ae0f1596bfe3371b (commit)
via d31b95195168ded0d3300159403adb2c4917e291 (commit)
via 2ff9bf8522c5f8981af5fd524769733ac1e3e8de (commit)
via a752c0dc2798fb1af93d56f6f73bea964df12633 (commit)
via 696ac4dfcc4e48c95df8935fc3640377c5df18fb (commit)
via 01e74380f6170b5cb1105e5df9a368ab257420ef (commit)
via aa42c03669df8acf997d3108f08ce94d5d7611c2 (commit)
via 0e64cbea3d22411564af302a63b670fe0617ccf3 (commit)
via 73d1aaafb226b5e386b6b2eeacc40b836ff85940 (commit)
via a70c0ff578712ab8170aea0d2fb0d9b53cee8c5c (commit)
via 6bf927ab6ea9232b4678bb6b99ef9dfa23a62941 (commit)
via 788cf402394a4bedc1c4e6bb97b22a2e33226450 (commit)
via baedef98eeee0357983ce9730b102be6b2158029 (commit)
via d532c41b91a53a5559de42bf15a3980b8f041677 (commit)
via 912a8702466f07ca3f4c673a895361e5d7775b7b (commit)
via adfb42846617f6ed11cbe6ca9f0256e48a0cbb49 (commit)
via 5b6b22e8ead58068d9085bc72d2a719f7cbfd3b7 (commit)
via 67af975c0be6e0e00e19967acdbc1c69497398f9 (commit)
via d85ae24dfb96997ce50ece2eb06a33a997313640 (commit)
via 7beae9f15ac49f144a15d3ebfe80c2f29e43b3ff (commit)
via 870d7a2b4f397a4619553b0f9798b6e8b3ed173e (commit)
via 445f31fc06d338f0cafda188d0287f935c2edc3c (commit)
via 06bfe276c8bfd71cf601761659d6b20acebc23b8 (commit)
via f826a8864a4ec7bfffac0f67d45f8ce0085e9d23 (commit)
via 5afa815c9cd4550bf93181bc0ed0134aa83dfc5d (commit)
via e1138ba1995f970083ad752f1ff8f71876483194 (commit)
via 7055591c2e9ba97b9a5d1c15a3b7e1ce409966f5 (commit)
via f207859b0be606ea77d488262e2b8d114c9ae370 (commit)
via 7ea3e4ff28fb02b0c82a2e304ba8d958528bc2ae (commit)
via 45cc48673a75c8318d2e6ca3651d94e64a08ad47 (commit)
via 7e9f96021ac200f2fe5b25f4e02bd11b3331fb34 (commit)
via a8fc38526a3e8fb9fef00042e1acc5b4a80b3f3f (commit)
via bd4b6c1a83a857f48e63fd64c276c77457c41bca (commit)
via e744e076fae41492fb990bc32594d9daf2908094 (commit)
via 6ea3048785915947a24305f0cff88f7b903182a0 (commit)
via 898a0b5a2ec6141fc408bef3d93e040870386de8 (commit)
via 2e85d145fc44b49bceaec3ab95da43688f8db0f4 (commit)
via dea901d66e46041f96d3d3a0f95bf0ab209387c9 (commit)
via 8470b3f45b48bf627642e8f41938492be4eacf2c (commit)
via 7aec4ce019555b0c7113c585fda4a7ef18b84b5a (commit)
via 0d782201bf5c23725db77c3d3d0e9bd959b1268d (commit)
via e30f5b7d4032f79eb3ecdb0a11de37486221845c (commit)
via e106eca674288661ca6a2b7352ed082cbcda1b12 (commit)
via f3a1fc5a9ec0cea5dcd6e505bf9a440ee3651891 (commit)
via 136b5494d13fdc4a7b3b59d4bd451beb2c075e25 (commit)
via 3b12702faf0fa42890e4c857aabda3e6d5eb5c83 (commit)
via dfe13aa2c82371dad3b455e79e295a21b50d4992 (commit)
via c6a4432bf184bf13a1fd97407103f0c37010b5a1 (commit)
via 64fa96ef28f98b087bc5844c5d9944145a06e3c0 (commit)
via 73788ca8bedcb4dd9578a1a992223e51a7d99a0d (commit)
via 5a9c6dcbb3bdda159cc45edb9d8b34e7b5043b9e (commit)
via 411313403cac04d1b1b1c7f579da32eaaaf4d80d (commit)
via 628ddb80aa5b33185e7eff81e72d158936079d91 (commit)
via c5661d2860da05b4666c9f4764509034aa7da693 (commit)
via e63dda67d70eb4cb92cbc406510a0f21337374a4 (commit)
via 0ea72faa4e448356665bab3d679d71e0958963aa (commit)
via 7385dc1243aa9862239c2551d523b1df3fdc63c3 (commit)
via bf943698b6f37f35c22e245d6b56df9d19411ebf (commit)
via 6734191c6822d41920c322d83fa0e17221d95dc3 (commit)
via e6251e7bd98fbc64e9dbf489c8afaf426af46919 (commit)
via bce5cb56413da437c29628c529cec47649d12eb9 (commit)
via bcae9a98b0dd82b7be93e90134a01a03b44b4af7 (commit)
via 7cd554943b455248f8488f7b70b6dc31fc4cc67c (commit)
via 67a4a16d8e4418f0525b580c157c1295ca1563fc (commit)
via 085a61df2ebe26f9555188c452501ecbf349f887 (commit)
via 15b6a6b284f00fa790ef003a9df8c8ae5a4d7d6a (commit)
via f39ede00675f0d7dcdb864e91653c4dacb98e694 (commit)
via ecdf15573b4734488893a03500312f18575819ce (commit)
via cf8ec359cc0e4a02e11c71f194fc076c6f9168c1 (commit)
via 4a45769178ee91469c414ccc7a64f529b6ee221a (commit)
via 2051e2bdbbafd32716e0098a71cb1f5b657a5075 (commit)
via 4168aa4675174ec74816ed6b7e23518c2b64c96a (commit)
via fdcb2b82d7a6fe917f236bdc95a7a231169fe21a (commit)
via 7c4a6456982254440d4e145fe0b250693a11975e (commit)
via 913ddf05745a691c71291aba47fc901fc7ead1de (commit)
via fc7648637b356078988ca1ed598e74c394beeaaa (commit)
via 37e9bc8ae48ae2c014fd4f63fc37b18348d05513 (commit)
via 391d29029d69704bc6bd541d80209532e582c3c0 (commit)
via 8217c9251acef6f09fa04e1ead5eaa69b6909284 (commit)
via 0af34a3f833a3e90edc18223b91fcafebc786275 (commit)
via 6f16379e9a8d1f2d10c648793582a10772f29e32 (commit)
via 75c3ed282029f4d2a80adf75f52ec1b9b34edcb7 (commit)
via 9174596d5bfc456d06f4cf74a7a67e9b2b09aac3 (commit)
via a589525d4e1d0e4ce385a01820a7fa6fa9a5030e (commit)
via 795ab688ee994181d92c2a106fc2408d86dbbbf8 (commit)
via c5e05a1c70d7a3db2456677524872a590624285f (commit)
via cc7005bc371ee104c368dbb894eb4f8b7a86d64a (commit)
via 6c2961a01142c7ba9fc03a410004dd696e9208cd (commit)
via fd12a19a5e59afbd78ca67b1305c70bb1ecb724b (commit)
via 97812f4d38b1077c87e8fde02b1d62da6a1a6a06 (commit)
via f1d19308ade7f7d115be243650270e8a2a38fc38 (commit)
via 2be89ca129e078f7e558d07b93ce89bf9ed13a9d (commit)
via 6f3b0cc29eb1c1dcb2e02058e3db9ab04ca36b42 (commit)
via a6029b97ea84d9e9a13d71b21213b6fd0be41e87 (commit)
via f3056b42cf2ddb52cdd7de013ada33e4aa953ada (commit)
via 6c498233a1c6a75fbfc81471b94bdc89306879c3 (commit)
via 27219b32c740ba55d88697829e05bf58120b86d9 (commit)
via a2689737679cf2553c118a1d96de7c9ddfec62b0 (commit)
via 3dc2afe2b85eb5c7ec784b6ed8b19242e45f6e34 (commit)
via 5c39373f48f9694a16d1486ab073f4ab229e9c55 (commit)
via cf9a806dbd8fc58caafefbb4a5328fac2d322cee (commit)
via 8ffcf6e725f97a4f3480ef6583743d7786e42997 (commit)
via e29dcaf3b7dde40b960455587142e7a79c53bfab (commit)
via daa4a3f1ff34840f83705011780d62a5f4a56508 (commit)
via a3d7d5d50806fdfb80f44f53c7d990cf79a8d566 (commit)
via 7b0419128bce68f48a158292430ed4a7202aa1b1 (commit)
via 29bcdbb05948a5f12d2d8cb36a0c3c582e738be3 (commit)
via 9fdee5b40b190585f3fac949a366dfcf06ad202a (commit)
via fd629322442e3a7131d779a266745ffd05e83c56 (commit)
via f318aa1e386a941df1d2cb2f4d82f8337578baa5 (commit)
via 31a26df2cc91427f0a4281d6ac5a1c0b53a8c0f1 (commit)
via d8164b046c71c3f313fa4f7e239d50823b619297 (commit)
via 9c246c03838c1cc844d15a7c4817029df1994e96 (commit)
via 9fdf9fd3ea7130fd85eaf0a333a965ac4d2b07c3 (commit)
via e809758a7e0f3f63162a0a9064b95bd1c1d10628 (commit)
via bab980466108c6c22d2c820213d07b3d1b18c48e (commit)
via 9f09b127d447991bd749235f78516700a20c7dff (commit)
via ea7d717b1ed5ae84812c53dbbc3f399c6ff0b65e (commit)
via 54cd715022acc06bcf59038d863b1a3ab7e4bba1 (commit)
via e773b1e6ce2af1753034cb1065518c2341228008 (commit)
via e2c2a6994d05124760ea7f18caf5d28fb47e453c (commit)
via 208fae8a0ebaa56b69105c89d69e337aef6a3e62 (commit)
via 2bc8d9eff694d2160a005edecc95cdc088d546f1 (commit)
via e3eefae0e596a587e91693ed37a61699ac66560a (commit)
via a5bbb22e83fc724650973dab5eb6f3eccbc1f65c (commit)
via 87a6a23669dc534df5d3de146e77efd3a2bafb22 (commit)
via 09834e439b685ca3bb4404e40e046b11772fe50d (commit)
via edb7bb4766773cffa8262b4cd8bb980888913d65 (commit)
via 441891f376221d7bcd1f6fc8927595fe25417255 (commit)
via 0c2a05c3213da8b1269af37d65af3f8bffdb01c2 (commit)
via 7abb7efd319526bb2260fdcc35440a31dfd5cf51 (commit)
via 9274c3dd4058b3f63ba97570fc2f1598debbc03d (commit)
via 2d8c757cf10a22ba708b44e6305f4dbae29b7297 (commit)
via 1c5e812258da4b002d309f969d722c86004ecf94 (commit)
via b8596c08ac2ef2201c1e8559ac5f4d62ebde3d91 (commit)
via 8c6eea2f1a6fab2d2be4d0de6a6826273eb2c3c9 (commit)
via c5f171027d9b237630a71dc43d4b1b3dc391c591 (commit)
via a1dcb961a6d819c154cfa5767ce4193f31cf29b3 (commit)
via c1ff4aa7866aa7189c770136d19578b1295a6229 (commit)
via 9a9d82c28caf37278375912d33441e4318d55349 (commit)
via b597129782e4e65cbb9b2317b116d83daea0820c (commit)
via b521d265b1d02771500527f00704e6c9371a3c37 (commit)
via aac006ddec98c96ac5d9e19bd28496f8ff95f0ae (commit)
via a927454d25f17a3cfb5c130f26933a76a9a9060b (commit)
via b349875146af814dbeac07e96b043a3a3996b7cd (commit)
via 3323ec063ccc87b210e6da04c57c625af270b230 (commit)
via 211a5b04251424f17f659257718329af7a3cdc0c (commit)
via 3e5aed1c3be296b92f3a21e0dfde315deaef9daa (commit)
via 0ca3a342d19ec89b8ae6bba0a74f0f9ecc5cf7c2 (commit)
via d7a4096d251933a21325739fcd32129b073c33ce (commit)
via f6fe5fe26b7b64c2d194b1dd27b1bd038e8fa70c (commit)
via f6a8e7919755ce15cd75ad01326e02151fa99445 (commit)
via 1ad7fef5249f409317c20d5242bc3c4c2b8d9d18 (commit)
via 0dfe0e758890379d625e08d4deffbbbd5822e99f (commit)
via dca14012bd9c62178890ff82d29c655ae71d2977 (commit)
via 78c22f5edc3c74bc50e52d5291ddc5c80c20ba8a (commit)
via 820f33aaed18b37f68bc4abfeea52df2df3bd374 (commit)
via 9b5a0d84600b3c86425bba5ea2324334a7ba873d (commit)
via 737caee88dae8d442950efeee98ea83c1e7db7a4 (commit)
via 9eaa8fef80b3bf2ece73936fc3c9e5c136df8e78 (commit)
via 8b0d7b9d94b9f142dc4f08ce12b345321359b3cd (commit)
via 7656f194465ed50901c9cf3e31a68c3014b576ba (commit)
via 86fd6dff2a77150148ed7b3d9152e0a431070666 (commit)
via 700908288cdafd7d68dc2861e2348f38aeb38782 (commit)
via a6dc56a71e0085f9e0f889ecbb8b085f6c92da7b (commit)
via 500f6a47e2609f936d43f47bcce4e429eb57997d (commit)
via c55cb58ac15b61eac574d8adafb08bc32f2bc8c1 (commit)
via 05c29c5abc79bc1ceb7999176252debf0a6811e4 (commit)
via c165c50d072105c82c9b15059e756a2cba353dbb (commit)
via 47f3ce525efcf2aa30abbae0374c19c9f8960789 (commit)
via c66fe8a9a0a6b5106c94a4ce6eeda551275dc2bc (commit)
via 7d94e4af9840c1f273ded31c3a39a6bb6a0496a5 (commit)
via d5f9864ffc30701af0e393b692fb0bded8c6a95a (commit)
via 31c944228ca3694bed59d024283ba236be630f0f (commit)
via 3c98a49cbdbb36065b23f5a03c695d720d30556f (commit)
via fd5985271fee3bcb6a290b6ad10525980a97ef8d (commit)
via ef73663576c54d04bd9f1dfe1cdf587515e5cc71 (commit)
from 3ce5e1304bd77eb167f856a2a163038f01f452c8 (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 26b9f9090073c896762af3125af54958e153f8f2
Merge: 3ce5e1304bd77eb167f856a2a163038f01f452c8
96ec2c9c65468b1404865371d19342d6badb0be9
Author: Neil Jerram <address@hidden>
Date: Sat Apr 10 13:32:42 2010 +0100
Merge branch 'master' into wip-manual-2
Conflicts:
doc/ref/api-procedures.texi
doc/ref/misc-modules.texi
(Caused by me removing address@hidden' from a couple of sections that have
been modified
by others.)
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 8 +
.gitignore | 8 +
GNUmakefile | 2 +-
GUILE-VERSION | 6 +-
HACKING | 5 +-
Makefile.am | 11 +-
NEWS | 669 +-
README | 38 +-
THANKS | 7 +
benchmark-suite/Makefile.am | 3 +-
benchmark-suite/benchmarks/vlists.bm | 103 +
build-aux/announce-gen | 2 +-
build-aux/arg-nonnull.h | 2 +-
build-aux/c++defs.h | 233 +
build-aux/config.rpath | 2 +-
build-aux/gendocs.sh | 20 +-
build-aux/gitlog-to-changelog | 2 +-
build-aux/gnu-web-doc-update | 2 +-
build-aux/gnupload | 17 +-
build-aux/link-warning.h | 45 -
build-aux/unused-parameter.h | 36 +
build-aux/useless-if-before-free | 2 +-
build-aux/vc-list-files | 6 +-
build-aux/warn-on-use.h | 92 +
configure.ac | 65 +-
doc/Makefile.am | 4 +-
doc/maint/guile.texi | 109 +-
doc/mbapi.texi | 987 --
doc/mltext.texi | 146 -
doc/ref/Makefile.am | 34 +-
doc/ref/api-compound.texi | 828 +-
doc/ref/api-control.texi | 361 +-
doc/ref/api-data.texi | 461 +-
doc/ref/api-debug.texi | 322 +-
doc/ref/api-evaluation.texi | 61 +-
doc/ref/api-foreign.texi | 831 ++
doc/ref/api-i18n.texi | 12 +
doc/ref/api-io.texi | 32 +-
doc/ref/api-lalr.texi | 36 +
doc/ref/api-macros.texi | 878 ++
doc/ref/api-modules.texi | 857 +-
doc/ref/api-options.texi | 6 +-
doc/ref/api-procedures.texi | 300 +-
doc/ref/api-undocumented.texi | 4 +-
doc/ref/data-rep.texi | 789 +-
doc/ref/guile.texi | 40 +-
doc/ref/history.texi | 47 +-
doc/ref/intro.texi | 5 +-
doc/ref/libguile-concepts.texi | 35 +-
doc/ref/libguile-linking.texi | 6 +-
doc/ref/libguile-smobs.texi | 7 +-
doc/ref/make-texinfo.scm | 28 +
doc/ref/misc-modules.texi | 84 +-
doc/ref/new-docstrings.texi | 271 +
doc/ref/posix.texi | 194 +-
doc/ref/srfi-modules.texi | 537 +-
doc/ref/standard-library.am | 2 +
doc/ref/standard-library.scm | 48 +
doc/ref/vm.texi | 164 +-
doc/tutorial/ChangeLog-2008 | 54 -
doc/tutorial/ChangeLog-guile-doc-tutorial | 16 -
doc/tutorial/Makefile.am | 26 -
doc/tutorial/guile-tut.texi | 1373 --
guile-readline/Makefile.am | 7 +-
lib/Makefile.am | 256 +-
lib/alignof.h | 2 +-
lib/alloca.in.h | 4 +-
lib/arpa_inet.in.h | 29 +-
lib/asnprintf.c | 2 +-
lib/byteswap.in.h | 2 +-
lib/c-ctype.c | 2 +-
lib/c-ctype.h | 2 +-
lib/c-strcase.h | 3 +-
lib/c-strcasecmp.c | 2 +-
lib/c-strcaseeq.h | 2 +-
lib/c-strncasecmp.c | 2 +-
lib/canonicalize-lgpl.c | 2 +-
lib/config.charset | 2 +-
lib/duplocale.c | 2 +-
lib/errno.in.h | 2 +-
lib/float+.h | 2 +-
lib/float.in.h | 2 +-
lib/flock.c | 2 +-
lib/full-read.c | 2 +-
lib/full-read.h | 2 +-
lib/full-write.c | 3 +-
lib/full-write.h | 2 +-
lib/gai_strerror.c | 76 +
lib/getaddrinfo.c | 438 +
lib/gettext.h | 3 +-
lib/iconv.c | 2 +-
lib/iconv.in.h | 59 +-
lib/iconv_close.c | 2 +-
lib/iconv_open.c | 2 +-
lib/iconveh.h | 2 +-
lib/inet_ntop.c | 2 +-
lib/inet_pton.c | 2 +-
lib/localcharset.c | 2 +-
lib/localcharset.h | 2 +-
lib/locale.in.h | 28 +-
lib/lstat.c | 3 +-
lib/malloc.c | 2 +-
lib/malloca.c | 2 +-
lib/malloca.h | 2 +-
lib/mbrlen.c | 2 +-
lib/mbrtowc.c | 2 +-
lib/mbsinit.c | 2 +-
lib/memchr.c | 2 +-
lib/netdb.in.h | 192 +
lib/netinet_in.in.h | 2 +-
lib/pathmax.h | 3 +-
lib/printf-args.c | 2 +-
lib/printf-args.h | 3 +-
lib/printf-parse.c | 2 +-
lib/printf-parse.h | 3 +-
lib/putenv.c | 4 +-
lib/readlink.c | 6 +-
lib/ref-add.sin | 2 +-
lib/ref-del.sin | 2 +-
lib/safe-read.c | 4 +-
lib/safe-read.h | 2 +-
lib/safe-write.c | 2 +-
lib/safe-write.h | 2 +-
lib/size_max.h | 2 +-
lib/snprintf.c | 72 +
lib/stat.c | 2 +-
lib/stdarg.in.h | 2 +-
lib/stdbool.in.h | 2 +-
lib/stddef.in.h | 2 +-
lib/stdint.in.h | 2 +-
lib/stdio-write.c | 2 +-
lib/stdio.in.h | 1142 +-
lib/stdlib.in.h | 503 +-
lib/strcasecmp.c | 2 +-
lib/streq.h | 2 +-
lib/strftime.c | 3 +-
lib/strftime.h | 2 +-
lib/striconveh.c | 2 +-
lib/striconveh.h | 2 +-
lib/string.in.h | 662 +-
lib/strings.in.h | 37 +-
lib/strncasecmp.c | 2 +-
lib/sys_file.in.h | 30 +-
lib/sys_socket.in.h | 663 +-
lib/sys_stat.in.h | 309 +-
lib/time.in.h | 131 +-
lib/time_r.c | 2 +-
lib/unistd.in.h | 1002 +-
lib/unistr.h | 14 +-
lib/unistr/u8-mbtouc-aux.c | 2 +-
lib/unistr/u8-mbtouc-unsafe-aux.c | 2 +-
lib/unistr/u8-mbtouc-unsafe.c | 2 +-
lib/unistr/u8-mbtouc.c | 2 +-
lib/unistr/u8-mbtoucr.c | 2 +-
lib/unistr/u8-prev.c | 2 +-
lib/unistr/u8-uctomb-aux.c | 2 +-
lib/unistr/u8-uctomb.c | 2 +-
lib/unitypes.h | 2 +-
lib/vasnprintf.c | 22 +-
lib/vasnprintf.h | 17 +-
lib/verify.h | 2 +-
lib/version-etc-fsf.c | 2 +-
lib/version-etc.c | 4 +-
lib/version-etc.h | 2 +-
lib/vsnprintf.c | 2 +-
lib/wchar.in.h | 342 +-
lib/write.c | 2 +-
lib/xsize.h | 2 +-
libguile.h | 3 +-
libguile/Makefile.am | 50 +-
libguile/_scm.h | 6 +-
libguile/alist.c | 3 +-
libguile/array-map.c | 151 +-
libguile/array-map.h | 3 +-
libguile/arrays.c | 181 +-
libguile/arrays.h | 10 +-
libguile/async.c | 3 +-
libguile/backtrace.c | 3 +-
libguile/boolean.c | 28 +-
libguile/boolean.h | 40 +-
libguile/bytevectors.c | 41 +-
libguile/bytevectors.h | 4 +
libguile/c-tokenize.lex | 14 -
libguile/chars.c | 89 +-
libguile/chars.h | 3 +
libguile/continuations.c | 245 +-
libguile/continuations.h | 31 +-
libguile/control.c | 282 +
libguile/control.h | 60 +
libguile/debug.c | 31 +-
libguile/debug.h | 3 +-
libguile/deprecated.c | 423 +-
libguile/deprecated.h | 47 +-
libguile/dynl.c | 151 +-
libguile/dynl.h | 4 +-
libguile/dynwind.c | 109 +-
libguile/eq.c | 8 +-
libguile/eval.c | 120 +-
libguile/eval.h | 1 +
libguile/evalext.c | 10 +-
libguile/filesys.c | 20 +-
libguile/fluids.c | 309 +-
libguile/fluids.h | 30 +-
libguile/foreign.c | 1115 ++
libguile/foreign.h | 131 +
libguile/fports.c | 37 +-
libguile/frames.c | 45 +-
libguile/frames.h | 11 +-
libguile/gc-malloc.c | 29 +-
libguile/gc.c | 30 +-
libguile/gc.h | 3 +-
libguile/gen-scmconfig.c | 13 -
libguile/gen-scmconfig.h.in | 2 -
libguile/generalized-arrays.c | 28 +-
libguile/generalized-vectors.c | 7 +-
libguile/goops.c | 79 +-
libguile/goops.h | 1 -
libguile/gsubr.c | 1010 +-
libguile/gsubr.h | 38 +-
libguile/hash.c | 5 +-
libguile/hooks.c | 11 +
libguile/hooks.h | 3 +-
libguile/i18n.c | 262 +-
libguile/i18n.h | 2 +
libguile/init.c | 37 +-
libguile/inline.h | 41 +-
libguile/instructions.c | 8 +-
libguile/lang.c | 55 -
libguile/lang.h | 50 -
libguile/list.c | 3 +-
libguile/load.c | 27 +-
libguile/load.h | 1 +
libguile/macros.c | 297 +-
libguile/macros.h | 40 +-
libguile/memoize.c | 186 +-
libguile/memoize.h | 10 +-
libguile/modules.c | 27 +-
libguile/net_db.c | 297 +-
libguile/net_db.h | 4 +-
libguile/objcodes.c | 63 +-
libguile/objcodes.h | 24 +-
libguile/options.c | 3 +-
libguile/pairs.h | 23 +-
libguile/ports.c | 4 +-
libguile/posix.c | 99 +-
libguile/posix.h | 4 +-
libguile/print.c | 147 +-
libguile/private-options.h | 11 +-
libguile/procprop.c | 52 +-
libguile/procs.c | 72 +-
libguile/procs.h | 28 -
libguile/programs.c | 93 +-
libguile/programs.h | 19 +-
libguile/promises.c | 3 +-
libguile/read.c | 436 +-
libguile/script.c | 35 +-
libguile/smob.c | 515 +-
libguile/smob.h | 18 +-
libguile/snarf.h | 118 +-
libguile/sort.c | 3 +-
libguile/srfi-13.c | 2 +-
libguile/srfi-14.i.c | 922 +-
libguile/srfi-4.c | 1032 +--
libguile/srfi-4.h | 3 +
libguile/srfi-4.i.c | 207 -
libguile/stackchk.h | 8 +-
libguile/stacks.c | 215 +-
libguile/strings.c | 246 +-
libguile/strings.h | 5 +
libguile/strorder.c | 12 +-
libguile/strports.c | 84 +-
libguile/strports.h | 4 +-
libguile/struct.c | 400 +-
libguile/struct.h | 42 +-
libguile/tags.h | 35 +-
libguile/throw.c | 687 +-
libguile/throw.h | 7 -
libguile/trees.c | 3 +-
libguile/unidata_to_charset.pl | 13 +-
libguile/vectors.c | 14 +-
libguile/vectors.h | 2 +-
libguile/version.c | 11 +-
libguile/version.h.in | 3 +-
libguile/vm-bootstrap.h | 30 -
libguile/vm-engine.c | 50 +-
libguile/vm-engine.h | 57 +-
libguile/vm-i-loader.c | 18 +-
libguile/vm-i-scheme.c | 506 +-
libguile/vm-i-system.c | 700 +-
libguile/vm.c | 389 +-
libguile/vm.h | 40 +-
libguile/weaks.c | 3 +-
m4/00gnulib.m4 | 2 +-
m4/alloca.m4 | 3 +-
m4/arpa_inet_h.m4 | 23 +-
m4/autobuild.m4 | 3 +-
m4/byteswap.m4 | 2 +-
m4/canonicalize.m4 | 2 +-
m4/codeset.m4 | 2 +-
m4/dos.m4 | 2 +-
m4/double-slash-root.m4 | 2 +-
m4/duplocale.m4 | 6 +-
m4/eealloc.m4 | 2 +-
m4/environ.m4 | 2 +-
m4/errno_h.m4 | 2 +-
m4/extensions.m4 | 18 +-
m4/fcntl-o.m4 | 81 +
m4/fcntl_h.m4 | 108 -
m4/float_h.m4 | 2 +-
m4/flock.m4 | 2 +-
m4/fpieee.m4 | 2 +-
m4/func.m4 | 20 +
m4/getaddrinfo.m4 | 173 +
m4/glibc21.m4 | 2 +-
m4/gnulib-cache.m4 | 6 +-
m4/gnulib-common.m4 | 38 +-
m4/gnulib-comp.m4 | 245 +-
m4/gnulib-tool.m4 | 2 +-
m4/hostent.m4 | 45 +
m4/iconv.m4 | 25 +-
m4/iconv_h.m4 | 2 +-
m4/iconv_open.m4 | 6 +-
m4/include_next.m4 | 2 +-
m4/inet_ntop.m4 | 2 +-
m4/inet_pton.m4 | 2 +-
m4/inline.m4 | 2 +-
m4/intmax_t.m4 | 3 +-
m4/inttypes_h.m4 | 2 +-
m4/ld-version-script.m4 | 2 +-
m4/lib-ld.m4 | 2 +-
m4/lib-link.m4 | 2 +-
m4/lib-prefix.m4 | 2 +-
m4/libunistring.m4 | 2 +-
m4/localcharset.m4 | 2 +-
m4/locale-fr.m4 | 2 +-
m4/locale-ja.m4 | 2 +-
m4/locale-zh.m4 | 2 +-
m4/locale_h.m4 | 24 +-
m4/longlong.m4 | 2 +-
m4/lstat.m4 | 2 +-
m4/malloc.m4 | 2 +-
m4/malloca.m4 | 3 +-
m4/mbrlen.m4 | 2 +-
m4/mbrtowc.m4 | 3 +-
m4/mbsinit.m4 | 2 +-
m4/mbstate_t.m4 | 2 +-
m4/memchr.m4 | 2 +-
m4/mmap-anon.m4 | 2 +-
m4/multiarch.m4 | 2 +-
m4/netdb_h.m4 | 46 +
m4/netinet_in_h.m4 | 2 +-
m4/pathmax.m4 | 3 +-
m4/printf.m4 | 2 +-
m4/putenv.m4 | 2 +-
m4/readlink.m4 | 6 +-
m4/safe-read.m4 | 3 +-
m4/safe-write.m4 | 2 +-
m4/servent.m4 | 47 +
m4/size_max.m4 | 2 +-
m4/snprintf.m4 | 40 +
m4/socklen.m4 | 2 +-
m4/sockpfaf.m4 | 2 +-
m4/ssize_t.m4 | 2 +-
m4/stat.m4 | 6 +-
m4/stdarg.m4 | 2 +-
m4/stdbool.m4 | 2 +-
m4/stddef_h.m4 | 2 +-
m4/stdint.m4 | 2 +-
m4/stdint_h.m4 | 2 +-
m4/stdio_h.m4 | 17 +-
m4/stdlib_h.m4 | 20 +-
m4/strcase.m4 | 2 +-
m4/strftime.m4 | 3 +-
m4/string_h.m4 | 16 +-
m4/strings_h.m4 | 8 +-
m4/sys_file_h.m4 | 15 +-
m4/sys_socket_h.m4 | 28 +-
m4/sys_stat_h.m4 | 11 +-
m4/time_h.m4 | 40 +-
m4/time_r.m4 | 3 +-
m4/tm_gmtoff.m4 | 2 +-
m4/unistd_h.m4 | 27 +-
m4/vasnprintf.m4 | 2 +-
m4/version-etc.m4 | 2 +-
m4/visibility.m4 | 2 +-
m4/vsnprintf.m4 | 2 +-
m4/warn-on-use.m4 | 45 +
m4/warnings.m4 | 12 +-
m4/wchar.m4 | 105 -
m4/wchar_h.m4 | 152 +
m4/wchar_t.m4 | 2 +-
m4/wint_t.m4 | 2 +-
m4/write.m4 | 2 +-
m4/xsize.m4 | 2 +-
maint.mk | 133 +-
meta/Makefile.am | 2 +-
meta/guile-2.0-uninstalled.pc.in | 2 +-
meta/guile-2.0.pc.in | 5 +-
meta/guile-tools.in | 3 +-
module/Makefile.am | 88 +-
module/ice-9/boot-9.scm | 2076 ++--
module/ice-9/compile-psyntax.scm | 2 +-
module/ice-9/control.scm | 56 +
module/ice-9/curried-definitions.scm | 41 +
module/ice-9/debugging/traps.scm | 7 +-
module/ice-9/deprecated.scm | 38 +-
module/ice-9/eval.scm | 137 +-
module/ice-9/format.scm | 33 +-
module/ice-9/i18n.scm | 18 +-
module/ice-9/networking.scm | 9 +-
module/ice-9/optargs.scm | 33 +-
module/ice-9/posix.scm | 3 +
module/ice-9/pretty-print.scm | 187 +-
module/ice-9/psyntax-pp.scm |17530 ++++++++++++-----------
module/ice-9/psyntax.scm | 279 +-
module/ice-9/r4rs.scm | 68 +-
module/ice-9/runq.scm | 3 +-
module/ice-9/session.scm | 4 +-
module/ice-9/syncase.scm | 10 +-
module/ice-9/vlist.scm | 489 +
module/language/assembly.scm | 8 +-
module/language/assembly/compile-bytecode.scm | 125 +-
module/language/assembly/decompile-bytecode.scm | 4 +-
module/language/assembly/disassemble.scm | 23 +-
module/language/ecmascript/array.scm | 8 +-
module/language/ecmascript/parse-lalr.scm | 1731 ---
module/language/ecmascript/parse.scm | 522 +-
module/language/ecmascript/tokenize.scm | 60 +-
module/language/elisp/README | 2 +-
module/language/elisp/compile-tree-il.scm | 4 +-
module/language/elisp/runtime.scm | 7 +-
module/language/elisp/runtime/macro-slot.scm | 45 +-
module/language/glil.scm | 13 +-
module/language/glil/compile-assembly.scm | 46 +-
module/language/glil/decompile-assembly.scm | 8 +-
module/language/objcode/spec.scm | 7 +-
module/language/scheme/compile-tree-il.scm | 4 +-
module/language/tree-il.scm | 179 +-
module/language/tree-il/analyze.scm | 515 +-
module/language/tree-il/compile-glil.scm | 276 +-
module/language/tree-il/inline.scm | 52 +-
module/language/tree-il/primitives.scm | 202 +-
module/rnrs/bytevector.scm | 13 +-
module/rnrs/io/ports.scm | 13 +-
module/scripts/compile.scm | 8 +-
module/scripts/snarf-check-and-output-texi.scm | 11 +
module/srfi/srfi-18.scm | 3 +-
module/srfi/srfi-19.scm | 20 +-
module/srfi/srfi-35.scm | 11 +-
module/srfi/srfi-4.scm | 149 +-
module/srfi/srfi-4/gnu.scm | 66 +-
module/srfi/srfi-88.scm | 6 +-
module/srfi/srfi-9.scm | 5 +-
module/statprof.scm | 704 +
module/sxml/apply-templates.scm | 102 +
module/sxml/fold.scm | 250 +
module/sxml/simple.scm | 169 +
module/sxml/ssax.scm | 246 +
module/sxml/ssax/input-parse.scm | 180 +
module/sxml/transform.scm | 298 +
module/sxml/upstream/COPYING.SSAX | 2 +
module/sxml/upstream/SSAX.scm | 3212 +++++
module/sxml/upstream/SXML-tree-trans.scm | 249 +
module/sxml/upstream/SXPath-old.scm | 1216 ++
module/sxml/upstream/assert.scm | 35 +
module/sxml/upstream/input-parse.scm | 326 +
module/sxml/xpath.scm | 493 +
module/system/base/compile.scm | 13 +-
module/system/base/lalr.scm | 45 +
module/system/base/lalr.upstream.scm | 2077 +++
module/system/base/message.scm | 8 +-
module/system/base/pmatch.scm | 45 +-
module/system/foreign.scm | 106 +
module/system/repl/command.scm | 122 +-
module/system/repl/common.scm | 97 +-
module/system/repl/repl.scm | 2 +-
module/system/vm/debug.scm | 436 +-
module/system/vm/frame.scm | 276 +-
module/system/vm/inspect.scm | 190 +
module/system/vm/instruction.scm | 5 +-
module/system/vm/objcode.scm | 5 +-
module/system/vm/program.scm | 48 +-
module/system/vm/trace.scm | 135 +-
module/system/vm/vm.scm | 11 +-
module/texinfo.scm | 1215 ++
module/texinfo/docbook.scm | 233 +
module/texinfo/html.scm | 257 +
module/texinfo/indexing.scm | 75 +
module/texinfo/plain-text.scm | 316 +
module/texinfo/reflection.scm | 581 +
module/texinfo/serialize.scm | 263 +
module/texinfo/string-utils.scm | 400 +
srfi/Makefile.am | 13 +-
srfi/srfi-1.c | 3 +-
test-suite/Makefile.am | 67 +-
test-suite/guile-test | 9 +-
test-suite/lalr/common-test.scm | 63 +
test-suite/lalr/glr-test.scm | 88 +
test-suite/lalr/run-guile-test.sh | 30 +
test-suite/lalr/test-glr-associativity.scm | 102 +
test-suite/lalr/test-glr-basics-01.scm | 35 +
test-suite/lalr/test-glr-basics-02.scm | 30 +
test-suite/lalr/test-glr-basics-03.scm | 37 +
test-suite/lalr/test-glr-basics-04.scm | 43 +
test-suite/lalr/test-glr-basics-05.scm | 40 +
test-suite/lalr/test-glr-script-expression.scm | 125 +
test-suite/lalr/test-glr-single-expressions.scm | 60 +
test-suite/lalr/test-lr-associativity-01.scm | 91 +
test-suite/lalr/test-lr-associativity-02.scm | 91 +
test-suite/lalr/test-lr-associativity-03.scm | 85 +
test-suite/lalr/test-lr-associativity-04.scm | 83 +
test-suite/lalr/test-lr-basics-01.scm | 38 +
test-suite/lalr/test-lr-basics-02.scm | 33 +
test-suite/lalr/test-lr-basics-03.scm | 36 +
test-suite/lalr/test-lr-basics-04.scm | 31 +
test-suite/lalr/test-lr-basics-05.scm | 36 +
test-suite/lalr/test-lr-error-recovery-01.scm | 145 +
test-suite/lalr/test-lr-error-recovery-02.scm | 51 +
test-suite/lalr/test-lr-no-clause.scm | 40 +
test-suite/lalr/test-lr-script-expression.scm | 119 +
test-suite/lalr/test-lr-single-expressions.scm | 59 +
test-suite/lib.scm | 78 +-
test-suite/standalone/Makefile.am | 38 +-
test-suite/standalone/test-ffi | 199 +
test-suite/standalone/test-ffi-lib.c | 215 +
test-suite/standalone/test-unwind.c | 10 +-
test-suite/tests/00-initial-env.test | 48 +
test-suite/tests/arrays.test | 608 +
test-suite/tests/asm-to-bytecode.test | 36 +-
test-suite/tests/bit-operations.test | 6 +-
test-suite/tests/bytevectors.test | 76 +-
test-suite/tests/c-api/Makefile | 16 -
test-suite/tests/c-api/README | 11 -
test-suite/tests/c-api/strings.c | 74 -
test-suite/tests/c-api/testlib.c | 121 -
test-suite/tests/c-api/testlib.h | 28 -
test-suite/tests/chars.test | 31 +-
test-suite/tests/control.test | 227 +
test-suite/tests/curried-definitions.test | 84 +
test-suite/tests/ecmascript.test | 74 +
test-suite/tests/elisp-compiler.test | 4 +-
test-suite/tests/elisp.test | 600 +-
test-suite/tests/encoding-escapes.test | 9 +-
test-suite/tests/encoding-iso88591.test | 7 +-
test-suite/tests/encoding-iso88597.test | 7 +-
test-suite/tests/encoding-utf8.test | 5 +-
test-suite/tests/eval.test | 34 +-
test-suite/tests/exceptions.test | 153 +-
test-suite/tests/fluids.test | 93 +
test-suite/tests/foreign.test | 57 +
test-suite/tests/hooks.test | 5 +-
test-suite/tests/i18n.test | 13 +
test-suite/tests/keywords.test | 8 +-
test-suite/tests/load.test | 18 +-
test-suite/tests/modules.test | 12 +-
test-suite/tests/net-db.test | 98 +
test-suite/tests/numbers.test | 13 +-
test-suite/tests/optargs.test | 42 +-
test-suite/tests/ports.test | 47 +-
test-suite/tests/posix.test | 21 +-
test-suite/tests/print.test | 54 +
test-suite/tests/procprop.test | 11 +-
test-suite/tests/r6rs-ports.test | 31 +-
test-suite/tests/reader.test | 143 +-
test-suite/tests/regexp.test | 87 +-
test-suite/tests/socket.test | 12 +-
test-suite/tests/srfi-13.test | 19 +
test-suite/tests/srfi-14.test | 18 +-
test-suite/tests/srfi-31.test | 6 +-
test-suite/tests/srfi-35.test | 11 +-
test-suite/tests/srfi-4.test | 102 +-
test-suite/tests/srfi-88.test | 11 +-
test-suite/tests/srfi-9.test | 18 +-
test-suite/tests/statprof.test | 111 +
test-suite/tests/strings.test | 48 +-
test-suite/tests/structs.test | 37 +-
test-suite/tests/sxml.fold.test | 210 +
test-suite/tests/sxml.ssax.test | 140 +
test-suite/tests/sxml.transform.test | 99 +
test-suite/tests/sxml.xpath.test | 698 +
test-suite/tests/syncase.test | 41 +-
test-suite/tests/texinfo.docbook.test | 32 +
test-suite/tests/texinfo.serialize.test | 185 +
test-suite/tests/texinfo.string-utils.test | 118 +
test-suite/tests/texinfo.test | 404 +
test-suite/tests/tree-il.test | 127 +-
test-suite/tests/unif.test | 563 -
test-suite/tests/version.test | 7 +-
test-suite/tests/vlist.test | 303 +
testsuite/t-records.scm | 3 +-
590 files changed, 53944 insertions(+), 27646 deletions(-)
create mode 100644 .dir-locals.el
create mode 100644 benchmark-suite/benchmarks/vlists.bm
create mode 100644 build-aux/c++defs.h
mode change 100644 => 100755 build-aux/gendocs.sh
delete mode 100644 build-aux/link-warning.h
create mode 100644 build-aux/unused-parameter.h
create mode 100644 build-aux/warn-on-use.h
delete mode 100644 doc/mbapi.texi
delete mode 100644 doc/mltext.texi
create mode 100644 doc/ref/api-foreign.texi
create mode 100644 doc/ref/api-lalr.texi
create mode 100644 doc/ref/api-macros.texi
create mode 100644 doc/ref/make-texinfo.scm
create mode 100644 doc/ref/standard-library.am
create mode 100644 doc/ref/standard-library.scm
delete mode 100644 doc/tutorial/ChangeLog-2008
delete mode 100644 doc/tutorial/ChangeLog-guile-doc-tutorial
delete mode 100644 doc/tutorial/Makefile.am
delete mode 100644 doc/tutorial/guile-tut.texi
create mode 100644 lib/gai_strerror.c
create mode 100644 lib/getaddrinfo.c
create mode 100644 lib/netdb.in.h
create mode 100644 lib/snprintf.c
create mode 100644 libguile/control.c
create mode 100644 libguile/control.h
create mode 100644 libguile/foreign.c
create mode 100644 libguile/foreign.h
delete mode 100644 libguile/lang.c
delete mode 100644 libguile/lang.h
delete mode 100644 libguile/srfi-4.i.c
delete mode 100644 libguile/vm-bootstrap.h
create mode 100644 m4/fcntl-o.m4
delete mode 100644 m4/fcntl_h.m4
create mode 100644 m4/func.m4
create mode 100644 m4/getaddrinfo.m4
create mode 100644 m4/hostent.m4
create mode 100644 m4/netdb_h.m4
create mode 100644 m4/servent.m4
create mode 100644 m4/snprintf.m4
create mode 100644 m4/warn-on-use.m4
delete mode 100644 m4/wchar.m4
create mode 100644 m4/wchar_h.m4
create mode 100644 module/ice-9/control.scm
create mode 100644 module/ice-9/curried-definitions.scm
create mode 100644 module/ice-9/vlist.scm
delete mode 100644 module/language/ecmascript/parse-lalr.scm
create mode 100644 module/statprof.scm
create mode 100644 module/sxml/apply-templates.scm
create mode 100644 module/sxml/fold.scm
create mode 100644 module/sxml/simple.scm
create mode 100644 module/sxml/ssax.scm
create mode 100644 module/sxml/ssax/input-parse.scm
create mode 100644 module/sxml/transform.scm
create mode 100644 module/sxml/upstream/COPYING.SSAX
create mode 100644 module/sxml/upstream/SSAX.scm
create mode 100644 module/sxml/upstream/SXML-tree-trans.scm
create mode 100644 module/sxml/upstream/SXPath-old.scm
create mode 100644 module/sxml/upstream/assert.scm
create mode 100644 module/sxml/upstream/input-parse.scm
create mode 100644 module/sxml/xpath.scm
create mode 100644 module/system/base/lalr.scm
create mode 100755 module/system/base/lalr.upstream.scm
create mode 100644 module/system/foreign.scm
create mode 100644 module/system/vm/inspect.scm
create mode 100644 module/texinfo.scm
create mode 100644 module/texinfo/docbook.scm
create mode 100644 module/texinfo/html.scm
create mode 100644 module/texinfo/indexing.scm
create mode 100644 module/texinfo/plain-text.scm
create mode 100644 module/texinfo/reflection.scm
create mode 100644 module/texinfo/serialize.scm
create mode 100644 module/texinfo/string-utils.scm
create mode 100644 test-suite/lalr/common-test.scm
create mode 100644 test-suite/lalr/glr-test.scm
create mode 100644 test-suite/lalr/run-guile-test.sh
create mode 100644 test-suite/lalr/test-glr-associativity.scm
create mode 100644 test-suite/lalr/test-glr-basics-01.scm
create mode 100644 test-suite/lalr/test-glr-basics-02.scm
create mode 100644 test-suite/lalr/test-glr-basics-03.scm
create mode 100644 test-suite/lalr/test-glr-basics-04.scm
create mode 100644 test-suite/lalr/test-glr-basics-05.scm
create mode 100644 test-suite/lalr/test-glr-script-expression.scm
create mode 100644 test-suite/lalr/test-glr-single-expressions.scm
create mode 100644 test-suite/lalr/test-lr-associativity-01.scm
create mode 100644 test-suite/lalr/test-lr-associativity-02.scm
create mode 100644 test-suite/lalr/test-lr-associativity-03.scm
create mode 100644 test-suite/lalr/test-lr-associativity-04.scm
create mode 100644 test-suite/lalr/test-lr-basics-01.scm
create mode 100644 test-suite/lalr/test-lr-basics-02.scm
create mode 100644 test-suite/lalr/test-lr-basics-03.scm
create mode 100644 test-suite/lalr/test-lr-basics-04.scm
create mode 100644 test-suite/lalr/test-lr-basics-05.scm
create mode 100644 test-suite/lalr/test-lr-error-recovery-01.scm
create mode 100644 test-suite/lalr/test-lr-error-recovery-02.scm
create mode 100644 test-suite/lalr/test-lr-no-clause.scm
create mode 100644 test-suite/lalr/test-lr-script-expression.scm
create mode 100644 test-suite/lalr/test-lr-single-expressions.scm
create mode 100755 test-suite/standalone/test-ffi
create mode 100644 test-suite/standalone/test-ffi-lib.c
create mode 100644 test-suite/tests/00-initial-env.test
create mode 100644 test-suite/tests/arrays.test
delete mode 100644 test-suite/tests/c-api/Makefile
delete mode 100644 test-suite/tests/c-api/README
delete mode 100644 test-suite/tests/c-api/strings.c
delete mode 100644 test-suite/tests/c-api/testlib.c
delete mode 100644 test-suite/tests/c-api/testlib.h
create mode 100644 test-suite/tests/control.test
create mode 100644 test-suite/tests/curried-definitions.test
create mode 100644 test-suite/tests/ecmascript.test
create mode 100644 test-suite/tests/fluids.test
create mode 100644 test-suite/tests/foreign.test
create mode 100644 test-suite/tests/net-db.test
create mode 100644 test-suite/tests/print.test
create mode 100644 test-suite/tests/statprof.test
create mode 100644 test-suite/tests/sxml.fold.test
create mode 100644 test-suite/tests/sxml.ssax.test
create mode 100644 test-suite/tests/sxml.transform.test
create mode 100644 test-suite/tests/sxml.xpath.test
create mode 100644 test-suite/tests/texinfo.docbook.test
create mode 100644 test-suite/tests/texinfo.serialize.test
create mode 100644 test-suite/tests/texinfo.string-utils.test
create mode 100644 test-suite/tests/texinfo.test
delete mode 100644 test-suite/tests/unif.test
create mode 100644 test-suite/tests/vlist.test
diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..ca0c337
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,8 @@
+;; Per-directory local variables for GNU Emacs 23 and later.
+
+((nil . ((fill-column . 80)
+ (tab-width . 8)))
+ (c-mode . ((c-file-style . "gnu")))
+ (scheme-mode . ((indent-tabs-mode . nil)))
+ (emacs-lisp-mode . ((indent-tabs-mode . nil)))
+ (texinfo-mode . ((indent-tabs-mode . nil))))
diff --git a/.gitignore b/.gitignore
index 3db7382..b07b196 100644
--- a/.gitignore
+++ b/.gitignore
@@ -111,6 +111,8 @@ INSTALL
/lib/arpa/inet.h
/lib/stdio.h
/lib/sys/stat.h
+/lib/arg-nonnull.h
+/lib/link-warning.h
/GPATH
/GRTAGS
/GSYMS
@@ -119,3 +121,9 @@ INSTALL
/meta/guile-config
/lib/locale.h
/module/ice-9/eval.go.stamp
+/doc/ref/standard-library.texi
+/doc/ref/standard-libraryscmfiles
+/lib/wchar.h
+/lib/sys/socket.h
+/lib/warn-on-use.h
+/lib/unused-parameter.h
diff --git a/GNUmakefile b/GNUmakefile
index 33eb3aa..40ccc06 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -5,7 +5,7 @@
# It is necessary if you want to build targets usually of interest
# only to the maintainer.
-# Copyright (C) 2001, 2003, 2006-2009 Free Software Foundation, Inc.
+# Copyright (C) 2001, 2003, 2006-2010 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
diff --git a/GUILE-VERSION b/GUILE-VERSION
index 4a4e201..53c1c05 100644
--- a/GUILE-VERSION
+++ b/GUILE-VERSION
@@ -2,10 +2,10 @@
GUILE_MAJOR_VERSION=1
GUILE_MINOR_VERSION=9
-GUILE_MICRO_VERSION=6
+GUILE_MICRO_VERSION=9
-GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}
-GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}
+GUILE_EFFECTIVE_VERSION=2.0
+GUILE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}.${GUILE_MICRO_VERSION}
# All of the shared lib versioning info. Right now, for this to work
# properly, you'll also need to add AC_SUBST calls to the right place
diff --git a/HACKING b/HACKING
index ffe04a8..7463fe5 100644
--- a/HACKING
+++ b/HACKING
@@ -230,7 +230,7 @@ When deprecating a definition, always follow this procedure:
- Write commit messages for functions written in C using the
functions' C names, and write entries for functions written in Scheme
-using the functions' Scheme names. For example,
+using the functions' Scheme names. For example,
* foo.c: Moved scm_procedure_documentation from eval.c.
@@ -278,6 +278,9 @@ the list of years in the copyright notice at the top of the
file.
- When you get bug reports or patches from people, be sure to list
them in THANKS.
+- Do not introduce trailing whitespace (and feel free to clean it up
+opportunistically, that is, if doing so is part of some other change).
+The goal is to reduce (and over time, eliminate) spurious diffs.
Naming conventions =================================================
diff --git a/Makefile.am b/Makefile.am
index c51a61b..3705762 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 2008, 2009,
2010 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -25,10 +25,11 @@
AUTOMAKE_OPTIONS = 1.10
SUBDIRS = lib meta libguile guile-readline emacs \
- srfi doc examples test-suite benchmark-suite am \
- module testsuite
+ srfi examples test-suite benchmark-suite am \
+ module doc testsuite
-include_HEADERS = libguile.h
+libguileincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)
+libguileinclude_HEADERS = libguile.h
EXTRA_DIST = LICENSE HACKING GUILE-VERSION \
m4/ChangeLog-2008 \
@@ -47,6 +48,8 @@ dist-hook: gen-ChangeLog
clean-local:
rm -rf cache/
+CONFIG_STATUS_DEPENDENCIES = GUILE-VERSION
+
gen_start_rev = 61db429e251bfd2f75cb4632972e0238056eb24b
.PHONY: gen-ChangeLog
gen-ChangeLog:
diff --git a/NEWS b/NEWS
index 662b3a9..efa8e1a 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,5 @@
Guile NEWS --- history of user-visible changes.
-Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
See the end for copying conditions.
Please send Guile bug reports to address@hidden
@@ -8,214 +8,85 @@ Please send Guile bug reports to address@hidden
(During the 1.9 series, we will keep an incremental NEWS for the latest
prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
-Changes in 1.9.6 (since the 1.9.5 prerelease):
+Changes in 1.9.10 (since the 1.9.9 prerelease):
-** New implementation of `primitive-eval'
-
-Guile's `primitive-eval' is now implemented in Scheme. Actually there is
-still a C evaluator, used when building a fresh Guile to interpret the
-compiler, so we can compile eval.scm. Thereafter all calls to
-primitive-eval are implemented by VM-compiled code.
-
-This allows all of Guile's procedures, be they interpreted or compiled,
-to execute on the same stack, unifying multiple-value return semantics,
-providing for proper tail recursion between interpreted and compiled
-code, and simplifying debugging.
-
-As part of this change, the evaluator no longer mutates the internal
-representation of the code being evaluated in a thread-unsafe manner.
-
-There are two negative aspects of this change, however. First, Guile
-takes a lot longer to compile now. Also, there is less debugging
-information available for debugging interpreted code. We hope to improve
-both of these situations.
-
-There are many changes to the internal C evalator interface, but all
-public interfaces should be the same. See the ChangeLog for details. If
-we have inadvertantly changed an interface that you were using, please
-contact address@hidden
-
-** Elisp compiler
-
-The derelict Guile maintainers finally got around to merging Daniel
-Kraft's excellent Emacs Lisp compiler. You can now switch to Elisp at
-the repl: `,language elisp'. All kudos to Daniel, and all bugs to
address@hidden
-
-** Faster SRFI-9 record access
-
-SRFI-9 records are now implemented directly on top of Guile's structs,
-and their accessors are defined in such a way that normal call-sites
-inline to special VM opcodes, while still allowing for the general case
-(e.g. passing a record accessor to `apply').
-
-** Some VM metadata removed
-
-It used to be that the standard virtual machine counted the number of
-instructions it executed. This capability has been removed, as it was
-not very useful, and had some overhead. Also it used to try to record
-the time spent in the VM, but these calculations were borked, so we
-removed them too.
-
-** Inline memq/memv of a key in a constant list
-
-The impoverished Guile inliner is slightly less lame now that it does
-`(memv k '(foo))' => `(eq? k 'foo)'.
-
-** Rename "else" fields of <conditional> and <lambda-case>
-
-Having a field named "else" just didn't sit right with "cond", and
-everything else. So now Tree-IL's <conditional> has "consequent" and
-"alternate", and <lambda-case> has "alternate".
-
-** Allow interrupts in tail loops
-
-Tail-recursive loops that compile to tight, procedure-less jumps
-previously were uninterruptible. Now the VM handle interrupts whenever
-it jumps backwards.
-
-** Tail patterns in syntax-case
-
-Guile has pulled in some more recent changes from the psyntax portable
-syntax expander, to implement support for "tail patterns". Such patterns
-are supported by syntax-rules and syntax-case. This allows a syntax-case
-match clause to have ellipses, then a pattern at the end. For example:
-
- (define-syntax case
- (syntax-rules (else)
- ((_ val match-clause ... (else e e* ...))
- [...])))
-
-Note how there is MATCH-CLAUSE, which is ellipsized, then there is a
-tail pattern for the else clause. Thanks to Andreas Rottmann for the
-patch, and Kent Dybvig for the code.
-
-** New struct constructors that don't involve making lists
-
-`scm_c_make_struct' and `scm_c_make_structv' are new varargs and array
-constructors, respectively, for structs. You might find them useful.
-
-** Applicable struct support
-
-One may now make structs from Scheme that may be applied as procedures.
-To do so, make a struct whose vtable is `<applicable-struct-vtable>'.
-That struct will be the vtable of your applicable structs; instances of
-that new struct are assumed to have the procedure in their first slot.
-`<applicable-struct-vtable>' is like Common Lisp's
-`funcallable-standard-class'. Likewise there is
-`<applicable-struct-with-setter-vtable>', which looks for the setter in
-the second slot. This needs to be better documented.
-
-** GOOPS dispatch in scheme
-
-As an implementation detail, GOOPS dispatch is no longer implemented by
-special evaluator bytecodes, but rather directly via a Scheme function
-associated with an applicable struct. There is some VM support for the
-underlying primitives, like `class-of'.
-
-This change will in the future allow users to customize generic function
-dispatch without incurring a performance penalty, and allow us to
-implement method combinations.
-
-** Procedures-with-setters are now implemented using applicable structs
-
-From a user's perspective this doesn't mean very much. But if, for some
-odd reason, you used the SCM_PROCEDURE_WITH_SETTER_P, SCM_PROCEDURE, or
-SCM_SETTER macros, know that they're deprecated now. Also, scm_tc7_pws
-is gone.
-
-** No more `local-eval'
-
-`local-eval' used to exist so that one could evaluate code in the
-lexical context of a function. Since there is no way to get the lexical
-environment any more, as that concept has no meaning for the compiler,
-and a different meaning for the interpreter, we have removed the
-function.
-
-If you think you need `local-eval', you should probably implement your
-own metacircular evaluator. It will probably be as fast as Guile's
-anyway.
-
-** Bit twiddlings
-
-*** Remove old evaluator closures
-
-There used to be ranges of typecodes allocated to interpreted data
-structures, but that it no longer the case, given that interpreted
-procedure are now just regular VM closures. As a result, there is a
-newly free tc3, and a number of removed macros. See the ChangeLog for
-details.
-
-*** Simplify representation of primitive procedures
-
-It used to be that there were something like 12 different typecodes
-allocated to primitive procedures, each with its own calling convention.
-Now there is only one, the gsubr. This may affect user code if you were
-defining a procedure using scm_c_make_subr rather scm_c_make_gsubr. The
-solution is to switch to use scm_c_make_gsubr. This solution works well
-both with the old 1.8 and and with the current 1.9 branch.
-
-*** Some SMOB types changed to have static typecodes
+** Hygienic macros documented as the primary syntactic extension mechanism.
-Fluids, dynamic states, and hash tables used to be SMOB objects, but now
-they have statically allocated tc7 typecodes.
-
-*** Preparations for changing SMOB representation
-
-If things go right, we'll be changing the SMOB representation soon. To
-that end, we did a lot of cleanups to calls to e.g. SCM_CELL_WORD_2(x) when
-the code meant SCM_SMOB_DATA_2(x); user code will need similar changes
-in the future. Code accessing SMOBs using SCM_CELL macros was never
-correct, but until now things still worked. Users should be aware of
-such changes.
-
-** Stack refactor
+The macro documentation was finally fleshed out with some documentation
+on `syntax-case' macros, and other parts of the macro expansion process.
+See "Macros" in the manual, for details.
-It used to be that Guile had debugging frames on the C stack and on the
-VM stack. Now Guile's procedures only run on the VM stack, simplifying
-much of the C API. See the ChangeLog for details. The Scheme API has not
-been changed significantly.
+** Interactive Guile follows GNU conventions
-** New procedure, `define!'
-
-`define!' is a procedure that takes two arguments, a symbol and a value,
-and binds the value to the symbol in the current module. It's useful to
-programmatically make definitions in the current module, and is slightly
-less verbose than `module-define!'.
+As recommended by the GPL, Guile now shows a brief copyright and
+warranty disclaimer on startup, along with pointers to more information.
+On the other hand, changing languages is more concise.
-** eqv? not a generic
+** Support for arbitrary procedure metadata
-One used to be able to extend `eqv?' as a primitive-generic, but no
-more. Because `eqv?' is in the expansion of `case' (via `memv'), which
-should be able to compile to static dispatch tables, it doesn't make
-sense to allow extensions that would subvert this optimization.
+Building on its support for docstrings, Guile now supports multiple
+docstrings, adding them to the tail of a compiled procedure's
+properties. For example:
-** Deprecate trampolines
+ (define (foo)
+ "one"
+ "two"
+ 3)
+ (use-modules (system vm program))
+ (program-properties foo)
+ => ((name . foo) (documentation . "one") (documentation . "two"))
+
+Also, vectors of pairs are now treated as additional metadata entries:
+
+ (define (bar)
+ #((quz . #f) (docstring . "xyzzy"))
+ 3)
+ (use-modules (system vm program))
+ (program-properties bar)
+ => ((name . bar) (quz . #f) (docstring . "xyzzy"))
+
+This allows arbitrary literals to be embedded as metadata in a compiled
+procedure.
+
+** Better documentation infrastructure for macros
+
+It is now possible to introspect on the type of a macro, e.g.
+syntax-rules, identifier-syntax, etc, and extract information about that
+macro, such as the syntax-rules patterns or the defmacro arguments.
+`(texinfo reflection)' takes advantage of this to give better macro
+documentation.
+
+** Autocompilation for applications that use Guile as an extension language
+
+It used to be that only applications that ran Guile through the
+`scm_shell' function got the advantages of autocompilation. This has
+been changed so that all applications have autocompilation on by
+default.
-There used to be C functions `scm_trampoline_0', `scm_trampoline_1', and
-so on. The point was to do some precomputation on the type of the
-procedure, then return a specialized "call" procedure. However this
-optimization wasn't actually an optimization, so it is now deprecated.
-Just use `scm_call_0', etc instead.
+** Better integration of Lisp nil
-** Undeprecate `scm_the_root_module ()'
+`scm_is_boolean', `scm_is_false', and `scm_is_null' all return true now
+for Lisp's `nil'. This shouldn't affect any Scheme code at this point,
+but when we start to integrate more with Emacs, it is possible that we
+break code that assumes that, for example, `(not x)' implies that `x' is
+`eq?' to `#f'. This is not a common assumption. Refactoring affected
+code to rely on properties instead of identities will improve code
+correctness.
-It's useful to be able to get the root module from C without doing a
-full module lookup.
+That is to say, user code should test falsity with `if', not with `eq?'.
-** New struct slot allocation: "hidden"
+** Integration of lalr-scm, a parser generator
-A hidden slot is readable and writable, but will not be initialized by a
-call to make-struct. For example in your layout you would say "ph"
-instead of "pw". Hidden slots are useful for adding new slots to a
-vtable without breaking existing invocations to make-struct.
+Guile has included Dominique Boucher's fine `lalr-scm' parser generator
+as `(system base lalr)'. See "LALR(1) Parsing" in the manual, for more
+information.
-** New type definitions for `scm_t_intptr' and friends.
+** Documentation for the dynamic foreign function interface (FFI).
-`SCM_T_UINTPTR_MAX', `SCM_T_INTPTR_MIN', `SCM_T_INTPTR_MAX',
-`SIZEOF_SCM_T_BITS', `scm_t_intptr' and `scm_t_uintptr' are now
-available to C. Have fun!
+See "Foreign Function Interface" in the manual, for more information.
+** Unicode character set update to Unicode 5.2.
+
** And of course, the usual collection of bugfixes
Interested users should see the ChangeLog for more information.
@@ -231,6 +102,14 @@ Changes in 1.9.x (since the 1.8.x series):
** `(rnrs bytevector)', the R6RS bytevector API
** `(rnrs io ports)', a subset of the R6RS I/O port API
** `(system xref)', a cross-referencing facility (FIXME undocumented)
+** `(ice-9 vlist)', lists with constant-time random access; hash lists
+** `(system foreign)', foreign function interface
+
+** Imported statprof, SSAX, and texinfo modules from Guile-Lib
+
+The statprof statistical profiler, the SSAX XML toolkit, and the texinfo
+toolkit from Guile-Lib have been imported into Guile proper. See
+"Standard Library" in the manual for more details.
* Changes to the stand-alone interpreter
@@ -259,6 +138,31 @@ Running Guile with no arguments drops the user into the
new REPL. While
it is self-documenting to an extent, the new REPL has not yet been
documented in the manual. This will be fixed before 2.0.
+** New reader options: `square-brackets' and `r6rs-hex-escapes'
+
+The reader supports a new option (changeable via `read-options'),
+`square-brackets', which instructs it to interpret square brackets as
+parenthesis. This option is on by default.
+
+When the new `r6rs-hex-escapes' reader option is enabled, the reader
+will recognize string escape sequences as defined in R6RS.
+
+** Function profiling and tracing at the REPL
+
+The `,profile FORM' REPL meta-command can now be used to statistically
+profile execution of a form, to see which functions are taking the most
+time. See `,help profile' for more information.
+
+Similarly, `,trace FORM' traces all function applications that occur
+during the execution of `FORM'. See `,help trace' for more information.
+
+** New debugger
+
+By default, if an exception is raised at the REPL and not caught by user
+code, Guile will drop the user into a debugger. The user may request a
+backtrace, inspect frames, or continue raising the exception. Full
+documentation is available from within the debugger.
+
** New `guile-tools' commands: `compile', `disassemble'
Pass the `--help' command-line option to these commands for more
@@ -275,13 +179,59 @@ include `/path/to/lib'.
Backtraces may now be disclosed with the keyboard in addition to the
mouse.
+** Load path change: search in version-specific paths before site paths
+
+When looking for a module, Guile now searches first in Guile's
+version-specific path (the library path), *then* in the site dir. This
+allows Guile's copy of SSAX to override any Guile-Lib copy the user has
+installed. Also it should cut the number of `stat' system calls by half,
+in the common case.
+
+
* Changes to Scheme functions and syntax
+** New implementation of `primitive-eval'
+
+Guile's `primitive-eval' is now implemented in Scheme. Actually there is
+still a C evaluator, used when building a fresh Guile to interpret the
+compiler, so we can compile eval.scm. Thereafter all calls to
+primitive-eval are implemented by VM-compiled code.
+
+This allows all of Guile's procedures, be they interpreted or compiled,
+to execute on the same stack, unifying multiple-value return semantics,
+providing for proper tail recursion between interpreted and compiled
+code, and simplifying debugging.
+
+As part of this change, the evaluator no longer mutates the internal
+representation of the code being evaluated in a thread-unsafe manner.
+
+There are two negative aspects of this change, however. First, Guile
+takes a lot longer to compile now. Also, there is less debugging
+information available for debugging interpreted code. We hope to improve
+both of these situations.
+
+There are many changes to the internal C evalator interface, but all
+public interfaces should be the same. See the ChangeLog for details. If
+we have inadvertantly changed an interface that you were using, please
+contact address@hidden
+
** Procedure removed: `the-environment'
This procedure was part of the interpreter's execution model, and does
not apply to the compiler.
+** No more `local-eval'
+
+`local-eval' used to exist so that one could evaluate code in the
+lexical context of a function. Since there is no way to get the lexical
+environment any more, as that concept has no meaning for the compiler,
+and a different meaning for the interpreter, we have removed the
+function.
+
+If you think you need `local-eval', you should probably implement your
+own metacircular evaluator. It will probably be as fast as Guile's
+anyway.
+
** Files loaded with `primitive-load-path' will now be compiled
automatically.
@@ -301,13 +251,6 @@ will be created if needed.
To inhibit autocompilation, set the GUILE_AUTO_COMPILE environment
variable to 0, or pass --no-autocompile on the Guile command line.
-Note that there is currently a bug here: automatic compilation will
-sometimes be attempted when it shouldn't.
-
-For example, the old (lang elisp) modules are meant to be interpreted,
-not compiled. This bug will be fixed before 2.0. FIXME 2.0: Should say
-something here about module-transformer called for compile.
-
** Files loaded with `load' will now be compiled automatically.
As with files loaded via `primitive-load-path', `load' will also compile
@@ -327,12 +270,15 @@ the first time they run a Guile script, as the script is
autocompiled.
Note however that the interface of these functions is likely to change
in the next prerelease.
-** New procedure in `(oops goops)': `method-formals'
+** New POSIX procedure: `getsid'
+
+Scheme binding for the `getsid' C library call.
+
+** New POSIX procedure: `getaddrinfo'
-** BUG: (procedure-property func 'arity) does not work on compiled
- procedures
+Scheme binding for the `getaddrinfo' C library function.
-This will be fixed one way or another before 2.0.
+** New procedure in `(oops goops)': `method-formals'
** New procedures in (ice-9 session): `add-value-help-handler!',
`remove-value-help-handler!', `add-name-help-handler!'
@@ -352,11 +298,12 @@ combining arity and formals. For example:
Additionally, `module-commentary' is now publically exported from
`(ice-9 session).
-** Deprecated: `procedure->memoizing-macro', `procedure->syntax'
+** Removed: `procedure->memoizing-macro', `procedure->syntax'
-These procedures will not work with syncase expansion, and indeed are
-not used in the normal course of Guile. They are still used by the old
-Emacs Lisp support, however.
+These procedures created primitive fexprs for the old evaluator, and are
+no longer supported. If you feel that you need these functions, you
+probably need to write your own metacircular evaluator (which will
+probably be as fast as Guile's, anyway).
** New language: ECMAScript
@@ -373,6 +320,12 @@ languages. See the manual for details, or
http://en.wikipedia.org/wiki/Brainfuck for more information about the
Brainfuck language itself.
+** New language: Elisp
+
+Guile now has an experimental Emacs Lisp compiler and runtime. You can
+now switch to Elisp at the repl: `,language elisp'. All kudos to Daniel
+Kraft, and all bugs to address@hidden
+
** Defmacros may now have docstrings.
Indeed, any macro may have a docstring. `object-documentation' from
@@ -400,11 +353,19 @@ like this works now:
It used to be you had to export `helper' from `(foo)' as well.
Thankfully, this has been fixed.
-** New function, `procedure-module'
+** Complete support for version information in Guile's `module' form
+
+Guile modules now have a `#:version' field. They may be loaded by
+version as well. See "R6RS Version References", "General Information
+about Modules", "Using Guile Modules", and "Creating Guile Modules" in
+the manual for more information.
-While useful on its own, `procedure-module' is used by psyntax on syntax
-transformers to determine the module in which to scope introduced
-identifiers.
+** Support for renaming bindings on module export
+
+Wherever Guile accepts a symbol as an argument to specify a binding to
+export, it now also accepts a pair of symbols, indicating that a binding
+should be renamed on export. See "Creating Guile Modules" in the manual
+for more information.
** `eval-case' has been deprecated, and replaced by `eval-when'.
@@ -527,6 +488,14 @@ actually used this, this behavior may be reinstated via the
#; comments out an entire expression. See SRFI-62 or the R6RS for more
information.
+** Prompts: Delimited, composable continuations
+
+Guile now has prompts as part of its primitive language. See "Prompts"
+in the manual, for more information.
+
+Expressions entered in at the REPL, or from the command line, are
+surrounded by a prompt with the default prompt tag.
+
** `make-stack' with a tail-called procedural narrowing argument no longer
works (with compiled procedures)
@@ -564,6 +533,13 @@ Now a syntax error is signaled, as this syntax is not
supported by
default. If there is sufficient demand, this syntax can be supported
again by default.
+** New procedure, `define!'
+
+`define!' is a procedure that takes two arguments, a symbol and a value,
+and binds the value to the symbol in the current module. It's useful to
+programmatically make definitions in the current module, and is slightly
+less verbose than `module-define!'.
+
** All modules have names now
Before, you could have anonymous modules: modules without names. Now,
@@ -652,6 +628,27 @@ environment as well: `syntax->datum', `datum->syntax',
`bound-identifier=?', `free-identifier=?', `generate-temporaries',
`identifier?', and `syntax-violation'. See the R6RS for documentation.
+** Documentation of `syntax-rules' and `syntax-case' macros
+
+The documentation of macros in the manual is now separate from that of
+procedures. A new section on hygienic macros has been added.
+
+** Tail patterns in syntax-case
+
+Guile has pulled in some more recent changes from the psyntax portable
+syntax expander, to implement support for "tail patterns". Such patterns
+are supported by syntax-rules and syntax-case. This allows a syntax-case
+match clause to have ellipses, then a pattern at the end. For example:
+
+ (define-syntax case
+ (syntax-rules (else)
+ ((_ val match-clause ... (else e e* ...))
+ [...])))
+
+Note how there is MATCH-CLAUSE, which is ellipsized, then there is a
+tail pattern for the else clause. Thanks to Andreas Rottmann for the
+patch, and Kent Dybvig for the code.
+
** Lexical bindings introduced by hygienic macros may not be referenced
by nonhygienic macros.
@@ -714,6 +711,55 @@ compatibility purposes. No semantic change has been made
(we hope).
Optional and keyword arguments now dispatch via special VM operations,
without the need to cons rest arguments, making them very fast.
+** New function, `truncated-print', with `format' support
+
+`(ice-9 pretty-print)' now exports `truncated-print', a printer that
+will ensure that the output stays within a certain width, truncating the
+output in what is hopefully an intelligent manner. See the manual for
+more details.
+
+There is a new `format' specifier, address@hidden', for doing a truncated
+print (as opposed to `~y', which does a pretty-print). See the `format'
+documentation for more details.
+
+** SRFI-4 vectors reimplemented in terms of R6RS bytevectors
+
+Guile now implements SRFI-4 vectors using bytevectors. Often when you
+have a numeric vector, you end up wanting to write its bytes somewhere,
+or have access to the underlying bytes, or read in bytes from somewhere
+else. Bytevectors are very good at this sort of thing. But the SRFI-4
+APIs are nicer to use when doing number-crunching, because they are
+addressed by element and not by byte.
+
+So as a compromise, Guile allows all bytevector functions to operate on
+numeric vectors. They address the underlying bytes in the native
+endianness, as one would expect.
+
+Following the same reasoning, that it's just bytes underneath, Guile
+also allows uniform vectors of a given type to be accessed as if they
+were of any type. One can fill a u32vector, and access its elements with
+u8vector-ref. One can use f64vector-ref on bytevectors. It's all the
+same to Guile.
+
+In this way, uniform numeric vectors may be written to and read from
+input/output ports using the procedures that operate on bytevectors.
+
+Calls to SRFI-4 accessors (ref and set functions) from Scheme are now
+inlined to the VM instructions for bytevector access.
+
+See "SRFI-4" in the manual, for more information.
+
+** Nonstandard SRFI-4 procedures now available from `(srfi srfi-4 gnu)'
+
+Guile's `(srfi srfi-4)' now only exports those srfi-4 procedures that
+are part of the standard. Complex uniform vectors and the
+`any->FOOvector' family are now available only from `(srfi srfi-4 gnu)'.
+
+Guile's default environment imports `(srfi srfi-4)', and probably should
+import `(srfi srfi-4 gnu)' as well.
+
+See "SRFI-4 Extensions" in the manual, for more information.
+
** New syntax: include-from-path.
`include-from-path' is like `include', except it looks for its file in
@@ -797,7 +843,7 @@ There was an EBCDIC compile flag that altered some of the
character
processing. It appeared that full EBCDIC support was never completed
and was unmaintained.
-** Compile-time warnings: -Wunbound-variable, -Warity-mismatch.
+** Compile-time warnings
Guile can warn about potentially unbound free variables. Pass the
-Wunbound-variable on the `guile-tools compile' command line, or add
@@ -808,11 +854,8 @@ Guile can also warn when you pass the wrong number of
arguments to a
procedure, with -Warity-mismatch, or `arity-mismatch' in the
`#:warnings' as above.
-** New macro type: syncase-macro
-
-XXX Need to decide whether to document this for 2.0, probably should:
-make-syncase-macro, make-extended-syncase-macro, macro-type,
-syncase-macro-type, syncase-macro-binding
+Other warnings include `-Wunused-variable' and `-Wunused-toplevel', to
+warn about unused local or global (top-level) variables.
** A new `memoize-symbol' evaluator trap has been added.
@@ -827,6 +870,17 @@ This slightly improves program startup times.
See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'.
+** GOOPS dispatch in scheme
+
+As an implementation detail, GOOPS dispatch is no longer implemented by
+special evaluator bytecodes, but rather directly via a Scheme function
+associated with an applicable struct. There is some VM support for the
+underlying primitives, like `class-of'.
+
+This change will in the future allow users to customize generic function
+dispatch without incurring a performance penalty, and allow us to
+implement method combinations.
+
** GOOPS cleanups.
GOOPS had a number of concepts that were relevant to the days of Tcl,
@@ -836,6 +890,31 @@ were a kind of generic specific to the Tcl support.
Entities were
applicable structures, but were unusable; entities will come back in the
next alpha release, but with a less stupid name.
+** Applicable struct support
+
+One may now make structs from Scheme that may be applied as procedures.
+To do so, make a struct whose vtable is `<applicable-struct-vtable>'.
+That struct will be the vtable of your applicable structs; instances of
+that new struct are assumed to have the procedure in their first slot.
+`<applicable-struct-vtable>' is like Common Lisp's
+`funcallable-standard-class'. Likewise there is
+`<applicable-struct-with-setter-vtable>', which looks for the setter in
+the second slot. This needs to be better documented.
+
+** New struct slot allocation: "hidden"
+
+A hidden slot is readable and writable, but will not be initialized by a
+call to make-struct. For example in your layout you would say "ph"
+instead of "pw". Hidden slots are useful for adding new slots to a
+vtable without breaking existing invocations to make-struct.
+
+** eqv? not a generic
+
+One used to be able to extend `eqv?' as a primitive-generic, but no
+more. Because `eqv?' is in the expansion of `case' (via `memv'), which
+should be able to compile to static dispatch tables, it doesn't make
+sense to allow extensions that would subvert this optimization.
+
** `inet-ntop' and `inet-pton' are always available.
Guile now use a portable implementation of `inet_pton'/`inet_ntop', so
@@ -848,6 +927,13 @@ The bit-twiddling operations `ash', `logand', `logior',
and `logxor' now
have dedicated bytecodes. Guile is not just for symbolic computation,
it's for number crunching too.
+** Faster SRFI-9 record access
+
+SRFI-9 records are now implemented directly on top of Guile's structs,
+and their accessors are defined in such a way that normal call-sites
+inline to special VM opcodes, while still allowing for the general case
+(e.g. passing a record accessor to `apply').
+
** R6RS block comment support
Guile now supports R6RS nested block comments. The start of a comment is
@@ -909,6 +995,13 @@ History library functions.
Instead, use make-typed-array, list->typed-array, or array-type,
respectively.
+** Deprecated: `lazy-catch'
+
+`lazy-catch' was a form that captured the stack at the point of a
+`throw', but the dynamic state at the point of the `catch'. It was a bit
+crazy. Please change to use `catch', possibly with a throw-handler, or
+`with-throw-handler'.
+
** Last but not least, the `λ' macro can be used in lieu of `lambda'
* Changes to the C interface
@@ -922,6 +1015,12 @@ backward-compatible way. A new allocation routine,
Libgc is a conservative GC, which we hope will make interaction with C
code easier and less error-prone.
+** New type definitions for `scm_t_intptr' and friends.
+
+`SCM_T_UINTPTR_MAX', `SCM_T_INTPTR_MIN', `SCM_T_INTPTR_MAX',
+`SIZEOF_SCM_T_BITS', `scm_t_intptr' and `scm_t_uintptr' are now
+available to C. Have fun!
+
** The GH interface (deprecated in version 1.6, 2001) was removed.
** Internal `scm_i_' functions now have "hidden" linkage with GCC/ELF
@@ -932,12 +1031,120 @@ application code.
** Functions for handling `scm_option' now no longer require an argument
indicating length of the `scm_t_option' array.
-** scm_primitive_load_path has additional argument, exception_on_error
+** Procedures-with-setters are now implemented using applicable structs
+
+From a user's perspective this doesn't mean very much. But if, for some
+odd reason, you used the SCM_PROCEDURE_WITH_SETTER_P, SCM_PROCEDURE, or
+SCM_SETTER macros, know that they're deprecated now. Also, scm_tc7_pws
+is gone.
+
+** Remove old evaluator closures
+
+There used to be ranges of typecodes allocated to interpreted data
+structures, but that it no longer the case, given that interpreted
+procedure are now just regular VM closures. As a result, there is a
+newly free tc3, and a number of removed macros. See the ChangeLog for
+details.
+
+** Primitive procedures are now VM trampoline procedures
+
+It used to be that there were something like 12 different typecodes
+allocated to primitive procedures, each with its own calling convention.
+Now there is only one, the gsubr. This may affect user code if you were
+defining a procedure using scm_c_make_subr rather scm_c_make_gsubr. The
+solution is to switch to use scm_c_make_gsubr. This solution works well
+both with the old 1.8 and and with the current 1.9 branch.
+
+Guile's old evaluator used to have special cases for applying "gsubrs",
+primitive procedures with specified numbers of required, optional, and
+rest arguments. Now, however, Guile represents gsubrs as normal VM
+procedures, with appropriate bytecode to parse out the correct number of
+arguments, including optional and rest arguments, and then with a
+special bytecode to apply the gsubr.
+
+This allows primitive procedures to appear on the VM stack, allowing
+them to be accurately counted in profiles. Also they now have more
+debugging information attached to them -- their number of arguments, for
+example. In addition, the VM can completely inline the application
+mechanics, allowing for faster primitive calls.
+
+However there are some changes on the C level. There is no more
+`scm_tc7_gsubr' or `scm_tcs_subrs' typecode for primitive procedures, as
+they are just VM procedures. Likewise the macros `SCM_GSUBR_TYPE',
+`SCM_GSUBR_MAKTYPE', `SCM_GSUBR_REQ', `SCM_GSUBR_OPT', and
+`SCM_GSUBR_REST' are gone, as are `SCM_SUBR_META_INFO', `SCM_SUBR_PROPS'
+`SCM_SET_SUBR_GENERIC_LOC', and `SCM_SUBR_ARITY_TO_TYPE'.
+
+Perhaps more significantly, `scm_c_make_subr',
+`scm_c_make_subr_with_generic', `scm_c_define_subr', and
+`scm_c_define_subr_with_generic'. They all operated on subr typecodes,
+and there are no more subr typecodes. Use the scm_c_make_gsubr family
+instead.
+
+Normal users of gsubrs should not be affected, though, as the
+scm_c_make_gsubr family still is the correct way to create primitive
+procedures.
+
+** Remove deprecated array C interfaces
+
+Removed the deprecated array functions `scm_i_arrayp',
+`scm_i_array_ndim', `scm_i_array_mem', `scm_i_array_v',
+`scm_i_array_base', `scm_i_array_dims', and the deprecated macros
+`SCM_ARRAYP', `SCM_ARRAY_NDIM', `SCM_ARRAY_CONTP', `SCM_ARRAY_MEM',
+`SCM_ARRAY_V', `SCM_ARRAY_BASE', and `SCM_ARRAY_DIMS'.
+
+** Remove unused snarf macros
+
+`SCM_DEFINE1', `SCM_PRIMITIVE_GENERIC_1', `SCM_PROC1, and `SCM_GPROC1'
+are no more. Use SCM_DEFINE or SCM_PRIMITIVE_GENERIC instead.
+
+** Add foreign value wrapper
+
+Guile now has a datatype for aliasing "foreign" values, such as native
+long values. This should be useful for making a proper foreign function
+interface. Interested hackers should see libguile/foreign.h.
+
+** New functions: `scm_call_n', `scm_c_run_hookn'
+
+`scm_call_n' applies to apply a function to an array of arguments.
+`scm_c_run_hookn' runs a hook with an array of arguments.
+
+** Some SMOB types changed to have static typecodes
+
+Fluids, dynamic states, and hash tables used to be SMOB objects, but now
+they have statically allocated tc7 typecodes.
+
+** Preparations for changing SMOB representation
+
+If things go right, we'll be changing the SMOB representation soon. To
+that end, we did a lot of cleanups to calls to e.g. SCM_CELL_WORD_2(x) when
+the code meant SCM_SMOB_DATA_2(x); user code will need similar changes
+in the future. Code accessing SMOBs using SCM_CELL macros was never
+correct, but until now things still worked. Users should be aware of
+such changes.
+
+** Changed invocation mechanics of applicable SMOBs
+
+Guile's old evaluator used to have special cases for applying SMOB
+objects. Now, with the VM, when Guile sees a SMOB, it looks up a VM
+trampoline procedure for it, and use the normal mechanics to apply the
+trampoline. This simplifies procedure application in the normal,
+non-SMOB case.
+
+The upshot is that the mechanics used to apply a SMOB are different from
+1.8. Descriptors no longer have `apply_0', `apply_1', `apply_2', and
+`apply_3' functions, and the macros SCM_SMOB_APPLY_0 and friends are now
+deprecated. Just use the scm_call_0 family of procedures.
** New C function: scm_module_public_interface
This procedure corresponds to Scheme's `module-public-interface'.
+** Undeprecate `scm_the_root_module ()'
+
+It's useful to be able to get the root module from C without doing a
+full module lookup.
+
** Inline vector allocation
Instead of having vectors point out into the heap for their data, their
@@ -946,6 +1153,19 @@ true for bytevectors, by default, though there is an
indirection
available which should allow for making a bytevector from an existing
memory region.
+** New struct constructors that don't involve making lists
+
+`scm_c_make_struct' and `scm_c_make_structv' are new varargs and array
+constructors, respectively, for structs. You might find them useful.
+
+** Stack refactor
+
+In Guile 1.8, there were debugging frames on the C stack. Now there is
+no more need to explicitly mark the stack in this way, because Guile has
+a VM stack that it knows how to walk, which simplifies the C API
+considerably. See the ChangeLog for details; the relevant interface is
+in libguile/stacks.h. The Scheme API has not been changed significantly.
+
** Removal of Guile's primitive object system.
There were a number of pieces in `objects.[ch]' that tried to be a
@@ -962,6 +1182,14 @@ shall be, Amen, except that `futures.c' and `futures.h'
are no longer a
part of it. These files were experimental, never compiled, and would be
better implemented in Scheme anyway. In the future, that is.
+** Deprecate trampolines
+
+There used to be C functions `scm_trampoline_0', `scm_trampoline_1', and
+so on. The point was to do some precomputation on the type of the
+procedure, then return a specialized "call" procedure. However this
+optimization wasn't actually an optimization, so it is now deprecated.
+Just use `scm_call_0', etc instead.
+
** Better support for Lisp `nil'.
The bit representation of `nil' has been tweaked so that it is now very
@@ -1023,6 +1251,17 @@ macros should now require `guile-2.0' instead of
`guile-1.8'.
If $(libdir) is /usr/lib, for example, Guile will install its .go files
to /usr/lib/guile/1.9/ccache. These files are architecture-specific.
+** Parallel installability fixes
+
+Guile now installs its header files to a effective-version-specific
+directory, and includes the effective version (e.g. 2.0) in the library
+name (e.g. libguile-2.0.so).
+
+This change should be transparent to users, who should detect Guile via
+the guile.m4 macro, or the guile-2.0.pc pkg-config file. It will allow
+parallel installs for multiple versions of Guile development
+environments.
+
** Dynamically loadable extensions may be placed in a Guile-specific path
Before, Guile only searched the system library paths for extensions
@@ -1040,6 +1279,10 @@ See http://www.hpl.hp.com/personal/Hans_Boehm/gc/, for
more information.
See http://www.gnu.org/software/libunistring/, for more information. Our
Unicode support uses routines from libunistring.
+** New dependency: libffi
+
+See http://sourceware.org/libffi/, for more information.
+
Changes in 1.8.8 (since 1.8.7)
diff --git a/README b/README
index c4f24f8..90914e1 100644
--- a/README
+++ b/README
@@ -34,6 +34,7 @@ Guile depends on the following external libraries.
- libltdl
- libunistring
- libgc
+- libffi
It will also use the libreadline library if it is available. For each
of these there is a corresponding --with-XXX-prefix option that you
can use when invoking ./configure, if you have these libraries
@@ -50,16 +51,19 @@ names (where that is supported), makes it impossible to
later move the
built executables and libraries to an installation location other than
the one that was specified at build time.
-Another possible approach is to set CPPFLAGS and LDFLAGS before
-running configure, so that they include -I options for all the
+Another possible approach is to set CPPFLAGS and LDFLAGS on the
+configure command-line, so that they include -I options for all the
non-standard places where you have installed header files and -L
options for all the non-standard places where you have installed
libraries. This will allow configure and make to find those headers
-and libraries during the build. The locations found will not be
-hardcoded into the build executables and libraries, so with this
-approach you will probably also need to set LD_LIBRARY_PATH
-correspondingly, to allow Guile to find the necessary libraries again
-at runtime.
+and libraries during the build. E.g.:
+
+ ../configure [...] CPPFLAGS='-I/my/include' LDFLAGS='-L/my/lib'
+
+The locations found will not be hardcoded into the build executables and
+libraries, so with this approach you will probably also need to set
+LD_LIBRARY_PATH correspondingly, to allow Guile to find the necessary
+libraries again at runtime.
Required External Packages ================================================
@@ -88,6 +92,26 @@ Guile requires the following external packages:
conservative garbage collector used by Guile. It is available
from http://www.hpl.hp.com/personal/Hans_Boehm/gc/ .
+ - libffi
+
+ libffi provides a "foreign function interface", used by the
+ `(system foreign)' module. It is available from
+ http://sourceware.org/libffi/ .
+
+ - pkg-config
+
+ Guile's ./configure script uses pkg-config to discover the correct
+ compile and link options for libgc. If you don't have pkg-config
+ installed, or you have a version of libgc that doesn't provide a
+ .pc file, you can work around this by setting some variables as
+ part of the configure command-line:
+
+ - PKG_CONFIG=true
+
+ - BDW_GC_CFLAGS=<compile flags for picking up libgc headers>
+
+ - BDW_GC_LIBS=<linker flags for picking up the libgc library>
+
Special Instructions For Some Systems =====================================
diff --git a/THANKS b/THANKS
index e507d73..2649a2a 100644
--- a/THANKS
+++ b/THANKS
@@ -31,6 +31,7 @@ For fixes or providing information which led to a fix:
Adrian Bunk
Michael Carmack
R Clayton
+ Tristan Colgate
Stephen Compall
Brian Crowder
Christopher Cramer
@@ -49,6 +50,7 @@ For fixes or providing information which led to a fix:
Panicz Maciej Godek
John Goerzen
Mike Gran
+ Raimon Grau
Szavai Gyula
Roland Haeder
Sven Hartrumpf
@@ -69,14 +71,17 @@ For fixes or providing information which led to a fix:
Matt Kraai
Daniel Kraft
Miroslav Lichvar
+ Daniel Llorens del RÃo
Jeff Long
Marco Maggi
Gregory Marton
Kjetil S. Matheussen
Antoine Mathys
+ Patrick McCarty
Dan McMahill
Roger Mc Murtrie
Scott McPeak
+ Andrew Milkowski
Tim Mooney
Han-Wen Nienhuys
Jan Nieuwenhuizen
@@ -91,6 +96,7 @@ For fixes or providing information which led to a fix:
Ron Peterson
David Pirotte
Carlos Pita
+ Sergey Poznyakoff
Ken Raeburn
Juhani Rantanen
Andreas Rottmann
@@ -100,6 +106,7 @@ For fixes or providing information which led to a fix:
Frank Schwidom
John Steele Scott
Thiemo Seufer
+ Ivan Shcherbakov
Scott Shedden
Alex Shinn
Daniel Skarda
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index a9da00e..583519a 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -7,7 +7,8 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/structs.bm \
benchmarks/subr.bm \
benchmarks/uniform-vector-read.bm \
- benchmarks/vectors.bm
+ benchmarks/vectors.bm \
+ benchmarks/vlists.bm
EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
ChangeLog-2008
diff --git a/benchmark-suite/benchmarks/vlists.bm
b/benchmark-suite/benchmarks/vlists.bm
new file mode 100644
index 0000000..329c786
--- /dev/null
+++ b/benchmark-suite/benchmarks/vlists.bm
@@ -0,0 +1,103 @@
+;;; -*- mode: scheme; coding: iso-8859-1; -*-
+;;; VLists.
+;;;
+;;; Copyright 2009 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER. If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks vlists)
+ :use-module (srfi srfi-1)
+ :use-module (ice-9 vlist)
+ :use-module (benchmark-suite lib))
+
+;; Note: Use `--iteration-factor' to change this.
+(define iterations 2000000)
+
+;; The size of large lists.
+(define %list-size 700000)
+
+(define %big-list (make-list %list-size))
+(define %big-vlist (list->vlist %big-list))
+
+(define-syntax comparative-benchmark
+ (syntax-rules ()
+ ((_ benchmark-name iterations
+ ((api ((name value) ...)))
+ body ...)
+ (benchmark (format #f "~A (~A)" benchmark-name 'api)
+ iterations
+ (let ((name value) ...)
+ body ...)))
+ ((_ benchmark-name iterations
+ ((api bindings) apis ...)
+ body ...)
+ (begin
+ (comparative-benchmark benchmark-name iterations
+ ((api bindings))
+ body ...)
+ (comparative-benchmark benchmark-name iterations
+ (apis ...)
+ body ...)))))
+
+
+(with-benchmark-prefix "constructors"
+
+ (comparative-benchmark "cons" 2
+ ((srfi-1 ((cons cons) (null '())))
+ (vlist ((cons vlist-cons) (null vlist-null))))
+ (let loop ((i %list-size)
+ (r null))
+ (and (> i 0)
+ (loop (1- i) (cons #t r)))))
+
+
+ (comparative-benchmark "acons" 2
+ ((srfi-1 ((acons alist-cons) (null '())))
+ (vlist ((acons vhash-cons) (null vlist-null))))
+ (let loop ((i %list-size)
+ (r null))
+ (if (zero? i)
+ r
+ (loop (1- i) (acons i i r))))))
+
+
+(define %big-alist
+ (let loop ((i %list-size) (res '()))
+ (if (zero? i)
+ res
+ (loop (1- i) (alist-cons i i res)))))
+(define %big-vhash
+ (let loop ((i %list-size) (res vlist-null))
+ (if (zero? i)
+ res
+ (loop (1- i) (vhash-cons i i res)))))
+
+
+(with-benchmark-prefix "iteration"
+
+ (comparative-benchmark "fold" 2
+ ((srfi-1 ((fold fold) (lst %big-list)))
+ (vlist ((fold vlist-fold) (lst %big-vlist))))
+ (fold (lambda (x y) y) #t lst))
+
+ (comparative-benchmark "assoc" 70
+ ((srfi-1 ((assoc assoc) (alst %big-alist)))
+ (vhash ((assoc vhash-assoc) (alst %big-vhash))))
+ (let loop ((i (quotient %list-size 3)))
+ (and (> i 0)
+ (begin
+ (assoc i alst)
+ (loop (- i 5000)))))))
diff --git a/build-aux/announce-gen b/build-aux/announce-gen
index 5fbb9cd..7d70fd4 100755
--- a/build-aux/announce-gen
+++ b/build-aux/announce-gen
@@ -9,7 +9,7 @@ my $VERSION = '2009-11-20 13:36'; # UTC
# If you change this file with Emacs, please let the write hook
# do its job. Otherwise, update this string manually.
-# Copyright (C) 2002-2009 Free Software Foundation, Inc.
+# Copyright (C) 2002-2010 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
diff --git a/build-aux/arg-nonnull.h b/build-aux/arg-nonnull.h
index 24ad6b5..7e3e2db 100644
--- a/build-aux/arg-nonnull.h
+++ b/build-aux/arg-nonnull.h
@@ -1,5 +1,5 @@
/* A C macro for declaring that specific arguments must not be NULL.
- Copyright (C) 2009 Free Software Foundation, Inc.
+ Copyright (C) 2009, 2010 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
diff --git a/build-aux/c++defs.h b/build-aux/c++defs.h
new file mode 100644
index 0000000..31b29c2
--- /dev/null
+++ b/build-aux/c++defs.h
@@ -0,0 +1,233 @@
+/* C++ compatible function declaration macros.
+ Copyright (C) 2010 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published
+ by the Free Software Foundation; either version 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 General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _GL_CXXDEFS_H
+#define _GL_CXXDEFS_H
+
+/* The three most frequent use cases of these macros are:
+
+ * For providing a substitute for a function that is missing on some
+ platforms, but is declared and works fine on the platforms on which
+ it exists:
+
+ #if @GNULIB_FOO@
+ # if address@hidden@
+ _GL_FUNCDECL_SYS (foo, ...);
+ # endif
+ _GL_CXXALIAS_SYS (foo, ...);
+ _GL_CXXALIASWARN (foo);
+ #elif defined GNULIB_POSIXCHECK
+ ...
+ #endif
+
+ * For providing a replacement for a function that exists on all platforms,
+ but is broken/insufficient and needs to be replaced on some platforms:
+
+ #if @GNULIB_FOO@
+ # if @REPLACE_FOO@
+ # if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+ # undef foo
+ # define foo rpl_foo
+ # endif
+ _GL_FUNCDECL_RPL (foo, ...);
+ _GL_CXXALIAS_RPL (foo, ...);
+ # else
+ _GL_CXXALIAS_SYS (foo, ...);
+ # endif
+ _GL_CXXALIASWARN (foo);
+ #elif defined GNULIB_POSIXCHECK
+ ...
+ #endif
+
+ * For providing a replacement for a function that exists on some platforms
+ but is broken/insufficient and needs to be replaced on some of them and
+ is additionally either missing or undeclared on some other platforms:
+
+ #if @GNULIB_FOO@
+ # if @REPLACE_FOO@
+ # if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+ # undef foo
+ # define foo rpl_foo
+ # endif
+ _GL_FUNCDECL_RPL (foo, ...);
+ _GL_CXXALIAS_RPL (foo, ...);
+ # else
+ # if address@hidden@ or if address@hidden@
+ _GL_FUNCDECL_SYS (foo, ...);
+ # endif
+ _GL_CXXALIAS_SYS (foo, ...);
+ # endif
+ _GL_CXXALIASWARN (foo);
+ #elif defined GNULIB_POSIXCHECK
+ ...
+ #endif
+*/
+
+/* _GL_EXTERN_C declaration;
+ performs the declaration with C linkage. */
+#if defined __cplusplus
+# define _GL_EXTERN_C extern "C"
+#else
+# define _GL_EXTERN_C extern
+#endif
+
+/* _GL_FUNCDECL_RPL (func, rettype, parameters_and_attributes);
+ declares a replacement function, named rpl_func, with the given prototype,
+ consisting of return type, parameters, and attributes.
+ Example:
+ _GL_FUNCDECL_RPL (open, int, (const char *filename, int flags, ...)
+ _GL_ARG_NONNULL ((1)));
+ */
+#define _GL_FUNCDECL_RPL(func,rettype,parameters_and_attributes) \
+ _GL_FUNCDECL_RPL_1 (rpl_##func, rettype, parameters_and_attributes)
+#define _GL_FUNCDECL_RPL_1(rpl_func,rettype,parameters_and_attributes) \
+ _GL_EXTERN_C rettype rpl_func parameters_and_attributes
+
+/* _GL_FUNCDECL_SYS (func, rettype, parameters_and_attributes);
+ declares the system function, named func, with the given prototype,
+ consisting of return type, parameters, and attributes.
+ Example:
+ _GL_FUNCDECL_SYS (open, int, (const char *filename, int flags, ...)
+ _GL_ARG_NONNULL ((1)));
+ */
+#define _GL_FUNCDECL_SYS(func,rettype,parameters_and_attributes) \
+ _GL_EXTERN_C rettype func parameters_and_attributes
+
+/* _GL_CXXALIAS_RPL (func, rettype, parameters);
+ declares a C++ alias called GNULIB_NAMESPACE::func
+ that redirects to rpl_func, if GNULIB_NAMESPACE is defined.
+ Example:
+ _GL_CXXALIAS_RPL (open, int, (const char *filename, int flags, ...));
+ */
+#define _GL_CXXALIAS_RPL(func,rettype,parameters) \
+ _GL_CXXALIAS_RPL_1 (func, rpl_##func, rettype, parameters)
+#if defined __cplusplus && defined GNULIB_NAMESPACE
+# define _GL_CXXALIAS_RPL_1(func,rpl_func,rettype,parameters) \
+ namespace GNULIB_NAMESPACE \
+ { \
+ rettype (*const func) parameters = ::rpl_func; \
+ } \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#else
+# define _GL_CXXALIAS_RPL_1(func,rpl_func,rettype,parameters) \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#endif
+
+/* _GL_CXXALIAS_SYS (func, rettype, parameters);
+ declares a C++ alias called GNULIB_NAMESPACE::func
+ that redirects to the system provided function func, if GNULIB_NAMESPACE
+ is defined.
+ Example:
+ _GL_CXXALIAS_SYS (open, int, (const char *filename, int flags, ...));
+ */
+#if defined __cplusplus && defined GNULIB_NAMESPACE
+ /* If we were to write
+ rettype (*const func) parameters = ::func;
+ like above in _GL_CXXALIAS_RPL_1, the compiler could optimize calls
+ better (remove an indirection through a 'static' pointer variable),
+ but then the _GL_CXXALIASWARN macro below would cause a warning not only
+ for uses of ::func but also for uses of GNULIB_NAMESPACE::func. */
+# define _GL_CXXALIAS_SYS(func,rettype,parameters) \
+ namespace GNULIB_NAMESPACE \
+ { \
+ static rettype (*func) parameters = ::func; \
+ } \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#else
+# define _GL_CXXALIAS_SYS(func,rettype,parameters) \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#endif
+
+/* _GL_CXXALIAS_SYS_CAST (func, rettype, parameters);
+ is like _GL_CXXALIAS_SYS (func, rettype, parameters);
+ except that the C function func may have a slightly different declaration.
+ A cast is used to silence the "invalid conversion" error that would
+ otherwise occur. */
+#if defined __cplusplus && defined GNULIB_NAMESPACE
+# define _GL_CXXALIAS_SYS_CAST(func,rettype,parameters) \
+ namespace GNULIB_NAMESPACE \
+ { \
+ static rettype (*func) parameters = \
+ reinterpret_cast<rettype(*)parameters>(::func); \
+ } \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#else
+# define _GL_CXXALIAS_SYS_CAST(func,rettype,parameters) \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#endif
+
+/* _GL_CXXALIAS_SYS_CAST2 (func, rettype, parameters, rettype2, parameters2);
+ is like _GL_CXXALIAS_SYS (func, rettype, parameters);
+ except that the C function is picked among a set of overloaded functions,
+ namely the one with rettype2 and parameters2. Two consecutive casts
+ are used to silence the "cannot find a match" and "invalid conversion"
+ errors that would otherwise occur. */
+#if defined __cplusplus && defined GNULIB_NAMESPACE
+ /* The outer cast must be a reinterpret_cast.
+ The inner cast: When the function is defined as a set of overloaded
+ functions, it works as a static_cast<>, choosing the designated variant.
+ When the function is defined as a single variant, it works as a
+ reinterpret_cast<>. The parenthesized cast syntax works both ways. */
+# define _GL_CXXALIAS_SYS_CAST2(func,rettype,parameters,rettype2,parameters2) \
+ namespace GNULIB_NAMESPACE \
+ { \
+ static rettype (*func) parameters = \
+ reinterpret_cast<rettype(*)parameters>( \
+ (rettype2(*)parameters2)(::func)); \
+ } \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#else
+# define _GL_CXXALIAS_SYS_CAST2(func,rettype,parameters,rettype2,parameters2) \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#endif
+
+/* _GL_CXXALIASWARN (func);
+ causes a warning to be emitted when ::func is used but not when
+ GNULIB_NAMESPACE::func is used. func must be defined without overloaded
+ variants. */
+#if defined __cplusplus && defined GNULIB_NAMESPACE
+# define _GL_CXXALIASWARN(func) \
+ _GL_CXXALIASWARN_1 (func, GNULIB_NAMESPACE)
+# define _GL_CXXALIASWARN_1(func,namespace) \
+ _GL_CXXALIASWARN_2 (func, namespace)
+# define _GL_CXXALIASWARN_2(func,namespace) \
+ _GL_WARN_ON_USE (func, \
+ "The symbol ::" #func " refers to the system function. " \
+ "Use " #namespace "::" #func " instead.")
+#else
+# define _GL_CXXALIASWARN(func) \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#endif
+
+/* _GL_CXXALIASWARN1 (func, rettype, parameters_and_attributes);
+ causes a warning to be emitted when the given overloaded variant of ::func
+ is used but not when GNULIB_NAMESPACE::func is used. */
+#if defined __cplusplus && defined GNULIB_NAMESPACE
+# define _GL_CXXALIASWARN1(func,rettype,parameters_and_attributes) \
+ _GL_CXXALIASWARN1_1 (func, rettype, parameters_and_attributes, \
+ GNULIB_NAMESPACE)
+# define _GL_CXXALIASWARN1_1(func,rettype,parameters_and_attributes,namespace)
\
+ _GL_CXXALIASWARN1_2 (func, rettype, parameters_and_attributes, namespace)
+# define _GL_CXXALIASWARN1_2(func,rettype,parameters_and_attributes,namespace)
\
+ _GL_WARN_ON_USE_CXX (func, rettype, parameters_and_attributes, \
+ "The symbol ::" #func " refers to the system function.
" \
+ "Use " #namespace "::" #func " instead.")
+#else
+# define _GL_CXXALIASWARN1(func,rettype,parameters_and_attributes) \
+ _GL_EXTERN_C int _gl_cxxalias_dummy
+#endif
+
+#endif /* _GL_CXXDEFS_H */
diff --git a/build-aux/config.rpath b/build-aux/config.rpath
index 85c2f20..17298f2 100755
--- a/build-aux/config.rpath
+++ b/build-aux/config.rpath
@@ -2,7 +2,7 @@
# Output a system dependent set of variables, describing how to set the
# run time search path of shared libraries in an executable.
#
-# Copyright 1996-2008 Free Software Foundation, Inc.
+# Copyright 1996-2010 Free Software Foundation, Inc.
# Taken from GNU libtool, 2001
# Originally by Gordon Matzigkeit <address@hidden>, 1996
#
diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh
old mode 100644
new mode 100755
index 992d9fc..67d5b52
--- a/build-aux/gendocs.sh
+++ b/build-aux/gendocs.sh
@@ -1,10 +1,10 @@
-#!/bin/sh
+#!/bin/sh -e
# gendocs.sh -- generate a GNU manual in many formats. This script is
# mentioned in maintain.texi. See the help message below for usage details.
-scriptversion=2009-09-09.22
+scriptversion=2010-02-13.20
-# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009
+# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
# Free Software Foundation, Inc.
#
# This program is free software: you can redistribute it and/or modify
@@ -56,6 +56,7 @@ See the GNU Maintainers document for a more extensive
discussion:
http://www.gnu.org/prep/maintain_toc.html
Options:
+ -s SRCFILE read Texinfo from SRCFILE, instead of PACKAGE.{texinfo|texi|txi}
-o OUTDIR write files into OUTDIR, instead of manual/.
--email ADR use ADR as contact in generated web pages.
--docbook convert to DocBook too (xml, txt, html, pdf and ps).
@@ -119,12 +120,14 @@ PACKAGE=
address@hidden # please override with --email
htmlarg=
outdir=manual
+srcfile=
while test $# -gt 0; do
case $1 in
--email) shift; EMAIL=$1;;
--help) echo "$usage"; exit 0;;
--version) echo "$version"; exit 0;;
+ -s) shift; srcfile=$1;;
-o) shift; outdir=$1;;
--docbook) docbook=yes;;
--html) shift; htmlarg=$1;;
@@ -146,7 +149,9 @@ while test $# -gt 0; do
shift
done
-if test -s "$srcdir/$PACKAGE.texinfo"; then
+if test -n "$srcfile"; then
+ :
+elif test -s "$srcdir/$PACKAGE.texinfo"; then
srcfile=$srcdir/$PACKAGE.texinfo
elif test -s "$srcdir/$PACKAGE.texi"; then
srcfile=$srcdir/$PACKAGE.texi
@@ -268,13 +273,14 @@ else
fi
echo Making .tar.gz for sources...
-srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null`
+d=`dirname $srcfile`
+srcfiles=`ls $d/*.texinfo $d/*.texi $d/*.txi $d/*.eps 2>/dev/null` || true
tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles
texi_tgz_size=`calcsize $outdir/$PACKAGE.texi.tar.gz`
if test -n "$docbook"; then
cmd="$SETLANG $MAKEINFO -o - --docbook \"$srcfile\" >
${srcdir}/$PACKAGE-db.xml"
- echo "Generating docbook XML... $(cmd)"
+ echo "Generating docbook XML... ($cmd)"
eval "$cmd"
docbook_xml_size=`calcsize $PACKAGE-db.xml`
gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz
@@ -302,7 +308,7 @@ if test -n "$docbook"; then
mv $PACKAGE-db.txt $outdir/
cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml"
- echo "Generating docbook PS... $(cmd)"
+ echo "Generating docbook PS... ($cmd)"
eval "$cmd"
gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz
docbook_ps_gz_size=`calcsize $outdir/$PACKAGE-db.ps.gz`
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 32f76e8..7660af5 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -9,7 +9,7 @@ my $VERSION = '2009-10-30 13:46'; # UTC
# If you change this file with Emacs, please let the write hook
# do its job. Otherwise, update this string manually.
-# Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+# Copyright (C) 2008-2010 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
diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update
index 91902c5..2c1a0cc 100755
--- a/build-aux/gnu-web-doc-update
+++ b/build-aux/gnu-web-doc-update
@@ -9,7 +9,7 @@
VERSION=2009-07-21.16; # UTC
-# Copyright (C) 2009 Free Software Foundation, Inc.
+# Copyright (C) 2009, 2010 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
diff --git a/build-aux/gnupload b/build-aux/gnupload
index 5ebacdb..c28a5cc 100755
--- a/build-aux/gnupload
+++ b/build-aux/gnupload
@@ -1,9 +1,10 @@
#!/bin/sh
# Sign files and upload them.
-scriptversion=2009-11-29.20; # UTC
+scriptversion=2010-02-08.07; # UTC
-# Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation
+# Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 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
@@ -32,10 +33,11 @@ delete_symlinks=
collect_var=
dbg=
-usage="Usage: $0 [OPTIONS]... [COMMAND] FILES... [[COMMAND] FILES...]
+usage="Usage: $0 [OPTION]... [CMD] FILE... [[CMD] FILE...]
-Sign all FILES, and upload them to selected destinations, according to
-<http://www.gnu.org/prep/maintain/html_node/Automated-FTP-Uploads.html>.
+Sign all FILES, and process them at selected destinations according to CMD.
+<http://www.gnu.org/prep/maintain/html_node/Automated-FTP-Uploads.html>
+explains further.
Commands:
--delete delete FILES from destination
@@ -96,6 +98,11 @@ Examples:
--delete oopsbar-0.9.91.tar.gz \\
-- foobar-0.9.91.tar.gz
+gnupload uses the ncftpput program to do the transfers; if you don't
+happen to have an ncftp package installed, the ncftpput-ftp script in
+the build-aux/ directory of the gnulib package
+(http://savannah.gnu.org/projects/gnulib) may serve as a replacement.
+
Report bugs to <address@hidden>.
Send patches to <address@hidden>."
diff --git a/build-aux/link-warning.h b/build-aux/link-warning.h
deleted file mode 100644
index 7fefab7..0000000
--- a/build-aux/link-warning.h
+++ /dev/null
@@ -1,45 +0,0 @@
-/* A C macro for emitting link time warnings.
- Copyright (C) 1995, 1997, 2000, 2002-2003, 2007, 2009 Free Software
- Foundation, Inc.
-
- This program is free software: you can redistribute it and/or modify it
- under the terms of the GNU 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 General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
-
-/* GL_LINK_WARNING("literal string") arranges to emit the literal string as
- a linker warning on most glibc systems.
- We use a linker warning rather than a preprocessor warning, because
- #warning cannot be used inside macros. */
-#ifndef GL_LINK_WARNING
- /* This works on platforms with GNU ld and ELF object format.
- Testing __GLIBC__ is sufficient for asserting that GNU ld is in use.
- Testing __ELF__ guarantees the ELF object format.
- Testing __GNUC__ is necessary for the compound expression syntax. */
-# if defined __GLIBC__ && defined __ELF__ && defined __GNUC__
-# define GL_LINK_WARNING(message) \
- GL_LINK_WARNING1 (__FILE__, __LINE__, message)
-# define GL_LINK_WARNING1(file, line, message) \
- GL_LINK_WARNING2 (file, line, message) /* macroexpand file and line */
-# define GL_LINK_WARNING2(file, line, message) \
- GL_LINK_WARNING3 (file ":" #line ": warning: " message)
-# define GL_LINK_WARNING3(message) \
- ({ static const char warning[sizeof (message)] \
- __attribute__ ((__unused__, \
- __section__ (".gnu.warning"), \
- __aligned__ (1))) \
- = message "\n"; \
- (void)0; \
- })
-# else
-# define GL_LINK_WARNING(message) ((void) 0)
-# endif
-#endif
diff --git a/build-aux/unused-parameter.h b/build-aux/unused-parameter.h
new file mode 100644
index 0000000..b6fa325
--- /dev/null
+++ b/build-aux/unused-parameter.h
@@ -0,0 +1,36 @@
+/* A C macro for declaring that specific function parameters are not used.
+ Copyright (C) 2008-2010 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published
+ by the Free Software Foundation; either version 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 General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* _GL_UNUSED_PARAMETER is a marker that can be appended to function parameter
+ declarations for parameters that are not used. This helps to reduce
+ warnings, such as from GCC -Wunused-parameter. The syntax is as follows:
+ type param _GL_UNUSED_PARAMETER
+ or more generally
+ param_decl _GL_UNUSED_PARAMETER
+ For example:
+ int param _GL_UNUSED_PARAMETER
+ int *(*param)(void) _GL_UNUSED_PARAMETER
+ Other possible, but obscure and discouraged syntaxes:
+ int _GL_UNUSED_PARAMETER *(*param)(void)
+ _GL_UNUSED_PARAMETER int *(*param)(void)
+ */
+#ifndef _GL_UNUSED_PARAMETER
+# if __GNUC__ >= 3 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7)
+# define _GL_UNUSED_PARAMETER __attribute__ ((__unused__))
+# else
+# define _GL_UNUSED_PARAMETER
+# endif
+#endif
diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free
index 793c975..6aa7d39 100755
--- a/build-aux/useless-if-before-free
+++ b/build-aux/useless-if-before-free
@@ -12,7 +12,7 @@ my $VERSION = '2009-04-16 15:57'; # UTC
# If you change this file with Emacs, please let the write hook
# do its job. Otherwise, update this string manually.
-# Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+# Copyright (C) 2008-2010 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
diff --git a/build-aux/vc-list-files b/build-aux/vc-list-files
index cc716e9..b9f2fbd 100755
--- a/build-aux/vc-list-files
+++ b/build-aux/vc-list-files
@@ -2,9 +2,9 @@
# List version-controlled file names.
# Print a version string.
-scriptversion=2009-07-21.16; # UTC
+scriptversion=2010-02-21.13; # UTC
-# Copyright (C) 2006-2009 Free Software Foundation, Inc.
+# Copyright (C) 2006-2010 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
@@ -85,7 +85,7 @@ elif test -d .hg; then
eval exec hg locate '"$dir/*"' $postprocess
elif test -d .bzr; then
test "$postprocess" = '' && postprocess="| sed 's|^\./||'"
- eval exec bzr ls --versioned '"$dir"' $postprocess
+ eval exec bzr ls -R --versioned '"$dir"' $postprocess
elif test -d CVS; then
test "$postprocess" = '' && postprocess="| sed 's|^\./||'"
if test -x build-aux/cvsu; then
diff --git a/build-aux/warn-on-use.h b/build-aux/warn-on-use.h
new file mode 100644
index 0000000..03ae871
--- /dev/null
+++ b/build-aux/warn-on-use.h
@@ -0,0 +1,92 @@
+/* A C macro for emitting warnings if a function is used.
+ Copyright (C) 2010 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published
+ by the Free Software Foundation; either version 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 General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* _GL_WARN_ON_USE (function, "literal string") issues a declaration
+ for FUNCTION which will then trigger a compiler warning containing
+ the text of "literal string" anywhere that function is called, if
+ supported by the compiler. If the compiler does not support this
+ feature, the macro expands to an unused extern declaration.
+
+ This macro is useful for marking a function as a potential
+ portability trap, with the intent that "literal string" include
+ instructions on the replacement function that should be used
+ instead. However, one of the reasons that a function is a
+ portability trap is if it has the wrong signature. Declaring
+ FUNCTION with a different signature in C is a compilation error, so
+ this macro must use the same type as any existing declaration so
+ that programs that avoid the problematic FUNCTION do not fail to
+ compile merely because they included a header that poisoned the
+ function. But this implies that _GL_WARN_ON_USE is only safe to
+ use if FUNCTION is known to already have a declaration. Use of
+ this macro implies that there must not be any other macro hiding
+ the declaration of FUNCTION; but undefining FUNCTION first is part
+ of the poisoning process anyway (although for symbols that are
+ provided only via a macro, the result is a compilation error rather
+ than a warning containing "literal string"). Also note that in
+ C++, it is only safe to use if FUNCTION has no overloads.
+
+ For an example, it is possible to poison 'getline' by:
+ - adding a call to gl_WARN_ON_USE_PREPARE([[#include <stdio.h>]],
+ [getline]) in configure.ac, which potentially defines
+ HAVE_RAW_DECL_GETLINE
+ - adding this code to a header that wraps the system <stdio.h>:
+ #undef getline
+ #if HAVE_RAW_DECL_GETLINE
+ _GL_WARN_ON_USE (getline, "getline is required by POSIX 2008, but"
+ "not universally present; use the gnulib module getline");
+ #endif
+
+ It is not possible to directly poison global variables. But it is
+ possible to write a wrapper accessor function, and poison that
+ (less common usage, like &environ, will cause a compilation error
+ rather than issue the nice warning, but the end result of informing
+ the developer about their portability problem is still achieved):
+ #if HAVE_RAW_DECL_ENVIRON
+ static inline char ***rpl_environ (void) { return &environ; }
+ _GL_WARN_ON_USE (rpl_environ, "environ is not always properly declared");
+ # undef environ
+ # define environ (*rpl_environ ())
+ #endif
+ */
+#ifndef _GL_WARN_ON_USE
+
+# if 4 < __GNUC__ || (__GNUC__ == 4 && 3 <= __GNUC_MINOR__)
+/* A compiler attribute is available in gcc versions 4.3.0 and later. */
+# define _GL_WARN_ON_USE(function, message) \
+extern __typeof__ (function) function __attribute__ ((__warning__ (message)))
+
+# else /* Unsupported. */
+# define _GL_WARN_ON_USE(function, message) \
+extern int _gl_warn_on_use
+# endif
+#endif
+
+/* _GL_WARN_ON_USE_CXX (function, rettype, parameters_and_attributes, "string")
+ is like _GL_WARN_ON_USE (function, "string"), except that the function is
+ declared with the given prototype, consisting of return type, parameters,
+ and attributes.
+ This variant is useful for overloaded functions in C++. _GL_WARN_ON_USE does
+ not work in this case. */
+#ifndef _GL_WARN_ON_USE_CXX
+# if 4 < __GNUC__ || (__GNUC__ == 4 && 3 <= __GNUC_MINOR__)
+# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \
+extern rettype function parameters_and_attributes \
+ __attribute__ ((__warning__ (msg)))
+# else /* Unsupported. */
+# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \
+extern int _gl_warn_on_use
+# endif
+#endif
diff --git a/configure.ac b/configure.ac
index 35c2ed9..73a4bd2 100644
--- a/configure.ac
+++ b/configure.ac
@@ -4,7 +4,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[
-Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
2008, 2009 Free Software Foundation, Inc.
+Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
2008, 2009, 2010 Free Software Foundation, Inc.
This file is part of GUILE
@@ -105,14 +105,6 @@ AC_ARG_ENABLE(error-on-warning,
*) AC_MSG_ERROR(bad value ${enableval} for --enable-error-on-warning) ;;
esac])
-SCM_I_GSC_GUILE_DEBUG_FREELIST=0
-AC_ARG_ENABLE(debug-freelist,
- [ --enable-debug-freelist include garbage collector freelist debugging
code],
- if test "$enable_debug_freelist" = y \
- || test "$enable_debug_freelist" = yes; then
- SCM_I_GSC_GUILE_DEBUG_FREELIST=1
- fi)
-
AC_ARG_ENABLE(debug-malloc,
[ --enable-debug-malloc include malloc debugging code],
if test "$enable_debug_malloc" = y || test "$enable_debug_malloc" = yes; then
@@ -168,10 +160,6 @@ fi
AC_DEFINE_UNQUOTED([SCM_WARN_DEPRECATED_DEFAULT], "$warn_default",
[Define this to control the default warning level for deprecated features.])
-AC_ARG_ENABLE(elisp,
- [ --disable-elisp omit Emacs Lisp support],,
- enable_elisp=yes)
-
dnl Added the following configure option in January 2008 following
dnl investigation of problems with "64" system and library calls on
dnl Darwin (MacOS X). The libguile code (_scm.h) assumes that if a
@@ -262,11 +250,6 @@ if test "$enable_debug_malloc" = yes; then
AC_LIBOBJ([debug-malloc])
fi
-if test "$enable_elisp" = yes; then
- SCM_I_GSC_ENABLE_ELISP=1
-else
- SCM_I_GSC_ENABLE_ELISP=0
-fi
AC_CHECK_LIB(uca, __uc_get_ar_bsp)
AC_C_CONST
@@ -671,6 +654,16 @@ sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h
sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
direct.h langinfo.h nl_types.h machine/fpu.h])
+# Reasons for testing:
+# nl_item - lacking on Cygwin
+AC_CHECK_TYPES([nl_item], [], [],
+ [[#ifdef HAVE_LANGINFO_H
+ # include <langinfo.h>
+ #endif
+ #ifdef HAVE_NL_TYPES_H
+ # include <nl_types.h>
+ #endif]])
+
# "complex double" is new in C99, and "complex" is only a keyword if
# <complex.h> is included
AC_CHECK_TYPES(complex double,,,
@@ -764,8 +757,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
# nl_langinfo - X/Open, not available on Windows.
+# utimensat: posix.1-2008
#
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir
mknod nice pipe _pipe 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
nl_langinfo])
+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 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
nl_langinfo utimensat])
# Reasons for testing:
# netdb.h - not in mingw
@@ -865,11 +859,14 @@ fi
dnl GMP tests
-AC_LIB_HAVE_LINKFLAGS(gmp,
+AC_LIB_HAVE_LINKFLAGS([gmp],
[],
[#include <gmp.h>],
- [mpz_import (0, 0, 0, 0, 0, 0, 0);],
- AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
+ [mpz_import (0, 0, 0, 0, 0, 0, 0);])
+
+if test "x$HAVE_LIBGMP" != "xyes"; then
+ AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README])
+fi
dnl GNU libunistring is checked for by Gnulib's `libunistring' module.
if test "x$LTLIBUNISTRING" != "x"; then
@@ -878,6 +875,22 @@ else
AC_MSG_ERROR([GNU libunistring is required, please install it.])
fi
+dnl Libffi is needed to compile Guile's foreign function interface, but its
+dnl interface isn't exposed in Guile's API.
+PKG_CHECK_MODULES(LIBFFI, libffi)
+AC_SUBST(LIBFFI_CFLAGS)
+AC_SUBST(LIBFFI_LIBS)
+
+dnl figure out approriate ffi type for size_t
+AC_CHECK_SIZEOF(size_t)
+AC_CHECK_SIZEOF(ssize_t)
+ffi_size_type=uint$(($ac_cv_sizeof_size_t*8))
+ffi_ssize_type=sint$(($ac_cv_sizeof_ssize_t*8))
+AC_DEFINE_UNQUOTED(ffi_type_size_t, ffi_type_${ffi_size_type},
+ [ffi type for size_t])
+AC_DEFINE_UNQUOTED(ffi_type_ssize_t, ffi_type_${ffi_ssize_type},
+ [ffi type for ssize_t])
+
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
#AC_CHECK_FUNCS(gettext)
@@ -1157,7 +1170,10 @@ int main () { return (isnan(x) != 0); }]]),
# Note AC_STRUCT_ST_BLOCKS is not used here because we don't want the
# AC_LIBOBJ(fileblocks) replacement which that macro gives.
#
-AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct
stat.st_blocks])
+AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct
stat.st_blocks, struct stat.st_atim, struct stat.st_mtim, struct
stat.st_ctim],,,
+ [#define _GNU_SOURCE
+AC_INCLUDES_DEFAULT
+])
AC_STRUCT_TIMEZONE
AC_CHECK_MEMBERS([struct tm.tm_gmtoff],,,
@@ -1595,10 +1611,8 @@ AC_SUBST([sitedir])
# Additional SCM_I_GSC definitions are above.
AC_SUBST([SCM_I_GSC_GUILE_DEBUG])
-AC_SUBST([SCM_I_GSC_GUILE_DEBUG_FREELIST])
AC_SUBST([SCM_I_GSC_ENABLE_DISCOURAGED])
AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED])
-AC_SUBST([SCM_I_GSC_ENABLE_ELISP])
AC_SUBST([SCM_I_GSC_STACK_GROWS_UP])
AC_SUBST([SCM_I_GSC_C_INLINE])
AC_CONFIG_FILES([libguile/gen-scmconfig.h])
@@ -1611,7 +1625,6 @@ AC_CONFIG_FILES([
doc/Makefile
doc/r5rs/Makefile
doc/ref/Makefile
- doc/tutorial/Makefile
emacs/Makefile
examples/Makefile
libguile/Makefile
diff --git a/doc/Makefile.am b/doc/Makefile.am
index 06f55a7..c296045 100644
--- a/doc/Makefile.am
+++ b/doc/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 2002, 2006, 2008, 2009 Free Software Foundation,
Inc.
+## Copyright (C) 1998, 2002, 2006, 2008, 2009, 2010 Free Software
Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -21,7 +21,7 @@
AUTOMAKE_OPTIONS = gnu
-SUBDIRS = ref tutorial r5rs
+SUBDIRS = ref r5rs
dist_man1_MANS = guile.1
diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi
index 127f0bb..d521f98 100644
--- a/doc/maint/guile.texi
+++ b/doc/maint/guile.texi
@@ -2130,7 +2130,7 @@ all necessary initialization information.
@c snarfed from goops.c:2318
@deffn {Scheme Procedure} %method-more-specific? m1 m2 targs
@deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs)
-
+Return true if method @var{m1} is more specific than @var{m2} given the
argument types (classes) listed in @var{targs}.
@end deffn
%goops-loaded
@@ -3220,19 +3220,19 @@ environment. For example:
@c snarfed from macros.c:165
@deffn {Scheme Procedure} macro? obj
@deffnx {C Function} scm_macro_p (obj)
-Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a
-syntax transformer.
+Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a
+syntax transformer, or a syntax-case macro.
@end deffn
macro-type
@c snarfed from macros.c:186
@deffn {Scheme Procedure} macro-type m
@deffnx {C Function} scm_macro_type (m)
-Return one of the symbols @code{syntax}, @code{macro} or
address@hidden, depending on whether @var{m} is a syntax
-transformer, a regular macro, or a memoizing macro,
-respectively. If @var{m} is not a macro, @code{#f} is
-returned.
+Return one of the symbols @code{syntax}, @code{macro},
address@hidden, or @code{syntax-case}, depending on whether
address@hidden is a syntax transformer, a regular macro, a memoizing
+macro, or a syntax-case macro, respectively. If @var{m} is
+not a macro, @code{#f} is returned.
@end deffn
macro-name
@@ -3300,7 +3300,7 @@ Return a interface eval closure for the module
@var{module}. Such a closure does
@c snarfed from modules.c:399
@deffn {Scheme Procedure} module-import-interface module sym
@deffnx {C Function} scm_module_import_interface (module, sym)
-
+Return the module or interface from which @var{sym} is imported in
@var{module}. If @var{sym} is not imported (i.e., it is not defined in
@var{module} or it is a module-local binding instead of an imported one), then
@code{#f} is returned.
@end deffn
%get-pre-modules-obarray
@@ -3689,10 +3689,9 @@ procedure does not accept complex arguments.
make-rectangular
@c snarfed from numbers.c:5286
address@hidden {Scheme Procedure} make-rectangular real imaginary
address@hidden {C Function} scm_make_rectangular (real, imaginary)
-Return a complex number constructed of the given @var{real} and
address@hidden parts.
address@hidden {Scheme Procedure} make-rectangular real_part imaginary_part
address@hidden {C Function} scm_make_rectangular (real_part, imaginary_part)
+Return a complex number constructed of the given @var{real-part} and
@var{imaginary-part} parts.
@end deffn
make-polar
@@ -4361,8 +4360,8 @@ with the associated setter @var{setter}.
@c snarfed from procs.c:308
@deffn {Scheme Procedure} procedure proc
@deffnx {C Function} scm_procedure (proc)
-Return the procedure of @var{proc}, which must be either a
-procedure with setter, or an operator struct.
+Return the procedure of @var{proc}, which must be an
+applicable struct.
@end deffn
primitive-make-property
@@ -4566,7 +4565,9 @@ Install the procedure @var{proc} for reading expressions
starting with the character sequence @code{#} and @var{chr}.
@var{proc} will be called with two arguments: the character
@var{chr} and the port to read further data from. The object
-returned will be the return value of @code{read}.
+returned will be the return value of @code{read}.
+Passing @code{#f} for @var{proc} will remove a previous setting.
+
@end deffn
call-with-dynamic-root
@@ -5438,30 +5439,23 @@ Return the number of elements in the uniform vector
@var{v}.
uniform-vector-read!
@c snarfed from srfi-4.c:845
address@hidden {Scheme Procedure} uniform-vector-read! uvec [port_or_fd [start
[end]]]
address@hidden {C Function} scm_uniform_vector_read_x (uvec, port_or_fd, start,
end)
-Fill the elements of @var{uvec} by reading
-raw bytes from @var{port-or-fdes}, using host byte order.
address@hidden {Scheme Procedure} uniform-array-read! ura [port_or_fd [start
[end]]]
address@hidden {Scheme Procedure} uniform-vector-read! uve [port-or-fdes]
[start] [end]
address@hidden {C Function} scm_uniform_array_read_x (ura, port_or_fd, start,
end)
+Attempt to read all elements of @var{ura}, in lexicographic order, as
+binary objects from @var{port-or-fdes}.
+If an end of file is encountered,
+the objects up to that point are put into @var{ura}
+(starting at the beginning) and the remainder of the array is
+unchanged.
-The optional arguments @var{start} (inclusive) and @var{end}
-(exclusive) allow a specified region to be read,
+The optional arguments @var{start} and @var{end} allow
+a specified region of a vector (or linearized array) to be read,
leaving the remainder of the vector unchanged.
-When @var{port-or-fdes} is a port, all specified elements
-of @var{uvec} are attempted to be read, potentially blocking
-while waiting formore input or end-of-file.
-When @var{port-or-fd} is an integer, a single call to
-read(2) is made.
-
-An error is signalled when the last element has only
-been partially filled before reaching end-of-file or in
-the single call to read(2).
-
address@hidden returns the number of elements
-read.
-
address@hidden may be omitted, in which case it defaults
-to the value returned by @code{(current-input-port)}.
address@hidden returns the number of objects read.
address@hidden may be omitted, in which case it defaults to the value
+returned by @code{(current-input-port)}.
@end deffn
uniform-vector-write
@@ -6671,8 +6665,9 @@ mismatch index, depending upon whether @var{s1} is less
than,
equal to, or greater than @var{s2}. The mismatch index is the
largest index @var{i} such that for every 0 <= @var{j} <
@var{i}, @address@hidden = @address@hidden -- that is,
address@hidden is the first position that does not match. The
-character comparison is done case-insensitively.
address@hidden is the first position where the lowercased letters
+do not match.
+
@end deffn
string=
@@ -7090,8 +7085,8 @@ operate on. The return value is unspecified.
string-append/shared
@c snarfed from srfi-13.c:2635
address@hidden {Scheme Procedure} string-append/shared . ls
address@hidden {C Function} scm_string_append_shared (ls)
address@hidden {Scheme Procedure} string-append/shared . rest
address@hidden {C Function} scm_string_append_shared (rest)
Like @code{string-append}, but the result may share memory
with the argument strings.
@end deffn
@@ -7749,7 +7744,8 @@ character sets.
string=?
@c snarfed from strorder.c:50
address@hidden {Scheme Procedure} string=? s1 s2
address@hidden {Scheme Procedure} string=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_equal_p (s1, s2, rest)
Lexicographic equality predicate; return @code{#t} if the two
strings are the same length and contain the same characters in
the same positions, otherwise return @code{#f}.
@@ -7762,7 +7758,8 @@ characters.
string-ci=?
@c snarfed from strorder.c:62
address@hidden {Scheme Procedure} string-ci=? s1 s2
address@hidden {Scheme Procedure} string-ci=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_equal_p (s1, s2, rest)
Case-insensitive string equality predicate; return @code{#t} if
the two strings are the same length and their component
characters match (ignoring case) at each position; otherwise
@@ -7771,35 +7768,40 @@ return @code{#f}.
string<?
@c snarfed from strorder.c:72
address@hidden {Scheme Procedure} string<? s1 s2
address@hidden {Scheme Procedure} string<? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_less_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically less than @var{s2}.
@end deffn
string<=?
@c snarfed from strorder.c:82
address@hidden {Scheme Procedure} string<=? s1 s2
address@hidden {Scheme Procedure} string<=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_leq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically less than or equal to @var{s2}.
@end deffn
string>?
@c snarfed from strorder.c:92
address@hidden {Scheme Procedure} string>? s1 s2
address@hidden {Scheme Procedure} string>? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_gr_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically greater than @var{s2}.
@end deffn
string>=?
@c snarfed from strorder.c:102
address@hidden {Scheme Procedure} string>=? s1 s2
address@hidden {Scheme Procedure} string>=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_geq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically greater than or equal to @var{s2}.
@end deffn
string-ci<?
@c snarfed from strorder.c:113
address@hidden {Scheme Procedure} string-ci<? s1 s2
address@hidden {Scheme Procedure} string-ci<? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_less_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically less than @var{s2}
regardless of case.
@@ -7807,7 +7809,8 @@ regardless of case.
string-ci<=?
@c snarfed from strorder.c:124
address@hidden {Scheme Procedure} string-ci<=? s1 s2
address@hidden {Scheme Procedure} string-ci<=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_leq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically less than or equal
to @var{s2} regardless of case.
@@ -7815,7 +7818,8 @@ to @var{s2} regardless of case.
string-ci>?
@c snarfed from strorder.c:135
address@hidden {Scheme Procedure} string-ci>? s1 s2
address@hidden {Scheme Procedure} string-ci>? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_gr_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically greater than
@var{s2} regardless of case.
@@ -7823,7 +7827,8 @@ Case insensitive lexicographic ordering predicate; return
string-ci>=?
@c snarfed from strorder.c:146
address@hidden {Scheme Procedure} string-ci>=? s1 s2
address@hidden {Scheme Procedure} string-ci>=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_geq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically greater than or
equal to @var{s2} regardless of case.
diff --git a/doc/mbapi.texi b/doc/mbapi.texi
deleted file mode 100644
index 3f53ccd..0000000
--- a/doc/mbapi.texi
+++ /dev/null
@@ -1,987 +0,0 @@
-\input texinfo
address@hidden mbapi.info
address@hidden Multibyte API
address@hidden off
-
address@hidden Open issues:
-
address@hidden What's the best way to report errors? Should functions return a
address@hidden magic value, according to C tradition, or should they signal a
address@hidden Guile exception?
-
address@hidden
-
-
address@hidden Working With Multibyte Strings in C
address@hidden Working With Multibyte Strings in C
-
-Guile allows strings to contain characters drawn from a wide variety of
-languages, including many Asian, Eastern European, and Middle Eastern
-languages, in a uniform and unrestricted way. The string representation
-normally used in C code --- an array of @sc{ASCII} characters --- is not
-sufficient for Guile strings, since they may contain characters not
-present in @sc{ASCII}.
-
-Instead, Guile uses a very large character set, and encodes each
-character as a sequence of one or more bytes. We call this
-variable-width encoding a @dfn{multibyte} encoding. Guile uses this
-single encoding internally for all strings, symbol names, error
-messages, etc., and performs appropriate conversions upon input and
-output.
-
-The use of this variable-width encoding is almost invisible to Scheme
-code. Strings are still indexed by character number, not by byte
-offset; @code{string-length} still returns the length of a string in
-characters, not in bytes. @code{string-ref} and @code{string-set!} are
-no longer guaranteed to be constant-time operations, but Guile uses
-various strategies to reduce the impact of this change.
-
-However, the encoding is visible via Guile's C interface, which gives
-the user direct access to a string's bytes. This chapter explains how
-to work with Guile multibyte text in C code. Since variable-width
-encodings are clumsier to work with than simple fixed-width encodings,
-Guile provides a set of standard macros and functions for manipulating
-multibyte text to make the job easier. Furthermore, Guile makes some
-promises about the encoding which you can use in writing your own text
-processing code.
-
-While we discuss guaranteed properties of Guile's encoding, and provide
-functions to operate on its character set, we do not actually specify
-either the character set or encoding here. This is because we expect
-both of them to change in the future: currently, Guile uses the same
-encoding as GNU Emacs 20.4, but we hope to change Guile (and GNU Emacs
-as well) to use Unicode and UTF-8, with some extensions. This will make
-it more comfortable to use Guile with other systems which use UTF-8,
-like the GTk user interface toolkit.
-
address@hidden
-* Multibyte String Terminology::
-* Promised Properties of the Guile Multibyte Encoding::
-* Functions for Operating on Multibyte Text::
-* Multibyte Text Processing Errors::
-* Why Guile Does Not Use a Fixed-Width Encoding::
address@hidden menu
-
-
address@hidden Multibyte String Terminology, Promised Properties of the Guile
Multibyte Encoding, Working With Multibyte Strings in C, Working With Multibyte
Strings in C
address@hidden Multibyte String Terminology
-
-In the descriptions which follow, we make the following definitions:
address@hidden @dfn
-
address@hidden byte
-A @dfn{byte} is a number between 0 and 255. It has no inherent textual
-interpretation. So 65 is a byte, not a character.
-
address@hidden character
-A @dfn{character} is a unit of text. It has no inherent numeric value.
address@hidden and @samp{.} are characters, not bytes. (This is different
-from the C language's definition of @dfn{character}; in this chapter, we
-will always use a phrase like ``the C language's @code{char} type'' when
-that's what we mean.)
-
address@hidden character set
-A @dfn{character set} is an invertible mapping between numbers and a
-given set of characters. @sc{ASCII} is a character set assigning
-characters to the numbers 0 through 127. It maps @samp{A} onto the
-number 65, and @samp{.} onto 46.
-
-Note that a character set maps characters onto numbers, @emph{not
-necessarily} onto bytes. For example, the Unicode character set maps
-the Greek lower-case @samp{alpha} character onto the number 945, which
-is not a byte.
-
-(This is what Internet standards would call a "coding character set".)
-
address@hidden encoding
-An encoding maps numbers onto sequences of bytes. For example, the
-UTF-8 encoding, defined in the Unicode Standard, would map the number
-945 onto the sequence of bytes @samp{206 177}. When using the
address@hidden character set, every number assigned also happens to be a
-byte, so there is an obvious trivial encoding for @sc{ASCII} in bytes.
-
-(This is what Internet standards would call a "character encoding
-scheme".)
-
address@hidden table
-
-Thus, to turn a character into a sequence of bytes, you need a character
-set to assign a number to that character, and then an encoding to turn
-that number into a sequence of bytes.
-
-Likewise, to interpret a sequence of bytes as a sequence of characters,
-you use an encoding to extract a sequence of numbers from the bytes, and
-then a character set to turn the numbers into characters.
-
-Errors can occur while carrying out either of these processes. For
-example, under a particular encoding, a given string of bytes might not
-correspond to any number. For example, the byte sequence @samp{128 128}
-is not a valid encoding of any number under UTF-8.
-
-Having carefully defined our terminology, we will now abuse it.
-
-We will sometimes use the word @dfn{character} to refer to the number
-assigned to a character by a character set, in contexts where it's
-obvious we mean a number.
-
-Sometimes there is a close association between a particular encoding and
-a particular character set. Thus, we may sometimes refer to the
-character set and encoding together as an @dfn{encoding}.
-
-
address@hidden Promised Properties of the Guile Multibyte Encoding, Functions
for Operating on Multibyte Text, Multibyte String Terminology, Working With
Multibyte Strings in C
address@hidden Promised Properties of the Guile Multibyte Encoding
-
-Internally, Guile uses a single encoding for all text --- symbols,
-strings, error messages, etc. Here we list a number of helpful
-properties of Guile's encoding. It is correct to write code which
-assumes these properties; code which uses these assumptions will be
-portable to all future versions of Guile, as far as we know.
-
address@hidden @sc{ASCII} character is encoded as a single byte from 0 to 127,
in
-the obvious way.} This means that a standard C string containing only
address@hidden characters is a valid Guile string (except for the terminator;
-Guile strings store the length explicitly, so they can contain null
-characters).
-
address@hidden encodings of address@hidden characters use only bytes between 128
-and 255.} That is, when we turn a address@hidden character into a
-series of bytes, none of those bytes can ever be mistaken for the
-encoding of an @sc{ASCII} character. This means that you can search a
-Guile string for an @sc{ASCII} character using the standard
address@hidden library function. By extension, you can search for an
address@hidden substring in a Guile string using a traditional substring
-search algorithm --- you needn't add special checks to verify encoding
-boundaries, etc.
-
address@hidden character encoding is a subsequence of any other character
-encoding.} (This is just a stronger version of the previous promise.)
-This means that you can search for occurrences of one Guile string
-within another Guile string just as if they were raw byte strings. You
-can use the stock @code{memmem} function (provided on GNU systems, at
-least) for such searches. If you don't need the ability to represent
-null characters in your text, you can still use null-termination for
-strings, and use the traditional string-handling functions like
address@hidden, @code{strstr}, and @code{strcat}.
-
address@hidden can always determine the full length of a character's encoding
-from its first byte.} Guile provides the macro @code{scm_mb_len} which
-computes the encoding's length from its first byte. Given the first
-rule, you can see that @code{scm_mb_len (@var{b})}, for any @code{0 <=
address@hidden <= 127}, returns 1.
-
address@hidden an arbitrary byte position in a Guile string, you can always
-find the beginning and end of the character containing that byte without
-scanning too far in either direction.} This means that, if you are sure
-a byte sequence is a valid encoding of a character sequence, you can
-find character boundaries without keeping track of the beginning and
-ending of the overall string. This promise relies on the fact that, in
-addition to storing the string's length explicitly, Guile always either
-terminates the string's storage with a zero byte, or shares it with
-another string which is terminated this way.
-
-
address@hidden Functions for Operating on Multibyte Text, Multibyte Text
Processing Errors, Promised Properties of the Guile Multibyte Encoding, Working
With Multibyte Strings in C
address@hidden Functions for Operating on Multibyte Text
-
-Guile provides a variety of functions, variables, and types for working
-with multibyte text.
-
address@hidden
-* Basic Multibyte Character Processing::
-* Finding Character Encoding Boundaries::
-* Multibyte String Functions::
-* Exchanging Guile Text With the Outside World in C::
-* Implementing Your Own Text Conversions::
address@hidden menu
-
-
address@hidden Basic Multibyte Character Processing, Finding Character Encoding
Boundaries, Functions for Operating on Multibyte Text, Functions for Operating
on Multibyte Text
address@hidden Basic Multibyte Character Processing
-
-Here are the essential types and functions for working with Guile text.
-Guile uses the C type @code{unsigned char *} to refer to text encoded
-with Guile's encoding.
-
-Note that any operation marked here as a ``Libguile Macro'' might
-evaluate its argument multiple times.
-
address@hidden {Libguile Type} scm_char_t
-This is a signed integral type large enough to hold any character in
-Guile's character set. All character numbers are positive.
address@hidden deftp
-
address@hidden {Libguile Macro} scm_char_t scm_mb_get (const unsigned char
address@hidden)
-Return the character whose encoding starts at @var{p}. If @var{p} does
-not point at a valid character encoding, the behavior is undefined.
address@hidden deftypefn
-
address@hidden {Libguile Macro} int scm_mb_put (unsigned char address@hidden,
scm_char_t @var{c})
-Place the encoded form of the Guile character @var{c} at @var{p}, and
-return its length in bytes. If @var{c} is not a Guile character, the
-behavior is undefined.
address@hidden deftypefn
-
address@hidden {Libguile Constant} int scm_mb_max_len
-The maximum length of any character's encoding, in bytes. You may
-assume this is relatively small --- less than a dozen or so.
address@hidden deftypevr
-
address@hidden {Libguile Macro} int scm_mb_len (unsigned char @var{b})
-If @var{b} is the first byte of a character's encoding, return the full
-length of the character's encoding, in bytes. If @var{b} is not a valid
-leading byte, the behavior is undefined.
address@hidden deftypefn
-
address@hidden {Libguile Macro} int scm_mb_char_len (scm_char_t @var{c})
-Return the length of the encoding of the character @var{c}, in bytes.
-If @var{c} is not a valid Guile character, the behavior is undefined.
address@hidden deftypefn
-
address@hidden {Libguile Function} scm_char_t scm_mb_get_func (const unsigned
char address@hidden)
address@hidden {Libguile Function} int scm_mb_put_func (unsigned char
address@hidden, scm_char_t @var{c})
address@hidden {Libguile Function} int scm_mb_len_func (unsigned char @var{b})
address@hidden {Libguile Function} int scm_mb_char_len_func (scm_char_t @var{c})
-These are functions identical to the corresponding macros. You can use
-them in situations where the overhead of a function call is acceptable,
-and the cleaner semantics of function application are desireable.
address@hidden deftypefn
-
-
address@hidden Finding Character Encoding Boundaries, Multibyte String
Functions, Basic Multibyte Character Processing, Functions for Operating on
Multibyte Text
address@hidden Finding Character Encoding Boundaries
-
-These are functions for finding the boundaries between characters in
-multibyte text.
-
-Note that any operation marked here as a ``Libguile Macro'' might
-evaluate its argument multiple times, unless the definition promises
-otherwise.
-
address@hidden {Libguile Macro} int scm_mb_boundary_p (const unsigned char
address@hidden)
-Return non-zero iff @var{p} points to the start of a character in
-multibyte text.
-
-This macro will evaluate its argument only once.
address@hidden deftypefn
-
address@hidden {Libguile Function} {const unsigned char *} scm_mb_floor (const
unsigned char address@hidden)
-``Round'' @var{p} to the previous character boundary. That is, if
address@hidden points to the middle of the encoding of a Guile character,
-return a pointer to the first byte of the encoding. If @var{p} points
-to the start of the encoding of a Guile character, return @var{p}
-unchanged.
address@hidden deftypefn
-
address@hidden {libguile Function} {const unsigned char *} scm_mb_ceiling
(const unsigned char address@hidden)
-``Round'' @var{p} to the next character boundary. That is, if @var{p}
-points to the middle of the encoding of a Guile character, return a
-pointer to the first byte of the encoding of the next character. If
address@hidden points to the start of the encoding of a Guile character, return
address@hidden unchanged.
address@hidden deftypefn
-
-Note that it is usually not friendly for functions to silently correct
-byte offsets that point into the middle of a character's encoding. Such
-offsets almost always indicate a programming error, and they should be
-reported as early as possible. So, when you write code which operates
-on multibyte text, you should not use functions like these to ``clean
-up'' byte offsets which the originator believes to be correct; instead,
-your code should signal a @code{text:not-char-boundary} error as soon as
-it detects an invalid offset. @xref{Multibyte Text Processing Errors}.
-
-
address@hidden Multibyte String Functions, Exchanging Guile Text With the
Outside World in C, Finding Character Encoding Boundaries, Functions for
Operating on Multibyte Text
address@hidden Multibyte String Functions
-
-These functions allow you to operate on multibyte strings: sequences of
-character encodings.
-
address@hidden {Libguile Function} int scm_mb_count (const unsigned char
address@hidden, int @var{len})
-Return the number of Guile characters encoded by the @var{len} bytes at
address@hidden
-
-If the sequence contains any invalid character encodings, or ends with
-an incomplete character encoding, signal a @code{text:bad-encoding}
-error.
address@hidden deftypefn
-
address@hidden {Libguile Macro} scm_char_t scm_mb_walk (unsigned char
address@hidden)
-Return the character whose encoding starts at @address@hidden, and
-advance @address@hidden to the start of the next character. Return -1
-if @address@hidden does not point to a valid character encoding.
address@hidden deftypefn
-
address@hidden {Libguile Function} {const unsigned char *} scm_mb_prev (const
unsigned char address@hidden)
-If @var{p} points to the middle of the encoding of a Guile character,
-return a pointer to the first byte of the encoding. If @var{p} points
-to the start of the encoding of a Guile character, return the start of
-the previous character's encoding.
-
-This is like @code{scm_mb_floor}, but the returned pointer will always
-be before @var{p}. If you use this function to drive an iteration, it
-guarantees backward progress.
address@hidden deftypefn
-
address@hidden {Libguile Function} {const unsigned char *} scm_mb_next (const
unsigned char address@hidden)
-If @var{p} points to the encoding of a Guile character, return a pointer
-to the first byte of the encoding of the next character.
-
-This is like @code{scm_mb_ceiling}, but the returned pointer will always
-be after @var{p}. If you use this function to drive an iteration, it
-guarantees forward progress.
address@hidden deftypefn
-
address@hidden {Libguile Function} {const unsigned char *} scm_mb_index (const
unsigned char address@hidden, int @var{len}, int @var{i})
-Assuming that the @var{len} bytes starting at @var{p} are a
-concatenation of valid character encodings, return a pointer to the
-start of the @var{i}'th character encoding in the sequence.
-
-This function scans the sequence from the beginning to find the
address@hidden'th character, and will generally require time proportional to
-the distance from @var{p} to the returned address.
-
-If the sequence contains any invalid character encodings, or ends with
-an incomplete character encoding, signal a @code{text:bad-encoding}
-error.
address@hidden deftypefn
-
-It is common to process the characters in a string from left to right.
-However, if you fetch each character using @code{scm_mb_index}, each
-call will scan the text from the beginning, so your loop will require
-time proportional to at least the square of the length of the text. To
-avoid this poor performance, you can use an @code{scm_mb_cache}
-structure and the @code{scm_mb_index_cached} macro.
-
address@hidden {Libguile Type} {struct scm_mb_cache}
-This structure holds information that allows a string scanning operation
-to use the results from a previous scan of the string. It has the
-following members:
address@hidden @code
-
address@hidden character
-An index, in characters, into the string.
-
address@hidden byte
-The index, in bytes, of the start of that character.
-
address@hidden table
-
-In other words, @code{byte} is the byte offset of the
address@hidden'th character of the string. Note that if @code{byte}
-and @code{character} are equal, then all characters before that point
-must have encodings exactly one byte long, and the string can be indexed
-normally.
-
-All elements of a @code{struct scm_mb_cache} structure should be
-initialized to zero before its first use, and whenever the string's text
-changes.
address@hidden deftp
-
address@hidden {Libguile Macro} const unsigned char *scm_mb_index_cached (const
unsigned char address@hidden, int @var{len}, int @var{i}, struct scm_mb_cache
address@hidden)
address@hidden {Libguile Function} const unsigned char
*scm_mb_index_cached_func (const unsigned char address@hidden, int @var{len},
int @var{i}, struct scm_mb_cache address@hidden)
-This macro and this function are identical to @code{scm_mb_index},
-except that they may consult and update address@hidden in order to avoid
-scanning the string from the beginning. @code{scm_mb_index_cached} is a
-macro, so it may have less overhead than
address@hidden, but it may evaluate its arguments more
-than once.
-
-Using @code{scm_mb_index_cached} or @code{scm_mb_index_cached_func}, you
-can scan a string from left to right, or from right to left, in time
-proportional to the length of the string. As long as each character
-fetched is less than some constant distance before or after the previous
-character fetched with @var{cache}, each access will require constant
-time.
address@hidden deftypefn
-
-Guile also provides functions to convert between an encoded sequence of
-characters, and an array of @code{scm_char_t} objects.
-
address@hidden {Libguile Function} scm_char_t *scm_mb_multibyte_to_fixed (const
unsigned char address@hidden, int @var{len}, int address@hidden)
-Convert the variable-width text in the @var{len} bytes at @var{p}
-to an array of @code{scm_char_t} values. Return a pointer to the array,
-and set @address@hidden to the number of elements it contains.
-The returned array is allocated with @code{malloc}, and it is the
-caller's responsibility to free it.
-
-If the text is not a sequence of valid character encodings, this
-function will signal a @code{text:bad-encoding} error.
address@hidden deftypefn
-
address@hidden {Libguile Function} unsigned char *scm_mb_fixed_to_multibyte
(const scm_char_t address@hidden, int @var{len}, int address@hidden)
-Convert the array of @code{scm_char_t} values to a sequence of
-variable-width character encodings. Return a pointer to the array of
-bytes, and set @address@hidden to its length, in bytes.
-
-The returned byte sequence is terminated with a zero byte, which is not
-counted in the length returned in @address@hidden
-
-The returned byte sequence is allocated with @code{malloc}; it is the
-caller's responsibility to free it.
-
-If the text is not a sequence of valid character encodings, this
-function will signal a @code{text:bad-encoding} error.
address@hidden deftypefn
-
-
address@hidden Exchanging Guile Text With the Outside World in C, Implementing
Your Own Text Conversions, Multibyte String Functions, Functions for Operating
on Multibyte Text
address@hidden Exchanging Guile Text With the Outside World in C
-
-[[This is kind of a heavy-weight model, given that one end of the
-conversion is always going to be the Guile encoding. Any way to shorten
-things a bit?]]
-
-Guile provides functions for converting between Guile's internal text
-representation and encodings popular in the outside world. These
-functions are closely modeled after the @code{iconv} functions available
-on some systems.
-
-To convert text between two encodings, you should first call
address@hidden to indicate the source and destination
-encodings; this function returns a context object which records the
-conversion to perform.
-
-Then, you should call @code{scm_mb_iconv} to actually convert the text.
-This function expects input and output buffers, and a pointer to the
-context you got from @var{scm_mb_iconv_open}. You don't need to pass
-all your input to @code{scm_mb_iconv} at once; you can invoke it on
-successive blocks of input (as you read it from a file, say), and it
-will convert as much as it can each time, indicating when you should
-grow your output buffer.
-
-An encoding may be @dfn{stateless}, or @dfn{stateful}. In most
-encodings, a contiguous group of bytes from the sequence completely
-specifies a particular character; these are stateless encodings.
-However, some encodings require you to look back an unbounded number of
-bytes in the stream to assign a meaning to a particular byte sequence;
-such encodings are stateful.
-
-For example, in the @samp{ISO-2022-JP} encoding for Japanese text, the
-byte sequence @samp{27 36 66} indicates that subsequent bytes should be
-taken in pairs and interpreted as characters from the JIS-0208 character
-set. An arbitrary number of byte pairs may follow this sequence. The
-byte sequence @samp{27 40 66} indicates that subsequent bytes should be
-interpreted as @sc{ASCII}. In this encoding, you cannot tell whether a
-given byte is an @sc{ASCII} character without looking back an arbitrary
-distance for the most recent escape sequence, so it is a stateful
-encoding.
-
-In Guile, if a conversion involves a stateful encoding, the context
-object carries any necessary state. Thus, you can have many independent
-conversions to or from stateful encodings taking place simultaneously,
-as long as each data stream uses its own context object for the
-conversion.
-
address@hidden {Libguile Type} {struct scm_mb_iconv}
-This is the type for context objects, which represent the encodings and
-current state of an ongoing text conversion. A @code{struct
-scm_mb_iconv} records the source and destination encodings, and keeps
-track of any information needed to handle stateful encodings.
address@hidden deftp
-
address@hidden {Libguile Function} {struct scm_mb_iconv *} scm_mb_iconv_open
(const char address@hidden, const char address@hidden)
-Return a pointer to a new @code{struct scm_mb_iconv} context object,
-ready to convert from the encoding named @var{fromcode} to the encoding
-named @var{tocode}. For stateful encodings, the context object is in
-some appropriate initial state, ready for use with the
address@hidden function.
-
-When you are done using a context object, you may call
address@hidden to free it.
-
-If either @var{tocode} or @var{fromcode} is not the name of a known
-encoding, this function will signal the @code{text:unknown-conversion}
-error, described below.
-
address@hidden Try to use names here from the IANA list:
address@hidden see ftp://ftp.isi.edu/in-notes/iana/assignments/character-sets
-Guile supports at least these encodings:
address@hidden @samp
-
address@hidden US-ASCII
address@hidden, in the standard one-character-per-byte encoding.
-
address@hidden ISO-8859-1
-The usual character set for Western European languages, in its usual
-one-character-per-byte encoding.
-
address@hidden Guile-MB
-Guile's current internal multibyte encoding. The actual encoding this
-name refers to will change from one version of Guile to the next. You
-should use this when converting data between external sources and the
-encoding used by Guile objects.
-
-You should @emph{not} use this as the encoding for data presented to the
-outside world, for two reasons. 1) Its meaning will change over time,
-so data written using the @samp{guile} encoding with one version of
-Guile might not be readable with the @samp{guile} encoding in another
-version of Guile. 2) It currently corresponds to @samp{Emacs-Mule},
-which invented for Emacs's internal use, and was never intended to serve
-as an exchange medium.
-
address@hidden Guile-Wide
-Guile's character set, as an array of @code{scm_char_t} values.
-
-Note that this encoding is even less suitable for public use than
address@hidden, since the exact sequence of bytes depends heavily on the
-size and endianness the host system uses for @code{scm_char_t}. Using
-this encoding is very much like calling the
address@hidden or @code{scm_mb_fixed_to_multibyte}
-functions, except that @code{scm_mb_iconv} gives you more control over
-buffer allocation and management.
-
address@hidden Emacs-Mule
-This is the variable-length encoding for multi-lingual text by GNU
-Emacs, at least through version 20.4. You probably should not use this
-encoding, as it is designed only for Emacs's internal use. However, we
-provide it here because it's trivial to support, and some people
-probably do have @samp{emacs-mule}-format files lying around.
-
address@hidden table
-
-(At the moment, this list doesn't include any character sets suitable for
-external use that can actually handle multilingual data; this is
-unfortunate, as it encourages users to write data in Emacs-Mule format,
-which nobody but Emacs and Guile understands. We hope to add support
-for Unicode in UTF-8 soon, which should solve this problem.)
-
-Case is not significant in encoding names.
-
-You can define your own conversions; see @ref{Implementing Your Own Text
-Conversions}.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_have_encoding (const char
address@hidden)
-Return a non-zero value if Guile supports the encoding named @var{encoding}[[]]
address@hidden deftypefn
-
address@hidden {Libguile Function} size_t scm_mb_iconv (struct scm_mb_iconv
address@hidden, const char address@hidden, size_t address@hidden, char
address@hidden, size_t address@hidden)
-Convert a sequence of characters from one encoding to another. The
-argument @var{context} specifies the encodings to use for the input and
-output, and carries state for stateful encodings; use
address@hidden to create a @var{context} object for a
-particular conversion.
-
-Upon entry to the function, @address@hidden should point to the
-input buffer, and @address@hidden should hold the number of
-input bytes present in the buffer; @address@hidden should point to
-the output buffer, and @address@hidden should hold the number
-of bytes available to hold the conversion results in that buffer.
-
-Upon exit from the function, @address@hidden points to the first
-unconsumed byte of input, and @address@hidden holds the number
-of unconsumed input bytes; @address@hidden points to the byte after
-the last output byte, and @address@hidden holds the number of
-bytes left unused in the output buffer.
-
-For stateful encodings, @var{context} carries encoding state from one
-call to @code{scm_mb_iconv} to the next. Thus, successive calls to
address@hidden which use the same context object can convert a
-stream of data one chunk at a time.
-
-If @var{inbuf} is zero or @address@hidden is zero, then the call is
-taken as a request to reset the states of the input and the output
-encodings. If @var{outbuf} is non-zero and @address@hidden is
-non-zero, then @code{scm_mb_iconv} stores a byte sequence in the output
-buffer to put the output encoding in its initial state. If the output
-buffer is not large enough to hold this byte sequence,
address@hidden returns @code{scm_mb_iconv_too_big}, and leaves
-the shift states of @var{context}'s input and output encodings
-unchanged.
-
-The @code{scm_mb_iconv} function always consumes only complete
-characters or shift sequences from the input buffer, and the output
-buffer always contains a sequence of complete characters or escape
-sequences.
-
-If the input sequence contains characters which are not expressible in
-the output encoding, @code{scm_mb_iconv} converts it in an
-implementation-defined way. It may simply delete the character.
-
-Some encodings use byte sequences which do not correspond to any textual
-character. For example, the escape sequence of a stateful encoding has
-no textual meaning. When converting from such an encoding, a call to
address@hidden might consume input but produce no output, since the
-input sequence might contain only escape sequences.
-
-Normally, @code{scm_mb_iconv} returns the number of input characters it
-could not convert perfectly to the ouput encoding. However, it may
-return one of the @code{scm_mb_iconv_} codes described below, to
-indicate an error. All of these codes are negative values.
-
-If the input sequence contains an invalid character encoding, conversion
-stops before the invalid input character, and @code{scm_mb_iconv}
-returns the constant value @code{scm_mb_iconv_bad_encoding}.
-
-If the input sequence ends with an incomplete character encoding,
address@hidden will leave it in the input buffer, unconsumed, and
-return the constant value @code{scm_mb_iconv_incomplete_encoding}. This
-is not necessarily an error, if you expect to call @code{scm_mb_iconv}
-again with more data which might contain the rest of the encoding
-fragment.
-
-If the output buffer does not contain enough room to hold the converted
-form of the complete input text, @code{scm_mb_iconv} converts as much as
-it can, changes the input and output pointers to reflect the amount of
-text successfully converted, and then returns
address@hidden
address@hidden deftypefn
-
-Here are the status codes that might be returned by @code{scm_mb_iconv}.
-They are all negative integers.
address@hidden @code
-
address@hidden scm_mb_iconv_too_big
-The conversion needs more room in the output buffer. Some characters
-may have been consumed from the input buffer, and some characters may
-have been placed in the available space in the output buffer.
-
address@hidden scm_mb_iconv_bad_encoding
address@hidden encountered an invalid character encoding in the
-input buffer. Conversion stopped before the invalid character, so there
-may be some characters consumed from the input buffer, and some
-converted text in the output buffer.
-
address@hidden scm_mb_iconv_incomplete_encoding
-The input buffer ends with an incomplete character encoding. The
-incomplete encoding is left in the input buffer, unconsumed. This is
-not necessarily an error, if you expect to call @code{scm_mb_iconv}
-again with more data which might contain the rest of the incomplete
-encoding.
-
address@hidden table
-
-
-Finally, Guile provides a function for destroying conversion contexts.
-
address@hidden {Libguile Function} void scm_mb_iconv_close (struct scm_mb_iconv
address@hidden)
-Deallocate the conversion context object @var{context}, and all other
-resources allocated by the call to @code{scm_mb_iconv_open} which
-returned @var{context}.
address@hidden deftypefn
-
-
address@hidden Implementing Your Own Text Conversions, , Exchanging Guile Text
With the Outside World in C, Functions for Operating on Multibyte Text
address@hidden Implementing Your Own Text Conversions
-
-[[note that conversions to and from Guile must produce streams
-containing only valid character encodings, or else Guile will crash]]
-
-This section describes the interface for adding your own encoding
-conversions for use with @code{scm_mb_iconv}. The interface here is
-borrowed from the GNOME Project's @file{libunicode} library.
-
-Guile's @code{scm_mb_iconv} function works by converting the input text
-to a stream of @code{scm_char_t} characters, and then converting
-those characters to the desired output encoding. This makes it easy
-for Guile to choose the appropriate conversion back ends for an
-arbitrary pair of input and output encodings, but it also means that the
-accuracy and quality of the conversions depends on the fidelity of
-Guile's internal character set to the source and destination encodings.
-Since @code{scm_mb_iconv} will be used almost exclusively for converting
-to and from Guile's internal character set, this shouldn't be a problem.
-
-To add support for a particular encoding to Guile, you must provide one
-function (called the @dfn{read} function) which converts from your
-encoding to an array of @code{scm_char_t}'s, and another function
-(called the @dfn{write} function) to convert from an array of
address@hidden's back into your encoding. To convert from some
-encoding @var{a} to some other encoding @var{b}, Guile pairs up
address@hidden's read function with @var{b}'s write function. Each call to
address@hidden passes text in encoding @var{a} through the read
-function, to produce an array of @code{scm_char_t}'s, and then passes
-that array to the write function, to produce text in encoding @var{b}.
-
-For stateful encodings, a read or write function can hang its own data
-structures off the conversion object, and provide its own functions to
-allocate and destroy them; this allows read and write functions to
-maintain whatever state they like.
-
-The Guile conversion back end represents each available encoding with a
address@hidden scm_mb_encoding} object.
-
address@hidden {Libguile Type} {struct scm_mb_encoding}
-This data structure describes an encoding. It has the following
-members:
-
address@hidden @code
-
address@hidden char **names
-An array of strings, giving the various names for this encoding. The
-array should be terminated by a zero pointer. Case is not significant
-in encoding names.
-
-The @code{scm_mb_iconv_open} function searches the list of registered
-encodings for an encoding whose @code{names} array matches its
address@hidden or @var{fromcode} argument.
-
address@hidden int (*init) (void address@hidden)
-An initialization function for the encoding's private data.
address@hidden will call this function, passing it the address
-of the cookie for this encoding in this context. (We explain cookies
-below.) There is no way for the @code{init} function to tell whether
-the encoding will be used for reading or writing.
-
-Note that @code{init} receives a @emph{pointer} to the cookie, not the
-cookie itself. Because the type of @var{cookie} is @code{void **}, the
-C compiler will not check it as carefully as it would other types.
-
-The @code{init} member may be zero, indicating that no initialization is
-necessary for this encoding.
-
address@hidden int (*destroy) (void address@hidden)
-A deallocation function for the encoding's private data.
address@hidden calls this function, passing it the address of
-the cookie for this encoding in this context. The @code{destroy}
-function should free any data the @code{init} function allocated.
-
-Note that @code{destroy} receives a @emph{pointer} to the cookie, not the
-cookie itself. Because the type of @var{cookie} is @code{void **}, the
-C compiler will not check it as carefully as it would other types.
-
-The @code{destroy} member may be zero, indicating that this encoding
-doesn't need to perform any special action to destroy its local data.
-
address@hidden int (*reset) (void address@hidden, char address@hidden, size_t
address@hidden)
-Put the encoding into its initial shift state. Guile calls this
-function whether the encoding is being used for input or output, so this
-should take appropriate steps for both directions. If @var{outbuf} and
address@hidden are valid, the reset function should emit an escape
-sequence to reset the output stream to its initial state; @var{outbuf}
-and @var{outbytesleft} should be handled just as for
address@hidden
-
-This function can return an @code{scm_mb_iconv_} error code
-(@pxref{Exchanging Guile Text With the Outside World in C}). If it
-returns @code{scm_mb_iconv_too_big}, then the output buffer's shift
-state must be left unchanged.
-
-Note that @code{reset} receives the cookie's value itself, not a pointer
-to the cookie, as the @code{init} and @code{destroy} functions do.
-
-The @code{reset} member may be zero, indicating that this encoding
-doesn't use a shift state.
-
address@hidden enum scm_mb_read_result (*read) (void address@hidden, const char
address@hidden, size_t address@hidden, scm_char_t address@hidden, size_t
address@hidden)
-Read some bytes and convert into an array of Guile characters. This is
-the encoding's read function.
-
-On entry, there are address@hidden bytes of text at address@hidden to
-be converted, and address@hidden characters available at
address@hidden to hold the results.
-
-On exit, address@hidden and address@hidden indicate the input bytes
-still not consumed. address@hidden and address@hidden indicate the
-output buffer space still not filled. (By exclusion, these indicate
-which input bytes were consumed, and which output characters were
-produced.)
-
-Return one of the @code{enum scm_mb_read_result} values, described below.
-
-Note that @code{read} receives the cookie's value itself, not a pointer
-to the cookie, as the @code{init} and @code{destroy} functions do.
-
address@hidden enum scm_mb_write_result (*write) (void address@hidden,
scm_char_t address@hidden, size_t address@hidden, address@hidden, size_t
address@hidden)
-Convert an array of Guile characters to output bytes. This is
-the encoding's write function.
-
-On entry, there are address@hidden Guile characters available at
address@hidden, and address@hidden bytes available to store output at
address@hidden
-
-On exit, address@hidden and address@hidden indicate the number of
-Guile characters left unconverted (because there was insufficient room
-in the output buffer to hold their converted forms), and
address@hidden and address@hidden indicate the unused portion of the
-output buffer.
-
-Return one of the @code{scm_mb_write_result} values, described below.
-
-Note that @code{write} receives the cookie's value itself, not a pointer
-to the cookie, as the @code{init} and @code{destroy} functions do.
-
address@hidden struct scm_mb_encoding *next
-This is used by Guile to maintain a linked list of encodings. It is
-filled in when you call @code{scm_mb_register_encoding} to add your
-encoding to the list.
-
address@hidden table
address@hidden deftp
-
-Here is the enumerated type for the values an encoding's read function
-can return:
-
address@hidden {Libguile Type} {enum scm_mb_read_result}
-This type represents the result of a call to an encoding's read
-function. It has the following values:
-
address@hidden @code
-
address@hidden scm_mb_read_ok
-The read function consumed at least one byte of input.
-
address@hidden scm_mb_read_incomplete
-The data present in the input buffer does not contain a complete
-character encoding. No input was consumed, and no characters were
-produced as output. This is not necessarily an error status, if there
-is more data to pass through.
-
address@hidden scm_mb_read_error
-The input contains an invalid character encoding.
-
address@hidden table
address@hidden deftp
-
-Here is the enumerated type for the values an encoding's write function
-can return:
-
address@hidden {Libguile Type} {enum scm_mb_write_result}
-This type represents the result of a call to an encoding's write
-function. It has the following values:
-
address@hidden @code
-
address@hidden scm_mb_write_ok
-The write function was able to convert all the characters in @var{inbuf}
-successfully.
-
address@hidden scm_mb_write_too_big
-The write function filled the output buffer, but there are still
-characters in @var{inbuf} left unconsumed; @var{inbuf} and
address@hidden indicate the unconsumed portion of the input buffer.
-
address@hidden table
address@hidden deftp
-
-
-Conversions to or from stateful encodings need to keep track of each
-encoding's current state. Each conversion context contains two
address@hidden *} variables called @dfn{cookies}, one for the input
-encoding, and one for the output encoding. These cookies are passed to
-the encodings' functions, for them to use however they please. A
-stateful encoding can use its cookie to hold a pointer to some object
-which maintains the context's current shift state. Stateless encodings
-will probably not use their cookies.
-
-The cookies' lifetime is the same as that of the context object. When
-the user calls @code{scm_mb_iconv_close} to destroy a context object,
address@hidden calls the input and output encodings'
address@hidden functions, passing them their respective cookies, so each
-encoding can free any data it allocated for that context.
-
-Note that, if a read or write function returns a successful result code
-like @code{scm_mb_read_ok} or @code{scm_mb_write_ok}, then the remaining
-input, together with the output, must together represent the complete
-input text; the encoding may not store any text temporarily in its
-cookie. This is because, if @code{scm_mb_iconv} returns a successful
-result to the user, it is correct for the user to assume that all the
-consumed input has been converted and placed in the output buffer.
-There is no ``flush'' operation to push any final results out of the
-encodings' buffers.
-
-Here is the function you call to register a new encoding with the
-conversion system:
-
address@hidden {Libguile Function} void scm_mb_register_encoding (struct
scm_mb_encoding address@hidden)
-Add the encoding described by @address@hidden to the set
-understood by @code{scm_mb_iconv_open}. Once you have registered your
-encoding, you can use it by calling @code{scm_mb_iconv_open} with one of
-the names in @address@hidden>names}.
address@hidden deftypefn
-
-
address@hidden Multibyte Text Processing Errors, Why Guile Does Not Use a
Fixed-Width Encoding, Functions for Operating on Multibyte Text, Working With
Multibyte Strings in C
address@hidden Multibyte Text Processing Errors
-
-This section describes error conditions which code can signal to
-indicate problems encountered while processing multibyte text. In each
-case, the arguments @var{message} and @var{args} are an error format
-string and arguments to be substituted into the string, as accepted by
-the @code{display-error} function.
-
address@hidden Condition text:not-char-boundary func message args object offset
-By calling @var{func}, the program attempted to access a character at
-byte offset @var{offset} in the Guile object @var{object}, but
address@hidden is not the start of a character's encoding in @var{object}.
-
-Typically, @var{object} is a string or symbol. If the function signalling
-the error cannot find the Guile object that contains the text it is
-inspecting, it should use @code{#f} for @var{object}.
address@hidden deffn
-
address@hidden Condition text:bad-encoding func message args object
-By calling @var{func}, the program attempted to interpret the text in
address@hidden, but @var{object} contains a byte sequence which is not a
-valid encoding for any character.
address@hidden deffn
-
address@hidden Condition text:not-guile-char func message args number
-By calling @var{func}, the program attempted to treat @var{number} as the
-number of a character in the Guile character set, but @var{number} does
-not correspond to any character in the Guile character set.
address@hidden deffn
-
address@hidden Condition text:unknown-conversion func message args from to
-By calling @var{func}, the program attempted to convert from an encoding
-named @var{from} to an encoding named @var{to}, but Guile does not
-support such a conversion.
address@hidden deffn
-
address@hidden {Libguile Variable} SCM scm_text_not_char_boundary
address@hidden {Libguile Variable} SCM scm_text_bad_encoding
address@hidden {Libguile Variable} SCM scm_text_not_guile_char
-These variables hold the scheme symbol objects whose names are the
-condition symbols above. You can use these when signalling these
-errors, instead of looking them up yourself.
address@hidden deftypevr
-
-
address@hidden Why Guile Does Not Use a Fixed-Width Encoding, , Multibyte Text
Processing Errors, Working With Multibyte Strings in C
address@hidden Why Guile Does Not Use a Fixed-Width Encoding
-
-Multibyte encodings are clumsier to work with than encodings which use a
-fixed number of bytes for every character. For example, using a
-fixed-width encoding, we can extract the @var{i}th character of a string
-in constant time, and we can always substitute the @var{i}th character
-of a string with any other character without reallocating or copying the
-string.
-
-However, there are no fixed-width encodings which include the characters
-we wish to include, and also fit in a reasonable amount of space.
-Despite the Unicode standard's claims to the contrary, Unicode is not
-really a fixed-width encoding. Unicode uses surrogate pairs to
-represent characters outside the 16-bit range; a surrogate pair must be
-treated as a single character, but occupies two 16-bit spaces. As of
-this writing, there are already plans to assign characters to the
-surrogate character codes. Three- and four-byte encodings are
-too wasteful for a majority of Guile's users, who only need @sc{ASCII}
-and a few accented characters.
-
-Another alternative would be to have several different fixed-width
-string representations, each with a different element size. For each
-string, Guile would use the smallest element size capable of
-accomodating the string's text. This would allow users of English and
-the Western European languages to use the traditional memory-efficient
-encodings. However, if Guile has @var{n} string representations, then
-users must write @var{n} versions of any code which manipulates text
-directly --- one for each element size. And if a user wants to operate
-on two strings simultaneously, and wants to avoid testing the string
-sizes within the loop, she must make @address@hidden copies of the loop.
-Most users will simply not bother. Instead, they will write code which
-supports only one string size, leaving us back where we started. By
-using a single internal representation, Guile makes it easier for users
-to write multilingual code.
-
-[[What about tagging each string with its encoding?
-"Every extension must be written to deal with every encoding"]]
-
-[[You don't really want to index strings anyway.]]
-
-Finally, Guile's multibyte encoding is not so bad. Unlike a two- or
-four-byte encoding, it is efficient in space for American and European
-users. Furthermore, the properties described above mean that many
-functions can be coded just as they would for a single-byte encoding;
-see @ref{Promised Properties of the Guile Multibyte Encoding}.
-
address@hidden
diff --git a/doc/mltext.texi b/doc/mltext.texi
deleted file mode 100644
index 73071f5..0000000
--- a/doc/mltext.texi
+++ /dev/null
@@ -1,146 +0,0 @@
address@hidden Working with Multilingual Text
address@hidden Working with Multilingual Text
-
address@hidden Guile Character Properties, Exchanging Text With The Outside
World, Multibyte String Functions, Functions for Operating on Multibyte Text
address@hidden Guile Character Properties
-
-These functions give information about the nature of a given Guile
-character. These are defined for any @code{scm_mb_char_t} value.
-
address@hidden {Libguile Function} int scm_mb_isalnum (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is an alphabetic or numeric character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_is_alpha (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is an alphabetic character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_iscntrl (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a control character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isdigit (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a digit.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isgraph (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a visible character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isupper (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is an upper-case character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_islower (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a lower-case character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_istitle (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a title-case character. See the Unicode
-standard for an explanation of title case.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isprint (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a printable character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_ispunct (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a punctuation character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isspace (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a whitespace character.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isxdigit (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a hexadecimal digit.
address@hidden deftypefn
-
address@hidden {Libguile Function} int scm_mb_isdefined (scm_mb_char_t @var{c})
-Return non-zero iff @var{c} is a valid character.
address@hidden deftypefn
-
address@hidden {Libguile Function} scm_mb_char_t scm_mb_char_toupper
(scm_mb_char_t @var{c})
address@hidden {Libguile Function} scm_mb_char_t scm_mb_char_tolower
(scm_mb_char_t @var{c})
address@hidden {Libguile Function} scm_mb_char_t scm_mb_char_totitle
(scm_mb_char_t @var{c})
-Convert @var{c} to upper, lower, or title case. If @var{c} has no
-equivalent in the requested case, or is already in that case, return it
-unchanged.
address@hidden deftypefn
-
address@hidden {Libguile Function} in scm_mb_digit_value (scm_mb_char_t @var{c})
-If @var{c} is a hexadecimal digit (according to
address@hidden), then return its numeric value. Otherwise
-return -1.
address@hidden deftypefn
-
address@hidden {Libguile Function} in scm_mb_digit_value (scm_mb_char_t @var{c})
-If @var{c} is a digit (according to @code{scm_mb_isdigit}), then
-return its numeric value. Otherwise return -1.
address@hidden deftypefn
-
-
address@hidden Multibyte Character Tables, Multibyte Character Categories,
Exchanging Text With The Outside World, Functions for Operating on Multibyte
Text
address@hidden Multibyte Character Tables
-
-A @dfn{character table} is a table mapping @code{scm_mb_char_t} values
-onto Guile objects. Guile provides functions for creating character
-tables, setting entries, and looking up characters. Character tables
-are Guile objects, so they are managed by Guile's garbage collector.
-
-A character table can have a ``parent'' table, from which it inherits
-values for characters. If a character table @var{child}, with a parent
-table @var{parent} maps some character @var{c} to the value
address@hidden, then @code{scm_c_char_table_ref (@var{child},
address@hidden)} will look up @var{c} in @var{parent}, and return the value it
-finds there.
-
-This section describes only the C API for working with character tables.
-For the Scheme-level API, see @ref{some other section}.
-
address@hidden {Libguile Function} scm_make_char_table (SCM @var{init}, SCM
@var{parent})
-Return a new character table object which maps every character to
address@hidden If @var{parent} is a character table, then @var{parent} is
-the new table's parent. If @var{parent} table is @code{SCM_UNDEFINED},
-then the new table has no parent. Otherwise, signal a type error.
address@hidden deffn
-
address@hidden {Libguile Function} SCM scm_c_char_table_ref (SCM @var{table},
scm_mb_char_t @var{c})
-Look up the character @var{c} in the character table @var{table}, and
-return the value found there. If @var{table} maps @var{c} to
address@hidden, and @var{table} has a parent, then look up @var{c}
-in the parent.
-
-If @var{table} is not a character table, signal an error.
address@hidden deftypefn
-
address@hidden {Libguile Function} SCM scm_c_char_table_set_x (SCM @var{table},
scm_mb_char_t @var{c}, SCM @var{value})
-Set @var{table}'s value for the character @var{c} to @var{value}.
-If @var{value} is @code{SCM_UNDEFINED}, then @var{table}'s parent's
-value will show through for @var{c}.
-
-If @var{table} is not a character table, signal an error.
-
-This function changes only @var{table} itself, never @var{table}'s
-parent.
address@hidden deftypefn
-
-[[this is all wrong. what about default values?]]
-
-
-
-
-
address@hidden Multibyte Character Categories, , Multibyte Character Tables,
Functions for Operating on Multibyte Text
address@hidden Multibyte Character Categories
-
-[[This will describe an ADT representing subsets of the Guile character
-set.]]
-
-
-
-
address@hidden Exchanging Guile Text With the Outside World
address@hidden Exchanging Guile Text With the Outside World
-
-[[Scheme-level functions for converting between encodings]]
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index e201198..16cf7a2 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc.
+## Copyright (C) 1998, 2004, 2006, 2008, 2009, 2010 Free Software
Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -21,7 +21,7 @@
AUTOMAKE_OPTIONS = gnu
-BUILT_SOURCES = lib-version.texi
+BUILT_SOURCES = lib-version.texi standard-library.texi
info_TEXINFOS = guile.texi
@@ -35,10 +35,13 @@ guile_TEXINFOS = preface.texi \
scheme-ideas.texi \
api-data.texi \
api-procedures.texi \
+ api-macros.texi \
api-utility.texi \
api-binding.texi \
api-control.texi \
api-io.texi \
+ api-foreign.texi \
+ api-lalr.texi \
api-evaluation.texi \
api-memory.texi \
api-modules.texi \
@@ -128,3 +131,30 @@ EXTRA_DIST += lib-version.texi
# But when we want to get back to a clean tree, lib-version.texi
# should be cleaned.
CLEANFILES = lib-version.texi
+
+# Support for snarfing docs out of Scheme modules.
+snarf_doc = standard-library
+
+$(snarf_doc).am: $(snarf_doc).scm
+ GUILE_AUTO_COMPILE=0 ;
\
+ variable="`echo $(snarf_doc) | tr - _`_scm_files" ;
\
+ "$(preinstguile)" -l "$(srcdir)/$(snarf_doc).scm" -c "
\
+ (format #t \"# Automatically generated, do not edit.~%\")
\
+ (format #t \"$$variable = \")
\
+ (for-each (lambda (m)
\
+ (format #t \"$$""(top_srcdir)/module/~a.scm \"
\
+ (string-join (map symbol->string m) \"/\")))
\
+ (map car *modules*))" > "address@hidden"
+ mv "address@hidden" "$@"
+
+# The following line leads to the definition of $(standard_library_scm_files).
+include standard-library.am
+
+$(snarf_doc).texi: $(standard_library_scm_files)
+ GUILE_AUTO_COMPILE=0 \
+ "$(preinstguile)" "$(srcdir)/make-texinfo.scm" \
+ "$(abs_srcdir)/$(snarf_doc).scm" > "address@hidden"
+ mv "address@hidden" "$@"
+
+CLEANFILES += $(snarf_doc).texi
+EXTRA_DIST += $(snarf_doc).scm make-texinfo.scm $(snarf_doc).texi
$(snarf_doc).am
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 7709184..93d930f 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.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, 2005,
2006, 2007, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -21,14 +21,15 @@ values can be looked up within them.
* Pairs:: Scheme's basic building block.
* Lists:: Special list functions supported by Guile.
* Vectors:: One-dimensional arrays of Scheme objects.
-* Uniform Numeric Vectors:: Vectors with elements of a single numeric type.
* Bit Vectors:: Vectors of bits.
* Generalized Vectors:: Treating all vector-like things uniformly.
* Arrays:: Matrices, etc.
+* VLists:: Vector-like lists.
* Records::
* Structures::
* Dictionary Types:: About dictionary types in general.
* Association Lists:: List-based dictionaries.
+* VHashes:: VList-based dictionaries.
* Hash Tables:: Table-based dictionaries.
@end menu
@@ -670,6 +671,7 @@ and that most array procedures operate happily on vectors
* Vector Creation:: Dynamic vector creation and validation.
* Vector Accessors:: Accessing and modifying vector contents.
* Vector Accessing from C:: Ways to work with vectors from C.
+* Uniform Numeric Vectors:: Vectors of unboxed numeric values.
@end menu
@@ -958,508 +960,17 @@ scm_array_handle_release (&handle);
@end deftypefn
@node Uniform Numeric Vectors
address@hidden Uniform Numeric Vectors
address@hidden Uniform Numeric Vectors
A uniform numeric vector is a vector whose elements are all of a single
numeric type. Guile offers uniform numeric vectors for signed and
unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of
floating point values, and complex floating-point numbers of these two
-sizes.
-
-Strings could be regarded as uniform vectors of characters,
address@hidden Likewise, bit vectors could be regarded as uniform
-vectors of bits, @xref{Bit Vectors}. Both are sufficiently different
-from uniform numeric vectors that the procedures described here do not
-apply to these two data types. However, both strings and bit vectors
-are generalized vectors, @xref{Generalized Vectors}, and arrays,
address@hidden
-
-Uniform numeric vectors are the special case of one dimensional uniform
-numeric arrays.
-
-Uniform numeric vectors can be useful since they consume less memory
-than the non-uniform, general vectors. Also, since the types they can
-store correspond directly to C types, it is easier to work with them
-efficiently on a low level. Consider image processing as an example,
-where you want to apply a filter to some image. While you could store
-the pixels of an image in a general vector and write a general
-convolution function, things are much more efficient with uniform
-vectors: the convolution function knows that all pixels are unsigned
-8-bit values (say), and can use a very tight inner loop.
-
-That is, when it is written in C. Functions for efficiently working
-with uniform numeric vectors from C are listed at the end of this
-section.
-
-Procedures similar to the vector procedures (@pxref{Vectors}) are
-provided for handling these uniform vectors, but they are distinct
-datatypes and the two cannot be inter-mixed. If you want to work
-primarily with uniform numeric vectors, but want to offer support for
-general vectors as a convenience, you can use one of the
address@hidden functions. They will coerce lists and vectors to
-the given type of uniform vector. Alternatively, you can write two
-versions of your code: one that is fast and works only with uniform
-numeric vectors, and one that works with any kind of vector but is
-slower.
-
-One set of the procedures listed below is a generic one: it works with
-all types of uniform numeric vectors. In addition to that, there is a
-set of procedures for each type that only works with that type. Unless
-you really need to the generality of the first set, it is best to use
-the more specific functions. They might not be that much faster, but
-their use can serve as a kind of declaration and makes it easier to
-optimize later on.
-
-The generic set of procedures uses @code{uniform} in its names, the
-specific ones use the tag from the following table.
-
address@hidden @nicode
address@hidden u8
-unsigned 8-bit integers
-
address@hidden s8
-signed 8-bit integers
-
address@hidden u16
-unsigned 16-bit integers
-
address@hidden s16
-signed 16-bit integers
-
address@hidden u32
-unsigned 32-bit integers
-
address@hidden s32
-signed 32-bit integers
-
address@hidden u64
-unsigned 64-bit integers
-
address@hidden s64
-signed 64-bit integers
-
address@hidden f32
-the C type @code{float}
-
address@hidden f64
-the C type @code{double}
-
address@hidden c32
-complex numbers in rectangular form with the real and imaginary part
-being a @code{float}
-
address@hidden c64
-complex numbers in rectangular form with the real and imaginary part
-being a @code{double}
-
address@hidden table
-
-The external representation (ie.@: read syntax) for these vectors is
-similar to normal Scheme vectors, but with an additional tag from the
-table above indicating the vector's type. For example,
-
address@hidden
-#u16(1 2 3)
-#f64(3.1415 2.71)
address@hidden lisp
-
-Note that the read syntax for floating-point here conflicts with
address@hidden for false. In Standard Scheme one can write @code{(1 #f3)}
-for a three element list @code{(1 #f 3)}, but for Guile @code{(1 #f3)}
-is invalid. @code{(1 #f 3)} is almost certainly what one should write
-anyway to make the intention clear, so this is rarely a problem.
-
address@hidden {Scheme Procedure} uniform-vector? obj
address@hidden {Scheme Procedure} u8vector? obj
address@hidden {Scheme Procedure} s8vector? obj
address@hidden {Scheme Procedure} u16vector? obj
address@hidden {Scheme Procedure} s16vector? obj
address@hidden {Scheme Procedure} u32vector? obj
address@hidden {Scheme Procedure} s32vector? obj
address@hidden {Scheme Procedure} u64vector? obj
address@hidden {Scheme Procedure} s64vector? obj
address@hidden {Scheme Procedure} f32vector? obj
address@hidden {Scheme Procedure} f64vector? obj
address@hidden {Scheme Procedure} c32vector? obj
address@hidden {Scheme Procedure} c64vector? obj
address@hidden {C Function} scm_uniform_vector_p (obj)
address@hidden {C Function} scm_u8vector_p (obj)
address@hidden {C Function} scm_s8vector_p (obj)
address@hidden {C Function} scm_u16vector_p (obj)
address@hidden {C Function} scm_s16vector_p (obj)
address@hidden {C Function} scm_u32vector_p (obj)
address@hidden {C Function} scm_s32vector_p (obj)
address@hidden {C Function} scm_u64vector_p (obj)
address@hidden {C Function} scm_s64vector_p (obj)
address@hidden {C Function} scm_f32vector_p (obj)
address@hidden {C Function} scm_f64vector_p (obj)
address@hidden {C Function} scm_c32vector_p (obj)
address@hidden {C Function} scm_c64vector_p (obj)
-Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
-indicated type.
address@hidden deffn
-
address@hidden {Scheme Procedure} make-u8vector n [value]
address@hidden {Scheme Procedure} make-s8vector n [value]
address@hidden {Scheme Procedure} make-u16vector n [value]
address@hidden {Scheme Procedure} make-s16vector n [value]
address@hidden {Scheme Procedure} make-u32vector n [value]
address@hidden {Scheme Procedure} make-s32vector n [value]
address@hidden {Scheme Procedure} make-u64vector n [value]
address@hidden {Scheme Procedure} make-s64vector n [value]
address@hidden {Scheme Procedure} make-f32vector n [value]
address@hidden {Scheme Procedure} make-f64vector n [value]
address@hidden {Scheme Procedure} make-c32vector n [value]
address@hidden {Scheme Procedure} make-c64vector n [value]
address@hidden {C Function} scm_make_u8vector n [value]
address@hidden {C Function} scm_make_s8vector n [value]
address@hidden {C Function} scm_make_u16vector n [value]
address@hidden {C Function} scm_make_s16vector n [value]
address@hidden {C Function} scm_make_u32vector n [value]
address@hidden {C Function} scm_make_s32vector n [value]
address@hidden {C Function} scm_make_u64vector n [value]
address@hidden {C Function} scm_make_s64vector n [value]
address@hidden {C Function} scm_make_f32vector n [value]
address@hidden {C Function} scm_make_f64vector n [value]
address@hidden {C Function} scm_make_c32vector n [value]
address@hidden {C Function} scm_make_c64vector n [value]
-Return a newly allocated homogeneous numeric vector holding @var{n}
-elements of the indicated type. If @var{value} is given, the vector
-is initialized with that value, otherwise the contents are
-unspecified.
address@hidden deffn
-
address@hidden {Scheme Procedure} u8vector value @dots{}
address@hidden {Scheme Procedure} s8vector value @dots{}
address@hidden {Scheme Procedure} u16vector value @dots{}
address@hidden {Scheme Procedure} s16vector value @dots{}
address@hidden {Scheme Procedure} u32vector value @dots{}
address@hidden {Scheme Procedure} s32vector value @dots{}
address@hidden {Scheme Procedure} u64vector value @dots{}
address@hidden {Scheme Procedure} s64vector value @dots{}
address@hidden {Scheme Procedure} f32vector value @dots{}
address@hidden {Scheme Procedure} f64vector value @dots{}
address@hidden {Scheme Procedure} c32vector value @dots{}
address@hidden {Scheme Procedure} c64vector value @dots{}
address@hidden {C Function} scm_u8vector (values)
address@hidden {C Function} scm_s8vector (values)
address@hidden {C Function} scm_u16vector (values)
address@hidden {C Function} scm_s16vector (values)
address@hidden {C Function} scm_u32vector (values)
address@hidden {C Function} scm_s32vector (values)
address@hidden {C Function} scm_u64vector (values)
address@hidden {C Function} scm_s64vector (values)
address@hidden {C Function} scm_f32vector (values)
address@hidden {C Function} scm_f64vector (values)
address@hidden {C Function} scm_c32vector (values)
address@hidden {C Function} scm_c64vector (values)
-Return a newly allocated homogeneous numeric vector of the indicated
-type, holding the given parameter @var{value}s. The vector length is
-the number of parameters given.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-length vec
address@hidden {Scheme Procedure} u8vector-length vec
address@hidden {Scheme Procedure} s8vector-length vec
address@hidden {Scheme Procedure} u16vector-length vec
address@hidden {Scheme Procedure} s16vector-length vec
address@hidden {Scheme Procedure} u32vector-length vec
address@hidden {Scheme Procedure} s32vector-length vec
address@hidden {Scheme Procedure} u64vector-length vec
address@hidden {Scheme Procedure} s64vector-length vec
address@hidden {Scheme Procedure} f32vector-length vec
address@hidden {Scheme Procedure} f64vector-length vec
address@hidden {Scheme Procedure} c32vector-length vec
address@hidden {Scheme Procedure} c64vector-length vec
address@hidden {C Function} scm_uniform_vector_length (vec)
address@hidden {C Function} scm_u8vector_length (vec)
address@hidden {C Function} scm_s8vector_length (vec)
address@hidden {C Function} scm_u16vector_length (vec)
address@hidden {C Function} scm_s16vector_length (vec)
address@hidden {C Function} scm_u32vector_length (vec)
address@hidden {C Function} scm_s32vector_length (vec)
address@hidden {C Function} scm_u64vector_length (vec)
address@hidden {C Function} scm_s64vector_length (vec)
address@hidden {C Function} scm_f32vector_length (vec)
address@hidden {C Function} scm_f64vector_length (vec)
address@hidden {C Function} scm_c32vector_length (vec)
address@hidden {C Function} scm_c64vector_length (vec)
-Return the number of elements in @var{vec}.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-ref vec i
address@hidden {Scheme Procedure} u8vector-ref vec i
address@hidden {Scheme Procedure} s8vector-ref vec i
address@hidden {Scheme Procedure} u16vector-ref vec i
address@hidden {Scheme Procedure} s16vector-ref vec i
address@hidden {Scheme Procedure} u32vector-ref vec i
address@hidden {Scheme Procedure} s32vector-ref vec i
address@hidden {Scheme Procedure} u64vector-ref vec i
address@hidden {Scheme Procedure} s64vector-ref vec i
address@hidden {Scheme Procedure} f32vector-ref vec i
address@hidden {Scheme Procedure} f64vector-ref vec i
address@hidden {Scheme Procedure} c32vector-ref vec i
address@hidden {Scheme Procedure} c64vector-ref vec i
address@hidden {C Function} scm_uniform_vector_ref (vec i)
address@hidden {C Function} scm_u8vector_ref (vec i)
address@hidden {C Function} scm_s8vector_ref (vec i)
address@hidden {C Function} scm_u16vector_ref (vec i)
address@hidden {C Function} scm_s16vector_ref (vec i)
address@hidden {C Function} scm_u32vector_ref (vec i)
address@hidden {C Function} scm_s32vector_ref (vec i)
address@hidden {C Function} scm_u64vector_ref (vec i)
address@hidden {C Function} scm_s64vector_ref (vec i)
address@hidden {C Function} scm_f32vector_ref (vec i)
address@hidden {C Function} scm_f64vector_ref (vec i)
address@hidden {C Function} scm_c32vector_ref (vec i)
address@hidden {C Function} scm_c64vector_ref (vec i)
-Return the element at index @var{i} in @var{vec}. The first element
-in @var{vec} is index 0.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-set! vec i value
address@hidden {Scheme Procedure} u8vector-set! vec i value
address@hidden {Scheme Procedure} s8vector-set! vec i value
address@hidden {Scheme Procedure} u16vector-set! vec i value
address@hidden {Scheme Procedure} s16vector-set! vec i value
address@hidden {Scheme Procedure} u32vector-set! vec i value
address@hidden {Scheme Procedure} s32vector-set! vec i value
address@hidden {Scheme Procedure} u64vector-set! vec i value
address@hidden {Scheme Procedure} s64vector-set! vec i value
address@hidden {Scheme Procedure} f32vector-set! vec i value
address@hidden {Scheme Procedure} f64vector-set! vec i value
address@hidden {Scheme Procedure} c32vector-set! vec i value
address@hidden {Scheme Procedure} c64vector-set! vec i value
address@hidden {C Function} scm_uniform_vector_set_x (vec i value)
address@hidden {C Function} scm_u8vector_set_x (vec i value)
address@hidden {C Function} scm_s8vector_set_x (vec i value)
address@hidden {C Function} scm_u16vector_set_x (vec i value)
address@hidden {C Function} scm_s16vector_set_x (vec i value)
address@hidden {C Function} scm_u32vector_set_x (vec i value)
address@hidden {C Function} scm_s32vector_set_x (vec i value)
address@hidden {C Function} scm_u64vector_set_x (vec i value)
address@hidden {C Function} scm_s64vector_set_x (vec i value)
address@hidden {C Function} scm_f32vector_set_x (vec i value)
address@hidden {C Function} scm_f64vector_set_x (vec i value)
address@hidden {C Function} scm_c32vector_set_x (vec i value)
address@hidden {C Function} scm_c64vector_set_x (vec i value)
-Set the element at index @var{i} in @var{vec} to @var{value}. The
-first element in @var{vec} is index 0. The return value is
-unspecified.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector->list vec
address@hidden {Scheme Procedure} u8vector->list vec
address@hidden {Scheme Procedure} s8vector->list vec
address@hidden {Scheme Procedure} u16vector->list vec
address@hidden {Scheme Procedure} s16vector->list vec
address@hidden {Scheme Procedure} u32vector->list vec
address@hidden {Scheme Procedure} s32vector->list vec
address@hidden {Scheme Procedure} u64vector->list vec
address@hidden {Scheme Procedure} s64vector->list vec
address@hidden {Scheme Procedure} f32vector->list vec
address@hidden {Scheme Procedure} f64vector->list vec
address@hidden {Scheme Procedure} c32vector->list vec
address@hidden {Scheme Procedure} c64vector->list vec
address@hidden {C Function} scm_uniform_vector_to_list (vec)
address@hidden {C Function} scm_u8vector_to_list (vec)
address@hidden {C Function} scm_s8vector_to_list (vec)
address@hidden {C Function} scm_u16vector_to_list (vec)
address@hidden {C Function} scm_s16vector_to_list (vec)
address@hidden {C Function} scm_u32vector_to_list (vec)
address@hidden {C Function} scm_s32vector_to_list (vec)
address@hidden {C Function} scm_u64vector_to_list (vec)
address@hidden {C Function} scm_s64vector_to_list (vec)
address@hidden {C Function} scm_f32vector_to_list (vec)
address@hidden {C Function} scm_f64vector_to_list (vec)
address@hidden {C Function} scm_c32vector_to_list (vec)
address@hidden {C Function} scm_c64vector_to_list (vec)
-Return a newly allocated list holding all elements of @var{vec}.
address@hidden deffn
-
address@hidden {Scheme Procedure} list->u8vector lst
address@hidden {Scheme Procedure} list->s8vector lst
address@hidden {Scheme Procedure} list->u16vector lst
address@hidden {Scheme Procedure} list->s16vector lst
address@hidden {Scheme Procedure} list->u32vector lst
address@hidden {Scheme Procedure} list->s32vector lst
address@hidden {Scheme Procedure} list->u64vector lst
address@hidden {Scheme Procedure} list->s64vector lst
address@hidden {Scheme Procedure} list->f32vector lst
address@hidden {Scheme Procedure} list->f64vector lst
address@hidden {Scheme Procedure} list->c32vector lst
address@hidden {Scheme Procedure} list->c64vector lst
address@hidden {C Function} scm_list_to_u8vector (lst)
address@hidden {C Function} scm_list_to_s8vector (lst)
address@hidden {C Function} scm_list_to_u16vector (lst)
address@hidden {C Function} scm_list_to_s16vector (lst)
address@hidden {C Function} scm_list_to_u32vector (lst)
address@hidden {C Function} scm_list_to_s32vector (lst)
address@hidden {C Function} scm_list_to_u64vector (lst)
address@hidden {C Function} scm_list_to_s64vector (lst)
address@hidden {C Function} scm_list_to_f32vector (lst)
address@hidden {C Function} scm_list_to_f64vector (lst)
address@hidden {C Function} scm_list_to_c32vector (lst)
address@hidden {C Function} scm_list_to_c64vector (lst)
-Return a newly allocated homogeneous numeric vector of the indicated type,
-initialized with the elements of the list @var{lst}.
address@hidden deffn
-
address@hidden {Scheme Procedure} any->u8vector obj
address@hidden {Scheme Procedure} any->s8vector obj
address@hidden {Scheme Procedure} any->u16vector obj
address@hidden {Scheme Procedure} any->s16vector obj
address@hidden {Scheme Procedure} any->u32vector obj
address@hidden {Scheme Procedure} any->s32vector obj
address@hidden {Scheme Procedure} any->u64vector obj
address@hidden {Scheme Procedure} any->s64vector obj
address@hidden {Scheme Procedure} any->f32vector obj
address@hidden {Scheme Procedure} any->f64vector obj
address@hidden {Scheme Procedure} any->c32vector obj
address@hidden {Scheme Procedure} any->c64vector obj
address@hidden {C Function} scm_any_to_u8vector (obj)
address@hidden {C Function} scm_any_to_s8vector (obj)
address@hidden {C Function} scm_any_to_u16vector (obj)
address@hidden {C Function} scm_any_to_s16vector (obj)
address@hidden {C Function} scm_any_to_u32vector (obj)
address@hidden {C Function} scm_any_to_s32vector (obj)
address@hidden {C Function} scm_any_to_u64vector (obj)
address@hidden {C Function} scm_any_to_s64vector (obj)
address@hidden {C Function} scm_any_to_f32vector (obj)
address@hidden {C Function} scm_any_to_f64vector (obj)
address@hidden {C Function} scm_any_to_c32vector (obj)
address@hidden {C Function} scm_any_to_c64vector (obj)
-Return a (maybe newly allocated) uniform numeric vector of the indicated
-type, initialized with the elements of @var{obj}, which must be a list,
-a vector, or a uniform vector. When @var{obj} is already a suitable
-uniform numeric vector, it is returned unchanged.
address@hidden deffn
-
address@hidden {C Function} int scm_is_uniform_vector (SCM uvec)
-Return non-zero when @var{uvec} is a uniform numeric vector, zero
-otherwise.
address@hidden deftypefn
-
address@hidden {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s8vector (const scm_t_int8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s16vector (const scm_t_int16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s32vector (const scm_t_int32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s64vector (const scm_t_int64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_f32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_f64vector (const double *data, size_t
len)
address@hidden {C Function} SCM scm_take_c32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_c64vector (const double *data, size_t
len)
-Return a new uniform numeric vector of the indicated type and length
-that uses the memory pointed to by @var{data} to store its elements.
-This memory will eventually be freed with @code{free}. The argument
address@hidden specifies the number of elements in @var{data}, not its size
-in bytes.
-
-The @code{c32} and @code{c64} variants take a pointer to a C array of
address@hidden or @code{double}s. The real parts of the complex numbers
-are at even indices in that array, the corresponding imaginary parts are
-at the following odd index.
address@hidden deftypefn
-
address@hidden {C Function} size_t scm_c_uniform_vector_length (SCM uvec)
-Return the number of elements of @var{uvec} as a @code{size_t}.
address@hidden deftypefn
-
address@hidden {C Function} {const void *} scm_uniform_vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint8 *} scm_u8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int8 *} scm_s8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint16 *} scm_u16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int16 *} scm_s16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint32 *} scm_u32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int32 *} scm_s32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint64 *} scm_u64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int64 *} scm_s64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_f23vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_f64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_c32vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_c64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
-Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
-returns a pointer to the elements of a uniform numeric vector of the
-indicated kind.
address@hidden deftypefn
-
address@hidden {C Function} {void *} scm_uniform_vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint8 *} scm_u8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int8 *} scm_s8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint16 *} scm_u16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int16 *} scm_s16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint32 *} scm_u32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int32 *} scm_s32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint64 *} scm_u64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int64 *} scm_s64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_f23vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_f64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_c32vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_c64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
-Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
-C}), but returns a pointer to the elements of a uniform numeric vector
-of the indicated kind.
address@hidden deftypefn
-
-Uniform numeric vectors can be written to and read from input/output
-ports using the procedures listed below. However, bytevectors may often
-be more convenient for binary input/output since they provide more
-flexibility in the interpretation of raw byte sequences
-(@pxref{Bytevectors}).
-
address@hidden {Scheme Procedure} uniform-vector-read! uvec [port_or_fd [start
[end]]]
address@hidden {C Function} scm_uniform_vector_read_x (uvec, port_or_fd, start,
end)
-Fill the elements of @var{uvec} by reading
-raw bytes from @var{port-or-fdes}, using host byte order.
-
-The optional arguments @var{start} (inclusive) and @var{end}
-(exclusive) allow a specified region to be read,
-leaving the remainder of the vector unchanged.
-
-When @var{port-or-fdes} is a port, all specified elements
-of @var{uvec} are attempted to be read, potentially blocking
-while waiting formore input or end-of-file.
-When @var{port-or-fd} is an integer, a single call to
-read(2) is made.
-
-An error is signalled when the last element has only
-been partially filled before reaching end-of-file or in
-the single call to read(2).
-
address@hidden returns the number of elements
-read.
-
address@hidden may be omitted, in which case it defaults
-to the value returned by @code{(current-input-port)}.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-write uvec [port_or_fd [start
[end]]]
address@hidden {C Function} scm_uniform_vector_write (uvec, port_or_fd, start,
end)
-Write the elements of @var{uvec} as raw bytes to
address@hidden, in the host byte order.
-
-The optional arguments @var{start} (inclusive)
-and @var{end} (exclusive) allow
-a specified region to be written.
-
-When @var{port-or-fdes} is a port, all specified elements
-of @var{uvec} are attempted to be written, potentially blocking
-while waiting for more room.
-When @var{port-or-fd} is an integer, a single call to
-write(2) is made.
-
-An error is signalled when the last element has only
-been partially written in the single call to write(2).
-
-The number of objects actually written is returned.
address@hidden may be
-omitted, in which case it defaults to the value returned by
address@hidden(current-output-port)}.
address@hidden deffn
+sizes. @xref{SRFI-4}, for more information.
+For many purposes, bytevectors work just as well as uniform vectors, and have
+the advantage that they integrate well with binary input and output.
address@hidden, for more information on bytevectors.
@node Bit Vectors
@subsection Bit Vectors
@@ -1982,45 +1493,6 @@ a @result{} #2((#f #f) (#f #t))
@end example
@end deffn
address@hidden {Scheme Procedure} enclose-array array dim1 @dots{}
address@hidden {C Function} scm_enclose_array (array, dimlist)
address@hidden, @var{dim2} @dots{} should be nonnegative integers less than
-the rank of @var{array}. @code{enclose-array} returns an array
-resembling an array of shared arrays. The dimensions of each shared
-array are the same as the @var{dim}th dimensions of the original array,
-the dimensions of the outer array are the same as those of the original
-array that did not match a @var{dim}.
-
-An enclosed array is not a general Scheme array. Its elements may not
-be set using @code{array-set!}. Two references to the same element of
-an enclosed array will be @code{equal?} but will not in general be
address@hidden The value returned by @code{array-prototype} when given an
-enclosed array is unspecified.
-
-For example,
-
address@hidden
-(enclose-array '#3(((a b c)
- (d e f))
- ((1 2 3)
- (4 5 6)))
- 1)
address@hidden
-#<enclosed-array (#1(a d) #1(b e) #1(c f))
- (#1(1 4) #1(2 5) #1(3 6))>
-
-(enclose-array '#3(((a b c)
- (d e f))
- ((1 2 3)
- (4 5 6)))
- 1 0)
address@hidden
-#<enclosed-array #2((a 1) (d 4))
- #2((b 2) (e 5))
- #2((c 3) (f 6))>
address@hidden lisp
address@hidden deffn
-
@deffn {Scheme Procedure} array-shape array
@deffnx {Scheme Procedure} array-dimensions array
@deffnx {C Function} scm_array_dimensions (array)
@@ -2078,9 +1550,7 @@ is unspecified.
Return @code{#t} if all arguments are arrays with the same shape, the
same type, and have corresponding elements which are either
@code{equal?} or @code{array-equal?}. This function differs from
address@hidden (@pxref{Equality}) in that a one dimensional shared
-array may be @code{array-equal?} but not @code{equal?} to a vector or
-uniform vector.
address@hidden (@pxref{Equality}) in that all arguments must be arrays.
@end deffn
@c FIXME: array-map! accepts no source arrays at all, and in that
@@ -2615,6 +2085,172 @@ reading and writing. You must take care not to modify
bits outside of
the allowed index range of the array, even for contiguous arrays.
@end deftypefn
address@hidden VLists
address@hidden VLists
+
address@hidden vlist
+
+The @code{(ice-9 vlist)} module provides an implementation of the @dfn{VList}
+data structure designed by Phil Bagwell in 2002. VLists are immutable lists,
+which can contain any Scheme object. They improve on standard Scheme linked
+lists in several areas:
+
address@hidden
address@hidden
+Random access has typically constant-time complexity.
+
address@hidden
+Computing the length of a VList has time complexity logarithmic in the number
of
+elements.
+
address@hidden
+VLists use less storage space than standard lists.
+
address@hidden
+VList elements are stored in contiguous regions, which improves memory locality
+and leads to more efficient use of hardware caches.
address@hidden itemize
+
+The idea behind VLists is to store vlist elements in increasingly large
+contiguous blocks (implemented as vectors here). These blocks are linked to
one
+another using a pointer to the next block and an offset within that block. The
+size of these blocks form a geometric series with ratio
address@hidden (2 by default).
+
+The VList structure also serves as the basis for the @dfn{VList-based hash
+lists} or ``vhashes'', an immutable dictionary type (@pxref{VHashes}).
+
+However, the current implementation in @code{(ice-9 vlist)} has several
+noteworthy shortcomings:
+
address@hidden
+
address@hidden
+It is @emph{not} thread-safe. Although operations on vlists are all
address@hidden transparent} (i.e., purely functional), adding elements to a
+vlist with @code{vlist-cons} mutates part of its internal structure, which
makes
+it non-thread-safe. This could be fixed, but it would slow down
address@hidden
+
address@hidden
address@hidden always allocates at least as much memory as @code{cons}.
+Again, Phil Bagwell describes how to fix it, but that would require tuning the
+garbage collector in a way that may not be generally beneficial.
+
address@hidden
address@hidden is a Scheme procedure compiled to bytecode, and it does not
+compete with the straightforward C implementation of @code{cons}, and with the
+fact that the VM has a special @code{cons} instruction.
+
address@hidden itemize
+
+We hope to address these in the future.
+
+The programming interface exported by @code{(ice-9 vlist)} is defined below.
+Most of it is the same as SRFI-1 with an added @code{vlist-} prefix to function
+names.
+
address@hidden {Scheme Procedure} vlist? obj
+Return true if @var{obj} is a VList.
address@hidden deffn
+
address@hidden {Scheme Variable} vlist-null
+The empty VList. Note that it's possible to create an empty VList not
address@hidden to @code{vlist-null}; thus, callers should always use
address@hidden when testing whether a VList is empty.
address@hidden defvr
+
address@hidden {Scheme Procedure} vlist-null? vlist
+Return true if @var{vlist} is empty.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-cons item vlist
+Return a new vlist with @var{item} as its head and @var{vlist} as its tail.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-head vlist
+Return the head of @var{vlist}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-tail vlist
+Return the tail of @var{vlist}.
address@hidden deffn
+
address@hidden {Scheme Variable} block-growth-factor
+A fluid that defines the growth factor of VList blocks, 2 by default.
address@hidden defvr
+
+The functions below provide the usual set of higher-level list operations.
+
address@hidden {Scheme Procedure} vlist-fold proc init vlist
address@hidden {Scheme Procedure} vlist-fold-right proc init vlist
+Fold over @var{vlist}, calling @var{proc} for each element, as for SRFI-1
address@hidden and @code{fold-right} (@pxref{SRFI-1, @code{fold}}).
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-ref vlist index
+Return the element at index @var{index} in @var{vlist}. This is typically a
+constant-time operation.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-length vlist
+Return the length of @var{vlist}. This is typically logarithmic in the number
+of elements in @var{vlist}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-reverse vlist
+Return a new @var{vlist} whose content are those of @var{vlist} in reverse
+order.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-map proc vlist
+Map @var{proc} over the elements of @var{vlist} and return a new vlist.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-for-each proc vlist
+Call @var{proc} on each element of @var{vlist}. The result is unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-drop vlist count
+Return a new vlist that does not contain the @var{count} first elements of
address@hidden This is typically a constant-time operation.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-take vlist count
+Return a new vlist that contains only the @var{count} first elements of
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-filter pred vlist
+Return a new vlist containing all the elements from @var{vlist} that satisfy
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-delete x vlist [equal?]
+Return a new vlist corresponding to @var{vlist} without the elements
address@hidden to @var{x}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-unfold p f g seed [tail-gen]
address@hidden {Scheme Procedure} vlist-unfold-right p f g seed [tail]
+Return a new vlist, as for SRFI-1 @code{unfold} and @code{unfold-right}
+(@pxref{SRFI-1, @code{unfold}}).
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist-append vlists ...
+Append the given vlists and return the resulting vlist.
address@hidden deffn
+
address@hidden {Scheme Procedure} list->vlist lst
+Return a new vlist whose contents correspond to @var{lst}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vlist->list vlist
+Return a new list whose contents match those of @var{vlist}.
address@hidden deffn
+
+
+
@node Records
@subsection Records
@@ -3559,6 +3195,118 @@ capitals
("Florida" . "Tallahassee"))
@end lisp
address@hidden VHashes
address@hidden VList-Based Hash Lists or ``VHashes''
+
address@hidden VList-based hash lists
address@hidden VHash
+
+The @code{(ice-9 vlist)} module provides an implementation of @dfn{VList-based
+hash lists} (@pxref{VLists}). VList-based hash lists, or @dfn{vhashes}, are an
+immutable dictionary type similar to association lists that maps @dfn{keys} to
address@hidden However, unlike association lists, accessing a value given its
+key is typically a constant-time operation.
+
+The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as
+that of association lists found in SRFI-1, with procedure names prefixed by
address@hidden instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
+
+In addition, vhashes can be manipulated using VList operations:
+
address@hidden
+(vlist-head (vhash-consq 'a 1 vlist-null))
address@hidden (a . 1)
+
+(define vh1 (vhash-consq 'b 2 (vhash-consq 'a 1 vlist-null)))
+(define vh2 (vhash-consq 'c 3 (vlist-tail vh1)))
+
+(vhash-assq 'a vh2)
address@hidden (a . 1)
+(vhash-assq 'b vh2)
address@hidden #f
+(vhash-assq 'c vh2)
address@hidden (c . 3)
+(vlist->list vh2)
address@hidden ((c . 3) (a . 1))
address@hidden example
+
+However, keep in mind that procedures that construct new VLists
+(@code{vlist-map}, @code{vlist-filter}, etc.) return raw VLists, not vhashes:
+
address@hidden
+(define vh (alist->vhash '((a . 1) (b . 2) (c . 3)) hashq))
+(vhash-assq 'a vh)
address@hidden (a . 1)
+
+(define vl
+ ;; This will create a raw vlist.
+ (vlist-filter (lambda (key+value) (odd? (cdr key+value))) vh))
+(vhash-assq 'a vl)
address@hidden ERROR: Wrong type argument in position 2
+
+(vlist->list vl)
address@hidden ((a . 1) (c . 3))
address@hidden example
+
address@hidden {Scheme Procedure} vhash? obj
+Return true if @var{obj} is a vhash.
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-cons key value vhash [hash-proc]
address@hidden {Scheme Procedure} vhash-consq key value vhash
address@hidden {Scheme Procedure} vhash-consv key value vhash
+Return a new hash list based on @var{vhash} where @var{key} is associated with
address@hidden, using @var{hash-proc} to compute the hash of @var{key}.
address@hidden must be either @code{vlist-null} or a vhash returned by a
previous
+call to @code{vhash-cons}. @var{hash-proc} defaults to @code{hash}
(@pxref{Hash
+Table Reference, @code{hash} procedure}). With @code{vhash-consq}, the
address@hidden hash function is used; with @code{vhash-consv} the @code{hashv}
+hash function is used.
+
+All @code{vhash-cons} calls made to construct a vhash should use the same
address@hidden Failing to do that, the result is undefined.
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-assoc key vhash [equal? [hash-proc]]
address@hidden {Scheme Procedure} vhash-assq key vhash
address@hidden {Scheme Procedure} vhash-assv key vhash
+Return the first key/value pair from @var{vhash} whose key is equal to
@var{key}
+according to the @var{equal?} equality predicate (which defaults to
address@hidden), and using @var{hash-proc} (which defaults to @code{hash}) to
+compute the hash of @var{key}. The second form uses @code{eq?} as the equality
+predicate and @code{hashq} as the hash function; the last form uses @code{eqv?}
+and @code{hashv}.
+
+Note that it is important to consistently use the same hash function for
address@hidden as was passed to @code{vhash-cons}. Failing to do that, the
+result is unpredictable.
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-delete key vhash [equal? [hash-proc]]
address@hidden {Scheme Procedure} vhash-delq key vhash
address@hidden {Scheme Procedure} vhash-delv key vhash
+Remove all associations from @var{vhash} with @var{key}, comparing keys with
address@hidden (which defaults to @code{equal?}), and computing the hash of
address@hidden using @var{hash-proc} (which defaults to @code{hash}). The
second
+form uses @code{eq?} as the equality predicate and @code{hashq} as the hash
+function; the last one uses @code{eqv?} and @code{hashv}.
+
+Again the choice of @var{hash-proc} must be consistent with previous calls to
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vhash-fold proc vhash
+Fold over the key/pair elements of @var{vhash}. For each pair call @var{proc}
+as @code{(@var{proc} key value result)}.
address@hidden deffn
+
address@hidden {Scheme Procedure} alist->vhash alist [hash-proc]
+Return the vhash corresponding to @var{alist}, an association list, using
address@hidden to compute key hashes. When omitted, @var{hash-proc} defaults
+to @code{hash}.
address@hidden deffn
+
+
@node Hash Tables
@subsection Hash Tables
@tpindex Hash Tables
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index a8296c9..0b4b587 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -15,7 +15,8 @@ flow of Scheme affects C code.
* if cond case:: Simple conditional evaluation.
* and or:: Conditional evaluation of a sequence.
* while do:: Iteration mechanisms.
-* Continuations:: Continuations.
+* Prompts:: Composable, delimited continuations.
+* Continuations:: Non-composable continuations.
* Multiple Values:: Returning and accepting multiple values.
* Exceptions:: Throwing and catching exceptions.
* Error Reporting:: Procedures for signaling errors.
@@ -343,6 +344,112 @@ times.
@end deffn
address@hidden Prompts
address@hidden Prompts
address@hidden prompts
address@hidden delimited continuations
address@hidden composable continuations
address@hidden non-local exit
+
+Prompts are control-flow barriers between different parts of a program. In the
+same way that a user sees a shell prompt (e.g., the Bash prompt) as a barrier
+between the operating system and her programs, Scheme prompts allow the Scheme
+programmer to treat parts of programs as if they were running in different
+operating systems.
+
+We use this roundabout explanation because, unless you're a functional
+programming junkie, you probably haven't heard the term, ``delimited,
composable
+continuation''. That's OK; it's a relatively recent topic, but a very useful
+one to know about.
+
address@hidden {Scheme Procedure} call-with-prompt tag thunk handler
+Set up a prompt, and call @var{thunk} within that prompt.
+
+During the dynamic extent of the call to @var{thunk}, a prompt named @var{tag}
+will be present in the dynamic context, such that if a user calls
address@hidden (see below) with that tag, control rewinds back to the
+prompt, and the @var{handler} is run.
+
address@hidden must be a procedure. The first argument to @var{handler} will be
+the state of the computation begun when @var{thunk} was called, and ending with
+the call to @code{abort-to-prompt}. The remaining arguments to @var{handler}
are
+those passed to @code{abort-to-prompt}.
address@hidden deffn
+
address@hidden {Scheme Procedure} abort-to-prompt tag val ...
+Unwind the dynamic and control context to the nearest prompt named @var{tag},
+also passing the given values.
address@hidden deffn
+
+C programmers may recognize @code{call-with-prompt} and @code{abort-to-prompt}
+as a fancy kind of @code{setjmp} and @code{longjmp}, respectively. Prompts are
+indeed quite useful as non-local escape mechanisms. Guile's @code{catch} and
address@hidden are implemented in terms of prompts. Prompts are more convenient
+than @code{longjmp}, in that one has the opportunity to pass multiple values to
+the jump target.
+
+Also unlike @code{longjmp}, the prompt handler is given the full state of the
+process that was aborted, as the first argument to the prompt's handler. That
+state is the @dfn{continuation} of the computation wrapped by the prompt. It is
+a @dfn{delimited continuation}, because it is not the whole continuation of the
+program; rather, just the computation initiated by the call to
address@hidden
+
+The continuation is a procedure, and may be reinstated simply by invoking it,
+with any number of values. Here's where things get interesting, and complicated
+as well. Besides being described as delimited, continuations reified by prompts
+are also @dfn{composable}, because invoking a prompt-saved continuation
composes
+that continuation with the current one.
+
+Imagine you have saved a continuation via call-with-prompt:
+
address@hidden
+(define cont
+ (call-with-prompt
+ ;; tag
+ 'foo
+ ;; thunk
+ (lambda ()
+ (+ 34 (abort-to-prompt 'foo)))
+ ;; handler
+ (lambda (k) k)))
address@hidden example
+
+The resulting continuation is the addition of 34. It's as if you had written:
+
address@hidden
+(define cont
+ (lambda (x)
+ (+ 34 x)))
address@hidden example
+
+So, if we call @code{cont} with one numeric value, we get that number,
+incremented by 34:
+
address@hidden
+(cont 8)
address@hidden 42
+(* 2 (cont 8))
address@hidden 84
address@hidden example
+
+The last example illustrates what we mean when we say, "composes with the
+current continuation". We mean that there is a current continuation -- some
+remaining things to compute, like @code{(lambda (x) (* x 2))} -- and that
+calling the saved continuation doesn't wipe out the current continuation, it
+composes the saved continuation with the current one.
+
+We're belaboring the point here because traditional Scheme continuations, as
+discussed in the next section, aren't composable, and are actually less
+expressive than continuations captured by prompts. But there's a place for them
+both.
+
+Before moving on, we should mention that if the handler of a prompt is a
address@hidden expression, and the first argument isn't referenced, an abort to
+that prompt will not cause a continuation to be reified. This can be an
+important efficiency consideration to keep in mind.
+
+
@node Continuations
@subsection Continuations
@cindex continuations
@@ -409,15 +516,6 @@ invoke that continuation.
This is in common use since the latter is rather long.
@end deffn
address@hidden {C Function} SCM scm_make_continuation (int *first)
-Capture the current continuation as described above. The return value
-is the new continuation, and @var{*first} is set to 1.
-
-When the continuation is invoked, @code{scm_make_continuation} will
-return again, this time returning the value (or set of multiple
-values) passed in that invocation, and with @var{*first} set to 0.
address@hidden deftypefn
-
@sp 1
@noindent
Here is a simple example,
@@ -475,13 +573,12 @@ with programs written in other languages, such as C,
which do not know
about continuations. Basically continuations are captured by a block
copy of the stack, and resumed by copying back.
-For this reason, generally continuations should be used only when
-there is no other simple way to achieve the desired result, or when
-the elegance of the continuation mechanism outweighs the need for
-performance.
+For this reason, continuations captured by @code{call/cc} should be used only
+when there is no other simple way to achieve the desired result, or when the
+elegance of the continuation mechanism outweighs the need for performance.
Escapes upwards from loops or nested functions are generally best
-handled with exceptions (@pxref{Exceptions}). Coroutines can be
+handled with prompts (@pxref{Prompts}). Coroutines can be
efficiently implemented with cooperating threads (a thread holds a
full program stack but doesn't copy it around the way continuations
do).
@@ -614,8 +711,7 @@ more conveniently.
@menu
* Exception Terminology:: Different ways to say the same thing.
* Catch:: Setting up to catch exceptions.
-* Throw Handlers:: Adding extra handling to a throw.
-* Lazy Catch:: Catch without unwinding the stack.
+* Throw Handlers:: Handling exceptions before unwinding the stack.
* Throw:: Throwing an exception.
* Exception Implementation:: How Guile implements exceptions.
@end menu
@@ -808,17 +904,53 @@ Operations}).
@subsubsection Throw Handlers
It's sometimes useful to be able to intercept an exception that is being
-thrown, but without changing where in the dynamic context that exception
-will eventually be caught. This could be to clean up some related state
-or to pass information about the exception to a debugger, for example.
-The @code{with-throw-handler} procedure provides a way to do this.
+thrown before the stack is unwound. This could be to clean up some
+related state, to print a backtrace, or to pass information about the
+exception to a debugger, for example. The @code{with-throw-handler}
+procedure provides a way to do this.
@deffn {Scheme Procedure} with-throw-handler key thunk handler
@deffnx {C Function} scm_with_throw_handler (key, thunk, handler)
Add @var{handler} to the dynamic context as a throw handler
for key @var{key}, then invoke @var{thunk}.
+
+This behaves exactly like @code{catch}, except that it does not unwind
+the stack before invoking @var{handler}. If the @var{handler} procedure
+returns normally, Guile rethrows the same exception again to the next
+innermost catch or throw handler. @var{handler} may exit nonlocally, of
+course, via an explicit throw or via invoking a continuation.
@end deffn
+Typically @var{handler} is used to display a backtrace of the stack at
+the point where the corresponding @code{throw} occurred, or to save off
+this information for possible display later.
+
+Not unwinding the stack means that throwing an exception that is handled
+via a throw handler is equivalent to calling the throw handler handler
+inline instead of each @code{throw}, and then omitting the surrounding
address@hidden In other words,
+
address@hidden
+(with-throw-handler 'key
+ (lambda () @dots{} (throw 'key args @dots{}) @dots{})
+ handler)
address@hidden lisp
+
address@hidden
+is mostly equivalent to
+
address@hidden
+((lambda () @dots{} (handler 'key args @dots{}) @dots{}))
address@hidden lisp
+
+In particular, the dynamic context when @var{handler} is invoked is that
+of the site where @code{throw} is called. The examples are not quite
+equivalent, because the body of a @code{with-throw-handler} is not in
+tail position with respect to the @code{with-throw-handler}, and if
address@hidden exits normally, Guile arranges to rethrow the error, but
+hopefully the intention is clear. (For an introduction to what is meant
+by dynamic context, @xref{Dynamic Wind}.)
+
@deftypefn {C Function} SCM scm_c_with_throw_handler (SCM tag,
scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void
*handler_data, int lazy_catch_p)
The above @code{scm_with_throw_handler} takes Scheme procedures as body
(thunk) and handler arguments. @code{scm_c_with_throw_handler} is an
@@ -846,141 +978,13 @@ everything that a @code{catch} would do until the point
where
then it rethrows to the next innermost @code{catch} or throw handler
instead.
+Note also that since the dynamic context is not unwound, if a
address@hidden handler throws to a key that does not match
+the @code{with-throw-handler} expression's @var{key}, the new throw may
+be handled by a @code{catch} or throw handler that is @emph{closer} to
+the throw than the first @code{with-throw-handler}.
address@hidden Lazy Catch
address@hidden Catch Without Unwinding
-
-Before version 1.8, Guile's closest equivalent to
address@hidden was @code{lazy-catch}. From version 1.8
-onwards we recommend using @code{with-throw-handler} because its
-behaviour is more useful than that of @code{lazy-catch}, but
address@hidden is still supported as well.
-
-A @dfn{lazy catch} is used in the same way as a normal @code{catch},
-with @var{key}, @var{thunk} and @var{handler} arguments specifying the
-exception type, normal case code and handler procedure, but differs in
-one important respect: the handler procedure is executed without
-unwinding the call stack from the context of the @code{throw} expression
-that caused the handler to be invoked.
-
address@hidden {Scheme Procedure} lazy-catch key thunk handler
address@hidden {C Function} scm_lazy_catch (key, thunk, handler)
-This behaves exactly like @code{catch}, except that it does
-not unwind the stack before invoking @var{handler}.
-If the @var{handler} procedure returns normally, Guile
-rethrows the same exception again to the next innermost catch,
-lazy-catch or throw handler. If the @var{handler} exits
-non-locally, that exit determines the continuation.
address@hidden deffn
-
address@hidden {C Function} SCM scm_internal_lazy_catch (SCM tag,
scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void
*handler_data)
-The above @code{scm_lazy_catch} takes Scheme procedures as body and
-handler arguments. @code{scm_internal_lazy_catch} is an equivalent
-taking C functions. See @code{scm_internal_catch} (@pxref{Catch}) for
-a description of the parameters, the behaviour however of course
-follows @code{lazy-catch}.
address@hidden deftypefn
-
-Typically @var{handler} is used to display a backtrace of the stack at
-the point where the corresponding @code{throw} occurred, or to save off
-this information for possible display later.
-
-Not unwinding the stack means that throwing an exception that is caught
-by a @code{lazy-catch} is @emph{almost} equivalent to calling the
address@hidden's handler inline instead of each @code{throw}, and
-then omitting the surrounding @code{lazy-catch}. In other words,
-
address@hidden
-(lazy-catch 'key
- (lambda () @dots{} (throw 'key args @dots{}) @dots{})
- handler)
address@hidden lisp
-
address@hidden
-is @emph{almost} equivalent to
-
address@hidden
-((lambda () @dots{} (handler 'key args @dots{}) @dots{}))
address@hidden lisp
-
address@hidden
-But why only @emph{almost}? The difference is that with
address@hidden (as with normal @code{catch}), the dynamic context is
-unwound back to just outside the @code{lazy-catch} expression before
-invoking the handler. (For an introduction to what is meant by dynamic
-context, @xref{Dynamic Wind}.)
-
-Then, when the handler @emph{itself} throws an exception, that exception
-must be caught by some kind of @code{catch} (including perhaps another
address@hidden) higher up the call stack.
-
-The dynamic context also includes @code{with-fluids} blocks
-(@pxref{Fluids and Dynamic States}),
-so the effect of unwinding the dynamic context can also be seen in fluid
-variable values. This is illustrated by the following code, in which
-the normal case thunk uses @code{with-fluids} to temporarily change the
-value of a fluid:
-
address@hidden
-(define f (make-fluid))
-(fluid-set! f "top level value")
-
-(define (handler . args)
- (cons (fluid-ref f) args))
-
-(lazy-catch 'foo
- (lambda ()
- (with-fluids ((f "local value"))
- (throw 'foo)))
- handler)
address@hidden
-("top level value" foo)
-
-((lambda ()
- (with-fluids ((f "local value"))
- (handler 'foo))))
address@hidden
-("local value" foo)
address@hidden lisp
-
address@hidden
-In the @code{lazy-catch} version, the unwinding of dynamic context
-restores @code{f} to its value outside the @code{with-fluids} block
-before the handler is invoked, so the handler's @code{(fluid-ref f)}
-returns the external value.
-
address@hidden is useful because it permits the implementation of
-debuggers and other reflective programming tools that need to access the
-state of the call stack at the exact point where an exception or an
-error is thrown. For an example of this, see REFFIXME:stack-catch.
-
-It should be obvious from the above that @code{lazy-catch} is very
-similar to @code{with-throw-handler}. In fact Guile implements
address@hidden in exactly the same way as @code{with-throw-handler},
-except with a flag set to say ``where there are slight differences
-between what @code{with-throw-handler} and @code{lazy-catch} would do,
-do what @code{lazy-catch} has always done''. There are two such
-differences:
-
address@hidden
address@hidden
address@hidden handlers execute in the full dynamic context
-of the originating @code{throw} call. @code{lazy-catch} handlers
-execute in the dynamic context of the @code{lazy-catch} expression,
-excepting only that the stack has not yet been unwound from the point of
-the @code{throw} call.
-
address@hidden
-If a @code{with-throw-handler} handler throws to a key that does not
-match the @code{with-throw-handler} expression's @var{key}, the new
-throw may be handled by a @code{catch} or throw handler that is _closer_
-to the throw than the first @code{with-throw-handler}. If a
address@hidden handler throws, it will always be handled by a
address@hidden or throw handler that is higher up the dynamic context than
-the first @code{lazy-catch}.
address@hidden enumerate
-
-Here is an example to illustrate the second difference:
+Here is an example to illustrate this behavior:
@lisp
(catch 'a
@@ -998,14 +1002,7 @@ Here is an example to illustrate the second difference:
@noindent
This code will call @code{inner-handler} and then continue with the
-continuation of the inner @code{catch}. If the
address@hidden was changed to @code{lazy-catch}, however, the
-code would call @code{outer-handler} and then continue with the
-continuation of the outer @code{catch}.
-
-Modulo these two differences, any statements in the previous and
-following subsections about throw handlers apply to lazy catches as
-well.
+continuation of the inner @code{catch}.
@node Throw
@@ -1501,6 +1498,42 @@ which is the name of the procedure incorrectly invoked.
@end deftypefn
address@hidden Signalling Type Errors
+
+Every function visible at the Scheme level should aggressively check the
+types of its arguments, to avoid misinterpreting a value, and perhaps
+causing a segmentation fault. Guile provides some macros to make this
+easier.
+
address@hidden Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, unsigned
int @var{position}, const char address@hidden)
+If @var{test} is zero, signal a ``wrong type argument'' error,
+attributed to the subroutine named @var{subr}, operating on the value
address@hidden, which is the @var{position}'th argument of @var{subr}.
address@hidden deftypefn
+
address@hidden Macro int SCM_ARG1
address@hidden Macro int SCM_ARG2
address@hidden Macro int SCM_ARG3
address@hidden Macro int SCM_ARG4
address@hidden Macro int SCM_ARG5
address@hidden Macro int SCM_ARG6
address@hidden Macro int SCM_ARG7
+One of the above values can be used for @var{position} to indicate the
+number of the argument of @var{subr} which is being checked.
+Alternatively, a positive integer number can be used, which allows to
+check arguments after the seventh. However, for parameter numbers up to
+seven it is preferable to use @code{SCM_ARGN} instead of the
+corresponding raw number, since it will make the code easier to
+understand.
address@hidden deftypefn
+
address@hidden Macro int SCM_ARGn
+Passing a value of zero or @code{SCM_ARGn} for @var{position} allows to
+leave it unspecified which argument's type is incorrect. Again,
address@hidden should be preferred over a raw zero constant.
address@hidden deftypefn
+
+
@node Continuation Barriers
@subsection Continuation Barriers
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index c6022e9..420660b 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.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, 2006,
2007, 2008, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -1053,10 +1053,9 @@ locale-dependent parsing).
@rnindex magnitude
@rnindex angle
address@hidden {Scheme Procedure} make-rectangular real imaginary
address@hidden {C Function} scm_make_rectangular (real, imaginary)
-Return a complex number constructed of the given @var{real} and
address@hidden parts.
address@hidden {Scheme Procedure} make-rectangular real_part imaginary_part
address@hidden {C Function} scm_make_rectangular (real_part, imaginary_part)
+Return a complex number constructed of the given @var{real-part} and
@var{imaginary-part} parts.
@end deffn
@deffn {Scheme Procedure} make-polar x y
@@ -1688,11 +1687,28 @@ the backslash of @code{#\}.
Many of the non-printing characters, such as whitespace characters and
control characters, also have names.
-The most commonly used non-printing characters are space and
-newline. Their character names are @code{#\space} and
address@hidden There are also names for all of the ``C0 control
-characters'' (those with code points below 32). The following table
-describes the names for each character.
+The most commonly used non-printing characters have long character
+names, described in the table below.
+
address@hidden address@hidden {Preferred}
address@hidden Character Name @tab Codepoint
address@hidden @code{#\nul} @tab U+0000
address@hidden @code{#\alarm} @tab u+0007
address@hidden @code{#\backspace} @tab U+0008
address@hidden @code{#\tab} @tab U+0009
address@hidden @code{#\linefeed} @tab U+000A
address@hidden @code{#\newline} @tab U+000A
address@hidden @code{#\vtab} @tab U+000B
address@hidden @code{#\page} @tab U+000C
address@hidden @code{#\return} @tab U+000D
address@hidden @code{#\esc} @tab U+001B
address@hidden @code{#\space} @tab U+0020
address@hidden @code{#\delete} @tab U+007F
address@hidden multitable
+
+There are also short names for all of the ``C0 control characters''
+(those with code points below 32). The following table lists the short
+name for each character.
@multitable @columnfractions .25 .25 .25 .25
@item 0 = @code{#\nul}
@@ -1705,7 +1721,7 @@ describes the names for each character.
@tab 7 = @code{#\bel}
@item 8 = @code{#\bs}
@tab 9 = @code{#\ht}
- @tab 10 = @code{#\lf}
+ @tab 10 = @code{#\lf}
@tab 11 = @code{#\vt}
@item 12 = @code{#\ff}
@tab 13 = @code{#\cr}
@@ -1730,24 +1746,16 @@ describes the names for each character.
@item 32 = @code{#\sp}
@end multitable
-The ``delete'' character (code point U+007F) may be referred to with the
-name @code{#\del}.
+The short name for the ``delete'' character (code point U+007F) is
address@hidden
-One might note that the space character has two names --
address@hidden and @code{#\sp} -- as does the newline character.
-Several other non-printing characters have more than one name, for the
-sake of compatibility with previous versions.
+There are also a few alternative names left over for compatibility with
+previous versions of Guile.
@multitable address@hidden {Preferred}
@item Alternate @tab Standard
address@hidden @code{#\sp} @tab @code{#\space}
@item @code{#\nl} @tab @code{#\newline}
address@hidden @code{#\lf} @tab @code{#\newline}
address@hidden @code{#\tab} @tab @code{#\ht}
address@hidden @code{#\backspace} @tab @code{#\bs}
address@hidden @code{#\return} @tab @code{#\cr}
address@hidden @code{#\page} @tab @code{#\ff}
address@hidden @code{#\np} @tab @code{#\ff}
address@hidden @code{#\np} @tab @code{#\page}
@item @code{#\null} @tab @code{#\nul}
@end multitable
@@ -1755,6 +1763,18 @@ Characters may also be written using their code point
values. They can
be written with as an octal number, such as @code{#\10} for
@code{#\bs} or @code{#\177} for @code{#\del}.
+When the @code{r6rs-hex-escapes} reader option is enabled, there is an
+additional syntax for character escapes: @code{#\xHHHH} -- the letter 'x'
+followed by a hexadecimal number of one to eight digits.
+
address@hidden
+(read-enable 'r6rs-hex-escapes)
address@hidden lisp
+
+Enabling this option will also change the hex escape format for strings. More
+on string escapes can be found at (@pxref{String Syntax}). More on reader
+options in general can be found at (@pxref{Reader options}).
+
@rnindex char?
@deffn {Scheme Procedure} char? x
@deffnx {C Function} scm_char_p (x)
@@ -1874,6 +1894,81 @@ Return @code{#t} iff @var{chr} is either uppercase or
lowercase, else
@code{#f}.
@end deffn
address@hidden {Scheme Procedure} char-general-category chr
address@hidden {C Function} scm_char_general_category (chr)
+Return a symbol giving the two-letter name of the Unicode general
+category assigned to @var{chr} or @code{#f} if no named category is
+assigned. The following table provides a list of category names along
+with their meanings.
+
address@hidden @columnfractions .1 .4 .1 .4
address@hidden Lu
+ @tab Uppercase letter
+ @tab Pf
+ @tab Final quote punctuation
address@hidden Ll
+ @tab Lowercase letter
+ @tab Po
+ @tab Other punctuation
address@hidden Lt
+ @tab Titlecase letter
+ @tab Sm
+ @tab Math symbol
address@hidden Lm
+ @tab Modifier letter
+ @tab Sc
+ @tab Currency symbol
address@hidden Lo
+ @tab Other letter
+ @tab Sk
+ @tab Modifier symbol
address@hidden Mn
+ @tab Non-spacing mark
+ @tab So
+ @tab Other symbol
address@hidden Mc
+ @tab Combining spacing mark
+ @tab Zs
+ @tab Space separator
address@hidden Me
+ @tab Enclosing mark
+ @tab Zl
+ @tab Line separator
address@hidden Nd
+ @tab Decimal digit number
+ @tab Zp
+ @tab Paragraph separator
address@hidden Nl
+ @tab Letter number
+ @tab Cc
+ @tab Control
address@hidden No
+ @tab Other number
+ @tab Cf
+ @tab Format
address@hidden Pc
+ @tab Connector punctuation
+ @tab Cs
+ @tab Surrogate
address@hidden Pd
+ @tab Dash punctuation
+ @tab Co
+ @tab Private use
address@hidden Ps
+ @tab Open punctuation
+ @tab Cn
+ @tab Unassigned
address@hidden Pe
+ @tab Close punctuation
+ @tab
+ @tab
address@hidden Pi
+ @tab Initial quote punctuation
+ @tab
+ @tab
address@hidden multitable
address@hidden deffn
+
@rnindex char->integer
@deffn {Scheme Procedure} char->integer chr
@deffnx {C Function} scm_char_to_integer (chr)
@@ -1900,6 +1995,30 @@ Return the uppercase character version of @var{chr}.
Return the lowercase character version of @var{chr}.
@end deffn
address@hidden char-titlecase
address@hidden {Scheme Procedure} char-titlecase chr
address@hidden {C Function} scm_char_titlecase (chr)
+Return the titlecase character version of @var{chr} if one exists;
+otherwise return the uppercase version.
+
+For most characters these will be the same, but the Unicode Standard
+includes certain digraph compatibility characters, such as @code{U+01F3}
+``dz'', for which the uppercase and titlecase characters are different
+(@code{U+01F1} ``DZ'' and @code{U+01F2} ``Dz'' in this case,
+respectively).
address@hidden deffn
+
address@hidden scm_t_wchar
address@hidden {C Function} scm_t_wchar scm_c_upcase (scm_t_wchar @var{c})
address@hidden {C Function} scm_t_wchar scm_c_downcase (scm_t_wchar @var{c})
address@hidden {C Function} scm_t_wchar scm_c_titlecase (scm_t_wchar @var{c})
+
+These C functions take an integer representation of a Unicode
+codepoint and return the codepoint corresponding to its uppercase,
+lowercase, and titlecase forms respectively. The type
address@hidden is a signed, 32-bit integer.
address@hidden deftypefn
+
@node Character Sets
@subsection Character Sets
@@ -2493,7 +2612,8 @@ Guile provides all procedures of SRFI-13 and a few more.
* Reversing and Appending Strings:: Appending strings to form a new string.
* Mapping Folding and Unfolding:: Iterating over strings.
* Miscellaneous String Operations:: Replicating, insertion, parsing, ...
-* Conversion to/from C::
+* Conversion to/from C::
+* String Internals:: The storage strategy for strings.
@end menu
@node String Syntax
@@ -2507,10 +2627,10 @@ Guile provides all procedures of SRFI-13 and a few more.
The read syntax for strings is an arbitrarily long sequence of
characters enclosed in double quotes (@nicode{"}).
-Backslash is an escape character and can be used to insert the
-following special characters. @nicode{\"} and @nicode{\\} are R5RS
-standard, the rest are Guile extensions, notice they follow C string
-syntax.
+Backslash is an escape character and can be used to insert the following
+special characters. @nicode{\"} and @nicode{\\} are R5RS standard, the
+next seven are R6RS standard --- notice they follow C syntax --- and the
+remaining four are Guile extensions.
@table @asis
@item @nicode{\\}
@@ -2520,9 +2640,6 @@ Backslash character.
Double quote character (an unescaped @nicode{"} is otherwise the end
of the string).
address@hidden @nicode{\0}
-NUL character (ASCII 0).
-
@item @nicode{\a}
Bell character (ASCII 7).
@@ -2541,6 +2658,12 @@ Tab character (ASCII 9).
@item @nicode{\v}
Vertical tab character (ASCII 11).
address@hidden @nicode{\b}
+Backspace character (ASCII 8).
+
address@hidden @nicode{\0}
+NUL character (ASCII 0).
+
@item @nicode{\xHH}
Character code given by two hexadecimal digits. For example
@nicode{\x7f} for an ASCII DEL (127).
@@ -2564,6 +2687,20 @@ The following are examples of string literals:
"\"Hi\", he said."
@end lisp
+The three escape sequences @code{\xHH}, @code{\uHHHH} and @code{\UHHHHHH} were
+chosen to not break compatibility with code written for previous versions of
+Guile. The R6RS specification suggests a different, incompatible syntax for
hex
+escapes: @code{\xHHHH;} -- a character code followed by one to eight
hexadecimal
+digits terminated with a semicolon. If this escape format is desired instead,
+it can be enabled with the reader option @code{r6rs-hex-escapes}.
+
address@hidden
+(read-enable 'r6rs-hex-escapes)
address@hidden lisp
+
+Enabling this option will also change the hex escape format for characters.
+More on character escapes can be found at (@pxref{Characters}). More on
+reader options in general can be found at (@pxref{Reader options}).
@node String Predicates
@subsubsection String Predicates
@@ -2973,7 +3110,7 @@ predicates (@pxref{Characters}), but are defined on
character sequences.
The first set is specified in R5RS and has names that end in @code{?}.
The second set is specified in SRFI-13 and the names have not ending
address@hidden
address@hidden
The predicates ending in @code{-ci} ignore the character case
when comparing strings. For now, case-insensitive comparison is done
@@ -2983,7 +3120,8 @@ comparison. See @xref{Text Collation, the @code{(ice-9
i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
address@hidden {Scheme Procedure} string=? s1 s2
address@hidden {Scheme Procedure} string=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_equal_p (s1, s2, rest)
Lexicographic equality predicate; return @code{#t} if the two
strings are the same length and contain the same characters in
the same positions, otherwise return @code{#f}.
@@ -2995,31 +3133,36 @@ characters.
@end deffn
@rnindex string<?
address@hidden {Scheme Procedure} string<? s1 s2
address@hidden {Scheme Procedure} string<? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_less_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically less than @var{s2}.
@end deffn
@rnindex string<=?
address@hidden {Scheme Procedure} string<=? s1 s2
address@hidden {Scheme Procedure} string<=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_leq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically less than or equal to @var{s2}.
@end deffn
@rnindex string>?
address@hidden {Scheme Procedure} string>? s1 s2
address@hidden {Scheme Procedure} string>? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_gr_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically greater than @var{s2}.
@end deffn
@rnindex string>=?
address@hidden {Scheme Procedure} string>=? s1 s2
address@hidden {Scheme Procedure} string>=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_geq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if @var{s1}
is lexicographically greater than or equal to @var{s2}.
@end deffn
@rnindex string-ci=?
address@hidden {Scheme Procedure} string-ci=? s1 s2
address@hidden {Scheme Procedure} string-ci=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_equal_p (s1, s2, rest)
Case-insensitive string equality predicate; return @code{#t} if
the two strings are the same length and their component
characters match (ignoring case) at each position; otherwise
@@ -3027,28 +3170,32 @@ return @code{#f}.
@end deffn
@rnindex string-ci<?
address@hidden {Scheme Procedure} string-ci<? s1 s2
address@hidden {Scheme Procedure} string-ci<? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_less_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically less than @var{s2}
regardless of case.
@end deffn
@rnindex string<=?
address@hidden {Scheme Procedure} string-ci<=? s1 s2
address@hidden {Scheme Procedure} string-ci<=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_leq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically less than or equal
to @var{s2} regardless of case.
@end deffn
@rnindex string-ci>?
address@hidden {Scheme Procedure} string-ci>? s1 s2
address@hidden {Scheme Procedure} string-ci>? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_gr_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically greater than
@var{s2} regardless of case.
@end deffn
@rnindex string-ci>=?
address@hidden {Scheme Procedure} string-ci>=? s1 s2
address@hidden {Scheme Procedure} string-ci>=? [s1 [s2 . rest]]
address@hidden {C Function} scm_i_string_ci_geq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return
@code{#t} if @var{s1} is lexicographically greater than or
equal to @var{s2} regardless of case.
@@ -3071,8 +3218,9 @@ mismatch index, depending upon whether @var{s1} is less
than,
equal to, or greater than @var{s2}. The mismatch index is the
largest index @var{i} such that for every 0 <= @var{j} <
@var{i}, @address@hidden = @address@hidden -- that is,
address@hidden is the first position that does not match. The
-character comparison is done case-insensitively.
address@hidden is the first position where the lowercased letters
+do not match.
+
@end deffn
@deffn {Scheme Procedure} string= s1 s2 [start1 [end1 [start2 [end2]]]]
@@ -3163,6 +3311,70 @@ Compute a hash value for @var{S}. the optional argument
@var{bound} is a non-ne
Compute a hash value for @var{S}. the optional argument @var{bound} is a
non-negative exact integer specifying the range of the hash function. A
positive value restricts the return value to the range [0,bound).
@end deffn
+Because the same visual appearance of an abstract Unicode character can
+be obtained via multiple sequences of Unicode characters, even the
+case-insensitive string comparison functions described above may return
address@hidden when presented with strings containing different
+representations of the same character. For example, the Unicode
+character ``LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE'' can be
+represented with a single character (U+1E69) or by the character ``LATIN
+SMALL LETTER S'' (U+0073) followed by the combining marks ``COMBINING
+DOT BELOW'' (U+0323) and ``COMBINING DOT ABOVE'' (U+0307).
+
+For this reason, it is often desirable to ensure that the strings
+to be compared are using a mutually consistent representation for every
+character. The Unicode standard defines two methods of normalizing the
+contents of strings: Decomposition, which breaks composite characters
+into a set of constituent characters with an ordering defined by the
+Unicode Standard; and composition, which performs the converse.
+
+There are two decomposition operations. ``Canonical decomposition''
+produces character sequences that share the same visual appearance as
+the original characters, while ``compatiblity decomposition'' produces
+ones whose visual appearances may differ from the originals but which
+represent the same abstract character.
+
+These operations are encapsulated in the following set of normalization
+forms:
+
address@hidden @dfn
address@hidden NFD
+Characters are decomposed to their canonical forms.
+
address@hidden NFKD
+Characters are decomposed to their compatibility forms.
+
address@hidden NFC
+Characters are decomposed to their canonical forms, then composed.
+
address@hidden NFKC
+Characters are decomposed to their compatibility forms, then composed.
+
address@hidden table
+
+The functions below put their arguments into one of the forms described
+above.
+
address@hidden {Scheme Procedure} string-normalize-nfd s
address@hidden {C Function} scm_string_normalize_nfd (s)
+Return the @code{NFD} normalized form of @var{s}.
address@hidden deffn
+
address@hidden {Scheme Procedure} string-normalize-nfkd s
address@hidden {C Function} scm_string_normalize_nfkd (s)
+Return the @code{NFKD} normalized form of @var{s}.
address@hidden deffn
+
address@hidden {Scheme Procedure} string-normalize-nfc s
address@hidden {C Function} scm_string_normalize_nfc (s)
+Return the @code{NFC} normalized form of @var{s}.
address@hidden deffn
+
address@hidden {Scheme Procedure} string-normalize-nfkc s
address@hidden {C Function} scm_string_normalize_nfkc (s)
+Return the @code{NFKC} normalized form of @var{s}.
address@hidden deffn
+
@node String Searching
@subsubsection String Searching
@@ -3337,6 +3549,13 @@ case-insensitively.
These are procedures for mapping strings to their upper- or lower-case
equivalents, respectively, or for capitalizing strings.
+They use the basic case mapping rules for Unicode characters. No
+special language or context rules are considered. The resulting strings
+are guaranteed to be the same length as the input strings.
+
address@hidden Case Mapping, the @code{(ice-9
+i18n)} module}, for locale-dependent case conversions.
+
@deffn {Scheme Procedure} string-upcase str [start [end]]
@deffnx {C Function} scm_substring_upcase (str, start, end)
@deffnx {C Function} scm_string_upcase (str)
@@ -3437,8 +3656,8 @@ concatenation of the given strings, @var{args}.
@end example
@end deffn
address@hidden {Scheme Procedure} string-append/shared . ls
address@hidden {C Function} scm_string_append_shared (ls)
address@hidden {Scheme Procedure} string-append/shared . rest
address@hidden {C Function} scm_string_append_shared (rest)
Like @code{string-append}, but the result may share memory
with the argument strings.
@end deffn
@@ -3658,12 +3877,19 @@ that make up the string. For Scheme strings, character
encoding is
not an issue (most of the time), since in Scheme you never get to see
the bytes, only the characters.
-Well, ideally, anyway. Right now, Guile simply equates Scheme
-characters and bytes, ignoring the possibility of multi-byte encodings
-completely. This will change in the future, where Guile will use
-Unicode codepoints as its characters and UTF-8 or some other encoding
-as its internal encoding. When you exclusively use the functions
-listed in this section, you are `future-proof'.
+Converting to C and converting from C each have their own challenges.
+
+When converting from C to Scheme, it is important that the sequence of
+bytes in the C string be valid with respect to its encoding. ASCII
+strings, for example, can't have any bytes greater than 127. An ASCII
+byte greater than 127 is considered @emph{ill-formed} and cannot be
+converted into a Scheme character.
+
+Problems can occur in the reverse operation as well. Not all character
+encodings can hold all possible Scheme characters. Some encodings, like
+ASCII for example, can only describe a small subset of all possible
+characters. So, when converting to C, one must first decide what to do
+with Scheme characters that can't be represented in the C string.
Converting a Scheme string to a C string will often allocate fresh
memory to hold the result. You must take care that this memory is
@@ -3673,8 +3899,9 @@ using @code{scm_dynwind_free} inside an appropriate
dynwind context,
@deftypefn {C Function} SCM scm_from_locale_string (const char *str)
@deftypefnx {C Function} SCM scm_from_locale_stringn (const char *str, size_t
len)
-Creates a new Scheme string that has the same contents as @var{str}
-when interpreted in the current locale character encoding.
+Creates a new Scheme string that has the same contents as @var{str} when
+interpreted in the locale character encoding of the
address@hidden
For @code{scm_from_locale_string}, @var{str} must be null-terminated.
@@ -3682,6 +3909,8 @@ For @code{scm_from_locale_stringn}, @var{len} specifies
the length of
@var{str} in bytes, and @var{str} does not need to be null-terminated.
If @var{len} is @code{(size_t)-1}, then @var{str} does need to be
null-terminated and the real length will be found with @code{strlen}.
+
+If the C string is ill-formed, an error will be raised.
@end deftypefn
@deftypefn {C Function} SCM scm_take_locale_string (char *str)
@@ -3695,10 +3924,10 @@ can then use @var{str} directly as its internal
representation.
@deftypefn {C Function} {char *} scm_to_locale_string (SCM str)
@deftypefnx {C Function} {char *} scm_to_locale_stringn (SCM str, size_t *lenp)
-Returns a C string in the current locale encoding with the same
-contents as @var{str}. The C string must be freed with @code{free}
-eventually, maybe by using @code{scm_dynwind_free}, @xref{Dynamic
-Wind}.
+Returns a C string with the same contents as @var{str} in the locale
+encoding of the @code{current-output-port}. The C string must be freed
+with @code{free} eventually, maybe by using @code{scm_dynwind_free},
address@hidden Wind}.
For @code{scm_to_locale_string}, the returned string is
null-terminated and an error is signalled when @var{str} contains
@@ -3710,6 +3939,14 @@ returned string in bytes is stored in @address@hidden
The
returned string will not be null-terminated in this case. If
@var{lenp} is @code{NULL}, @code{scm_to_locale_stringn} behaves like
@code{scm_to_locale_string}.
+
+If a character in @var{str} cannot be represented in the locale encoding
+of the current output port, the port conversion strategy of the current
+output port will determine the result, @xref{Ports}. If output port's
+conversion strategy is @code{error}, an error will be raised. If it is
address@hidden, a replacement character, such as a question mark, will
+be inserted in its place. If it is @code{escape}, a hex escape will be
+inserted in its place.
@end deftypefn
@deftypefn {C Function} size_t scm_to_locale_stringbuf (SCM str, char *buf,
size_t max_len)
@@ -3725,6 +3962,71 @@ is larger than @var{max_len}, only @var{max_len} bytes
have been
stored and you probably need to try again with a larger buffer.
@end deftypefn
address@hidden String Internals
address@hidden String Internals
+
+Guile stores each string in memory as a contiguous array of Unicode code
+points along with an associated set of attributes. If all of the code
+points of a string have an integer range between 0 and 255 inclusive,
+the code point array is stored as one byte per code point: it is stored
+as an ISO-8859-1 (aka Latin-1) string. If any of the code points of the
+string has an integer value greater that 255, the code point array is
+stored as four bytes per code point: it is stored as a UTF-32 string.
+
+Conversion between the one-byte-per-code-point and
+four-bytes-per-code-point representations happens automatically as
+necessary.
+
+No API is provided to set the internal representation of strings;
+however, there are pair of procedures available to query it. These are
+debugging procedures. Using them in production code is discouraged,
+since the details of Guile's internal representation of strings may
+change from release to release.
+
address@hidden {Scheme Procedure} string-bytes-per-char str
address@hidden {C Function} scm_string_bytes_per_char (str)
+Return the number of bytes used to encode a Unicode code point in string
address@hidden The result is one or four.
address@hidden deffn
+
address@hidden {Scheme Procedure} %string-dump str
address@hidden {C Function} scm_sys_string_dump (str)
+Returns an association list containing debugging information for
address@hidden The association list has the following entries.
address@hidden @code
+
address@hidden string
+The string itself.
+
address@hidden start
+The start index of the string into its stringbuf
+
address@hidden length
+The length of the string
+
address@hidden shared
+If this string is a substring, it returns its
+parent string. Otherwise, it returns @code{#f}
+
address@hidden read-only
address@hidden if the string is read-only
+
address@hidden stringbuf-chars
+A new string containing this string's stringbuf's characters
+
address@hidden stringbuf-length
+The number of characters in this stringbuf
+
address@hidden stringbuf-shared
address@hidden if this stringbuf is shared
+
address@hidden stringbuf-wide
address@hidden if this stringbuf's characters are stored in a 32-bit buffer,
+or @code{#f} if they are stored in an 8-bit buffer
address@hidden table
address@hidden deffn
+
+
@node Bytevectors
@subsection Bytevectors
@@ -3768,6 +4070,7 @@ R6RS (@pxref{R6RS I/O Ports}).
* Bytevectors as Floats:: Interpreting bytes as real numbers.
* Bytevectors as Strings:: Interpreting bytes as Unicode strings.
* Bytevectors as Generalized Vectors:: Guile extension to the bytevector API.
+* Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4.
@end menu
@node Bytevector Endianness
@@ -4102,12 +4405,7 @@ the host's native endianness.
@cindex Unicode string encoding
Bytevector contents can also be interpreted as Unicode strings encoded
-in one of the most commonly available encoding address@hidden
-1.8 does @emph{not} support Unicode strings. Therefore, the procedures
-described here assume that Guile strings are internally encoded
-according to the current locale. For instance, if @code{$LC_CTYPE} is
address@hidden, then @code{string->utf-8} @i{et al.} will
-assume that Guile strings are Latin-1-encoded.}.
+in one of the most commonly available encoding formats.
@lisp
(utf8->string (u8-list->bytevector '(99 97 102 101)))
@@ -4118,23 +4416,27 @@ assume that Guile strings are Latin-1-encoded.}.
@end lisp
@deffn {Scheme Procedure} string->utf8 str
address@hidden {Scheme Procedure} string->utf16 str
address@hidden {Scheme Procedure} string->utf32 str
address@hidden {Scheme Procedure} string->utf16 str [endianness]
address@hidden {Scheme Procedure} string->utf32 str [endianness]
@deffnx {C Function} scm_string_to_utf8 (str)
address@hidden {C Function} scm_string_to_utf16 (str)
address@hidden {C Function} scm_string_to_utf32 (str)
address@hidden {C Function} scm_string_to_utf16 (str, endianness)
address@hidden {C Function} scm_string_to_utf32 (str, endianness)
Return a newly allocated bytevector that contains the UTF-8, UTF-16, or
-UTF-32 (aka. UCS-4) encoding of @var{str}.
+UTF-32 (aka. UCS-4) encoding of @var{str}. For UTF-16 and UTF-32,
address@hidden should be the symbol @code{big} or @code{little}; when omitted,
+it defaults to big endian.
@end deffn
@deffn {Scheme Procedure} utf8->string utf
address@hidden {Scheme Procedure} utf16->string utf
address@hidden {Scheme Procedure} utf32->string utf
address@hidden {Scheme Procedure} utf16->string utf [endianness]
address@hidden {Scheme Procedure} utf32->string utf [endianness]
@deffnx {C Function} scm_utf8_to_string (utf)
address@hidden {C Function} scm_utf16_to_string (utf)
address@hidden {C Function} scm_utf32_to_string (utf)
address@hidden {C Function} scm_utf16_to_string (utf, endianness)
address@hidden {C Function} scm_utf32_to_string (utf, endianness)
Return a newly allocated string that contains from the UTF-8-, UTF-16-,
-or UTF-32-decoded contents of bytevector @var{utf}.
+or UTF-32-decoded contents of bytevector @var{utf}. For UTF-16 and UTF-32,
address@hidden should be the symbol @code{big} or @code{little}; when omitted,
+it defaults to big endian.
@end deffn
@node Bytevectors as Generalized Vectors
@@ -4164,6 +4466,13 @@ these APIs, bytes are accessed one at a time as 8-bit
unsigned integers:
@end example
address@hidden Bytevectors as Uniform Vectors
address@hidden Accessing Bytevectors with the SRFI-4 API
+
+Bytevectors may also be accessed with the SRFI-4 API. @xref{SRFI-4 and
+Bytevectors}, for more information.
+
+
@node Regular Expressions
@subsection Regular Expressions
@tpindex Regular expressions
@@ -5550,7 +5859,7 @@ Equivalent to @code{scm_symbol_to_keyword
(scm_from_locale_symbol
@subsection ``Functionality-Centric'' Data Types
Procedures and macros are documented in their own chapter: see
address@hidden and Macros}.
address@hidden and @ref{Macros}.
Variable objects are documented as part of the description of Guile's
module system: see @ref{Variables}.
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 916453a..0aa1bb6 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.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, 2007
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -9,9 +9,9 @@
@cindex Debugging
In order to understand Guile's debugging facilities, you first need to
-understand a little about how the evaluator works and what the Scheme
-stack is. With that in place we explain the low level trap calls that
-the evaluator can be configured to make, and the trap and breakpoint
+understand a little about how Guile represent the Scheme control stack.
+With that in place we explain the low level trap calls that the
+evaluator can be configured to make, and the trap and breakpoint
infrastructure that builds on top of those calls.
@menu
@@ -24,41 +24,31 @@ infrastructure that builds on top of those calls.
@node Evaluation Model
@subsection Evaluation and the Scheme Stack
-The idea of the Scheme stack is central to a lot of debugging. It
-always exists implicitly, as a result of the way that the Guile
-evaluator works, and can be summoned into concrete existence as a
-first-class Scheme value by the @code{make-stack} call, so that an
-introspective Scheme program -- such as a debugger -- can present it in
-some way and allow the user to query its details. The first thing to
-understand, therefore, is how the workings of the evaluator build up the
-stack.
-
address@hidden Evaluations
address@hidden Applications
-Broadly speaking, the evaluator performs @dfn{evaluations} and
address@hidden An evaluation means that it is looking at a source
-code expression like @code{(+ x 5)} or @code{(if msg (loop))}, deciding
-whether the top level of the expression is a procedure call, macro,
-builtin syntax, or whatever, and doing some appropriate processing in
-each case. (In the examples here, @code{(+ x 5)} would normally be a
-procedure call, and @code{(if msg (loop))} builtin syntax.) For a
-procedure call, ``appropriate processing'' includes evaluating the
-procedure's arguments, as that must happen before the procedure itself
-can be called. An application means calling a procedure once its
-arguments have been calculated.
-
address@hidden Stack
address@hidden Frames
address@hidden Stack frames
-Typically evaluations and applications alternate with each other, and
-together they form a @dfn{stack} of operations pending completion. This
-is because, on the one hand, evaluation of an expression like @code{(+ x
-5)} requires --- once its arguments have been calculated --- an
-application (in this case, of the procedure @code{+}) before it can
-complete and return a result, and, on the other hand, the application of
-a procedure written in Scheme involves evaluating the sequence of
-expressions that constitute that procedure's code. Each level on this
-stack is called a @dfn{frame}.
+The idea of the Scheme stack is central to a lot of debugging. The
+Scheme stack is a reified representation of the pending function returns
+in an expression's continuation. As Guile implements function calls
+using a stack, this reification takes the form of a number of nested
+stack frames, each of which has the procedure and its arguments, along
+with local variables and temporary values.
+
+A Scheme stack always exists implicitly, and can be summoned into
+concrete existence as a first-class Scheme value by the
address@hidden call, so that an introspective Scheme program -- such
+as a debugger -- can present it in some way and allow the user to query
+its details. The first thing to understand, therefore, is how Guile's
+function call convention creates the stack.
+
+Broadly speaking, Guile represents all control flow on a stack. Calling
+a function involves pushing an empty frame on the stack, then evaluating
+the procedure and its arguments, then fixing up the new frame so that it
+points to the old one. Frames on the stack are thus linked together. A
+tail call is the same, except it reuses the existing frame instead of
+pushing on a new one.
+
+In this way, the only frames that are on the stack are ``active''
+frames, frames which need to do some work before the computation is
+complete. On the other hand, a function that has tail-called another
+function will not be on the stack, as it has no work left to do.
Therefore, when an error occurs in a running program, or the program
hits a breakpoint, or in fact at any point that the programmer chooses,
@@ -73,7 +63,6 @@ stack and its frames.
* Examining the Stack::
* Examining Stack Frames::
* Source Properties:: Remembering the source of an expression.
-* Decoding Memoized Source Expressions::
* Starting a New Stack::
@end menu
@@ -95,10 +84,10 @@ describes the Scheme stack at that point.
Create a new stack. If @var{obj} is @code{#t}, the current
evaluation stack is used for creating the stack frames,
otherwise the frames are taken from @var{obj} (which must be
-either a debug object or a continuation).
+a continuation or a frame object).
@var{args} should be a list containing any combination of
-integer, procedure and @code{#t} values.
+integer, procedure, prompt tag and @code{#t} values.
These values specify various ways of cutting away uninteresting
stack frames from the top and bottom of the stack that
@@ -106,28 +95,26 @@ stack frames from the top and bottom of the stack that
@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}
@var{outer_cut_2} @dots{})}.
-Each @var{inner_cut_N} can be @code{#t}, an integer, or a
-procedure. @code{#t} means to cut away all frames up to but
-excluding the first user module frame. An integer means to cut
-away exactly that number of frames. A procedure means to cut
-away all frames up to but excluding the application frame whose
+Each @var{inner_cut_N} can be @code{#t}, an integer, a prompt
+tag, or a procedure. @code{#t} means to cut away all frames up
+to but excluding the first user module frame. An integer means
+to cut away exactly that number of frames. A prompt tag means
+to cut away all frames that are inside a prompt with the given
+tag. A procedure means to cut away all frames up to but
+excluding the application frame whose procedure matches the
+specified one.
+
+Each @var{outer_cut_N} can be an integer, a prompt tag, or a
+procedure. An integer means to cut away that number of frames.
+A prompt tag means to cut away all frames that are outside a
+prompt with the given tag. A procedure means to cut away
+frames down to but excluding the application frame whose
procedure matches the specified one.
-Each @var{outer_cut_N} can be an integer or a procedure. An
-integer means to cut away that number of frames. A procedure
-means to cut away frames down to but excluding the application
-frame whose procedure matches the specified one.
-
If the @var{outer_cut_N} of the last pair is missing, it is
taken as 0.
@end deffn
address@hidden {Scheme Procedure} last-stack-frame obj
address@hidden {C Function} scm_last_stack_frame (obj)
-Return the last (innermost) frame of @var{obj}, which must be
-either a debug object or a continuation.
address@hidden deffn
-
@node Examining the Stack
@subsubsection Examining the Stack
@@ -174,33 +161,12 @@ backtrace.
Return @code{#t} if @var{obj} is a stack frame.
@end deffn
address@hidden {Scheme Procedure} frame-number frame
address@hidden {C Function} scm_frame_number (frame)
-Return the frame number of @var{frame}.
address@hidden deffn
-
@deffn {Scheme Procedure} frame-previous frame
@deffnx {C Function} scm_frame_previous (frame)
Return the previous frame of @var{frame}, or @code{#f} if
@var{frame} is the first frame in its stack.
@end deffn
address@hidden {Scheme Procedure} frame-next frame
address@hidden {C Function} scm_frame_next (frame)
-Return the next frame of @var{frame}, or @code{#f} if
address@hidden is the last frame in its stack.
address@hidden deffn
-
address@hidden {Scheme Procedure} frame-source frame
address@hidden {C Function} scm_frame_source (frame)
-Return the source of @var{frame}.
address@hidden deffn
-
address@hidden {Scheme Procedure} frame-procedure? frame
address@hidden {C Function} scm_frame_procedure_p (frame)
-Return @code{#t} if a procedure is associated with @var{frame}.
address@hidden deffn
-
@deffn {Scheme Procedure} frame-procedure frame
@deffnx {C Function} scm_frame_procedure (frame)
Return the procedure for @var{frame}, or @code{#f} if no
@@ -212,21 +178,6 @@ procedure is associated with @var{frame}.
Return the arguments of @var{frame}.
@end deffn
address@hidden {Scheme Procedure} frame-evaluating-args? frame
address@hidden {C Function} scm_frame_evaluating_args_p (frame)
-Return @code{#t} if @var{frame} contains evaluated arguments.
address@hidden deffn
-
address@hidden {Scheme Procedure} frame-overflow? frame
address@hidden {C Function} scm_frame_overflow_p (frame)
-Return @code{#t} if @var{frame} is an overflow frame.
address@hidden deffn
-
address@hidden {Scheme Procedure} frame-real? frame
address@hidden {C Function} scm_frame_real_p (frame)
-Return @code{#t} if @var{frame} is a real frame.
address@hidden deffn
-
@deffn {Scheme Procedure} display-application frame [port [indent]]
@deffnx {C Function} scm_display_application (frame, port, indent)
Display a procedure application @var{frame} to the output port
@@ -241,14 +192,12 @@ output.
@cindex source properties
As Guile reads in Scheme code from file or from standard input, it
remembers the file name, line number and column number where each
-expression begins. These pieces of information are known as the
address@hidden properties} of the expression. If an expression undergoes
-transformation --- for example, if there is a syntax transformer in
-effect, or the expression is a macro call --- the source properties are
-copied from the untransformed to the transformed expression so that, if
-an error occurs when evaluating the transformed expression, Guile's
-debugger can point back to the file and location where the expression
-originated.
+expression begins. These pieces of information are known as the
address@hidden properties} of the expression. Syntax expanders and the
+compiler propagate these source properties to compiled procedures, so
+that, if an error occurs when evaluating the transformed expression,
+Guile's debugger can point back to the file and location where the
+expression originated.
The way that source properties are stored means that Guile can only
associate source properties with parenthesized expressions, and not, for
@@ -274,10 +223,7 @@ port>''.
The recording of source properties is controlled by the read option
named ``positions'' (@pxref{Reader options}). This option is switched
address@hidden by default, together with the debug options ``debug'' and
-``backtrace'' (@pxref{Debugger options}), when Guile is run
-interactively; all these options are @emph{off} by default when Guile
-runs a script non-interactively.
address@hidden by default.
The following procedures can be used to access and set the source
properties of read expressions.
@@ -305,51 +251,19 @@ Return the property specified by @var{key} from
@var{obj}'s source
properties.
@end deffn
-In practice there are only two ways that you should use the ability to
-set an expression's source properties.
+If the @code{positions} reader option is enabled, each parenthesized
+expression will have values set for the @code{filename}, @code{line} and
address@hidden properties.
address@hidden
address@hidden
-To set a breakpoint on an expression, use @code{(set-source-property!
address@hidden 'breakpoint #t)}. If you do this, you should also set the
address@hidden and @code{enter-frame-handler} trap options
-(@pxref{Evaluator trap options}) and @code{breakpoints} debug option
-(@pxref{Debugger options}) appropriately, and the evaluator will then
-call your enter frame handler whenever it is about to evaluate that
-expression.
-
address@hidden
-To make a read or constructed expression appear to have come from a
-different source than what the expression's source properties already
-say, you can use @code{set-source-property!} to set the expression's
address@hidden, @code{line} and @code{column} properties. The
-properties that you set will then show up later if that expression is
-involved in a backtrace or error report.
address@hidden itemize
-
-If you are looking for a way to attach arbitrary information to an
-expression other than these properties, you should use
address@hidden instead (@pxref{Object Properties}). That
-will avoid bloating the source property hash table, which is really
-only intended for the debugging purposes just described.
-
-
address@hidden Decoding Memoized Source Expressions
address@hidden Decoding Memoized Source Expressions
-
address@hidden {Scheme Procedure} memoized? obj
address@hidden {C Function} scm_memoized_p (obj)
-Return @code{#t} if @var{obj} is memoized.
address@hidden deffn
+If you're stuck with defmacros (@pxref{Defmacros}), and want to preserve
+source information, the following helper function might be useful to
+you:
address@hidden {Scheme Procedure} unmemoize m
address@hidden {C Function} scm_unmemoize (m)
-Unmemoize the memoized expression @var{m},
address@hidden deffn
-
address@hidden {Scheme Procedure} memoized-environment m
address@hidden {C Function} scm_memoized_environment (m)
-Return the environment of the memoized expression @var{m}.
address@hidden {Scheme Procedure} cons-source xorig x y
address@hidden {C Function} scm_cons_source (xorig, x, y)
+Create and return a new pair whose car and cdr are @var{x} and @var{y}.
+Any source properties associated with @var{xorig} are also associated
+with the new pair.
@end deffn
@@ -376,15 +290,15 @@ the error chose explicitly to provide. This information
originates with
the @code{error} or @code{throw} call (or their C code equivalents, if
the error is detected by C code) that signals the error, and is passed
automatically to the handler procedure of the innermost applicable
address@hidden, @code{lazy-catch} or @code{with-throw-handler} expression.
address@hidden or @code{with-throw-handler} expression.
@subsubsection Intercepting basic error information
Therefore, to catch errors that occur within a chunk of Scheme code, and
to intercept basic information about those errors, you need to execute
-that code inside the dynamic context of a @code{catch},
address@hidden or @code{with-throw-handler} expression, or the
-equivalent in C. In Scheme, this means you need something like this:
+that code inside the dynamic context of a @code{catch} or
address@hidden expression, or the equivalent in C. In Scheme,
+this means you need something like this:
@lisp
(catch #t
@@ -399,13 +313,12 @@ equivalent in C. In Scheme, this means you need
something like this:
@end lisp
@noindent
-The @code{catch} here can also be @code{lazy-catch} or
address@hidden; see @ref{Throw Handlers} and @ref{Lazy Catch}
-for the details of how these differ from @code{catch}. The @code{#t}
-means that the catch is applicable to all kinds of error; if you want to
-restrict your catch to just one kind of error, you can put the symbol
-for that kind of error instead of @code{#t}. The equivalent to this in
-C would be something like this:
+The @code{catch} here can also be @code{with-throw-handler}; see @ref{Throw
+Handlers} for information on the when you might want to use
address@hidden instead of @code{catch}. The @code{#t} means that the
+catch is applicable to all kinds of error; if you want to restrict your catch
to
+just one kind of error, you can put the symbol for that kind of error instead
of
address@hidden The equivalent to this in C would be something like this:
@lisp
SCM my_body_proc (void *body_data)
@@ -436,9 +349,8 @@ SCM my_handler_proc (void *handler_data,
@noindent
Again, as with the Scheme version, @code{scm_c_catch} could be replaced
-by @code{scm_internal_lazy_catch} or @code{scm_c_with_throw_handler},
-and @code{SCM_BOOL_T} could instead be the symbol for a particular kind
-of error.
+by @code{scm_c_with_throw_handler}, and @code{SCM_BOOL_T} could instead
+be the symbol for a particular kind of error.
@subsubsection Capturing the full error stack
@@ -446,19 +358,10 @@ The other interesting information about an error is the
full Scheme
stack at the point where the error occurred; in other words what
innermost expression was being evaluated, what was the expression that
called that one, and so on. If you want to write your code so that it
-captures and can display this information as well, there are three
+captures and can display this information as well, there are a couple
important things to understand.
-Firstly, the code in question must be executed using the debugging
-version of the evaluator, because information about the Scheme stack is
-only available at all from the debugging evaluator. Using the debugging
-evaluator means that the debugger option (@pxref{Debugger options})
-called @code{debug} must be enabled; this can be done by running
address@hidden(debug-enable 'debug)} or @code{(turn-on-debugging)} at the top
-level of your program; or by running guile with the @code{--debug}
-command line option, if your program begins life as a Scheme script.
-
-Secondly, the stack at the point of the error needs to be explicitly
+Firstly, the stack at the point of the error needs to be explicitly
captured by a @code{make-stack} call (or the C equivalent
@code{scm_make_stack}). The Guile library does not do this
``automatically'' for you, so you will need to write code with a
@@ -472,16 +375,15 @@ running on top of the Guile library, and which uses
@code{catch} and
@code{make-stack} in the way we are about to describe to capture the
stack when an error occurs.)
-Thirdly, in order to capture the stack effectively at the point where
-the error occurred, the @code{make-stack} call must be made before Guile
-unwinds the stack back to the location of the prevailing catch
-expression. This means that the @code{make-stack} call must be made
-within the handler of a @code{lazy-catch} or @code{with-throw-handler}
-expression, or the optional "pre-unwind" handler of a @code{catch}.
-(For the full story of how these alternatives differ from each other,
-see @ref{Exceptions}. The main difference is that @code{catch}
-terminates the error, whereas @code{lazy-catch} and
address@hidden only intercept it temporarily and then allow
+And secondly, in order to capture the stack effectively at the point
+where the error occurred, the @code{make-stack} call must be made before
+Guile unwinds the stack back to the location of the prevailing catch
+expression. This means that the @code{make-stack} call must be made
+within the handler of a @code{with-throw-handler} expression, or the
+optional "pre-unwind" handler of a @code{catch}. (For the full story of
+how these alternatives differ from each other, see @ref{Exceptions}. The
+main difference is that @code{catch} terminates the error, whereas
address@hidden only intercepts it temporarily and then allow
it to continue propagating up to the next innermost handler.)
So, here are some examples of how to do all this in Scheme and in C.
@@ -582,11 +484,11 @@ application frame -- that is, a frame that satisfies the
@subsubsection What the Guile REPL does
-The Guile REPL code (in @file{ice-9/boot-9.scm}) uses a @code{catch}
-with a pre-unwind handler to capture the stack when an error occurs in
-an expression that was typed into the REPL, and saves the captured stack
-in a fluid (@pxref{Fluids and Dynamic States}) called
address@hidden You can then use the @code{(backtrace)} command,
+The Guile REPL code (in @file{system/repl/repl.scm} and related files)
+uses a @code{catch} with a pre-unwind handler to capture the stack when
+an error occurs in an expression that was typed into the REPL, and saves
+the captured stack in a fluid (@pxref{Fluids and Dynamic States}) called
address@hidden You can then use the @code{(backtrace)} command,
which is basically equivalent to @code{(display-backtrace (fluid-ref
the-last-stack))}, to print out this stack at any time until it is
overwritten by the next error that occurs.
@@ -619,17 +521,16 @@ Invoke the Guile debugger to explore the context of the
last error.
@cindex Tracing
@cindex Code coverage
@cindex Profiling
-The low level C code of Guile's evaluator can be configured to call
-out at key points to arbitrary user-specified procedures. These
-procedures, and the circumstances under which the evaluator calls
-them, are configured by the ``evaluator trap options'' interface
-(@pxref{Evaluator trap options}), and by the @code{trace} and
address@hidden fields of the ``debug options'' interface
-(@pxref{Debugger options}). In principle this allows Scheme code to
-implement any model it chooses for examining the evaluation stack as
-program execution proceeds, and for suspending execution to be resumed
-later. Possible applications of this feature include breakpoints,
-runtime tracing, code coverage, and profiling.
+Guile's virtual machine can be configured to call out at key points to
+arbitrary user-specified procedures. For more information on these
+hooks, and the circumstances under which the VM calls them, see @ref{VM
+Behaviour}.
+
+In principle, these hooks allow Scheme code to implement any model it
+chooses for examining the evaluation stack as program execution
+proceeds, and for suspending execution to be resumed later. Possible
+applications of this feature include breakpoints, runtime tracing, code
+coverage, and profiling.
@cindex Trap classes
@cindex Trap objects
@@ -650,6 +551,14 @@ user wanting to use traps, and the developer interested in
understanding how the interface hangs together.
address@hidden Actually, this section is bitrotten
+
+Dear reader: the following sections have some great ideas, and some code
+that just needs a few days of massaging to get it to work with the VM
+(as opposed to the old interpreter). Want to help? Yes? Yes!
address@hidden@@gnu.org}, that's where.
+
+
@subsubsection A Quick Note on Terminology
@cindex Trap terminology
@@ -1886,19 +1795,6 @@ hi!
guile>
@end lisp
address@hidden
address@hidden Memoization
-(For anyone wondering why the first @code{(do-main 4)} call above
-generates lots more trace lines than the subsequent calls: these
-examples also demonstrate how the Guile evaluator ``memoizes'' code.
-When Guile evaluates a source code expression for the first time, it
-changes some parts of the expression so that they will be quicker to
-evaluate when that expression is evaluated again; this is called
-memoization. The trace output from the first @code{(do-main 4)} call
-shows memoization steps, such as an internal define being transformed to
-a letrec.)
-
-
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 457015e..21eee68 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -291,7 +291,9 @@ Install the procedure @var{proc} for reading expressions
starting with the character sequence @code{#} and @var{chr}.
@var{proc} will be called with two arguments: the character
@var{chr} and the port to read further data from. The object
-returned will be the return value of @code{read}.
+returned will be the return value of @code{read}.
+Passing @code{#f} for @var{proc} will remove a previous setting.
+
@end deffn
@@ -457,8 +459,7 @@ Note that well-written Scheme programs will not typically
call the
procedures in this section, for the same reason that it is often bad
taste to use @code{eval}. The normal interface to the compiler is the
command-line file compiler, which can be invoked from the shell as
address@hidden compile @var{foo.scm}}. This interface needs more
-documentation.
address@hidden compile foo.scm}.
(Why are calls to @code{eval} and @code{compile} usually in bad taste?
Because they are limited, in that they can only really make sense for
@@ -471,6 +472,49 @@ For more information on the compiler itself, see
@ref{Compiling to the
Virtual Machine}. For information on the virtual machine, see @ref{A
Virtual Machine for Guile}.
+The command-line interface to Guile's compiler is the @command{guile-tools
+compile} command:
+
address@hidden {Command} {guile-tools compile} address@hidden @var{file}...
+Compile @var{file}, a source file, and store bytecode in the compilation cache
+or in the file specified by the @option{-o} option. The following options are
+available:
+
address@hidden @option
+
address@hidden -L @var{dir}
address@hidden address@hidden
+Add @var{dir} to the front of the module load path.
+
address@hidden -o @var{ofile}
address@hidden address@hidden
+Write output bytecode to @var{ofile}. By convention, bytecode file names end
+in @code{.go}.
+
address@hidden -W @var{warning}
address@hidden address@hidden
+Emit warnings of type @var{warning}; use @code{--warn=help} for a list of
+available warnings. Currently recognized warnings include
address@hidden, @code{unused-toplevel}, @code{unbound-variable}, and
address@hidden
+
address@hidden -f @var{lang}
address@hidden address@hidden
+Use @var{lang} as the source language of @var{file}. If this option is
omitted,
address@hidden is assumed.
+
address@hidden -t @var{lang}
address@hidden address@hidden
+Use @var{lang} as the target language of @var{file}. If this option is
omitted,
address@hidden is assumed.
+
address@hidden table
+
address@hidden deffn
+
+The compiler can also be invoked directly by Scheme code using the procedures
+below:
+
@deffn {Scheme Procedure} compile exp [env=#f] [from=(current-language)]
[to=value] [opts=()]
Compile the expression @var{exp} in the environment @var{env}. If
@var{exp} is a procedure, the result will be a compiled procedure;
@@ -856,6 +900,15 @@ Accessors to a virtual machine's hooks. Usually you pass
@code{(the-vm)} as the @var{vm}.
@end deffn
address@hidden {Scheme Procedure} vm-trace-level vm
+Retrieve the ``trace level'' of the VM. If positive, the trace hooks associated
+with @var{vm} will be run. The initial trace level is 0.
address@hidden deffn
+
address@hidden {Scheme Procedure} set-vm-trace-level! vm level
+Set the ``trace level'' of the VM.
address@hidden deffn
+
@xref{A Virtual Machine for Guile}, for more information on Guile's
virtual machine.
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
new file mode 100644
index 0000000..2a4f0df
--- /dev/null
+++ b/doc/ref/api-foreign.texi
@@ -0,0 +1,831 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2008, 2009, 2010
address@hidden Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
+
address@hidden
address@hidden Foreign Function Interface
address@hidden Foreign Function Interface
address@hidden foreign function interface
address@hidden ffi
+
+The more one hacks in Scheme, the more one realizes that there are
+actually two computational worlds: one which is warm and alive, that
+land of parentheses, and one cold and dead, the land of C and its ilk.
+
+But yet we as programmers live in both worlds, and Guile itself is half
+implemented in C. So it is that Guile's living half pays respect to its
+dead counterpart, via a spectrum of interfaces to C ranging from dynamic
+loading of Scheme primitives to dynamic binding of stock C library
+prodedures.
+
address@hidden
+* Foreign Libraries:: Dynamically linking to libraries.
+* Foreign Functions:: Simple calls to C procedures.
+* C Extensions:: Extending Guile in C with loadable modules.
+* Modules and Extensions:: Loading C extensions into modules.
+* Foreign Pointers:: Accessing global variables.
+* Dynamic FFI:: Calling arbitrary C functions.
address@hidden menu
+
+
address@hidden Foreign Libraries
address@hidden Foreign Libraries
+
+Most modern Unices have something called @dfn{shared libraries}. This
+ordinarily means that they have the capability to share the executable
+image of a library between several running programs to save memory and
+disk space. But generally, shared libraries give a lot of additional
+flexibility compared to the traditional static libraries. In fact,
+calling them `dynamic' libraries is as correct as calling them `shared'.
+
+Shared libraries really give you a lot of flexibility in addition to the
+memory and disk space savings. When you link a program against a shared
+library, that library is not closely incorporated into the final
+executable. Instead, the executable of your program only contains
+enough information to find the needed shared libraries when the program
+is actually run. Only then, when the program is starting, is the final
+step of the linking process performed. This means that you need not
+recompile all programs when you install a new, only slightly modified
+version of a shared library. The programs will pick up the changes
+automatically the next time they are run.
+
+Now, when all the necessary machinery is there to perform part of the
+linking at run-time, why not take the next step and allow the programmer
+to explicitly take advantage of it from within his program? Of course,
+many operating systems that support shared libraries do just that, and
+chances are that Guile will allow you to access this feature from within
+your Scheme programs. As you might have guessed already, this feature
+is called @dfn{dynamic address@hidden people also refer to the
+final linking stage at program startup as `dynamic linking', so if you
+want to make yourself perfectly clear, it is probably best to use the
+more technical term @dfn{dlopening}, as suggested by Gordon Matzigkeit
+in his libtool documentation.}
+
+We titled this section ``foreign libraries'' because although the name
+``foreign'' doesn't leak into the API, the world of C really is foreign
+to Scheme -- and that estrangement extends to components of foreign
+libraries as well, as we see in future sections.
+
address@hidden {Scheme Procedure} dynamic-link [library]
address@hidden {C Function} scm_dynamic_link (library)
+Find the shared library denoted by @var{library} (a string) and link it
+into the running Guile application. When everything works out, return a
+Scheme object suitable for representing the linked object file.
+Otherwise an error is thrown. How object files are searched is system
+dependent.
+
+Normally, @var{library} is just the name of some shared library file
+that will be searched for in the places where shared libraries usually
+reside, such as in @file{/usr/lib} and @file{/usr/local/lib}.
+
+When @var{library} is omitted, a @dfn{global symbol handle} is returned. This
+handle provides access to the symbols available to the program at run-time,
+including those exported by the program itself and the shared libraries already
+loaded.
address@hidden deffn
+
address@hidden {Scheme Procedure} dynamic-object? obj
address@hidden {C Function} scm_dynamic_object_p (obj)
+Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}
+otherwise.
address@hidden deffn
+
address@hidden {Scheme Procedure} dynamic-unlink dobj
address@hidden {C Function} scm_dynamic_unlink (dobj)
+Unlink the indicated object file from the application. The
+argument @var{dobj} must have been obtained by a call to
address@hidden After @code{dynamic-unlink} has been
+called on @var{dobj}, its content is no longer accessible.
address@hidden deffn
+
address@hidden
+(define libgl-obj (dynamic-link "libGL"))
+libgl-obj
address@hidden #<dynamic-object "libGL">
+(dynamic-unlink libGL-obj)
+libGL-obj
address@hidden #<dynamic-object "libGL" (unlinked)>
address@hidden smallexample
+
+As you can see, after calling @code{dynamic-unlink} on a dynamically
+linked library, it is marked as @samp{(unlinked)} and you are no longer
+able to use it with @code{dynamic-call}, etc. Whether the library is
+really removed from you program is system-dependent and will generally
+not happen when some other parts of your program still use it.
+
+When dynamic linking is disabled or not supported on your system,
+the above functions throw errors, but they are still available.
+
+
address@hidden Foreign Functions
address@hidden Foreign Functions
+
+The most natural thing to do with a dynamic library is to grovel around
+in it for a function pointer: a @dfn{foreign function}.
address@hidden exists for that purpose.
+
address@hidden {Scheme Procedure} dynamic-func name dobj
address@hidden {C Function} scm_dynamic_func (name, dobj)
+Return a ``handle'' for the func @var{name} in the shared object referred to
+by @var{dobj}. The handle can be passed to @code{dynamic-call} to
+actually call the function.
+
+Regardless whether your C compiler prepends an underscore @samp{_} to the
global
+names in a program, you should @strong{not} include this underscore in
address@hidden since it will be added automatically when necessary.
address@hidden deffn
+
+Guile has static support for calling functions with no arguments,
address@hidden
+
address@hidden {Scheme Procedure} dynamic-call func dobj
address@hidden {C Function} scm_dynamic_call (func, dobj)
+Call the C function indicated by @var{func} and @var{dobj}.
+The function is passed no arguments and its return value is
+ignored. When @var{function} is something returned by
address@hidden, call that function and ignore @var{dobj}.
+When @var{func} is a string , look it up in @var{dynobj}; this
+is equivalent to
address@hidden
+(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)
address@hidden smallexample
+
+Interrupts are deferred while the C function is executing (with
address@hidden/@code{SCM_ALLOW_INTS}).
address@hidden deffn
+
address@hidden is not very powerful. It is mostly intended to be
+used for calling specially written initialization functions that will
+then add new primitives to Guile. For example, we do not expect that you
+will dynamically link @file{libX11} with @code{dynamic-link} and then
+construct a beautiful graphical user interface just by using
address@hidden Instead, the usual way would be to write a special
+Guile-to-X11 glue library that has intimate knowledge about both Guile
+and X11 and does whatever is necessary to make them inter-operate
+smoothly. This glue library could then be dynamically linked into a
+vanilla Guile interpreter and activated by calling its initialization
+function. That function would add all the new types and primitives to
+the Guile interpreter that it has to offer.
+
+(There is actually another, better option: simply to create a
address@hidden wrapper in Scheme via the dynamic FFI. @xref{Dynamic FFI},
+for more information.)
+
+Given some set of C extensions to Guile, the next logical step is to
+integrate these glue libraries into the module system of Guile so that
+you can load new primitives into a running system just as you can load
+new Scheme code.
+
address@hidden {Scheme Procedure} load-extension lib init
address@hidden {C Function} scm_load_extension (lib, init)
+Load and initialize the extension designated by LIB and INIT.
+When there is no pre-registered function for LIB/INIT, this is
+equivalent to
+
address@hidden
+(dynamic-call INIT (dynamic-link LIB))
address@hidden lisp
+
+When there is a pre-registered function, that function is called
+instead.
+
+Normally, there is no pre-registered function. This option exists
+only for situations where dynamic linking is unavailable or unwanted.
+In that case, you would statically link your program with the desired
+library, and register its init function right after Guile has been
+initialized.
+
+LIB should be a string denoting a shared library without any file type
+suffix such as ".so". The suffix is provided automatically. It
+should also not contain any directory components. Libraries that
+implement Guile Extensions should be put into the normal locations for
+shared libraries. We recommend to use the naming convention
+libguile-bla-blum for a extension related to a module `(bla blum)'.
+
+The normal way for a extension to be used is to write a small Scheme
+file that defines a module, and to load the extension into this
+module. When the module is auto-loaded, the extension is loaded as
+well. For example,
+
address@hidden
+(define-module (bla blum))
+
+(load-extension "libguile-bla-blum" "bla_init_blum")
address@hidden lisp
address@hidden deffn
+
address@hidden C Extensions
address@hidden C Extensions
+
+The most interesting application of dynamically linked libraries is
+probably to use them for providing @emph{compiled code modules} to
+Scheme programs. As much fun as programming in Scheme is, every now and
+then comes the need to write some low-level C stuff to make Scheme even
+more fun.
+
+Not only can you put these new primitives into their own module (see the
+previous section), you can even put them into a shared library that is
+only then linked to your running Guile image when it is actually
+needed.
+
+An example will hopefully make everything clear. Suppose we want to
+make the Bessel functions of the C library available to Scheme in the
+module @samp{(math bessel)}. First we need to write the appropriate
+glue code to convert the arguments and return values of the functions
+from Scheme to C and back. Additionally, we need a function that will
+add them to the set of Guile primitives. Because this is just an
+example, we will only implement this for the @code{j0} function.
+
address@hidden
+#include <math.h>
+#include <libguile.h>
+
+SCM
+j0_wrapper (SCM x)
address@hidden
+ return scm_from_double (j0 (scm_to_double (x, "j0")));
address@hidden
+
+void
+init_math_bessel ()
address@hidden
+ scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper);
address@hidden
address@hidden smallexample
+
+We can already try to bring this into action by manually calling the low
+level functions for performing dynamic linking. The C source file needs
+to be compiled into a shared library. Here is how to do it on
+GNU/Linux, please refer to the @code{libtool} documentation for how to
+create dynamically linkable libraries portably.
+
address@hidden
+gcc -shared -o libbessel.so -fPIC bessel.c
address@hidden smallexample
+
+Now fire up Guile:
+
address@hidden
+(define bessel-lib (dynamic-link "./libbessel.so"))
+(dynamic-call "init_math_bessel" bessel-lib)
+(j0 2)
address@hidden 0.223890779141236
address@hidden lisp
+
+The filename @file{./libbessel.so} should be pointing to the shared
+library produced with the @code{gcc} command above, of course. The
+second line of the Guile interaction will call the
address@hidden function which in turn will register the C
+function @code{j0_wrapper} with the Guile interpreter under the name
address@hidden This function becomes immediately available and we can call
+it from Scheme.
+
+Fun, isn't it? But we are only half way there. This is what
address@hidden has to say about @code{j0}:
+
address@hidden
+(apropos "j0")
address@hidden (guile-user): j0 #<primitive-procedure j0>
address@hidden smallexample
+
+As you can see, @code{j0} is contained in the root module, where all
+the other Guile primitives like @code{display}, etc live. In general,
+a primitive is put into whatever module is the @dfn{current module} at
+the time @code{scm_c_define_gsubr} is called.
+
+A compiled module should have a specially named @dfn{module init
+function}. Guile knows about this special name and will call that
+function automatically after having linked in the shared library. For
+our example, we replace @code{init_math_bessel} with the following code in
address@hidden:
+
address@hidden
+void
+init_math_bessel (void *unused)
address@hidden
+ scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper);
+ scm_c_export ("j0", NULL);
address@hidden
+
+void
+scm_init_math_bessel_module ()
address@hidden
+ scm_c_define_module ("math bessel", init_math_bessel, NULL);
address@hidden
address@hidden smallexample
+
+The general pattern for the name of a module init function is:
address@hidden, followed by the name of the module where the
+individual hierarchical components are concatenated with underscores,
+followed by @samp{_module}.
+
+After @file{libbessel.so} has been rebuilt, we need to place the shared
+library into the right place.
+
+Once the module has been correctly installed, it should be possible to
+use it like this:
+
address@hidden
+guile> (load-extension "./libbessel.so" "scm_init_math_bessel_module")
+guile> (use-modules (math bessel))
+guile> (j0 2)
+0.223890779141236
+guile> (apropos "j0")
address@hidden (math bessel): j0 #<primitive-procedure j0>
address@hidden smallexample
+
+That's it!
+
+
address@hidden Modules and Extensions
address@hidden Modules and Extensions
+
+The new primitives that you add to Guile with @code{scm_c_define_gsubr}
+(@pxref{Primitive Procedures}) or with any of the other mechanisms are
+placed into the module that is current when the
address@hidden is executed. Extensions loaded from the REPL,
+for example, will be placed into the @code{(guile-user)} module, if the
+REPL module was not changed.
+
+To define C primitives within a specific module, the simplest way is:
+
address@hidden
+(define-module (foo bar))
+(load-extension "foobar-c-code" "foo_bar_init")
address@hidden example
+
+When loaded with @code{(use-modules (foo bar))}, the
address@hidden call looks for the @file{foobar-c-code.so} (etc)
+object file in the standard system locations, such as @file{/usr/lib}
+or @file{/usr/local/lib}.
+
+If someone installs your module to a non-standard location then the
+object file won't be found. You can address this by inserting the
+install location in the @file{foo/bar.scm} file. This is convenient
+for the user and also guarantees the intended object is read, even if
+stray older or newer versions are in the loader's path.
+
+The usual way to specify an install location is with a @code{prefix}
+at the configure stage, for instance @samp{./configure prefix=/opt}
+results in library files as say @file{/opt/lib/foobar-c-code.so}.
+When using Autoconf (@pxref{Top, , Introduction, autoconf, The GNU
+Autoconf Manual}), the library location is in a @code{libdir}
+variable. Its value is intended to be expanded by @command{make}, and
+can by substituted into a source file like @file{foo.scm.in}
+
address@hidden
+(define-module (foo bar))
+(load-extension "XXlibdirXX/foobar-c-code" "foo_bar_init")
address@hidden example
+
address@hidden
+with the following in a @file{Makefile}, using @command{sed}
+(@pxref{Top, , Introduction, sed, SED, A Stream Editor}),
+
address@hidden
+foo.scm: foo.scm.in
+ sed 's|XXlibdirXX|$(libdir)|' <foo.scm.in >foo.scm
address@hidden example
+
+The actual pattern @code{XXlibdirXX} is arbitrary, it's only something
+which doesn't otherwise occur. If several modules need the value, it
+can be easier to create one @file{foo/config.scm} with a define of the
address@hidden location, and use that as required.
+
address@hidden
+(define-module (foo config))
+(define-public foo-config-libdir "XXlibdirXX"")
address@hidden example
+
+Such a file might have other locations too, for instance a data
+directory for auxiliary files, or @code{localedir} if the module has
+its own @code{gettext} message catalogue
+(@pxref{Internationalization}).
+
+When installing multiple C code objects, it can be convenient to put
+them in a subdirectory of @code{libdir}, thus giving for example
address@hidden/usr/lib/foo/some-obj.so}. If the objects are only meant to be
+used through the module, then a subdirectory keeps them out of sight.
+
+It will be noted all of the above requires that the Scheme code to be
+found in @code{%load-path} (@pxref{Build Config}). Presently it's
+left up to the system administrator or each user to augment that path
+when installing Guile modules in non-default locations. But having
+reached the Scheme code, that code should take care of hitting any of
+its own private files etc.
+
+Presently there's no convention for having a Guile version number in
+module C code filenames or directories. This is primarily because
+there's no established principles for two versions of Guile to be
+installed under the same prefix (eg. two both under @file{/usr}).
+Assuming upward compatibility is maintained then this should be
+unnecessary, and if compatibility is not maintained then it's highly
+likely a package will need to be revisited anyway.
+
+The present suggestion is that modules should assume when they're
+installed under a particular @code{prefix} that there's a single
+version of Guile there, and the @code{guile-config} at build time has
+the necessary information about it. C code or Scheme code might adapt
+itself accordingly (allowing for features not available in an older
+version for instance).
+
+
address@hidden Foreign Pointers
address@hidden Foreign Pointers
+
+The previous sections have shown how Guile can be extended at runtime by
+loading compiled C extensions. This approach is all well and good, but
+wouldn't it be nice if we didn't have to write any C at all? This
+section takes up the problem of accessing C values from Scheme, and the
+next discusses C functions.
+
address@hidden
+* Foreign Types:: Expressing C types in Scheme.
+* Foreign Variables:: Typed pointers.
+* Void Pointers and Byte Access:: Pointers into the ether.
+* Foreign Structs:: Packing and unpacking structs.
address@hidden menu
+
address@hidden Foreign Types
address@hidden Foreign Types
+
+The first impedance mismatch that one sees between C and Scheme is that
+in C, the storage locations (variables) are typed, but in Scheme types
+are associated with values, not variables. @xref{Values and Variables}.
+
+So when accessing a C value through a Scheme pointer, we must give the
+type of the pointed-to value explicitly, as a parameter to any Scheme
+procedure that accesses the value.
+
+These ``C type values'' may be constructed using the constants and
+procedures from the @code{(system foreign)} module, which may be loaded
+like this:
+
address@hidden
+(use-modules (system foreign))
address@hidden example
+
address@hidden(system foreign)} exports a number of values expressing the basic
+C types:
+
address@hidden {Scheme Variable} int8
address@hidden {Scheme Variable} uint8
address@hidden {Scheme Variable} uint16
address@hidden {Scheme Variable} int16
address@hidden {Scheme Variable} uint32
address@hidden {Scheme Variable} int32
address@hidden {Scheme Variable} uint64
address@hidden {Scheme Variable} int64
address@hidden {Scheme Variable} float
address@hidden {Scheme Variable} double
+Values exported by the @code{(system foreign)} module, representing C
+numeric types of the specified sizes and signednesses.
address@hidden defvr
+
+In addition there are some convenience bindings for indicating types of
+platform-dependent size:
+
address@hidden {Scheme Variable} int
address@hidden {Scheme Variable} unsigned-int
address@hidden {Scheme Variable} long
address@hidden {Scheme Variable} unsigned-long
address@hidden {Scheme Variable} size_t
+Values exported by the @code{(system foreign)} module, representing C
+numeric types. For example, @code{long} may be @code{equal?} to
address@hidden on a 64-bit platform.
address@hidden defvr
+
address@hidden Foreign Variables
address@hidden Foreign Variables
+
+Given the types defined in the previous section, C pointers may be
+looked up dynamically using @code{dynamic-pointer}.
+
address@hidden {Scheme Procedure} dynamic-pointer name type dobj [len]
address@hidden {C Function} scm_dynamic_pointer (name, type, dobj, len)
+Return a ``handle'' for the pointer @var{name} in the shared object referred to
+by @var{dobj}. The handle aliases a C value, and is declared to be of type
address@hidden Valid types are defined in the @code{(system foreign)} module.
+
+This facility works by asking the dynamic linker for the address of a symbol,
+then assuming that it aliases a value of a given type. Obviously, the user must
+be very careful to ensure that the value actually is of the declared type, or
+bad things will happen.
+
+Regardless whether your C compiler prepends an underscore @samp{_} to the
global
+names in a program, you should @strong{not} include this underscore in
address@hidden since it will be added automatically when necessary.
address@hidden deffn
+
+For example, currently Guile has a variable, @code{scm_numptob}, as part
+of its API. It is declared as a C @code{long}. So, to create a handle
+pointing to that foreign value, we do:
+
address@hidden
+(use-modules (system foreign))
+(define numptob (dynamic-pointer "scm_numptob" long (dynamic-link)))
+numptob
address@hidden #<foreign int32 8>
address@hidden example
+
+A value returned by @code{dynamic-pointer} is a Scheme wrapper for a C
+pointer, with additional type information. A foreign pointer prints
+according to its type. This example showed that a @code{long} on this
+platform is an @code{int32}, and that the value pointed to by
address@hidden is 8.
+
+Typed pointers may be referenced using the @code{foreign-ref} and
address@hidden functions.
+
address@hidden {Scheme Procedure} foreign-ref foreign
address@hidden {C Function} scm_foreign_ref foreign
+Reference the foreign value pointed to by @var{foreign}.
+
+The value will be referenced according to its type.
+
address@hidden
+(foreign-ref numptob) @result{} 8 ; YMMV
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} foreign-set! foreign val
address@hidden {C Function} scm_foreign_set_x foreign val
+Set the foreign value pointed to by @var{foreign}.
+
+The value will be set according to its type.
+
address@hidden
+(foreign-set! numptob 120) ; Don't try this at home!
address@hidden example
address@hidden deffn
+
+If we wanted to corrupt Guile's internal state, we could set
address@hidden to another value; but we shouldn't, because that
+variable is not meant to be set. Indeed this point applies more widely:
+the C API is a dangerous place to be. Not only might setting a value
+crash your program, simply referencing a value with a wrong-sized type
+can prove equally disastrous.
+
+
address@hidden Void Pointers and Byte Access
address@hidden Void Pointers and Byte Access
+
+As a special case, a dynamic pointer may be declared to point to type
address@hidden, in which case it is treated as a void pointer. A void
+pointer prints its value as a pointer, without dereferencing the
+pointer.
+
+It's important at this point to conceptually separate foreign values
+from foreign pointers. @code{dynamic-pointer} gives you a foreign
+pointer. A foreign value is the semantic meaning of the bytes pointed to
+by a pointer. Only foreign pointers may be wrapped in Scheme. One may
+make a pointer to a foreign value, and wrap that as a Scheme object, but
+a bare foreign value may not be wrapped.
+
+When you call @code{dynamic-pointer}, the @var{type} argument indicates
+the type to which the given symbol points, but sometimes you don't know
+that type. Sometimes you have a pointer, and you don't know what kind of
+object it references. It's simply a pointer out into the ether, into the
address@hidden
+
+Guile can wrap such a pointer, by declaring that it points to
address@hidden
+
address@hidden {Scheme Variable} void
+A foreign type value representing nothing.
+
address@hidden has two uses: for a foreign pointer, declaring it to be of
+type @code{void} is like having a @code{void*} in C. For a function, a
+return type of @code{void} indicates that the function returns no
+values. A function argument type of @code{void} is invalid.
address@hidden defvr
+
+As an example, @code{(dynamic-pointer "foo" void bar-lib)} links in the
address@hidden symbol in the @var{bar-lib} library as a pointer to
address@hidden: a @code{void*}.
+
+Void pointers may be accessed as bytevectors.
+
address@hidden {Scheme Procedure} foreign->bytevector foreign [uvec_type
[offset [len]]]
address@hidden {C Function} scm_foreign_to_bytevector foreign uvec_type offset
len
+Return a bytevector aliasing the memory pointed to by
address@hidden
+
address@hidden must be a void pointer, a foreign whose type is
address@hidden By default, the resulting bytevector will alias
+all of the memory pointed to by @var{foreign}, from beginning
+to end, treated as a @code{vu8} array.
+
+The user may specify an alternate default interpretation for
+the memory by passing the @var{uvec_type} argument, to indicate
+that the memory is an array of elements of that type.
address@hidden should be something that
address@hidden would return, like @code{f32}
+or @code{s16}.
+
+Users may also specify that the bytevector should only alias a
+subset of the memory, by specifying @var{offset} and @var{len}
+arguments.
+
+Mutating the returned bytevector mutates the memory pointed to by
address@hidden, so buckle your seatbelts.
address@hidden deffn
+
address@hidden {Scheme Procedure} bytevector->foreign bv [offset [len]]
address@hidden {C Function} scm_bytevector_to_foreign bv offset len
+Return a foreign pointer aliasing the memory pointed to by
address@hidden
+
+The resulting foreign will be a void pointer, a foreign whose
+type is @code{void}. By default it will alias all of the
+memory pointed to by @var{bv}, from beginning to end.
+
+Users may explicily specify that the foreign should only alias a
+subset of the memory, by specifying @var{offset} and @var{len}
+arguments.
address@hidden deffn
+
+
address@hidden Foreign Structs
address@hidden Foreign Structs
+
+Finally, one last note on foreign values before moving on to actually
+calling foreign functions. Sometimes you need to deal with C structs,
+which requires interpreting each element of the struct according to the
+its type, offset, and alignment. Guile has some primitives to support
+this.
+
address@hidden {Scheme Procedure} sizeof type
address@hidden {C Function} scm_sizeof type
+Return the size of @var{type}, in bytes.
+
address@hidden should be a valid C type, like @code{int}.
+Alternately @var{type} may be the symbol @code{*}, in which
+case the size of a pointer is returned. @var{type} may
+also be a list of types, in which case the size of a
address@hidden with ABI-conventional packing is returned.
address@hidden deffn
+
address@hidden {Scheme Procedure} alignof type
address@hidden {C Function} scm_alignof type
+Return the alignment of @var{type}, in bytes.
+
address@hidden should be a valid C type, like @code{int}.
+Alternately @var{type} may be the symbol @code{*}, in which
+case the alignment of a pointer is returned. @var{type} may
+also be a list of types, in which case the alignment of a
address@hidden with ABI-conventional packing is returned.
address@hidden deffn
+
+Guile also provides some convenience methods to pack and unpack foreign
+pointers wrapping C structs.
+
address@hidden {Scheme Procedure} make-c-struct types vals
+Create a foreign pointer to a C struct containing @var{vals} with types
address@hidden
+
address@hidden and @code{types} should be lists of the same length.
address@hidden deffn
+
address@hidden {Scheme Procedure} parse-c-struct foreign types
+Parse a foreign pointer to a C struct, returning a list of values.
+
address@hidden should be a list of C types.
address@hidden deffn
+
+For example, to create and parse the equivalent of a @code{struct @{
+int64_t a; uint8_t b; @}}:
+
address@hidden
+(parse-c-struct (make-c-struct (list int64 uint8)
+ (list 300 43))
+ (list int64 uint8))
address@hidden (300 43)
address@hidden example
+
+As yet, Guile only has convenience routines to support
+conventionally-packed structs. But given the @code{bytevector->foreign}
+and @code{foreign->bytevector} routines, one can create and parse
+tightly packed structs and unions by hand. See the code for
address@hidden(system foreign)} for details.
+
+
address@hidden Dynamic FFI
address@hidden Dynamic FFI
+
+Of course, the land of C is not all nouns and no verbs: there are
+functions too, and Guile allows you to call them.
+
address@hidden {Scheme Procedure} make-foreign-function return_type func_ptr
arg_types
address@hidden {C Procedure} scm_make_foreign_function return_type func_ptr
arg_types
+Make a foreign function.
+
+Given the foreign void pointer @var{func_ptr}, its argument and
+return types @var{arg_types} and @var{return_type}, return a
+procedure that will pass arguments to the foreign function
+and return appropriate values.
+
address@hidden should be a list of foreign types.
address@hidden should be a foreign type. @xref{Foreign Types}, for
+more information on foreign types.
address@hidden deffn
+
+Here is a better definition of @code{(math bessel)}:
+
address@hidden
+(define-module (math bessel)
+ #:use-module (system foreign)
+ #:export (j0))
+
+(define libm (dynamic-link "libm"))
+
+(define j0
+ (make-foreign-function double
+ (dynamic-func "j0" libm)
+ (list double)))
address@hidden example
+
+That's it! No C at all.
+
+Numeric arguments and return values from foreign functions are
+represented as Scheme values. For example, @code{j0} in the above
+example takes a Scheme number as its argument, and returns a Scheme
+number.
+
+Pointers may be passed to and returned from foreign functions as well.
+In that case the type of the argument or return value should be the
+symbol @code{*}, indicating a pointer. For example, the following
+code makes @code{memcpy} available to Scheme:
+
address@hidden
+(define memcpy
+ (let ((this (dynamic-link)))
+ (make-foreign-function '*
+ (dynamic-func "memcpy" this)
+ (list '* '* size_t))))
address@hidden example
+
+To invoke @code{memcpy}, one must pass it foreign pointers:
+
address@hidden
+(use-modules (rnrs bytevector))
+
+(define src
+ (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7))))
+(define dest
+ (bytevector->foreign (make-bytevector 16 0)))
+
+(memcpy dest src (bytevector-length (foreign->bytevector src)))))
+
+(bytevector->u8-list (foreign->bytevector dest))
address@hidden (0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0)
address@hidden example
+
+One may also pass structs as values, passing structs as foreign
+pointers. @xref{Foreign Structs}, for more information on how to express
+struct types and struct values.
+
+``Out'' arguments are passed as foreign pointers. The memory pointed to
+by the foreign pointer is mutated in place.
+
address@hidden
+;; struct timeval @{
+;; time_t tv_sec; /* seconds */
+;; suseconds_t tv_usec; /* microseconds */
+;; @};
+;; assuming fields are of type "long"
+
+(define gettimeofday
+ (let ((f (make-foreign-function
+ int
+ (dynamic-func "gettimeofday" (dynamic-link))
+ (list '* '*)))
+ (tv-type (list long long)))
+ (lambda ()
+ (let* ((timeval (make-c-struct tv-type (list 0 0)))
+ (ret (f timeval %null-pointer)))
+ (if (zero? ret)
+ (apply values (parse-c-struct timeval tv-type))
+ (error "gettimeofday returned an error" ret))))))
+
+(gettimeofday)
address@hidden 1270587589
address@hidden 499553
address@hidden example
+
+This example also shows use of @code{%null-pointer}, which is a null
+foreign pointer, exported by @code{(system foreign)}.
+
address@hidden {Scheme Variable} %null-pointer
+A foreign pointer whose value is 0.
address@hidden defvr
+
+As you can see, this interface to foreign functions is at a very low,
+somewhat dangerous level. A contribution to Guile in the form of a
+high-level FFI would be most welcome.
+
address@hidden Local Variables:
address@hidden TeX-master: "guile.texi"
address@hidden End:
diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi
index fba8f32..e98db12 100644
--- a/doc/ref/api-i18n.texi
+++ b/doc/ref/api-i18n.texi
@@ -196,6 +196,12 @@ Return the uppercase character that corresponds to
@var{chr} according
to either @var{locale} or the current locale.
@end deffn
address@hidden {Scheme Procedure} char-locale-titlecase chr [locale]
address@hidden {C Function} scm_char_locale_titlecase (chr, locale)
+Return the titlecase character that corresponds to @var{chr} according
+to either @var{locale} or the current locale.
address@hidden deffn
+
@deffn {Scheme Procedure} string-locale-upcase str [locale]
@deffnx {C Function} scm_string_locale_upcase (str, locale)
Return a new string that is the uppercase version of @var{str}
@@ -208,6 +214,12 @@ Return a new string that is the down-case version of
@var{str}
according to either @var{locale} or the current locale.
@end deffn
address@hidden {Scheme Procedure} string-locale-titlecase str [locale]
address@hidden {C Function} scm_string_locale_titlecase (str, locale)
+Return a new string that is the titlecase version of @var{str}
+according to either @var{locale} or the current locale.
address@hidden deffn
+
Note that in the current implementation Guile has no notion of
multibyte characters and in a multibyte locale characters may not be
converted correctly.
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index a483f19..f09ecfb 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.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, 2007,
2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -75,6 +75,12 @@ how characters and strings written to the port are converted
to bytes.
When ports are created, they inherit their character encoding from the
current locale, but, that can be modified after the port is created.
+Currently, the ports only work with @emph{non-modal} encodings. Most
+encodings are non-modal, meaning that the conversion of bytes to a
+string doesn't depend on its context: the same byte sequence will always
+return the same string. A couple of modal encodings are in common use,
+like ISO-2022-JP and ISO-2022-KR, and they are not yet supported.
+
Each port also has an associated conversion strategy: what to do when
a Guile character can't be converted to the port's encoded character
representation for output. There are three possible strategies: to
@@ -971,6 +977,28 @@ away from its default.
Calls the one-argument procedure @var{proc} with a newly created output
port. When the function returns, the string composed of the characters
written into the port is returned. @var{proc} should not close the port.
+
+Note that which characters can be written to a string port depend on the port's
+encoding. The default encoding of string ports is specified by the
address@hidden fluid (@pxref{Ports,
address@hidden). For instance, it is an error to write Greek
+letter alpha to an ISO-8859-1-encoded string port since this character cannot
be
+represented with ISO-8859-1:
+
address@hidden
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+
+(with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (call-with-output-string
+ (lambda (p)
+ (display alpha p))))
+
address@hidden
+Throw to key `encoding-error'
address@hidden example
+
+Changing the string port's encoding to a Unicode-capable encoding such as UTF-8
+solves the problem.
@end deffn
@deffn {Scheme Procedure} call-with-input-string string proc
@@ -984,6 +1012,8 @@ read. The value yielded by the @var{proc} is returned.
Calls the zero-argument procedure @var{thunk} with the current output
port set temporarily to a new string port. It returns a string
composed of the characters written to the current output.
+
+See @code{call-with-output-string} above for character encoding considerations.
@end deffn
@deffn {Scheme Procedure} with-input-from-string string thunk
diff --git a/doc/ref/api-lalr.texi b/doc/ref/api-lalr.texi
new file mode 100644
index 0000000..e19614c
--- /dev/null
+++ b/doc/ref/api-lalr.texi
@@ -0,0 +1,36 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2009, 2010
address@hidden Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
+
address@hidden
address@hidden LALR(1) Parsing
address@hidden LALR(1) Parsing
+
+The @code{(system base lalr)} module provides the
address@hidden://code.google.com/p/lalr-scm/, @code{lalr-scm} LALR(1) parser
+generator by Dominique Boucher}. @code{lalr-scm} uses the same algorithm as
GNU
+Bison (@pxref{Introduction, Introduction to Bison,, bison, address@hidden The
+Yacc-compatible Parser Generator}). Parsers are defined using the
address@hidden macro.
+
address@hidden {Scheme Syntax} lalr-parser address@hidden @var{tokens}
@var{rules}...
+Generate an LALR(1) syntax analyzer. @var{tokens} is a list of symbols
+representing the terminal symbols of the grammar. @var{rules} are the grammar
+production rules.
+
+Each rule has the form @code{(@var{non-terminal} (@var{rhs} ...) : @var{action}
+...)}, where @var{non-terminal} is the name of the rule, @var{rhs} are the
+right-hand sides, i.e., the production rule, and @var{action} is a semantic
+action associated with the rule.
+
+The generated parser is a two-argument procedure that takes a @dfn{tokenizer}
+and a @dfn{syntax error procedure}. The tokenizer should be a unary procedure
+taking a port and returning a lexical token as produced by
address@hidden The syntax error procedure may be called with at
+least an error message (a string), and optionally the lexical token that caused
+the error.
address@hidden deffn
+
+Please refer to the @code{lalr-scm} documentation for details.
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
new file mode 100644
index 0000000..51f54ed
--- /dev/null
+++ b/doc/ref/api-macros.texi
@@ -0,0 +1,878 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010
address@hidden Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
+
address@hidden
address@hidden Macros
address@hidden Macros
+
+At its best, programming in Lisp is an iterative process of building up a
+language appropriate to the problem at hand, and then solving the problem in
+that language. Defining new procedures is part of that, but Lisp also allows
+the user to extend its syntax, with its famous @dfn{macros}.
+
address@hidden macros
address@hidden transformation
+Macros are syntactic extensions which cause the expression that they appear in
+to be transformed in some way @emph{before} being evaluated. In expressions
that
+are intended for macro transformation, the identifier that names the relevant
+macro must appear as the first element, like this:
+
address@hidden
+(@var{macro-name} @var{macro-args} @dots{})
address@hidden lisp
+
address@hidden macro expansion
+Macro expansion is a separate phase of evaluation, run before code is
+interpreted or compiled. A macro is a program that runs on programs,
translating
+an embedded language into core Scheme.
+
address@hidden
+* Defining Macros:: Binding macros, globally and locally.
+* Syntax Rules:: Pattern-driven macros.
+* Syntax Case:: Procedural, hygienic macros.
+* Defmacros:: Lisp-style macros.
+* Identifier Macros:: Identifier macros.
+* Eval When:: Affecting the expand-time environment.
+* Internal Macros:: Macros as first-class values.
address@hidden menu
+
address@hidden Defining Macros
address@hidden Defining Macros
+
+A macro is a binding between a keyword and a syntax transformer. Since it's
+difficult to discuss @code{define-syntax} without discussing the format of
+transformers, consider the following example macro definition:
+
address@hidden
+(define-syntax when
+ (syntax-rules ()
+ ((when condition exp ...)
+ (if condition
+ (begin exp ...)))))
+
+(when #t
+ (display "hey ho\n")
+ (display "let's go\n"))
address@hidden hey ho
address@hidden let's go
address@hidden example
+
+In this example, the @code{when} binding is bound with @code{define-syntax}.
+Syntax transformers are discussed in more depth in @ref{Syntax Rules} and
address@hidden Case}.
+
address@hidden {Syntax} define-syntax keyword transformer
+Bind @var{keyword} to the syntax transformer obtained by evaluating
address@hidden
+
+After a macro has been defined, further instances of @var{keyword} in Scheme
+source code will invoke the syntax transformer defined by @var{transformer}.
address@hidden deffn
+
+One can also establish local syntactic bindings with @code{let-syntax}.
+
address@hidden {Syntax} let-syntax ((keyword transformer) ...) exp...
+Bind @var{keyword...} to @var{transformer...} while expanding @var{exp...}.
+
+A @code{let-syntax} binding only exists at expansion-time.
+
address@hidden
+(let-syntax ((unless
+ (syntax-rules ()
+ ((unless condition exp ...)
+ (if (not condition)
+ (begin exp ...))))))
+ (unless #t
+ (primitive-exit 1))
+ "rock rock rock")
address@hidden "rock rock rock"
address@hidden example
address@hidden deffn
+
+A @code{define-syntax} form is valid anywhere a definition may appear: at the
+top-level, or locally. Just as a local @code{define} expands out to an instance
+of @code{letrec}, a local @code{define-syntax} expands out to
address@hidden
+
address@hidden {Syntax} letrec-syntax ((keyword transformer) ...) exp...
+Bind @var{keyword...} to @var{transformer...} while expanding @var{exp...}.
+
+In the spirit of @code{letrec} versus @code{let}, an expansion produced by
address@hidden may reference a @var{keyword} bound by the
+same @var{letrec-syntax}.
+
address@hidden
+(letrec-syntax ((my-or
+ (syntax-rules ()
+ ((my-or)
+ #t)
+ ((my-or exp)
+ exp)
+ ((my-or exp rest ...)
+ (let ((t exp))
+ (if exp
+ exp
+ (my-or rest ...)))))))
+ (my-or #f "rockaway beach"))
address@hidden "rockaway beach"
address@hidden example
address@hidden deffn
+
address@hidden Syntax Rules
address@hidden Syntax-rules Macros
+
address@hidden macros are simple, pattern-driven syntax transformers, with
+a beauty worthy of Scheme.
+
address@hidden {Syntax} syntax-rules literals (pattern template)...
+Create a syntax transformer that will rewrite an expression using the rules
+embodied in the @var{pattern} and @var{template} clauses.
address@hidden deffn
+
+A @code{syntax-rules} macro consists of three parts: the literals (if any), the
+patterns, and as many templates as there are patterns.
+
+When the syntax expander sees the invocation of a @code{syntax-rules} macro, it
+matches the expression against the patterns, in order, and rewrites the
+expression using the template from the first matching pattern. If no pattern
+matches, a syntax error is signalled.
+
address@hidden Patterns
+
+We have already seen some examples of patterns in the previous section:
address@hidden(unless condition exp ...)}, @code{(my-or exp)}, and so on. A
pattern is
+structured like the expression that it is to match. It can have nested
structure
+as well, like @code{(let ((var val) ...) exp exp* ...)}. Broadly speaking,
+patterns are made of lists, improper lists, vectors, identifiers, and datums.
+Users can match a sequence of patterns using the ellipsis (@code{...}).
+
+Identifiers in a pattern are called @dfn{literals} if they are present in the
address@hidden literals list, and @dfn{pattern variables} otherwise. When
+building up the macro output, the expander replaces instances of a pattern
+variable in the template with the matched subexpression.
+
address@hidden
+(define-syntax kwote
+ (syntax-rules ()
+ ((kwote exp)
+ (quote exp))))
+(kwote (foo . bar))
address@hidden (foo . bar)
address@hidden example
+
+An improper list of patterns matches as rest arguments do:
+
address@hidden
+(define-syntax let1
+ (syntax-rules ()
+ ((_ (var val) . exps)
+ (let ((var val)) . exps))))
address@hidden example
+
+However this definition of @code{let1} probably isn't what you want, as the
tail
+pattern @var{exps} will match non-lists, like @code{(let1 (foo 'bar) . baz)}.
So
+often instead of using improper lists as patterns, ellipsized patterns are
+better. Instances of a pattern variable in the template must be followed by an
+ellipsis.
+
address@hidden
+(define-syntax let1
+ (syntax-rules ()
+ ((_ (var val) exp ...)
+ (let ((var val)) exp ...))))
address@hidden example
+
+This @code{let1} probably still doesn't do what we want, because the body
+matches sequences of zero expressions, like @code{(let1 (foo 'bar))}. In this
+case we need to assert we have at least one body expression. A common idiom for
+this is to name the ellipsized pattern variable with an asterisk:
+
address@hidden
+(define-syntax let1
+ (syntax-rules ()
+ ((_ (var val) exp exp* ...)
+ (let ((var val)) exp exp* ...))))
address@hidden example
+
+A vector of patterns matches a vector whose contents match the patterns,
+including ellipsizing and tail patterns.
+
address@hidden
+(define-syntax letv
+ (syntax-rules ()
+ ((_ #((var val) ...) exp exp* ...)
+ (let ((var val) ...) exp exp* ...))))
+(letv #((foo 'bar)) foo)
address@hidden foo
address@hidden example
+
+Literals are used to match specific datums in an expression, like the use of
address@hidden>} and @code{else} in @code{cond} expressions.
+
address@hidden
+(define-syntax cond1
+ (syntax-rules (=> else)
+ ((cond1 test => fun)
+ (let ((exp test))
+ (if exp (fun exp) #f)))
+ ((cond1 test exp exp* ...)
+ (if test (begin exp exp* ...)))
+ ((cond1 else exp exp* ...)
+ (begin exp exp* ...))))
+
+(define (square x) (* x x))
+(cond1 10 => square)
address@hidden 100
+(let ((=> #t))
+ (cond1 10 => square))
address@hidden #<procedure square (x)>
address@hidden example
+
+A literal matches an input expression if the input expression is an identifier
+with the same name as the literal, and both are address@hidden
+lawyers probably see the need here for use of @code{literal-identifier=?}
rather
+than @code{free-identifier=?}, and would probably be correct. Patches
+accepted.}.
+
+If a pattern is not a list, vector, or an identifier, it matches as a literal,
+with @code{equal?}.
+
address@hidden
+(define-syntax define-matcher-macro
+ (syntax-rules ()
+ ((_ name lit)
+ (define-syntax name
+ (syntax-rules ()
+ ((_ lit) #t)
+ ((_ else) #f))))))
+
+(define-matcher-macro is-literal-foo? "foo")
+
+(is-literal-foo? "foo")
address@hidden #t
+(is-literal-foo? "bar")
address@hidden #f
+(let ((foo "foo"))
+ (is-literal-foo? foo))
address@hidden #f
address@hidden example
+
+The last example indicates that matching happens at expansion-time, not
+at run-time.
+
+Syntax-rules macros are always used as @code{(@var{macro} . @var{args})}, and
+the @var{macro} will always be a symbol. Correspondingly, a @code{syntax-rules}
+pattern must be a list (proper or improper), and the first pattern in that list
+must be an identifier. Incidentally it can be any identifier -- it doesn't have
+to actually be the name of the macro. Thus the following three are equivalent:
+
address@hidden
+(define-syntax when
+ (syntax-rules ()
+ ((when c e ...)
+ (if c (begin e ...)))))
+
+(define-syntax when
+ (syntax-rules ()
+ ((_ c e ...)
+ (if c (begin e ...)))))
+
+(define-syntax when
+ (syntax-rules ()
+ ((something-else-entirely c e ...)
+ (if c (begin e ...)))))
address@hidden example
+
+For clarity, use one of the first two variants. Also note that since the
pattern
+variable will always match the macro itself (e.g., @code{cond1}), it is
actually
+left unbound in the template.
+
address@hidden Hygiene
+
address@hidden macros have a magical property: they preserve referential
+transparency. When you read a macro definition, any free bindings in that macro
+are resolved relative to the macro definition; and when you read a macro
+instantiation, all free bindings in that expression are resolved relative to
the
+expression.
+
+This property is sometimes known as @dfn{hygiene}, and it does aid in code
+cleanliness. In your macro definitions, you can feel free to introduce
temporary
+variables, without worrying about inadvertantly introducing bindings into the
+macro expansion.
+
+Consider the definition of @code{my-or} from the previous section:
+
address@hidden
+(define-syntax my-or
+ (syntax-rules ()
+ ((my-or)
+ #t)
+ ((my-or exp)
+ exp)
+ ((my-or exp rest ...)
+ (let ((t exp))
+ (if exp
+ exp
+ (my-or rest ...))))))
address@hidden example
+
+A naive expansion of @code{(let ((t #t)) (my-or #f t))} would yield:
+
address@hidden
+(let ((t #t))
+ (let ((t #f))
+ (if t t t)))
address@hidden #f
address@hidden example
+
address@hidden
+Which clearly is not what we want. Somehow the @code{t} in the definition is
+distinct from the @code{t} at the site of use; and it is indeed this
distinction
+that is maintained by the syntax expander, when expanding hygienic macros.
+
+This discussion is mostly relevant in the context of traditional Lisp macros
+(@pxref{Defmacros}), which do not preserve referential transparency. Hygiene
+adds to the expressive power of Scheme.
+
address@hidden Further Information
+
+For a formal definition of @code{syntax-rules} and its pattern language, see
address@hidden, , Macros, r5rs, Revised(5) Report on the Algorithmic Language
+Scheme}.
+
address@hidden macros are simple and clean, but do they have limitations.
+They do not lend themselves to expressive error messages: patterns either match
+or they don't. Their ability to generate code is limited to template-driven
+expansion; often one needs to define a number of helper macros to get real work
+done. Sometimes one wants to introduce a binding into the lexical context of
the
+generated code; this is impossible with @code{syntax-rules}. Relatedly, they
+cannot programmatically generate identifiers.
+
+The solution to all of these problems is to use @code{syntax-case} if you need
+its features. But if for some reason you're stuck with @code{syntax-rules}, you
+might enjoy Joe Marshall's
address@hidden://sites.google.com/site/evalapply/eccentric.txt,@code{syntax-rules}
+Primer for the Merely Eccentric}.
+
address@hidden Syntax Case
address@hidden Support for the @code{syntax-case} System
+
address@hidden macros are procedural syntax transformers, with a power
+worthy of Scheme.
+
address@hidden {Syntax} syntax-case syntax literals (pattern [guard] exp)...
+Match the syntax object @var{syntax} against the given patterns, in order. If a
address@hidden matches, return the result of evaluating the associated
@var{exp}.
address@hidden deffn
+
+Compare the following definitions of @code{when}:
+
address@hidden
+(define-syntax when
+ (syntax-rules ()
+ ((_ test e e* ...)
+ (if test (begin e e* ...)))))
+
+(define-syntax when
+ (lambda (x)
+ (syntax-case x ()
+ ((_ test e e* ...)
+ #'(if test (begin e e* ...))))))
address@hidden example
+
+Clearly, the @code{syntax-case} definition is similar to its
@code{syntax-rules}
+counterpart, and equally clearly there are some differences. The
address@hidden definition is wrapped in a @code{lambda}, a function of one
+argument; that argument is passed to the @code{syntax-case} invocation; and the
+``return value'' of the macro has a @code{#'} prefix.
+
+All of these differences stem from the fact that @code{syntax-case} does not
+define a syntax transformer itself -- instead, @code{syntax-case} expressions
+provide a way to destructure a @dfn{syntax object}, and to rebuild syntax
+objects as output.
+
+So the @code{lambda} wrapper is simply a leaky implementation detail, that
+syntax transformers are just functions that transform syntax to syntax. This
+should not be surprising, given that we have already described macros as
+``programs that write programs''. @code{syntax-case} is simply a way to take
+apart and put together program text, and to be a valid syntax transformer it
+needs to be wrapped in a procedure.
+
+Unlike traditional Lisp macros (@pxref{Defmacros}), @code{syntax-case} macros
+transform syntax objects, not raw Scheme forms. Recall the naive expansion of
address@hidden given in the previous section:
+
address@hidden
+(let ((t #t))
+ (my-or #f t))
+;; naive expansion:
+(let ((t #t))
+ (let ((t #f))
+ (if t t t)))
address@hidden example
+
+Raw Scheme forms simply don't have enough information to distinguish the first
+two @code{t} instances in @code{(if t t t)} from the third @code{t}. So instead
+of representing identifiers as symbols, the syntax expander represents
+identifiers as annotated syntax objects, attaching such information to those
+syntax objects as is needed to maintain referential transparency.
+
address@hidden {Syntax} syntax form
+Create a syntax object wrapping @var{form} within the current lexical context.
address@hidden deffn
+
+Syntax objects are typically created internally to the process of expansion,
but
+it is possible to create them outside of syntax expansion:
+
address@hidden
+(syntax (foo bar baz))
address@hidden #<some representation of that syntax>
address@hidden example
+
address@hidden
+However it is more common, and useful, to create syntax objects when building
+output from a @code{syntax-case} expression.
+
address@hidden
+(define-syntax add1
+ (lambda (x)
+ (syntax-case x ()
+ ((_ exp)
+ (syntax (+ exp 1))))))
address@hidden example
+
+It is not strictly necessary for a @code{syntax-case} expression to return a
+syntax object, because @code{syntax-case} expressions can be used in helper
+functions, or otherwise used outside of syntax expansion itself. However a
+syntax transformer procedure must return a syntax object, so most uses of
address@hidden do end up returning syntax objects.
+
+Here in this case, the form that built the return value was @code{(syntax (+
exp
+1))}. The interesting thing about this is that within a @code{syntax}
+expression, any appearance of a pattern variable is substitued into the
+resulting syntax object, carrying with it all relevant metadata from the source
+expression, such as lexical identity and source location.
+
+Indeed, a pattern variable may only be referenced from inside a @code{syntax}
+form. The syntax expander would raise an error when defining @code{add1} if it
+found @var{exp} referenced outside a @code{syntax} form.
+
+Since @code{syntax} appears frequently in macro-heavy code, it has a special
+reader macro: @code{#'}. @code{#'foo} is transformed by the reader into
address@hidden(syntax foo)}, just as @code{'foo} is tranformed into
@code{(quote foo)}.
+
+The pattern language used by @code{syntax-case} is conveniently the same
+language used by @code{syntax-rules}. Given this, Guile actually defines
address@hidden in terms of @code{syntax-case}:
+
address@hidden
+(define-syntax syntax-rules
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k ...) ((keyword . pattern) template) ...)
+ #'(lambda (x)
+ (syntax-case x (k ...)
+ ((dummy . pattern) #'template)
+ ...))))))
address@hidden example
+
+And that's that.
+
address@hidden Why @code{syntax-case}?
+
+The examples we have shown thus far could just as well have been expressed with
address@hidden, and have just shown that @code{syntax-case} is more
+verbose, which is true. But there is a difference: @code{syntax-case} creates
address@hidden macros, giving the full power of Scheme to the macro expander.
+This has many practical applications.
+
+A common desire is to be able to match a form only if it is an identifier. This
+is impossible with @code{syntax-rules}, given the datum matching forms. But
with
address@hidden it is easy:
+
address@hidden {Scheme Procedure} identifier? syntax-object
+Returns @code{#t} iff @var{syntax-object} is an identifier.
address@hidden deffn
+
address@hidden
+(define-syntax add1!
+ (lambda (x)
+ (syntax-case x ()
+ ((_ var) (identifier? #'var)
+ #'(set! var (add1 var))))))
+
+(define foo 0)
+(add1! foo)
+foo @result{} 1
+(add1! "not-an-identifier") @result{} error
address@hidden example
+
+With @code{syntax-rules}, the error for @code{(add1! "not-an-identifier")}
would
+be something like ``invalid @code{set!}''. With @code{syntax-case}, it will say
+something like ``invalid @code{add1!}'', because we attach the @dfn{guard
+clause} to the pattern: @code{(identifier? #'var)}. This becomes more important
+with more complicated macros. It is necessary to use @code{identifier?},
because
+to the expander, an identifier is more than a bare symbol.
+
+Note that even in the guard clause, we reference the @var{var} pattern variable
+within a @code{syntax} form, via @code{#'var}.
+
+Another common desire is to introduce bindings into the lexical context of the
+output expression. One example would be in the so-called ``anaphoric macros'',
+like @code{aif}. Anaphoric macros bind some expression to a well-known
+identifier, often @code{it}, within their bodies. For example, in @code{(aif
+(foo) (bar it))}, @code{it} would be bound to the result of @code{(foo)}.
+
+To begin with, we should mention a solution that doesn't work:
+
address@hidden
+;; doesn't work
+(define-syntax aif
+ (lambda (x)
+ (syntax-case x ()
+ ((_ test then else)
+ #'(let ((it test))
+ (if it then else))))))
address@hidden example
+
+The reason that this doesn't work is that, by default, the expander will
+preserve referential transparency; the @var{then} and @var{else} expressions
+won't have access to the binding of @code{it}.
+
+But they can, if we explicitly introduce a binding via @code{datum->syntax}.
+
address@hidden {Scheme Procedure} datum->syntax for-syntax datum
+Create a syntax object that wraps @var{datum}, within the lexical context
+corresponding to the syntax object @var{for-syntax}.
address@hidden deffn
+
+For completeness, we should mention that it is possible to strip the metadata
+from a syntax object, returning a raw Scheme datum:
+
address@hidden {Scheme Procedure} syntax->datum syntax-object
+Strip the metadata from @var{syntax-object}, returning its contents as a raw
+Scheme datum.
address@hidden deffn
+
+In this case we want to introduce @code{it} in the context of the whole
+expression, so we can create a syntax object as @code{(datum->syntax x 'it)},
+where @code{x} is the whole expression, as passed to the transformer procedure.
+
+Here's another solution that doesn't work:
+
address@hidden
+;; doesn't work either
+(define-syntax aif
+ (lambda (x)
+ (syntax-case x ()
+ ((_ test then else)
+ (let ((it (datum->syntax x 'it)))
+ #'(let ((it test))
+ (if it then else)))))))
address@hidden example
+
+The reason that this one doesn't work is that there are really two environments
+at work here -- the environment of pattern variables, as bound by
address@hidden, and the environment of lexical variables, as bound by normal
+Scheme. Here we need to introduce a piece of Scheme's environment into that of
+the syntax expander, and we can do so using @code{syntax-case} itself:
+
address@hidden
+;; works, but is obtuse
+(define-syntax aif
+ (lambda (x)
+ (syntax-case x ()
+ ((_ test then else)
+ ;; invoking syntax-case on the generated
+ ;; syntax object to expose it to `syntax'
+ (syntax-case (datum->syntax x 'it) ()
+ (it
+ #'(let ((it test))
+ (if it then else))))))))
+
+(aif (getuid) (display it) (display "none")) (newline)
address@hidden 500
address@hidden example
+
+However there are easier ways to write this. @code{with-syntax} is often
+convenient:
+
address@hidden {Syntax} with-syntax ((pat val)...) exp...
+Bind patterns @var{pat} from their corresponding values @var{val}, within the
+lexical context of @var{exp...}.
+
address@hidden
+;; better
+(define-syntax aif
+ (lambda (x)
+ (syntax-case x ()
+ ((_ test then else)
+ (with-syntax ((it (datum->syntax x 'it)))
+ #'(let ((it test))
+ (if it then else)))))))
address@hidden example
address@hidden deffn
+
+As you might imagine, @code{with-syntax} is defined in terms of
address@hidden But even that might be off-putting to you if you are an old
+Lisp macro hacker, used to building macro output with @code{quasiquote}. The
+issue is that @code{with-syntax} creates a separation between the point of
+definition of a value and its point of substitution.
+
address@hidden quasisyntax
address@hidden unsyntax
address@hidden unsyntax-splicing
+So for cases in which a @code{quasiquote} style makes more sense,
address@hidden also defines @code{quasisyntax}, and the related
address@hidden and @code{unsyntax-splicing}, abbreviated by the reader as
address@hidden, @code{#,}, and @code{#,@@}, respectively.
+
+For example, to define a macro that inserts a compile-time timestamp into a
+source file, one may write:
+
address@hidden
+(define-syntax display-compile-timestamp
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ #`(begin
+ (display "The compile timestamp was: ")
+ (display #,(current-time))
+ (newline))))))
address@hidden example
+
+Finally, we should mention the following helper procedures defined by the core
+of @code{syntax-case}:
+
address@hidden {Scheme Procedure} bound-identifier=? a b
+Returns @code{#t} iff the syntax objects @var{a} and @var{b} refer to the same
+lexically-bound identifier.
address@hidden deffn
+
address@hidden {Scheme Procedure} free-identifier=? a b
+Returns @code{#t} iff the syntax objects @var{a} and @var{b} refer to the same
+free identifier.
address@hidden deffn
+
address@hidden {Scheme Procedure} generate-temporaries ls
+Return a list of temporary identifiers as long as @var{ls} is long.
address@hidden deffn
+
+Readers interested in further information on @code{syntax-case} macros should
+see R. Kent Dybvig's excellent @cite{The Scheme Programming Language}, either
+edition 3 or 4, in the chapter on syntax. Dybvig was the primary author of the
address@hidden system. The book itself is available online at
address@hidden://scheme.com/tspl4/}.
+
address@hidden Defmacros
address@hidden Lisp-style Macro Definitions
+
+The traditional way to define macros in Lisp is very similar to procedure
+definitions. The key differences are that the macro definition body should
+return a list that describes the transformed expression, and that the
definition
+is marked as a macro definition (rather than a procedure definition) by the use
+of a different definition keyword: in Lisp, @code{defmacro} rather than
address@hidden, and in Scheme, @code{define-macro} rather than @code{define}.
+
address@hidden defmacro
address@hidden define-macro
+Guile supports this style of macro definition using both @code{defmacro}
+and @code{define-macro}. The only difference between them is how the
+macro name and arguments are grouped together in the definition:
+
address@hidden
+(defmacro @var{name} (@var{args} @dots{}) @var{body} @dots{})
address@hidden lisp
+
address@hidden
+is the same as
+
address@hidden
+(define-macro (@var{name} @var{args} @dots{}) @var{body} @dots{})
address@hidden lisp
+
address@hidden
+The difference is analogous to the corresponding difference between
+Lisp's @code{defun} and Scheme's @code{define}.
+
+Having read the previous section on @code{syntax-case}, it's probably clear
that
+Guile actually implements defmacros in terms of @code{syntax-case}, applying
the
+transformer on the expression between invocations of @code{syntax->datum} and
address@hidden>syntax}. This realization leads us to the problem with defmacros,
+that they do not preserve referential transparency. One can be careful to not
+introduce bindings into expanded code, via liberal use of @code{gensym}, but
+there is no getting around the lack of referential transparency for free
+bindings in the macro itself.
+
+Even a macro as simple as our @code{when} from before is difficult to get
right:
+
address@hidden
+(define-macro (when cond exp . rest)
+ `(if ,cond
+ (begin ,exp . ,rest)))
+
+(when #f (display "Launching missiles!\n"))
address@hidden #f
+
+(let ((if list))
+ (when #f (display "Launching missiles!\n")))
address@hidden Launching missiles!
address@hidden (#f #<unspecified>)
address@hidden example
+
+Guile's perspective is that defmacros have had a good run, but that modern
+macros should be written with @code{syntax-rules} or @code{syntax-case}. There
+are still many uses of defmacros within Guile itself, but we will be phasing
+them out over time. Of course we won't take away @code{defmacro} or
address@hidden themselves, as there is lots of code out there that uses
+them.
+
+
address@hidden Identifier Macros
address@hidden Identifier Macros
+
+When the syntax expander sees a form in which the first element is a macro, the
+whole form gets passed to the macro's syntax transformer. One may visualize
this
+as:
+
address@hidden
+(define-syntax foo foo-transformer)
+(foo @var{arg}...)
+;; expands via
+(foo-transformer #'(foo @var{arg}...))
address@hidden example
+
+If, on the other hand, a macro is referenced in some other part of a form, the
+syntax transformer is invoked with only the macro reference, not the whole
form.
+
address@hidden
+(define-syntax foo foo-transformer)
+foo
+;; expands via
+(foo-transformer #'foo)
address@hidden example
+
+This allows bare identifier references to be replaced programmatically via a
+macro. @code{syntax-rules} provides some syntax to effect this transformation
+more easily.
+
address@hidden {Syntax} identifier-syntax exp
+Returns a macro transformer that will replace occurences of the macro with
address@hidden
address@hidden deffn
+
+For example, if you are importing external code written in terms of @code{fx+},
+the fixnum addition operator, but Guile doesn't have @code{fx+}, you may use
the
+following to replace @code{fx+} with @code{+}:
+
address@hidden
+(define-syntax fx+ (identifier-syntax +))
address@hidden example
+
+Later versions of the @code{psyntax} @code{syntax-case} expander, on which
+Guile's syntax expander is based, include @code{identifier-syntax} support for
+recognizing identifiers on the left-hand side of a @code{set!} expression as
+well. Guile should port that code to its expander.
+
address@hidden Eval When
address@hidden Eval-when
+
+As @code{syntax-case} macros have the whole power of Scheme available to them,
+they present a problem regarding time: when a macro runs, what parts of the
+program are available for the macro to use?
+
+The default answer to this question is that when you import a module (via
address@hidden or @code{use-modules}), that module will be loaded up at
+expansion-time, as well as at run-time. Additionally, top-level syntactic
+definitions within one compilation unit made by @code{define-syntax} are also
+evaluated at expansion time, in the order that they appear in the compilation
+unit (file).
+
+But if a syntactic definition needs to call out to a normal procedure at
+expansion-time, it might well need need special declarations to indicate that
+the procedure should be made available at expansion-time.
+
+For example, the following code will work at a REPL, but not in a file:
+
address@hidden
+;; incorrect
+(use-modules (srfi srfi-19))
+(define (date) (date->string (current-date)))
+(define-syntax %date (identifier-syntax (date)))
+(define *compilation-date* %date)
address@hidden example
+
+It works at a REPL because the expressions are evaluated one-by-one, in order,
+but if placed in a file, the expressions are expanded one-by-one, but not
+evaluated until the compiled file is loaded.
+
+The fix is to use @code{eval-when}.
+
address@hidden
+;; correct: using eval-when
+(use-modules (srfi srfi-19))
+(eval-when (compile load eval)
+ (define (date) (date->string (current-date))))
+(define-syntax %date (identifier-syntax (date)))
+(define *compilation-date* %date)
address@hidden example
+
address@hidden {Syntax} eval-when conditions exp...
+Evaluate @var{exp...} under the given @var{conditions}. Valid conditions
include
address@hidden, @code{load}, and @code{compile}. If you need to use
address@hidden, use it with all three conditions, as in the above example.
+Other uses of @code{eval-when} may void your warranty or poison your cat.
address@hidden deffn
+
address@hidden Internal Macros
address@hidden Internal Macros
+
address@hidden {Scheme Procedure} make-syntax-transformer name type binding
+Construct a syntax transformer object. This is part of Guile's low-level
support
+for syntax-case.
address@hidden deffn
+
address@hidden {Scheme Procedure} macro? obj
address@hidden {C Function} scm_macro_p (obj)
+Return @code{#t} iff @var{obj} is a syntax transformer.
+
+Note that it's a bit difficult to actually get a macro as a first-class object;
+simply naming it (like @code{case}) will produce a syntax error. But it is
+possible to get these objects using @code{module-ref}:
+
address@hidden
+(macro? (module-ref (current-module) 'case))
address@hidden #t
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} macro-type m
address@hidden {C Function} scm_macro_type (m)
+Return the @var{type} that was given when @var{m} was constructed, via
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} macro-name m
address@hidden {C Function} scm_macro_name (m)
+Return the name of the macro @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} macro-binding m
address@hidden {C Function} scm_macro_binding (m)
+Return the binding of the macro @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} macro-transformer m
address@hidden {C Function} scm_macro_transformer (m)
+Return the transformer of the macro @var{m}. This will return a procedure, for
+which one may ask the docstring. That's the whole reason this section is
+documented. Actually a part of the result of @code{macro-binding}.
address@hidden deffn
+
+
address@hidden Local Variables:
address@hidden TeX-master: "guile.texi"
address@hidden End:
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index 054f87f..618f5fa 100644
--- a/doc/ref/api-modules.texi
+++ b/doc/ref/api-modules.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, 2007,
2008
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -41,121 +41,20 @@ In addition, Guile offers variables as first-class
objects. They can
be used for interacting with the module system.
@menu
-* provide and require:: The SLIB feature mechanism.
-* Environments:: R5RS top-level environments.
-* The Guile module system:: How Guile does it.
-* Dynamic Libraries:: Loading libraries of compiled code at run time.
-* Variables:: First-class variables.
address@hidden menu
-
address@hidden provide and require
address@hidden provide and require
-
-Aubrey Jaffer, mostly to support his portable Scheme library SLIB,
-implemented a provide/require mechanism for many Scheme implementations.
-Library files in SLIB @emph{provide} a feature, and when user programs
address@hidden that feature, the library file is loaded in.
-
-For example, the file @file{random.scm} in the SLIB package contains the
-line
-
address@hidden
-(provide 'random)
address@hidden lisp
-
-so to use its procedures, a user would type
-
address@hidden
-(require 'random)
address@hidden lisp
-
-and they would magically become available, @emph{but still have the same
-names!} So this method is nice, but not as good as a full-featured
-module system.
-
-When SLIB is used with Guile, provide and require can be used to access
-its facilities.
-
address@hidden Environments
address@hidden Environments
address@hidden environment
-
-Scheme, as defined in R5RS, does @emph{not} have a full module system.
-However it does define the concept of a top-level @dfn{environment}.
-Such an environment maps identifiers (symbols) to Scheme objects such
-as procedures and lists: @ref{About Closure}. In other words, it
-implements a set of @dfn{bindings}.
-
-Environments in R5RS can be passed as the second argument to
address@hidden (@pxref{Fly Evaluation}). Three procedures are defined to
-return environments: @code{scheme-report-environment},
address@hidden and @code{interaction-environment} (@pxref{Fly
-Evaluation}).
-
-In addition, in Guile any module can be used as an R5RS environment,
-i.e., passed as the second argument to @code{eval}.
-
-Note: the following two procedures are available only when the
address@hidden(ice-9 r5rs)} module is loaded:
-
address@hidden
-(use-modules (ice-9 r5rs))
address@hidden lisp
-
address@hidden {Scheme Procedure} scheme-report-environment version
address@hidden {Scheme Procedure} null-environment version
address@hidden must be the exact integer `5', corresponding to revision
-5 of the Scheme report (the Revised^5 Report on Scheme).
address@hidden returns a specifier for an
-environment that is empty except for all bindings defined in the
-report that are either required or both optional and supported by the
-implementation. @code{null-environment} returns a specifier for an
-environment that is empty except for the (syntactic) bindings for all
-syntactic keywords defined in the report that are either required or
-both optional and supported by the implementation.
-
-Currently Guile does not support values of @var{version} for other
-revisions of the report.
-
-The effect of assigning (through the use of @code{eval}) a variable
-bound in a @code{scheme-report-environment} (for example @code{car})
-is unspecified. Currently the environments specified by
address@hidden are not immutable in Guile.
address@hidden deffn
-
address@hidden The Guile module system
address@hidden The Guile module system
-
-The Guile module system extends the concept of environments, discussed
-in the previous section, with mechanisms to define, use and customise
-sets of bindings.
-
-In 1996 Tom Lord implemented a full-featured module system for Guile which
-allows loading Scheme source files into a private name space. This system has
-been available since at least Guile version 1.1.
-
-For Guile version 1.5.0 and later, the system has been improved to have better
-integration from C code, more fine-grained user control over interfaces, and
-documentation.
-
-Although it is anticipated that the module system implementation will
-change in the future, the Scheme programming interface described in this
-manual should be considered stable. The C programming interface is
-considered relatively stable, although at the time of this writing,
-there is still some flux.
-
address@hidden
* General Information about Modules:: Guile module basics.
* Using Guile Modules:: How to use existing modules.
* Creating Guile Modules:: How to package your code into modules.
* Module System Reflection:: Accessing module objects at run-time.
-* Module System Quirks:: Strange things to be aware of.
* Included Guile Modules:: Which modules come with Guile?
+* R6RS Version References:: Using version numbers with modules.
* Accessing Modules from C:: How to work with modules with C code.
+* Variables:: First-class variables.
+* provide and require:: The SLIB feature mechanism.
+* Environments:: R5RS top-level environments.
@end menu
@node General Information about Modules
address@hidden General Information about Modules
address@hidden General Information about Modules
A Guile module can be thought of as a collection of named procedures,
variables and macros. More precisely, it is a set of @dfn{bindings}
@@ -194,6 +93,21 @@ would result in the filename @code{ice-9/popen.scm} and
searched in the
installation directories of Guile and in all other directories in the
load path.
+A slightly different search mechanism is used when a client module
+specifies a version reference as part of a request to load a module
+(@pxref{R6RS Version References}). Instead of searching the directories
+in the load path for a single filename, Guile uses the elements of the
+version reference to locate matching, numbered subdirectories of a
+constructed base path. For example, a request for the
address@hidden(rnrs base)} module with version reference @code{(6)} would cause
+Guile to discover the @code{rnrs/6} subdirectory (if it exists in any of
+the directories in the load path) and search its contents for the
+filename @code{base.scm}.
+
+When multiple modules are found that match a version reference, Guile
+sorts these modules by version number, followed by the length of their
+version specifications, in order to choose a ``best'' match.
+
@c FIXME::martin: Not sure about this, maybe someone knows better?
Every module has a so-called syntax transformer associated with it.
This is a procedure which performs all syntax transformation for the
@@ -202,13 +116,9 @@ you can manipulate the current syntax transformer using the
@code{use-syntax} syntactic form or the @code{#:use-syntax} module
definition option (@pxref{Creating Guile Modules}).
-Please note that there are some problems with the current module system
-you should keep in mind (@pxref{Module System Quirks}). We hope to
-address these eventually.
-
@node Using Guile Modules
address@hidden Using Guile Modules
address@hidden Using Guile Modules
To use a Guile module is to access either its public interface or a
custom interface (@pxref{General Information about Modules}). Both
@@ -323,6 +233,21 @@ omitted, the returned interface has no bindings. If the
@code{:select}
clause is omitted, @var{renamer} operates on the used module's public
interface.
+In addition to the above, @var{spec} can also include a @code{:version}
+clause, of the form:
+
address@hidden
+ :version VERSION-SPEC
address@hidden lisp
+
+where @var{version-spec} is an R6RS-compatible version reference. The
+presence of this clause changes Guile's search behavior as described in
+the section on module name resolution
+(@pxref{General Information about Modules}). An error will be signaled
+in the case in which a module with the same name has already been
+loaded, if that module specifies a version and that version is not
+compatible with @var{version-spec}.
+
Signal error if module name is not resolvable.
@end deffn
@@ -349,7 +274,7 @@ last resort.
@end deffn
@node Creating Guile Modules
address@hidden Creating Guile Modules
address@hidden Creating Guile Modules
When you want to create your own modules, you have to take the following
steps:
@@ -420,40 +345,42 @@ the module is used.
@item #:export @var{list}
@cindex export
-Export all identifiers in @var{list} which must be a list of symbols.
-This is equivalent to @code{(export @var{list})} in the module body.
+Export all identifiers in @var{list} which must be a list of symbols
+or pairs of symbols. This is equivalent to @code{(export @var{list})}
+in the module body.
@item #:re-export @var{list}
@cindex re-export
Re-export all identifiers in @var{list} which must be a list of
-symbols. The symbols in @var{list} must be imported by the current
-module from other modules. This is equivalent to @code{re-export}
-below.
+symbols or pairs of symbols. The symbols in @var{list} must be
+imported by the current module from other modules. This is equivalent
+to @code{re-export} below.
@item #:export-syntax @var{list}
@cindex export-syntax
-Export all identifiers in @var{list} which must be a list of symbols.
-The identifiers in @var{list} must refer to macros (@pxref{Macros})
-defined in the current module. This is equivalent to
address@hidden(export-syntax @var{list})} in the module body.
+Export all identifiers in @var{list} which must be a list of symbols
+or pairs of symbols. The identifiers in @var{list} must refer to
+macros (@pxref{Macros}) defined in the current module. This is
+equivalent to @code{(export-syntax @var{list})} in the module body.
@item #:re-export-syntax @var{list}
@cindex re-export-syntax
Re-export all identifiers in @var{list} which must be a list of
-symbols. The symbols in @var{list} must refer to macros imported by
-the current module from other modules. This is equivalent to
address@hidden(re-export-syntax @var{list})} in the module body.
+symbols or pairs of symbols. The symbols in @var{list} must refer to
+macros imported by the current module from other modules. This is
+equivalent to @code{(re-export-syntax @var{list})} in the module body.
@item #:replace @var{list}
@cindex replace
@cindex replacing binding
@cindex overriding binding
@cindex duplicate binding
-Export all identifiers in @var{list} (a list of symbols) and mark them
-as @dfn{replacing bindings}. In the module user's name space, this
-will have the effect of replacing any binding with the same name that
-is not also ``replacing''. Normally a replacement results in an
-``override'' warning message, @code{#:replace} avoids that.
+Export all identifiers in @var{list} (a list of symbols or pairs of
+symbols) and mark them as @dfn{replacing bindings}. In the module
+user's name space, this will have the effect of replacing any binding
+with the same name that is not also ``replacing''. Normally a
+replacement results in an ``override'' warning message,
address@hidden:replace} avoids that.
This is useful for modules that export bindings that have the same
name as core bindings. @code{#:replace}, in a sense, lets Guile know
@@ -482,6 +409,13 @@ instead of a comparison.
The @code{#:duplicates} (see below) provides fine-grain control about
duplicate binding handling on the module-user side.
address@hidden #:version @var{list}
address@hidden module version
+Specify a version for the module in the form of @var{list}, a list of
+zero or more exact, nonnegative integers. The corresponding
address@hidden:version} option in the @code{use-modules} form allows callers
+to restrict the value of this option in various ways.
+
@item #:duplicates @var{list}
@cindex duplicate binding handlers
@cindex duplicate binding
@@ -561,8 +495,11 @@ do not know anything about dangerous procedures.
@c end
@deffn syntax export variable @dots{}
-Add all @var{variable}s (which must be symbols) to the list of exported
-bindings of the current module.
+Add all @var{variable}s (which must be symbols or pairs of symbols) to
+the list of exported bindings of the current module. If @var{variable}
+is a pair, its @code{car} gives the name of the variable as seen by the
+current module and its @code{cdr} specifies a name for the binding in
+the current module's public interface.
@end deffn
@c begin (scm-doc-string "boot-9.scm" "define-public")
@@ -572,13 +509,14 @@ Equivalent to @code{(begin (define foo ...) (export
foo))}.
@c end
@deffn syntax re-export variable @dots{}
-Add all @var{variable}s (which must be symbols) to the list of
-re-exported bindings of the current module. Re-exported bindings must
-be imported by the current module from some other module.
+Add all @var{variable}s (which must be symbols or pairs of symbols) to
+the list of re-exported bindings of the current module. Pairs of
+symbols are handled as in @code{export}. Re-exported bindings must be
+imported by the current module from some other module.
@end deffn
@node Module System Reflection
address@hidden Module System Reflection
address@hidden Module System Reflection
The previous sections have described a declarative view of the module
system. You can also work with it programmatically by accessing and
@@ -631,40 +569,9 @@ arguments should be module objects, and @var{interface}
should very
likely be a module returned by @code{resolve-interface}.
@end deffn
address@hidden Module System Quirks
address@hidden Module System Quirks
-
-Although the programming interfaces are relatively stable, the Guile
-module system itself is still evolving. Here are some situations where
-usage surpasses design.
-
address@hidden @bullet
-
address@hidden
-When using a module which exports a macro definition, the other module
-must export all bindings the macro expansion uses, too, because the
-expanded code would otherwise not be able to see these definitions and
-issue a ``variable unbound'' error, or worse, would use another binding
-which might be present in the scope of the expansion.
-
address@hidden
-When two or more used modules export bindings with the same names, the
-last accessed module wins, and the exported binding of that last module
-will silently be used. This might lead to hard-to-find errors because
-wrong procedures or variables are used. To avoid this kind of
address@hidden situation, use a custom interface specification
-(@pxref{Using Guile Modules}). (We include this entry for the possible
-benefit of users of Guile versions previous to 1.5.0, when custom
-interfaces were added to the module system.)
-
address@hidden
-[Add other quirks here.]
-
address@hidden itemize
-
@node Included Guile Modules
address@hidden Included Guile Modules
address@hidden Included Guile Modules
@c FIXME::martin: Review me!
@@ -787,8 +694,92 @@ library SLIB from Guile (@pxref{SLIB}).
@end table
address@hidden R6RS Version References
address@hidden R6RS Version References
+
+Guile's module system includes support for locating modules based on
+a declared version specifier of the same form as the one described in
+R6RS (@pxref{Library form, R6RS Library Form,, r6rs, The Revised^6
+Report on the Algorithmic Language Scheme}). By using the
address@hidden:version} keyword in a @code{define-module} form, a module may
+specify a version as a list of zero or more exact, nonnegative integers.
+
+This version can then be used to locate the module during the module
+search process. Client modules and callers of the @code{use-modules}
+function may specify constraints on the versions of target modules by
+providing a @dfn{version reference}, which has one of the following
+forms:
+
address@hidden
+ (@var{sub-version-reference} ...)
+ (and @var{version-reference} ...)
+ (or @var{version-reference} ...)
+ (not @var{version-reference})
address@hidden lisp
+
+in which @var{sub-version-reference} is in turn one of:
+
address@hidden
+ (@var{sub-version})
+ (>= @var{sub-version})
+ (<= @var{sub-version})
+ (and @var{sub-version-reference} ...)
+ (or @var{sub-version-reference} ...)
+ (not @var{sub-version-reference})
address@hidden lisp
+
+in which @var{sub-version} is an exact, nonnegative integer as above. A
+version reference matches a declared module version if each element of
+the version reference matches a corresponding element of the module
+version, according to the following rules:
+
address@hidden @bullet
address@hidden
+The @code{and} sub-form matches a version or version element if every
+element in the tail of the sub-form matches the specified version or
+version element.
+
address@hidden
+The @code{or} sub-form matches a version or version element if any
+element in the tail of the sub-form matches the specified version or
+version element.
+
address@hidden
+The @code{not} sub-form matches a version or version element if the tail
+of the sub-form does not match the version or version element.
+
address@hidden
+The @code{>=} sub-form matches a version element if the element is
+greater than or equal to the @var{sub-version} in the tail of the
+sub-form.
+
address@hidden
+The @code{<=} sub-form matches a version element if the version is less
+than or equal to the @var{sub-version} in the tail of the sub-form.
+
address@hidden
+A @var{sub-version} matches a version element if one is @var{eqv?} to
+the other.
address@hidden itemize
+
+For example, a module declared as:
+
address@hidden
+ (define-module (mylib mymodule) #:version (1 2 0))
address@hidden lisp
+
+would be successfully loaded by any of the following @code{use-modules}
+expressions:
+
address@hidden
+ (use-modules ((mylib mymodule) #:version (1 2 (>= 0))))
+ (use-modules ((mylib mymodule) #:version (or (1 2 0) (1 2 1))))
+ (use-modules ((mylib mymodule) #:version ((and (>= 1) (not 2)) 2 0)))
address@hidden lisp
+
+
@node Accessing Modules from C
address@hidden Accessing Modules from C
address@hidden Accessing Modules from C
The last sections have described how modules are used in Scheme code,
which is the recommended way of creating and accessing modules. You
@@ -884,454 +875,6 @@ of the current module. The list of names is terminated by
@code{NULL}.
@end deftypefn
address@hidden Dynamic Libraries
address@hidden Dynamic Libraries
-
-Most modern Unices have something called @dfn{shared libraries}. This
-ordinarily means that they have the capability to share the executable
-image of a library between several running programs to save memory and
-disk space. But generally, shared libraries give a lot of additional
-flexibility compared to the traditional static libraries. In fact,
-calling them `dynamic' libraries is as correct as calling them `shared'.
-
-Shared libraries really give you a lot of flexibility in addition to the
-memory and disk space savings. When you link a program against a shared
-library, that library is not closely incorporated into the final
-executable. Instead, the executable of your program only contains
-enough information to find the needed shared libraries when the program
-is actually run. Only then, when the program is starting, is the final
-step of the linking process performed. This means that you need not
-recompile all programs when you install a new, only slightly modified
-version of a shared library. The programs will pick up the changes
-automatically the next time they are run.
-
-Now, when all the necessary machinery is there to perform part of the
-linking at run-time, why not take the next step and allow the programmer
-to explicitly take advantage of it from within his program? Of course,
-many operating systems that support shared libraries do just that, and
-chances are that Guile will allow you to access this feature from within
-your Scheme programs. As you might have guessed already, this feature
-is called @dfn{dynamic address@hidden people also refer to the
-final linking stage at program startup as `dynamic linking', so if you
-want to make yourself perfectly clear, it is probably best to use the
-more technical term @dfn{dlopening}, as suggested by Gordon Matzigkeit
-in his libtool documentation.}
-
-As with many aspects of Guile, there is a low-level way to access the
-dynamic linking apparatus, and a more high-level interface that
-integrates dynamically linked libraries into the module system.
-
address@hidden
-* Low level dynamic linking::
-* Compiled Code Modules::
-* Dynamic Linking and Compiled Code Modules::
-* Compiled Code Installation::
address@hidden menu
-
address@hidden Low level dynamic linking
address@hidden Low level dynamic linking
-
-When using the low level procedures to do your dynamic linking, you have
-complete control over which library is loaded when and what gets done
-with it.
-
address@hidden {Scheme Procedure} dynamic-link library
address@hidden {C Function} scm_dynamic_link (library)
-Find the shared library denoted by @var{library} (a string) and link it
-into the running Guile application. When everything works out, return a
-Scheme object suitable for representing the linked object file.
-Otherwise an error is thrown. How object files are searched is system
-dependent.
-
-Normally, @var{library} is just the name of some shared library file
-that will be searched for in the places where shared libraries usually
-reside, such as in @file{/usr/lib} and @file{/usr/local/lib}.
address@hidden deffn
-
address@hidden {Scheme Procedure} dynamic-object? obj
address@hidden {C Function} scm_dynamic_object_p (obj)
-Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f}
-otherwise.
address@hidden deffn
-
address@hidden {Scheme Procedure} dynamic-unlink dobj
address@hidden {C Function} scm_dynamic_unlink (dobj)
-Unlink the indicated object file from the application. The
-argument @var{dobj} must have been obtained by a call to
address@hidden After @code{dynamic-unlink} has been
-called on @var{dobj}, its content is no longer accessible.
address@hidden deffn
-
address@hidden {Scheme Procedure} dynamic-func name dobj
address@hidden {C Function} scm_dynamic_func (name, dobj)
-Search the dynamic object @var{dobj} for the C function
-indicated by the string @var{name} and return some Scheme
-handle that can later be used with @code{dynamic-call} to
-actually call the function.
-
-Regardless whether your C compiler prepends an underscore @samp{_} to
-the global names in a program, you should @strong{not} include this
-underscore in @var{function}. Guile knows whether the underscore is
-needed or not and will add it when necessary.
address@hidden deffn
-
address@hidden {Scheme Procedure} dynamic-call func dobj
address@hidden {C Function} scm_dynamic_call (func, dobj)
-Call the C function indicated by @var{func} and @var{dobj}.
-The function is passed no arguments and its return value is
-ignored. When @var{function} is something returned by
address@hidden, call that function and ignore @var{dobj}.
-When @var{func} is a string , look it up in @var{dynobj}; this
-is equivalent to
address@hidden
-(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)
address@hidden smallexample
-
-Interrupts are deferred while the C function is executing (with
address@hidden/@code{SCM_ALLOW_INTS}).
address@hidden deffn
-
address@hidden {Scheme Procedure} dynamic-args-call func dobj args
address@hidden {C Function} scm_dynamic_args_call (func, dobj, args)
-Call the C function indicated by @var{func} and @var{dobj},
-just like @code{dynamic-call}, but pass it some arguments and
-return its return value. The C function is expected to take
-two arguments and return an @code{int}, just like @code{main}:
address@hidden
-int c_func (int argc, char **argv);
address@hidden smallexample
-
-The parameter @var{args} must be a list of strings and is
-converted into an array of @code{char *}. The array is passed
-in @var{argv} and its size in @var{argc}. The return value is
-converted to a Scheme number and returned from the call to
address@hidden
address@hidden deffn
-
-When dynamic linking is disabled or not supported on your system,
-the above functions throw errors, but they are still available.
-
-Here is a small example that works on GNU/Linux:
-
address@hidden
-(define libc-obj (dynamic-link "libc.so"))
-libc-obj
address@hidden #<dynamic-object "libc.so">
-(dynamic-args-call 'rand libc-obj '())
address@hidden 269167349
-(dynamic-unlink libc-obj)
-libc-obj
address@hidden #<dynamic-object "libc.so" (unlinked)>
address@hidden smallexample
-
-As you can see, after calling @code{dynamic-unlink} on a dynamically
-linked library, it is marked as @samp{(unlinked)} and you are no longer
-able to use it with @code{dynamic-call}, etc. Whether the library is
-really removed from you program is system-dependent and will generally
-not happen when some other parts of your program still use it. In the
-example above, @code{libc} is almost certainly not removed from your
-program because it is badly needed by almost everything.
-
-The functions to call a function from a dynamically linked library,
address@hidden and @code{dynamic-args-call}, are not very powerful.
-They are mostly intended to be used for calling specially written
-initialization functions that will then add new primitives to Guile.
-For example, we do not expect that you will dynamically link
address@hidden with @code{dynamic-link} and then construct a beautiful
-graphical user interface just by using @code{dynamic-call} and
address@hidden Instead, the usual way would be to write a
-special Guile<->X11 glue library that has intimate knowledge about both
-Guile and X11 and does whatever is necessary to make them inter-operate
-smoothly. This glue library could then be dynamically linked into a
-vanilla Guile interpreter and activated by calling its initialization
-function. That function would add all the new types and primitives to
-the Guile interpreter that it has to offer.
-
-From this setup the next logical step is to integrate these glue
-libraries into the module system of Guile so that you can load new
-primitives into a running system just as you can load new Scheme code.
-
-There is, however, another possibility to get a more thorough access to
-the functions contained in a dynamically linked library. Anthony Green
-has written @file{libffi}, a library that implements a @dfn{foreign
-function interface} for a number of different platforms. With it, you
-can extend the Spartan functionality of @code{dynamic-call} and
address@hidden considerably. There is glue code available in
-the Guile contrib archive to make @file{libffi} accessible from Guile.
-
address@hidden Compiled Code Modules
address@hidden Putting Compiled Code into Modules
-
-The new primitives that you add to Guile with
address@hidden (@pxref{Primitive Procedures}) or with any
-of the other mechanisms are placed into the @code{(guile-user)} module
-by default. However, it is also possible to put new primitives into
-other modules.
-
-The mechanism for doing so is not very well thought out and is likely to
-change when the module system of Guile itself is revised, but it is
-simple and useful enough to document it as it stands.
-
-What @code{scm_c_define_gsubr} and the functions used by the snarfer
-really do is to add the new primitives to whatever module is the
address@hidden module} when they are called. This is analogous to the
-way Scheme code is put into modules: the @code{define-module} expression
-at the top of a Scheme source file creates a new module and makes it the
-current module while the rest of the file is evaluated. The
address@hidden expressions in that file then add their new definitions to
-this current module.
-
-Therefore, all we need to do is to make sure that the right module is
-current when calling @code{scm_c_define_gsubr} for our new primitives.
-
address@hidden Dynamic Linking and Compiled Code Modules
address@hidden Dynamic Linking and Compiled Code Modules
-
-The most interesting application of dynamically linked libraries is
-probably to use them for providing @emph{compiled code modules} to
-Scheme programs. As much fun as programming in Scheme is, every now and
-then comes the need to write some low-level C stuff to make Scheme even
-more fun.
-
-Not only can you put these new primitives into their own module (see the
-previous section), you can even put them into a shared library that is
-only then linked to your running Guile image when it is actually
-needed.
-
-An example will hopefully make everything clear. Suppose we want to
-make the Bessel functions of the C library available to Scheme in the
-module @samp{(math bessel)}. First we need to write the appropriate
-glue code to convert the arguments and return values of the functions
-from Scheme to C and back. Additionally, we need a function that will
-add them to the set of Guile primitives. Because this is just an
-example, we will only implement this for the @code{j0} function.
-
address@hidden FIXME::martin: Change all gh_ references to their scm_
equivalents.
-
address@hidden
-#include <math.h>
-#include <libguile.h>
-
-SCM
-j0_wrapper (SCM x)
address@hidden
- return scm_double2num (j0 (scm_num2dbl (x, "j0")));
address@hidden
-
-void
-init_math_bessel ()
address@hidden
- scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper);
address@hidden
address@hidden smallexample
-
-We can already try to bring this into action by manually calling the low
-level functions for performing dynamic linking. The C source file needs
-to be compiled into a shared library. Here is how to do it on
-GNU/Linux, please refer to the @code{libtool} documentation for how to
-create dynamically linkable libraries portably.
-
address@hidden
-gcc -shared -o libbessel.so -fPIC bessel.c
address@hidden smallexample
-
-Now fire up Guile:
-
address@hidden
-(define bessel-lib (dynamic-link "./libbessel.so"))
-(dynamic-call "init_math_bessel" bessel-lib)
-(j0 2)
address@hidden 0.223890779141236
address@hidden lisp
-
-The filename @file{./libbessel.so} should be pointing to the shared
-library produced with the @code{gcc} command above, of course. The
-second line of the Guile interaction will call the
address@hidden function which in turn will register the C
-function @code{j0_wrapper} with the Guile interpreter under the name
address@hidden This function becomes immediately available and we can call
-it from Scheme.
-
-Fun, isn't it? But we are only half way there. This is what
address@hidden has to say about @code{j0}:
-
address@hidden
-(apropos "j0")
address@hidden (guile-user): j0 #<primitive-procedure j0>
address@hidden smallexample
-
-As you can see, @code{j0} is contained in the root module, where all
-the other Guile primitives like @code{display}, etc live. In general,
-a primitive is put into whatever module is the @dfn{current module} at
-the time @code{scm_c_define_gsubr} is called.
-
-A compiled module should have a specially named @dfn{module init
-function}. Guile knows about this special name and will call that
-function automatically after having linked in the shared library. For
-our example, we replace @code{init_math_bessel} with the following code in
address@hidden:
-
address@hidden
-void
-init_math_bessel (void *unused)
address@hidden
- scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper);
- scm_c_export ("j0", NULL);
address@hidden
-
-void
-scm_init_math_bessel_module ()
address@hidden
- scm_c_define_module ("math bessel", init_math_bessel, NULL);
address@hidden
address@hidden smallexample
-
-The general pattern for the name of a module init function is:
address@hidden, followed by the name of the module where the
-individual hierarchical components are concatenated with underscores,
-followed by @samp{_module}.
-
-After @file{libbessel.so} has been rebuilt, we need to place the shared
-library into the right place.
-
-Once the module has been correctly installed, it should be possible to
-use it like this:
-
address@hidden
-guile> (load-extension "./libbessel.so" "scm_init_math_bessel_module")
-guile> (use-modules (math bessel))
-guile> (j0 2)
-0.223890779141236
-guile> (apropos "j0")
address@hidden (math bessel): j0 #<primitive-procedure j0>
address@hidden smallexample
-
-That's it!
-
address@hidden {Scheme Procedure} load-extension lib init
address@hidden {C Function} scm_load_extension (lib, init)
-Load and initialize the extension designated by LIB and INIT.
-When there is no pre-registered function for LIB/INIT, this is
-equivalent to
-
address@hidden
-(dynamic-call INIT (dynamic-link LIB))
address@hidden lisp
-
-When there is a pre-registered function, that function is called
-instead.
-
-Normally, there is no pre-registered function. This option exists
-only for situations where dynamic linking is unavailable or unwanted.
-In that case, you would statically link your program with the desired
-library, and register its init function right after Guile has been
-initialized.
-
-LIB should be a string denoting a shared library without any file type
-suffix such as ".so". The suffix is provided automatically. It
-should also not contain any directory components. Libraries that
-implement Guile Extensions should be put into the normal locations for
-shared libraries. We recommend to use the naming convention
-libguile-bla-blum for a extension related to a module `(bla blum)'.
-
-The normal way for a extension to be used is to write a small Scheme
-file that defines a module, and to load the extension into this
-module. When the module is auto-loaded, the extension is loaded as
-well. For example,
-
address@hidden
-(define-module (bla blum))
-
-(load-extension "libguile-bla-blum" "bla_init_blum")
address@hidden lisp
address@hidden deffn
-
-
address@hidden Compiled Code Installation
address@hidden Compiled Code Installation
-
-The simplest way to write a module using compiled C code is
-
address@hidden
-(define-module (foo bar))
-(load-extension "foobar-c-code" "foo_bar_init")
address@hidden example
-
-When loaded with @code{(use-modules (foo bar))}, the
address@hidden call looks for the @file{foobar-c-code.so} (etc)
-object file in the standard system locations, such as @file{/usr/lib}
-or @file{/usr/local/lib}.
-
-If someone installs your module to a non-standard location then the
-object file won't be found. You can address this by inserting the
-install location in the @file{foo/bar.scm} file. This is convenient
-for the user and also guarantees the intended object is read, even if
-stray older or newer versions are in the loader's path.
-
-The usual way to specify an install location is with a @code{prefix}
-at the configure stage, for instance @samp{./configure prefix=/opt}
-results in library files as say @file{/opt/lib/foobar-c-code.so}.
-When using Autoconf (@pxref{Top, , Introduction, autoconf, The GNU
-Autoconf Manual}), the library location is in a @code{libdir}
-variable. Its value is intended to be expanded by @command{make}, and
-can by substituted into a source file like @file{foo.scm.in}
-
address@hidden
-(define-module (foo bar))
-(load-extension "XXlibdirXX/foobar-c-code" "foo_bar_init")
address@hidden example
-
address@hidden
-with the following in a @file{Makefile}, using @command{sed}
-(@pxref{Top, , Introduction, sed, SED, A Stream Editor}),
-
address@hidden
-foo.scm: foo.scm.in
- sed 's|XXlibdirXX|$(libdir)|' <foo.scm.in >foo.scm
address@hidden example
-
-The actual pattern @code{XXlibdirXX} is arbitrary, it's only something
-which doesn't otherwise occur. If several modules need the value, it
-can be easier to create one @file{foo/config.scm} with a define of the
address@hidden location, and use that as required.
-
address@hidden
-(define-module (foo config))
-(define-public foo-config-libdir "XXlibdirXX"")
address@hidden example
-
-Such a file might have other locations too, for instance a data
-directory for auxiliary files, or @code{localedir} if the module has
-its own @code{gettext} message catalogue
-(@pxref{Internationalization}).
-
-When installing multiple C code objects, it can be convenient to put
-them in a subdirectory of @code{libdir}, thus giving for example
address@hidden/usr/lib/foo/some-obj.so}. If the objects are only meant to be
-used through the module, then a subdirectory keeps them out of sight.
-
-It will be noted all of the above requires that the Scheme code to be
-found in @code{%load-path} (@pxref{Build Config}). Presently it's
-left up to the system administrator or each user to augment that path
-when installing Guile modules in non-default locations. But having
-reached the Scheme code, that code should take care of hitting any of
-its own private files etc.
-
-Presently there's no convention for having a Guile version number in
-module C code filenames or directories. This is primarily because
-there's no established principles for two versions of Guile to be
-installed under the same prefix (eg. two both under @file{/usr}).
-Assuming upward compatibility is maintained then this should be
-unnecessary, and if compatibility is not maintained then it's highly
-likely a package will need to be revisited anyway.
-
-The present suggestion is that modules should assume when they're
-installed under a particular @code{prefix} that there's a single
-version of Guile there, and the @code{guile-config} at build time has
-the necessary information about it. C code or Scheme code might adapt
-itself accordingly (allowing for features not available in an older
-version for instance).
-
@node Variables
@subsection Variables
@@ -1374,9 +917,6 @@ name @var{name} in the current module. But they can also
be created
dynamically by calling one of the constructor procedures
@code{make-variable} and @code{make-undefined-variable}.
-First-class variables are especially useful for interacting with the
-current module system (@pxref{The Guile module system}).
-
@deffn {Scheme Procedure} make-undefined-variable
@deffnx {C Function} scm_make_undefined_variable ()
Return a variable that is initially unbound.
@@ -1414,6 +954,83 @@ return @code{#f}.
@end deffn
address@hidden provide and require
address@hidden provide and require
+
+Aubrey Jaffer, mostly to support his portable Scheme library SLIB,
+implemented a provide/require mechanism for many Scheme implementations.
+Library files in SLIB @emph{provide} a feature, and when user programs
address@hidden that feature, the library file is loaded in.
+
+For example, the file @file{random.scm} in the SLIB package contains the
+line
+
address@hidden
+(provide 'random)
address@hidden lisp
+
+so to use its procedures, a user would type
+
address@hidden
+(require 'random)
address@hidden lisp
+
+and they would magically become available, @emph{but still have the same
+names!} So this method is nice, but not as good as a full-featured
+module system.
+
+When SLIB is used with Guile, provide and require can be used to access
+its facilities.
+
address@hidden Environments
address@hidden Environments
address@hidden environment
+
+Scheme, as defined in R5RS, does @emph{not} have a full module system.
+However it does define the concept of a top-level @dfn{environment}.
+Such an environment maps identifiers (symbols) to Scheme objects such
+as procedures and lists: @ref{About Closure}. In other words, it
+implements a set of @dfn{bindings}.
+
+Environments in R5RS can be passed as the second argument to
address@hidden (@pxref{Fly Evaluation}). Three procedures are defined to
+return environments: @code{scheme-report-environment},
address@hidden and @code{interaction-environment} (@pxref{Fly
+Evaluation}).
+
+In addition, in Guile any module can be used as an R5RS environment,
+i.e., passed as the second argument to @code{eval}.
+
+Note: the following two procedures are available only when the
address@hidden(ice-9 r5rs)} module is loaded:
+
address@hidden
+(use-modules (ice-9 r5rs))
address@hidden lisp
+
address@hidden {Scheme Procedure} scheme-report-environment version
address@hidden {Scheme Procedure} null-environment version
address@hidden must be the exact integer `5', corresponding to revision
+5 of the Scheme report (the Revised^5 Report on Scheme).
address@hidden returns a specifier for an
+environment that is empty except for all bindings defined in the
+report that are either required or both optional and supported by the
+implementation. @code{null-environment} returns a specifier for an
+environment that is empty except for the (syntactic) bindings for all
+syntactic keywords defined in the report that are either required or
+both optional and supported by the implementation.
+
+Currently Guile does not support values of @var{version} for other
+revisions of the report.
+
+The effect of assigning (through the use of @code{eval}) a variable
+bound in a @code{scheme-report-environment} (for example @code{car})
+is unspecified. Currently the environments specified by
address@hidden are not immutable in Guile.
address@hidden deffn
+
+
+
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index 464c7f0..b44bb18 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2008, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -509,6 +509,7 @@ keywords #f Style of keyword recognition: #f,
'prefix or 'postfix
case-insensitive no Convert symbols to lower case.
positions yes Record positions of source code expressions.
copy no Copy source code expressions.
+r6rs-hex-escapes no Use R6RS-style string and character hex escapes
@end smalllisp
Notice that while Standard Scheme is case insensitive, to ease
@@ -521,6 +522,9 @@ To make Guile case insensitive, you can type
(read-enable 'case-insensitive)
@end lisp
+For more information on the effect of the @code{r6rs-hex-escapes} option, see
+(@pxref{Characters}) and (@pxref{String Syntax}).
+
@node Printing options
@subsubsection Printing options
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 0644556..a2f647c 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -1,11 +1,11 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
address@hidden Procedures and Macros
address@hidden Procedures and Macros
address@hidden Procedures
address@hidden Procedures
@menu
* Lambda:: Basic procedure creation using lambda.
@@ -15,10 +15,6 @@
* Case-lambda:: One function, multiple arities.
* Procedure Properties:: Procedure properties and meta-information.
* Procedures with Setters:: Procedures with setters.
-* Macros:: Lisp style macro definitions.
-* Syntax Rules:: Support for R5RS @code{syntax-rules}.
-* Syntax Case:: Support for the @code{syntax-case} system.
-* Internal Macros:: Guile's internal representation.
@end menu
@@ -111,7 +107,7 @@ the given @var{name} but no environment binding will be
created. The
arguments @var{req}, @var{opt} and @var{rst} specify the number of
required, optional and ``rest'' arguments respectively. The total
number of these arguments should match the actual number of arguments
-to @var{fcn}. The number of rest arguments should be 0 or 1.
+to @var{fcn}, but may not exceed 10. The number of rest arguments should be 0
or 1.
@code{scm_c_make_gsubr} returns a value of type @code{SCM} which is a
``handle'' for the procedure.
@end deftypefun
@@ -767,8 +763,8 @@ associated setter procedure.
@deffn {Scheme Procedure} procedure proc
@deffnx {C Function} scm_procedure (proc)
-Return the procedure of @var{proc}, which must be either a
-procedure with setter, or an operator struct.
+Return the procedure of @var{proc}, which must be an
+applicable struct.
@end deffn
@deffn {Scheme Procedure} setter proc
@@ -777,290 +773,6 @@ setter or an operator struct.
@end deffn
address@hidden Macros
address@hidden Lisp Style Macro Definitions
-
address@hidden macros
address@hidden transformation
-Macros are objects which cause the expression that they appear in to be
-transformed in some way @emph{before} being evaluated. In expressions
-that are intended for macro transformation, the identifier that names
-the relevant macro must appear as the first element, like this:
-
address@hidden
-(@var{macro-name} @var{macro-args} @dots{})
address@hidden lisp
-
-In Lisp-like languages, the traditional way to define macros is very
-similar to procedure definitions. The key differences are that the
-macro definition body should return a list that describes the
-transformed expression, and that the definition is marked as a macro
-definition (rather than a procedure definition) by the use of a
-different definition keyword: in Lisp, @code{defmacro} rather than
address@hidden, and in Scheme, @code{define-macro} rather than
address@hidden
-
address@hidden defmacro
address@hidden define-macro
-Guile supports this style of macro definition using both @code{defmacro}
-and @code{define-macro}. The only difference between them is how the
-macro name and arguments are grouped together in the definition:
-
address@hidden
-(defmacro @var{name} (@var{args} @dots{}) @var{body} @dots{})
address@hidden lisp
-
address@hidden
-is the same as
-
address@hidden
-(define-macro (@var{name} @var{args} @dots{}) @var{body} @dots{})
address@hidden lisp
-
address@hidden
-The difference is analogous to the corresponding difference between
-Lisp's @code{defun} and Scheme's @code{define}.
-
address@hidden, from the @file{boot-9.scm} file in the Guile
-distribution, is a good example of macro definition using
address@hidden:
-
address@hidden
-(defmacro false-if-exception (expr)
- `(catch #t
- (lambda () ,expr)
- (lambda args #f)))
address@hidden lisp
-
address@hidden
-The effect of this definition is that expressions beginning with the
-identifier @code{false-if-exception} are automatically transformed into
-a @code{catch} expression following the macro definition specification.
-For example:
-
address@hidden
-(false-if-exception (open-input-file "may-not-exist"))
address@hidden
-(catch #t
- (lambda () (open-input-file "may-not-exist"))
- (lambda args #f))
address@hidden lisp
-
-
address@hidden Syntax Rules
address@hidden The R5RS @code{syntax-rules} System
address@hidden R5RS syntax-rules system
-
-R5RS defines an alternative system for macro and syntax transformations
-using the keywords @code{define-syntax}, @code{let-syntax},
address@hidden and @code{syntax-rules}.
-
-The main difference between the R5RS system and the traditional macros
-of the previous section is how the transformation is specified. In
-R5RS, rather than permitting a macro definition to return an arbitrary
-expression, the transformation is specified in a pattern language that
-
address@hidden @bullet
address@hidden
-does not require complicated quoting and extraction of components of the
-source expression using @code{caddr} etc.
-
address@hidden
-is designed such that the bindings associated with identifiers in the
-transformed expression are well defined, and such that it is impossible
-for the transformed expression to construct new identifiers.
address@hidden itemize
-
address@hidden
-The last point is commonly referred to as being @dfn{hygienic}: the R5RS
address@hidden system provides @dfn{hygienic macros}.
-
-For example, the R5RS pattern language for the @code{false-if-exception}
-example of the previous section looks like this:
-
address@hidden
-(syntax-rules ()
- ((_ expr)
- (catch #t
- (lambda () expr)
- (lambda args #f))))
address@hidden lisp
-
address@hidden @code{syncase}
-In Guile, the @code{syntax-rules} system is provided by the @code{(ice-9
-syncase)} module. To make these facilities available in your code,
-include the expression @code{(use-syntax (ice-9 syncase))} (@pxref{Using
-Guile Modules}) before the first usage of @code{define-syntax} etc. If
-you are writing a Scheme module, you can alternatively include the form
address@hidden:use-syntax (ice-9 syncase)} in your @code{define-module}
-declaration (@pxref{Creating Guile Modules}).
-
address@hidden
-* Pattern Language:: The @code{syntax-rules} pattern language.
-* Define-Syntax:: Top level syntax definitions.
-* Let-Syntax:: Local syntax definitions.
address@hidden menu
-
-
address@hidden Pattern Language
address@hidden The @code{syntax-rules} Pattern Language
-
-
address@hidden Define-Syntax
address@hidden Top Level Syntax Definitions
-
-define-syntax: The gist is
-
- (define-syntax <keyword> <transformer-spec>)
-
-makes the <keyword> into a macro so that
-
- (<keyword> ...)
-
-expands at _compile_ or _read_ time (i.e. before any
-evaluation begins) into some expression that is
-given by the <transformer-spec>.
-
-
address@hidden Let-Syntax
address@hidden Local Syntax Definitions
-
-
address@hidden Syntax Case
address@hidden Support for the @code{syntax-case} System
-
-
-
address@hidden Internal Macros
address@hidden Internal Representation of Macros and Syntax
-
-[FIXME: used to be true. Isn't any more. Use syntax-rules or
-syntax-case please :)]
-
-Internally, Guile uses three different flavors of macros. The three
-flavors are called @dfn{acro} (or @dfn{syntax}), @dfn{macro} and
address@hidden
-
-Given the expression
-
address@hidden
-(foo @dots{})
address@hidden lisp
-
address@hidden
-with @code{foo} being some flavor of macro, one of the following things
-will happen when the expression is evaluated.
-
address@hidden @bullet
address@hidden
-When @code{foo} has been defined to be an @dfn{acro}, the procedure used
-in the acro definition of @code{foo} is passed the whole expression and
-the current lexical environment, and whatever that procedure returns is
-the value of evaluating the expression. You can think of this a
-procedure that receives its argument as an unevaluated expression.
-
address@hidden
-When @code{foo} has been defined to be a @dfn{macro}, the procedure used
-in the macro definition of @code{foo} is passed the whole expression and
-the current lexical environment, and whatever that procedure returns is
-evaluated again. That is, the procedure should return a valid Scheme
-expression.
-
address@hidden
-When @code{foo} has been defined to be a @dfn{mmacro}, the procedure
-used in the mmacro definition of `foo' is passed the whole expression
-and the current lexical environment, and whatever that procedure returns
-replaces the original expression. Evaluation then starts over from the
-new expression that has just been returned.
address@hidden itemize
-
-The key difference between a @dfn{macro} and a @dfn{mmacro} is that the
-expression returned by a @dfn{mmacro} procedure is remembered (or
address@hidden) so that the expansion does not need to be done again
-next time the containing code is evaluated.
-
-The primitives @code{procedure->syntax}, @code{procedure->macro} and
address@hidden>memoizing-macro} are used to construct acros, macros
-and mmacros respectively. However, if you do not have a very special
-reason to use one of these primitives, you should avoid them: they are
-very specific to Guile's current implementation and therefore likely to
-change. Use @code{defmacro}, @code{define-macro} (@pxref{Macros}) or
address@hidden (@pxref{Syntax Rules}) instead. (In low level
-terms, @code{defmacro}, @code{define-macro} and @code{define-syntax} are
-all implemented as mmacros.)
-
address@hidden {Scheme Procedure} procedure->syntax code
address@hidden {C Function} scm_makacro (code)
-Return a macro which, when a symbol defined to this value appears as the
-first symbol in an expression, returns the result of applying @var{code}
-to the expression and the environment.
address@hidden deffn
-
address@hidden {Scheme Procedure} procedure->macro code
address@hidden {C Function} scm_makmacro (code)
-Return a macro which, when a symbol defined to this value appears as the
-first symbol in an expression, evaluates the result of applying
address@hidden to the expression and the environment. For example:
-
address@hidden
-(define trace
- (procedure->macro
- (lambda (x env)
- `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))
-
-(trace @i{foo})
address@hidden
-(set! @i{foo} (tracef @i{foo} '@i{foo})).
address@hidden lisp
address@hidden deffn
-
address@hidden {Scheme Procedure} procedure->memoizing-macro code
address@hidden {C Function} scm_makmmacro (code)
-Return a macro which, when a symbol defined to this value appears as the
-first symbol in an expression, evaluates the result of applying
address@hidden to the expression and the environment.
address@hidden>memoizing-macro} is the same as
address@hidden>macro}, except that the expression returned by
address@hidden replaces the original macro expression in the memoized form
-of the containing code.
address@hidden deffn
-
-In the following primitives, @dfn{acro} flavor macros are referred to
-as @dfn{syntax transformers}.
-
address@hidden {Scheme Procedure} macro? obj
address@hidden {C Function} scm_macro_p (obj)
-Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a
-syntax transformer.
address@hidden deffn
-
address@hidden {Scheme Procedure} macro-type m
address@hidden {C Function} scm_macro_type (m)
-Return one of the symbols @code{syntax}, @code{macro} or
address@hidden, depending on whether @var{m} is a syntax
-transformer, a regular macro, or a memoizing macro,
-respectively. If @var{m} is not a macro, @code{#f} is
-returned.
address@hidden deffn
-
address@hidden {Scheme Procedure} macro-name m
address@hidden {C Function} scm_macro_name (m)
-Return the name of the macro @var{m}.
address@hidden deffn
-
address@hidden {Scheme Procedure} macro-transformer m
address@hidden {C Function} scm_macro_transformer (m)
-Return the transformer of the macro @var{m}.
address@hidden deffn
-
address@hidden {Scheme Procedure} cons-source xorig x y
address@hidden {C Function} scm_cons_source (xorig, x, y)
-Create and return a new pair whose car and cdr are @var{x} and @var{y}.
-Any source properties associated with @var{xorig} are also associated
-with the new pair.
address@hidden deffn
-
-
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi
index ef1df19..cae96bc 100644
--- a/doc/ref/api-undocumented.texi
+++ b/doc/ref/api-undocumented.texi
@@ -155,7 +155,7 @@ has been passed to scm_register_module_xxx.
@deffn {Scheme Procedure} module-import-interface module sym
@deffnx {C Function} scm_module_import_interface (module, sym)
-
+Return the module or interface from which @var{sym} is imported in
@var{module}. If @var{sym} is not imported (i.e., it is not defined in
@var{module} or it is a module-local binding instead of an imported one), then
@code{#f} is returned.
@end deffn
@@ -623,7 +623,7 @@ on the C level which depends on the loaded GOOPS modules.
@deffn {Scheme Procedure} %method-more-specific? m1 m2 targs
@deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs)
-
+Return true if method @var{m1} is more specific than @var{m2} given the
argument types (classes) listed in @var{targs}.
@end deffn
@deffn {Scheme Procedure} find-method . l
diff --git a/doc/ref/data-rep.texi b/doc/ref/data-rep.texi
index 5f2a22b..7e80478 100644
--- a/doc/ref/data-rep.texi
+++ b/doc/ref/data-rep.texi
@@ -1,11 +1,11 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
address@hidden Data Representation in Scheme
address@hidden Data Representation in Scheme
address@hidden Data Representation
address@hidden Data Representation
Scheme is a latently-typed language; this means that the system cannot,
in general, determine the type of a given expression at compile time.
@@ -27,27 +27,25 @@ single type large enough to hold either a complete value or
a pointer
to a complete value, along with the necessary typing information.
The following sections will present a simple typing system, and then
-make some refinements to correct its major weaknesses. However, this is
-not a description of the system Guile actually uses. It is only an
-illustration of the issues Guile's system must address. We provide all
-the information one needs to work with Guile's data in @ref{The
-Libguile Runtime Environment}.
-
+make some refinements to correct its major weaknesses. We then conclude
+with a discussion of specific choices that Guile has made regarding
+garbage collection and data representation.
@menu
* A Simple Representation::
* Faster Integers::
* Cheaper Pairs::
-* Guile Is Hairier::
+* Conservative GC::
+* The SCM Type in Guile::
@end menu
@node A Simple Representation
@subsection A Simple Representation
-The simplest way to meet the above requirements in C would be to
-represent each value as a pointer to a structure containing a type
-indicator, followed by a union carrying the real value. Assuming that
address@hidden is the name of our universal type, we can write:
+The simplest way to represent Scheme values in C would be to represent
+each value as a pointer to a structure containing a type indicator,
+followed by a union carrying the real value. Assuming that @code{SCM} is
+the name of our universal type, we can write:
@example
enum type @{ integer, pair, string, vector, ... @};
@@ -98,17 +96,17 @@ too costly, in both time and space. Integers should be
very cheap to
create and manipulate.
One possible solution comes from the observation that, on many
-architectures, structures must be aligned on a four-byte boundary.
-(Whether or not the machine actually requires it, we can write our own
-allocator for @code{struct value} objects that assures this is true.)
-In this case, the lower two bits of the structure's address are known to
-be zero.
+architectures, heap-allocated data (i.e., what you get when you call
address@hidden) must be aligned on an eight-byte boundary. (Whether or
+not the machine actually requires it, we can write our own allocator for
address@hidden value} objects that assures this is true.) In this case,
+the lower three bits of the structure's address are known to be zero.
This gives us the room we need to provide an improved representation
for integers. We make the following rules:
@itemize @bullet
@item
-If the lower two bits of an @code{SCM} value are zero, then the SCM
+If the lower three bits of an @code{SCM} value are zero, then the SCM
value is a pointer to a @code{struct value}, and everything proceeds as
before.
@item
@@ -132,11 +130,11 @@ struct value @{
@} value;
@};
-#define POINTER_P(x) (((int) (x) & 3) == 0)
+#define POINTER_P(x) (((int) (x) & 7) == 0)
#define INTEGER_P(x) (! POINTER_P (x))
-#define GET_INTEGER(x) ((int) (x) >> 2)
-#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1))
+#define GET_INTEGER(x) ((int) (x) >> 3)
+#define MAKE_INTEGER(x) ((SCM) (((x) << 3) | 1))
@end example
Notice that @code{integer} no longer appears as an element of @code{enum
@@ -174,34 +172,36 @@ integers, we can compute their sum as follows:
@example
MAKE_INTEGER (GET_INTEGER (@var{x}) + GET_INTEGER (@var{y}))
@end example
-Now, integer math requires no allocation or memory references. Most
-real Scheme systems actually use an even more efficient representation,
-but this essay isn't about bit-twiddling. (Hint: what if pointers had
address@hidden in their least significant bits, and integers had @code{00}?)
+Now, integer math requires no allocation or memory references. Most real
+Scheme systems actually implement addition and other operations using an
+even more efficient algorithm, but this essay isn't about
+bit-twiddling. (Hint: how do you decide when to overflow to a bignum?
+How would you do it in assembly?)
@node Cheaper Pairs
@subsection Cheaper Pairs
-However, there is yet another issue to confront. Most Scheme heaps
-contain more pairs than any other type of object; Jonathan Rees says
-that pairs occupy 45% of the heap in his Scheme implementation, Scheme
-48. However, our representation above spends three @code{SCM}-sized
-words per pair --- one for the type, and two for the @sc{car} and
address@hidden Is there any way to represent pairs using only two words?
+However, there is yet another issue to confront. Most Scheme heaps
+contain more pairs than any other type of object; Jonathan Rees said at
+one point that pairs occupy 45% of the heap in his Scheme
+implementation, Scheme 48. However, our representation above spends
+three @code{SCM}-sized words per pair --- one for the type, and two for
+the @sc{car} and @sc{cdr}. Is there any way to represent pairs using
+only two words?
Let us refine the convention we established earlier. Let us assert
that:
@itemize @bullet
@item
- If the bottom two bits of an @code{SCM} value are @code{#b00}, then
+ If the bottom three bits of an @code{SCM} value are @code{#b000}, then
it is a pointer, as before.
@item
- If the bottom two bits are @code{#b01}, then the upper bits are an
+ If the bottom three bits are @code{#b001}, then the upper bits are an
integer. This is a bit more restrictive than before.
@item
- If the bottom two bits are @code{#b10}, then the value, with the bottom
- two bits masked out, is the address of a pair.
+ If the bottom two bits are @code{#b010}, then the value, with the bottom
+ three bits masked out, is the address of a pair.
@end itemize
Here is the new C code:
@@ -223,14 +223,14 @@ struct pair @{
SCM car, cdr;
@};
-#define POINTER_P(x) (((int) (x) & 3) == 0)
+#define POINTER_P(x) (((int) (x) & 7) == 0)
-#define INTEGER_P(x) (((int) (x) & 3) == 1)
-#define GET_INTEGER(x) ((int) (x) >> 2)
-#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1))
+#define INTEGER_P(x) (((int) (x) & 7) == 1)
+#define GET_INTEGER(x) ((int) (x) >> 3)
+#define MAKE_INTEGER(x) ((SCM) (((x) << 3) | 1))
-#define PAIR_P(x) (((int) (x) & 3) == 2)
-#define GET_PAIR(x) ((struct pair *) ((int) (x) & ~3))
+#define PAIR_P(x) (((int) (x) & 7) == 2)
+#define GET_PAIR(x) ((struct pair *) ((int) (x) & ~7))
@end example
Notice that @code{enum type} and @code{struct value} now only contain
@@ -278,94 +278,32 @@ are referencing, making a modified pointer as fast to use
as an
unmodified pointer.
address@hidden Guile Is Hairier
address@hidden Guile Is Hairier
-
-We originally started with a very simple typing system --- each object
-has a field that indicates its type. Then, for the sake of efficiency
-in both time and space, we moved some of the typing information directly
-into the @code{SCM} value, and left the rest in the @code{struct value}.
-Guile itself employs a more complex hierarchy, storing finer and finer
-gradations of type information in different places, depending on the
-object's coarser type.
-
-In the author's opinion, Guile could be simplified greatly without
-significant loss of efficiency, but the simplified system would still be
-more complex than what we've presented above.
-
-
address@hidden The Libguile Runtime Environment
address@hidden The Libguile Runtime Environment
-
-Here we present the specifics of how Guile represents its data. We
-don't go into complete detail; an exhaustive description of Guile's
-system would be boring, and we do not wish to encourage people to write
-code which depends on its details anyway. We do, however, present
-everything one need know to use Guile's data. It is assumed that the
-reader understands the concepts laid out in @ref{Data Representation
-in Scheme}.
-
-FIXME: much of this is outdated as of 1.8, we don't provide many of
-these macros any more. Also here we're missing sections about the
-evaluator implementation, which is interesting, and notes about tail
-recursion between scheme and c.
-
address@hidden
-* General Rules::
-* Conservative GC::
-* Immediates vs Non-immediates::
-* Immediate Datatypes::
-* Non-immediate Datatypes::
-* Signalling Type Errors::
-* Unpacking the SCM type::
address@hidden menu
-
address@hidden General Rules
address@hidden General Rules
-
-Any code which operates on Guile datatypes must @code{#include} the
-header file @code{<libguile.h>}. This file contains a definition for
-the @code{SCM} typedef (Guile's universal type, as in the examples
-above), and definitions and declarations for a host of macros and
-functions that operate on @code{SCM} values.
-
-All identifiers declared by @code{<libguile.h>} begin with @code{scm_}
-or @code{SCM_}.
-
address@hidden [[I wish this were true, but I don't think it is at the moment.
-JimB]]
address@hidden Macros do not evaluate their arguments more than once, unless
documented
address@hidden to do so.
-
-The functions described here generally check the types of their
address@hidden arguments, and signal an error if their arguments are of an
-inappropriate type. Macros generally do not, unless that is their
-specified purpose. You must verify their argument types beforehand, as
-necessary.
-
-Macros and functions that return a boolean value have names ending in
address@hidden or @code{_p} (for ``predicate''). Those that return a negated
-boolean value have names starting with @code{SCM_N}. For example,
address@hidden (@var{x})} is a predicate which returns non-zero iff
address@hidden is an immediate value (an @code{IM}). @code{SCM_NCONSP
-(@var{x})} is a predicate which returns non-zero iff @var{x} is
address@hidden a pair object (a @code{CONS}).
-
-
@node Conservative GC
@subsection Conservative Garbage Collection
Aside from the latent typing, the major source of constraints on a
Scheme implementation's data representation is the garbage collector.
The collector must be able to traverse every live object in the heap, to
-determine which objects are not live.
-
-There are many ways to implement this, but Guile uses an algorithm
-called @dfn{mark and sweep}. The collector scans the system's global
-variables and the local variables on the stack to determine which
-objects are immediately accessible by the C code. It then scans those
-objects to find the objects they point to, @i{et cetera}. The collector
-sets a @dfn{mark bit} on each object it finds, so each object is
-traversed only once. This process is called @dfn{tracing}.
+determine which objects are not live, and thus collectable.
+
+There are many ways to implement this. Guile's garbage collection is
+built on a library, the Boehm-Demers-Weiser conservative garbage
+collector (BDW-GC). The BDW-GC ``just works'', for the most part. But
+since it is interesting to know how these things work, we include here a
+high-level description of what the BDW-GC does.
+
+Garbage collection has two logical phases: a @dfn{mark} phase, in which
+the set of live objects is enumerated, and a @dfn{sweep} phase, in which
+objects not traversed in the mark phase are collected. Correct
+functioning of the collector depends on being able to traverse the
+entire set of live objects.
+
+In the mark phase, the collector scans the system's global variables and
+the local variables on the stack to determine which objects are
+immediately accessible by the C code. It then scans those objects to
+find the objects they point to, and so on. The collector logically sets
+a @dfn{mark bit} on each object it finds, so each object is traversed
+only once.
When the collector can find no unmarked objects pointed to by marked
objects, it assumes that any objects that are still unmarked will never
@@ -380,9 +318,9 @@ to all global variables that refer to the heap, and another
list
for the collector's benefit.
The list of global variables is usually not too difficult to maintain,
-since global variables are relatively rare. However, an explicitly
+since global variables are relatively rare. However, an explicitly
maintained list of local variables (in the author's personal experience)
-is a nightmare to maintain. Thus, Guile uses a technique called
+is a nightmare to maintain. Thus, the BDW-GC uses a technique called
@dfn{conservative garbage collection}, to make the local variable list
unnecessary.
@@ -392,50 +330,21 @@ is a pointer into the heap. Thus, the collector marks
all objects whose
addresses appear anywhere in the stack, without knowing for sure how
that word is meant to be interpreted.
+In addition to the stack, the BDW-GC will also scan static data
+sections. This means that global variables are also scanned when looking
+for live Scheme objects.
+
Obviously, such a system will occasionally retain objects that are
-actually garbage, and should be freed. In practice, this is not a
-problem. The alternative, an explicitly maintained list of local
+actually garbage, and should be freed. In practice, this is not a
+problem. The alternative, an explicitly maintained list of local
variable addresses, is effectively much less reliable, due to programmer
-error.
-
-To accommodate this technique, data must be represented so that the
-collector can accurately determine whether a given stack word is a
-pointer or not. Guile does this as follows:
-
address@hidden @bullet
address@hidden
-Every heap object has a two-word header, called a @dfn{cell}. Some
-objects, like pairs, fit entirely in a cell's two words; others may
-store pointers to additional memory in either of the words. For
-example, strings and vectors store their length in the first word, and a
-pointer to their elements in the second.
-
address@hidden
-Guile allocates whole arrays of cells at a time, called @dfn{heap
-segments}. These segments are always allocated so that the cells they
-contain fall on eight-byte boundaries, or whatever is appropriate for
-the machine's word size. Guile keeps all cells in a heap segment
-initialized, whether or not they are currently in use.
-
address@hidden
-Guile maintains a sorted table of heap segments.
address@hidden itemize
-
-Thus, given any random word @var{w} fetched from the stack, Guile's
-garbage collector can consult the table to see if @var{w} falls within a
-known heap segment, and check @var{w}'s alignment. If both tests pass,
-the collector knows that @var{w} is a valid pointer to a cell,
-intentional or not, and proceeds to trace the cell.
-
-Note that heap segments do not contain all the data Guile uses; cells
-for objects like vectors and strings contain pointers to other memory
-areas. However, since those pointers are internal, and not shared among
-many pieces of code, it is enough for the collector to find the cell,
-and then use the cell's type to find more pointers to trace.
+error. Interested readers should see the BDW-GC web page at
address@hidden://www.hpl.hp.com/personal/Hans_Boehm/gc}, for more
+information.
address@hidden Immediates vs Non-immediates
address@hidden Immediates vs Non-immediates
address@hidden The SCM Type in Guile
address@hidden The SCM Type in Guile
Guile classifies Scheme objects into two kinds: those that fit entirely
within an @code{SCM}, and those that require heap storage.
@@ -446,481 +355,15 @@ mysterious end-of-file object, and some others.
The remaining types are called, not surprisingly, @dfn{non-immediates}.
They include pairs, procedures, strings, vectors, and all other data
-types in Guile.
-
address@hidden Macro int SCM_IMP (SCM @var{x})
-Return non-zero iff @var{x} is an immediate object.
address@hidden deftypefn
-
address@hidden Macro int SCM_NIMP (SCM @var{x})
-Return non-zero iff @var{x} is a non-immediate object. This is the
-exact complement of @code{SCM_IMP}, above.
address@hidden deftypefn
-
-Note that for versions of Guile prior to 1.4 it was necessary to use the
address@hidden macro before calling a finer-grained predicate to
-determine @var{x}'s type, such as @code{SCM_CONSP} or
address@hidden This is no longer required: the definitions of all
-Guile type predicates now include a call to @code{SCM_NIMP} where
-necessary.
-
-
address@hidden Immediate Datatypes
address@hidden Immediate Datatypes
-
-The following datatypes are immediate values; that is, they fit entirely
-within an @code{SCM} value. The @code{SCM_IMP} and @code{SCM_NIMP}
-macros will distinguish these from non-immediates; see @ref{Immediates
-vs Non-immediates} for an explanation of the distinction.
-
-Note that the type predicates for immediate values work correctly on any
address@hidden value; you do not need to call @code{SCM_IMP} first, to
-establish that a value is immediate.
-
address@hidden
-* Integer Data::
-* Character Data::
-* Boolean Data::
-* Unique Values::
address@hidden menu
-
address@hidden Integer Data
address@hidden Integers
-
-Here are functions for operating on small integers, that fit within an
address@hidden Such integers are called @dfn{immediate numbers}, or
address@hidden In general, INUMs occupy all but two bits of an
address@hidden
-
-Bignums and floating-point numbers are non-immediate objects, and have
-their own, separate accessors. The functions here will not work on
-them. This is not as much of a problem as you might think, however,
-because the system never constructs bignums that could fit in an INUM,
-and never uses floating point values for exact integers.
-
address@hidden Macro int SCM_INUMP (SCM @var{x})
-Return non-zero iff @var{x} is a small integer value.
address@hidden deftypefn
-
address@hidden Macro int SCM_NINUMP (SCM @var{x})
-The complement of SCM_INUMP.
address@hidden deftypefn
-
address@hidden Macro int SCM_INUM (SCM @var{x})
-Return the value of @var{x} as an ordinary, C integer. If @var{x}
-is not an INUM, the result is undefined.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_MAKINUM (int @var{i})
-Given a C integer @var{i}, return its representation as an @code{SCM}.
-This function does not check for overflow.
address@hidden deftypefn
-
+types in Guile. For non-immediates, the @code{SCM} word contains a
+pointer to data on the heap, with further information about the object
+in question is stored in that data.
address@hidden Character Data
address@hidden Characters
-
-Here are functions for operating on characters.
-
address@hidden Macro int SCM_CHARP (SCM @var{x})
-Return non-zero iff @var{x} is a character value.
address@hidden deftypefn
-
address@hidden Macro {unsigned int} SCM_CHAR (SCM @var{x})
-Return the value of @code{x} as a C character. If @var{x} is not a
-Scheme character, the result is undefined.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_MAKE_CHAR (int @var{c})
-Given a C character @var{c}, return its representation as a Scheme
-character value.
address@hidden deftypefn
-
-
address@hidden Boolean Data
address@hidden Booleans
-
-Booleans are represented as two specific immediate SCM values,
address@hidden and @code{SCM_BOOL_F}. @xref{Booleans}, for more
+This section describes how the @code{SCM} type is actually represented
+and used at the C level. Interested readers should see
address@hidden/tags.h} for an exposition of how Guile stores type
information.
address@hidden Unique Values
address@hidden Unique Values
-
-The immediate values that are neither small integers, characters, nor
-booleans are all unique values --- that is, datatypes with only one
-instance.
-
address@hidden Macro SCM SCM_EOL
-The Scheme empty list object, or ``End Of List'' object, usually written
-in Scheme as @code{'()}.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_EOF_VAL
-The Scheme end-of-file value. It has no standard written
-representation, for obvious reasons.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_UNSPECIFIED
-The value returned by expressions which the Scheme standard says return
-an ``unspecified'' value.
-
-This is sort of a weirdly literal way to take things, but the standard
-read-eval-print loop prints nothing when the expression returns this
-value, so it's not a bad idea to return this when you can't think of
-anything else helpful.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_UNDEFINED
-The ``undefined'' value. Its most important property is that is not
-equal to any valid Scheme value. This is put to various internal uses
-by C code interacting with Guile.
-
-For example, when you write a C function that is callable from Scheme
-and which takes optional arguments, the interpreter passes
address@hidden for any arguments you did not receive.
-
-We also use this to mark unbound variables.
address@hidden deftypefn
-
address@hidden Macro int SCM_UNBNDP (SCM @var{x})
-Return true if @var{x} is @code{SCM_UNDEFINED}. Apply this to a
-symbol's value to see if it has a binding as a global variable.
address@hidden deftypefn
-
-
address@hidden Non-immediate Datatypes
address@hidden Non-immediate Datatypes
-
-A non-immediate datatype is one which lives in the heap, either because
-it cannot fit entirely within a @code{SCM} word, or because it denotes a
-specific storage location (in the nomenclature of the Revised^5 Report
-on Scheme).
-
-The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these
-from immediates; see @ref{Immediates vs Non-immediates}.
-
-Given a cell, Guile distinguishes between pairs and other non-immediate
-types by storing special @dfn{tag} values in a non-pair cell's car, that
-cannot appear in normal pairs. A cell with a non-tag value in its car
-is an ordinary pair. The type of a cell with a tag in its car depends
-on the tag; the non-immediate type predicates test this value. If a tag
-value appears elsewhere (in a vector, for example), the heap may become
-corrupted.
-
-Note how the type information for a non-immediate object is split
-between the @code{SCM} word and the cell that the @code{SCM} word points
-to. The @code{SCM} word itself only indicates that the object is
-non-immediate --- in other words stored in a heap cell. The tag stored
-in the first word of the heap cell indicates more precisely the type of
-that object.
-
-The type predicates for non-immediate values work correctly on any
address@hidden value; you do not need to call @code{SCM_NIMP} first, to
-establish that a value is non-immediate.
-
address@hidden
-* Pair Data::
-* Vector Data::
-* Procedures::
-* Closures::
-* Subrs::
-* Port Data::
address@hidden menu
-
-
address@hidden Pair Data
address@hidden Pairs
-
-Pairs are the essential building block of list structure in Scheme. A
-pair object has two fields, called the @dfn{car} and the @dfn{cdr}.
-
-It is conventional for a pair's @sc{car} to contain an element of a
-list, and the @sc{cdr} to point to the next pair in the list, or to
-contain @code{SCM_EOL}, indicating the end of the list. Thus, a set of
-pairs chained through their @sc{cdr}s constitutes a singly-linked list.
-Scheme and libguile define many functions which operate on lists
-constructed in this fashion, so although lists chained through the
address@hidden of pairs will work fine too, they may be less convenient to
-manipulate, and receive less support from the community.
-
-Guile implements pairs by mapping the @sc{car} and @sc{cdr} of a pair
-directly into the two words of the cell.
-
-
address@hidden Macro int SCM_CONSP (SCM @var{x})
-Return non-zero iff @var{x} is a Scheme pair object.
address@hidden deftypefn
-
address@hidden Macro int SCM_NCONSP (SCM @var{x})
-The complement of SCM_CONSP.
address@hidden deftypefn
-
address@hidden SCM scm_cons (SCM @var{car}, SCM @var{cdr})
-Allocate (``CONStruct'') a new pair, with @var{car} and @var{cdr} as its
-contents.
address@hidden deftypefun
-
-The macros below perform no type checking. The results are undefined if
address@hidden is an immediate. However, since all non-immediate Guile
-objects are constructed from cells, and these macros simply return the
-first element of a cell, they actually can be useful on datatypes other
-than pairs. (Of course, it is not very modular to use them outside of
-the code which implements that datatype.)
-
address@hidden Macro SCM SCM_CAR (SCM @var{cell})
-Return the @sc{car}, or first field, of @var{cell}.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_CDR (SCM @var{cell})
-Return the @sc{cdr}, or second field, of @var{cell}.
address@hidden deftypefn
-
address@hidden Macro void SCM_SETCAR (SCM @var{cell}, SCM @var{x})
-Set the @sc{car} of @var{cell} to @var{x}.
address@hidden deftypefn
-
address@hidden Macro void SCM_SETCDR (SCM @var{cell}, SCM @var{x})
-Set the @sc{cdr} of @var{cell} to @var{x}.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_CAAR (SCM @var{cell})
address@hidden Macro SCM SCM_CADR (SCM @var{cell})
address@hidden Macro SCM SCM_CDAR (SCM @var{cell}) @dots{}
address@hidden Macro SCM SCM_CDDDDR (SCM @var{cell})
-Return the @sc{car} of the @sc{car} of @var{cell}, the @sc{car} of the
address@hidden of @var{cell}, @i{et cetera}.
address@hidden deftypefn
-
-
address@hidden Vector Data
address@hidden Vectors, Strings, and Symbols
-
-Vectors, strings, and symbols have some properties in common. They all
-have a length, and they all have an array of elements. In the case of a
-vector, the elements are @code{SCM} values; in the case of a string or
-symbol, the elements are characters.
-
-All these types store their length (along with some tagging bits) in the
address@hidden of their header cell, and store a pointer to the elements in
-their @sc{cdr}. Thus, the @code{SCM_CAR} and @code{SCM_CDR} macros
-are (somewhat) meaningful when applied to these datatypes.
-
address@hidden Macro int SCM_VECTORP (SCM @var{x})
-Return non-zero iff @var{x} is a vector.
address@hidden deftypefn
-
address@hidden Macro int SCM_STRINGP (SCM @var{x})
-Return non-zero iff @var{x} is a string.
address@hidden deftypefn
-
address@hidden Macro int SCM_SYMBOLP (SCM @var{x})
-Return non-zero iff @var{x} is a symbol.
address@hidden deftypefn
-
address@hidden Macro int SCM_VECTOR_LENGTH (SCM @var{x})
address@hidden Macro int SCM_STRING_LENGTH (SCM @var{x})
address@hidden Macro int SCM_SYMBOL_LENGTH (SCM @var{x})
-Return the length of the object @var{x}. The result is undefined if
address@hidden is not a vector, string, or symbol, respectively.
address@hidden deftypefn
-
address@hidden Macro {SCM *} SCM_VECTOR_BASE (SCM @var{x})
-Return a pointer to the array of elements of the vector @var{x}.
-The result is undefined if @var{x} is not a vector.
address@hidden deftypefn
-
address@hidden Macro {char *} SCM_STRING_CHARS (SCM @var{x})
address@hidden Macro {char *} SCM_SYMBOL_CHARS (SCM @var{x})
-Return a pointer to the characters of @var{x}. The result is undefined
-if @var{x} is not a symbol or string, respectively.
address@hidden deftypefn
-
-There are also a few magic values stuffed into memory before a symbol's
-characters, but you don't want to know about those. What cruft!
-
-Note that @code{SCM_VECTOR_BASE}, @code{SCM_STRING_CHARS} and
address@hidden return pointers to data within the respective
-object. Care must be taken that the object is not garbage collected
-while that data is still being accessed. This is the same as for a
-smob, @xref{Remembering During Operations}.
-
-
address@hidden Procedures
address@hidden Procedures
-
-Guile provides two kinds of procedures: @dfn{closures}, which are the
-result of evaluating a @code{lambda} expression, and @dfn{subrs}, which
-are C functions packaged up as Scheme objects, to make them available to
-Scheme programmers.
-
-(There are actually other sorts of procedures: compiled closures, and
-continuations; see the source code for details about them.)
-
address@hidden SCM scm_procedure_p (SCM @var{x})
-Return @code{SCM_BOOL_T} iff @var{x} is a Scheme procedure object, of
-any sort. Otherwise, return @code{SCM_BOOL_F}.
address@hidden deftypefun
-
-
address@hidden Closures
address@hidden Closures
-
-[FIXME: this needs to be further subbed, but texinfo has no subsubsub]
-
-A closure is a procedure object, generated as the value of a
address@hidden expression in Scheme. The representation of a closure is
-straightforward --- it contains a pointer to the code of the lambda
-expression from which it was created, and a pointer to the environment
-it closes over.
-
-In Guile, each closure also has a property list, allowing the system to
-store information about the closure. I'm not sure what this is used for
-at the moment --- the debugger, maybe?
-
address@hidden Macro int SCM_CLOSUREP (SCM @var{x})
-Return non-zero iff @var{x} is a closure.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_PROCPROPS (SCM @var{x})
-Return the property list of the closure @var{x}. The results are
-undefined if @var{x} is not a closure.
address@hidden deftypefn
-
address@hidden Macro void SCM_SETPROCPROPS (SCM @var{x}, SCM @var{p})
-Set the property list of the closure @var{x} to @var{p}. The results
-are undefined if @var{x} is not a closure.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_CODE (SCM @var{x})
-Return the code of the closure @var{x}. The result is undefined if
address@hidden is not a closure.
-
-This function should probably only be used internally by the
-interpreter, since the representation of the code is intimately
-connected with the interpreter's implementation.
address@hidden deftypefn
-
address@hidden Macro SCM SCM_ENV (SCM @var{x})
-Return the environment enclosed by @var{x}.
-The result is undefined if @var{x} is not a closure.
-
-This function should probably only be used internally by the
-interpreter, since the representation of the environment is intimately
-connected with the interpreter's implementation.
address@hidden deftypefn
-
-
address@hidden Subrs
address@hidden Subrs
-
-[FIXME: this needs to be further subbed, but texinfo has no subsubsub]
-
-A subr is a pointer to a C function, packaged up as a Scheme object to
-make it callable by Scheme code. In addition to the function pointer,
-the subr also contains a pointer to the name of the function, and
-information about the number of arguments accepted by the C function, for
-the sake of error checking.
-
-There is no single type predicate macro that recognizes subrs, as
-distinct from other kinds of procedures. The closest thing is
address@hidden; see @ref{Procedures}.
-
address@hidden Macro {char *} SCM_SNAME (@var{x})
-Return the name of the subr @var{x}. The result is undefined if
address@hidden is not a subr.
address@hidden deftypefn
-
address@hidden SCM scm_c_define_gsubr (char address@hidden, int @var{req}, int
@var{opt}, int @var{rest}, SCM (address@hidden)())
-Create a new subr object named @var{name}, based on the C function
address@hidden, make it visible to Scheme the value of as a global
-variable named @var{name}, and return the subr object.
-
-The subr object accepts @var{req} required arguments, @var{opt} optional
-arguments, and a @var{rest} argument iff @var{rest} is non-zero. The C
-function @var{function} should accept @address@hidden + @var{opt}}
-arguments, or @address@hidden + @var{opt} + 1} arguments if @code{rest}
-is non-zero.
-
-When a subr object is applied, it must be applied to at least @var{req}
-arguments, or else Guile signals an error. @var{function} receives the
-subr's first @var{req} arguments as its first @var{req} arguments. If
-there are fewer than @var{opt} arguments remaining, then @var{function}
-receives the value @code{SCM_UNDEFINED} for any missing optional
-arguments.
-
-If @var{rst} is non-zero, then any arguments after the first
address@hidden@var{req} + @var{opt}} are packaged up as a list and passed as
address@hidden's last argument. @var{function} must not modify that
-list. (Because when subr is called through @code{apply} the list is
-directly from the @code{apply} argument, which the caller will expect
-to be unchanged.)
-
-Note that subrs can actually only accept a predefined set of
-combinations of required, optional, and rest arguments. For example, a
-subr can take one required argument, or one required and one optional
-argument, but a subr can't take one required and two optional arguments.
-It's bizarre, but that's the way the interpreter was written. If the
-arguments to @code{scm_c_define_gsubr} do not fit one of the predefined
-patterns, then @code{scm_c_define_gsubr} will return a compiled closure
-object instead of a subr object.
address@hidden deftypefun
-
-
address@hidden Port Data
address@hidden Ports
-
-Haven't written this yet, 'cos I don't understand ports yet.
-
-
address@hidden Signalling Type Errors
address@hidden Signalling Type Errors
-
-Every function visible at the Scheme level should aggressively check the
-types of its arguments, to avoid misinterpreting a value, and perhaps
-causing a segmentation fault. Guile provides some macros to make this
-easier.
-
address@hidden Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, unsigned
int @var{position}, const char address@hidden)
-If @var{test} is zero, signal a ``wrong type argument'' error,
-attributed to the subroutine named @var{subr}, operating on the value
address@hidden, which is the @var{position}'th argument of @var{subr}.
address@hidden deftypefn
-
address@hidden Macro int SCM_ARG1
address@hidden Macro int SCM_ARG2
address@hidden Macro int SCM_ARG3
address@hidden Macro int SCM_ARG4
address@hidden Macro int SCM_ARG5
address@hidden Macro int SCM_ARG6
address@hidden Macro int SCM_ARG7
-One of the above values can be used for @var{position} to indicate the
-number of the argument of @var{subr} which is being checked.
-Alternatively, a positive integer number can be used, which allows to
-check arguments after the seventh. However, for parameter numbers up to
-seven it is preferable to use @code{SCM_ARGN} instead of the
-corresponding raw number, since it will make the code easier to
-understand.
address@hidden deftypefn
-
address@hidden Macro int SCM_ARGn
-Passing a value of zero or @code{SCM_ARGn} for @var{position} allows to
-leave it unspecified which argument's type is incorrect. Again,
address@hidden should be preferred over a raw zero constant.
address@hidden deftypefn
-
-
address@hidden Unpacking the SCM type
address@hidden Unpacking the SCM Type
-
-The previous sections have explained how @code{SCM} values can refer to
-immediate and non-immediate Scheme objects. For immediate objects, the
-complete object value is stored in the @code{SCM} word itself, while for
-non-immediates, the @code{SCM} word contains a pointer to a heap cell,
-and further information about the object in question is stored in that
-cell. This section describes how the @code{SCM} type is actually
-represented and used at the C level.
-
In fact, there are two basic C data types to represent objects in
Guile: @code{SCM} and @code{scm_t_bits}.
@@ -931,7 +374,6 @@ Guile: @code{SCM} and @code{scm_t_bits}.
* Allocating Cells::
* Heap Cell Type Information::
* Accessing Cell Entries::
-* Basic Rules for Accessing Cell Entries::
@end menu
@@ -986,6 +428,48 @@ If so, all of the type and value information can be
determined from the
(@var{x})}.
@end itemize
+There are a number of special values in Scheme, most of them documented
+elsewhere in this manual. It's not quite the right place to put them,
+but for now, here's a list of the C names given to some of these values:
+
address@hidden Macro SCM SCM_EOL
+The Scheme empty list object, or ``End Of List'' object, usually written
+in Scheme as @code{'()}.
address@hidden deftypefn
+
address@hidden Macro SCM SCM_EOF_VAL
+The Scheme end-of-file value. It has no standard written
+representation, for obvious reasons.
address@hidden deftypefn
+
address@hidden Macro SCM SCM_UNSPECIFIED
+The value returned by expressions which the Scheme standard says return
+an ``unspecified'' value.
+
+This is sort of a weirdly literal way to take things, but the standard
+read-eval-print loop prints nothing when the expression returns this
+value, so it's not a bad idea to return this when you can't think of
+anything else helpful.
address@hidden deftypefn
+
address@hidden Macro SCM SCM_UNDEFINED
+The ``undefined'' value. Its most important property is that is not
+equal to any valid Scheme value. This is put to various internal uses
+by C code interacting with Guile.
+
+For example, when you write a C function that is callable from Scheme
+and which takes optional arguments, the interpreter passes
address@hidden for any arguments you did not receive.
+
+We also use this to mark unbound variables.
address@hidden deftypefn
+
address@hidden Macro int SCM_UNBNDP (SCM @var{x})
+Return true if @var{x} is @code{SCM_UNDEFINED}. Note that this is not a
+check to see if @var{x} is @code{SCM_UNBOUND}. History will not be kind
+to us.
address@hidden deftypefn
+
@node Non-immediate objects
@subsubsection Non-immediate objects
@@ -1187,31 +671,6 @@ entries.
@end itemize
address@hidden Basic Rules for Accessing Cell Entries
address@hidden Basic Rules for Accessing Cell Entries
-
-For each cell type it is generally up to the implementation of that type
-which of the corresponding cell entries hold Scheme objects and which
-hold raw C values. However, there is one basic rule that has to be
-followed: Scheme pairs consist of exactly two cell entries, which both
-contain Scheme objects. Further, a cell which contains a Scheme object
-in it first entry has to be a Scheme pair. In other words, it is not
-allowed to store a Scheme object in the first cell entry and a non
-Scheme object in the second cell entry.
-
address@hidden Fixme:shouldn't this rather be SCM_PAIRP / SCM_PAIR_P ?
address@hidden Macro int SCM_CONSP (SCM @var{x})
-Determine, whether the Scheme object @var{x} is a Scheme pair,
-i.e. whether @var{x} references a heap cell consisting of exactly two
-entries, where both entries contain a Scheme object. In this case, both
-entries will have to be accessed using the @code{SCM_CELL_OBJECT}
-macros. On the contrary, if the @code{SCM_CONSP} predicate is not
-fulfilled, the first entry of the Scheme cell is guaranteed not to be a
-Scheme value and thus the first cell entry must be accessed using the
address@hidden macro.
address@hidden deftypefn
-
-
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 0438e24..60d1ea5 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -13,7 +13,7 @@
@copying
This manual documents Guile version @value{VERSION}.
-Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009 Free
+Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009, 2010 Free
Software Foundation.
Permission is granted to copy, distribute and/or modify this document
@@ -175,6 +175,7 @@ x
* API Reference::
* Guile Modules::
+* Standard Library::
* GOOPS::
@@ -253,13 +254,10 @@ musings and guidelines about programming with Guile. It
explores
different ways to design a program around Guile, or how to embed Guile
into existing programs.
-There is also a pedagogical yet detailed explanation of how the data
-representation of Guile is implemented, see @ref{Data Representation in
-Scheme} and @ref{The Libguile Runtime Environment}.
-
-You don't need to know the details given there to use Guile from C,
-but they are useful when you want to modify Guile itself or when you
-are just curious about how it is all done.
+For a pedagogical yet detailed explanation of how the data representation of
+Guile is implemented, @xref{Data Representation}. You don't need to know the
+details given there to use Guile from C, but they are useful when you want to
+modify Guile itself or when you are just curious about how it is all done.
For detailed reference information on the variables, functions
etc. that make up Guile's application programming interface (API),
@@ -298,15 +296,18 @@ available through both Scheme and C interfaces.
* Simple Data Types:: Numbers, strings, booleans and so on.
* Compound Data Types:: Data types for holding other data.
* Smobs:: Defining new data types in C.
-* Procedures and Macros:: Procedures and macros.
+* Procedures:: Procedures.
+* Macros:: Extending the syntax of Scheme.
* Utility Functions:: General utility functions.
* Binding Constructs:: Definitions and variable bindings.
* Control Mechanisms:: Controlling the flow of program execution.
* Input and Output:: Ports, reading and writing.
+* LALR(1) Parsing:: Generating LALR(1) parsers.
* Read/Load/Eval/Compile:: Reading and evaluating Scheme code.
* Memory Management:: Memory management and garbage collection.
* Objects:: Low level object orientation support.
* Modules:: Designing reusable code libraries.
+* Foreign Function Interface:: Interacting with C procedures and data.
* Scheduling:: Threads, mutexes, asyncs and dynamic roots.
* Options and Config:: Configuration, features and runtime options.
* Translation:: Support for translating other languages.
@@ -323,13 +324,16 @@ available through both Scheme and C interfaces.
@include api-compound.texi
@include api-smobs.texi
@include api-procedures.texi
address@hidden api-macros.texi
@include api-utility.texi
@include api-binding.texi
@include api-control.texi
@include api-io.texi
address@hidden api-lalr.texi
@include api-evaluation.texi
@include api-memory.texi
@include api-modules.texi
address@hidden api-foreign.texi
@include api-scheduling.texi
@c object orientation support here
@include api-options.texi
@@ -368,6 +372,13 @@ available through both Scheme and C interfaces.
@include scsh.texi
@include scheme-debugging.texi
address@hidden Standard Library
address@hidden Standard Library
+
address@hidden
address@hidden standard-library.texi
address@hidden
+
@include goops.texi
@node Guile Implementation
@@ -393,13 +404,10 @@ This knowledge can help you to make that step from being
one who is
merely familiar with Scheme to being a real hacker.
@menu
-* History:: A brief history of Guile.
-* Data Representation in Scheme:: Why things aren't just totally
- straightforward, in general terms.
-* The Libguile Runtime Environment:: Low-level details on Guile's C
- runtime library.
-* A Virtual Machine for Guile:: How compiled procedures work.
-* Compiling to the Virtual Machine:: Not as hard as you might think.
+* History:: A brief history of Guile.
+* Data Representation:: How Guile represents Scheme data.
+* A Virtual Machine for Guile:: How compiled procedures work.
+* Compiling to the Virtual Machine:: Not as hard as you might think.
@end menu
@include history.texi
diff --git a/doc/ref/history.texi b/doc/ref/history.texi
index 7454cfe..f1109b2 100644
--- a/doc/ref/history.texi
+++ b/doc/ref/history.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2008
address@hidden Copyright (C) 2008, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -134,7 +134,8 @@ Since then, Guile has had a group maintainership. The first
group was
Maciej Stachowiak, Mikael Djurfeldt, and Marius Vollmer, with Vollmer
staying on the longest. By late 2007, Vollmer had mostly moved on to
other things, so Neil Jerram and Ludovic Courtès stepped up to take on
-the primary maintenance responsibility.
+the primary maintenance responsibility. Jerram and Courtès were joined
+by Andy Wingo in late 2009.
Of course, a large part of the actual work on Guile has come from
other contributors too numerous to mention, but without whom the world
@@ -167,18 +168,17 @@ less the same form.
@itemx 1.2 --- 24 June 1997
Support for Tcl/Tk and ctax were split off as separate packages, and
have remained there since. Guile became more compatible with SCSH, and
-more useful as a UNIX scripting language. Libguile can now be built as
+more useful as a UNIX scripting language. Libguile could now be built as
a shared library, and third-party extensions written in C became
loadable via dynamic linking.
@item 1.3.0 --- 19 October 1998
Command-line editing became much more pleasant through the use of the
readline library. The initial support for internationalization via
-multi-byte strings was removed, and has yet to be added back, though
-UTF-8 hacks are common. Modules gained the ability to have custom
-expanders, which is still used for syntax-case macros. Initial Emacs
-Lisp support landed, ports gained better support for file descriptors,
-and fluids were added.
+multi-byte strings was removed; 10 years were to pass before proper
+internationalization would land again. Initial Emacs Lisp support
+landed, ports gained better support for file descriptors, and fluids
+were added.
@item 1.3.2 --- 20 August 1999
@itemx 1.3.4 --- 25 September 1999
@@ -186,8 +186,8 @@ and fluids were added.
A long list of lispy features were added: hooks, Common Lisp's
@code{format}, optional and keyword procedure arguments,
@code{getopt-long}, sorting, random numbers, and many other fixes and
-enhancements. Guile now has an interactive debugger, interactive help,
-and gives better backtraces.
+enhancements. Guile also gained an interactive debugger, interactive
+help, and better backtraces.
@item 1.6 --- 6 September 2002
Guile gained support for the R5RS standard, and added a number of SRFI
@@ -202,12 +202,15 @@ user-space threading was removed in favor of POSIX
pre-emptive
threads, providing true multiprocessing. Gettext support was added,
and Guile's C API was cleaned up and orthogonalized in a massive way.
address@hidden 2.0 --- thus far, only unstable snapshots available
-A virtual machine was added to Guile, along with the associated
-compiler and toolchain. Support for internationalization was added.
-Running Guile instances became controllable and debuggable from within
-Emacs, via GDS, which was also backported to 1.8.5. An SRFI-18
-interface to multithreading was added, including thread cancellation.
address@hidden 2.0 --- April 2010
+A virtual machine was added to Guile, along with the associated compiler
+and toolchain. Support for internationalization was finally
+reimplemented, in terms of unicode, locales, and libunistring. Running
+Guile instances became controllable and debuggable from within Emacs,
+via GDS and Geiser. Guile caught up to features found in a number of
+other Schemes: SRFI-18 threads, including thread cancellation,
+module-hygienic macros, a profiler, tracer, and debugger, SSAX XML
+integration, bytevectors, module versions, and partial support for R6RS.
@end table
@node Status
@@ -267,12 +270,12 @@ language with a syntax that is closer to C, or to Python.
Another
interesting idea to consider is compiling e.g. Python to Guile. It's
not that far-fetched of an idea: see for example IronPython or JRuby.
-And then there's Emacs itself. Though there is a somewhat-working
-Emacs Lisp translator for Guile, it cannot yet execute all of Emacs
-Lisp. A serious integration of Guile with Emacs would replace the
-Elisp virtual machine with Guile, and provide the necessary C shims so
-that Guile could emulate Emacs' C API. This would give lots of
-exciting things to Emacs: native threads, a real object system, more
+And then there's Emacs itself. Though there is a somewhat-working Emacs
+Lisp language frontend for Guile, it cannot yet execute all of Emacs
+Lisp. A serious integration of Guile with Emacs would replace the Elisp
+virtual machine with Guile, and provide the necessary C shims so that
+Guile could emulate Emacs' C API. This would give lots of exciting
+things to Emacs: native threads, a real object system, more
sophisticated types, cleaner syntax, and access to all of the Guile
extensions.
diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi
index c91aacb..3301ded 100644
--- a/doc/ref/intro.texi
+++ b/doc/ref/intro.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, 2006
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -302,7 +302,8 @@ When Guile is correctly installed on your system, the above
program
can be compiled and linked like this:
@example
-$ gcc -o simple-guile simple-guile.c -lguile
+$ gcc -o simple-guile simple-guile.c \
+ `pkg-config --cflags --libs guile-2.0`
@end example
When it is run, it behaves just like the @code{guile} program except
diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi
index f0471c2..1e4cb1e 100644
--- a/doc/ref/libguile-concepts.texi
+++ b/doc/ref/libguile-concepts.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, 2005
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -152,8 +152,8 @@ that have been added to Guile by third-party libraries.
Also, computing with @code{SCM} is not necessarily inefficient. Small
integers will be encoded directly in the @code{SCM} value, for example,
-and do not need any additional memory on the heap. See @ref{The
-Libguile Runtime Environment} to find out the details.
+and do not need any additional memory on the heap. See @ref{Data
+Representation} to find out the details.
Some special @code{SCM} values are available to C code without needing
to convert them from C values:
@@ -169,9 +169,8 @@ In addition to @code{SCM}, Guile also defines the related
type
@code{scm_t_bits}. This is an unsigned integral type of sufficient
size to hold all information that is directly contained in a
@code{SCM} value. The @code{scm_t_bits} type is used internally by
-Guile to do all the bit twiddling explained in @ref{The Libguile
-Runtime Environment}, but you will encounter it occasionally in low-level
-user code as well.
+Guile to do all the bit twiddling explained in @ref{Data Representation}, but
+you will encounter it occasionally in low-level user code as well.
@node Garbage Collection
@@ -450,21 +449,15 @@ that are stored in local variables. When a thread puts
itself into
guile mode for the first time, it gets a Scheme representation and is
listed by @code{all-threads}, for example.
-While in guile mode, a thread promises to reach a safe point
-reasonably frequently (@pxref{Asynchronous Signals}). In addition to
-running signal handlers, these points are also potential rendezvous
-points of all guile mode threads where Guile can orchestrate global
-things like garbage collection. Consequently, when a thread in guile
-mode blocks and does no longer frequent safe points, it might cause
-all other guile mode threads to block as well. To prevent this from
-happening, a guile mode thread should either only block in libguile
-functions (who know how to do it right), or should temporarily leave
-guile mode with @code{scm_without_guile}.
-
-For some common blocking operations, Guile provides convenience
-functions. For example, if you want to lock a pthread mutex while in
-guile mode, you might want to use @code{scm_pthread_mutex_lock} which is
-just like @code{pthread_mutex_lock} except that it leaves guile mode
+Threads in guile mode can block (e.g., do blocking I/O) without causing any
address@hidden Guile 1.8, a thread blocking in guile mode would prevent
+garbage collection to occur. Thus, threads had to leave guile mode whenever
+they could block. This is no longer needed with Guile 2.0.}; temporarily
+leaving guile mode with @code{scm_without_guile} before blocking slightly
+improves GC performance, though. For some common blocking operations, Guile
+provides convenience functions. For example, if you want to lock a pthread
+mutex while in guile mode, you might want to use @code{scm_pthread_mutex_lock}
+which is just like @code{pthread_mutex_lock} except that it leaves guile mode
while blocking.
diff --git a/doc/ref/libguile-linking.texi b/doc/ref/libguile-linking.texi
index 78a93e6..b6a8855 100644
--- a/doc/ref/libguile-linking.texi
+++ b/doc/ref/libguile-linking.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, 2005
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -174,9 +174,7 @@ checking for Guile... yes
creating ./config.status
creating Makefile
$ make
-gcc -c -I/usr/local/include simple-guile.c
-gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm
- -o simple-guile
+[...]
$ ./simple-guile
guile> (+ 1 2 3)
6
diff --git a/doc/ref/libguile-smobs.texi b/doc/ref/libguile-smobs.texi
index 213312c..c6581a1 100644
--- a/doc/ref/libguile-smobs.texi
+++ b/doc/ref/libguile-smobs.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, 2005
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -69,8 +69,7 @@ function is allowed to do.
Guile will apply this function to each instance of the new type to print
the value, as for @code{display} or @code{write}. The default print
function prints @code{#<NAME ADDRESS>} where @code{NAME} is the first
-argument passed to @code{scm_make_smob_type}. For more information on
-printing, see @ref{Port Data}.
+argument passed to @code{scm_make_smob_type}.
@item equalp
If Scheme code asks the @code{equal?} function to compare two instances
@@ -521,7 +520,7 @@ Smobs are called smob because they are small: they normally
have only
room for one @code{void*} or @code{SCM} value plus 16 bits. The
reason for this is that smobs are directly implemented by using the
low-level, two-word cells of Guile that are also used to implement
-pairs, for example. (@pxref{The Libguile Runtime Environment} for the
+pairs, for example. (@pxref{Data Representation} for the
details.) One word of the two-word cells is used for
@code{SCM_SMOB_DATA} (or @code{SCM_SMOB_OBJECT}), the other contains
the 16-bit type tag and the 16 extra bits.
diff --git a/doc/ref/make-texinfo.scm b/doc/ref/make-texinfo.scm
new file mode 100644
index 0000000..c967bc1
--- /dev/null
+++ b/doc/ref/make-texinfo.scm
@@ -0,0 +1,28 @@
+;; make-texinfo.scm -- document a set of scheme modules as texinfo
+;; Copyright (C) 2006,2007,2009 Andy Wingo <wingo at pobox dot com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (texinfo reflection)
+ (texinfo serialize))
+
+(define (main config-scm)
+ (load config-scm)
+ (display
+ (stexi->texi
+ (package-stexi-documentation-for-include
+ (map car *modules*)
+ (map cdr *modules*)))))
+
+(apply main (cdr (command-line)))
diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index b56bcff..6cd0ad2 100644
--- a/doc/ref/misc-modules.texi
+++ b/doc/ref/misc-modules.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, 2006
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -15,7 +15,7 @@ The module @code{(ice-9 pretty-print)} provides the procedure
objects. This is especially useful for deeply nested or complex data
structures, such as lists and vectors.
-The module is loaded by simply saying.
+The module is loaded by entering the following:
@lisp
(use-modules (ice-9 pretty-print))
@@ -59,6 +59,67 @@ Print within the given @var{columns}. The default is 79.
@end deffn
address@hidden truncated printing
+Also exported by the @code{(ice-9 pretty-print)} module is
address@hidden, a procedure to print Scheme datums, truncating
+the output to a certain number of characters. This is useful when you
+need to present an arbitrary datum to the user, but you only have one
+line in which to do so.
+
address@hidden
+(define exp '(a b #(c d e) f . g))
+(truncated-print exp #:width 10) (newline)
address@hidden (a b . #)
+(truncated-print exp #:width 15) (newline)
address@hidden (a b # f . g)
+(truncated-print exp #:width 18) (newline)
address@hidden (a b #(c ...) . #)
+(truncated-print exp #:width 20) (newline)
address@hidden (a b #(c d e) f . g)
+(truncated-print "The quick brown fox" #:width 20) (newline)
address@hidden "The quick brown..."
+(truncated-print (current-module) #:width 20) (newline)
address@hidden #<directory (gui...>
address@hidden lisp
+
address@hidden will not output a trailing newline. If an expression does
+not fit in the given width, it will be truncated -- possibly
address@hidden Unicode-capable ports, the ellipsis is represented by
+character `HORIZONTAL ELLIPSIS' (U+2026), otherwise it is represented by three
+dots.}, or in the worst case, displayed as @nicode{#}.
+
address@hidden {Scheme Procedure} truncated-print obj [port] [keyword-options]
+Print @var{obj}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
address@hidden, though that behavior can be overriden via the
address@hidden keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expressoin of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+``ration'' the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument.
+
+The further @var{keyword-options} are keywords and parameters as
+follows,
+
address@hidden @asis
address@hidden @nicode{#:display?} @var{flag}
+If @var{flag} is true then print using @code{display}. The default is
address@hidden which means use @code{write} style. (@pxref{Writing})
+
address@hidden @nicode{#:width} @var{columns}
+Print within the given @var{columns}. The default is 79.
+
address@hidden @nicode{#:breadth-first?} @var{flag}
+If @var{flag} is true, then allocate the available width breadth-first
+among elements of a compound data structure (list, vector, pair,
+etc.). The default is @code{#f} which means that any element is
+allowed to consume all of the available width.
address@hidden table
address@hidden deffn
+
+
@node Formatted Output
@section Formatted Output
@cindex formatted output
@@ -575,9 +636,22 @@ to help. When using @code{gettext} to translate messages
(@pxref{Internationalization}).
@item @nicode{~y}
-Pretty print. No parameters.
-
-Output an argument with @code{pretty-print} (@pxref{Pretty Printing}).
+Structured printing. Parameters: @var{width}.
+
address@hidden outputs an argument using @code{pretty-print}
+(@pxref{Pretty Printing}). The result will be formatted to fit within
address@hidden columns (79 by default), consuming multiple lines if
+necessary.
+
address@hidden@@y} outputs an argument using @code{truncated-print}
+(@pxref{Pretty Printing}). The resulting code will be formatted to fit
+within @var{width} columns (79 by default), on a single line. The
+output will be truncated if necessary.
+
address@hidden:@@y} is like @nicode{~@@y}, except the @var{width} parameter
+is interpreted to be the maximum column to which to output. That is to
+say, if you are at column 10, and @nicode{~60:@@y} is seen, the datum
+will be truncated to 50 columns.
@item @nicode{~?}
@itemx @nicode{~k}
diff --git a/doc/ref/new-docstrings.texi b/doc/ref/new-docstrings.texi
index c8f16a3..65dda6e 100644
--- a/doc/ref/new-docstrings.texi
+++ b/doc/ref/new-docstrings.texi
@@ -1,3 +1,274 @@
@c module-for-docstring (guile)
+
address@hidden {Scheme Procedure} uniform-array->bytevector array
address@hidden {C Function} scm_uniform_array_to_bytevector (array)
+Return a newly allocated bytevector whose contents
+will be copied from the uniform array @var{array}.
address@hidden deffn
+
address@hidden {Scheme Procedure} %start-stack id thunk
address@hidden {C Function} scm_sys_start_stack (id, thunk)
+Call @var{thunk} on an evaluator stack tagged with @var{id}.
address@hidden deffn
+
address@hidden {Scheme Procedure} guardian-destroyed? guardian
address@hidden {C Function} scm_guardian_destroyed_p (guardian)
+Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.
address@hidden deffn
+
address@hidden {Scheme Procedure} guardian-greedy? guardian
address@hidden {C Function} scm_guardian_greedy_p (guardian)
+Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.
address@hidden deffn
+
address@hidden {Scheme Procedure} destroy-guardian! guardian
address@hidden {C Function} scm_destroy_guardian_x (guardian)
+Destroys @var{guardian}, by making it impossible to put any more
+objects in it or get any objects from it. It also unguards any
+objects guarded by @var{guardian}.
address@hidden deffn
+
address@hidden {Scheme Procedure} gc-dump
address@hidden {C Function} scm_gc_dump ()
+Dump information about the garbage collector's internal data structures and
memory usage to the standard output.
address@hidden deffn
+
address@hidden {Scheme Procedure} gc-disable
address@hidden {C Function} scm_gc_disable ()
+Disables the garbage collector. Nested calls are permitted. GC is re-enabled
once @code{gc-enable} has been called the same number of times
@code{gc-disable} was called.
address@hidden deffn
+
address@hidden {Scheme Procedure} gc-enable
address@hidden {C Function} scm_gc_enable ()
+Enables the garbage collector.
address@hidden deffn
+
address@hidden {Scheme Procedure} make-generalized-vector type len [fill]
address@hidden {C Function} scm_make_generalized_vector (type, len, fill)
+Make a generalized vector
address@hidden deffn
+
address@hidden {Scheme Procedure} set-primitive-generic! subr generic
address@hidden {C Function} scm_set_primitive_generic_x (subr, generic)
+
address@hidden deffn
+
address@hidden {Scheme Procedure} nl-langinfo item [locale]
address@hidden {C Function} scm_nl_langinfo (item, locale)
+Return a string denoting locale information for @var{item} in the current
locale or that specified by @var{locale}. The semantics and arguments are the
same as those of the X/Open @code{nl_langinfo} function (@pxref{The Elegant and
Fast Way, @code{nl_langinfo},, libc, The GNU C Library Reference Manual}).
address@hidden deffn
+
address@hidden {Scheme Procedure} %warn-autocompilation-enabled
address@hidden {C Function} scm_sys_warn_autocompilation_enabled ()
+
address@hidden deffn
+
address@hidden {Scheme Procedure} make-syncase-macro type binding
address@hidden {C Function} scm_make_syncase_macro (type, binding)
+Return a @dfn{macro} that requires expansion by syntax-case.
+While users should not call this function, it is useful to know
+that syntax-case macros are represented as Guile primitive macros.
address@hidden deffn
+
address@hidden {Scheme Procedure} make-extended-syncase-macro m type binding
address@hidden {C Function} scm_make_extended_syncase_macro (m, type, binding)
+Extend a core macro @var{m} with a syntax-case binding.
address@hidden deffn
+
address@hidden {Scheme Procedure} syncase-macro-type m
address@hidden {C Function} scm_syncase_macro_type (m)
+Return the type of the macro @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} syncase-macro-binding m
address@hidden {C Function} scm_syncase_macro_binding (m)
+Return the binding of the macro @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} memoize-expression exp
address@hidden {C Function} scm_memoize_expression (exp)
+Memoize the expression @var{exp}.
address@hidden deffn
+
address@hidden {Scheme Procedure} unmemoize-expression m
address@hidden {C Function} scm_unmemoize_expression (m)
+Unmemoize the memoized expression @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} memoized-expression-typecode m
address@hidden {C Function} scm_memoized_expression_typecode (m)
+Return the typecode from the memoized expression @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} memoized-expression-data m
address@hidden {C Function} scm_memoized_expression_data (m)
+Return the data from the memoized expression @var{m}.
address@hidden deffn
+
address@hidden {Scheme Procedure} memoized-typecode sym
address@hidden {C Function} scm_memoized_typecode (sym)
+Return the memoized typecode corresponding to the symbol @var{sym}.
address@hidden deffn
+
address@hidden {Scheme Procedure} memoize-variable-access! m mod
address@hidden {C Function} scm_memoize_variable_access_x (m, mod)
+Look up and cache the variable that @var{m} will access, returning the
variable.
address@hidden deffn
+
address@hidden {Scheme Procedure} module-local-variable module sym
address@hidden {C Function} scm_module_local_variable (module, sym)
+Return the variable bound to @var{sym} in @var{module}. Return @code{#f} is
@var{sym} is not bound locally in @var{module}.
address@hidden deffn
+
address@hidden {Scheme Procedure} module-variable module sym
address@hidden {C Function} scm_module_variable (module, sym)
+Return the variable bound to @var{sym} in @var{module}. This may be both a
local variable or an imported variable. Return @code{#f} is @var{sym} is not
bound in @var{module}.
address@hidden deffn
+
address@hidden {Scheme Procedure} eval-closure-module eval_closure
address@hidden {C Function} scm_eval_closure_module (eval_closure)
+Return the module associated with this eval closure.
address@hidden deffn
+
address@hidden {Scheme Procedure} module-transformer module
address@hidden {C Function} scm_module_transformer (module)
+Returns the syntax expander for the given module.
address@hidden deffn
+
address@hidden {Scheme Procedure} module-public-interface module
address@hidden {C Function} scm_module_public_interface (module)
+Return the public interface of @var{module}.
+
+If @var{module} has no public interface, @code{#f} is returned.
address@hidden deffn
+
address@hidden {Scheme Procedure} define! sym value
address@hidden {C Function} scm_define (sym, value)
+Define @var{sym} to be @var{value} in the current module.Returns the variable
itself. Note that this is a procedure, not a macro.
address@hidden deffn
+
address@hidden {Scheme Procedure} module-reverse-lookup module variable
address@hidden {C Function} scm_module_reverse_lookup (module, variable)
+Return the symbol under which @var{variable} is bound in @var{module} or
@var{#f} if @var{variable} is not visible from @var{module}. If @var{module}
is @code{#f}, then the pre-module obarray is used.
address@hidden deffn
+
address@hidden {Scheme Procedure} cddr x
address@hidden {C Function} scm_cddr (x)
+
address@hidden deffn
+
address@hidden {Scheme Procedure} make-promise thunk
address@hidden {C Function} scm_make_promise (thunk)
+Create a new promise object.
+
address@hidden is a procedural form of @code{delay}.
+These two expressions are equivalent:
address@hidden
+(delay @var{exp})
+(make-promise (lambda () @var{exp}))
address@hidden lisp
+
address@hidden deffn
+
address@hidden {Scheme Procedure} %get-stack-size
address@hidden {C Function} scm_sys_get_stack_size ()
+Return the current thread's C stack size (in Scheme objects).
address@hidden deffn
+
address@hidden {Scheme Procedure} %string-dump str
address@hidden {C Function} scm_sys_string_dump (str)
+Returns an association list containing debugging information
+for @var{str}. The association list has the following address@hidden @code
address@hidden string
+The string itself.
address@hidden start
+The start index of the string into its stringbuf
address@hidden length
+The length of the string
address@hidden shared
+If this string is a substring, it returns its parent string.
+Otherwise, it returns @code{#f}
address@hidden read-only
address@hidden if the string is read-only
address@hidden stringbuf-chars
+A new string containing this string's stringbuf's characters
address@hidden stringbuf-length
+The number of characters in this stringbuf
address@hidden stringbuf-shared
address@hidden if this stringbuf is shared
address@hidden stringbuf-wide
address@hidden if this stringbuf's characters are stored in a
+32-bit buffer, or @code{#f} if they are stored in an 8-bit
+buffer
address@hidden table
address@hidden deffn
+
address@hidden {Scheme Procedure} %symbol-dump sym
address@hidden {C Function} scm_sys_symbol_dump (sym)
+Returns an association list containing debugging information
+for @var{sym}. The association list has the following address@hidden @code
address@hidden symbol
+The symbol itself
address@hidden hash
+Its hash value
address@hidden interned
address@hidden if it is an interned symbol
address@hidden stringbuf-chars
+A new string containing this symbols's stringbuf's characters
address@hidden stringbuf-length
+The number of characters in this stringbuf
address@hidden stringbuf-shared
address@hidden if this stringbuf is shared
address@hidden stringbuf-wide
address@hidden if this stringbuf's characters are stored in a
+32-bit buffer, or @code{#f} if they are stored in an 8-bit
+buffer
address@hidden table
address@hidden deffn
+
address@hidden {Scheme Procedure} string-bytes-per-char string
address@hidden {C Function} scm_string_bytes_per_char (string)
+Return the bytes used to represent a character in @var{string}.This will
return 1 or 4.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-element-type v
address@hidden {C Function} scm_uniform_vector_element_type (v)
+Return the type of the elements in the uniform vector, @var{v}.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-element-size v
address@hidden {C Function} scm_uniform_vector_element_size (v)
+Return the number of bytes allocated to each element in the
+uniform vector, @var{v}.
address@hidden deffn
+
address@hidden {Scheme Procedure} canonicalize-path path
address@hidden {C Function} scm_canonicalize_path (path)
+Return the canonical path of @var{path}. A canonical path has
+no @code{.} or @code{..} components, nor any repeated path
+separators (@code{/}) nor symlinks.
+
+Raises an error if any component of @var{path} does not exist.
address@hidden deffn
+
address@hidden {Scheme Procedure} getrlimit resource
address@hidden {C Function} scm_getrlimit (resource)
+Get a resource limit for this process. @var{resource} identifies the resource,
+either as an integer or as a symbol. For example, @code{(getrlimit 'stack)}
+gets the limits associated with @code{RLIMIT_STACK}.
+
address@hidden returns two values, the soft and the hard limit. If no
+limit is set for the resource in question, the returned limit will be
@code{#f}.
address@hidden deffn
+
address@hidden {Scheme Procedure} setrlimit resource soft hard
address@hidden {C Function} scm_setrlimit (resource, soft, hard)
+Set a resource limit for this process. @var{resource} identifies the resource,
+either as an integer or as a symbol. @var{soft} and @var{hard} should be
integers,
+or @code{#f} to indicate no limit (i.e., @code{RLIM_INFINITY}).
+
+For example, @code{(setrlimit 'stack 150000 300000)} sets the
@code{RLIMIT_STACK}
+limit to 150 kilobytes, with a hard limit of 300 kB.
address@hidden deffn
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index fbe3059..89f8e84 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.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, 2006,
2007, 2008, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -687,13 +687,21 @@ case @code{stat:rdev} returns @code{#f}.
The size of a regular file in bytes.
@end deffn
@deffn {Scheme Procedure} stat:atime st
-The last access time for the file.
+The last access time for the file, in seconds.
@end deffn
@deffn {Scheme Procedure} stat:mtime st
-The last modification time for the file.
+The last modification time for the file, in seconds.
@end deffn
@deffn {Scheme Procedure} stat:ctime st
-The last modification time for the attributes of the file.
+The last modification time for the attributes of the file, in seconds.
address@hidden deffn
address@hidden {Scheme Procedure} stat:atimensec st
address@hidden {Scheme Procedure} stat:mtimensec st
address@hidden {Scheme Procedure} stat:ctimensec st
+The fractional part of a file's access, modification, or attribute modification
+time, in nanoseconds. Nanosecond timestamps are only available on some
operating
+systems and filesystems. If Guile cannot retrieve nanosecond-level timestamps
+for a file, these fields will be set to 0.
@end deffn
@deffn {Scheme Procedure} stat:blksize st
The optimal block size for reading or writing the file, in bytes. On
@@ -763,14 +771,18 @@ the new permissions as a decimal number, e.g.,
@code{(chmod "foo" #o755)}.
The return value is unspecified.
@end deffn
address@hidden {Scheme Procedure} utime pathname [actime [modtime]]
address@hidden {C Function} scm_utime (pathname, actime, modtime)
address@hidden file times
address@hidden {Scheme Procedure} utime pathname [actime [modtime [actimens
[modtimens [flags]]]]]
address@hidden {C Function} scm_utime (pathname, actime, modtime, actimens,
modtimens, flags)
@code{utime} sets the access and modification times for the
file named by @var{path}. If @var{actime} or @var{modtime} is
not supplied, then the current time is used. @var{actime} and
@var{modtime} must be integer time values as returned by the
@code{current-time} procedure.
+
+The optional @var{actimens} and @var{modtimens} are nanoseconds
+to add @var{actime} and @var{modtime}. Nanosecond precision is
+only supported on some combinations of filesystems and operating
+systems.
@lisp
(utime "foo" (- (current-time) 3600))
@end lisp
@@ -1596,6 +1608,12 @@ from its controlling terminal if it has one.
The return value is an integer representing the new process group ID.
@end deffn
address@hidden {Scheme Procedure} getsid pid
address@hidden {C Function} scm_getsid (pid)
+Returns the session ID of process @var{pid}. (The session
+ID of a process is the process group ID of its session leader.)
address@hidden deffn
+
@deffn {Scheme Procedure} waitpid pid [options]
@deffnx {C Function} scm_waitpid (pid, options)
This procedure collects status information from a child process which
@@ -2318,6 +2336,164 @@ This section describes procedures which query various
network databases.
Care should be taken when using the database routines since they are not
reentrant.
address@hidden @code{getaddrinfo}
+
address@hidden @code{addrinfo} object type
address@hidden host name lookup
address@hidden service name lookup
+
+The @code{getaddrinfo} procedure maps host and service names to socket
addresses
+and associated information in a protocol-independent way.
+
address@hidden {Scheme Procedure} getaddrinfo name service [hint_flags
[hint_family [hint_socktype [hint_protocol]]]]
address@hidden {C Function} scm_getaddrinfo (name, service, hint_flags,
hint_family, hint_socktype, hint_protocol)
+Return a list of @code{addrinfo} structures containing
+a socket address and associated information for host @var{name}
+and/or @var{service} to be used in creating a socket with
+which to address the specified service.
+
address@hidden
+(let* ((ai (car (getaddrinfo "www.gnu.org" "http")))
+ (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+ (addrinfo:protocol ai))))
+ (connect s (addrinfo:addr ai))
+ s)
address@hidden example
+
+When @var{service} is omitted or is @code{#f}, return
+network-level addresses for @var{name}. When @var{name}
+is @code{#f} @var{service} must be provided and service
+locations local to the caller are returned.
+
+Additional hints can be provided. When specified,
address@hidden should be a bitwise-or of zero or more
+constants among the following:
+
address@hidden @code
address@hidden AI_PASSIVE
+Socket address is intended for @code{bind}.
+
address@hidden AI_CANONNAME
+Request for canonical host name, available via
address@hidden:canonname}. This makes sense mainly when
+DNS lookups are involved.
+
address@hidden AI_NUMERICHOST
+Specifies that @var{name} is a numeric host address string
+(e.g., @code{"127.0.0.1"}), meaning that name resolution
+will not be used.
+
address@hidden AI_NUMERICSERV
+Likewise, specifies that @var{service} is a numeric port
+string (e.g., @code{"80"}).
+
address@hidden AI_ADDRCONFIG
+Return only addresses configured on the local system It is
+highly recommended to provide this flag when the returned
+socket addresses are to be used to make connections;
+otherwise, some of the returned addresses could be unreachable
+or use a protocol that is not supported.
+
address@hidden AI_V4MAPPED
+When looking up IPv6 addresses, return mapped IPv4 addresses if
+there is no IPv6 address available at all.
+
address@hidden AI_ALL
+If this flag is set along with @code{AI_V4MAPPED} when looking up IPv6
+addresses, return all IPv6 addresses as well as all IPv4 addresses, the latter
+mapped to IPv6 format.
address@hidden table
+
+When given, @var{hint_family} should specify the requested
+address family, e.g., @code{AF_INET6}. Similarly,
address@hidden should specify the requested socket type
+(e.g., @code{SOCK_DGRAM}), and @var{hint_protocol} should
+specify the requested protocol (its value is interpretered
+as in calls to @code{socket}).
+
+On error, an exception with key @code{getaddrinfo-error} is
+thrown, with an error code (an integer) as its argument:
+
address@hidden
+(catch 'getaddrinfo-error
+ (lambda ()
+ (getaddrinfo "www.gnu.org" "gopher"))
+ (lambda (key errcode)
+ (cond ((= errcode EAI_SERVICE)
+ (display "doesn't know about Gopher!\n"))
+ ((= errcode EAI_NONAME)
+ (display "www.gnu.org not found\\n"))
+ (else
+ (format #t "something wrong: ~a\n"
+ (gai-strerror errcode))))))
address@hidden example
+
+Error codes are:
+
address@hidden @code
address@hidden EAI_AGAIN
+The name or service could not be resolved at this time. Future
+attempts may succeed.
+
address@hidden EAI_BADFLAGS
address@hidden contains an invalid value.
+
address@hidden EAI_FAIL
+A non-recoverable error occurred when attempting to
+resolve the name.
+
address@hidden EAI_FAMILY
address@hidden was not recognized.
+
address@hidden EAI_NONAME
+Either @var{name} does not resolve for the supplied parameters,
+or neither @var{name} nor @var{service} were supplied.
+
address@hidden EAI_SERVICE
address@hidden was not recognized for the specified socket type.
+
address@hidden EAI_SOCKTYPE
address@hidden was not recognized.
+
address@hidden EAI_SYSTEM
+A system error occurred; the error code can be found in
address@hidden
address@hidden table
+
+Users are encouraged to read the
address@hidden://www.opengroup.org/onlinepubs/9699919799/functions/getaddrinfo.html,
+"POSIX specification} for more details.
address@hidden deffn
+
+The following procedures take an @code{addrinfo} object as returned by
address@hidden:
+
address@hidden {Scheme Procedure} addrinfo:flags ai
+Return flags for @var{ai} as a bitwise or of @code{AI_} values (see above).
address@hidden deffn
+
address@hidden {Scheme Procedure} addrinfo:fam ai
+Return the address family of @var{ai} (a @code{AF_} value).
address@hidden deffn
+
address@hidden {Scheme Procedure} addrinfo:socktype ai
+Return the socket type for @var{ai} (a @code{SOCK_} value).
address@hidden deffn
+
address@hidden {Scheme Procedure} addrinfo:protocol ai
+Return the protocol of @var{ai}.
address@hidden deffn
+
address@hidden {Scheme Procedure} addrinfo:addr ai
+Return the socket address associated with @var{ai} as a @code{sockaddr}
+object (@pxref{Network Socket Address}).
address@hidden deffn
+
address@hidden {Scheme Procedure} addrinfo:canonname ai
+Return a string for the canonical name associated with @var{ai} if
+the @code{AI_CANONNAME} flag was supplied.
address@hidden deffn
+
@subsubheading The Host Database
@cindex @file{/etc/hosts}
@cindex network database
@@ -2348,7 +2524,9 @@ The list of network addresses associated with @var{host}.
For
Conversion}).
@end deffn
-The following procedures are used to search the host database:
+The following procedures can be used to search the host database. However,
address@hidden should be preferred over them since it's more generic and
+thread-safe.
@deffn {Scheme Procedure} gethost [host]
@deffnx {Scheme Procedure} gethostbyname hostname
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8f8889c..0d192fa 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -1292,8 +1292,539 @@ from separate @code{and} and @code{let*}, or from
@code{cond} with
@subsection SRFI-4 - Homogeneous numeric vector datatypes
@cindex SRFI-4
-The SRFI-4 procedures and data types are always available, @xref{Uniform
-Numeric Vectors}.
+SRFI-4 provides an interface to uniform numeric vectors: vectors whose elements
+are all of a single numeric type. Guile offers uniform numeric vectors for
+signed and unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of
+floating point values, and, as an extension to SRFI-4, complex floating-point
+numbers of these two sizes.
+
+The standard SRFI-4 procedures and data types may be included via loading the
+appropriate module:
+
address@hidden
+(use-modules (srfi srfi-4))
address@hidden example
+
+This module is currently a part of the default Guile environment, but it is a
+good practice to explicitly import the module. In the future, using SRFI-4
+procedures without importing the SRFI-4 module will cause a deprecation message
+to be printed. (Of course, one may call the C functions at any time. Would that
+C had modules!)
+
address@hidden
+* SRFI-4 Overview:: The warp and weft of uniform numeric vectors.
+* SRFI-4 API:: Uniform vectors, from Scheme and from C.
+* SRFI-4 Generic Operations:: The general, operating on the specific.
+* SRFI-4 and Bytevectors:: SRFI-4 vectors are backed by bytevectors.
+* SRFI-4 Extensions:: Guile-specific extensions to the standard.
address@hidden menu
+
address@hidden SRFI-4 Overview
address@hidden SRFI-4 - Overview
+
+Uniform numeric vectors can be useful since they consume less memory
+than the non-uniform, general vectors. Also, since the types they can
+store correspond directly to C types, it is easier to work with them
+efficiently on a low level. Consider image processing as an example,
+where you want to apply a filter to some image. While you could store
+the pixels of an image in a general vector and write a general
+convolution function, things are much more efficient with uniform
+vectors: the convolution function knows that all pixels are unsigned
+8-bit values (say), and can use a very tight inner loop.
+
+This is implemented in Scheme by having the compiler notice calls to the SRFI-4
+accessors, and inline them to appropriate compiled code. From C you have access
+to the raw array; functions for efficiently working with uniform numeric
vectors
+from C are listed at the end of this section.
+
+Uniform numeric vectors are the special case of one dimensional uniform
+numeric arrays.
+
+There are 12 standard kinds of uniform numeric vectors, and they all have their
+own complement of constructors, accessors, and so on. Procedures that operate
on
+a specific kind of uniform numeric vector have a ``tag'' in their name,
+indicating the element type.
+
address@hidden @nicode
address@hidden u8
+unsigned 8-bit integers
+
address@hidden s8
+signed 8-bit integers
+
address@hidden u16
+unsigned 16-bit integers
+
address@hidden s16
+signed 16-bit integers
+
address@hidden u32
+unsigned 32-bit integers
+
address@hidden s32
+signed 32-bit integers
+
address@hidden u64
+unsigned 64-bit integers
+
address@hidden s64
+signed 64-bit integers
+
address@hidden f32
+the C type @code{float}
+
address@hidden f64
+the C type @code{double}
+
address@hidden table
+
+In addition, Guile supports uniform arrays of complex numbers, with the
+nonstandard tags:
+
address@hidden @nicode
+
address@hidden c32
+complex numbers in rectangular form with the real and imaginary part
+being a @code{float}
+
address@hidden c64
+complex numbers in rectangular form with the real and imaginary part
+being a @code{double}
+
address@hidden table
+
+The external representation (ie.@: read syntax) for these vectors is
+similar to normal Scheme vectors, but with an additional tag from the
+tables above indicating the vector's type. For example,
+
address@hidden
+#u16(1 2 3)
+#f64(3.1415 2.71)
address@hidden lisp
+
+Note that the read syntax for floating-point here conflicts with
address@hidden for false. In Standard Scheme one can write @code{(1 #f3)}
+for a three element list @code{(1 #f 3)}, but for Guile @code{(1 #f3)}
+is invalid. @code{(1 #f 3)} is almost certainly what one should write
+anyway to make the intention clear, so this is rarely a problem.
+
+
address@hidden SRFI-4 API
address@hidden SRFI-4 - API
+
+Note that the @nicode{c32} and @nicode{c64} functions are only available from
address@hidden(srfi srfi-4 gnu)}.
+
address@hidden {Scheme Procedure} u8vector? obj
address@hidden {Scheme Procedure} s8vector? obj
address@hidden {Scheme Procedure} u16vector? obj
address@hidden {Scheme Procedure} s16vector? obj
address@hidden {Scheme Procedure} u32vector? obj
address@hidden {Scheme Procedure} s32vector? obj
address@hidden {Scheme Procedure} u64vector? obj
address@hidden {Scheme Procedure} s64vector? obj
address@hidden {Scheme Procedure} f32vector? obj
address@hidden {Scheme Procedure} f64vector? obj
address@hidden {Scheme Procedure} c32vector? obj
address@hidden {Scheme Procedure} c64vector? obj
address@hidden {C Function} scm_u8vector_p (obj)
address@hidden {C Function} scm_s8vector_p (obj)
address@hidden {C Function} scm_u16vector_p (obj)
address@hidden {C Function} scm_s16vector_p (obj)
address@hidden {C Function} scm_u32vector_p (obj)
address@hidden {C Function} scm_s32vector_p (obj)
address@hidden {C Function} scm_u64vector_p (obj)
address@hidden {C Function} scm_s64vector_p (obj)
address@hidden {C Function} scm_f32vector_p (obj)
address@hidden {C Function} scm_f64vector_p (obj)
address@hidden {C Function} scm_c32vector_p (obj)
address@hidden {C Function} scm_c64vector_p (obj)
+Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
+indicated type.
address@hidden deffn
+
address@hidden {Scheme Procedure} make-u8vector n [value]
address@hidden {Scheme Procedure} make-s8vector n [value]
address@hidden {Scheme Procedure} make-u16vector n [value]
address@hidden {Scheme Procedure} make-s16vector n [value]
address@hidden {Scheme Procedure} make-u32vector n [value]
address@hidden {Scheme Procedure} make-s32vector n [value]
address@hidden {Scheme Procedure} make-u64vector n [value]
address@hidden {Scheme Procedure} make-s64vector n [value]
address@hidden {Scheme Procedure} make-f32vector n [value]
address@hidden {Scheme Procedure} make-f64vector n [value]
address@hidden {Scheme Procedure} make-c32vector n [value]
address@hidden {Scheme Procedure} make-c64vector n [value]
address@hidden {C Function} scm_make_u8vector n [value]
address@hidden {C Function} scm_make_s8vector n [value]
address@hidden {C Function} scm_make_u16vector n [value]
address@hidden {C Function} scm_make_s16vector n [value]
address@hidden {C Function} scm_make_u32vector n [value]
address@hidden {C Function} scm_make_s32vector n [value]
address@hidden {C Function} scm_make_u64vector n [value]
address@hidden {C Function} scm_make_s64vector n [value]
address@hidden {C Function} scm_make_f32vector n [value]
address@hidden {C Function} scm_make_f64vector n [value]
address@hidden {C Function} scm_make_c32vector n [value]
address@hidden {C Function} scm_make_c64vector n [value]
+Return a newly allocated homogeneous numeric vector holding @var{n}
+elements of the indicated type. If @var{value} is given, the vector
+is initialized with that value, otherwise the contents are
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector value @dots{}
address@hidden {Scheme Procedure} s8vector value @dots{}
address@hidden {Scheme Procedure} u16vector value @dots{}
address@hidden {Scheme Procedure} s16vector value @dots{}
address@hidden {Scheme Procedure} u32vector value @dots{}
address@hidden {Scheme Procedure} s32vector value @dots{}
address@hidden {Scheme Procedure} u64vector value @dots{}
address@hidden {Scheme Procedure} s64vector value @dots{}
address@hidden {Scheme Procedure} f32vector value @dots{}
address@hidden {Scheme Procedure} f64vector value @dots{}
address@hidden {Scheme Procedure} c32vector value @dots{}
address@hidden {Scheme Procedure} c64vector value @dots{}
address@hidden {C Function} scm_u8vector (values)
address@hidden {C Function} scm_s8vector (values)
address@hidden {C Function} scm_u16vector (values)
address@hidden {C Function} scm_s16vector (values)
address@hidden {C Function} scm_u32vector (values)
address@hidden {C Function} scm_s32vector (values)
address@hidden {C Function} scm_u64vector (values)
address@hidden {C Function} scm_s64vector (values)
address@hidden {C Function} scm_f32vector (values)
address@hidden {C Function} scm_f64vector (values)
address@hidden {C Function} scm_c32vector (values)
address@hidden {C Function} scm_c64vector (values)
+Return a newly allocated homogeneous numeric vector of the indicated
+type, holding the given parameter @var{value}s. The vector length is
+the number of parameters given.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector-length vec
address@hidden {Scheme Procedure} s8vector-length vec
address@hidden {Scheme Procedure} u16vector-length vec
address@hidden {Scheme Procedure} s16vector-length vec
address@hidden {Scheme Procedure} u32vector-length vec
address@hidden {Scheme Procedure} s32vector-length vec
address@hidden {Scheme Procedure} u64vector-length vec
address@hidden {Scheme Procedure} s64vector-length vec
address@hidden {Scheme Procedure} f32vector-length vec
address@hidden {Scheme Procedure} f64vector-length vec
address@hidden {Scheme Procedure} c32vector-length vec
address@hidden {Scheme Procedure} c64vector-length vec
address@hidden {C Function} scm_u8vector_length (vec)
address@hidden {C Function} scm_s8vector_length (vec)
address@hidden {C Function} scm_u16vector_length (vec)
address@hidden {C Function} scm_s16vector_length (vec)
address@hidden {C Function} scm_u32vector_length (vec)
address@hidden {C Function} scm_s32vector_length (vec)
address@hidden {C Function} scm_u64vector_length (vec)
address@hidden {C Function} scm_s64vector_length (vec)
address@hidden {C Function} scm_f32vector_length (vec)
address@hidden {C Function} scm_f64vector_length (vec)
address@hidden {C Function} scm_c32vector_length (vec)
address@hidden {C Function} scm_c64vector_length (vec)
+Return the number of elements in @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector-ref vec i
address@hidden {Scheme Procedure} s8vector-ref vec i
address@hidden {Scheme Procedure} u16vector-ref vec i
address@hidden {Scheme Procedure} s16vector-ref vec i
address@hidden {Scheme Procedure} u32vector-ref vec i
address@hidden {Scheme Procedure} s32vector-ref vec i
address@hidden {Scheme Procedure} u64vector-ref vec i
address@hidden {Scheme Procedure} s64vector-ref vec i
address@hidden {Scheme Procedure} f32vector-ref vec i
address@hidden {Scheme Procedure} f64vector-ref vec i
address@hidden {Scheme Procedure} c32vector-ref vec i
address@hidden {Scheme Procedure} c64vector-ref vec i
address@hidden {C Function} scm_u8vector_ref (vec i)
address@hidden {C Function} scm_s8vector_ref (vec i)
address@hidden {C Function} scm_u16vector_ref (vec i)
address@hidden {C Function} scm_s16vector_ref (vec i)
address@hidden {C Function} scm_u32vector_ref (vec i)
address@hidden {C Function} scm_s32vector_ref (vec i)
address@hidden {C Function} scm_u64vector_ref (vec i)
address@hidden {C Function} scm_s64vector_ref (vec i)
address@hidden {C Function} scm_f32vector_ref (vec i)
address@hidden {C Function} scm_f64vector_ref (vec i)
address@hidden {C Function} scm_c32vector_ref (vec i)
address@hidden {C Function} scm_c64vector_ref (vec i)
+Return the element at index @var{i} in @var{vec}. The first element
+in @var{vec} is index 0.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector-set! vec i value
address@hidden {Scheme Procedure} s8vector-set! vec i value
address@hidden {Scheme Procedure} u16vector-set! vec i value
address@hidden {Scheme Procedure} s16vector-set! vec i value
address@hidden {Scheme Procedure} u32vector-set! vec i value
address@hidden {Scheme Procedure} s32vector-set! vec i value
address@hidden {Scheme Procedure} u64vector-set! vec i value
address@hidden {Scheme Procedure} s64vector-set! vec i value
address@hidden {Scheme Procedure} f32vector-set! vec i value
address@hidden {Scheme Procedure} f64vector-set! vec i value
address@hidden {Scheme Procedure} c32vector-set! vec i value
address@hidden {Scheme Procedure} c64vector-set! vec i value
address@hidden {C Function} scm_u8vector_set_x (vec i value)
address@hidden {C Function} scm_s8vector_set_x (vec i value)
address@hidden {C Function} scm_u16vector_set_x (vec i value)
address@hidden {C Function} scm_s16vector_set_x (vec i value)
address@hidden {C Function} scm_u32vector_set_x (vec i value)
address@hidden {C Function} scm_s32vector_set_x (vec i value)
address@hidden {C Function} scm_u64vector_set_x (vec i value)
address@hidden {C Function} scm_s64vector_set_x (vec i value)
address@hidden {C Function} scm_f32vector_set_x (vec i value)
address@hidden {C Function} scm_f64vector_set_x (vec i value)
address@hidden {C Function} scm_c32vector_set_x (vec i value)
address@hidden {C Function} scm_c64vector_set_x (vec i value)
+Set the element at index @var{i} in @var{vec} to @var{value}. The
+first element in @var{vec} is index 0. The return value is
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector->list vec
address@hidden {Scheme Procedure} s8vector->list vec
address@hidden {Scheme Procedure} u16vector->list vec
address@hidden {Scheme Procedure} s16vector->list vec
address@hidden {Scheme Procedure} u32vector->list vec
address@hidden {Scheme Procedure} s32vector->list vec
address@hidden {Scheme Procedure} u64vector->list vec
address@hidden {Scheme Procedure} s64vector->list vec
address@hidden {Scheme Procedure} f32vector->list vec
address@hidden {Scheme Procedure} f64vector->list vec
address@hidden {Scheme Procedure} c32vector->list vec
address@hidden {Scheme Procedure} c64vector->list vec
address@hidden {C Function} scm_u8vector_to_list (vec)
address@hidden {C Function} scm_s8vector_to_list (vec)
address@hidden {C Function} scm_u16vector_to_list (vec)
address@hidden {C Function} scm_s16vector_to_list (vec)
address@hidden {C Function} scm_u32vector_to_list (vec)
address@hidden {C Function} scm_s32vector_to_list (vec)
address@hidden {C Function} scm_u64vector_to_list (vec)
address@hidden {C Function} scm_s64vector_to_list (vec)
address@hidden {C Function} scm_f32vector_to_list (vec)
address@hidden {C Function} scm_f64vector_to_list (vec)
address@hidden {C Function} scm_c32vector_to_list (vec)
address@hidden {C Function} scm_c64vector_to_list (vec)
+Return a newly allocated list holding all elements of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} list->u8vector lst
address@hidden {Scheme Procedure} list->s8vector lst
address@hidden {Scheme Procedure} list->u16vector lst
address@hidden {Scheme Procedure} list->s16vector lst
address@hidden {Scheme Procedure} list->u32vector lst
address@hidden {Scheme Procedure} list->s32vector lst
address@hidden {Scheme Procedure} list->u64vector lst
address@hidden {Scheme Procedure} list->s64vector lst
address@hidden {Scheme Procedure} list->f32vector lst
address@hidden {Scheme Procedure} list->f64vector lst
address@hidden {Scheme Procedure} list->c32vector lst
address@hidden {Scheme Procedure} list->c64vector lst
address@hidden {C Function} scm_list_to_u8vector (lst)
address@hidden {C Function} scm_list_to_s8vector (lst)
address@hidden {C Function} scm_list_to_u16vector (lst)
address@hidden {C Function} scm_list_to_s16vector (lst)
address@hidden {C Function} scm_list_to_u32vector (lst)
address@hidden {C Function} scm_list_to_s32vector (lst)
address@hidden {C Function} scm_list_to_u64vector (lst)
address@hidden {C Function} scm_list_to_s64vector (lst)
address@hidden {C Function} scm_list_to_f32vector (lst)
address@hidden {C Function} scm_list_to_f64vector (lst)
address@hidden {C Function} scm_list_to_c32vector (lst)
address@hidden {C Function} scm_list_to_c64vector (lst)
+Return a newly allocated homogeneous numeric vector of the indicated type,
+initialized with the elements of the list @var{lst}.
address@hidden deffn
+
address@hidden {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s8vector (const scm_t_int8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s16vector (const scm_t_int16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s32vector (const scm_t_int32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s64vector (const scm_t_int64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_f32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_f64vector (const double *data, size_t
len)
address@hidden {C Function} SCM scm_take_c32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_c64vector (const double *data, size_t
len)
+Return a new uniform numeric vector of the indicated type and length
+that uses the memory pointed to by @var{data} to store its elements.
+This memory will eventually be freed with @code{free}. The argument
address@hidden specifies the number of elements in @var{data}, not its size
+in bytes.
+
+The @code{c32} and @code{c64} variants take a pointer to a C array of
address@hidden or @code{double}s. The real parts of the complex numbers
+are at even indices in that array, the corresponding imaginary parts are
+at the following odd index.
address@hidden deftypefn
+
address@hidden {C Function} {const scm_t_uint8 *} scm_u8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int8 *} scm_s8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint16 *} scm_u16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int16 *} scm_s16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint32 *} scm_u32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int32 *} scm_s32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint64 *} scm_u64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int64 *} scm_s64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_f23vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_f64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_c32vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_c64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
+returns a pointer to the elements of a uniform numeric vector of the
+indicated kind.
address@hidden deftypefn
+
address@hidden {C Function} {scm_t_uint8 *} scm_u8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int8 *} scm_s8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint16 *} scm_u16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int16 *} scm_s16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint32 *} scm_u32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int32 *} scm_s32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint64 *} scm_u64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int64 *} scm_s64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_f23vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_f64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_c32vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_c64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
+C}), but returns a pointer to the elements of a uniform numeric vector
+of the indicated kind.
address@hidden deftypefn
+
address@hidden SRFI-4 Generic Operations
address@hidden SRFI-4 - Generic operations
+
+Guile also provides procedures that operate on all types of uniform numeric
+vectors. In what is probably a bug, these procedures are currently available
in
+the default environment as well; however prudent hackers will make sure to
+import @code{(srfi srfi-4 gnu)} before using these.
+
address@hidden {C Function} int scm_is_uniform_vector (SCM uvec)
+Return non-zero when @var{uvec} is a uniform numeric vector, zero
+otherwise.
address@hidden deftypefn
+
address@hidden {C Function} size_t scm_c_uniform_vector_length (SCM uvec)
+Return the number of elements of @var{uvec} as a @code{size_t}.
address@hidden deftypefn
+
address@hidden {Scheme Procedure} uniform-vector? obj
address@hidden {C Function} scm_uniform_vector_p (obj)
+Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
+indicated type.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-length vec
address@hidden {C Function} scm_uniform_vector_length (vec)
+Return the number of elements in @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-ref vec i
address@hidden {C Function} scm_uniform_vector_ref (vec i)
+Return the element at index @var{i} in @var{vec}. The first element
+in @var{vec} is index 0.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-set! vec i value
address@hidden {C Function} scm_uniform_vector_set_x (vec i value)
+Set the element at index @var{i} in @var{vec} to @var{value}. The
+first element in @var{vec} is index 0. The return value is
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector->list vec
address@hidden {C Function} scm_uniform_vector_to_list (vec)
+Return a newly allocated list holding all elements of @var{vec}.
address@hidden deffn
+
address@hidden {C Function} {const void *} scm_uniform_vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
+returns a pointer to the elements of a uniform numeric vector.
address@hidden deftypefn
+
address@hidden {C Function} {void *} scm_uniform_vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
+C}), but returns a pointer to the elements of a uniform numeric vector.
address@hidden deftypefn
+
+Unless you really need to the limited generality of these functions, it is best
+to use the type-specific functions, or the generalized vector accessors.
+
address@hidden SRFI-4 and Bytevectors
address@hidden SRFI-4 - Relation to bytevectors
+
+Guile implements SRFI-4 vectors using bytevectors (@pxref{Bytevectors}). Often
+when you have a numeric vector, you end up wanting to write its bytes
somewhere,
+or have access to the underlying bytes, or read in bytes from somewhere else.
+Bytevectors are very good at this sort of thing. But the SRFI-4 APIs are nicer
+to use when doing number-crunching, because they are addressed by element and
+not by byte.
+
+So as a compromise, Guile allows all bytevector functions to operate on numeric
+vectors. They address the underlying bytes in the native endianness, as one
+would expect.
+
+Following the same reasoning, that it's just bytes underneath, Guile also
allows
+uniform vectors of a given type to be accessed as if they were of any type. One
+can fill a @nicode{u32vector}, and access its elements with
address@hidden One can use @nicode{f64vector-ref} on bytevectors. It's
+all the same to Guile.
+
+In this way, uniform numeric vectors may be written to and read from
+input/output ports using the procedures that operate on bytevectors.
+
address@hidden, for more information.
+
+
address@hidden SRFI-4 Extensions
address@hidden SRFI-4 - Guile extensions
+
+Guile defines some useful extensions to SRFI-4, which are not available in the
+default Guile environment. They may be imported by loading the extensions
+module:
+
address@hidden
+(use-modules (srfi srfi-4 gnu))
address@hidden example
+
address@hidden {Scheme Procedure} any->u8vector obj
address@hidden {Scheme Procedure} any->s8vector obj
address@hidden {Scheme Procedure} any->u16vector obj
address@hidden {Scheme Procedure} any->s16vector obj
address@hidden {Scheme Procedure} any->u32vector obj
address@hidden {Scheme Procedure} any->s32vector obj
address@hidden {Scheme Procedure} any->u64vector obj
address@hidden {Scheme Procedure} any->s64vector obj
address@hidden {Scheme Procedure} any->f32vector obj
address@hidden {Scheme Procedure} any->f64vector obj
address@hidden {Scheme Procedure} any->c32vector obj
address@hidden {Scheme Procedure} any->c64vector obj
address@hidden {C Function} scm_any_to_u8vector (obj)
address@hidden {C Function} scm_any_to_s8vector (obj)
address@hidden {C Function} scm_any_to_u16vector (obj)
address@hidden {C Function} scm_any_to_s16vector (obj)
address@hidden {C Function} scm_any_to_u32vector (obj)
address@hidden {C Function} scm_any_to_s32vector (obj)
address@hidden {C Function} scm_any_to_u64vector (obj)
address@hidden {C Function} scm_any_to_s64vector (obj)
address@hidden {C Function} scm_any_to_f32vector (obj)
address@hidden {C Function} scm_any_to_f64vector (obj)
address@hidden {C Function} scm_any_to_c32vector (obj)
address@hidden {C Function} scm_any_to_c64vector (obj)
+Return a (maybe newly allocated) uniform numeric vector of the indicated
+type, initialized with the elements of @var{obj}, which must be a list,
+a vector, or a uniform vector. When @var{obj} is already a suitable
+uniform numeric vector, it is returned unchanged.
address@hidden deffn
+
@node SRFI-6
@subsection SRFI-6 - Basic String Ports
diff --git a/doc/ref/standard-library.am b/doc/ref/standard-library.am
new file mode 100644
index 0000000..27246f4
--- /dev/null
+++ b/doc/ref/standard-library.am
@@ -0,0 +1,2 @@
+# Automatically generated, do not edit.
+standard_library_scm_files = $(top_srcdir)/module/statprof.scm
$(top_srcdir)/module/sxml/apply-templates.scm
$(top_srcdir)/module/sxml/fold.scm $(top_srcdir)/module/sxml/simple.scm
$(top_srcdir)/module/sxml/ssax.scm
$(top_srcdir)/module/sxml/ssax/input-parse.scm
$(top_srcdir)/module/sxml/transform.scm $(top_srcdir)/module/sxml/xpath.scm
$(top_srcdir)/module/texinfo.scm $(top_srcdir)/module/texinfo/docbook.scm
$(top_srcdir)/module/texinfo/html.scm $(top_srcdir)/module/texinfo/indexing.scm
$(top_srcdir)/module/texinfo/string-utils.scm
$(top_srcdir)/module/texinfo/plain-text.scm
$(top_srcdir)/module/texinfo/serialize.scm
$(top_srcdir)/module/texinfo/reflection.scm
\ No newline at end of file
diff --git a/doc/ref/standard-library.scm b/doc/ref/standard-library.scm
new file mode 100644
index 0000000..7fd17b5
--- /dev/null
+++ b/doc/ref/standard-library.scm
@@ -0,0 +1,48 @@
+;; The modules to document
+(define *modules*
+ '(((statprof)
+ "Statistical profiler")
+ ((sxml apply-templates)
+ "A more XSLT-like approach to SXML transformations")
+ ((sxml fold)
+ "Fold-based SXML transformation operators")
+ ((sxml simple)
+ "Convenient XML parsing and serializing")
+ ((sxml ssax)
+ "Functional-style XML parsing for Scheme")
+ ((sxml ssax input-parse)
+ "The SSAX tokenizer, optimized for Guile")
+ ((sxml transform)
+ "A higher-order SXML transformation operator, "
+ (code "pre-post-order"))
+ ((sxml xpath)
+ "XPath for SXML")
+ ((texinfo)
+ "Parse texinfo files or fragments into " (code "stexi") ", a "
+ "scheme representation")
+ ((texinfo docbook)
+ "Transform a subset of docbook into " (code "stexi"))
+ ((texinfo html)
+ "Transform " (code "stexi") " into HTML")
+ ((texinfo indexing)
+ "Extract an index from a piece of " (code "stexi"))
+ ((texinfo string-utils)
+ "String utility functions used by the texinfo processor")
+ ((texinfo plain-text)
+ "Render " (code "stexi") " as plain text")
+ ((texinfo serialize)
+ "Render " (code "stexi") " as texinfo")
+ ((texinfo reflection)
+ "Enable texinfo across Guile's help system")))
+
+(define *module-sources*
+ '(((sxml ssax) . "http://ssax.sourceforge.net/";)
+ ((sxml xpath) . "http://ssax.sourceforge.net/";)
+ ((sxml transform) . "http://ssax.sourceforge.net/";)
+ ((sxml apply-templates) . "http://ssax.sourceforge.net/";)
+ ((sxml ssax input-parse) . "http://ssax.sourceforge.net/";)
+ ((htmlprag) . "http://neilvandyke.org/htmlprag/";)))
+
+(define *scripts* '())
+
+;; arch-tag: e493ad42-ad58-451c-a2d6-b17ba6c1d1d0
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index fe5c1ee..0b56b4b 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -1,15 +1,15 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2008,2009
address@hidden Copyright (C) 2008,2009,2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node A Virtual Machine for Guile
@section A Virtual Machine for Guile
-Guile has both an interpreter and a compiler. To a user, the
-difference is largely transparent---interpreted and compiled
-procedures can call each other as they please.
+Guile has both an interpreter and a compiler. To a user, the difference
+is transparent---interpreted and compiled procedures can call each other
+as they please.
The difference is that the compiler creates and interprets bytecode
for a custom virtual machine, instead of interpreting the
@@ -33,21 +33,19 @@ machine.
@subsection Why a VM?
@cindex interpreter
address@hidden evaluator
-For a long time, Guile only had an interpreter, called the
address@hidden Guile's evaluator operates directly on the
-S-expression representation of Scheme source code.
+For a long time, Guile only had an interpreter. Guile's interpreter
+operated directly on the S-expression representation of Scheme source
+code.
-But while the evaluator is highly optimized and hand-tuned, and
-contains some extensive speed trickery (@pxref{Memoization}), it still
+But while the interpreter was highly optimized and hand-tuned, it still
performs many needless computations during the course of evaluating an
expression. For example, application of a function to arguments
-needlessly conses up the arguments in a list. Evaluation of an
-expression always has to figure out what the car of the expression is
--- a procedure, a memoized form, or something else. All values have to
-be allocated on the heap. Et cetera.
+needlessly consed up the arguments in a list. Evaluation of an
+expression always had to figure out what the car of the expression is --
+a procedure, a memoized form, or something else. All values have to be
+allocated on the heap. Et cetera.
-The solution to this problem is to compile the higher-level language,
+The solution to this problem was to compile the higher-level language,
Scheme, into a lower-level language for which all of the checks and
dispatching have already been done---the code is instead stripped to
the bare minimum needed to ``do the job''.
@@ -71,7 +69,21 @@ for Guile (@code{cons}, @code{struct-ref}, etc.).
So this is what Guile does. The rest of this section describes that VM
that Guile implements, and the compiled procedures that run on it.
-Note that this decision to implement a bytecode compiler does not
+Before moving on, though, we should note that though we spoke of the
+interpreter in the past tense, Guile still has an interpreter. The
+difference is that before, it was Guile's main evaluator, and so was
+implemented in highly optimized C; now, it is actually implemented in
+Scheme, and compiled down to VM bytecode, just like any other program.
+(There is still a C interpreter around, used to bootstrap the compiler,
+but it is not normally used at runtime.)
+
+The upside of implementing the interpreter in Scheme is that we preserve
+tail calls and multiple-value handling between interpreted and compiled
+code. The downside is that the interpreter in Guile 2.0 is slower than
+the interpreter in 1.8. We hope the that the compiler's speed makes up
+for the loss!
+
+Also note that this decision to implement a bytecode compiler does not
preclude native compilation. We can compile from bytecode to native
code at runtime, or even do ahead of time compilation. More
possibilities are discussed in @ref{Extending the Compiler}.
@@ -79,12 +91,9 @@ possibilities are discussed in @ref{Extending the Compiler}.
@node VM Concepts
@subsection VM Concepts
-A virtual machine (VM) is a Scheme object. Users may create virtual
-machines using the standard procedures described later in this manual,
-but that is usually unnecessary, as Guile ensures that there is one
-virtual machine per thread. When a VM-compiled procedure is run, Guile
-looks up the virtual machine for the current thread and executes the
-procedure using that VM.
+Compiled code is run by a virtual machine (VM). Each thread has its own
+VM. When a compiled procedure is run, Guile looks up the virtual machine
+for the current thread and executes the procedure using that VM.
Guile's virtual machine is a stack machine---that is, it has few
registers, and the instructions defined in the VM operate by pushing
@@ -113,12 +122,6 @@ the ``program counter'' (pc). This set of registers is
pretty typical
for stack machines; their exact meanings in the context of Guile's VM
are described in the next section.
-A virtual machine executes by loading a compiled procedure, and
-executing the object code associated with that procedure. Of course,
-that procedure may call other procedures, tail-call others, ad
-infinitum---indeed, within a guile whose modules have all been
-compiled to object code, one might never leave the virtual machine.
-
@c wingo: The following is true, but I don't know in what context to
@c describe it. A documentation FIXME.
@@ -241,8 +244,8 @@ prove statements about functions. It is especially good at
describing
scope relations, and it is for that reason that we mention it here.
Guile allocates all variables on the stack. When a lexically enclosed
-procedure with free variables---a @dfn{closure}---is created, it
-copies those variables its free variable vector. References to free
+procedure with free variables---a @dfn{closure}---is created, it copies
+those variables into its free variable vector. References to free
variables are then redirected through the free variable vector.
If a variable is ever @code{set!}, however, it will need to be
@@ -306,42 +309,45 @@ We can see how these concepts tie together by
disassembling the
@smallexample
scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
scheme@@(guile-user)> ,x foo
-Disassembly of #<program foo (a)>:
+Disassembly of #<procedure foo (a)>:
- 0 (object-ref 1) ;; #<program b7e478b0 at <unknown port>:0:16
(b)>
- 2 (local-ref 0) ;; `a' (arg)
- 4 (vector 0 1) ;; 1 element
- 7 (make-closure)
- 8 (return)
+ 0 (assert-nargs-ee 0 1)
+ 3 (reserve-locals 0 1)
+ 6 (object-ref 1) ;; #<procedure 85bfec0 at <current
input>:0:16 (b)>
+ 8 (local-ref 0) ;; `a'
+ 10 (make-closure 0 1)
+ 13 (return)
----------------------------------------
-Disassembly of #<program b7e478b0 at <unknown port>:0:16 (b)>:
-
- 0 (toplevel-ref 1) ;; `foo'
- 2 (free-ref 0) ;; (closure variable)
- 4 (local-ref 0) ;; `b' (arg)
- 6 (list 0 3) ;; 3 elements at (unknown file):0:28
- 9 (return)
+Disassembly of #<procedure 85bfec0 at <current input>:0:16 (b)>:
+
+ 0 (assert-nargs-ee 0 1)
+ 3 (reserve-locals 0 1)
+ 6 (toplevel-ref 1) ;; `foo'
+ 8 (free-ref 0) ;; (closure variable)
+ 10 (local-ref 0) ;; `b'
+ 12 (list 0 3) ;; 3 elements at (unknown
file):0:28
+ 15 (return)
@end smallexample
-At @code{ip} 0, we load up the compiled lambda. @code{Ip} 2 and 4
-create the free variables vector, and @code{ip} 7 makes the
-closure---binding code (from the compiled lambda) with data (the
-free-variable vector). Finally we return the closure.
-
-The second stanza disassembles the compiled lambda. Toplevel variables
-are resolved relative to the module that was current when the
-procedure was created. This lookup occurs lazily, at the first time
-the variable is actually referenced, and the location of the lookup is
-cached so that future references are very cheap. @xref{Environment
-Control Instructions}, for more details.
-
-Then we see a reference to an external variable, corresponding to
address@hidden The disassembler doesn't have enough information to give a
-name to that variable, so it just marks it as being a ``closure
-variable''. Finally we see the reference to @code{b}, then the
address@hidden opcode, an inline implementation of the @code{list} scheme
-routine.
+First there's some prelude, where @code{foo} checks that it was called with
only
+1 argument. Then at @code{ip} 6, we load up the compiled lambda. @code{Ip} 8
+loads up `a', so that it can be captured into a closure by at @code{ip}
+10---binding code (from the compiled lambda) with data (the free-variable
+vector). Finally we return the closure.
+
+The second stanza disassembles the compiled lambda. After the prelude, we note
+that toplevel variables are resolved relative to the module that was current
+when the procedure was created. This lookup occurs lazily, at the first time
the
+variable is actually referenced, and the location of the lookup is cached so
+that future references are very cheap. @xref{Environment Control Instructions},
+for more details.
+
+Then we see a reference to a free variable, corresponding to @code{a}. The
+disassembler doesn't have enough information to give a name to that variable,
so
+it just marks it as being a ``closure variable''. Finally we see the reference
+to @code{b}, then the @code{list} opcode, an inline implementation of the
address@hidden scheme routine.
@node Instruction Set
@subsection Instruction Set
@@ -548,8 +554,8 @@ All the conditional branch instructions described below
work in the
same way:
@itemize
address@hidden They pop off the Scheme object located on the stack and use it as
-the branch condition;
address@hidden They pop off Scheme object(s) located on the stack for use in the
+branch condition
@item If the condition is true, then the instruction pointer is
increased by the offset passed as an argument to the branch
instruction;
@@ -557,22 +563,20 @@ instruction;
the one to which the instruction pointer points).
@end itemize
-Note that the offset passed to the instruction is encoded on two 8-bit
-integers which are then combined by the VM as one 16-bit integer. Note
-also that jump targets in Guile are aligned on 8-byte boundaries, and
-that the offset refers to the @var{n}th 8-byte boundary, effectively
-giving Guile a 19-bit relative address space.
+Note that the offset passed to the instruction is encoded as three 8-bit
+integers, in big-endian order, effectively giving Guile a 24-bit
+relative address space.
@deffn Instruction br offset
-Jump to @var{offset}.
+Jump to @var{offset}. No values are popped.
@end deffn
@deffn Instruction br-if offset
-Jump to @var{offset} if the condition on the stack is not false.
+Jump to @var{offset} if the object on the stack is not false.
@end deffn
@deffn Instruction br-if-not offset
-Jump to @var{offset} if the condition on the stack is false.
+Jump to @var{offset} if the object on the stack is false.
@end deffn
@deffn Instruction br-if-eq offset
@@ -678,14 +682,12 @@ and arguments off the stack, and push the result of
calling
@code{scm_apply}.
@end deffn
address@hidden Instruction goto/args nargs
address@hidden Instruction tail-call nargs
Like @code{call}, but reusing the current continuation. This
instruction implements tail calls as required by RnRS.
-For compiled procedures, that means that @code{goto/args} simply
+For compiled procedures, that means that @code{tail-call} simply
shuffles down the procedure and arguments to the current stack frame.
-The @code{goto/*} instruction family is named as it is because tail
-calls are equivalent to @code{goto}, along with relabeled variables.
For non-VM procedures, the result is the same, but the current VM
invocation remains on the C stack. True tail calls are not currently
@@ -693,16 +695,16 @@ possible between compiled and non-compiled procedures.
@end deffn
@deffn Instruction apply nargs
address@hidden Instruction goto/apply nargs
-Like @code{call} and @code{goto/args}, except that the top item on the
address@hidden Instruction tail-apply nargs
+Like @code{call} and @code{tail-call}, except that the top item on the
stack must be a list. The elements of that list are then pushed on the
stack and treated as additional arguments, replacing the list itself,
then the procedure is invoked as usual.
@end deffn
@deffn Instruction call/nargs
address@hidden Instruction goto/nargs
-These are like @code{call} and @code{goto/args}, except they take the
address@hidden Instruction tail-call/nargs
+These are like @code{call} and @code{tail-call}, except they take the
number of arguments from the stack instead of the instruction stream.
These instructions are used in the implementation of multiple value
returns, where the actual number of values is pushed on the stack.
@@ -767,7 +769,7 @@ Signals an error if there is an insufficient number of
values.
@end deffn
@deffn Instruction call/cc
address@hidden Instruction goto/cc
address@hidden Instruction tail-call/cc
Capture the current continuation, and then call (or tail-call) the
procedure on the top of the stack, with the continuation as the
argument.
@@ -821,7 +823,7 @@ Push @code{#t} onto the stack.
@end deffn
@deffn Instruction make-nil
-Push @code{%nil} onto the stack.
+Push @code{#nil} onto the stack.
@end deffn
@deffn Instruction make-eol
diff --git a/doc/tutorial/ChangeLog-2008 b/doc/tutorial/ChangeLog-2008
deleted file mode 100644
index 9b78ed7..0000000
--- a/doc/tutorial/ChangeLog-2008
+++ /dev/null
@@ -1,54 +0,0 @@
-2004-07-29 Kevin Ryde <address@hidden>
-
- * doc/tutorial/guile-tut.texi (What is libguile): Correction to
- reference manual "Data representation" cross reference.
-
-2004-06-28 Marius Vollmer <address@hidden>
-
- * Makefile.am: Removed home-grown code for HTML generation.
- Automake does it for us now.
-
- * guile-tut.texi (Top): Use @ifnottex instead of @ifinfo for the
- beneift of makeinfo --html.
-
-2003-09-27 Neil Jerram <address@hidden>
-
- * guile-tut.texi (Using Guile to program in Scheme): Fix result of
- `(reverse ls)', and change `squaring function' example to use `(*
- n n)' instead of `(expt n n)'. Thanks to Jack Pavlovsky for
- pointing these out.
-
-2003-05-27 Dirk Herrmann <address@hidden>
-
- * guile-tut.texi: Fix example, where a vector constant is used
- without quoting.
-
-2002-07-16 Neil Jerram <address@hidden>
-
- * guile-tut.texi (Jump Start): Apply patch from M. Luedde on use
- of tail recursion to avoid stack overflow (with minor editing).
-
-2001-11-18 Neil Jerram <address@hidden>
-
- * guile-tut.texi (History of Guile and its motivations): Update
- Tcl war URLs.
-
-2001-09-19 Thien-Thi Nguyen <address@hidden>
-
- * guile-tut.texi: Fix improper address@hidden' usage.
- Fix number typo in "Jump Start" section.
-
-2001-08-27 Neil Jerram <address@hidden>
-
- * Makefile.am (guile_tut_TEXINFOS): Removed.
- (TEXINFO_TEX): Added; avoids shipping multiple copies of
- texinfo.tex in a single distribution.
-
- * guile-tut.texi: Incorporate text previously in separate AUTHORS
- file.
-
-2001-08-27 Neil Jerram <address@hidden>
-
- The change log for files in this directory continues backwards
- from 2001-08-27 in ../ChangeLog, as all the Guile documentation
- prior to this date was contained in a single directory.
diff --git a/doc/tutorial/ChangeLog-guile-doc-tutorial
b/doc/tutorial/ChangeLog-guile-doc-tutorial
deleted file mode 100644
index 9d7233a..0000000
--- a/doc/tutorial/ChangeLog-guile-doc-tutorial
+++ /dev/null
@@ -1,16 +0,0 @@
-2001-01-27 Neil Jerram <address@hidden>
-
- * texinfo.tex: Replaced by latest version from ftp.gnu.org.
-
-1999-12-06 Gary Houston <address@hidden>
-
- * guile-tut.texi: tweaked the dircategory.
-
-1998-01-28 Mark Galassi <address@hidden>
-
- * guile-tut.texi: set @dircategory to "Scheme Programming".
-
-Mon Aug 18 16:11:43 1997 Jim Blandy <address@hidden>
-
- * texinfo.tex: Installed from texinfo release 3.11.
-
diff --git a/doc/tutorial/Makefile.am b/doc/tutorial/Makefile.am
deleted file mode 100644
index d359c4f..0000000
--- a/doc/tutorial/Makefile.am
+++ /dev/null
@@ -1,26 +0,0 @@
-## Process this file with Automake to create Makefile.in
-##
-## Copyright (C) 1998, 2006, 2008 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify it
-## under the terms of the GNU Lesser General Public License as
-## published by the Free Software Foundation; either version 3, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU Lesser General Public License for more details.
-##
-## You should have received a copy of the GNU Lesser General Public
-## License along with GUILE; see the file COPYING.LESSER. If not,
-## write to the Free Software Foundation, Inc., 51 Franklin Street,
-## Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-info_TEXINFOS = guile-tut.texi
-
-EXTRA_DIST = ChangeLog-2008
diff --git a/doc/tutorial/guile-tut.texi b/doc/tutorial/guile-tut.texi
deleted file mode 100644
index ed0b202..0000000
--- a/doc/tutorial/guile-tut.texi
+++ /dev/null
@@ -1,1373 +0,0 @@
-\input texinfo @c -*-texinfo-*-
address@hidden %**start of header
address@hidden guile-tut.info
address@hidden Guile Tutorial
address@hidden guile-tut
-
address@hidden version.texi
-
address@hidden The Algorithmic Language Scheme
address@hidden
-* Guile Tutorial: (guile-tut). The Guile tutorial.
address@hidden direntry
-
address@hidden off
address@hidden Choices for setchapternewpage are {on,off,odd}.
address@hidden 2
address@hidden %**end of header
-
address@hidden
address@hidden
address@hidden DL: lose the egregious vertical whitespace, esp. around examples
address@hidden but paras in @defun-like things don't have parindent
address@hidden 4pt plus 1pt
address@hidden iftex
-
address@hidden
address@hidden Guile Tutorial
address@hidden For use with Guile @value{VERSION}
address@hidden Last updated @value{UPDATED}
-
address@hidden Mark Galassi
address@hidden Cygnus Solutions and Los Alamos National Laboratory
address@hidden @email{rosalia@@nis.lanl.gov}
-
address@hidden
address@hidden 0pt plus 1filll
-Copyright @copyright{} 1997, 1998, 2004, 2006 Free Software Foundation
-
-Permission is granted to make and distribute verbatim copies of
-this manual provided the copyright notice and this permission notice
-are preserved on all copies.
-
-Permission is granted to copy and distribute modified versions of this
-manual under the conditions for verbatim copying, provided that the entire
-resulting derived work is distributed under the terms of a permission
-notice identical to this one.
-
-Permission is granted to copy and distribute translations of this manual
-into another language, under the above conditions for modified versions,
-except that this permission notice may be stated in a translation approved
-by the author.
address@hidden titlepage
-
-
address@hidden
address@hidden Top
address@hidden Guile Tutorial
address@hidden ifnottex
-
address@hidden
-This file gives a tutorial introduction to Guile.
-
-Copyright (C) 1997, 2004, 2006 Free Software Foundation
-
-Permission is granted to make and distribute verbatim copies of
-this manual provided the copyright notice and this permission notice
-are preserved on all copies.
-
address@hidden
-Permission is granted to process this file through TeX and print the
-results, provided the printed document carries copying permission
-notice identical to this one except for the removal of this paragraph
-(this paragraph not being relevant to the printed manual).
-
address@hidden ignore
-Permission is granted to copy and distribute modified versions of this
-manual under the conditions for verbatim copying, provided that the entire
-resulting derived work is distributed under the terms of a permission
-notice identical to this one.
-
-Permission is granted to copy and distribute translations of this manual
-into another language, under the above conditions for modified versions,
-except that this permission notice may be stated in a translation approved
-by the author.
address@hidden ifinfo
-
-
address@hidden
-* Jump Start::
-* Introduction::
-* Using Guile to program in Scheme::
-* Guile in a Library::
-* Regular Expression Support::
-* UNIX System Programming::
-* Where to find more Guile/Scheme resources::
-* Concept Index::
-* Procedure and Macro Index::
-* Variable Index::
-* Type Index::
address@hidden menu
-
-
address@hidden Jump Start
address@hidden Jump Start
-
address@hidden
-Before giving an overview of Guile, I present some simple commands and
-programs that you can type to get going immediately.
-
-Start by invoking the Guile interpreter. Usually you do this by just
-typing @code{guile}. Then type (or paste) the following expressions at
-the prompt; the interpreter's response is preceded (in this manual) by
address@hidden
-
address@hidden
-<shell-prompt> guile
address@hidden example
address@hidden
-(+ 20 35)
address@hidden 55
-(define (recursive-factorial n)
- (if (zero? n)
- 1
- (* n (recursive-factorial (- n 1)))))
-(recursive-factorial 5)
address@hidden 120
-(quit)
address@hidden lisp
-
-In this example we did some simple arithmetic @code{(+ 20 35)} and got
-the answer @code{55}. Then we coded the classic (and rather wasteful)
-factorial algorithm and computed the factorial of @code{55}. Finally we
-quit with @code{(quit)}.
-
address@hidden bignumbers
-We can find out about some of Scheme's nice features by asking for the
-factorial of some big number, say @code{500}. On some systems the
-correct answer will be returned (I do not indicate calling and leaving
-the guile session anymore).
-
address@hidden
-(recursive-factorial 500)
address@hidden 1220136825991110068701238785423046926253574342803192842192413588
- 3858453731538819976054964475022032818630136164771482035841633787
- 2207817720048078520515932928547790757193933060377296085908627042
- 9174547882424912726344305670173270769461062802310452644218878789
- 4657547771498634943677810376442740338273653974713864778784954384
- 8959553753799042324106127132698432774571554630997720278101456108
- 1188373709531016356324432987029563896628911658974769572087926928
- 8712817800702651745077684107196243903943225364226052349458501299
- 1857150124870696156814162535905669342381300885624924689156412677
- 5654481886506593847951775360894005745238940335798476363944905313
- 0623237490664450488246650759467358620746379251842004593696929810
- 2226397195259719094521782333175693458150855233282076282002340262
- 6907898342451712006207714640979456116127629145951237229913340169
- 5523638509428855920187274337951730145863575708283557801587354327
- 6888868012039988238470215146760544540766353598417443048012893831
- 3896881639487469658817504506926365338175055478128640000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000000000000000000000000000000
address@hidden lisp
-
-The result is an example of Scheme's @emph{bignumbers}. However, there
-are operating environments that provide (by default) too little stack
-space. They will instead produce an error message like this:
-
address@hidden
-(recursive-factorial 500)
address@hidden
-ERROR: Stack overflow
-ABORT: (stack-overflow)
address@hidden lisp
-
-Rather than enlarging the system's stack, we can implement the algorithm
-such that it does not consume increasing stack space. This is called a
address@hidden recursive} implementation. The following definition is tail
-recursive and so should work on all systems.
-
address@hidden
-(define (tail-recursive-factorial n)
- (define (loop k l)
- (if (zero? k) l
- (loop (- k 1) (* k l))))
- (loop n 1))
-
-(tail-recursive-factorial 500)
address@hidden 1220136825991110068701238785423046926253574342803192842192413588
- ;; ... skipped
address@hidden lisp
-
-This is the most basic use of Guile: a simple Scheme interpreter. In
-the rest of this tutorial I will show you how Guile has many facets: it
-is also an @emph{extensible} interpreter (to which many features can be
-easilly added) and an @emph{embeddable} interpreter (which can be
-invoked from your C programs).
-
-
address@hidden Introduction
address@hidden Introduction
-
address@hidden
address@hidden (which can stand for @emph{GNU Ubiquitous Intelligent
-Language Extension}) is the GNU extension language. It started out as
-an embeddable Scheme interpreter, and has rapidly evolved into a
-kitchen-sink package including a standalone Scheme interpreter, an
-embeddable Scheme interpreter, several graphics options, other languages
-that can be used along with Scheme (for now just @emph{ctax} and
address@hidden), and hooks for much more.
-
-
address@hidden
-* What are scripting and extension languages::
-* History of Guile and its motivations::
-* How to characterize Guile::
address@hidden menu
-
address@hidden What are scripting and extension languages
address@hidden What are scripting and extension languages
address@hidden scripting languages
address@hidden extension languages
-
-A @dfn{scripting language} is a programming language which serves as
-glue between other system programs. In the UNIX world, the traditional
-scripting language is the @emph{Bourne shell}, which allows many UNIX
-commands to be executed in sequence, or in a pipeline. Traditional UNIX
-commands are cleverly written to work well when put together in a
-script.
-
-Other examples of UNIX scripting languages are AWK, Perl, Scsh (the
-Scheme Shell: a Scheme interpreter enhanced to do good scripting),
-Python, Tcl, Java @dots{}
address@hidden scripting languages - examples
-
-UNIX programmers noticed, more than 25 years ago, that scripting
-languages can do serious work, so the Bourne shell was written to have
-variables, operators and control structures, just like a full-featured
-programming language.
address@hidden Bourne shell
-
-What scripting languages have, that traditional programming languages do
-not, is the ability to easily run an external program (or a pipeline of
-external programs) and use the returned values and output from that
-program in useful ways.
-
-An @dfn{extension language} is a programming language interpreter
-offered by an application program, so that users can write macros or
-even full-fledged programs to extend the original application.
-Extension languages have a C interface (it is usually C, but it could be
-any other compiled language), and can be given access to the C data
-structures. Likewise, there are C routines to access the extension
-language data structures.
-
-Extension languages abound in the software world, even though the name
address@hidden language} is seldom used. Examples are:
address@hidden extension languages - examples
-
address@hidden @bullet
address@hidden
-Emacs Lisp, the language used to program and customize GNU Emacs.
address@hidden Emacs Lisp
-
address@hidden
-Tcl, John Ousterhout's general-purpose scripting and extension language.
address@hidden Tcl
-
address@hidden
-The Lotus 1-2-3 macro language (any spreadsheet macro language,
-really). I mention this one first because it is a classic, even though
-it is seldom used any more.
address@hidden Lotus 1-2-3
-
address@hidden
-Other spreadsheet and database macro languages.
-
address@hidden
-The Dominion empire-style game's @emph{exec} files.
address@hidden Dominion
-
address@hidden
-Any syntax for a ".*rc" file you might have used. Almost all programs
-end up parsing some kind of startup or configuration file. The syntax
-for those can get pretty involved, thus justifying calling them
-"extension languages". The @emph{fvwm} window manager, for example,
-parses a rather elaborate @file{.fvwmrc} file.
-
address@hidden
-Brent Benson's libscheme.a, an embeddable Scheme interpreter.
address@hidden Benson, Brent
address@hidden libscheme
-
address@hidden
-Guile, the GNU extension language, which is the subject of this
-tutorial.
-
address@hidden itemize
-
-One lesson we can learn from looking at classical large software
-applications is that "writers of large programs" always end up throwing
-in some kind of parser for configuration or scripting.
-
-Of the examples listed above, Emacs Lisp, Tcl, Libscheme and Guile have
-an important property: they are not added as an afterthought for a
-specific application. They are general-purpose languages which a user
-can learn (even in college courses) and then use to customize the
-application program.
-
-This is a recent and (in my opinion) very exciting direction in
-large-program software engineering: program designers can link in the
-Guile or Tcl library from the very beginning, and tell their users "You
-want to customize this program? Just use Scheme (or Tcl, or whatever
-language), which you already know!"
address@hidden large programs
-
-
address@hidden History of Guile and its motivations
address@hidden History of Guile and its motivations
-
-A few separate threads of events led to the development of Guile.
-
-In the fall of 1994, Richard Stallman, director of the GNU project,
-posted an article with the subject "Why you should not use Tcl", in
-which he argued that Tcl is inadequate as an extension language. This
-generated a flurry of flames (available in the hypermail archive
-(@url{http://www.vanderburg.org/Tcl/war/}) @strong{The Tcl War}).
address@hidden Stallman, Richard
address@hidden GNU project
address@hidden Tcl
-
-The result was that Stallman then proposed his design for the GNU
-Extension Language, first called GEL and then renamed Guile. The
-discussion triggered by that article is also available in a hypermail
-archive, @url{http://www.vanderburg.org/Tcl/war2/}.
-
-One interesting feature of this GNU Extension Language plan was that
-users should have a @emph{choice} of languages to use in extending their
-program. The basic language would be a slightly modified Scheme, and
-translators would be written to convert other languages (like Tcl,
-Python, Perl, C-like languages @dots{}) into Scheme.
-
-Tom Lord started working on this project immediately, taking Aubrey
-Jaffer's small and portable implementation of Scheme, SCM, and making it
-into an embeddable interpreter: callable from C and allowing new Scheme
-procedures to be written in C.
address@hidden Lord, Tom
address@hidden Jaffer, Aubrey
-
-In the spring of 1995, the guile-ii snapshot was released. This made it
-possible to start writing code in C and Scheme using the guile
-facilities.
-
-The guile-iii snapshot was released the summer of 1995, and it had fixed
-enough problems so that the access to Scheme data structures from C was
-almost complete.
-
-After this, Cygnus Support added many features to Guile and finished
-implementing others, so that Guile acquired thread support, a regular
-expression matcher, a Tk interface, an interface to the SGI OpenGL
-graphics system, an @emph{applet} formalism, and some other packages.
-This was all in the Cygnus Guile r0.3 and r0.4 releases.
address@hidden Cygnus Support
-
-Meanwhile, Tom Lord left the project after having produced a divergent
-version of Guile: 1.0b2. The Free Software Foundation hired Jim Blandy
-to coordinate Guile development. The FSF released its first version of
-Guile in January 1997. In the future, many of the Cygnus packages will
-be re-integrated into Guile.
address@hidden Blandy, Jim
address@hidden Free Software Foundation
-
-
-
address@hidden How to characterize Guile
address@hidden How to characterize Guile
-
-I have already mentioned that Guile has become a kitchen sink package;
-here you can see how Guile freely takes new commands and constructs from
-the portable Scheme library @emph{slib}, the @emph{Tk} widget set, a
-posix library (useful for UNIX systems programming), the regular
-expression library @emph{rx}, and many more @dots{}
address@hidden slib
address@hidden Tk
address@hidden POSIX
address@hidden @cindex OpenGL
address@hidden rx
-
-So Guile has many more primitive procedures available to it than those
-specified in @ref{Standard Procedures, Revised(5) Report on the
-Algorithmic Language Scheme, , r5rs, Revised(5) Report on the
-Algorithmic Language Scheme}. On top of that, Guile will interpret
-almost all standard Scheme programs. The only incompatible difference
-between the basic Guile language and R5RS Scheme is that Guile is case
-sensitive, whereas R5RS is case insensitive. We hope that few people
-have written Scheme programs that depend on case insensitivity.
address@hidden case sensitivity
address@hidden Revised(5) Report on the Algorithmic Language Scheme
address@hidden report on Scheme
address@hidden Scheme language - report
address@hidden Scheme language - definition
-
-Here is a possible view of the @emph{sum of the parts} in Guile:
address@hidden extensions to standard Scheme
address@hidden extensions to R5RS
address@hidden Scheme extensions
address@hidden
-guile = standard Scheme (R5RS)
- PLUS extensions to R5RS offered by SCM
- PLUS some extra primitives offered by Guile (catch/throw)
- PLUS portable Scheme library (SLIB)
- PLUS embeddable Scheme interpreter library (libguile)
- PLUS Tk toolkit
- PLUS threads
- PLUS Posix library
address@hidden PLUS OpenGL library (mesa)
address@hidden PLUS OpenGL toolkit (glut)
- PLUS Regular expression library (rx)
address@hidden PLUS Applet formalism
- PLUS Tcl library
address@hidden example
-
-
address@hidden Using Guile to program in Scheme
address@hidden Using Guile to program in Scheme
address@hidden Scheme programming tutorial
address@hidden tutorial on Scheme programming
-
-In this section I give a tutorial introduction to programming in Scheme,
-with a slant toward the interesting things that can be done in Guile.
-
address@hidden Applets are so @emph{chic} that they get their own section, but
this
-This section will try to touch on many of the interesting and cool
-aspects of Guile, showing you how new types of problems can be solved
-with Guile. Note that using Guile as a library with @code{libguile.a}
-is described in its own chapter (@pxref{Guile in a Library}). Also note
-that some small examples are given in @ref{Jump Start}.
-
-To get started you need to know how to program in @dfn{Scheme} (a
-dialect of LISP). Fortunately Scheme is a small, clean language and is
-not hard to learn. It is also used in many undergraduate courses to
-introduce computer programming.
address@hidden lisp dialects
-
-I will not try to teach you Scheme here (although you might end up
-learning by example), since there are many good books on the subject,
-listed in @ref{Where to find more Guile/Scheme resources}. @footnote{To
-get started, look at the books @cite{Simply Scheme} and @cite{The Little
-Schemer} from that list.}
-
-
address@hidden Hello World
address@hidden hello world
-
-Our first program is the typical Scheme "hello world" program. Put the
-following code in a file called @code{hello.scm} (this can be find in
address@hidden/scheme/hello.scm}).
-
address@hidden
-#!/usr/local/bin/guile -s
-!#
-
-(display "hello world")
-(newline)
address@hidden smalllisp
-
-Then run guile on it. One way to do so is to start up guile and load
-this file:
-
address@hidden
-<shell-prompt> @kbd{guile}
-guile> @kbd{(load "hello")}
address@hidden smallexample
-
-Another way is to make the file executable and execute it directly.
-Notice how Guile recognizes a @code{-s} option which tells it to run a
-script and then exit. Guile also has a new type of block comment
-enclosed by @code{#!} and @code{!#}, so that you can make executable
-Scheme scripts with the standard UNIX @code{#!} mechanism.
-
-In the given example, the first line is used to invoke the Guile
-interpreter (make sure you correct the path if you installed Guile in
-something other than /usr/local/bin). Once Guile is invoked on this
-file, it will understand that the first line is a comment. The comment
-is then terminated with @code{!#} on the second line so as to not
-interfere with the execution mechanism.
-
-
address@hidden A bunch of operations in Scheme
-
-Here is some code you can type at the @code{guile>} prompt to see some
-of the Scheme data types at work (mostly lists and vectors). I have
-inserted brief comments @emph{before} each line of code explaining what
-happens.
-
address@hidden
-;; @r{make a list and bind it to the symbol @code{ls}}
-guile> @kbd{(define ls (list 1 2 3 4 5 6 7))}
- @result{}
-;; @r{display the list}
-guile> @kbd{ls}
- @result{} (1 2 3 4 5 6 7)
-;; @r{ask if @code{ls} is a vector; @code{#f} means it is not}
-guile> @kbd{(vector? ls)}
- @result{} #f
-;; @r{ask if @code{ls} is a list; @code{#t} means it is}
-guile> @kbd{(list? ls)}
- @result{} #t
-;; @r{ask for the length of @code{ls}}
-guile> @kbd{(length ls)}
- @result{} 7
-;; @r{pick out the first element of the list}
-guile> @kbd{(car ls)}
- @result{} 1
-;; @r{pick the rest of the list without the first element}
-guile> @kbd{(cdr ls)}
- @result{} (2 3 4 5 6 7)
-;; @r{this should pick out the 3rd element of the list}
-guile> @kbd{(car (cdr (cdr ls)))}
- @result{} 3
-;; @r{a shorthand for doing the same thing}
-guile> @kbd{(caddr ls)}
- @result{} 3
-;; @r{append the given list onto @code{ls}, print the result}
-;; @address@hidden:} the original list @code{ls} is @emph{not} modified}
-guile> @kbd{(append ls (list 8 9 10))}
- @result{} (1 2 3 4 5 6 7 8 9 10)
-guile> @kbd{(reverse ls)}
- @result{} (7 6 5 4 3 2 1)
-;; @r{ask if 12 is in the list --- it obviously is not}
-guile> @kbd{(memq 12 ls)}
- @result{} #f
-;; @r{ask if 4 is in the list --- returns the list from 4 on.}
-;; @r{Notice that the result will behave as true in conditionals}
-guile> @kbd{(memq 4 ls)}
- @result{} (4 5 6 7)
-;; @r{an @code{if} statement using the aforementioned result}
-guile> @kbd{(if (memq 4 ls)
- (display "hey, it's true!\n")
- (display "dude, it's false\n"))}
- @print{hey, it's true!}
- @result{}
-guile> @kbd{(if (memq 12 ls)
- (display "hey, it's true!\n")
- (display "dude, it's false\n"))}
- @print{dude, it's false}
- @result{}
-guile> @kbd{(memq 4 (reverse ls))}
- @result{} (4 3 2 1)
-;; @r{make a smaller list @code{ls2} to work with}
-guile> @kbd{(define ls2 (list 2 3 4))}
-;; @r{make a list in which the function @code{sin} has been}
-;; @r{applied to all elements of @code{ls2}}
-guile> @kbd{(map sin ls2)}
- @result{} (0.909297426825682 0.141120008059867 -0.756802495307928)
-;; @r{make a list in which the squaring function has been}
-;; @r{applied to all elements of @code{ls}}
-guile> @kbd{(map (lambda (n) (* n n)) ls)}
- @result{} (1 4 9 16 25 36 49)
address@hidden smalllisp
-
address@hidden
-;; @r{make a vector and bind it to the symbol @code{v}}
-guile> @kbd{(define v '#(1 2 3 4 5 6 7))}
-guile> @kbd{v}
- @result{} #(1 2 3 4 5 6 7)
-guile> @kbd{(vector? v)}
- @result{} #t
-guile> @kbd{(list? v)}
- @result{} #f
-guile> @kbd{(vector-length v)}
- @result{} 7
-;; @r{vector-ref allows you to pick out elements by index}
-guile> @kbd{(vector-ref v 2)}
- @result{} 3
-;; @r{play around with the vector: make it into a list, reverse}
-;; @r{the list, go back to a vector and take the second element}
-guile> @kbd{(vector-ref (list->vector (reverse (vector->list v))) 2)}
- @result{} 5
-;; @r{this demonstrates that the entries in a vector do not have}
-;; @r{to be of uniform type}
-guile> @kbd{(vector-set! v 4 "hi there")}
- @result{} "hi there"
-guile> @kbd{v}
- @result{} #(1 2 3 4 "hi there" 6 7)
address@hidden smalllisp
-
-
address@hidden Using recursion to process lists
address@hidden recursion
address@hidden list processing
-
-Here are some typical examples of using recursion to process a list.
-
address@hidden
-;; @r{this is a rather trivial way of reversing a list}
-(define (my-reverse l)
- (if (null? l)
- l
- (append (my-reverse (cdr l)) (list (car l)))))
-(my-reverse '(27 32 33 40))
address@hidden (40 33 32 27)
address@hidden smalllisp
-
-
address@hidden Processing matrices
-
-Suppose you have a matrix represented as a list of lists:
-
address@hidden
-(define m
- (list
- (list 7 2 1 3 2 8 5 3 6)
- (list 4 1 1 1 3 8 9 8 1)
- (list 5 5 4 8 1 8 2 2 4)))
address@hidden smalllisp
-
-Then you could apply a certain function to each element of the matrix in
-the following manner:
address@hidden
-;; @r{apply the function func to the matrix m element-by-element;}
-;; @r{return a matrix with the result.}
-(define (process-matrix m func)
- (map (lambda (l)
- (map func l))
- m))
address@hidden smalllisp
-Notice that I have used the Scheme @code{map} procedure because I am
-interested in the matrix that results from the application of
address@hidden, rather than in the side effects associated with applying
address@hidden
-
-This could be invoked with @code{(process-matrix m sin)} or
address@hidden(process-matrix m (lambda (x) (* x x)))}; for example:
-
address@hidden
-(process-matrix m (lambda (x) (* x x)))
address@hidden ((49 4 1 9 4 64 25 9 36) (16 1 1 1 9 64 81 64 1) (25 25 16 64 1
64 4 4 16))
address@hidden smalllisp
-
-To print a representation of the matrix, we could define a generalized
-routine:
address@hidden
-;; @r{proc is a procedure to represent the single element,}
-;; @r{row-proc is a procedure that is invoked after each row.}
-;; @r{Example: proc could be (lambda (x) (begin (display x) (display " ")))}
-;; @r{and row-proc could be (lambda (l) (display "\n"))}
-(define (represent-matrix m proc row-proc)
- (for-each (lambda (l)
- (begin
- (for-each proc l)
- (row-proc l)))
- m))
address@hidden smalllisp
address@hidden represent-matrix
-
-And then invoke it with
address@hidden
-(represent-matrix m
- (lambda (x) (begin (display x) (display " ")))
- (lambda (l) (begin (display "\n"))))
address@hidden 2 1 3 2 8 5 3 6}
address@hidden 1 1 1 3 8 9 8 1}
address@hidden 5 4 8 1 8 2 2 4}
address@hidden smalllisp
-
address@hidden objects
-
-Now we write a helper routine that uses Scheme @dfn{closures} to make
-objects with state that then receive messages to draw little squares.
address@hidden closures
address@hidden syntactic closures
-
-But let us take it one step at a time. I will start by showing you a
-simple example of object in Scheme. The object I make here represents a
-cell, which could be a cell in a matrix. The cell responds to commands
-to draw itself, to return the next cell, and so forth. @emph{Guile does
-not currently have a Tk interface, so I will leave the hooks for
-graphical rendering. In a future release of Guile I will add graphical
-rendering messages to the cell object.}
-
address@hidden
-;; @r{cell-object.scm: routines for creating and manipulating cell objects}
-
-;; @r{(the-x, the-y) is the initial position of the cell.}
-;; @r{the-color is a string representing a color; must be something Tk can
grok.}
-;; @r{square-size is the size of the square that gets drawn.}
-;; @r{(sizex, sizey) is the size of the matrix.}
-(define (MAKE-CELL the-x the-y the-color square-size sizex sizey)
- (define (get-x) the-x)
- (define (get-y) the-y)
-
- (define (set-x! new-x)
- (set! the-x new-x)
- the-x)
- (define (set-y! new-y)
- (set! the-y new-y)
- the-y)
- (define (get-color) the-color)
- (define (set-color! new-color)
- (set! the-color new-color)
- the-color)
- (define (next!)
- (set! the-x (+ the-x 1))
- (if (>= the-x sizex)
- (begin
- (set! the-x 0)
- (set! the-y (+ the-y 1))))
- (if (>= the-y sizey)
- (begin
- (display "CELL next!: value of y is too big; not changing it\n")
- (set! the-y (- the-y 1))))
- (cons the-x the-y))
- (define (draw)
- (let* ((x0 (* the-x square-size))
- (y0 (* the-y square-size))
- (x1 (+ x0 square-size))
- (y1 (+ y0 square-size)))
- (display "I should draw a ")
- (display the-color)
- (display " rectangle with corners at ")
- (display x0) (display y0) (display x1) (display y1)
- ))
-
- ;; self is the dispatch procedure
- (define (self message)
- (case message
- ((x) get-x)
- ((y) get-y)
- ((set-x!) set-x!)
- ((set-y!) set-y!)
- ((color) get-color)
- ((set-color!) set-color!)
- ((next!) next!)
- ((draw) draw)
- (else (error "CELL: Unknown message -> " message))))
- ;; and now return the dispatch procedure
- self
- )
address@hidden smallexample
address@hidden cell-object
address@hidden MAKE-CELL
-
-What does this procedure do? It returns another procedure
-(@code{self}) which receives a message (x, y, set-x!, set-y!, @dots{})
-and takes an action to return or modify its state. The state consists
-of the values of variables @code{the-x}, @code{the-y}, @code{the-color}
-and so forth.
-
-Here are some examples of how to use MAKE-CELL and the cell object it
-creates:
address@hidden
-(define c (MAKE-CELL 0 0 "red" 10 7 9))
-
-;; @r{retrieve the x and y coordinates}
-((c 'x))
address@hidden 0
-((c 'y))
address@hidden 0
-;; @r{change the x coordinate}
-((c 'set-x!) 5)
address@hidden 5
-((c 'x))
address@hidden 5
-;; @r{change the color}
-((c 'color))
address@hidden "red"
-((c 'set-color!) "green")
address@hidden "green"
-((c 'color))
address@hidden "green"
-;; @r{now use the next! message to move to the next cell}
-((c 'next!))
address@hidden (6 . 0)
-((c 'x))
address@hidden 6
-((c 'y))
address@hidden 0
-;; @r{now make things wrap around}
-((c 'next!))
address@hidden (0 . 1)
-((c 'next!))
address@hidden (1 . 1)
-((c 'next!))
address@hidden (2 . 1)
-((c 'x))
address@hidden 2
-((c 'y))
address@hidden 1
address@hidden smallexample
-
-You will notice that expressions like @code{(c 'next)} return procedures
-that do the job, so we have to use extra parentheses to make the job
-happen. This syntax is rather awkward; one way around it is to define a
address@hidden procedure:
-
address@hidden
-;; @r{send makes object syntax a bit easier; instead of saying}
-;; @r{ ((my-cell 'set-x!) 4)}
-;; @r{you can say}
-;; @r{ (send my-cell 'set-x! 4)}
-(define (send obj . args)
- (let ((first-eval (apply obj (list (car args)))))
- (if (null? (cdr args))
- (first-eval)
- (apply first-eval (cdr args)))))
address@hidden smallexample
address@hidden send
-
-You can see that @code{send} passes the message to the object, making
-sure that things are evaluated the proper number of times. You can now
-type:
-
address@hidden
-(define c2 (MAKE-CELL 0 0 "red" 10 7 9))
-(send c2 'x)
address@hidden 0
-(send c2 'set-x! 5)
address@hidden 5
-(send c2 'color)
address@hidden "red"
-(send c2 'set-color! "green")
address@hidden "green"
-(send c2 'next!)
address@hidden (1 . 0)
-(send c2 'x)
address@hidden 1
-(send c2 'y)
address@hidden 0
address@hidden smallexample
-
address@hidden object-based programming
address@hidden object-oriented programming
-
-This is the simplest way of implementing objects in Scheme, but it does
-not really allow for full @emph{object-oriented programming} (for
-example, there is no inheritance). But it is useful for
address@hidden programming}.
-
-Guile comes with a couple more complete object-oriented extensions to
-Scheme: these are part of slib (@pxref{Object, , , slib, SLIB: the
-portable Scheme library} and @pxref{Yasos, , , slib, SLIB: the portable
-Scheme library}).
-
address@hidden Guile in a Library
address@hidden Guile in a Library
-
address@hidden
address@hidden
address@hidden iftex
-In the previous chapters Guile was used to write programs entirely in
-Scheme, and no C code was seen; but I have been claiming @emph{ad
-nauseam} that Guile is an @emph{extension} language. Here we see how
-that is done, and how that can be useful.
address@hidden libguile
address@hidden extending C programs
-
-
address@hidden
-* Two world views::
-* What is libguile::
-* How to get started with libguile::
-* More interesting programming with libguile::
-* Further examples::
address@hidden menu
-
address@hidden Two world views
address@hidden Two world views
address@hidden master world
-
-In this manual, I usually jump into examples and explain them as you
-type in the code; here I will digress and ramble for a few paragraphs to
-set some concepts straight, and then let you type (or paste) in fun
-examples.
-
-In 1995, I implemented a large program, @dfn{Gnudl}, using Guile quite
-extensively. In the design phase of Gnudl, I found I had to make a
-choice: should the fundamental data structures be C or Scheme data
-structures?
address@hidden gnudl
address@hidden GNU Data Language
address@hidden Galassi, Mark
-
-Guile allows C to see its data structures (scalar types, lists, vectors,
-strings @dots{}). C also allows Guile to see its data structures. As a
-large program designer, you have to decide which of those capabilities
-to use. You have two main choices:
-
address@hidden 1
address@hidden
-You can write your software mostly in Scheme. In this case, your C
-software will mostly parse the Scheme code with Guile calls, and provide
-some new primitive procedures to be used by Scheme. This is what Gnudl
-does.
-
address@hidden
-You can write your software mostly in C, occasionally allowing Scheme
-code to be parsed by Guile, either to allow the user to modify data
-structures, or to parse a configuration file, @dots{}
address@hidden enumerate
-
-Mixing the two approaches seems unwise: the overall layout would be
-confusing. But who knows? There might be problems that are best solved
-by a hybrid approach. Please let me know if you think of such a
-problem.
-
-If you use the former approach, we will say that the @dfn{master world}
-is Scheme, and the C routines serve Scheme and access Scheme data
-structures. In the latter case, the master world is C, and Scheme
-routines serve the C code and access C data structures.
-
-In both approaches the @code{libguile.a} library is the same, but a
-predominantly different set of routines will be used. When we go
-through examples of libguile use, we will point out which is the master
-world in order to clarify these two approaches.
-
-
address@hidden What is libguile
address@hidden What is libguile
address@hidden libguile
address@hidden gh interface
address@hidden scm interface
-
address@hidden is the library which allows C programs to start a Scheme
-interpreter and execute Scheme code. There are also facilities in
-libguile to make C data structures available to Scheme, and vice versa.
-
-The interface provided by the libguile C library is somewhat specific to
-the implementation of the Scheme interpreter. This low-level libguile
-interface is usually referred to as the @code{scm_} interface, since its
-public calls (API) all have the @code{scm_} prefix.
-
-There is also a higher-level libguile interface, which is usually
-referred to as the @code{gh_} interface (libGuile High). Its public
-calls all have the @code{gh_} prefix. The @code{gh_} library interface
-is designed to hide the implementation details, thus making it easier to
-assimilate and portable to other underlying Scheme implementations.
-
-People extending Guile by adding bindings to C libraries (like OpenGL or
-Rx) are encouraged to use the @code{gh_} interface, so their work will
-be portable to other Scheme systems. The @code{gh_} interface should be
-more stable, because it is simpler.
-
-The @code{scm_} interface is necessary if you want to poke into the
-innards of Scheme data structures, or do anything else that is not
-offered by the @code{gh_} interface. It is not covered in this
-tutorial, but is covered extensively in @ref{Data representation,, Data
-Representation in Guile, guile, Guile Reference Manual}.
-
-This chapter gives a gentle introduction to the @code{gh_} interface,
-presenting some @emph{hello world}-style programs which I wrote while
-teaching myself to use libguile.
address@hidden hello world
-
-The @cite{Guile Programmer's Manual} gives more examples of programs
-written using libguile, illustrating diverse applications. You can also
-consult my @emph{Gnudl} documentation at
address@hidden://nis-www.lanl.gov/~rosalia/mydocs/} to see a large scale
-project that uses C and Scheme code together.
-
-
address@hidden How to get started with libguile
address@hidden How to get started with libguile
address@hidden learn0
-
-Here is an elementary first program, @code{learn0}, to get going with
-libguile. The program (which uses Scheme as a master world) is in a
-single source file, @code{learn0.c}:
-
address@hidden
-/* @r{test the new libgh.a (Guile High-level library) with a trivial
- program} */
-
-#include <stdio.h>
-
-#include <guile/gh.h>
-
-void main_prog(int argc, char *argv[]);
-
-main(int argc, char *argv[])
address@hidden
- gh_enter(argc, argv, main_prog);
address@hidden
-
-void main_prog(int argc, char *argv[])
address@hidden
- int done;
- char input_str[200];
-
- gh_eval_str("(display \"hello Guile\")");
- gh_eval_str("(newline)");
-
- /* @r{for fun, evaluate some simple Scheme expressions here} */
- gh_eval_str("(define (square x) (* x x))");
- gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))");
- gh_eval_str("(square 9)");
-
- /* @r{now sit in a Scheme eval loop: I input the expressions, have
- Guile evaluate them, and then get another expression.} */
- done = 0;
- fputs("learn0> ", stdout);
- while (fgets(input_str, 199, stdin) != NULL) @{
- gh_eval_str(input_str);
- fputs("\nlearn0> ", stdout);
- @}
-
- exit(0);
address@hidden
address@hidden smallexample
-
-If you name this program @code{learn0.c}, it can now be compiled with:
address@hidden
-gcc -g -c learn0.c -o learn0.o
-gcc -o learn0 learn0.o -lguile -lm
address@hidden smallexample
-
address@hidden @emph{NOTE: If you are in the Guile development tree, you can
simply do
address@hidden ``cd doc/examples/c; make; ./learn0''.}
-
-The program is simple: it creates a Scheme interpreter, passes a couple
-of strings to it that define new Scheme functions @code{square} and
address@hidden, and then a couple of strings that invoke those
-functions.
-
-It then goes into a read-eval-print-loop (REPL), so you could type
-one-line Scheme expressions to it and have them evaluated. For example:
address@hidden
-<shell-prompt> ./learn0
-hello Guile
-learn0> (display (sin 1.3))
-963.558185417193e-3
-learn0> (display (fact 10))
-3628800
-learn0> (quit)
-<shell-prompt>
address@hidden smallexample
-
-You should notice the key steps involved in this @code{learn0} program:
-
address@hidden
address@hidden
address@hidden
address@hidden <guile/gh.h>}
address@hidden
-You need to invoke the initialization routine @code{gh_enter()}. This
-starts up a Scheme interpreter, handling many implementation-specific
-details.
address@hidden
-Your main() function should be almost empty: the real main program goes
-in a separate function main_prog() which is passed to gh_enter(). This
-rather arcane convention is due to the way Guile's garbage collector
-works: the whole program has to run in the dynamic context of
address@hidden()}.
address@hidden
-You pass strings to the Scheme interpreter with the @code{gh_eval_str()}
-routine.
address@hidden
-You link your program with @code{-lguile}.
address@hidden enumerate
address@hidden cartouche
-
-
address@hidden More interesting programming with libguile
address@hidden More interesting programming with libguile
address@hidden learn1
address@hidden callback
address@hidden builtin functions
-
-The @code{learn0} program shows how you can invoke Scheme commands from
-a C program. This is not such a great achievement: the same could have
-been done by opening a pipe to SCM or any other Scheme interpreter.
-
-A true extension language must allow @dfn{callbacks}. Callbacks allow
-you to write C routines that can be invoked as Scheme procedures, thus
-adding new primitive procedures to Scheme. This also means that a
-Scheme procedure can modify a C data structure.
-
-Guile allows you to define new Scheme procedures in C, and provides a
-mechanism to go back and forth between C and Scheme data types.
-
-Here is a second program, @code{learn1}, which demonstrates these
-features. It is split into three source files: @code{learn1.c},
address@hidden and @code{c_builtins.c}. I am including the code
-here.
address@hidden , but you might just want to look at the online source code and
the
address@hidden Makefile.am that come with Guile in the
address@hidden @file{doc/examples/c} directory.
-
-Notice that @code{learn1} uses a Scheme master world, and the C routines
-in @code{c_builtins.c} are simply adding new primitives to Scheme.
-
address@hidden
-* learn1.c::
-* c_builtins.h::
-* c_builtins.c::
-* What learn1 is doing::
-* Compiling and running learn1::
address@hidden menu
-
address@hidden learn1.c
address@hidden learn1.c
-
-Here is @file{learn1.c}:
address@hidden
-#include <stdio.h>
-
-#include <guile/gh.h>
-
-#include "c_builtins.h"
-
-void main_prog(int argc, char *argv[]);
-
-main(int argc, char *argv[])
address@hidden
- gh_enter(argc, argv, main_prog);
address@hidden
-
-void main_prog(int argc, char *argv[])
address@hidden
- char input_str[200]; /* @r{ugly hack: assume strlen(line) < 200} */
- int done;
-
- /* @r{for fun, evaluate some simple Scheme expressions here} */
- gh_eval_str("(define (square x) (* x x))");
- gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))");
- gh_eval_str("(square 9)");
- gh_eval_str("(fact 100)");
-
- /* @r{now try to define some new builtins, coded in C, so that they are
- available in Scheme.} */
- gh_new_procedure1_0("c-factorial", c_factorial);
- gh_new_procedure1_0("c-sin", c_sin);
- gh_new_procedure1_0("v-t", vector_test);
-
- /* @r{now sit in a Scheme eval loop: I input the expressions, have
- Guile evaluate them, and then get another expression.} */
- done = 0;
- fputs("learn1> ", stdout);
- while (!done) @{
- if (gets(input_str) == NULL) @{
- done = 1;
- @} else @{
- gh_eval_str(input_str);
- fputs("learn1> ", stdout);
- @}
- @}
-
- exit(0);
address@hidden
address@hidden smallexample
-
address@hidden c_builtins.h
address@hidden c_builtins.h
-
-Here is @file{c_builtins.h}:
address@hidden
-/* @r{builtin function prototypes} */
-
-#include <guile/gh.h>
-
-SCM c_factorial(SCM n);
-SCM c_sin(SCM n);
-SCM vector_test(SCM s_length);
address@hidden smallexample
-
address@hidden c_builtins.c
address@hidden c_builtins.c
-
-Here is @file{c_builtins.c}:
address@hidden
-#include <stdio.h>
-#include <math.h>
-
-#include <guile/gh.h>
-
-#include "c_builtins.h"
-
-/* @r{this is a factorial routine in C, made to be callable by Scheme} */
-SCM c_factorial(SCM s_n)
address@hidden
- int i;
- unsigned long result = 1, n;
-
- n = gh_scm2ulong(s_n);
-
- gh_defer_ints();
- for (i = 1; i <= n; ++i) @{
- result = result*i;
- @}
- gh_allow_ints();
- return gh_ulong2scm(result);
address@hidden
-
-/* @r{a sin routine in C, callable from Scheme. it is named c_sin() to
- distinguish it from the default Scheme sin function} */
-SCM c_sin(SCM s_x)
address@hidden
- double x = gh_scm2double(s_x);
-
- return gh_double2scm(sin(x));
address@hidden
-
-/* @r{play around with vectors in Guile: this routine creates a vector of
- the given length, initializes it all to zero except element 2 which
- is set to 1.9.} */
-SCM vector_test(SCM s_length)
address@hidden
- SCM xvec;
-
- c_length = gh_scm2ulong(s_length);
- printf("requested length for vector: %ld\n", gh_scm2ulong(s_length));
-
- /* create a vector */
- xvec = gh_make_vector(s_length, gh_double2scm(0.0));
- /* set the second element in it */
- gh_vector_set_x(xvec, gh_int2scm(2), gh_double2scm(1.9));
-
- return xvec;
address@hidden
address@hidden smallexample
-
address@hidden What learn1 is doing
address@hidden What learn1 is doing
address@hidden registering callbacks
address@hidden registering C functions
address@hidden primitive procedures
-
-If you compare learn1 to learn0, you will find that learn1 uses a new
-Guile construct: the function @code{gh_new_procedure()}, and its
-siblings:
-
address@hidden
- /* @r{now try to define some new builtins, coded in C, so that they are
- available in Scheme.} */
- gh_new_procedure1_0("c-factorial", c_factorial);
- gh_new_procedure1_0("c-sin", c_sin);
- gh_new_procedure1_0("v-t", vector_test);
address@hidden smallexample
-
-It is clear that @code{gh_new_procedure()} adds a new builtin
-routine written in C which can be invoked from Scheme. We can now
-revise our checklist for programming with libguile, so it includes
-adding callbacks.
address@hidden libguile - step by step
-
address@hidden
address@hidden
address@hidden
address@hidden <guile/gh.h>}
address@hidden
-You need to invoke the initialization routine @code{gh_enter()}. This
-starts up a Scheme interpreter, handling many details.
address@hidden
-Your main() function should be almost empty: the real main program goes
-in a separate function main_prog() which is passed to gh_enter(). This
-rather arcane convention is due to the way Guile's garbage collector
-works: the whole program has to run in the dynamic context of
address@hidden()}.
address@hidden
-You pass strings to the Scheme interpreter with the @code{gh_eval_str()}
-routine.
address@hidden
address@hidden You can now define new builtin Scheme functions;
-i.e. define new builtin Scheme functions, with the
address@hidden()} routine.
address@hidden
-You pass strings to the Scheme interpreter with the
address@hidden()} routine.
address@hidden
-You link your program with @code{-lguile}.
address@hidden enumerate
address@hidden cartouche
-
-I breezed by the issue of how to write your C routines that are
-registered to be called from Scheme. This is non-trivial, and is
-discussed at length in the @cite{Guile Programmer's Manual}.
-
-
address@hidden Compiling and running learn1
address@hidden Compiling and running learn1
-
address@hidden
-gcc -g -c learn1.c -o learn1.o
-gcc -g -c c_builtins.c -o c_builtins.o
-gcc -o learn1 learn1.o c_builtins.o -lguile -lm
address@hidden smallexample
-
-If you run @code{learn1}, it will prompt you for a one-line Scheme
-expression, just as @code{learn0} did. The difference is that you can
-use the new C builtin procedures (@code{c-factorial}, @code{c-sin},
address@hidden).
-
address@hidden
-<shell-prompt> ./learn1
-welcome to Guile
-hello Guile
-learn1> (display (c-factorial 6))
-720
-learn1> (display (c-factorial 20))
-2192834560
-learn1> (display (c-factorial 100))
-0
-learn1> (display (c-sin 1.5))
-0.997494986604054
-learn1> (display (v-t 10))
-requested length for vector: 10
-#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0)
-learn1> (display (v-t 15))
-requested length for vector: 15
-#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)
-learn1> (quit)
-<shell-prompt>
address@hidden smallexample
-
-As you see, taking @code{(c-factorial 100)} does not use bignumbers and
-returns a bogus answer.
-
address@hidden Further examples
address@hidden Further examples
-
-Further ``idealized'' examples are included in the @code{doc/examples/c}
-distribution. They include programs to:
-
address@hidden [FIXME: still have to write some of these; then I will revise
the list.]
-
address@hidden @bullet
address@hidden
-Parse a startup file (C is the master world).
address@hidden
-Set up initial conditions for an n-body simulation (C is the master
-world).
address@hidden
-Implement a Scheme interpreter with all of Guile's goodies, @emph{plus}
-the readline library @emph{and} a fast Fourier transform routine
-provided in C (Scheme is the master world).
address@hidden itemize
-
address@hidden Regular Expression Support
address@hidden Regular Expression Support
-
address@hidden UNIX System Programming
address@hidden UNIX System Programming
-
address@hidden Where to find more Guile/Scheme resources
address@hidden Where to find more Guile/Scheme resources
-
-
address@hidden Concept Index
address@hidden Concept Index
-
address@hidden cp
-
address@hidden Procedure and Macro Index
address@hidden Procedure and Macro Index
-
-This is an alphabetical list of all the procedures and macros in Dominion.
-
address@hidden fn
-
address@hidden Variable Index
address@hidden Variable Index
-
-This is an alphabetical list of the major global variables in Dominion.
-
address@hidden vr
-
address@hidden Type Index
address@hidden Type Index
-
-This is an alphabetical list of the major data structures in Dominion.
-
address@hidden tp
-
address@hidden
-
address@hidden
diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am
index efdcd75..8d22b24 100644
--- a/guile-readline/Makefile.am
+++ b/guile-readline/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008, 2009,
2010 Free Software Foundation, Inc.
##
## This file is part of guile-readline.
##
@@ -45,7 +45,7 @@ lib_LTLIBRARIES = address@hidden@.la
address@hidden@_la_SOURCES = readline.c
address@hidden@_la_LIBADD = \
$(READLINE_LIBS) \
- ../libguile/libguile.la ../lib/libgnu.la
+ ../libguile/address@hidden@.la ../lib/libgnu.la
address@hidden@_la_LDFLAGS = \
-version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic \
@@ -54,7 +54,8 @@ address@hidden@_la_LDFLAGS = \
BUILT_SOURCES = readline.x
-pkginclude_HEADERS = readline.h
+modincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)
+modinclude_HEADERS = readline.h
snarfcppopts = $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
SUFFIXES = .x
diff --git a/lib/Makefile.am b/lib/Makefile.am
index b33fb6d..149586e 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -1,6 +1,6 @@
## DO NOT EDIT! GENERATED AUTOMATICALLY!
## Process this file with automake to produce Makefile.in.
-# Copyright (C) 2002-2009 Free Software Foundation, Inc.
+# Copyright (C) 2002-2010 Free Software Foundation, Inc.
#
# This file is free software, distributed under the terms of the GNU
# General Public License. As a special exception to the GNU General
@@ -9,7 +9,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib
--m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3
--libtool --macro-prefix=gl --no-vc-files alignof alloca-opt announce-gen
autobuild byteswap canonicalize-lgpl duplocale environ extensions flock fpieee
full-read full-write gendocs gitlog-to-changelog gnu-web-doc-update gnupload
havelib iconv_open-utf inet_ntop inet_pton lib-symbol-versions
lib-symbol-visibility libunistring locale maintainer-makefile putenv stdlib
strcase strftime striconveh string sys_stat verify version-etc-fsf vsnprintf
warnings
+# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib
--m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3
--libtool --macro-prefix=gl --no-vc-files alignof alloca-opt announce-gen
autobuild byteswap canonicalize-lgpl duplocale environ extensions flock fpieee
full-read full-write func gendocs getaddrinfo gitlog-to-changelog
gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton
lib-symbol-versions lib-symbol-visibility libunistring locale
maintainer-makefile putenv stdlib strcase strftime striconveh string sys_stat
verify version-etc-fsf vsnprintf warnings
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
@@ -71,6 +71,11 @@ EXTRA_DIST += $(top_srcdir)/build-aux/announce-gen
## begin gnulib module arg-nonnull
+# The BUILT_SOURCES created by this Makefile snippet are not used via #include
+# statements but through direct file reference. Therefore this snippet must be
+# present in all Makefile.am that need it. This is ensured by the applicability
+# 'all' defined above.
+
BUILT_SOURCES += arg-nonnull.h
# The arg-nonnull.h that gets inserted into generated .h files is the same as
# build-aux/arg-nonnull.h, except that it has the copyright header cut off.
@@ -90,11 +95,11 @@ EXTRA_DIST += $(top_srcdir)/build-aux/arg-nonnull.h
## begin gnulib module arpa_inet
-BUILT_SOURCES += $(ARPA_INET_H)
+BUILT_SOURCES += arpa/inet.h
# We need the following in order to create <arpa/inet.h> when the system
# doesn't have one.
-arpa/inet.h: arpa_inet.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+arpa/inet.h: arpa_inet.in.h $(WARN_ON_USE_H) $(ARG_NONNULL_H)
$(AM_V_at)$(MKDIR_P) arpa
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
@@ -106,8 +111,8 @@ arpa/inet.h: arpa_inet.in.h $(LINK_WARNING_H)
$(ARG_NONNULL_H)
-e 's|@''GNULIB_INET_PTON''@|$(GNULIB_INET_PTON)|g' \
-e 's|@''HAVE_DECL_INET_NTOP''@|$(HAVE_DECL_INET_NTOP)|g' \
-e 's|@''HAVE_DECL_INET_PTON''@|$(HAVE_DECL_INET_PTON)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
< $(srcdir)/arpa_inet.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -136,6 +141,30 @@ EXTRA_DIST += byteswap.in.h
## end gnulib module byteswap
+## begin gnulib module c++defs
+
+# The BUILT_SOURCES created by this Makefile snippet are not used via #include
+# statements but through direct file reference. Therefore this snippet must be
+# present in all Makefile.am that need it. This is ensured by the applicability
+# 'all' defined above.
+
+BUILT_SOURCES += c++defs.h
+# The c++defs.h that gets inserted into generated .h files is the same as
+# build-aux/c++defs.h, except that it has the copyright header cut off.
+c++defs.h: $(top_srcdir)/build-aux/c++defs.h
+ $(AM_V_GEN)rm -f address@hidden $@ && \
+ sed -n -e '/_GL_CXXDEFS/,$$p' \
+ < $(top_srcdir)/build-aux/c++defs.h \
+ > address@hidden && \
+ mv address@hidden $@
+MOSTLYCLEANFILES += c++defs.h c++defs.h-t
+
+CXXDEFS_H=c++defs.h
+
+EXTRA_DIST += $(top_srcdir)/build-aux/c++defs.h
+
+## end gnulib module c++defs
+
## begin gnulib module c-ctype
libgnu_la_SOURCES += c-ctype.h c-ctype.c
@@ -310,6 +339,15 @@ EXTRA_DIST += $(top_srcdir)/build-aux/gendocs.sh
## end gnulib module gendocs
+## begin gnulib module getaddrinfo
+
+
+EXTRA_DIST += gai_strerror.c getaddrinfo.c
+
+EXTRA_libgnu_la_SOURCES += gai_strerror.c getaddrinfo.c
+
+## end gnulib module getaddrinfo
+
## begin gnulib module gettext-h
libgnu_la_SOURCES += gettext.h
@@ -360,13 +398,13 @@ EXTRA_DIST += $(top_srcdir)/build-aux/config.rpath
## end gnulib module havelib
-## begin gnulib module iconv_open
+## begin gnulib module iconv-h
BUILT_SOURCES += $(ICONV_H)
# We need the following in order to create <iconv.h> when the system
# doesn't have one that works with the given compiler.
-iconv.h: iconv.in.h $(ARG_NONNULL_H)
+iconv.h: iconv.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -376,12 +414,20 @@ iconv.h: iconv.in.h $(ARG_NONNULL_H)
-e 's|@''REPLACE_ICONV''@|$(REPLACE_ICONV)|g' \
-e 's|@''REPLACE_ICONV_OPEN''@|$(REPLACE_ICONV_OPEN)|g' \
-e 's|@''REPLACE_ICONV_UTF''@|$(REPLACE_ICONV_UTF)|g' \
+ -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)/iconv.in.h; \
} > address@hidden && \
mv address@hidden $@
MOSTLYCLEANFILES += iconv.h iconv.h-t
+EXTRA_DIST += iconv.in.h
+
+## end gnulib module iconv-h
+
+## begin gnulib module iconv_open
+
iconv_open-aix.h: iconv_open-aix.gperf
$(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf >
$(srcdir)/iconv_open-aix.h-t
mv $(srcdir)/iconv_open-aix.h-t $(srcdir)/iconv_open-aix.h
@@ -402,7 +448,7 @@ MOSTLYCLEANFILES += iconv_open-aix.h-t
iconv_open-hpux.h-t iconv_open-irix.h
MAINTAINERCLEANFILES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h
iconv_open-osf.h iconv_open-solaris.h
EXTRA_DIST += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h
iconv_open-osf.h iconv_open-solaris.h
-EXTRA_DIST += iconv.in.h iconv_open-aix.gperf iconv_open-hpux.gperf
iconv_open-irix.gperf iconv_open-osf.gperf iconv_open-solaris.gperf iconv_open.c
+EXTRA_DIST += iconv_open-aix.gperf iconv_open-hpux.gperf iconv_open-irix.gperf
iconv_open-osf.gperf iconv_open-solaris.gperf iconv_open.c
EXTRA_libgnu_la_SOURCES += iconv_open.c
@@ -445,25 +491,6 @@ AM_CFLAGS += $(CFLAG_VISIBILITY)
## end gnulib module lib-symbol-visibility
-## begin gnulib module link-warning
-
-BUILT_SOURCES += link-warning.h
-# The link-warning.h that gets inserted into generated .h files is the same as
-# build-aux/link-warning.h, except that it has the copyright header cut off.
-link-warning.h: $(top_srcdir)/build-aux/link-warning.h
- $(AM_V_GEN)rm -f address@hidden $@ && \
- sed -n -e '/GL_LINK_WARNING/,$$p' \
- < $(top_srcdir)/build-aux/link-warning.h \
- > address@hidden && \
- mv address@hidden $@
-MOSTLYCLEANFILES += link-warning.h link-warning.h-t
-
-LINK_WARNING_H=link-warning.h
-
-EXTRA_DIST += $(top_srcdir)/build-aux/link-warning.h
-
-## end gnulib module link-warning
-
## begin gnulib module localcharset
libgnu_la_SOURCES += localcharset.h localcharset.c
@@ -540,20 +567,23 @@ EXTRA_DIST += config.charset ref-add.sin ref-del.sin
## begin gnulib module locale
-BUILT_SOURCES += $(LOCALE_H)
+BUILT_SOURCES += locale.h
# We need the following in order to create <locale.h> when the system
# doesn't have one that provides all definitions.
-locale.h: locale.in.h $(ARG_NONNULL_H)
+locale.h: locale.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''NEXT_LOCALE_H''@|$(NEXT_LOCALE_H)|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_DUPLOCALE''@|$(REPLACE_DUPLOCALE)|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)/locale.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -631,6 +661,35 @@ EXTRA_libgnu_la_SOURCES += memchr.c
## end gnulib module memchr
+## begin gnulib module netdb
+
+BUILT_SOURCES += $(NETDB_H)
+
+# We need the following in order to create <netdb.h> when the system
+# doesn't have one that works with the given compiler.
+netdb.h: netdb.in.h $(ARG_NONNULL_H)
+ $(AM_V_GEN)rm -f address@hidden $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_NETDB_H''@|$(NEXT_NETDB_H)|g' \
+ -e 's|@''HAVE_NETDB_H''@|$(HAVE_NETDB_H)|g' \
+ -e 's|@''GNULIB_GETADDRINFO''@|$(GNULIB_GETADDRINFO)|g' \
+ -e 's|@''HAVE_STRUCT_ADDRINFO''@|$(HAVE_STRUCT_ADDRINFO)|g' \
+ -e 's|@''HAVE_DECL_FREEADDRINFO''@|$(HAVE_DECL_FREEADDRINFO)|g' \
+ -e 's|@''HAVE_DECL_GAI_STRERROR''@|$(HAVE_DECL_GAI_STRERROR)|g' \
+ -e 's|@''HAVE_DECL_GETADDRINFO''@|$(HAVE_DECL_GETADDRINFO)|g' \
+ -e 's|@''HAVE_DECL_GETNAMEINFO''@|$(HAVE_DECL_GETNAMEINFO)|g' \
+ -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
+ < $(srcdir)/netdb.in.h; \
+ } > address@hidden && \
+ mv address@hidden $@
+MOSTLYCLEANFILES += netdb.h netdb.h-t
+
+EXTRA_DIST += netdb.in.h
+
+## end gnulib module netdb
+
## begin gnulib module netinet_in
BUILT_SOURCES += $(NETINET_IN_H)
@@ -704,6 +763,15 @@ libgnu_la_SOURCES += size_max.h
## end gnulib module size_max
+## begin gnulib module snprintf
+
+
+EXTRA_DIST += snprintf.c
+
+EXTRA_libgnu_la_SOURCES += snprintf.c
+
+## end gnulib module snprintf
+
## begin gnulib module stat
@@ -823,7 +891,7 @@ BUILT_SOURCES += stdio.h
# We need the following in order to create <stdio.h> when the system
# doesn't have one that works with the given compiler.
-stdio.h: stdio.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+stdio.h: stdio.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -869,7 +937,8 @@ stdio.h: stdio.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''GNULIB_VPRINTF_POSIX''@|$(GNULIB_VPRINTF_POSIX)|g' \
-e 's|@''GNULIB_VSNPRINTF''@|$(GNULIB_VSNPRINTF)|g' \
-e 's|@''GNULIB_VSPRINTF_POSIX''@|$(GNULIB_VSPRINTF_POSIX)|g' \
- -e 's|@''HAVE_DECL_FPURGE''@|$(HAVE_DECL_FPURGE)|g' \
+ < $(srcdir)/stdio.in.h | \
+ sed -e 's|@''HAVE_DECL_FPURGE''@|$(HAVE_DECL_FPURGE)|g' \
-e 's|@''HAVE_DECL_GETDELIM''@|$(HAVE_DECL_GETDELIM)|g' \
-e 's|@''HAVE_DECL_GETLINE''@|$(HAVE_DECL_GETLINE)|g' \
-e
's|@''HAVE_DECL_OBSTACK_PRINTF''@|$(HAVE_DECL_OBSTACK_PRINTF)|g' \
@@ -890,6 +959,7 @@ stdio.h: stdio.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''REPLACE_FSEEKO''@|$(REPLACE_FSEEKO)|g' \
-e 's|@''REPLACE_FTELL''@|$(REPLACE_FTELL)|g' \
-e 's|@''REPLACE_FTELLO''@|$(REPLACE_FTELLO)|g' \
+ -e 's|@''REPLACE_GETDELIM''@|$(REPLACE_GETDELIM)|g' \
-e 's|@''REPLACE_GETLINE''@|$(REPLACE_GETLINE)|g' \
-e 's|@''REPLACE_OBSTACK_PRINTF''@|$(REPLACE_OBSTACK_PRINTF)|g' \
-e 's|@''REPLACE_PERROR''@|$(REPLACE_PERROR)|g' \
@@ -907,9 +977,9 @@ stdio.h: stdio.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''REPLACE_VPRINTF''@|$(REPLACE_VPRINTF)|g' \
-e 's|@''REPLACE_VSNPRINTF''@|$(REPLACE_VSNPRINTF)|g' \
-e 's|@''REPLACE_VSPRINTF''@|$(REPLACE_VSPRINTF)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
- < $(srcdir)/stdio.in.h; \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)'; \
} > address@hidden && \
mv address@hidden $@
MOSTLYCLEANFILES += stdio.h stdio.h-t
@@ -926,7 +996,7 @@ BUILT_SOURCES += stdlib.h
# We need the following in order to create <stdlib.h> when the system
# doesn't have one that works with the given compiler.
-stdlib.h: stdlib.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+stdlib.h: stdlib.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -982,8 +1052,9 @@ stdlib.h: stdlib.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''REPLACE_SETENV''@|$(REPLACE_SETENV)|g' \
-e 's|@''REPLACE_STRTOD''@|$(REPLACE_STRTOD)|g' \
-e 's|@''REPLACE_UNSETENV''@|$(REPLACE_UNSETENV)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -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)/stdlib.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -1035,7 +1106,7 @@ BUILT_SOURCES += string.h
# We need the following in order to create <string.h> when the system
# doesn't have one that works with the given compiler.
-string.h: string.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+string.h: string.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -1074,6 +1145,8 @@ string.h: string.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''GNULIB_STRERROR''@|$(GNULIB_STRERROR)|g' \
-e 's|@''GNULIB_STRSIGNAL''@|$(GNULIB_STRSIGNAL)|g' \
-e 's|@''GNULIB_STRVERSCMP''@|$(GNULIB_STRVERSCMP)|g' \
+ < $(srcdir)/string.in.h | \
+ sed -e 's|@''HAVE_MBSLEN''@|$(HAVE_MBSLEN)|g' \
-e 's|@''HAVE_DECL_MEMMEM''@|$(HAVE_DECL_MEMMEM)|g' \
-e 's|@''HAVE_MEMPCPY''@|$(HAVE_MEMPCPY)|g' \
-e 's|@''HAVE_DECL_MEMRCHR''@|$(HAVE_DECL_MEMRCHR)|g' \
@@ -1101,8 +1174,9 @@ string.h: string.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \
-e 's|@''REPLACE_STRTOK_R''@|$(REPLACE_STRTOK_R)|g' \
-e 's|@''UNDEFINE_STRTOK_R''@|$(UNDEFINE_STRTOK_R)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -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)/string.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -1118,7 +1192,7 @@ 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 $(LINK_WARNING_H) $(ARG_NONNULL_H)
+strings.h: strings.in.h $(WARN_ON_USE_H) $(ARG_NONNULL_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -1126,8 +1200,8 @@ strings.h: strings.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''NEXT_STRINGS_H''@|$(NEXT_STRINGS_H)|g' \
-e 's|@''HAVE_STRCASECMP''@|$(HAVE_STRCASECMP)|g' \
-e 's|@''HAVE_DECL_STRNCASECMP''@|$(HAVE_DECL_STRNCASECMP)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_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 $@
@@ -1139,11 +1213,11 @@ EXTRA_DIST += strings.in.h
## begin gnulib module sys_file
-BUILT_SOURCES += $(SYS_FILE_H)
+BUILT_SOURCES += sys/file.h
# We need the following in order to create <sys/file.h> when the system
# has one that is incomplete.
-sys/file.h: sys_file.in.h
+sys/file.h: sys_file.in.h $(WARN_ON_USE_H)
$(AM_V_at)$(MKDIR_P) sys
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
@@ -1153,6 +1227,7 @@ sys/file.h: sys_file.in.h
-e 's|@''NEXT_SYS_FILE_H''@|$(NEXT_SYS_FILE_H)|g' \
-e 's/@''HAVE_FLOCK''@/$(HAVE_FLOCK)/g' \
-e 's/@''GNULIB_FLOCK''@/$(GNULIB_FLOCK)/g' \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
< $(srcdir)/sys_file.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -1165,11 +1240,11 @@ EXTRA_DIST += sys_file.in.h
## begin gnulib module sys_socket
-BUILT_SOURCES += $(SYS_SOCKET_H)
+BUILT_SOURCES += sys/socket.h
# We need the following in order to create <sys/socket.h> when the system
# doesn't have one that works with the given compiler.
-sys/socket.h: sys_socket.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+sys/socket.h: sys_socket.in.h $(CXXDEFS_H) $(WARN_ON_USE_H) $(ARG_NONNULL_H)
$(AM_V_at)$(MKDIR_P) sys
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
@@ -1198,8 +1273,9 @@ sys/socket.h: sys_socket.in.h $(LINK_WARNING_H)
$(ARG_NONNULL_H)
-e
's|@''HAVE_STRUCT_SOCKADDR_STORAGE''@|$(HAVE_STRUCT_SOCKADDR_STORAGE)|g' \
-e 's|@''HAVE_SA_FAMILY_T''@|$(HAVE_SA_FAMILY_T)|g' \
-e 's|@''HAVE_ACCEPT4''@|$(HAVE_ACCEPT4)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -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)/sys_socket.in.h; \
} > address@hidden && \
mv -f address@hidden $@
@@ -1216,7 +1292,7 @@ BUILT_SOURCES += sys/stat.h
# We need the following in order to create <sys/stat.h> when the system
# has one that is incomplete.
-sys/stat.h: sys_stat.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+sys/stat.h: sys_stat.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_at)$(MKDIR_P) sys
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
@@ -1255,8 +1331,9 @@ sys/stat.h: sys_stat.in.h $(LINK_WARNING_H)
$(ARG_NONNULL_H)
-e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \
-e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \
-e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -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)/sys_stat.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -1273,20 +1350,27 @@ BUILT_SOURCES += time.h
# We need the following in order to create <time.h> when the system
# doesn't have one that works with the given compiler.
-time.h: time.in.h $(ARG_NONNULL_H)
+time.h: time.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
- -e 's|@NEXT_TIME_H''@|$(NEXT_TIME_H)|g' \
- -e 's|@REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \
- -e 's|@REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \
- -e 's|@REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \
- -e 's|@REPLACE_STRPTIME''@|$(REPLACE_STRPTIME)|g' \
- -e 's|@REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
- -e
's|@SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g'
\
- -e
's|@TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
+ -e 's|@''NEXT_TIME_H''@|$(NEXT_TIME_H)|g' \
+ -e 's|@''GNULIB_MKTIME''@|$(GNULIB_MKTIME)|g' \
+ -e 's|@''GNULIB_NANOSLEEP''@|$(GNULIB_NANOSLEEP)|g' \
+ -e 's|@''GNULIB_STRPTIME''@|$(GNULIB_STRPTIME)|g' \
+ -e 's|@''GNULIB_TIMEGM''@|$(GNULIB_TIMEGM)|g' \
+ -e 's|@''GNULIB_TIME_R''@|$(GNULIB_TIME_R)|g' \
+ -e 's|@''REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \
+ -e 's|@''REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \
+ -e 's|@''REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \
+ -e 's|@''REPLACE_STRPTIME''@|$(REPLACE_STRPTIME)|g' \
+ -e 's|@''REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
+ -e
's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g'
\
+ -e
's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|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)/time.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -1311,7 +1395,7 @@ BUILT_SOURCES += unistd.h
# We need the following in order to create an empty placeholder for
# <unistd.h> when the system doesn't have one.
-unistd.h: unistd.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+unistd.h: unistd.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''HAVE_UNISTD_H''@|$(HAVE_UNISTD_H)|g' \
@@ -1334,6 +1418,7 @@ unistd.h: unistd.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''GNULIB_GETDTABLESIZE''@|$(GNULIB_GETDTABLESIZE)|g' \
-e 's|@''GNULIB_GETGROUPS''@|$(GNULIB_GETGROUPS)|g' \
-e 's|@''GNULIB_GETHOSTNAME''@|$(GNULIB_GETHOSTNAME)|g' \
+ -e 's|@''GNULIB_GETLOGIN''@|$(GNULIB_GETLOGIN)|g' \
-e 's|@''GNULIB_GETLOGIN_R''@|$(GNULIB_GETLOGIN_R)|g' \
-e 's|@''GNULIB_GETPAGESIZE''@|$(GNULIB_GETPAGESIZE)|g' \
-e 's|@''GNULIB_GETUSERSHELL''@|$(GNULIB_GETUSERSHELL)|g' \
@@ -1355,7 +1440,8 @@ unistd.h: unistd.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''GNULIB_UNLINKAT''@|$(GNULIB_UNLINKAT)|g' \
-e 's|@''GNULIB_USLEEP''@|$(GNULIB_USLEEP)|g' \
-e 's|@''GNULIB_WRITE''@|$(GNULIB_WRITE)|g' \
- -e 's|@''HAVE_CHOWN''@|$(HAVE_CHOWN)|g' \
+ < $(srcdir)/unistd.in.h | \
+ sed -e 's|@''HAVE_CHOWN''@|$(HAVE_CHOWN)|g' \
-e 's|@''HAVE_DUP2''@|$(HAVE_DUP2)|g' \
-e 's|@''HAVE_DUP3''@|$(HAVE_DUP3)|g' \
-e 's|@''HAVE_EUIDACCESS''@|$(HAVE_EUIDACCESS)|g' \
@@ -1367,6 +1453,7 @@ unistd.h: unistd.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''HAVE_GETDTABLESIZE''@|$(HAVE_GETDTABLESIZE)|g' \
-e 's|@''HAVE_GETGROUPS''@|$(HAVE_GETGROUPS)|g' \
-e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \
+ -e 's|@''HAVE_GETLOGIN''@|$(HAVE_GETLOGIN)|g' \
-e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \
-e 's|@''HAVE_GETUSERSHELL''@|$(HAVE_GETUSERSHELL)|g' \
-e 's|@''HAVE_LCHOWN''@|$(HAVE_LCHOWN)|g' \
@@ -1409,9 +1496,9 @@ unistd.h: unistd.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''REPLACE_WRITE''@|$(REPLACE_WRITE)|g' \
-e
's|@''UNISTD_H_HAVE_WINSOCK2_H''@|$(UNISTD_H_HAVE_WINSOCK2_H)|g' \
-e
's|@''UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS''@|$(UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS)|g'
\
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
- < $(srcdir)/unistd.in.h; \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)'; \
} > address@hidden && \
mv address@hidden $@
MOSTLYCLEANFILES += unistd.h unistd.h-t
@@ -1464,6 +1551,31 @@ EXTRA_DIST += unitypes.h
## end gnulib module unitypes
+## begin gnulib module unused-parameter
+
+# The BUILT_SOURCES created by this Makefile snippet are not used via #include
+# statements but through direct file reference. Therefore this snippet must be
+# present in all Makefile.am that need it. This is ensured by the applicability
+# 'all' defined above.
+
+BUILT_SOURCES += unused-parameter.h
+# The unused-parameter.h that gets inserted into generated .h files is the same
+# as build-aux/unused-parameter.h, except that it has the copyright header cut
+# off.
+unused-parameter.h: $(top_srcdir)/build-aux/unused-parameter.h
+ $(AM_V_GEN)rm -f address@hidden $@ && \
+ sed -n -e '/GL_UNUSED_PARAMETER/,$$p' \
+ < $(top_srcdir)/build-aux/unused-parameter.h \
+ > address@hidden && \
+ mv address@hidden $@
+MOSTLYCLEANFILES += unused-parameter.h unused-parameter.h-t
+
+UNUSED_PARAMETER_H=unused-parameter.h
+
+EXTRA_DIST += $(top_srcdir)/build-aux/unused-parameter.h
+
+## end gnulib module unused-parameter
+
## begin gnulib module useless-if-before-free
@@ -1514,13 +1626,32 @@ EXTRA_libgnu_la_SOURCES += vsnprintf.c
## end gnulib module vsnprintf
+## begin gnulib module warn-on-use
+
+BUILT_SOURCES += warn-on-use.h
+# The warn-on-use.h that gets inserted into generated .h files is the same as
+# build-aux/warn-on-use.h, except that it has the copyright header cut off.
+warn-on-use.h: $(top_srcdir)/build-aux/warn-on-use.h
+ $(AM_V_GEN)rm -f address@hidden $@ && \
+ sed -n -e '/^.ifndef/,$$p' \
+ < $(top_srcdir)/build-aux/warn-on-use.h \
+ > address@hidden && \
+ mv address@hidden $@
+MOSTLYCLEANFILES += warn-on-use.h warn-on-use.h-t
+
+WARN_ON_USE_H=warn-on-use.h
+
+EXTRA_DIST += $(top_srcdir)/build-aux/warn-on-use.h
+
+## end gnulib module warn-on-use
+
## begin gnulib module wchar
-BUILT_SOURCES += $(WCHAR_H)
+BUILT_SOURCES += wchar.h
# We need the following in order to create <wchar.h> when the system
# version does not work standalone.
-wchar.h: wchar.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
+wchar.h: wchar.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
$(AM_V_GEN)rm -f address@hidden $@ && \
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
@@ -1562,8 +1693,9 @@ wchar.h: wchar.in.h $(LINK_WARNING_H) $(ARG_NONNULL_H)
-e 's|@''REPLACE_WCSRTOMBS''@|$(REPLACE_WCSRTOMBS)|g' \
-e 's|@''REPLACE_WCSNRTOMBS''@|$(REPLACE_WCSNRTOMBS)|g' \
-e 's|@''REPLACE_WCWIDTH''@|$(REPLACE_WCWIDTH)|g' \
- -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ -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)/wchar.in.h; \
} > address@hidden && \
mv address@hidden $@
diff --git a/lib/alignof.h b/lib/alignof.h
index 28ce79c..13687ab 100644
--- a/lib/alignof.h
+++ b/lib/alignof.h
@@ -1,5 +1,5 @@
/* Determine alignment of types.
- Copyright (C) 2003-2004, 2006, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2003-2004, 2006, 2009-2010 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
diff --git a/lib/alloca.in.h b/lib/alloca.in.h
index 3d4f88b..ee7aa9a 100644
--- a/lib/alloca.in.h
+++ b/lib/alloca.in.h
@@ -1,7 +1,7 @@
/* Memory allocation on the stack.
- Copyright (C) 1995, 1999, 2001-2004, 2006-2008 Free Software
- Foundation, Inc.
+ Copyright (C) 1995, 1999, 2001-2004, 2006-2010 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
diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h
index 3f2f841..8e6c6c5 100644
--- a/lib/arpa_inet.in.h
+++ b/lib/arpa_inet.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <arpa/inet.h>.
- Copyright (C) 2005-2006, 2008-2009 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2008-2010 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
@@ -19,8 +19,11 @@
#ifndef _GL_ARPA_INET_H
/* Gnulib's sys/socket.h is responsible for pulling in winsock2.h etc
- under MinGW. */
-#include <sys/socket.h>
+ under MinGW.
+ But avoid namespace pollution on glibc systems. */
+#ifndef __GLIBC__
+# include <sys/socket.h>
+#endif
#if @HAVE_ARPA_INET_H@
@@ -36,10 +39,10 @@
#ifndef _GL_ARPA_INET_H
#define _GL_ARPA_INET_H
-/* The definition of GL_LINK_WARNING is 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
@@ -67,10 +70,10 @@ extern const char *inet_ntop (int af, const void *restrict
src,
# endif
#elif defined GNULIB_POSIXCHECK
# undef inet_ntop
-# define inet_ntop(af,src,dst,cnt) \
- (GL_LINK_WARNING ("inet_ntop is unportable - " \
- "use gnulib module inet_ntop for portability"), \
- inet_ntop (af, src, dst, cnt))
+# if HAVE_RAW_DECL_INET_NTOP
+_GL_WARN_ON_USE (inet_ntop, "inet_ntop is unportable - "
+ "use gnulib module inet_ntop for portability");
+# endif
#endif
#if @GNULIB_INET_PTON@
@@ -80,10 +83,10 @@ extern int inet_pton (int af, const char *restrict src,
void *restrict dst)
# endif
#elif defined GNULIB_POSIXCHECK
# undef inet_pton
-# define inet_pton(af,src,dst) \
- (GL_LINK_WARNING ("inet_pton is unportable - " \
- "use gnulib module inet_pton for portability"), \
- inet_pton (af, src, dst))
+# if HAVE_RAW_DECL_INET_PTON
+_GL_WARN_ON_USE (inet_pton, "inet_pton is unportable - "
+ "use gnulib module inet_pton for portability");
+# endif
#endif
#ifdef __cplusplus
diff --git a/lib/asnprintf.c b/lib/asnprintf.c
index 3b374a2..bc5a8af 100644
--- a/lib/asnprintf.c
+++ b/lib/asnprintf.c
@@ -1,5 +1,5 @@
/* Formatted output to strings.
- Copyright (C) 1999, 2002, 2006 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002, 2006, 2009, 2010 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
diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h
index 7b80cb5..cf2accb 100644
--- a/lib/byteswap.in.h
+++ b/lib/byteswap.in.h
@@ -1,5 +1,5 @@
/* byteswap.h - Byte swapping
- Copyright (C) 2005, 2007 Free Software Foundation, Inc.
+ Copyright (C) 2005, 2007, 2009, 2010 Free Software Foundation, Inc.
Written by Oskar Liljeblad <address@hidden>, 2005.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/c-ctype.c b/lib/c-ctype.c
index e36a513..403adc2 100644
--- a/lib/c-ctype.c
+++ b/lib/c-ctype.c
@@ -1,6 +1,6 @@
/* Character handling in C locale.
- Copyright 2000-2003, 2006 Free Software Foundation, Inc.
+ Copyright 2000-2003, 2006, 2009-2010 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
diff --git a/lib/c-ctype.h b/lib/c-ctype.h
index d7b067e..00c0a26 100644
--- a/lib/c-ctype.h
+++ b/lib/c-ctype.h
@@ -5,7 +5,7 @@
<ctype.h> functions' behaviour depends on the current locale set via
setlocale.
- Copyright (C) 2000-2003, 2006, 2008 Free Software Foundation, Inc.
+ Copyright (C) 2000-2003, 2006, 2008-2010 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
diff --git a/lib/c-strcase.h b/lib/c-strcase.h
index 714a3c6..99e7faf 100644
--- a/lib/c-strcase.h
+++ b/lib/c-strcase.h
@@ -1,5 +1,6 @@
/* Case-insensitive string comparison functions in C locale.
- Copyright (C) 1995-1996, 2001, 2003, 2005 Free Software Foundation, Inc.
+ Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2010 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
diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c
index ce28582..bc3e76d 100644
--- a/lib/c-strcasecmp.c
+++ b/lib/c-strcasecmp.c
@@ -1,5 +1,5 @@
/* c-strcasecmp.c -- case insensitive string comparator in C locale
- Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2010 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
diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h
index cd29b66..0af82f3 100644
--- a/lib/c-strcaseeq.h
+++ b/lib/c-strcaseeq.h
@@ -1,5 +1,5 @@
/* Optimized case-insensitive string comparison in C locale.
- Copyright (C) 2001-2002, 2007 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2007, 2009-2010 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
diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c
index 0a4e027..01dbf39 100644
--- a/lib/c-strncasecmp.c
+++ b/lib/c-strncasecmp.c
@@ -1,5 +1,5 @@
/* c-strncasecmp.c -- case insensitive string comparator in C locale
- Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2010 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
diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c
index c361a46..0f36add 100644
--- a/lib/canonicalize-lgpl.c
+++ b/lib/canonicalize-lgpl.c
@@ -1,5 +1,5 @@
/* Return the canonical absolute name of a given file.
- Copyright (C) 1996-2009 Free Software Foundation, Inc.
+ Copyright (C) 1996-2010 Free Software Foundation, Inc.
This file is part of the GNU C Library.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/config.charset b/lib/config.charset
index 217bef1..ae2efc4 100644
--- a/lib/config.charset
+++ b/lib/config.charset
@@ -1,7 +1,7 @@
#! /bin/sh
# Output a system dependent table of character encoding aliases.
#
-# Copyright (C) 2000-2004, 2006-2009 Free Software Foundation, Inc.
+# Copyright (C) 2000-2004, 2006-2010 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
diff --git a/lib/duplocale.c b/lib/duplocale.c
index ee928fd..857f545 100644
--- a/lib/duplocale.c
+++ b/lib/duplocale.c
@@ -1,5 +1,5 @@
/* Duplicate a locale object.
- Copyright (C) 2009 Free Software Foundation, Inc.
+ Copyright (C) 2009, 2010 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
diff --git a/lib/errno.in.h b/lib/errno.in.h
index a9b81d5..0e6fb7f 100644
--- a/lib/errno.in.h
+++ b/lib/errno.in.h
@@ -1,6 +1,6 @@
/* A POSIX-like <errno.h>.
- Copyright (C) 2008-2009 Free Software Foundation, Inc.
+ Copyright (C) 2008-2010 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
diff --git a/lib/float+.h b/lib/float+.h
index 2288e3d..956eb28 100644
--- a/lib/float+.h
+++ b/lib/float+.h
@@ -1,5 +1,5 @@
/* Supplemental information about the floating-point formats.
- Copyright (C) 2007 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009, 2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2007.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/float.in.h b/lib/float.in.h
index 63d55f8..ad99af3 100644
--- a/lib/float.in.h
+++ b/lib/float.in.h
@@ -1,6 +1,6 @@
/* A correct <float.h>.
- Copyright (C) 2007-2008 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 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
diff --git a/lib/flock.c b/lib/flock.c
index f583245..72eef5b 100644
--- a/lib/flock.c
+++ b/lib/flock.c
@@ -6,7 +6,7 @@
Written by Richard W.M. Jones <rjones.at.redhat.com>
- Copyright (C) 2008 Free Software Foundation, Inc.
+ Copyright (C) 2008-2010 Free Software Foundation, Inc.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
diff --git a/lib/full-read.c b/lib/full-read.c
index e02a42a..93d378d 100644
--- a/lib/full-read.c
+++ b/lib/full-read.c
@@ -1,5 +1,5 @@
/* An interface to read that retries after partial reads and interrupts.
- Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2002-2003, 2009-2010 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
diff --git a/lib/full-read.h b/lib/full-read.h
index adb8faa..71817a7 100644
--- a/lib/full-read.h
+++ b/lib/full-read.h
@@ -1,6 +1,6 @@
/* An interface to read() that reads all it is asked to read.
- Copyright (C) 2002 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2009-2010 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
diff --git a/lib/full-write.c b/lib/full-write.c
index 1e49da8..b0f6b27 100644
--- a/lib/full-write.c
+++ b/lib/full-write.c
@@ -1,7 +1,6 @@
/* An interface to read and write that retries (if necessary) until complete.
- Copyright (C) 1993, 1994, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- 2004, 2005, 2006 Free Software Foundation, Inc.
+ Copyright (C) 1993-1994, 1997-2006, 2009-2010 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
diff --git a/lib/full-write.h b/lib/full-write.h
index 3857e87..03dabfb 100644
--- a/lib/full-write.h
+++ b/lib/full-write.h
@@ -1,6 +1,6 @@
/* An interface to write() that writes all it is asked to write.
- Copyright (C) 2002-2003 Free Software Foundation, Inc.
+ Copyright (C) 2002-2003, 2009-2010 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
diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c
new file mode 100644
index 0000000..21e8076
--- /dev/null
+++ b/lib/gai_strerror.c
@@ -0,0 +1,76 @@
+/* Copyright (C) 1997, 2001, 2002, 2004, 2005, 2006, 2008, 2009, 2010 Free
+ Software Foundation, Inc.
+ This file is part of the GNU C Library.
+ Contributed by Philip Blundell <address@hidden>, 1997.
+
+ 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 _LIBC
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <netdb.h>
+
+#ifdef _LIBC
+# include <libintl.h>
+#else
+# include "gettext.h"
+# define _(String) gettext (String)
+# define N_(String) String
+#endif
+
+static struct
+ {
+ int code;
+ const char *msg;
+ }
+values[] =
+ {
+ { EAI_ADDRFAMILY, N_("Address family for hostname not supported") },
+ { EAI_AGAIN, N_("Temporary failure in name resolution") },
+ { EAI_BADFLAGS, N_("Bad value for ai_flags") },
+ { EAI_FAIL, N_("Non-recoverable failure in name resolution") },
+ { EAI_FAMILY, N_("ai_family not supported") },
+ { EAI_MEMORY, N_("Memory allocation failure") },
+ { EAI_NODATA, N_("No address associated with hostname") },
+ { EAI_NONAME, N_("Name or service not known") },
+ { EAI_SERVICE, N_("Servname not supported for ai_socktype") },
+ { EAI_SOCKTYPE, N_("ai_socktype not supported") },
+ { EAI_SYSTEM, N_("System error") },
+ { EAI_OVERFLOW, N_("Argument buffer too small") },
+#ifdef EAI_INPROGRESS
+ { EAI_INPROGRESS, N_("Processing request in progress") },
+ { EAI_CANCELED, N_("Request canceled") },
+ { EAI_NOTCANCELED, N_("Request not canceled") },
+ { EAI_ALLDONE, N_("All requests done") },
+ { EAI_INTR, N_("Interrupted by a signal") },
+ { EAI_IDN_ENCODE, N_("Parameter string not correctly encoded") }
+#endif
+ };
+
+const char *
+gai_strerror (int code)
+{
+ size_t i;
+ for (i = 0; i < sizeof (values) / sizeof (values[0]); ++i)
+ if (values[i].code == code)
+ return _(values[i].msg);
+
+ return _("Unknown error");
+}
+#ifdef _LIBC
+libc_hidden_def (gai_strerror)
+#endif
diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c
new file mode 100644
index 0000000..475eaa0
--- /dev/null
+++ b/lib/getaddrinfo.c
@@ -0,0 +1,438 @@
+/* Get address information (partial implementation).
+ Copyright (C) 1997, 2001-2002, 2004-2010 Free Software Foundation, Inc.
+ Contributed by Simon Josefsson <address@hidden>.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 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>
+
+/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
+ optimizes away the sa == NULL test below. */
+#define _GL_ARG_NONNULL(params)
+
+#include <netdb.h>
+
+#if HAVE_NETINET_IN_H
+# include <netinet/in.h>
+#endif
+
+/* Get inet_ntop. */
+#include <arpa/inet.h>
+
+/* Get calloc. */
+#include <stdlib.h>
+
+/* Get memcpy, strdup. */
+#include <string.h>
+
+/* Get snprintf. */
+#include <stdio.h>
+
+#include <stdbool.h>
+
+#include "gettext.h"
+#define _(String) gettext (String)
+#define N_(String) String
+
+/* BeOS has AF_INET, but not PF_INET. */
+#ifndef PF_INET
+# define PF_INET AF_INET
+#endif
+/* BeOS also lacks PF_UNSPEC. */
+#ifndef PF_UNSPEC
+# define PF_UNSPEC 0
+#endif
+
+#if defined _WIN32 || defined __WIN32__
+# define WIN32_NATIVE
+#endif
+
+#ifdef WIN32_NATIVE
+typedef int (WSAAPI *getaddrinfo_func) (const char*, const char*,
+ const struct addrinfo*,
+ struct addrinfo**);
+typedef void (WSAAPI *freeaddrinfo_func) (struct addrinfo*);
+typedef int (WSAAPI *getnameinfo_func) (const struct sockaddr*,
+ socklen_t, char*, DWORD,
+ char*, DWORD, int);
+
+static getaddrinfo_func getaddrinfo_ptr = NULL;
+static freeaddrinfo_func freeaddrinfo_ptr = NULL;
+static getnameinfo_func getnameinfo_ptr = NULL;
+
+static int
+use_win32_p (void)
+{
+ static int done = 0;
+ HMODULE h;
+
+ if (done)
+ return getaddrinfo_ptr ? 1 : 0;
+
+ done = 1;
+
+ h = GetModuleHandle ("ws2_32.dll");
+
+ if (h)
+ {
+ getaddrinfo_ptr = (getaddrinfo_func) GetProcAddress (h, "getaddrinfo");
+ freeaddrinfo_ptr = (freeaddrinfo_func) GetProcAddress (h,
"freeaddrinfo");
+ getnameinfo_ptr = (getnameinfo_func) GetProcAddress (h, "getnameinfo");
+ }
+
+ /* If either is missing, something is odd. */
+ if (!getaddrinfo_ptr || !freeaddrinfo_ptr || !getnameinfo_ptr)
+ {
+ getaddrinfo_ptr = NULL;
+ freeaddrinfo_ptr = NULL;
+ getnameinfo_ptr = NULL;
+ return 0;
+ }
+
+ return 1;
+}
+#endif
+
+static inline bool
+validate_family (int family)
+{
+ /* FIXME: Support more families. */
+#if HAVE_IPV4
+ if (family == PF_INET)
+ return true;
+#endif
+#if HAVE_IPV6
+ if (family == PF_INET6)
+ return true;
+#endif
+ if (family == PF_UNSPEC)
+ return true;
+ return false;
+}
+
+/* Translate name of a service location and/or a service name to set of
+ socket addresses. */
+int
+getaddrinfo (const char *restrict nodename,
+ const char *restrict servname,
+ const struct addrinfo *restrict hints,
+ struct addrinfo **restrict res)
+{
+ struct addrinfo *tmp;
+ int port = 0;
+ struct hostent *he;
+ void *storage;
+ size_t size;
+#if HAVE_IPV6
+ struct v6_pair {
+ struct addrinfo addrinfo;
+ struct sockaddr_in6 sockaddr_in6;
+ };
+#endif
+#if HAVE_IPV4
+ struct v4_pair {
+ struct addrinfo addrinfo;
+ struct sockaddr_in sockaddr_in;
+ };
+#endif
+
+#ifdef WIN32_NATIVE
+ if (use_win32_p ())
+ return getaddrinfo_ptr (nodename, servname, hints, res);
+#endif
+
+ if (hints && (hints->ai_flags & ~(AI_CANONNAME|AI_PASSIVE)))
+ /* FIXME: Support more flags. */
+ return EAI_BADFLAGS;
+
+ if (hints && !validate_family (hints->ai_family))
+ return EAI_FAMILY;
+
+ if (hints &&
+ hints->ai_socktype != SOCK_STREAM && hints->ai_socktype != SOCK_DGRAM)
+ /* FIXME: Support other socktype. */
+ return EAI_SOCKTYPE; /* FIXME: Better return code? */
+
+ if (!nodename)
+ {
+ if (!(hints->ai_flags & AI_PASSIVE))
+ return EAI_NONAME;
+
+#ifdef HAVE_IPV6
+ nodename = (hints->ai_family == AF_INET6) ? "::" : "0.0.0.0";
+#else
+ nodename = "0.0.0.0";
+#endif
+ }
+
+ if (servname)
+ {
+ struct servent *se = NULL;
+ const char *proto =
+ (hints && hints->ai_socktype == SOCK_DGRAM) ? "udp" : "tcp";
+
+ if (hints == NULL || !(hints->ai_flags & AI_NUMERICSERV))
+ /* FIXME: Use getservbyname_r if available. */
+ se = getservbyname (servname, proto);
+
+ if (!se)
+ {
+ char *c;
+ if (!(*servname >= '0' && *servname <= '9'))
+ return EAI_NONAME;
+ port = strtoul (servname, &c, 10);
+ if (*c || port > 0xffff)
+ return EAI_NONAME;
+ port = htons (port);
+ }
+ else
+ port = se->s_port;
+ }
+
+ /* FIXME: Use gethostbyname_r if available. */
+ he = gethostbyname (nodename);
+ if (!he || he->h_addr_list[0] == NULL)
+ return EAI_NONAME;
+
+ switch (he->h_addrtype)
+ {
+#if HAVE_IPV6
+ case PF_INET6:
+ size = sizeof (struct v6_pair);
+ break;
+#endif
+
+#if HAVE_IPV4
+ case PF_INET:
+ size = sizeof (struct v4_pair);
+ break;
+#endif
+
+ default:
+ return EAI_NODATA;
+ }
+
+ storage = calloc (1, size);
+ if (!storage)
+ return EAI_MEMORY;
+
+ switch (he->h_addrtype)
+ {
+#if HAVE_IPV6
+ case PF_INET6:
+ {
+ struct v6_pair *p = storage;
+ struct sockaddr_in6 *sinp = &p->sockaddr_in6;
+ tmp = &p->addrinfo;
+
+ if (port)
+ sinp->sin6_port = port;
+
+ if (he->h_length != sizeof (sinp->sin6_addr))
+ {
+ free (storage);
+ return EAI_SYSTEM; /* FIXME: Better return code? Set errno? */
+ }
+
+ memcpy (&sinp->sin6_addr, he->h_addr_list[0], sizeof sinp->sin6_addr);
+
+ tmp->ai_addr = (struct sockaddr *) sinp;
+ tmp->ai_addrlen = sizeof *sinp;
+ }
+ break;
+#endif
+
+#if HAVE_IPV4
+ case PF_INET:
+ {
+ struct v4_pair *p = storage;
+ struct sockaddr_in *sinp = &p->sockaddr_in;
+ tmp = &p->addrinfo;
+
+ if (port)
+ sinp->sin_port = port;
+
+ if (he->h_length != sizeof (sinp->sin_addr))
+ {
+ free (storage);
+ return EAI_SYSTEM; /* FIXME: Better return code? Set errno? */
+ }
+
+ memcpy (&sinp->sin_addr, he->h_addr_list[0], sizeof sinp->sin_addr);
+
+ tmp->ai_addr = (struct sockaddr *) sinp;
+ tmp->ai_addrlen = sizeof *sinp;
+ }
+ break;
+#endif
+
+ default:
+ free (storage);
+ return EAI_NODATA;
+ }
+
+ if (hints && hints->ai_flags & AI_CANONNAME)
+ {
+ const char *cn;
+ if (he->h_name)
+ cn = he->h_name;
+ else
+ cn = nodename;
+
+ tmp->ai_canonname = strdup (cn);
+ if (!tmp->ai_canonname)
+ {
+ free (storage);
+ return EAI_MEMORY;
+ }
+ }
+
+ tmp->ai_protocol = (hints) ? hints->ai_protocol : 0;
+ tmp->ai_socktype = (hints) ? hints->ai_socktype : 0;
+ tmp->ai_addr->sa_family = he->h_addrtype;
+ tmp->ai_family = he->h_addrtype;
+
+#ifdef HAVE_STRUCT_SOCKADDR_SA_LEN
+ switch (he->h_addrtype)
+ {
+#if HAVE_IPV4
+ case AF_INET:
+ tmp->ai_addr->sa_len = sizeof (struct sockaddr_in);
+ break;
+#endif
+#if HAVE_IPV6
+ case AF_INET6:
+ tmp->ai_addr->sa_len = sizeof (struct sockaddr_in6);
+ break;
+#endif
+ }
+#endif
+
+ /* FIXME: If more than one address, create linked list of addrinfo's. */
+
+ *res = tmp;
+
+ return 0;
+}
+
+/* Free `addrinfo' structure AI including associated storage. */
+void
+freeaddrinfo (struct addrinfo *ai)
+{
+#ifdef WIN32_NATIVE
+ if (use_win32_p ())
+ {
+ freeaddrinfo_ptr (ai);
+ return;
+ }
+#endif
+
+ while (ai)
+ {
+ struct addrinfo *cur;
+
+ cur = ai;
+ ai = ai->ai_next;
+
+ free (cur->ai_canonname);
+ free (cur);
+ }
+}
+
+int getnameinfo(const struct sockaddr *restrict sa, socklen_t salen,
+ char *restrict node, socklen_t nodelen,
+ char *restrict service, socklen_t servicelen,
+ int flags)
+{
+#ifdef WIN32_NATIVE
+ if (use_win32_p ())
+ return getnameinfo_ptr (sa, salen, node, nodelen,
+ service, servicelen, flags);
+#endif
+
+ /* FIXME: Support other flags. */
+ if ((node && nodelen > 0 && !(flags & NI_NUMERICHOST)) ||
+ (service && servicelen > 0 && !(flags & NI_NUMERICHOST)) ||
+ (flags & ~(NI_NUMERICHOST|NI_NUMERICSERV)))
+ return EAI_BADFLAGS;
+
+ if (sa == NULL || salen < sizeof (sa->sa_family))
+ return EAI_FAMILY;
+
+ switch (sa->sa_family)
+ {
+#if HAVE_IPV4
+ case AF_INET:
+ if (salen < sizeof (struct sockaddr_in))
+ return EAI_FAMILY;
+ break;
+#endif
+#if HAVE_IPV6
+ case AF_INET6:
+ if (salen < sizeof (struct sockaddr_in6))
+ return EAI_FAMILY;
+ break;
+#endif
+ default:
+ return EAI_FAMILY;
+ }
+
+ if (node && nodelen > 0 && flags & NI_NUMERICHOST)
+ {
+ switch (sa->sa_family)
+ {
+#if HAVE_IPV4
+ case AF_INET:
+ if (!inet_ntop (AF_INET,
+ &(((const struct sockaddr_in *) sa)->sin_addr),
+ node, nodelen))
+ return EAI_SYSTEM;
+ break;
+#endif
+
+#if HAVE_IPV6
+ case AF_INET6:
+ if (!inet_ntop (AF_INET6,
+ &(((const struct sockaddr_in6 *) sa)->sin6_addr),
+ node, nodelen))
+ return EAI_SYSTEM;
+ break;
+#endif
+
+ default:
+ return EAI_FAMILY;
+ }
+ }
+
+ if (service && servicelen > 0 && flags & NI_NUMERICSERV)
+ switch (sa->sa_family)
+ {
+#if HAVE_IPV4
+ case AF_INET:
+#endif
+#if HAVE_IPV6
+ case AF_INET6:
+#endif
+ {
+ unsigned short int port
+ = ntohs (((const struct sockaddr_in *) sa)->sin_port);
+ if (servicelen <= snprintf (service, servicelen, "%u", port))
+ return EAI_OVERFLOW;
+ }
+ break;
+ }
+
+ return 0;
+}
diff --git a/lib/gettext.h b/lib/gettext.h
index 3d7d08c..987009f 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -1,5 +1,6 @@
/* Convenience header for conditional use of GNU <libintl.h>.
- Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009 Free Software
Foundation, Inc.
+ Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2010 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
diff --git a/lib/iconv.c b/lib/iconv.c
index f64c045..5b29d9a 100644
--- a/lib/iconv.c
+++ b/lib/iconv.c
@@ -1,5 +1,5 @@
/* Character set conversion.
- Copyright (C) 1999-2001, 2007 Free Software Foundation, Inc.
+ Copyright (C) 1999-2001, 2007, 2009-2010 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
diff --git a/lib/iconv.in.h b/lib/iconv.in.h
index d90f289..5512c60 100644
--- a/lib/iconv.in.h
+++ b/lib/iconv.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <iconv.h>.
- Copyright (C) 2007-2009 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -28,20 +28,29 @@
#ifndef _GL_ICONV_H
#define _GL_ICONV_H
+/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
+
/* The definition of _GL_ARG_NONNULL is copied here. */
-#ifdef __cplusplus
-extern "C" {
-#endif
+/* The definition of _GL_WARN_ON_USE is copied here. */
#if @REPLACE_ICONV_OPEN@
/* An iconv_open wrapper that supports the IANA standardized encoding names
("ISO-8859-1" etc.) as far as possible. */
-# define iconv_open rpl_iconv_open
-extern iconv_t iconv_open (const char *tocode, const char *fromcode)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define iconv_open rpl_iconv_open
+# endif
+_GL_FUNCDECL_RPL (iconv_open, iconv_t,
+ (const char *tocode, const char *fromcode)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (iconv_open, iconv_t,
+ (const char *tocode, const char *fromcode));
+#else
+_GL_CXXALIAS_SYS (iconv_open, iconv_t,
+ (const char *tocode, const char *fromcode));
#endif
+_GL_CXXALIASWARN (iconv_open);
#if @REPLACE_ICONV_UTF@
/* Special constants for supporting UTF-{16,32}{BE,LE} encodings.
@@ -57,18 +66,36 @@ extern iconv_t iconv_open (const char *tocode, const char
*fromcode)
#endif
#if @REPLACE_ICONV@
-# define iconv rpl_iconv
-extern size_t iconv (iconv_t cd,
- @ICONV_CONST@ char **inbuf, size_t *inbytesleft,
- char **outbuf, size_t *outbytesleft);
-# define iconv_close rpl_iconv_close
-extern int iconv_close (iconv_t cd);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define iconv rpl_iconv
+# endif
+_GL_FUNCDECL_RPL (iconv, size_t,
+ (iconv_t cd,
+ @ICONV_CONST@ char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft));
+_GL_CXXALIAS_RPL (iconv, size_t,
+ (iconv_t cd,
+ @ICONV_CONST@ char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft));
+#else
+_GL_CXXALIAS_SYS (iconv, size_t,
+ (iconv_t cd,
+ @ICONV_CONST@ char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft));
#endif
+_GL_CXXALIASWARN (iconv);
-
-#ifdef __cplusplus
-}
+#if @REPLACE_ICONV@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define iconv_close rpl_iconv_close
+# endif
+_GL_FUNCDECL_RPL (iconv_close, int, (iconv_t cd));
+_GL_CXXALIAS_RPL (iconv_close, int, (iconv_t cd));
+#else
+_GL_CXXALIAS_SYS (iconv_close, int, (iconv_t cd));
#endif
+_GL_CXXALIASWARN (iconv_close);
+
#endif /* _GL_ICONV_H */
#endif /* _GL_ICONV_H */
diff --git a/lib/iconv_close.c b/lib/iconv_close.c
index 3680412..1b300ec 100644
--- a/lib/iconv_close.c
+++ b/lib/iconv_close.c
@@ -1,5 +1,5 @@
/* Character set conversion.
- Copyright (C) 2007 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009, 2010 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
diff --git a/lib/iconv_open.c b/lib/iconv_open.c
index d62dfda..1d1c053 100644
--- a/lib/iconv_open.c
+++ b/lib/iconv_open.c
@@ -1,5 +1,5 @@
/* Character set conversion.
- Copyright (C) 2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009, 2010 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
diff --git a/lib/iconveh.h b/lib/iconveh.h
index fe1bfe7..da15126 100644
--- a/lib/iconveh.h
+++ b/lib/iconveh.h
@@ -1,5 +1,5 @@
/* Character set conversion handler type.
- Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2001-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c
index 08ac7d4..cd5dbf1 100644
--- a/lib/inet_ntop.c
+++ b/lib/inet_ntop.c
@@ -1,6 +1,6 @@
/* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form
- Copyright (C) 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2008-2010 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
diff --git a/lib/inet_pton.c b/lib/inet_pton.c
index ae1bcb8..e7d4ba0 100644
--- a/lib/inet_pton.c
+++ b/lib/inet_pton.c
@@ -1,6 +1,6 @@
/* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form
- Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2006, 2008, 2009, 2010 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
diff --git a/lib/localcharset.c b/lib/localcharset.c
index 14359fc..29de23d 100644
--- a/lib/localcharset.c
+++ b/lib/localcharset.c
@@ -1,6 +1,6 @@
/* Determine a canonical name for the current locale's character encoding.
- Copyright (C) 2000-2006, 2008-2009 Free Software Foundation, Inc.
+ Copyright (C) 2000-2006, 2008-2010 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
diff --git a/lib/localcharset.h b/lib/localcharset.h
index 1772a50..c18f492 100644
--- a/lib/localcharset.h
+++ b/lib/localcharset.h
@@ -1,5 +1,5 @@
/* Determine a canonical name for the current locale's character encoding.
- Copyright (C) 2000-2003 Free Software Foundation, Inc.
+ Copyright (C) 2000-2003, 2009-2010 Free Software Foundation, Inc.
This file is part of the GNU CHARSET Library.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/locale.in.h b/lib/locale.in.h
index ff661dc..0d3ca80 100644
--- a/lib/locale.in.h
+++ b/lib/locale.in.h
@@ -1,5 +1,5 @@
/* A POSIX <locale.h>.
- Copyright (C) 2007-2009 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 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
@@ -34,8 +34,12 @@
# include <xlocale.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. */
+
/* The LC_MESSAGES locale category is specified in POSIX, but not in ISO C.
On systems that don't define it, use the same value as GNU libintl. */
#if !defined LC_MESSAGES
@@ -44,16 +48,24 @@
#if @GNULIB_DUPLOCALE@
# if @REPLACE_DUPLOCALE@
-# undef duplocale
-# define duplocale rpl_duplocale
-extern locale_t duplocale (locale_t locale) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef duplocale
+# define duplocale rpl_duplocale
+# endif
+_GL_FUNCDECL_RPL (duplocale, locale_t, (locale_t locale) _GL_ARG_NONNULL
((1)));
+_GL_CXXALIAS_RPL (duplocale, locale_t, (locale_t locale));
+# else
+# if @HAVE_DUPLOCALE@
+_GL_CXXALIAS_SYS (duplocale, locale_t, (locale_t locale));
+# endif
# endif
+_GL_CXXALIASWARN (duplocale);
#elif defined GNULIB_POSIXCHECK
# undef duplocale
-# define duplocale(l) \
- (GL_LINK_WARNING ("duplocale is buggy on some glibc systems - " \
- "use gnulib module duplocale for portability"), \
- duplocale (l))
+# if HAVE_RAW_DECL_DUPLOCALE
+_GL_WARN_ON_USE (duplocale, "duplocale is buggy on some glibc systems - "
+ "use gnulib module duplocale for portability");
+# endif
#endif
#endif /* _GL_LOCALE_H */
diff --git a/lib/lstat.c b/lib/lstat.c
index 3f9a97e..a8e95e6 100644
--- a/lib/lstat.c
+++ b/lib/lstat.c
@@ -1,7 +1,6 @@
/* Work around a bug of lstat on some systems
- Copyright (C) 1997-1999, 2000-2006, 2008-2009 Free Software
- Foundation, Inc.
+ Copyright (C) 1997-2006, 2008-2010 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
diff --git a/lib/malloc.c b/lib/malloc.c
index 9111c7a..614320c 100644
--- a/lib/malloc.c
+++ b/lib/malloc.c
@@ -1,6 +1,6 @@
/* malloc() function that is glibc compatible.
- Copyright (C) 1997, 1998, 2006, 2007 Free Software Foundation, Inc.
+ Copyright (C) 1997-1998, 2006-2007, 2009-2010 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
diff --git a/lib/malloca.c b/lib/malloca.c
index 38575a2..39baa5e 100644
--- a/lib/malloca.c
+++ b/lib/malloca.c
@@ -1,5 +1,5 @@
/* Safe automatic memory allocation.
- Copyright (C) 2003, 2006-2007 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2003.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/malloca.h b/lib/malloca.h
index 77c3ba1..e39d0f4 100644
--- a/lib/malloca.h
+++ b/lib/malloca.h
@@ -1,5 +1,5 @@
/* Safe automatic memory allocation.
- Copyright (C) 2003-2007 Free Software Foundation, Inc.
+ Copyright (C) 2003-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2003.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/mbrlen.c b/lib/mbrlen.c
index 94c66d6..1bd1cf4 100644
--- a/lib/mbrlen.c
+++ b/lib/mbrlen.c
@@ -1,5 +1,5 @@
/* Recognize multibyte character.
- Copyright (C) 1999-2000, 2008 Free Software Foundation, Inc.
+ Copyright (C) 1999-2000, 2008-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c
index e8b26e2..31f229c 100644
--- a/lib/mbrtowc.c
+++ b/lib/mbrtowc.c
@@ -1,5 +1,5 @@
/* Convert multibyte character to wide character.
- Copyright (C) 1999-2002, 2005-2009 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2005-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/mbsinit.c b/lib/mbsinit.c
index 7495794..811e39b 100644
--- a/lib/mbsinit.c
+++ b/lib/mbsinit.c
@@ -1,5 +1,5 @@
/* Test for initial conversion state.
- Copyright (C) 2008 Free Software Foundation, Inc.
+ Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/memchr.c b/lib/memchr.c
index ffc61cd..1e897cd 100644
--- a/lib/memchr.c
+++ b/lib/memchr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1991, 1993, 1996, 1997, 1999, 2000, 2003, 2004, 2006, 2008
+/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2010
Free Software Foundation, Inc.
Based on strlen implementation by Torbjorn Granlund (address@hidden),
diff --git a/lib/netdb.in.h b/lib/netdb.in.h
new file mode 100644
index 0000000..8fa6164
--- /dev/null
+++ b/lib/netdb.in.h
@@ -0,0 +1,192 @@
+/* Provide a netdb.h header file for systems lacking it (read: MinGW).
+ Copyright (C) 2008-2010 Free Software Foundation, Inc.
+ Written by Simon Josefsson.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 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. */
+
+/* This file is supposed to be used on platforms that lack <netdb.h>.
+ It is intended to provide definitions and prototypes needed by an
+ application. */
+
+#ifndef _GL_NETDB_H
+
+#if @HAVE_NETDB_H@
+
+# if __GNUC__ >= 3
address@hidden@
+# endif
+
+/* The include_next requires a split double-inclusion guard. */
+# @INCLUDE_NEXT@ @NEXT_NETDB_H@
+
+#endif
+
+#ifndef _GL_NETDB_H
+#define _GL_NETDB_H
+
+/* Get netdb.h definitions such as struct hostent for MinGW. */
+#include <sys/socket.h>
+
+/* The definition of _GL_ARG_NONNULL is copied here. */
+
+/* Declarations for a platform that lacks <netdb.h>, or where it is
+ incomplete. */
+
+#if @GNULIB_GETADDRINFO@
+
+# if address@hidden@
+
+/* Structure to contain information about address of a service provider. */
+struct addrinfo
+{
+ int ai_flags; /* Input flags. */
+ int ai_family; /* Protocol family for socket. */
+ int ai_socktype; /* Socket type. */
+ int ai_protocol; /* Protocol for socket. */
+ socklen_t ai_addrlen; /* Length of socket address. */
+ struct sockaddr *ai_addr; /* Socket address for socket. */
+ char *ai_canonname; /* Canonical name for service location. */
+ struct addrinfo *ai_next; /* Pointer to next in list. */
+};
+# endif
+
+/* Possible values for `ai_flags' field in `addrinfo' structure. */
+# ifndef AI_PASSIVE
+# define AI_PASSIVE 0x0001 /* Socket address is intended for `bind'. */
+# endif
+# ifndef AI_CANONNAME
+# define AI_CANONNAME 0x0002 /* Request for canonical name. */
+# endif
+# ifndef AI_NUMERICSERV
+# define AI_NUMERICSERV 0x0400 /* Don't use name resolution. */
+# endif
+
+# if 0
+# define AI_NUMERICHOST 0x0004 /* Don't use name resolution. */
+# endif
+
+/* These symbolic constants are required to be present by POSIX, but
+ our getaddrinfo replacement doesn't use them (yet). Setting them
+ to 0 on systems that doesn't have them avoids causing problems for
+ system getaddrinfo implementations that would be confused by
+ unknown values. */
+# ifndef AI_V4MAPPED
+# define AI_V4MAPPED 0 /* 0x0008: IPv4 mapped addresses are acceptable. */
+# endif
+# ifndef AI_ALL
+# define AI_ALL 0 /* 0x0010: Return IPv4 mapped and IPv6 addresses. */
+# endif
+# ifndef AI_ADDRCONFIG
+# define AI_ADDRCONFIG 0 /* 0x0020: Use configuration of this host to choose
+ returned address type. */
+# endif
+
+/* Error values for `getaddrinfo' function. */
+# ifndef EAI_BADFLAGS
+# define EAI_BADFLAGS -1 /* Invalid value for `ai_flags' field. */
+# define EAI_NONAME -2 /* NAME or SERVICE is unknown. */
+# define EAI_AGAIN -3 /* Temporary failure in name resolution. */
+# define EAI_FAIL -4 /* Non-recoverable failure in name res. */
+# define EAI_NODATA -5 /* No address associated with NAME. */
+# define EAI_FAMILY -6 /* `ai_family' not supported. */
+# define EAI_SOCKTYPE -7 /* `ai_socktype' not supported. */
+# define EAI_SERVICE -8 /* SERVICE not supported for `ai_socktype'. */
+# define EAI_MEMORY -10 /* Memory allocation failure. */
+# endif
+
+/* Since EAI_NODATA is deprecated by RFC3493, some systems (at least
+ FreeBSD, which does define EAI_BADFLAGS) have removed the definition
+ in favor of EAI_NONAME. */
+# if !defined EAI_NODATA && defined EAI_NONAME
+# define EAI_NODATA EAI_NONAME
+# endif
+
+# ifndef EAI_OVERFLOW
+/* Not defined on mingw32 and Haiku. */
+# define EAI_OVERFLOW -12 /* Argument buffer overflow. */
+# endif
+# ifndef EAI_ADDRFAMILY
+/* Not defined on mingw32. */
+# define EAI_ADDRFAMILY -9 /* Address family for NAME not supported. */
+# endif
+# ifndef EAI_SYSTEM
+/* Not defined on mingw32. */
+# define EAI_SYSTEM -11 /* System error returned in `errno'. */
+# endif
+
+# if 0
+/* The commented out definitions below are not yet implemented in the
+ GNULIB getaddrinfo() replacement, so are not yet needed.
+
+ If they are restored, be sure to protect the definitions with #ifndef. */
+# ifndef EAI_INPROGRESS
+# define EAI_INPROGRESS -100 /* Processing request in progress. */
+# define EAI_CANCELED -101 /* Request canceled. */
+# define EAI_NOTCANCELED -102 /* Request not canceled. */
+# define EAI_ALLDONE -103 /* All requests done. */
+# define EAI_INTR -104 /* Interrupted by a signal. */
+# define EAI_IDN_ENCODE -105 /* IDN encoding failed. */
+# endif
+# endif
+
+# if address@hidden@
+/* Translate name of a service location and/or a service name to set of
+ socket addresses.
+ For more details, see the POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/getaddrinfo.html>. */
+extern int getaddrinfo (const char *restrict nodename,
+ const char *restrict servname,
+ const struct addrinfo *restrict hints,
+ struct addrinfo **restrict res)
+ _GL_ARG_NONNULL ((4));
+# endif
+
+# if address@hidden@
+/* Free `addrinfo' structure AI including associated storage.
+ For more details, see the POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/getaddrinfo.html>. */
+extern void freeaddrinfo (struct addrinfo *ai) _GL_ARG_NONNULL ((1));
+# endif
+
+# if address@hidden@
+/* Convert error return from getaddrinfo() to a string.
+ For more details, see the POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/gai_strerror.html>. */
+extern const char *gai_strerror (int ecode);
+# endif
+
+# if address@hidden@
+/* Convert socket address to printable node and service names.
+ For more details, see the POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/getnameinfo.html>. */
+extern int getnameinfo(const struct sockaddr *restrict sa, socklen_t salen,
+ char *restrict node, socklen_t nodelen,
+ char *restrict service, socklen_t servicelen,
+ int flags)
+ _GL_ARG_NONNULL ((1));
+# endif
+
+/* Possible flags for getnameinfo. */
+# ifndef NI_NUMERICHOST
+# define NI_NUMERICHOST 1
+# endif
+# ifndef NI_NUMERICSERV
+# define NI_NUMERICSERV 2
+# endif
+
+#endif /* @GNULIB_GETADDRINFO@ */
+
+#endif /* _GL_NETDB_H */
+#endif /* _GL_NETDB_H */
diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h
index 8c94f6a..8a86bca 100644
--- a/lib/netinet_in.in.h
+++ b/lib/netinet_in.in.h
@@ -1,5 +1,5 @@
/* Substitute for <netinet/in.h>.
- Copyright (C) 2007-2008 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 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
diff --git a/lib/pathmax.h b/lib/pathmax.h
index 99d5ad8..c53aa9d 100644
--- a/lib/pathmax.h
+++ b/lib/pathmax.h
@@ -1,5 +1,6 @@
/* Define PATH_MAX somehow. Requires sys/types.h.
- Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009 Free Software Foundation,
Inc.
+ Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2010 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
diff --git a/lib/printf-args.c b/lib/printf-args.c
index 921931c..597bba9 100644
--- a/lib/printf-args.c
+++ b/lib/printf-args.c
@@ -1,5 +1,5 @@
/* Decomposed printf argument list.
- Copyright (C) 1999, 2002-2003, 2005-2007, 2009 Free Software
+ Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2010 Free Software
Foundation, Inc.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/printf-args.h b/lib/printf-args.h
index 60b56d6..d76352d 100644
--- a/lib/printf-args.h
+++ b/lib/printf-args.h
@@ -1,5 +1,6 @@
/* Decomposed printf argument list.
- Copyright (C) 1999, 2002-2003, 2006-2007 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002-2003, 2006-2007, 2009-2010 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
diff --git a/lib/printf-parse.c b/lib/printf-parse.c
index 577befa..d88ddf3 100644
--- a/lib/printf-parse.c
+++ b/lib/printf-parse.c
@@ -1,5 +1,5 @@
/* Formatted output to strings.
- Copyright (C) 1999-2000, 2002-2003, 2006-2008 Free Software Foundation, Inc.
+ Copyright (C) 1999-2000, 2002-2003, 2006-2010 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
diff --git a/lib/printf-parse.h b/lib/printf-parse.h
index 3225173..2cf965b 100644
--- a/lib/printf-parse.h
+++ b/lib/printf-parse.h
@@ -1,5 +1,6 @@
/* Parse printf format string.
- Copyright (C) 1999, 2002-2003, 2005, 2007 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002-2003, 2005, 2007, 2009-2010 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
diff --git a/lib/putenv.c b/lib/putenv.c
index 630a510..36c5123 100644
--- a/lib/putenv.c
+++ b/lib/putenv.c
@@ -1,5 +1,5 @@
-/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2008
- Free Software Foundation, Inc.
+/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2010 Free Software
+ Foundation, Inc.
NOTE: The canonical source of this file is maintained with the GNU C
Library. Bugs can be reported to address@hidden
diff --git a/lib/readlink.c b/lib/readlink.c
index 704e6f0..7d326b4 100644
--- a/lib/readlink.c
+++ b/lib/readlink.c
@@ -1,5 +1,5 @@
/* Stub for readlink().
- Copyright (C) 2003-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2003-2007, 2009-2010 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -29,8 +29,8 @@
such as DJGPP 2.03 and mingw32. */
ssize_t
-readlink (const char *name, char *buf _UNUSED_PARAMETER_,
- size_t bufsize _UNUSED_PARAMETER_)
+readlink (const char *name, char *buf _GL_UNUSED,
+ size_t bufsize _GL_UNUSED)
{
struct stat statbuf;
diff --git a/lib/ref-add.sin b/lib/ref-add.sin
index 3acdcc8..cb482d7 100644
--- a/lib/ref-add.sin
+++ b/lib/ref-add.sin
@@ -1,6 +1,6 @@
# Add this package to a list of references stored in a text file.
#
-# Copyright (C) 2000 Free Software Foundation, Inc.
+# Copyright (C) 2000, 2009, 2010 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
diff --git a/lib/ref-del.sin b/lib/ref-del.sin
index 7923d06..74f8e1c 100644
--- a/lib/ref-del.sin
+++ b/lib/ref-del.sin
@@ -1,6 +1,6 @@
# Remove this package from a list of references stored in a text file.
#
-# Copyright (C) 2000 Free Software Foundation, Inc.
+# Copyright (C) 2000, 2009, 2010 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
diff --git a/lib/safe-read.c b/lib/safe-read.c
index 76bb640..1a24096 100644
--- a/lib/safe-read.c
+++ b/lib/safe-read.c
@@ -1,7 +1,7 @@
/* An interface to read and write that retries after interrupts.
- Copyright (C) 1993, 1994, 1998, 2002, 2003, 2004, 2005, 2006 Free
- Software Foundation, Inc.
+ Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2010 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
diff --git a/lib/safe-read.h b/lib/safe-read.h
index 103fc3f..21c860b 100644
--- a/lib/safe-read.h
+++ b/lib/safe-read.h
@@ -1,5 +1,5 @@
/* An interface to read() that retries after interrupts.
- Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006, 2009-2010 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
diff --git a/lib/safe-write.c b/lib/safe-write.c
index fcd5c42..6e8c8d7 100644
--- a/lib/safe-write.c
+++ b/lib/safe-write.c
@@ -1,5 +1,5 @@
/* An interface to write that retries after interrupts.
- Copyright (C) 2002 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2009-2010 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
diff --git a/lib/safe-write.h b/lib/safe-write.h
index 51e3dcb..5c24996 100644
--- a/lib/safe-write.h
+++ b/lib/safe-write.h
@@ -1,5 +1,5 @@
/* An interface to write() that retries after interrupts.
- Copyright (C) 2002 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2009-2010 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
diff --git a/lib/size_max.h b/lib/size_max.h
index 419d73a..381eea1 100644
--- a/lib/size_max.h
+++ b/lib/size_max.h
@@ -1,5 +1,5 @@
/* size_max.h -- declare SIZE_MAX through system headers
- Copyright (C) 2005-2006 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2009-2010 Free Software Foundation, Inc.
Written by Simon Josefsson.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/snprintf.c b/lib/snprintf.c
new file mode 100644
index 0000000..4243679
--- /dev/null
+++ b/lib/snprintf.c
@@ -0,0 +1,72 @@
+/* Formatted output to strings.
+ Copyright (C) 2004, 2006-2010 Free Software Foundation, Inc.
+ Written by Simon Josefsson and Paul Eggert.
+
+ 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 <stdio.h>
+
+#include <errno.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "vasnprintf.h"
+
+/* Print formatted output to string STR. Similar to sprintf, but
+ additional length SIZE limit how much is written into STR. Returns
+ string length of formatted string (which may be larger than SIZE).
+ STR may be NULL, in which case nothing will be written. On error,
+ return a negative value. */
+int
+snprintf (char *str, size_t size, const char *format, ...)
+{
+ char *output;
+ size_t len;
+ size_t lenbuf = size;
+ va_list args;
+
+ va_start (args, format);
+ output = vasnprintf (str, &lenbuf, format, args);
+ len = lenbuf;
+ va_end (args);
+
+ if (!output)
+ return -1;
+
+ if (output != str)
+ {
+ if (size)
+ {
+ size_t pruned_len = (len < size ? len : size - 1);
+ memcpy (str, output, pruned_len);
+ str[pruned_len] = '\0';
+ }
+
+ free (output);
+ }
+
+ if (INT_MAX < len)
+ {
+ errno = EOVERFLOW;
+ return -1;
+ }
+
+ return len;
+}
diff --git a/lib/stat.c b/lib/stat.c
index 97b340c..60fe127 100644
--- a/lib/stat.c
+++ b/lib/stat.c
@@ -1,5 +1,5 @@
/* Work around platform bugs in stat.
- Copyright (C) 2009 Free Software Foundation, Inc.
+ Copyright (C) 2009, 2010 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
diff --git a/lib/stdarg.in.h b/lib/stdarg.in.h
index 873e6c0..4bbd01e 100644
--- a/lib/stdarg.in.h
+++ b/lib/stdarg.in.h
@@ -1,5 +1,5 @@
/* Substitute for and wrapper around <stdarg.h>.
- Copyright (C) 2008 Free Software Foundation, Inc.
+ Copyright (C) 2008, 2009, 2010 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
diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h
index 3390484..7b681f6 100644
--- a/lib/stdbool.in.h
+++ b/lib/stdbool.in.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001-2003, 2006-2008 Free Software Foundation, Inc.
+/* Copyright (C) 2001-2003, 2006-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2001.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/stddef.in.h b/lib/stddef.in.h
index dacc83d..b1dfb67 100644
--- a/lib/stddef.in.h
+++ b/lib/stddef.in.h
@@ -1,6 +1,6 @@
/* A substitute for POSIX 2008 <stddef.h>, for platforms that have issues.
- Copyright (C) 2009 Free Software Foundation, Inc.
+ Copyright (C) 2009, 2010 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
diff --git a/lib/stdint.in.h b/lib/stdint.in.h
index 36e6469..a1162d4 100644
--- a/lib/stdint.in.h
+++ b/lib/stdint.in.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001-2002, 2004-2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001-2002, 2004-2010 Free Software Foundation, Inc.
Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood.
This file is part of gnulib.
diff --git a/lib/stdio-write.c b/lib/stdio-write.c
index 7b26c78..61bba92 100644
--- a/lib/stdio-write.c
+++ b/lib/stdio-write.c
@@ -1,5 +1,5 @@
/* POSIX compatible FILE stream write function.
- Copyright (C) 2008-2009 Free Software Foundation, Inc.
+ Copyright (C) 2008-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/stdio.in.h b/lib/stdio.in.h
index 8e09570..27c554b 100644
--- a/lib/stdio.in.h
+++ b/lib/stdio.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <stdio.h>.
- Copyright (C) 2004, 2007-2009 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2007-2010 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
@@ -36,598 +36,970 @@
#ifndef _GL_STDIO_H
#define _GL_STDIO_H
+/* Get va_list. Needed on many systems, including glibc 2.8. */
#include <stdarg.h>
+
#include <stddef.h>
-#if (@GNULIB_FSEEKO@ && @REPLACE_FSEEKO@) \
- || (@GNULIB_FTELLO@ && @REPLACE_FTELLO@) \
- || (@GNULIB_GETDELIM@ && address@hidden@) \
- || (@GNULIB_GETLINE@ && (address@hidden@ || @REPLACE_GETLINE@))
-/* Get off_t and ssize_t. */
-# include <sys/types.h>
-#endif
+/* Get off_t and ssize_t. Needed on many systems, including glibc 2.8. */
+#include <sys/types.h>
#ifndef __attribute__
-/* This feature is available in gcc versions 2.5 and later. */
-# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5)
-# define __attribute__(Spec) /* empty */
-# endif
-/* The __-protected variants of `format' and `printf' attributes
- are accepted by gcc versions 2.6.4 (effectively 2.7) and later. */
+/* The __attribute__ feature is available in gcc versions 2.5 and later.
+ The __-protected variants of the attributes 'format' and 'printf' are
+ accepted by gcc versions 2.6.4 (effectively 2.7) and later.
+ We enable __attribute__ only if these are supported too, because
+ gnulib and libintl do '#define printf __printf__' when they override
+ the 'printf' function. */
# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 7)
-# define __format__ format
-# define __printf__ printf
+# define __attribute__(Spec) /* empty */
# endif
#endif
-/* The definition of GL_LINK_WARNING is copied here. */
+/* 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
#if @GNULIB_DPRINTF@
# if @REPLACE_DPRINTF@
-# define dprintf rpl_dprintf
-# endif
-# if @REPLACE_DPRINTF@ || address@hidden@
-extern int dprintf (int fd, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3))) _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define dprintf rpl_dprintf
+# endif
+_GL_FUNCDECL_RPL (dprintf, int, (int fd, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (dprintf, int, (int fd, const char *format, ...));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (dprintf, int, (int fd, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (dprintf, int, (int fd, const char *format, ...));
# endif
+_GL_CXXALIASWARN (dprintf);
#elif defined GNULIB_POSIXCHECK
# undef dprintf
-# define dprintf(d,f,a) \
- (GL_LINK_WARNING ("dprintf is unportable - " \
- "use gnulib module dprintf for portability"), \
- dprintf (d, f, a))
+# if HAVE_RAW_DECL_DPRINTF
+_GL_WARN_ON_USE (dprintf, "dprintf is unportable - "
+ "use gnulib module dprintf for portability");
+# endif
#endif
#if @GNULIB_FCLOSE@
+/* Close STREAM and its underlying file descriptor. */
# if @REPLACE_FCLOSE@
-# define fclose rpl_fclose
- /* Close STREAM and its underlying file descriptor. */
-extern int fclose (FILE *stream) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define fclose rpl_fclose
+# endif
+_GL_FUNCDECL_RPL (fclose, int, (FILE *stream) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (fclose, int, (FILE *stream));
+# else
+_GL_CXXALIAS_SYS (fclose, int, (FILE *stream));
# endif
+_GL_CXXALIASWARN (fclose);
#elif defined GNULIB_POSIXCHECK
# undef fclose
-# define fclose(f) \
- (GL_LINK_WARNING ("fclose is not always POSIX compliant - " \
- "use gnulib module fclose for portable " \
- "POSIX compliance"), \
- fclose (f))
+/* Assume fclose is always declared. */
+_GL_WARN_ON_USE (fclose, "fclose is not always POSIX compliant - "
+ "use gnulib module fclose for portable POSIX compliance");
#endif
#if @GNULIB_FFLUSH@
+/* Flush all pending data on STREAM according to POSIX rules. Both
+ output and seekable input streams are supported.
+ Note! LOSS OF DATA can occur if fflush is applied on an input stream
+ that is _not_seekable_ or on an update stream that is _not_seekable_
+ and in which the most recent operation was input. Seekability can
+ be tested with lseek(fileno(fp),0,SEEK_CUR). */
# if @REPLACE_FFLUSH@
-# define fflush rpl_fflush
- /* Flush all pending data on STREAM according to POSIX rules. Both
- output and seekable input streams are supported.
- Note! LOSS OF DATA can occur if fflush is applied on an input stream
- that is _not_seekable_ or on an update stream that is _not_seekable_
- and in which the most recent operation was input. Seekability can
- be tested with lseek(fileno(fp),0,SEEK_CUR). */
- extern int fflush (FILE *gl_stream);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define fflush rpl_fflush
+# endif
+_GL_FUNCDECL_RPL (fflush, int, (FILE *gl_stream));
+_GL_CXXALIAS_RPL (fflush, int, (FILE *gl_stream));
+# else
+_GL_CXXALIAS_SYS (fflush, int, (FILE *gl_stream));
# endif
+_GL_CXXALIASWARN (fflush);
#elif defined GNULIB_POSIXCHECK
# undef fflush
-# define fflush(f) \
- (GL_LINK_WARNING ("fflush is not always POSIX compliant - " \
- "use gnulib module fflush for portable " \
- "POSIX compliance"), \
- fflush (f))
+/* Assume fflush is always declared. */
+_GL_WARN_ON_USE (fflush, "fflush is not always POSIX compliant - "
+ "use gnulib module fflush for portable POSIX compliance");
#endif
+/* 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. */
+#undef gets
+_GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead");
+
#if @GNULIB_FOPEN@
# if @REPLACE_FOPEN@
-# undef fopen
-# define fopen rpl_fopen
-extern FILE * fopen (const char *filename, const char *mode)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fopen
+# define fopen rpl_fopen
+# endif
+_GL_FUNCDECL_RPL (fopen, FILE *, (const char *filename, const char *mode)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (fopen, FILE *, (const char *filename, const char *mode));
+# else
+_GL_CXXALIAS_SYS (fopen, FILE *, (const char *filename, const char *mode));
# endif
+_GL_CXXALIASWARN (fopen);
#elif defined GNULIB_POSIXCHECK
# undef fopen
-# define fopen(f,m) \
- (GL_LINK_WARNING ("fopen on Win32 platforms is not POSIX compatible - " \
- "use gnulib module fopen for portability"), \
- fopen (f, m))
-#endif
-
-#if @GNULIB_FPRINTF_POSIX@
-# if @REPLACE_FPRINTF@
-# define fprintf rpl_fprintf
-extern int fprintf (FILE *fp, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)))
- _GL_ARG_NONNULL ((1, 2));
-# endif
-#elif @GNULIB_FPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@
-# define fprintf rpl_fprintf
-extern int fprintf (FILE *fp, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)))
- _GL_ARG_NONNULL ((1, 2));
-#elif defined GNULIB_POSIXCHECK
-# undef fprintf
-# define fprintf \
- (GL_LINK_WARNING ("fprintf is not always POSIX compliant - " \
- "use gnulib module fprintf-posix for portable " \
- "POSIX compliance"), \
- fprintf)
+/* Assume fopen is always declared. */
+_GL_WARN_ON_USE (fopen, "fopen on Win32 platforms is not POSIX compatible - "
+ "use gnulib module fopen for portability");
+#endif
+
+#if @GNULIB_FPRINTF_POSIX@ || @GNULIB_FPRINTF@
+# if (@GNULIB_FPRINTF_POSIX@ && @REPLACE_FPRINTF@) \
+ || (@GNULIB_FPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@)
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define fprintf rpl_fprintf
+# endif
+# define GNULIB_overrides_fprintf 1
+_GL_FUNCDECL_RPL (fprintf, int, (FILE *fp, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (fprintf, int, (FILE *fp, const char *format, ...));
+# else
+_GL_CXXALIAS_SYS (fprintf, int, (FILE *fp, const char *format, ...));
+# endif
+_GL_CXXALIASWARN (fprintf);
+#endif
+#if address@hidden@ && defined GNULIB_POSIXCHECK
+# if !GNULIB_overrides_fprintf
+# undef fprintf
+# endif
+/* Assume fprintf is always declared. */
+_GL_WARN_ON_USE (fprintf, "fprintf is not always POSIX compliant - "
+ "use gnulib module fprintf-posix for portable "
+ "POSIX compliance");
#endif
#if @GNULIB_FPURGE@
+/* Discard all pending buffered I/O data on STREAM.
+ STREAM must not be wide-character oriented.
+ When discarding pending output, the file position is set back to where it
+ was before the write calls. When discarding pending input, the file
+ position is advanced to match the end of the previously read input.
+ Return 0 if successful. Upon error, return -1 and set errno. */
# if @REPLACE_FPURGE@
-# define fpurge rpl_fpurge
-# endif
-# if @REPLACE_FPURGE@ || address@hidden@
- /* Discard all pending buffered I/O data on STREAM.
- STREAM must not be wide-character oriented.
- When discarding pending output, the file position is set back to where it
- was before the write calls. When discarding pending input, the file
- position is advanced to match the end of the previously read input.
- Return 0 if successful. Upon error, return -1 and set errno. */
- extern int fpurge (FILE *gl_stream) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define fpurge rpl_fpurge
+# endif
+_GL_FUNCDECL_RPL (fpurge, int, (FILE *gl_stream) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (fpurge, int, (FILE *gl_stream));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (fpurge, int, (FILE *gl_stream) _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (fpurge, int, (FILE *gl_stream));
# endif
+_GL_CXXALIASWARN (fpurge);
#elif defined GNULIB_POSIXCHECK
# undef fpurge
-# define fpurge(f) \
- (GL_LINK_WARNING ("fpurge is not always present - " \
- "use gnulib module fpurge for portability"), \
- fpurge (f))
+# if HAVE_RAW_DECL_FPURGE
+_GL_WARN_ON_USE (fpurge, "fpurge is not always present - "
+ "use gnulib module fpurge for portability");
+# endif
#endif
-#if @GNULIB_FPUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef fputc
-# define fputc rpl_fputc
-extern int fputc (int c, FILE *stream) _GL_ARG_NONNULL ((2));
+#if @GNULIB_FPUTC@
+# if @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fputc
+# define fputc rpl_fputc
+# endif
+_GL_FUNCDECL_RPL (fputc, int, (int c, FILE *stream) _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (fputc, int, (int c, FILE *stream));
+# else
+_GL_CXXALIAS_SYS (fputc, int, (int c, FILE *stream));
+# endif
+_GL_CXXALIASWARN (fputc);
#endif
-#if @GNULIB_FPUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef fputs
-# define fputs rpl_fputs
-extern int fputs (const char *string, FILE *stream) _GL_ARG_NONNULL ((1, 2));
+#if @GNULIB_FPUTS@
+# if @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fputs
+# define fputs rpl_fputs
+# endif
+_GL_FUNCDECL_RPL (fputs, int, (const char *string, FILE *stream)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (fputs, int, (const char *string, FILE *stream));
+# else
+_GL_CXXALIAS_SYS (fputs, int, (const char *string, FILE *stream));
+# endif
+_GL_CXXALIASWARN (fputs);
#endif
#if @GNULIB_FREOPEN@
# if @REPLACE_FREOPEN@
-# undef freopen
-# define freopen rpl_freopen
-extern FILE * freopen (const char *filename, const char *mode, FILE *stream)
- _GL_ARG_NONNULL ((2, 3));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef freopen
+# define freopen rpl_freopen
+# endif
+_GL_FUNCDECL_RPL (freopen, FILE *,
+ (const char *filename, const char *mode, FILE *stream)
+ _GL_ARG_NONNULL ((2, 3)));
+_GL_CXXALIAS_RPL (freopen, FILE *,
+ (const char *filename, const char *mode, FILE *stream));
+# else
+_GL_CXXALIAS_SYS (freopen, FILE *,
+ (const char *filename, const char *mode, FILE *stream));
# endif
+_GL_CXXALIASWARN (freopen);
#elif defined GNULIB_POSIXCHECK
# undef freopen
-# define freopen(f,m,s) \
- (GL_LINK_WARNING ("freopen on Win32 platforms is not POSIX compatible - " \
- "use gnulib module freopen for portability"), \
- freopen (f, m, s))
-#endif
-
-#if @GNULIB_FSEEK@ && @REPLACE_FSEEK@
-extern int rpl_fseek (FILE *fp, long offset, int whence) _GL_ARG_NONNULL ((1));
-# undef fseek
-# if defined GNULIB_POSIXCHECK
-# define fseek(f,o,w) \
- (GL_LINK_WARNING ("fseek cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use fseeko function for handling of large files"), \
- rpl_fseek (f, o, w))
+/* Assume freopen is always declared. */
+_GL_WARN_ON_USE (freopen, "freopen on Win32 platforms is not POSIX compatible
- "
+ "use gnulib module freopen for portability");
+#endif
+
+
+/* Set up the following warnings, based on which modules are in use.
+ GNU Coding Standards discourage the use of fseek, since it imposes
+ an arbitrary limitation on some 32-bit hosts. Remember that the
+ fseek module depends on the fseeko module, so we only have three
+ cases to consider:
+
+ 1. The developer is not using either module. Issue a warning under
+ GNULIB_POSIXCHECK for both functions, to remind them that both
+ functions have bugs on some systems. _GL_NO_LARGE_FILES has no
+ impact on this warning.
+
+ 2. The developer is using both modules. They may be unaware of the
+ arbitrary limitations of fseek, so issue a warning under
+ GNULIB_POSIXCHECK. On the other hand, they may be using both
+ modules intentionally, so the developer can define
+ _GL_NO_LARGE_FILES in the compilation units where the use of fseek
+ is safe, to silence the warning.
+
+ 3. The developer is using the fseeko module, but not fseek. Gnulib
+ guarantees that fseek will still work around platform bugs in that
+ case, but we presume that the developer is aware of the pitfalls of
+ fseek and was trying to avoid it, so issue a warning even when
+ GNULIB_POSIXCHECK is undefined. Again, _GL_NO_LARGE_FILES can be
+ defined to silence the warning in particular compilation units.
+ In C++ compilations with GNULIB_NAMESPACE, in order to avoid that
+ fseek gets defined as a macro, it is recommended that the developer
+ uses the fseek module, even if he is not calling the fseek function.
+
+ Most gnulib clients that perform stream operations should fall into
+ category 3. */
+
+#if @GNULIB_FSEEK@
+# if defined GNULIB_POSIXCHECK && !defined _GL_NO_LARGE_FILES
+# define _GL_FSEEK_WARN /* Category 2, above. */
+# undef fseek
+# endif
+# if @REPLACE_FSEEK@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fseek
+# define fseek rpl_fseek
+# endif
+_GL_FUNCDECL_RPL (fseek, int, (FILE *fp, long offset, int whence)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (fseek, int, (FILE *fp, long offset, int whence));
# else
-# define fseek rpl_fseek
-# endif
-#elif defined GNULIB_POSIXCHECK
-# ifndef fseek
-# define fseek(f,o,w) \
- (GL_LINK_WARNING ("fseek cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use fseeko function for handling of large files"), \
- fseek (f, o, w))
+_GL_CXXALIAS_SYS (fseek, int, (FILE *fp, long offset, int whence));
# endif
+_GL_CXXALIASWARN (fseek);
#endif
#if @GNULIB_FSEEKO@
+# if address@hidden@ && !defined _GL_NO_LARGE_FILES
+# define _GL_FSEEK_WARN /* Category 3, above. */
+# undef fseek
+# endif
# if @REPLACE_FSEEKO@
/* Provide fseek, fseeko functions that are aware of a preceding
fflush(), and which detect pipes. */
-# define fseeko rpl_fseeko
-extern int fseeko (FILE *fp, off_t offset, int whence) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fseeko
+# define fseeko rpl_fseeko
+# endif
+_GL_FUNCDECL_RPL (fseeko, int, (FILE *fp, off_t offset, int whence)
+ _GL_ARG_NONNULL ((1)));
# if address@hidden@
+ /* In order to avoid that fseek gets defined as a macro here, the
+ developer can request the 'fseek' module. */
# undef fseek
-# define fseek(f,o,w) \
- (GL_LINK_WARNING ("fseek cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use fseeko function for handling of large files"), \
- fseeko (f, o, w))
+# define fseek rpl_fseek
+static inline int _GL_ARG_NONNULL ((1))
+rpl_fseek (FILE *fp, long offset, int whence)
+{
+ return fseeko (fp, offset, whence);
+}
# endif
+_GL_CXXALIAS_RPL (fseeko, int, (FILE *fp, off_t offset, int whence));
+# else
+_GL_CXXALIAS_SYS (fseeko, int, (FILE *fp, off_t offset, int whence));
# endif
+_GL_CXXALIASWARN (fseeko);
#elif defined GNULIB_POSIXCHECK
+# define _GL_FSEEK_WARN /* Category 1, above. */
+# undef fseek
# undef fseeko
-# define fseeko(f,o,w) \
- (GL_LINK_WARNING ("fseeko is unportable - " \
- "use gnulib module fseeko for portability"), \
- fseeko (f, o, w))
+# if HAVE_RAW_DECL_FSEEKO
+_GL_WARN_ON_USE (fseeko, "fseeko is unportable - "
+ "use gnulib module fseeko for portability");
+# endif
#endif
-#if @GNULIB_FTELL@ && @REPLACE_FTELL@
-extern long rpl_ftell (FILE *fp) _GL_ARG_NONNULL ((1));
-# undef ftell
-# if GNULIB_POSIXCHECK
-# define ftell(f) \
- (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use ftello function for handling of large files"), \
- rpl_ftell (f))
-# else
-# define ftell rpl_ftell
+#ifdef _GL_FSEEK_WARN
+# undef _GL_FSEEK_WARN
+/* Here, either fseek is undefined (but C89 guarantees that it is
+ declared), or it is defined as rpl_fseek (declared above). */
+_GL_WARN_ON_USE (fseek, "fseek cannot handle files larger than 4 GB "
+ "on 32-bit platforms - "
+ "use fseeko function for handling of large files");
+#endif
+
+
+/* ftell, ftello. See the comments on fseek/fseeko. */
+
+#if @GNULIB_FTELL@
+# if defined GNULIB_POSIXCHECK && !defined _GL_NO_LARGE_FILES
+# define _GL_FTELL_WARN /* Category 2, above. */
+# undef ftell
# endif
-#elif defined GNULIB_POSIXCHECK
-# ifndef ftell
-# define ftell(f) \
- (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use ftello function for handling of large files"), \
- ftell (f))
+# if @REPLACE_FTELL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef ftell
+# define ftell rpl_ftell
+# endif
+_GL_FUNCDECL_RPL (ftell, long, (FILE *fp) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (ftell, long, (FILE *fp));
+# else
+_GL_CXXALIAS_SYS (ftell, long, (FILE *fp));
# endif
+_GL_CXXALIASWARN (ftell);
#endif
#if @GNULIB_FTELLO@
+# if address@hidden@ && !defined _GL_NO_LARGE_FILES
+# define _GL_FTELL_WARN /* Category 3, above. */
+# undef ftell
+# endif
# if @REPLACE_FTELLO@
-# define ftello rpl_ftello
-extern off_t ftello (FILE *fp) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef ftello
+# define ftello rpl_ftello
+# endif
+_GL_FUNCDECL_RPL (ftello, off_t, (FILE *fp) _GL_ARG_NONNULL ((1)));
# if address@hidden@
+ /* In order to avoid that ftell gets defined as a macro here, the
+ developer can request the 'ftell' module. */
# undef ftell
-# define ftell(f) \
- (GL_LINK_WARNING ("ftell cannot handle files larger than 4 GB " \
- "on 32-bit platforms - " \
- "use ftello function for handling of large files"), \
- ftello (f))
+# define ftell rpl_ftell
+static inline long _GL_ARG_NONNULL ((1))
+rpl_ftell (FILE *f)
+{
+ return ftello (f);
+}
# endif
+_GL_CXXALIAS_RPL (ftello, off_t, (FILE *fp));
+# else
+_GL_CXXALIAS_SYS (ftello, off_t, (FILE *fp));
# endif
+_GL_CXXALIASWARN (ftello);
#elif defined GNULIB_POSIXCHECK
+# define _GL_FTELL_WARN /* Category 1, above. */
+# undef ftell
# undef ftello
-# define ftello(f) \
- (GL_LINK_WARNING ("ftello is unportable - " \
- "use gnulib module ftello for portability"), \
- ftello (f))
+# if HAVE_RAW_DECL_FTELLO
+_GL_WARN_ON_USE (ftello, "ftello is unportable - "
+ "use gnulib module ftello for portability");
+# endif
#endif
-#if @GNULIB_FWRITE@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef fwrite
-# define fwrite rpl_fwrite
-extern size_t fwrite (const void *ptr, size_t s, size_t n, FILE *stream)
- _GL_ARG_NONNULL ((1, 4));
+#ifdef _GL_FTELL_WARN
+# undef _GL_FTELL_WARN
+/* Here, either ftell is undefined (but C89 guarantees that it is
+ declared), or it is defined as rpl_ftell (declared above). */
+_GL_WARN_ON_USE (ftell, "ftell cannot handle files larger than 4 GB "
+ "on 32-bit platforms - "
+ "use ftello function for handling of large files");
+#endif
+
+
+#if @GNULIB_FWRITE@
+# if @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fwrite
+# define fwrite rpl_fwrite
+# endif
+_GL_FUNCDECL_RPL (fwrite, size_t,
+ (const void *ptr, size_t s, size_t n, FILE *stream)
+ _GL_ARG_NONNULL ((1, 4)));
+_GL_CXXALIAS_RPL (fwrite, size_t,
+ (const void *ptr, size_t s, size_t n, FILE *stream));
+# else
+_GL_CXXALIAS_SYS (fwrite, size_t,
+ (const void *ptr, size_t s, size_t n, FILE *stream));
+# endif
+_GL_CXXALIASWARN (fwrite);
#endif
#if @GNULIB_GETDELIM@
-# if address@hidden@
/* Read input, up to (and including) the next occurrence of DELIMITER, from
STREAM, store it in *LINEPTR (and NUL-terminate it).
*LINEPTR is a pointer returned from malloc (or NULL), pointing to *LINESIZE
bytes of space. It is realloc'd as necessary.
Return the number of bytes read and stored at *LINEPTR (not including the
NUL terminator), or -1 on error or EOF. */
-extern ssize_t getdelim (char **lineptr, size_t *linesize, int delimiter,
- FILE *stream)
- _GL_ARG_NONNULL ((1, 2, 4));
+# if @REPLACE_GETDELIM@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getdelim
+# define getdelim rpl_getdelim
+# endif
+_GL_FUNCDECL_RPL (getdelim, ssize_t,
+ (char **lineptr, size_t *linesize, int delimiter,
+ FILE *stream)
+ _GL_ARG_NONNULL ((1, 2, 4)));
+_GL_CXXALIAS_RPL (getdelim, ssize_t,
+ (char **lineptr, size_t *linesize, int delimiter,
+ FILE *stream));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (getdelim, ssize_t,
+ (char **lineptr, size_t *linesize, int delimiter,
+ FILE *stream)
+ _GL_ARG_NONNULL ((1, 2, 4)));
+# endif
+_GL_CXXALIAS_SYS (getdelim, ssize_t,
+ (char **lineptr, size_t *linesize, int delimiter,
+ FILE *stream));
# endif
+_GL_CXXALIASWARN (getdelim);
#elif defined GNULIB_POSIXCHECK
# undef getdelim
-# define getdelim(l, s, d, f) \
- (GL_LINK_WARNING ("getdelim is unportable - " \
- "use gnulib module getdelim for portability"), \
- getdelim (l, s, d, f))
+# if HAVE_RAW_DECL_GETDELIM
+_GL_WARN_ON_USE (getdelim, "getdelim is unportable - "
+ "use gnulib module getdelim for portability");
+# endif
#endif
#if @GNULIB_GETLINE@
-# if @REPLACE_GETLINE@
-# undef getline
-# define getline rpl_getline
-# endif
-# if address@hidden@ || @REPLACE_GETLINE@
/* Read a line, up to (and including) the next newline, from STREAM, store it
in *LINEPTR (and NUL-terminate it).
*LINEPTR is a pointer returned from malloc (or NULL), pointing to *LINESIZE
bytes of space. It is realloc'd as necessary.
Return the number of bytes read and stored at *LINEPTR (not including the
NUL terminator), or -1 on error or EOF. */
-extern ssize_t getline (char **lineptr, size_t *linesize, FILE *stream)
- _GL_ARG_NONNULL ((1, 2, 3));
+# if @REPLACE_GETLINE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getline
+# define getline rpl_getline
+# endif
+_GL_FUNCDECL_RPL (getline, ssize_t,
+ (char **lineptr, size_t *linesize, FILE *stream)
+ _GL_ARG_NONNULL ((1, 2, 3)));
+_GL_CXXALIAS_RPL (getline, ssize_t,
+ (char **lineptr, size_t *linesize, FILE *stream));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (getline, ssize_t,
+ (char **lineptr, size_t *linesize, FILE *stream)
+ _GL_ARG_NONNULL ((1, 2, 3)));
+# endif
+_GL_CXXALIAS_SYS (getline, ssize_t,
+ (char **lineptr, size_t *linesize, FILE *stream));
# endif
+_GL_CXXALIASWARN (getline);
#elif defined GNULIB_POSIXCHECK
# undef getline
-# define getline(l, s, f) \
- (GL_LINK_WARNING ("getline is unportable - " \
- "use gnulib module getline for portability"), \
- getline (l, s, f))
+# if HAVE_RAW_DECL_GETLINE
+_GL_WARN_ON_USE (getline, "getline is unportable - "
+ "use gnulib module getline for portability");
+# endif
#endif
-#if @GNULIB_OBSTACK_PRINTF@
+#if @GNULIB_OBSTACK_PRINTF@ || @GNULIB_OBSTACK_PRINTF_POSIX@
+struct obstack;
+/* Grow an obstack with formatted output. Return the number of
+ bytes added to OBS. No trailing nul byte is added, and the
+ object should be closed with obstack_finish before use. Upon
+ memory allocation error, call obstack_alloc_failed_handler. Upon
+ other error, return -1. */
# if @REPLACE_OBSTACK_PRINTF@
-# define obstack_printf rpl_osbtack_printf
-# define obstack_vprintf rpl_obstack_vprintf
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define obstack_printf rpl_obstack_printf
+# endif
+_GL_FUNCDECL_RPL (obstack_printf, int,
+ (struct obstack *obs, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (obstack_printf, int,
+ (struct obstack *obs, const char *format, ...));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (obstack_printf, int,
+ (struct obstack *obs, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (obstack_printf, int,
+ (struct obstack *obs, const char *format, ...));
# endif
-# if @REPLACE_OBSTACK_PRINTF@ || address@hidden@
- struct obstack;
- /* Grow an obstack with formatted output. Return the number of
- bytes added to OBS. No trailing nul byte is added, and the
- object should be closed with obstack_finish before use. Upon
- memory allocation error, call obstack_alloc_failed_handler. Upon
- other error, return -1. */
- extern int obstack_printf (struct obstack *obs, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3))) _GL_ARG_NONNULL ((1, 2));
- extern int obstack_vprintf (struct obstack *obs, const char *format,
- va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0))) _GL_ARG_NONNULL ((1, 2));
+_GL_CXXALIASWARN (obstack_printf);
+# if @REPLACE_OBSTACK_PRINTF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define obstack_vprintf rpl_obstack_vprintf
+# endif
+_GL_FUNCDECL_RPL (obstack_vprintf, int,
+ (struct obstack *obs, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (obstack_vprintf, int,
+ (struct obstack *obs, const char *format, va_list args));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (obstack_vprintf, int,
+ (struct obstack *obs, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)))
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (obstack_vprintf, int,
+ (struct obstack *obs, const char *format, va_list args));
# endif
+_GL_CXXALIASWARN (obstack_vprintf);
#endif
#if @GNULIB_PERROR@
-# if @REPLACE_PERROR@
-# define perror rpl_perror
/* Print a message to standard error, describing the value of ERRNO,
(if STRING is not NULL and not empty) prefixed with STRING and ": ",
and terminated with a newline. */
-extern void perror (const char *string);
+# if @REPLACE_PERROR@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define perror rpl_perror
+# endif
+_GL_FUNCDECL_RPL (perror, void, (const char *string));
+_GL_CXXALIAS_RPL (perror, void, (const char *string));
+# else
+_GL_CXXALIAS_SYS (perror, void, (const char *string));
# endif
+_GL_CXXALIASWARN (perror);
#elif defined GNULIB_POSIXCHECK
# undef perror
-# define perror(s) \
- (GL_LINK_WARNING ("perror is not always POSIX compliant - " \
- "use gnulib module perror for portability"), \
- perror (s))
+/* Assume perror is always declared. */
+_GL_WARN_ON_USE (perror, "perror is not always POSIX compliant - "
+ "use gnulib module perror for portability");
#endif
#if @GNULIB_POPEN@
# if @REPLACE_POPEN@
-# undef popen
-# define popen rpl_popen
-extern FILE *popen (const char *cmd, const char *mode)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef popen
+# define popen rpl_popen
+# endif
+_GL_FUNCDECL_RPL (popen, FILE *, (const char *cmd, const char *mode)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (popen, FILE *, (const char *cmd, const char *mode));
+# else
+_GL_CXXALIAS_SYS (popen, FILE *, (const char *cmd, const char *mode));
# endif
+_GL_CXXALIASWARN (popen);
#elif defined GNULIB_POSIXCHECK
# undef popen
-# define popen(c,m) \
- (GL_LINK_WARNING ("popen is buggy on some platforms - " \
- "use gnulib module popen or pipe for more portability"), \
- popen (c, m))
+# if HAVE_RAW_DECL_POPEN
+_GL_WARN_ON_USE (popen, "popen is buggy on some platforms - "
+ "use gnulib module popen or pipe for more portability");
+# endif
#endif
-#if @GNULIB_PRINTF_POSIX@
-# if @REPLACE_PRINTF@
+#if @GNULIB_PRINTF_POSIX@ || @GNULIB_PRINTF@
+# if (@GNULIB_PRINTF_POSIX@ && @REPLACE_PRINTF@) \
+ || (@GNULIB_PRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@)
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
/* Don't break __attribute__((format(printf,M,N))). */
-# define printf __printf__
-extern int printf (const char *format, ...)
- __attribute__ ((__format__ (__printf__, 1, 2))) _GL_ARG_NONNULL ((1));
+# define printf __printf__
+# endif
+# define GNULIB_overrides_printf 1
+_GL_FUNCDECL_RPL_1 (__printf__, int,
+ (const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 1, 2)))
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL_1 (printf, __printf__, int, (const char *format, ...));
+# else
+_GL_CXXALIAS_SYS (printf, int, (const char *format, ...));
# endif
-#elif @GNULIB_PRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@
-/* Don't break __attribute__((format(printf,M,N))). */
-# define printf __printf__
-extern int printf (const char *format, ...)
- __attribute__ ((__format__ (__printf__, 1, 2))) _GL_ARG_NONNULL ((1));
-#elif defined GNULIB_POSIXCHECK
-# undef printf
-# define printf \
- (GL_LINK_WARNING ("printf is not always POSIX compliant - " \
- "use gnulib module printf-posix for portable " \
- "POSIX compliance"), \
- printf)
-/* Don't break __attribute__((format(printf,M,N))). */
-# define format(kind,m,n) format (__##kind##__, m, n)
-# define __format__(kind,m,n) __format__ (__##kind##__, m, n)
-# define ____printf____ __printf__
-# define ____scanf____ __scanf__
-# define ____strftime____ __strftime__
-# define ____strfmon____ __strfmon__
+_GL_CXXALIASWARN (printf);
+#endif
+#if address@hidden@ && defined GNULIB_POSIXCHECK
+# if !GNULIB_overrides_printf
+# undef printf
+# endif
+/* Assume printf is always declared. */
+_GL_WARN_ON_USE (printf, "printf is not always POSIX compliant - "
+ "use gnulib module printf-posix for portable "
+ "POSIX compliance");
#endif
-#if @GNULIB_PUTC@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef putc
-# define putc rpl_fputc
-extern int putc (int c, FILE *stream) _GL_ARG_NONNULL ((2));
+#if @GNULIB_PUTC@
+# if @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef putc
+# define putc rpl_fputc
+# endif
+_GL_FUNCDECL_RPL (fputc, int, (int c, FILE *stream) _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL_1 (putc, rpl_fputc, int, (int c, FILE *stream));
+# else
+_GL_CXXALIAS_SYS (putc, int, (int c, FILE *stream));
+# endif
+_GL_CXXALIASWARN (putc);
#endif
-#if @GNULIB_PUTCHAR@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef putchar
-# define putchar rpl_putchar
-extern int putchar (int c);
+#if @GNULIB_PUTCHAR@
+# if @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef putchar
+# define putchar rpl_putchar
+# endif
+_GL_FUNCDECL_RPL (putchar, int, (int c));
+_GL_CXXALIAS_RPL (putchar, int, (int c));
+# else
+_GL_CXXALIAS_SYS (putchar, int, (int c));
+# endif
+_GL_CXXALIASWARN (putchar);
#endif
-#if @GNULIB_PUTS@ && @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
-# undef puts
-# define puts rpl_puts
-extern int puts (const char *string) _GL_ARG_NONNULL ((1));
+#if @GNULIB_PUTS@
+# if @REPLACE_STDIO_WRITE_FUNCS@ && @GNULIB_STDIO_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef puts
+# define puts rpl_puts
+# endif
+_GL_FUNCDECL_RPL (puts, int, (const char *string) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (puts, int, (const char *string));
+# else
+_GL_CXXALIAS_SYS (puts, int, (const char *string));
+# endif
+_GL_CXXALIASWARN (puts);
#endif
#if @GNULIB_REMOVE@
# if @REPLACE_REMOVE@
-# undef remove
-# define remove rpl_remove
-extern int remove (const char *name) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef remove
+# define remove rpl_remove
+# endif
+_GL_FUNCDECL_RPL (remove, int, (const char *name) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (remove, int, (const char *name));
+# else
+_GL_CXXALIAS_SYS (remove, int, (const char *name));
# endif
+_GL_CXXALIASWARN (remove);
#elif defined GNULIB_POSIXCHECK
# undef remove
-# define remove(n) \
- (GL_LINK_WARNING ("remove cannot handle directories on some platforms - " \
- "use gnulib module remove for more portability"), \
- remove (n))
+/* Assume remove is always declared. */
+_GL_WARN_ON_USE (remove, "remove cannot handle directories on some platforms -
"
+ "use gnulib module remove for more portability");
#endif
#if @GNULIB_RENAME@
# if @REPLACE_RENAME@
-# undef rename
-# define rename rpl_rename
-extern int rename (const char *old_filename, const char *new_filename)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef rename
+# define rename rpl_rename
+# endif
+_GL_FUNCDECL_RPL (rename, int,
+ (const char *old_filename, const char *new_filename)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (rename, int,
+ (const char *old_filename, const char *new_filename));
+# else
+_GL_CXXALIAS_SYS (rename, int,
+ (const char *old_filename, const char *new_filename));
# endif
+_GL_CXXALIASWARN (rename);
#elif defined GNULIB_POSIXCHECK
# undef rename
-# define rename(o,n) \
- (GL_LINK_WARNING ("rename is buggy on some platforms - " \
- "use gnulib module rename for more portability"), \
- rename (o, n))
+/* Assume rename is always declared. */
+_GL_WARN_ON_USE (rename, "rename is buggy on some platforms - "
+ "use gnulib module rename for more portability");
#endif
#if @GNULIB_RENAMEAT@
# if @REPLACE_RENAMEAT@
-# undef renameat
-# define renameat rpl_renameat
-# endif
-# if address@hidden@ || @REPLACE_RENAMEAT@
-extern int renameat (int fd1, char const *file1, int fd2, char const *file2)
- _GL_ARG_NONNULL ((2, 4));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef renameat
+# define renameat rpl_renameat
+# endif
+_GL_FUNCDECL_RPL (renameat, int,
+ (int fd1, char const *file1, int fd2, char const *file2)
+ _GL_ARG_NONNULL ((2, 4)));
+_GL_CXXALIAS_RPL (renameat, int,
+ (int fd1, char const *file1, int fd2, char const *file2));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (renameat, int,
+ (int fd1, char const *file1, int fd2, char const *file2)
+ _GL_ARG_NONNULL ((2, 4)));
+# endif
+_GL_CXXALIAS_SYS (renameat, int,
+ (int fd1, char const *file1, int fd2, char const *file2));
# endif
+_GL_CXXALIASWARN (renameat);
#elif defined GNULIB_POSIXCHECK
# undef renameat
-# define renameat(d1,f1,d2,f2) \
- (GL_LINK_WARNING ("renameat is not portable - " \
- "use gnulib module renameat for portability"), \
- renameat (d1, f1, d2, f2))
+# if HAVE_RAW_DECL_RENAMEAT
+_GL_WARN_ON_USE (renameat, "renameat is not portable - "
+ "use gnulib module renameat for portability");
+# endif
#endif
#if @GNULIB_SNPRINTF@
# if @REPLACE_SNPRINTF@
-# define snprintf rpl_snprintf
-# endif
-# if @REPLACE_SNPRINTF@ || address@hidden@
-extern int snprintf (char *str, size_t size, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 3, 4)))
- _GL_ARG_NONNULL ((3));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define snprintf rpl_snprintf
+# endif
+_GL_FUNCDECL_RPL (snprintf, int,
+ (char *str, size_t size, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 3, 4)))
+ _GL_ARG_NONNULL ((3)));
+_GL_CXXALIAS_RPL (snprintf, int,
+ (char *str, size_t size, const char *format, ...));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (snprintf, int,
+ (char *str, size_t size, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 3, 4)))
+ _GL_ARG_NONNULL ((3)));
+# endif
+_GL_CXXALIAS_SYS (snprintf, int,
+ (char *str, size_t size, const char *format, ...));
# endif
+_GL_CXXALIASWARN (snprintf);
#elif defined GNULIB_POSIXCHECK
# undef snprintf
-# define snprintf \
- (GL_LINK_WARNING ("snprintf is unportable - " \
- "use gnulib module snprintf for portability"), \
- snprintf)
+# if HAVE_RAW_DECL_SNPRINTF
+_GL_WARN_ON_USE (snprintf, "snprintf is unportable - "
+ "use gnulib module snprintf for portability");
+# 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.
+ 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
+ intentionally avoids adding a warning to sprintf except when
+ GNULIB_POSIXCHECK is defined. */
+
#if @GNULIB_SPRINTF_POSIX@
# if @REPLACE_SPRINTF@
-# define sprintf rpl_sprintf
-extern int sprintf (char *str, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3)))
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define sprintf rpl_sprintf
+# endif
+_GL_FUNCDECL_RPL (sprintf, int, (char *str, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (sprintf, int, (char *str, const char *format, ...));
+# else
+_GL_CXXALIAS_SYS (sprintf, int, (char *str, const char *format, ...));
# endif
+_GL_CXXALIASWARN (sprintf);
#elif defined GNULIB_POSIXCHECK
# undef sprintf
-# define sprintf \
- (GL_LINK_WARNING ("sprintf is not always POSIX compliant - " \
- "use gnulib module sprintf-posix for portable " \
- "POSIX compliance"), \
- sprintf)
+/* Assume sprintf is always declared. */
+_GL_WARN_ON_USE (sprintf, "sprintf is not always POSIX compliant - "
+ "use gnulib module sprintf-posix for portable "
+ "POSIX compliance");
#endif
#if @GNULIB_VASPRINTF@
+/* Write formatted output to a string dynamically allocated with malloc().
+ If the memory allocation succeeds, store the address of the string in
+ *RESULT and return the number of resulting bytes, excluding the trailing
+ NUL. Upon memory allocation error, or some other error, return -1. */
# if @REPLACE_VASPRINTF@
-# define asprintf rpl_asprintf
-# define vasprintf rpl_vasprintf
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define asprintf rpl_asprintf
+# endif
+_GL_FUNCDECL_RPL (asprintf, int,
+ (char **result, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (asprintf, int,
+ (char **result, const char *format, ...));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (asprintf, int,
+ (char **result, const char *format, ...)
+ __attribute__ ((__format__ (__printf__, 2, 3)))
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (asprintf, int,
+ (char **result, const char *format, ...));
# endif
-# if @REPLACE_VASPRINTF@ || address@hidden@
- /* Write formatted output to a string dynamically allocated with malloc().
- If the memory allocation succeeds, store the address of the string in
- *RESULT and return the number of resulting bytes, excluding the trailing
- NUL. Upon memory allocation error, or some other error, return -1. */
- extern int asprintf (char **result, const char *format, ...)
- __attribute__ ((__format__ (__printf__, 2, 3))) _GL_ARG_NONNULL ((1, 2));
- extern int vasprintf (char **result, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0))) _GL_ARG_NONNULL ((1, 2));
+_GL_CXXALIASWARN (asprintf);
+# if @REPLACE_VASPRINTF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define vasprintf rpl_vasprintf
+# endif
+_GL_FUNCDECL_RPL (vasprintf, int,
+ (char **result, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (vasprintf, int,
+ (char **result, const char *format, va_list args));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (vasprintf, int,
+ (char **result, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)))
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (vasprintf, int,
+ (char **result, const char *format, va_list args));
# endif
+_GL_CXXALIASWARN (vasprintf);
#endif
#if @GNULIB_VDPRINTF@
# if @REPLACE_VDPRINTF@
-# define vdprintf rpl_vdprintf
-# endif
-# if @REPLACE_VDPRINTF@ || address@hidden@
-extern int vdprintf (int fd, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0))) _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define vdprintf rpl_vdprintf
+# endif
+_GL_FUNCDECL_RPL (vdprintf, int, (int fd, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2,
0)))
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (vdprintf, int, (int fd, const char *format, va_list args));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (vdprintf, int, (int fd, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2,
0)))
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (vdprintf, int, (int fd, const char *format, va_list args));
# endif
+_GL_CXXALIASWARN (vdprintf);
#elif defined GNULIB_POSIXCHECK
# undef vdprintf
-# define vdprintf(d,f,a) \
- (GL_LINK_WARNING ("vdprintf is unportable - " \
- "use gnulib module vdprintf for portability"), \
- vdprintf (d, f, a))
-#endif
-
-#if @GNULIB_VFPRINTF_POSIX@
-# if @REPLACE_VFPRINTF@
-# define vfprintf rpl_vfprintf
-extern int vfprintf (FILE *fp, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)))
- _GL_ARG_NONNULL ((1, 2));
-# endif
-#elif @GNULIB_VFPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@
-# define vfprintf rpl_vfprintf
-extern int vfprintf (FILE *fp, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)))
- _GL_ARG_NONNULL ((1, 2));
-#elif defined GNULIB_POSIXCHECK
-# undef vfprintf
-# define vfprintf(s,f,a) \
- (GL_LINK_WARNING ("vfprintf is not always POSIX compliant - " \
- "use gnulib module vfprintf-posix for portable " \
- "POSIX compliance"), \
- vfprintf (s, f, a))
-#endif
-
-#if @GNULIB_VPRINTF_POSIX@
-# if @REPLACE_VPRINTF@
-# define vprintf rpl_vprintf
-extern int vprintf (const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 1, 0))) _GL_ARG_NONNULL ((1));
-# endif
-#elif @GNULIB_VPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@
-# define vprintf rpl_vprintf
-extern int vprintf (const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 1, 0))) _GL_ARG_NONNULL ((1));
-#elif defined GNULIB_POSIXCHECK
-# undef vprintf
-# define vprintf(f,a) \
- (GL_LINK_WARNING ("vprintf is not always POSIX compliant - " \
- "use gnulib module vprintf-posix for portable " \
- "POSIX compliance"), \
- vprintf (f, a))
+# if HAVE_RAW_DECL_VDPRINTF
+_GL_WARN_ON_USE (vdprintf, "vdprintf is unportable - "
+ "use gnulib module vdprintf for portability");
+# endif
+#endif
+
+#if @GNULIB_VFPRINTF_POSIX@ || @GNULIB_VFPRINTF@
+# if (@GNULIB_VFPRINTF_POSIX@ && @REPLACE_VFPRINTF@) \
+ || (@GNULIB_VFPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@)
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define vfprintf rpl_vfprintf
+# endif
+# define GNULIB_overrides_vfprintf 1
+_GL_FUNCDECL_RPL (vfprintf, int, (FILE *fp, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2,
0)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (vfprintf, int, (FILE *fp, const char *format, va_list args));
+# else
+_GL_CXXALIAS_SYS (vfprintf, int, (FILE *fp, const char *format, va_list args));
+# endif
+_GL_CXXALIASWARN (vfprintf);
+#endif
+#if address@hidden@ && defined GNULIB_POSIXCHECK
+# if !GNULIB_overrides_vfprintf
+# undef vfprintf
+# endif
+/* Assume vfprintf is always declared. */
+_GL_WARN_ON_USE (vfprintf, "vfprintf is not always POSIX compliant - "
+ "use gnulib module vfprintf-posix for portable "
+ "POSIX compliance");
+#endif
+
+#if @GNULIB_VPRINTF_POSIX@ || @GNULIB_VPRINTF@
+# if (@GNULIB_VPRINTF_POSIX@ && @REPLACE_VPRINTF@) \
+ || (@GNULIB_VPRINTF@ && @REPLACE_STDIO_WRITE_FUNCS@ &&
@GNULIB_STDIO_H_SIGPIPE@)
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define vprintf rpl_vprintf
+# endif
+# define GNULIB_overrides_vprintf 1
+_GL_FUNCDECL_RPL (vprintf, int, (const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 1, 0)))
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (vprintf, int, (const char *format, va_list args));
+# else
+_GL_CXXALIAS_SYS (vprintf, int, (const char *format, va_list args));
+# endif
+_GL_CXXALIASWARN (vprintf);
+#endif
+#if address@hidden@ && defined GNULIB_POSIXCHECK
+# if !GNULIB_overrides_vprintf
+# undef vprintf
+# endif
+/* Assume vprintf is always declared. */
+_GL_WARN_ON_USE (vprintf, "vprintf is not always POSIX compliant - "
+ "use gnulib module vprintf-posix for portable "
+ "POSIX compliance");
#endif
#if @GNULIB_VSNPRINTF@
# if @REPLACE_VSNPRINTF@
-# define vsnprintf rpl_vsnprintf
-# endif
-# if @REPLACE_VSNPRINTF@ || address@hidden@
-extern int vsnprintf (char *str, size_t size, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 3, 0)))
- _GL_ARG_NONNULL ((3));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define vsnprintf rpl_vsnprintf
+# endif
+_GL_FUNCDECL_RPL (vsnprintf, int,
+ (char *str, size_t size, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 3, 0)))
+ _GL_ARG_NONNULL ((3)));
+_GL_CXXALIAS_RPL (vsnprintf, int,
+ (char *str, size_t size, const char *format, va_list args));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (vsnprintf, int,
+ (char *str, size_t size, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 3, 0)))
+ _GL_ARG_NONNULL ((3)));
+# endif
+_GL_CXXALIAS_SYS (vsnprintf, int,
+ (char *str, size_t size, const char *format, va_list args));
# endif
+_GL_CXXALIASWARN (vsnprintf);
#elif defined GNULIB_POSIXCHECK
# undef vsnprintf
-# define vsnprintf(b,s,f,a) \
- (GL_LINK_WARNING ("vsnprintf is unportable - " \
- "use gnulib module vsnprintf for portability"), \
- vsnprintf (b, s, f, a))
+# if HAVE_RAW_DECL_VSNPRINTF
+_GL_WARN_ON_USE (vsnprintf, "vsnprintf is unportable - "
+ "use gnulib module vsnprintf for portability");
+# endif
#endif
#if @GNULIB_VSPRINTF_POSIX@
# if @REPLACE_VSPRINTF@
-# define vsprintf rpl_vsprintf
-extern int vsprintf (char *str, const char *format, va_list args)
- __attribute__ ((__format__ (__printf__, 2, 0)))
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define vsprintf rpl_vsprintf
+# endif
+_GL_FUNCDECL_RPL (vsprintf, int,
+ (char *str, const char *format, va_list args)
+ __attribute__ ((__format__ (__printf__, 2, 0)))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (vsprintf, int,
+ (char *str, const char *format, va_list args));
+# else
+_GL_CXXALIAS_SYS (vsprintf, int,
+ (char *str, const char *format, va_list args));
# endif
+_GL_CXXALIASWARN (vsprintf);
#elif defined GNULIB_POSIXCHECK
# undef vsprintf
-# define vsprintf(b,f,a) \
- (GL_LINK_WARNING ("vsprintf is not always POSIX compliant - " \
- "use gnulib module vsprintf-posix for portable " \
- "POSIX compliance"), \
- vsprintf (b, f, a))
+/* Assume vsprintf is always declared. */
+_GL_WARN_ON_USE (vsprintf, "vsprintf is not always POSIX compliant - "
+ "use gnulib module vsprintf-posix for portable "
+ "POSIX compliance");
#endif
-#ifdef __cplusplus
-}
-#endif
#endif /* _GL_STDIO_H */
#endif /* _GL_STDIO_H */
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
index f566ab9..00415e0 100644
--- a/lib/stdlib.in.h
+++ b/lib/stdlib.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <stdlib.h>.
- Copyright (C) 1995, 2001-2004, 2006-2009 Free Software Foundation, Inc.
+ Copyright (C) 1995, 2001-2004, 2006-2010 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
@@ -39,7 +39,7 @@
#include <stddef.h>
/* Solaris declares getloadavg() in <sys/loadavg.h>. */
-#if @GNULIB_GETLOADAVG@ && @HAVE_SYS_LOADAVG_H@
+#if (@GNULIB_GETLOADAVG@ || defined GNULIB_POSIXCHECK) && @HAVE_SYS_LOADAVG_H@
# include <sys/loadavg.h>
#endif
@@ -49,7 +49,8 @@
# include <random.h>
#endif
-#if @GNULIB_RANDOM_R@ || address@hidden@
+#if address@hidden@ || (@GNULIB_RANDOM_R@ && address@hidden@) \
+ || defined GNULIB_POSIXCHECK
# include <stdint.h>
#endif
@@ -66,10 +67,19 @@ struct random_data
};
#endif
-/* The definition of GL_LINK_WARNING is copied here. */
+#if (@GNULIB_MKSTEMP@ || @GNULIB_GETSUBOPT@ || defined GNULIB_POSIXCHECK) && !
defined __GLIBC__
+/* On MacOS X 10.3, only <unistd.h> declares mkstemp. */
+/* On Cygwin 1.7.1, only <unistd.h> declares getsubopt. */
+/* But avoid namespace pollution on glibc systems. */
+# include <unistd.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. */
+
/* Some systems do not define EXIT_*, despite otherwise supporting C89. */
#ifndef EXIT_SUCCESS
@@ -85,67 +95,82 @@ struct random_data
#endif
-#ifdef __cplusplus
-extern "C" {
-#endif
-
#if @GNULIB_ATOLL@
-# if address@hidden@
/* Parse a signed decimal integer.
Returns the value of the integer. Errors are not detected. */
-extern long long atoll (const char *string) _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (atoll, long long, (const char *string) _GL_ARG_NONNULL
((1)));
# endif
+_GL_CXXALIAS_SYS (atoll, long long, (const char *string));
+_GL_CXXALIASWARN (atoll);
#elif defined GNULIB_POSIXCHECK
# undef atoll
-# define atoll(s) \
- (GL_LINK_WARNING ("atoll is unportable - " \
- "use gnulib module atoll for portability"), \
- atoll (s))
+# if HAVE_RAW_DECL_ATOLL
+_GL_WARN_ON_USE (atoll, "atoll is unportable - "
+ "use gnulib module atoll for portability");
+# endif
#endif
#if @GNULIB_CALLOC_POSIX@
# if address@hidden@
-# undef calloc
-# define calloc rpl_calloc
-extern void * calloc (size_t nmemb, size_t size);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef calloc
+# define calloc rpl_calloc
+# endif
+_GL_FUNCDECL_RPL (calloc, void *, (size_t nmemb, size_t size));
+_GL_CXXALIAS_RPL (calloc, void *, (size_t nmemb, size_t size));
+# else
+_GL_CXXALIAS_SYS (calloc, void *, (size_t nmemb, size_t size));
# endif
+_GL_CXXALIASWARN (calloc);
#elif defined GNULIB_POSIXCHECK
# undef calloc
-# define calloc(n,s) \
- (GL_LINK_WARNING ("calloc is not POSIX compliant everywhere - " \
- "use gnulib module calloc-posix for portability"), \
- calloc (n, s))
+/* Assume calloc is always declared. */
+_GL_WARN_ON_USE (calloc, "calloc is not POSIX compliant everywhere - "
+ "use gnulib module calloc-posix for portability");
#endif
#if @GNULIB_CANONICALIZE_FILE_NAME@
# if @REPLACE_CANONICALIZE_FILE_NAME@
-# define canonicalize_file_name rpl_canonicalize_file_name
-# endif
-# if address@hidden@ || @REPLACE_CANONICALIZE_FILE_NAME@
-extern char *canonicalize_file_name (const char *name) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define canonicalize_file_name rpl_canonicalize_file_name
+# endif
+_GL_FUNCDECL_RPL (canonicalize_file_name, char *, (const char *name)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (canonicalize_file_name, char *, (const char *name));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (canonicalize_file_name, char *, (const char *name)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (canonicalize_file_name, char *, (const char *name));
# endif
+_GL_CXXALIASWARN (canonicalize_file_name);
#elif defined GNULIB_POSIXCHECK
# undef canonicalize_file_name
-# define canonicalize_file_name(n) \
- (GL_LINK_WARNING ("canonicalize_file_name is unportable - " \
- "use gnulib module canonicalize-lgpl for portability"), \
- canonicalize_file_name (n))
+# if HAVE_RAW_DECL_CANONICALIZE_FILE_NAME
+_GL_WARN_ON_USE (canonicalize_file_name, "canonicalize_file_name is unportable
- "
+ "use gnulib module canonicalize-lgpl for portability");
+# endif
#endif
#if @GNULIB_GETLOADAVG@
-# if address@hidden@
/* Store max(NELEM,3) load average numbers in LOADAVG[].
The three numbers are the load average of the last 1 minute, the last 5
minutes, and the last 15 minutes, respectively.
LOADAVG is an array of NELEM numbers. */
-extern int getloadavg (double loadavg[], int nelem) _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (getloadavg, int, (double loadavg[], int nelem)
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (getloadavg, int, (double loadavg[], int nelem));
+_GL_CXXALIASWARN (getloadavg);
#elif defined GNULIB_POSIXCHECK
# undef getloadavg
-# define getloadavg(l,n) \
- (GL_LINK_WARNING ("getloadavg is not portable - " \
- "use gnulib module getloadavg for portability"), \
- getloadavg (l, n))
+# if HAVE_RAW_DECL_GETLOADAVG
+_GL_WARN_ON_USE (getloadavg, "getloadavg is not portable - "
+ "use gnulib module getloadavg for portability");
+# endif
#endif
#if @GNULIB_GETSUBOPT@
@@ -161,50 +186,60 @@ extern int getloadavg (double loadavg[], int nelem)
_GL_ARG_NONNULL ((1));
For more details see the POSIX:2001 specification.
http://www.opengroup.org/susv3xsh/getsubopt.html */
# if address@hidden@
-extern int getsubopt (char **optionp, char *const *tokens, char **valuep)
- _GL_ARG_NONNULL ((1, 2, 3));
+_GL_FUNCDECL_SYS (getsubopt, int,
+ (char **optionp, char *const *tokens, char **valuep)
+ _GL_ARG_NONNULL ((1, 2, 3)));
# endif
+_GL_CXXALIAS_SYS (getsubopt, int,
+ (char **optionp, char *const *tokens, char **valuep));
+_GL_CXXALIASWARN (getsubopt);
#elif defined GNULIB_POSIXCHECK
# undef getsubopt
-# define getsubopt(o,t,v) \
- (GL_LINK_WARNING ("getsubopt is unportable - " \
- "use gnulib module getsubopt for portability"), \
- getsubopt (o, t, v))
+# if HAVE_RAW_DECL_GETSUBOPT
+_GL_WARN_ON_USE (getsubopt, "getsubopt is unportable - "
+ "use gnulib module getsubopt for portability");
+# endif
#endif
#if @GNULIB_MALLOC_POSIX@
# if address@hidden@
-# undef malloc
-# define malloc rpl_malloc
-extern void * malloc (size_t size);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef malloc
+# define malloc rpl_malloc
+# endif
+_GL_FUNCDECL_RPL (malloc, void *, (size_t size));
+_GL_CXXALIAS_RPL (malloc, void *, (size_t size));
+# else
+_GL_CXXALIAS_SYS (malloc, void *, (size_t size));
# endif
+_GL_CXXALIASWARN (malloc);
#elif defined GNULIB_POSIXCHECK
# undef malloc
-# define malloc(s) \
- (GL_LINK_WARNING ("malloc is not POSIX compliant everywhere - " \
- "use gnulib module malloc-posix for portability"), \
- malloc (s))
+/* Assume malloc is always declared. */
+_GL_WARN_ON_USE (malloc, "malloc is not POSIX compliant everywhere - "
+ "use gnulib module malloc-posix for portability");
#endif
#if @GNULIB_MKDTEMP@
-# if address@hidden@
/* Create a unique temporary directory from TEMPLATE.
The last six characters of TEMPLATE must be "XXXXXX";
they are replaced with a string that makes the directory name unique.
Returns TEMPLATE, or a null pointer if it cannot get a unique name.
The directory is created mode 700. */
-extern char * mkdtemp (char * /*template*/) _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (mkdtemp, char *, (char * /*template*/) _GL_ARG_NONNULL
((1)));
# endif
+_GL_CXXALIAS_SYS (mkdtemp, char *, (char * /*template*/));
+_GL_CXXALIASWARN (mkdtemp);
#elif defined GNULIB_POSIXCHECK
# undef mkdtemp
-# define mkdtemp(t) \
- (GL_LINK_WARNING ("mkdtemp is unportable - " \
- "use gnulib module mkdtemp for portability"), \
- mkdtemp (t))
+# if HAVE_RAW_DECL_MKDTEMP
+_GL_WARN_ON_USE (mkdtemp, "mkdtemp is unportable - "
+ "use gnulib module mkdtemp for portability");
+# endif
#endif
#if @GNULIB_MKOSTEMP@
-# if address@hidden@
/* Create a unique temporary file from TEMPLATE.
The last six characters of TEMPLATE must be "XXXXXX";
they are replaced with a string that makes the file name unique.
@@ -217,18 +252,21 @@ extern char * mkdtemp (char * /*template*/)
_GL_ARG_NONNULL ((1));
implementation.
Returns the open file descriptor if successful, otherwise -1 and errno
set. */
-extern int mkostemp (char * /*template*/, int /*flags*/) _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (mkostemp, int, (char * /*template*/, int /*flags*/)
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (mkostemp, int, (char * /*template*/, int /*flags*/));
+_GL_CXXALIASWARN (mkostemp);
#elif defined GNULIB_POSIXCHECK
# undef mkostemp
-# define mkostemp(t,f) \
- (GL_LINK_WARNING ("mkostemp is unportable - " \
- "use gnulib module mkostemp for portability"), \
- mkostemp (t, f))
+# if HAVE_RAW_DECL_MKOSTEMP
+_GL_WARN_ON_USE (mkostemp, "mkostemp is unportable - "
+ "use gnulib module mkostemp for portability");
+# endif
#endif
#if @GNULIB_MKOSTEMPS@
-# if address@hidden@
/* Create a unique temporary file from TEMPLATE.
The last six characters of TEMPLATE before a suffix of length
SUFFIXLEN must be "XXXXXX";
@@ -242,19 +280,23 @@ extern int mkostemp (char * /*template*/, int /*flags*/)
_GL_ARG_NONNULL ((1));
implementation.
Returns the open file descriptor if successful, otherwise -1 and errno
set. */
-extern int mkostemps (char * /*template*/, int /*suffixlen*/, int /*flags*/)
- _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (mkostemps, int,
+ (char * /*template*/, int /*suffixlen*/, int /*flags*/)
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (mkostemps, int,
+ (char * /*template*/, int /*suffixlen*/, int /*flags*/));
+_GL_CXXALIASWARN (mkostemps);
#elif defined GNULIB_POSIXCHECK
# undef mkostemps
-# define mkostemps(t,s,f) \
- (GL_LINK_WARNING ("mkostemps is unportable - " \
- "use gnulib module mkostemps for portability"), \
- mkostemps (t, s, f))
+# if HAVE_RAW_DECL_MKOSTEMPS
+_GL_WARN_ON_USE (mkostemps, "mkostemps is unportable - "
+ "use gnulib module mkostemps for portability");
+# endif
#endif
#if @GNULIB_MKSTEMP@
-# if @REPLACE_MKSTEMP@
/* Create a unique temporary file from TEMPLATE.
The last six characters of TEMPLATE must be "XXXXXX";
they are replaced with a string that makes the file name unique.
@@ -264,22 +306,25 @@ extern int mkostemps (char * /*template*/, int
/*suffixlen*/, int /*flags*/)
implementation.
Returns the open file descriptor if successful, otherwise -1 and errno
set. */
-# define mkstemp rpl_mkstemp
-extern int mkstemp (char * /*template*/) _GL_ARG_NONNULL ((1));
+# if @REPLACE_MKSTEMP@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define mkstemp rpl_mkstemp
+# endif
+_GL_FUNCDECL_RPL (mkstemp, int, (char * /*template*/) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mkstemp, int, (char * /*template*/));
# else
-/* On MacOS X 10.3, only <unistd.h> declares mkstemp. */
-# include <unistd.h>
+_GL_CXXALIAS_SYS (mkstemp, int, (char * /*template*/));
# endif
+_GL_CXXALIASWARN (mkstemp);
#elif defined GNULIB_POSIXCHECK
# undef mkstemp
-# define mkstemp(t) \
- (GL_LINK_WARNING ("mkstemp is unportable - " \
- "use gnulib module mkstemp for portability"), \
- mkstemp (t))
+# if HAVE_RAW_DECL_MKSTEMP
+_GL_WARN_ON_USE (mkstemp, "mkstemp is unportable - "
+ "use gnulib module mkstemp for portability");
+# endif
#endif
#if @GNULIB_MKSTEMPS@
-# if address@hidden@
/* Create a unique temporary file from TEMPLATE.
The last six characters of TEMPLATE prior to a suffix of length
SUFFIXLEN must be "XXXXXX";
@@ -290,145 +335,228 @@ extern int mkstemp (char * /*template*/)
_GL_ARG_NONNULL ((1));
implementation.
Returns the open file descriptor if successful, otherwise -1 and errno
set. */
-extern int mkstemps (char * /*template*/, int /*suffixlen*/)
- _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (mkstemps, int, (char * /*template*/, int /*suffixlen*/)
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (mkstemps, int, (char * /*template*/, int /*suffixlen*/));
+_GL_CXXALIASWARN (mkstemps);
#elif defined GNULIB_POSIXCHECK
# undef mkstemps
-# define mkstemps(t,s) \
- (GL_LINK_WARNING ("mkstemps is unportable - " \
- "use gnulib module mkstemps for portability"), \
- mkstemps (t, s))
+# if HAVE_RAW_DECL_MKSTEMPS
+_GL_WARN_ON_USE (mkstemps, "mkstemps is unportable - "
+ "use gnulib module mkstemps for portability");
+# endif
#endif
#if @GNULIB_PUTENV@
# if @REPLACE_PUTENV@
-# undef putenv
-# define putenv rpl_putenv
-extern int putenv (char *string) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef putenv
+# define putenv rpl_putenv
+# endif
+_GL_FUNCDECL_RPL (putenv, int, (char *string) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (putenv, int, (char *string));
+# else
+_GL_CXXALIAS_SYS (putenv, int, (char *string));
# endif
+_GL_CXXALIASWARN (putenv);
#endif
+
#if @GNULIB_RANDOM_R@
# if address@hidden@
-
# ifndef RAND_MAX
# define RAND_MAX 2147483647
# endif
+# endif
+#endif
-int srandom_r (unsigned int seed, struct random_data *rand_state)
- _GL_ARG_NONNULL ((2));
-int initstate_r (unsigned int seed, char *buf, size_t buf_size,
- struct random_data *rand_state)
- _GL_ARG_NONNULL ((2, 4));
-int setstate_r (char *arg_state, struct random_data *rand_state)
- _GL_ARG_NONNULL ((1, 2));
-int random_r (struct random_data *buf, int32_t *result)
- _GL_ARG_NONNULL ((1, 2));
+#if @GNULIB_RANDOM_R@
+# if address@hidden@
+_GL_FUNCDECL_SYS (random_r, int, (struct random_data *buf, int32_t *result)
+ _GL_ARG_NONNULL ((1, 2)));
# endif
+_GL_CXXALIAS_SYS (random_r, int, (struct random_data *buf, int32_t *result));
+_GL_CXXALIASWARN (random_r);
#elif defined GNULIB_POSIXCHECK
# undef random_r
-# define random_r(b,r) \
- (GL_LINK_WARNING ("random_r is unportable - " \
- "use gnulib module random_r for portability"), \
- random_r (b,r))
-# undef initstate_r
-# define initstate_r(s,b,sz,r) \
- (GL_LINK_WARNING ("initstate_r is unportable - " \
- "use gnulib module random_r for portability"), \
- initstate_r (s,b,sz,r))
+# if HAVE_RAW_DECL_RANDOM_R
+_GL_WARN_ON_USE (random_r, "random_r is unportable - "
+ "use gnulib module random_r for portability");
+# endif
+#endif
+
+#if @GNULIB_RANDOM_R@
+# if address@hidden@
+_GL_FUNCDECL_SYS (srandom_r, int,
+ (unsigned int seed, struct random_data *rand_state)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (srandom_r, int,
+ (unsigned int seed, struct random_data *rand_state));
+_GL_CXXALIASWARN (srandom_r);
+#elif defined GNULIB_POSIXCHECK
# undef srandom_r
-# define srandom_r(s,r) \
- (GL_LINK_WARNING ("srandom_r is unportable - " \
- "use gnulib module random_r for portability"), \
- srandom_r (s,r))
+# if HAVE_RAW_DECL_SRANDOM_R
+_GL_WARN_ON_USE (srandom_r, "srandom_r is unportable - "
+ "use gnulib module random_r for portability");
+# endif
+#endif
+
+#if @GNULIB_RANDOM_R@
+# if address@hidden@
+_GL_FUNCDECL_SYS (initstate_r, int,
+ (unsigned int seed, char *buf, size_t buf_size,
+ struct random_data *rand_state)
+ _GL_ARG_NONNULL ((2, 4)));
+# endif
+_GL_CXXALIAS_SYS (initstate_r, int,
+ (unsigned int seed, char *buf, size_t buf_size,
+ struct random_data *rand_state));
+_GL_CXXALIASWARN (initstate_r);
+#elif defined GNULIB_POSIXCHECK
+# undef initstate_r
+# if HAVE_RAW_DECL_INITSTATE_R
+_GL_WARN_ON_USE (initstate_r, "initstate_r is unportable - "
+ "use gnulib module random_r for portability");
+# endif
+#endif
+
+#if @GNULIB_RANDOM_R@
+# if address@hidden@
+_GL_FUNCDECL_SYS (setstate_r, int,
+ (char *arg_state, struct random_data *rand_state)
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (setstate_r, int,
+ (char *arg_state, struct random_data *rand_state));
+_GL_CXXALIASWARN (setstate_r);
+#elif defined GNULIB_POSIXCHECK
# undef setstate_r
-# define setstate_r(a,r) \
- (GL_LINK_WARNING ("setstate_r is unportable - " \
- "use gnulib module random_r for portability"), \
- setstate_r (a,r))
+# if HAVE_RAW_DECL_SETSTATE_R
+_GL_WARN_ON_USE (setstate_r, "setstate_r is unportable - "
+ "use gnulib module random_r for portability");
+# endif
#endif
+
#if @GNULIB_REALLOC_POSIX@
# if address@hidden@
-# undef realloc
-# define realloc rpl_realloc
-extern void * realloc (void *ptr, size_t size);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef realloc
+# define realloc rpl_realloc
+# endif
+_GL_FUNCDECL_RPL (realloc, void *, (void *ptr, size_t size));
+_GL_CXXALIAS_RPL (realloc, void *, (void *ptr, size_t size));
+# else
+_GL_CXXALIAS_SYS (realloc, void *, (void *ptr, size_t size));
# endif
+_GL_CXXALIASWARN (realloc);
#elif defined GNULIB_POSIXCHECK
# undef realloc
-# define realloc(p,s) \
- (GL_LINK_WARNING ("realloc is not POSIX compliant everywhere - " \
- "use gnulib module realloc-posix for portability"), \
- realloc (p, s))
+/* Assume realloc is always declared. */
+_GL_WARN_ON_USE (realloc, "realloc is not POSIX compliant everywhere - "
+ "use gnulib module realloc-posix for portability");
#endif
#if @GNULIB_REALPATH@
# if @REPLACE_REALPATH@
-# define realpath rpl_realpath
-# endif
-# if address@hidden@ || @REPLACE_REALPATH@
-extern char *realpath (const char *name, char *resolved) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define realpath rpl_realpath
+# endif
+_GL_FUNCDECL_RPL (realpath, char *, (const char *name, char *resolved)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (realpath, char *, (const char *name, char *resolved));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (realpath, char *, (const char *name, char *resolved)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (realpath, char *, (const char *name, char *resolved));
# endif
+_GL_CXXALIASWARN (realpath);
#elif defined GNULIB_POSIXCHECK
# undef realpath
-# define realpath(n,r) \
- (GL_LINK_WARNING ("realpath is unportable - use gnulib module " \
- "canonicalize or canonicalize-lgpl for portability"), \
- realpath (n, r))
+# if HAVE_RAW_DECL_REALPATH
+_GL_WARN_ON_USE (realpath, "realpath is unportable - use gnulib module "
+ "canonicalize or canonicalize-lgpl for portability");
+# endif
#endif
#if @GNULIB_RPMATCH@
-# if address@hidden@
/* Test a user response to a question.
Return 1 if it is affirmative, 0 if it is negative, or -1 if not clear. */
-extern int rpmatch (const char *response) _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (rpmatch, int, (const char *response) _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (rpmatch, int, (const char *response));
+_GL_CXXALIASWARN (rpmatch);
#elif defined GNULIB_POSIXCHECK
# undef rpmatch
-# define rpmatch(r) \
- (GL_LINK_WARNING ("rpmatch is unportable - " \
- "use gnulib module rpmatch for portability"), \
- rpmatch (r))
+# if HAVE_RAW_DECL_RPMATCH
+_GL_WARN_ON_USE (rpmatch, "rpmatch is unportable - "
+ "use gnulib module rpmatch for portability");
+# endif
#endif
#if @GNULIB_SETENV@
-# if @REPLACE_SETENV@
-# undef setenv
-# define setenv rpl_setenv
-# endif
-# if address@hidden@ || @REPLACE_SETENV@
/* Set NAME to VALUE in the environment.
If REPLACE is nonzero, overwrite an existing value. */
-extern int setenv (const char *name, const char *value, int replace)
- _GL_ARG_NONNULL ((1));
+# if @REPLACE_SETENV@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef setenv
+# define setenv rpl_setenv
+# endif
+_GL_FUNCDECL_RPL (setenv, int,
+ (const char *name, const char *value, int replace)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (setenv, int,
+ (const char *name, const char *value, int replace));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (setenv, int,
+ (const char *name, const char *value, int replace)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (setenv, int,
+ (const char *name, const char *value, int replace));
# endif
+_GL_CXXALIASWARN (setenv);
#elif defined GNULIB_POSIXCHECK
# undef setenv
-# define setenv(n,v,o) \
- (GL_LINK_WARNING ("setenv is unportable - " \
- "use gnulib module setenv for portability"), \
- setenv (n, v, o))
+# if HAVE_RAW_DECL_SETENV
+_GL_WARN_ON_USE (setenv, "setenv is unportable - "
+ "use gnulib module setenv for portability");
+# endif
#endif
#if @GNULIB_STRTOD@
-# if @REPLACE_STRTOD@
-# define strtod rpl_strtod
-# endif
-# if address@hidden@ || @REPLACE_STRTOD@
/* Parse a double from STRING, updating ENDP if appropriate. */
-extern double strtod (const char *str, char **endp) _GL_ARG_NONNULL ((1));
+# if @REPLACE_STRTOD@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define strtod rpl_strtod
+# endif
+_GL_FUNCDECL_RPL (strtod, double, (const char *str, char **endp)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (strtod, double, (const char *str, char **endp));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (strtod, double, (const char *str, char **endp)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (strtod, double, (const char *str, char **endp));
# endif
+_GL_CXXALIASWARN (strtod);
#elif defined GNULIB_POSIXCHECK
# undef strtod
-# define strtod(s, e) \
- (GL_LINK_WARNING ("strtod is unportable - " \
- "use gnulib module strtod for portability"), \
- strtod (s, e))
+# if HAVE_RAW_DECL_STRTOD
+_GL_WARN_ON_USE (strtod, "strtod is unportable - "
+ "use gnulib module strtod for portability");
+# endif
#endif
#if @GNULIB_STRTOLL@
-# if address@hidden@
/* Parse a signed integer whose textual representation starts at STRING.
The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0,
it may be decimal or octal (with prefix "0") or hexadecimal (with prefix
@@ -437,19 +565,23 @@ extern double strtod (const char *str, char **endp)
_GL_ARG_NONNULL ((1));
stored in *ENDPTR.
Upon overflow, the return value is LLONG_MAX or LLONG_MIN, and errno is set
to ERANGE. */
-extern long long strtoll (const char *string, char **endptr, int base)
- _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (strtoll, long long,
+ (const char *string, char **endptr, int base)
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (strtoll, long long,
+ (const char *string, char **endptr, int base));
+_GL_CXXALIASWARN (strtoll);
#elif defined GNULIB_POSIXCHECK
# undef strtoll
-# define strtoll(s,e,b) \
- (GL_LINK_WARNING ("strtoll is unportable - " \
- "use gnulib module strtoll for portability"), \
- strtoll (s, e, b))
+# if HAVE_RAW_DECL_STRTOLL
+_GL_WARN_ON_USE (strtoll, "strtoll is unportable - "
+ "use gnulib module strtoll for portability");
+# endif
#endif
#if @GNULIB_STRTOULL@
-# if address@hidden@
/* Parse an unsigned integer whose textual representation starts at STRING.
The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0,
it may be decimal or octal (with prefix "0") or hexadecimal (with prefix
@@ -458,37 +590,46 @@ extern long long strtoll (const char *string, char
**endptr, int base)
stored in *ENDPTR.
Upon overflow, the return value is ULLONG_MAX, and errno is set to
ERANGE. */
-extern unsigned long long strtoull (const char *string, char **endptr, int
base)
- _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (strtoull, unsigned long long,
+ (const char *string, char **endptr, int base)
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (strtoull, unsigned long long,
+ (const char *string, char **endptr, int base));
+_GL_CXXALIASWARN (strtoull);
#elif defined GNULIB_POSIXCHECK
# undef strtoull
-# define strtoull(s,e,b) \
- (GL_LINK_WARNING ("strtoull is unportable - " \
- "use gnulib module strtoull for portability"), \
- strtoull (s, e, b))
+# if HAVE_RAW_DECL_STRTOULL
+_GL_WARN_ON_USE (strtoull, "strtoull is unportable - "
+ "use gnulib module strtoull for portability");
+# endif
#endif
#if @GNULIB_UNSETENV@
-# if @REPLACE_UNSETENV@
-# undef unsetenv
-# define unsetenv rpl_unsetenv
-# endif
-# if address@hidden@ || @REPLACE_UNSETENV@
/* Remove the variable NAME from the environment. */
-extern int unsetenv (const char *name) _GL_ARG_NONNULL ((1));
+# if @REPLACE_UNSETENV@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef unsetenv
+# define unsetenv rpl_unsetenv
+# endif
+_GL_FUNCDECL_RPL (unsetenv, int, (const char *name) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (unsetenv, int, (const char *name));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (unsetenv, int, (const char *name) _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (unsetenv, int, (const char *name));
# endif
+_GL_CXXALIASWARN (unsetenv);
#elif defined GNULIB_POSIXCHECK
# undef unsetenv
-# define unsetenv(n) \
- (GL_LINK_WARNING ("unsetenv is unportable - " \
- "use gnulib module unsetenv for portability"), \
- unsetenv (n))
+# if HAVE_RAW_DECL_UNSETENV
+_GL_WARN_ON_USE (unsetenv, "unsetenv is unportable - "
+ "use gnulib module unsetenv for portability");
+# endif
#endif
-#ifdef __cplusplus
-}
-#endif
#endif /* _GL_STDLIB_H */
#endif /* _GL_STDLIB_H */
diff --git a/lib/strcasecmp.c b/lib/strcasecmp.c
index cc4778a..2891544 100644
--- a/lib/strcasecmp.c
+++ b/lib/strcasecmp.c
@@ -1,5 +1,5 @@
/* Case-insensitive string comparison function.
- Copyright (C) 1998-1999, 2005-2007 Free Software Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2007, 2009-2010 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
diff --git a/lib/streq.h b/lib/streq.h
index 1b4b1c5..8791598 100644
--- a/lib/streq.h
+++ b/lib/streq.h
@@ -1,5 +1,5 @@
/* Optimized string comparison.
- Copyright (C) 2001-2002, 2007 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2007, 2009-2010 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
diff --git a/lib/strftime.c b/lib/strftime.c
index a5cab69..c6a9ed2 100644
--- a/lib/strftime.c
+++ b/lib/strftime.c
@@ -1,5 +1,4 @@
-/* Copyright (C) 1991-1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007, 2009
Free Software
- Foundation, Inc.
+/* Copyright (C) 1991-2001, 2003-2007, 2009-2010 Free Software Foundation, Inc.
NOTE: The canonical source of this file is maintained with the GNU C
Library.
Bugs can be reported to address@hidden
diff --git a/lib/strftime.h b/lib/strftime.h
index 5f984b8..92501c3 100644
--- a/lib/strftime.h
+++ b/lib/strftime.h
@@ -1,6 +1,6 @@
/* declarations for strftime.c
- Copyright (C) 2002, 2004, 2008 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2004, 2008-2010 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
diff --git a/lib/striconveh.c b/lib/striconveh.c
index adb571e..ae10f3c 100644
--- a/lib/striconveh.c
+++ b/lib/striconveh.c
@@ -1,5 +1,5 @@
/* Character set conversion with error handling.
- Copyright (C) 2001-2009 Free Software Foundation, Inc.
+ Copyright (C) 2001-2010 Free Software Foundation, Inc.
Written by Bruno Haible and Simon Josefsson.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/striconveh.h b/lib/striconveh.h
index be5e500..dc92cea 100644
--- a/lib/striconveh.h
+++ b/lib/striconveh.h
@@ -1,5 +1,5 @@
/* Character set conversion with error handling.
- Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2001-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible and Simon Josefsson.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/string.in.h b/lib/string.in.h
index 7a0a9a2..ee1a03d 100644
--- a/lib/string.in.h
+++ b/lib/string.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <string.h>.
- Copyright (C) 1995-1996, 2001-2009 Free Software Foundation, Inc.
+ Copyright (C) 1995-1996, 2001-2010 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
@@ -31,6 +31,11 @@
/* NetBSD 5.0 mis-defines NULL. */
#include <stddef.h>
+/* MirBSD defines mbslen as a macro. */
+#if @GNULIB_MBSLEN@ && defined __MirBSD__
+# include <wchar.h>
+#endif
+
#ifndef __attribute__
/* This feature is available in gcc versions 2.5 and later. */
# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5)
@@ -43,78 +48,127 @@
#endif
-/* The definition of GL_LINK_WARNING is copied here. */
+/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
-
-#ifdef __cplusplus
-extern "C" {
-#endif
+/* The definition of _GL_WARN_ON_USE is copied here. */
/* Return the first instance of C within N bytes of S, or NULL. */
#if @GNULIB_MEMCHR@
# if @REPLACE_MEMCHR@
-# define memchr rpl_memchr
-extern void *memchr (void const *__s, int __c, size_t __n)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define memchr rpl_memchr
+# endif
+_GL_FUNCDECL_RPL (memchr, void *, (void const *__s, int __c, size_t __n)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (memchr, void *, (void const *__s, int __c, size_t __n));
+# else
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C" { const void * std::memchr (const void *, int, size_t); }
+ extern "C++" { void * std::memchr (void *, int, size_t); } */
+_GL_CXXALIAS_SYS_CAST2 (memchr,
+ void *, (void const *__s, int __c, size_t __n),
+ void const *, (void const *__s, int __c, size_t __n));
+# endif
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (memchr, void *, (void *__s, int __c, size_t __n));
+_GL_CXXALIASWARN1 (memchr, void const *,
+ (void const *__s, int __c, size_t __n));
+# else
+_GL_CXXALIASWARN (memchr);
# endif
#elif defined GNULIB_POSIXCHECK
# undef memchr
-# define memchr(s,c,n) \
- (GL_LINK_WARNING ("memchr has platform-specific bugs - " \
- "use gnulib module memchr for portability" ), \
- memchr (s, c, n))
+/* Assume memchr is always declared. */
+_GL_WARN_ON_USE (memchr, "memchr has platform-specific bugs - "
+ "use gnulib module memchr for portability" );
#endif
/* Return the first occurrence of NEEDLE in HAYSTACK. */
#if @GNULIB_MEMMEM@
# if @REPLACE_MEMMEM@
-# define memmem rpl_memmem
-# endif
-# if ! @HAVE_DECL_MEMMEM@ || @REPLACE_MEMMEM@
-extern void *memmem (void const *__haystack, size_t __haystack_len,
- void const *__needle, size_t __needle_len)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 3));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define memmem rpl_memmem
+# endif
+_GL_FUNCDECL_RPL (memmem, void *,
+ (void const *__haystack, size_t __haystack_len,
+ void const *__needle, size_t __needle_len)
+ __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 3)));
+_GL_CXXALIAS_RPL (memmem, void *,
+ (void const *__haystack, size_t __haystack_len,
+ void const *__needle, size_t __needle_len));
+# else
+# if ! @HAVE_DECL_MEMMEM@
+_GL_FUNCDECL_SYS (memmem, void *,
+ (void const *__haystack, size_t __haystack_len,
+ void const *__needle, size_t __needle_len)
+ __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 3)));
+# endif
+_GL_CXXALIAS_SYS (memmem, void *,
+ (void const *__haystack, size_t __haystack_len,
+ void const *__needle, size_t __needle_len));
# endif
+_GL_CXXALIASWARN (memmem);
#elif defined GNULIB_POSIXCHECK
# undef memmem
-# define memmem(a,al,b,bl) \
- (GL_LINK_WARNING ("memmem is unportable and often quadratic - " \
- "use gnulib module memmem-simple for portability, " \
- "and module memmem for speed" ), \
- memmem (a, al, b, bl))
+# if HAVE_RAW_DECL_MEMMEM
+_GL_WARN_ON_USE (memmem, "memmem is unportable and often quadratic - "
+ "use gnulib module memmem-simple for portability, "
+ "and module memmem for speed" );
+# endif
#endif
/* Copy N bytes of SRC to DEST, return pointer to bytes after the
last written byte. */
#if @GNULIB_MEMPCPY@
# if ! @HAVE_MEMPCPY@
-extern void *mempcpy (void *restrict __dest, void const *restrict __src,
- size_t __n)
- _GL_ARG_NONNULL ((1, 2));
+_GL_FUNCDECL_SYS (mempcpy, void *,
+ (void *restrict __dest, void const *restrict __src,
+ size_t __n)
+ _GL_ARG_NONNULL ((1, 2)));
# endif
+_GL_CXXALIAS_SYS (mempcpy, void *,
+ (void *restrict __dest, void const *restrict __src,
+ size_t __n));
+_GL_CXXALIASWARN (mempcpy);
#elif defined GNULIB_POSIXCHECK
# undef mempcpy
-# define mempcpy(a,b,n) \
- (GL_LINK_WARNING ("mempcpy is unportable - " \
- "use gnulib module mempcpy for portability"), \
- mempcpy (a, b, n))
+# if HAVE_RAW_DECL_MEMPCPY
+_GL_WARN_ON_USE (mempcpy, "mempcpy is unportable - "
+ "use gnulib module mempcpy for portability");
+# endif
#endif
/* Search backwards through a block for a byte (specified as an int). */
#if @GNULIB_MEMRCHR@
# if ! @HAVE_DECL_MEMRCHR@
-extern void *memrchr (void const *, int, size_t)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1));
+_GL_FUNCDECL_SYS (memrchr, void *, (void const *, int, size_t)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1)));
+# endif
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C++" { const void * std::memrchr (const void *, int, size_t); }
+ extern "C++" { void * std::memrchr (void *, int, size_t); } */
+_GL_CXXALIAS_SYS_CAST2 (memrchr,
+ void *, (void const *, int, size_t),
+ void const *, (void const *, int, size_t));
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (memrchr, void *, (void *, int, size_t));
+_GL_CXXALIASWARN1 (memrchr, void const *, (void const *, int, size_t));
+# else
+_GL_CXXALIASWARN (memrchr);
# endif
#elif defined GNULIB_POSIXCHECK
# undef memrchr
-# define memrchr(a,b,c) \
- (GL_LINK_WARNING ("memrchr is unportable - " \
- "use gnulib module memrchr for portability"), \
- memrchr (a, b, c))
+# if HAVE_RAW_DECL_MEMRCHR
+_GL_WARN_ON_USE (memrchr, "memrchr is unportable - "
+ "use gnulib module memrchr for portability");
+# endif
#endif
/* Find the first occurrence of C in S. More efficient than
@@ -122,105 +176,163 @@ extern void *memrchr (void const *, int, size_t)
occur within N bytes. */
#if @GNULIB_RAWMEMCHR@
# if ! @HAVE_RAWMEMCHR@
-extern void *rawmemchr (void const *__s, int __c_in)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1));
+_GL_FUNCDECL_SYS (rawmemchr, void *, (void const *__s, int __c_in)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1)));
+# endif
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C++" { const void * std::rawmemchr (const void *, int); }
+ extern "C++" { void * std::rawmemchr (void *, int); } */
+_GL_CXXALIAS_SYS_CAST2 (rawmemchr,
+ void *, (void const *__s, int __c_in),
+ void const *, (void const *__s, int __c_in));
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (rawmemchr, void *, (void *__s, int __c_in));
+_GL_CXXALIASWARN1 (rawmemchr, void const *, (void const *__s, int __c_in));
+# else
+_GL_CXXALIASWARN (rawmemchr);
# endif
#elif defined GNULIB_POSIXCHECK
# undef rawmemchr
-# define rawmemchr(a,b) \
- (GL_LINK_WARNING ("rawmemchr is unportable - " \
- "use gnulib module rawmemchr for portability"), \
- rawmemchr (a, b))
+# if HAVE_RAW_DECL_RAWMEMCHR
+_GL_WARN_ON_USE (rawmemchr, "rawmemchr is unportable - "
+ "use gnulib module rawmemchr for portability");
+# endif
#endif
/* Copy SRC to DST, returning the address of the terminating '\0' in DST. */
#if @GNULIB_STPCPY@
# if ! @HAVE_STPCPY@
-extern char *stpcpy (char *restrict __dst, char const *restrict __src)
- _GL_ARG_NONNULL ((1, 2));
+_GL_FUNCDECL_SYS (stpcpy, char *,
+ (char *restrict __dst, char const *restrict __src)
+ _GL_ARG_NONNULL ((1, 2)));
# endif
+_GL_CXXALIAS_SYS (stpcpy, char *,
+ (char *restrict __dst, char const *restrict __src));
+_GL_CXXALIASWARN (stpcpy);
#elif defined GNULIB_POSIXCHECK
# undef stpcpy
-# define stpcpy(a,b) \
- (GL_LINK_WARNING ("stpcpy is unportable - " \
- "use gnulib module stpcpy for portability"), \
- stpcpy (a, b))
+# if HAVE_RAW_DECL_STPCPY
+_GL_WARN_ON_USE (stpcpy, "stpcpy is unportable - "
+ "use gnulib module stpcpy for portability");
+# endif
#endif
/* Copy no more than N bytes of SRC to DST, returning a pointer past the
last non-NUL byte written into DST. */
#if @GNULIB_STPNCPY@
# if ! @HAVE_STPNCPY@
-# define stpncpy gnu_stpncpy
-extern char *stpncpy (char *restrict __dst, char const *restrict __src,
- size_t __n)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define stpncpy rpl_stpncpy
+# endif
+_GL_FUNCDECL_RPL (stpncpy, char *,
+ (char *restrict __dst, char const *restrict __src,
+ size_t __n)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (stpncpy, char *,
+ (char *restrict __dst, char const *restrict __src,
+ size_t __n));
+# else
+_GL_CXXALIAS_SYS (stpncpy, char *,
+ (char *restrict __dst, char const *restrict __src,
+ size_t __n));
# endif
+_GL_CXXALIASWARN (stpncpy);
#elif defined GNULIB_POSIXCHECK
# undef stpncpy
-# define stpncpy(a,b,n) \
- (GL_LINK_WARNING ("stpncpy is unportable - " \
- "use gnulib module stpncpy for portability"), \
- stpncpy (a, b, n))
+# if HAVE_RAW_DECL_STPNCPY
+_GL_WARN_ON_USE (stpncpy, "stpncpy is unportable - "
+ "use gnulib module stpncpy for portability");
+# endif
#endif
#if defined GNULIB_POSIXCHECK
/* strchr() does not work with multibyte strings if the locale encoding is
GB18030 and the character to be searched is a digit. */
# undef strchr
-# define strchr(s,c) \
- (GL_LINK_WARNING ("strchr cannot work correctly on character strings " \
- "in some multibyte locales - " \
- "use mbschr if you care about internationalization"), \
- strchr (s, c))
+/* Assume strchr is always declared. */
+_GL_WARN_ON_USE (strchr, "strchr cannot work correctly on character strings "
+ "in some multibyte locales - "
+ "use mbschr if you care about internationalization");
#endif
/* Find the first occurrence of C in S or the final NUL byte. */
#if @GNULIB_STRCHRNUL@
# if ! @HAVE_STRCHRNUL@
-extern char *strchrnul (char const *__s, int __c_in)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1));
+_GL_FUNCDECL_SYS (strchrnul, char *, (char const *__s, int __c_in)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1)));
+# endif
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C++" { const char * std::strchrnul (const char *, int); }
+ extern "C++" { char * std::strchrnul (char *, int); } */
+_GL_CXXALIAS_SYS_CAST2 (strchrnul,
+ char *, (char const *__s, int __c_in),
+ char const *, (char const *__s, int __c_in));
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (strchrnul, char *, (char *__s, int __c_in));
+_GL_CXXALIASWARN1 (strchrnul, char const *, (char const *__s, int __c_in));
+# else
+_GL_CXXALIASWARN (strchrnul);
# endif
#elif defined GNULIB_POSIXCHECK
# undef strchrnul
-# define strchrnul(a,b) \
- (GL_LINK_WARNING ("strchrnul is unportable - " \
- "use gnulib module strchrnul for portability"), \
- strchrnul (a, b))
+# if HAVE_RAW_DECL_STRCHRNUL
+_GL_WARN_ON_USE (strchrnul, "strchrnul is unportable - "
+ "use gnulib module strchrnul for portability");
+# endif
#endif
/* Duplicate S, returning an identical malloc'd string. */
#if @GNULIB_STRDUP@
# if @REPLACE_STRDUP@
-# undef strdup
-# define strdup rpl_strdup
-# endif
-# if !(@HAVE_DECL_STRDUP@ || defined strdup) || @REPLACE_STRDUP@
-extern char *strdup (char const *__s) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef strdup
+# define strdup rpl_strdup
+# endif
+_GL_FUNCDECL_RPL (strdup, char *, (char const *__s) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (strdup, char *, (char const *__s));
+# else
+# if !(@HAVE_DECL_STRDUP@ || defined strdup)
+_GL_FUNCDECL_SYS (strdup, char *, (char const *__s) _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (strdup, char *, (char const *__s));
# endif
+_GL_CXXALIASWARN (strdup);
#elif defined GNULIB_POSIXCHECK
# undef strdup
-# define strdup(a) \
- (GL_LINK_WARNING ("strdup is unportable - " \
- "use gnulib module strdup for portability"), \
- strdup (a))
+# if HAVE_RAW_DECL_STRDUP
+_GL_WARN_ON_USE (strdup, "strdup is unportable - "
+ "use gnulib module strdup for portability");
+# endif
#endif
/* Return a newly allocated copy of at most N bytes of STRING. */
#if @GNULIB_STRNDUP@
# if @REPLACE_STRNDUP@
-# undef strndup
-# define strndup rpl_strndup
-# endif
-# if @REPLACE_STRNDUP@ || ! @HAVE_DECL_STRNDUP@
-extern char *strndup (char const *__string, size_t __n) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef strndup
+# define strndup rpl_strndup
+# endif
+_GL_FUNCDECL_RPL (strndup, char *, (char const *__string, size_t __n)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (strndup, char *, (char const *__string, size_t __n));
+# else
+# if ! @HAVE_DECL_STRNDUP@
+_GL_FUNCDECL_SYS (strndup, char *, (char const *__string, size_t __n)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (strndup, char *, (char const *__string, size_t __n));
# endif
+_GL_CXXALIASWARN (strndup);
#elif defined GNULIB_POSIXCHECK
# undef strndup
-# define strndup(a,n) \
- (GL_LINK_WARNING ("strndup is unportable - " \
- "use gnulib module strndup for portability"), \
- strndup (a, n))
+# if HAVE_RAW_DECL_STRNDUP
+_GL_WARN_ON_USE (strndup, "strndup is unportable - "
+ "use gnulib module strndup for portability");
+# endif
#endif
/* Find the length (number of bytes) of STRING, but scan at most
@@ -228,15 +340,18 @@ extern char *strndup (char const *__string, size_t __n)
_GL_ARG_NONNULL ((1));
return MAXLEN. */
#if @GNULIB_STRNLEN@
# if ! @HAVE_DECL_STRNLEN@
-extern size_t strnlen (char const *__string, size_t __maxlen)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1));
+_GL_FUNCDECL_SYS (strnlen, size_t, (char const *__string, size_t __maxlen)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1)));
# endif
+_GL_CXXALIAS_SYS (strnlen, size_t, (char const *__string, size_t __maxlen));
+_GL_CXXALIASWARN (strnlen);
#elif defined GNULIB_POSIXCHECK
# undef strnlen
-# define strnlen(a,n) \
- (GL_LINK_WARNING ("strnlen is unportable - " \
- "use gnulib module strnlen for portability"), \
- strnlen (a, n))
+# if HAVE_RAW_DECL_STRNLEN
+_GL_WARN_ON_USE (strnlen, "strnlen is unportable - "
+ "use gnulib module strnlen for portability");
+# endif
#endif
#if defined GNULIB_POSIXCHECK
@@ -245,18 +360,32 @@ extern size_t strnlen (char const *__string, size_t
__maxlen)
locale encoding is GB18030 and one of the characters to be searched is a
digit. */
# undef strcspn
-# define strcspn(s,a) \
- (GL_LINK_WARNING ("strcspn cannot work correctly on character strings " \
- "in multibyte locales - " \
- "use mbscspn if you care about internationalization"), \
- strcspn (s, a))
+/* Assume strcspn is always declared. */
+_GL_WARN_ON_USE (strcspn, "strcspn cannot work correctly on character strings "
+ "in multibyte locales - "
+ "use mbscspn if you care about internationalization");
#endif
/* Find the first occurrence in S of any character in ACCEPT. */
#if @GNULIB_STRPBRK@
# if ! @HAVE_STRPBRK@
-extern char *strpbrk (char const *__s, char const *__accept)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 2));
+_GL_FUNCDECL_SYS (strpbrk, char *, (char const *__s, char const *__accept)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C" { const char * strpbrk (const char *, const char *); }
+ extern "C++" { char * strpbrk (char *, const char *); } */
+_GL_CXXALIAS_SYS_CAST2 (strpbrk,
+ char *, (char const *__s, char const *__accept),
+ const char *, (char const *__s, char const *__accept));
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (strpbrk, char *, (char *__s, char const *__accept));
+_GL_CXXALIASWARN1 (strpbrk, char const *,
+ (char const *__s, char const *__accept));
+# else
+_GL_CXXALIASWARN (strpbrk);
# endif
# if defined GNULIB_POSIXCHECK
/* strpbrk() assumes the second argument is a list of single-byte characters.
@@ -264,40 +393,36 @@ extern char *strpbrk (char const *__s, char const
*__accept)
locale encoding is GB18030 and one of the characters to be searched is a
digit. */
# undef strpbrk
-# define strpbrk(s,a) \
- (GL_LINK_WARNING ("strpbrk cannot work correctly on character strings " \
- "in multibyte locales - " \
- "use mbspbrk if you care about internationalization"), \
- strpbrk (s, a))
+_GL_WARN_ON_USE (strpbrk, "strpbrk cannot work correctly on character strings "
+ "in multibyte locales - "
+ "use mbspbrk if you care about internationalization");
# endif
#elif defined GNULIB_POSIXCHECK
# undef strpbrk
-# define strpbrk(s,a) \
- (GL_LINK_WARNING ("strpbrk is unportable - " \
- "use gnulib module strpbrk for portability"), \
- strpbrk (s, a))
+# if HAVE_RAW_DECL_STRPBRK
+_GL_WARN_ON_USE (strpbrk, "strpbrk is unportable - "
+ "use gnulib module strpbrk for portability");
+# endif
#endif
#if defined GNULIB_POSIXCHECK
/* strspn() assumes the second argument is a list of single-byte characters.
Even in this simple case, it cannot work with multibyte strings. */
# undef strspn
-# define strspn(s,a) \
- (GL_LINK_WARNING ("strspn cannot work correctly on character strings " \
- "in multibyte locales - " \
- "use mbsspn if you care about internationalization"), \
- strspn (s, a))
+/* Assume strspn is always declared. */
+_GL_WARN_ON_USE (strspn, "strspn cannot work correctly on character strings "
+ "in multibyte locales - "
+ "use mbsspn if you care about internationalization");
#endif
#if defined GNULIB_POSIXCHECK
/* strrchr() does not work with multibyte strings if the locale encoding is
GB18030 and the character to be searched is a digit. */
# undef strrchr
-# define strrchr(s,c) \
- (GL_LINK_WARNING ("strrchr cannot work correctly on character strings " \
- "in some multibyte locales - " \
- "use mbsrchr if you care about internationalization"), \
- strrchr (s, c))
+/* Assume strrchr is always declared. */
+_GL_WARN_ON_USE (strrchr, "strrchr cannot work correctly on character strings "
+ "in some multibyte locales - "
+ "use mbsrchr if you care about internationalization");
#endif
/* Search the next delimiter (char listed in DELIM) starting at *STRINGP.
@@ -318,30 +443,51 @@ extern char *strpbrk (char const *__s, char const
*__accept)
See also strtok_r(). */
#if @GNULIB_STRSEP@
# if ! @HAVE_STRSEP@
-extern char *strsep (char **restrict __stringp, char const *restrict __delim)
- _GL_ARG_NONNULL ((1, 2));
+_GL_FUNCDECL_SYS (strsep, char *,
+ (char **restrict __stringp, char const *restrict __delim)
+ _GL_ARG_NONNULL ((1, 2)));
# endif
+_GL_CXXALIAS_SYS (strsep, char *,
+ (char **restrict __stringp, char const *restrict __delim));
+_GL_CXXALIASWARN (strsep);
# if defined GNULIB_POSIXCHECK
# undef strsep
-# define strsep(s,d) \
- (GL_LINK_WARNING ("strsep cannot work correctly on character strings " \
- "in multibyte locales - " \
- "use mbssep if you care about internationalization"), \
- strsep (s, d))
+_GL_WARN_ON_USE (strsep, "strsep cannot work correctly on character strings "
+ "in multibyte locales - "
+ "use mbssep if you care about internationalization");
# endif
#elif defined GNULIB_POSIXCHECK
# undef strsep
-# define strsep(s,d) \
- (GL_LINK_WARNING ("strsep is unportable - " \
- "use gnulib module strsep for portability"), \
- strsep (s, d))
+# if HAVE_RAW_DECL_STRSEP
+_GL_WARN_ON_USE (strsep, "strsep is unportable - "
+ "use gnulib module strsep for portability");
+# endif
#endif
#if @GNULIB_STRSTR@
# if @REPLACE_STRSTR@
-# define strstr rpl_strstr
-extern char *strstr (const char *haystack, const char *needle)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define strstr rpl_strstr
+# endif
+_GL_FUNCDECL_RPL (strstr, char *, (const char *haystack, const char *needle)
+ __attribute__ ((__pure__))
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (strstr, char *, (const char *haystack, const char *needle));
+# else
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C++" { const char * strstr (const char *, const char *); }
+ extern "C++" { char * strstr (char *, const char *); } */
+_GL_CXXALIAS_SYS_CAST2 (strstr,
+ char *, (const char *haystack, const char *needle),
+ const char *, (const char *haystack, const char
*needle));
+# endif
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (strstr, char *, (char *haystack, const char *needle));
+_GL_CXXALIASWARN1 (strstr, const char *,
+ (const char *haystack, const char *needle));
+# else
+_GL_CXXALIASWARN (strstr);
# endif
#elif defined GNULIB_POSIXCHECK
/* strstr() does not work with multibyte strings if the locale encoding is
@@ -349,37 +495,59 @@ extern char *strstr (const char *haystack, const char
*needle)
POSIX says that it operates on "strings", and "string" in POSIX is defined
as a sequence of bytes, not of characters. */
# undef strstr
-# define strstr(a,b) \
- (GL_LINK_WARNING ("strstr is quadratic on many systems, and cannot " \
- "work correctly on character strings in most " \
- "multibyte locales - " \
- "use mbsstr if you care about internationalization, " \
- "or use strstr if you care about speed"), \
- strstr (a, b))
+/* Assume strstr is always declared. */
+_GL_WARN_ON_USE (strstr, "strstr is quadratic on many systems, and cannot "
+ "work correctly on character strings in most "
+ "multibyte locales - "
+ "use mbsstr if you care about internationalization, "
+ "or use strstr if you care about speed");
#endif
/* Find the first occurrence of NEEDLE in HAYSTACK, using case-insensitive
comparison. */
#if @GNULIB_STRCASESTR@
# if @REPLACE_STRCASESTR@
-# define strcasestr rpl_strcasestr
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define strcasestr rpl_strcasestr
+# endif
+_GL_FUNCDECL_RPL (strcasestr, char *,
+ (const char *haystack, const char *needle)
+ __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (strcasestr, char *,
+ (const char *haystack, const char *needle));
+# else
+# if ! @HAVE_STRCASESTR@
+_GL_FUNCDECL_SYS (strcasestr, char *,
+ (const char *haystack, const char *needle)
+ __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 2)));
+# endif
+ /* On some systems, this function is defined as an overloaded function:
+ extern "C++" { const char * strcasestr (const char *, const char *); }
+ extern "C++" { char * strcasestr (char *, const char *); } */
+_GL_CXXALIAS_SYS_CAST2 (strcasestr,
+ char *, (const char *haystack, const char *needle),
+ const char *, (const char *haystack, const char
*needle));
# endif
-# if ! @HAVE_STRCASESTR@ || @REPLACE_STRCASESTR@
-extern char *strcasestr (const char *haystack, const char *needle)
- __attribute__ ((__pure__)) _GL_ARG_NONNULL ((1, 2));
+# if __GLIBC__ == 2 && __GLIBC_MINOR__ >= 10 \
+ && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4))
+_GL_CXXALIASWARN1 (strcasestr, char *, (char *haystack, const char *needle));
+_GL_CXXALIASWARN1 (strcasestr, const char *,
+ (const char *haystack, const char *needle));
+# else
+_GL_CXXALIASWARN (strcasestr);
# endif
#elif defined GNULIB_POSIXCHECK
/* strcasestr() does not work with multibyte strings:
It is a glibc extension, and glibc implements it only for unibyte
locales. */
# undef strcasestr
-# define strcasestr(a,b) \
- (GL_LINK_WARNING ("strcasestr does work correctly on character strings " \
- "in multibyte locales - " \
- "use mbscasestr if you care about " \
- "internationalization, or use c-strcasestr if you want "
\
- "a locale independent function"), \
- strcasestr (a, b))
+# if HAVE_RAW_DECL_STRCASESTR
+_GL_WARN_ON_USE (strcasestr, "strcasestr does work correctly on character "
+ "strings in multibyte locales - "
+ "use mbscasestr if you care about "
+ "internationalization, or use c-strcasestr if you want "
+ "a locale independent function");
+# endif
#endif
/* Parse S into tokens separated by characters in DELIM.
@@ -406,30 +574,43 @@ extern char *strcasestr (const char *haystack, const char
*needle)
See also strsep(). */
#if @GNULIB_STRTOK_R@
# if @REPLACE_STRTOK_R@
-# undef strtok_r
-# define strtok_r rpl_strtok_r
-# elif @UNDEFINE_STRTOK_R@
-# undef strtok_r
-# endif
-# if ! @HAVE_DECL_STRTOK_R@ || @REPLACE_STRTOK_R@
-extern char *strtok_r (char *restrict s, char const *restrict delim,
- char **restrict save_ptr)
- _GL_ARG_NONNULL ((2, 3));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef strtok_r
+# define strtok_r rpl_strtok_r
+# endif
+_GL_FUNCDECL_RPL (strtok_r, char *,
+ (char *restrict s, char const *restrict delim,
+ char **restrict save_ptr)
+ _GL_ARG_NONNULL ((2, 3)));
+_GL_CXXALIAS_RPL (strtok_r, char *,
+ (char *restrict s, char const *restrict delim,
+ char **restrict save_ptr));
+# else
+# if @UNDEFINE_STRTOK_R@ || defined GNULIB_POSIXCHECK
+# undef strtok_r
+# endif
+# if ! @HAVE_DECL_STRTOK_R@
+_GL_FUNCDECL_SYS (strtok_r, char *,
+ (char *restrict s, char const *restrict delim,
+ char **restrict save_ptr)
+ _GL_ARG_NONNULL ((2, 3)));
+# endif
+_GL_CXXALIAS_SYS (strtok_r, char *,
+ (char *restrict s, char const *restrict delim,
+ char **restrict save_ptr));
# endif
+_GL_CXXALIASWARN (strtok_r);
# if defined GNULIB_POSIXCHECK
-# undef strtok_r
-# define strtok_r(s,d,p) \
- (GL_LINK_WARNING ("strtok_r cannot work correctly on character strings " \
- "in multibyte locales - " \
- "use mbstok_r if you care about internationalization"),
\
- strtok_r (s, d, p))
+_GL_WARN_ON_USE (strtok_r, "strtok_r cannot work correctly on character "
+ "strings in multibyte locales - "
+ "use mbstok_r if you care about internationalization");
# endif
#elif defined GNULIB_POSIXCHECK
# undef strtok_r
-# define strtok_r(s,d,p) \
- (GL_LINK_WARNING ("strtok_r is unportable - " \
- "use gnulib module strtok_r for portability"), \
- strtok_r (s, d, p))
+# if HAVE_RAW_DECL_STRTOK_R
+_GL_WARN_ON_USE (strtok_r, "strtok_r is unportable - "
+ "use gnulib module strtok_r for portability");
+# endif
#endif
@@ -439,13 +620,27 @@ extern char *strtok_r (char *restrict s, char const
*restrict delim,
#if @GNULIB_MBSLEN@
/* Return the number of multibyte characters in the character string STRING.
This considers multibyte characters, unlike strlen, which counts bytes. */
-extern size_t mbslen (const char *string) _GL_ARG_NONNULL ((1));
+# ifdef __MirBSD__ /* MirBSD defines mbslen as a macro. Override it. */
+# undef mbslen
+# endif
+# if @HAVE_MBSLEN@ /* AIX, OSF/1, MirBSD define mbslen already in libc. */
+# 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_CXXALIAS_RPL (mbslen, size_t, (const char *string));
+# else
+_GL_FUNCDECL_SYS (mbslen, size_t, (const char *string) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_SYS (mbslen, size_t, (const char *string));
+# endif
+_GL_CXXALIASWARN (mbslen);
#endif
#if @GNULIB_MBSNLEN@
/* Return the number of multibyte characters in the character string starting
at STRING and ending at STRING + LEN. */
-extern size_t mbsnlen (const char *string, size_t len) _GL_ARG_NONNULL ((1));
+_GL_EXTERN_C size_t mbsnlen (const char *string, size_t len)
+ _GL_ARG_NONNULL ((1));
#endif
#if @GNULIB_MBSCHR@
@@ -453,8 +648,19 @@ extern size_t mbsnlen (const char *string, size_t len)
_GL_ARG_NONNULL ((1));
and return a pointer to it. Return NULL if C is not found in STRING.
Unlike strchr(), this function works correctly in multibyte locales with
encodings such as GB18030. */
-# define mbschr rpl_mbschr /* avoid collision with HP-UX function */
-extern char * mbschr (const char *string, int c) _GL_ARG_NONNULL ((1));
+# if defined __hpux
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define mbschr rpl_mbschr /* avoid collision with HP-UX function */
+# endif
+_GL_FUNCDECL_RPL (mbschr, char *, (const char *string, int c)
+ _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_ARG_NONNULL ((1)));
+_GL_CXXALIAS_SYS (mbschr, char *, (const char *string, int c));
+# endif
+_GL_CXXALIASWARN (mbschr);
#endif
#if @GNULIB_MBSRCHR@
@@ -462,8 +668,19 @@ extern char * mbschr (const char *string, int c)
_GL_ARG_NONNULL ((1));
and return a pointer to it. Return NULL if C is not found in STRING.
Unlike strrchr(), this function works correctly in multibyte locales with
encodings such as GB18030. */
-# define mbsrchr rpl_mbsrchr /* avoid collision with HP-UX function */
-extern char * mbsrchr (const char *string, int c) _GL_ARG_NONNULL ((1));
+# if defined __hpux
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define mbsrchr rpl_mbsrchr /* avoid collision with HP-UX function */
+# endif
+_GL_FUNCDECL_RPL (mbsrchr, char *, (const char *string, int c)
+ _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_ARG_NONNULL ((1)));
+_GL_CXXALIAS_SYS (mbsrchr, char *, (const char *string, int c));
+# endif
+_GL_CXXALIASWARN (mbsrchr);
#endif
#if @GNULIB_MBSSTR@
@@ -471,7 +688,7 @@ extern char * mbsrchr (const char *string, int c)
_GL_ARG_NONNULL ((1));
string HAYSTACK. Return NULL if NEEDLE is not found in HAYSTACK.
Unlike strstr(), this function works correctly in multibyte locales with
encodings different from UTF-8. */
-extern char * mbsstr (const char *haystack, const char *needle)
+_GL_EXTERN_C char * mbsstr (const char *haystack, const char *needle)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -482,7 +699,7 @@ extern char * mbsstr (const char *haystack, const char
*needle)
Note: This function may, in multibyte locales, return 0 for strings of
different lengths!
Unlike strcasecmp(), this function works correctly in multibyte locales. */
-extern int mbscasecmp (const char *s1, const char *s2)
+_GL_EXTERN_C int mbscasecmp (const char *s1, const char *s2)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -496,7 +713,7 @@ extern int mbscasecmp (const char *s1, const char *s2)
of different lengths!
Unlike strncasecmp(), this function works correctly in multibyte locales.
But beware that N is not a byte count but a character count! */
-extern int mbsncasecmp (const char *s1, const char *s2, size_t n)
+_GL_EXTERN_C int mbsncasecmp (const char *s1, const char *s2, size_t n)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -510,7 +727,7 @@ extern int mbsncasecmp (const char *s1, const char *s2,
size_t n)
smaller length than PREFIX!
Unlike strncasecmp(), this function works correctly in multibyte
locales. */
-extern char * mbspcasecmp (const char *string, const char *prefix)
+_GL_EXTERN_C char * mbspcasecmp (const char *string, const char *prefix)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -520,7 +737,7 @@ extern char * mbspcasecmp (const char *string, const char
*prefix)
Note: This function may, in multibyte locales, return success even if
strlen (haystack) < strlen (needle) !
Unlike strcasestr(), this function works correctly in multibyte locales. */
-extern char * mbscasestr (const char *haystack, const char *needle)
+_GL_EXTERN_C char * mbscasestr (const char *haystack, const char *needle)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -530,7 +747,7 @@ extern char * mbscasestr (const char *haystack, const char
*needle)
beginning of the string to this occurrence, or to the end of the string
if none exists.
Unlike strcspn(), this function works correctly in multibyte locales. */
-extern size_t mbscspn (const char *string, const char *accept)
+_GL_EXTERN_C size_t mbscspn (const char *string, const char *accept)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -539,9 +756,19 @@ extern size_t mbscspn (const char *string, const char
*accept)
in the character string ACCEPT. Return the pointer to it, or NULL if none
exists.
Unlike strpbrk(), this function works correctly in multibyte locales. */
-# define mbspbrk rpl_mbspbrk /* avoid collision with HP-UX function */
-extern char * mbspbrk (const char *string, const char *accept)
- _GL_ARG_NONNULL ((1, 2));
+# if defined __hpux
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define mbspbrk rpl_mbspbrk /* avoid collision with HP-UX function */
+# endif
+_GL_FUNCDECL_RPL (mbspbrk, char *, (const char *string, const char *accept)
+ _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_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_SYS (mbspbrk, char *, (const char *string, const char *accept));
+# endif
+_GL_CXXALIASWARN (mbspbrk);
#endif
#if @GNULIB_MBSSPN@
@@ -550,7 +777,7 @@ extern char * mbspbrk (const char *string, const char
*accept)
beginning of the string to this occurrence, or to the end of the string
if none exists.
Unlike strspn(), this function works correctly in multibyte locales. */
-extern size_t mbsspn (const char *string, const char *reject)
+_GL_EXTERN_C size_t mbsspn (const char *string, const char *reject)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -569,7 +796,7 @@ extern size_t mbsspn (const char *string, const char
*reject)
Caveat: The identity of the delimiting character is lost.
See also mbstok_r(). */
-extern char * mbssep (char **stringp, const char *delim)
+_GL_EXTERN_C char * mbssep (char **stringp, const char *delim)
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -590,56 +817,69 @@ extern char * mbssep (char **stringp, const char *delim)
Caveat: The identity of the delimiting character is lost.
See also mbssep(). */
-extern char * mbstok_r (char *string, const char *delim, char **save_ptr)
+_GL_EXTERN_C char * mbstok_r (char *string, const char *delim, char **save_ptr)
_GL_ARG_NONNULL ((2, 3));
#endif
/* Map any int, typically from errno, into an error message. */
#if @GNULIB_STRERROR@
# if @REPLACE_STRERROR@
-# undef strerror
-# define strerror rpl_strerror
-extern char *strerror (int);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef strerror
+# define strerror rpl_strerror
+# endif
+_GL_FUNCDECL_RPL (strerror, char *, (int));
+_GL_CXXALIAS_RPL (strerror, char *, (int));
+# else
+_GL_CXXALIAS_SYS (strerror, char *, (int));
# endif
+_GL_CXXALIASWARN (strerror);
#elif defined GNULIB_POSIXCHECK
# undef strerror
-# define strerror(e) \
- (GL_LINK_WARNING ("strerror is unportable - " \
- "use gnulib module strerror to guarantee non-NULL
result"), \
- strerror (e))
+/* Assume strerror is always declared. */
+_GL_WARN_ON_USE (strerror, "strerror is unportable - "
+ "use gnulib module strerror to guarantee non-NULL result");
#endif
#if @GNULIB_STRSIGNAL@
# if @REPLACE_STRSIGNAL@
-# define strsignal rpl_strsignal
-# endif
-# if ! @HAVE_DECL_STRSIGNAL@ || @REPLACE_STRSIGNAL@
-extern char *strsignal (int __sig);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define strsignal rpl_strsignal
+# endif
+_GL_FUNCDECL_RPL (strsignal, char *, (int __sig));
+_GL_CXXALIAS_RPL (strsignal, char *, (int __sig));
+# else
+# if ! @HAVE_DECL_STRSIGNAL@
+_GL_FUNCDECL_SYS (strsignal, char *, (int __sig));
+# endif
+/* Need to cast, because on Cygwin 1.5.x systems, the return type is
+ 'const char *'. */
+_GL_CXXALIAS_SYS_CAST (strsignal, char *, (int __sig));
# endif
+_GL_CXXALIASWARN (strsignal);
#elif defined GNULIB_POSIXCHECK
# undef strsignal
-# define strsignal(a) \
- (GL_LINK_WARNING ("strsignal is unportable - " \
- "use gnulib module strsignal for portability"), \
- strsignal (a))
+# if HAVE_RAW_DECL_STRSIGNAL
+_GL_WARN_ON_USE (strsignal, "strsignal is unportable - "
+ "use gnulib module strsignal for portability");
+# endif
#endif
#if @GNULIB_STRVERSCMP@
# if address@hidden@
-extern int strverscmp (const char *, const char *) _GL_ARG_NONNULL ((1, 2));
+_GL_FUNCDECL_SYS (strverscmp, int, (const char *, const char *)
+ _GL_ARG_NONNULL ((1, 2)));
# endif
+_GL_CXXALIAS_SYS (strverscmp, int, (const char *, const char *));
+_GL_CXXALIASWARN (strverscmp);
#elif defined GNULIB_POSIXCHECK
# undef strverscmp
-# define strverscmp(a, b) \
- (GL_LINK_WARNING ("strverscmp is unportable - " \
- "use gnulib module strverscmp for portability"), \
- strverscmp (a, b))
+# if HAVE_RAW_DECL_STRVERSCMP
+_GL_WARN_ON_USE (strverscmp, "strverscmp is unportable - "
+ "use gnulib module strverscmp for portability");
+# endif
#endif
-#ifdef __cplusplus
-}
-#endif
-
#endif /* _GL_STRING_H */
#endif /* _GL_STRING_H */
diff --git a/lib/strings.in.h b/lib/strings.in.h
index 8e2b95c..b2cf2cf 100644
--- a/lib/strings.in.h
+++ b/lib/strings.in.h
@@ -1,6 +1,6 @@
/* A substitute <strings.h>.
- Copyright (C) 2007-2009 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -29,10 +29,9 @@
#define _GL_STRINGS_H
-/* The definition of GL_LINK_WARNING is 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" {
@@ -52,14 +51,14 @@ extern int strcasecmp (char const *s1, char const *s2)
POSIX says that it operates on "strings", and "string" in POSIX is defined
as a sequence of bytes, not of characters. */
# undef strcasecmp
-# define strcasecmp(a,b) \
- (GL_LINK_WARNING ("strcasecmp cannot work correctly on character strings "
\
- "in multibyte locales - " \
- "use mbscasecmp if you care about " \
- "internationalization, or use c_strcasecmp (from " \
- "gnulib module c-strcase) if you want a locale " \
- "independent function"), \
- strcasecmp (a, b))
+# 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,
@@ -75,14 +74,14 @@ extern int strncasecmp (char const *s1, char const *s2,
size_t n)
POSIX says that it operates on "strings", and "string" in POSIX is defined
as a sequence of bytes, not of characters. */
# undef strncasecmp
-# define strncasecmp(a,b,n) \
- (GL_LINK_WARNING ("strncasecmp cannot work correctly on character " \
- "strings in multibyte locales - " \
- "use mbsncasecmp or mbspcasecmp if you care about " \
- "internationalization, or use c_strncasecmp (from " \
- "gnulib module c-strcase) if you want a locale " \
- "independent function"), \
- strncasecmp (a, b, n))
+# 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
diff --git a/lib/strncasecmp.c b/lib/strncasecmp.c
index 8a82d93..d525deb 100644
--- a/lib/strncasecmp.c
+++ b/lib/strncasecmp.c
@@ -1,5 +1,5 @@
/* strncasecmp.c -- case insensitive string comparator
- Copyright (C) 1998-1999, 2005-2007 Free Software Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2007, 2009-2010 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
diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h
index 0973edc..bdf664d 100644
--- a/lib/sys_file.in.h
+++ b/lib/sys_file.in.h
@@ -1,6 +1,6 @@
/* Provide a more complete sys/file.h.
- Copyright (C) 2007-2008 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 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
@@ -31,28 +31,30 @@
#ifndef _GL_SYS_FILE_H
#define _GL_SYS_FILE_H
+#ifndef LOCK_SH
+/* Operations for the 'flock' call (same as Linux kernel constants). */
+# define LOCK_SH 1 /* Shared lock. */
+# define LOCK_EX 2 /* Exclusive lock. */
+# define LOCK_UN 8 /* Unlock. */
+
+/* Can be OR'd in to one of the above. */
+# define LOCK_NB 4 /* Don't block when locking. */
+#endif
+
+/* The definition of _GL_WARN_ON_USE is copied here. */
#if @GNULIB_FLOCK@
/* Apply or remove advisory locks on an open file.
Return 0 if successful, otherwise -1 and errno set. */
# if address@hidden@
extern int flock (int fd, int operation);
-
-/* Operations for the 'flock' call (same as Linux kernel constants). */
-#define LOCK_SH 1 /* Shared lock. */
-#define LOCK_EX 2 /* Exclusive lock. */
-#define LOCK_UN 8 /* Unlock. */
-
-/* Can be OR'd in to one of the above. */
-#define LOCK_NB 4 /* Don't block when locking. */
-
# endif
#elif defined GNULIB_POSIXCHECK
# undef flock
-# define flock(fd,op) \
- (GL_LINK_WARNING ("flock is unportable - " \
- "use gnulib module flock for portability"), \
- flock ((fd), (op)))
+# if HAVE_RAW_DECL_FLOCK
+_GL_WARN_ON_USE (flock, "flock is unportable - "
+ "use gnulib module flock for portability");
+# endif
#endif
diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h
index 1d46175..f54d757 100644
--- a/lib/sys_socket.in.h
+++ b/lib/sys_socket.in.h
@@ -1,6 +1,6 @@
/* Provide a sys/socket header file for systems lacking it (read: MinGW)
and for systems where it is incomplete.
- Copyright (C) 2005-2009 Free Software Foundation, Inc.
+ Copyright (C) 2005-2010 Free Software Foundation, Inc.
Written by Simon Josefsson.
This program is free software; you can redistribute it and/or modify
@@ -23,10 +23,24 @@
It is intended to provide definitions and prototypes needed by an
application. */
+#if defined _GL_ALREADY_INCLUDING_SYS_SOCKET_H
+/* Special invocation convention:
+ - On Cygwin 1.5.x we have a sequence of nested includes
+ <sys/socket.h> -> <cygwin/socket.h> -> <asm/socket.h> -> <cygwin/if.h>,
+ and the latter includes <sys/socket.h>. In this situation, the functions
+ are not yet declared, therefore we cannot provide the C++ aliases. */
+
address@hidden@ @NEXT_SYS_SOCKET_H@
+
+#else
+/* Normal invocation convention. */
+
#ifndef _GL_SYS_SOCKET_H
#if @HAVE_SYS_SOCKET_H@
+# define _GL_ALREADY_INCLUDING_SYS_SOCKET_H
+
# if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
# endif
@@ -38,13 +52,19 @@
/* The include_next requires a split double-inclusion guard. */
# @INCLUDE_NEXT@ @NEXT_SYS_SOCKET_H@
+# undef _GL_ALREADY_INCLUDING_SYS_SOCKET_H
+
#endif
#ifndef _GL_SYS_SOCKET_H
#define _GL_SYS_SOCKET_H
+/* 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. */
+
#if address@hidden@
typedef unsigned short sa_family_t;
#endif
@@ -126,8 +146,6 @@ struct sockaddr_storage
# define SHUT_RDWR SD_BOTH
# endif
-/* The definition of GL_LINK_WARNING is copied here. */
-
# if @HAVE_WINSOCK2_H@
/* Include headers needed by the emulation code. */
# include <sys/types.h>
@@ -137,11 +155,9 @@ typedef int socklen_t;
# endif
-# ifdef __cplusplus
-extern "C" {
-# endif
+#endif
-# if @HAVE_WINSOCK2_H@
+#if @HAVE_WINSOCK2_H@
/* Re-define FD_ISSET to avoid a WSA call while we are not using
network sockets. */
@@ -159,280 +175,404 @@ rpl_fd_isset (SOCKET fd, fd_set * set)
return 0;
}
-# undef FD_ISSET
-# define FD_ISSET(fd, set) rpl_fd_isset(fd, set)
+# undef FD_ISSET
+# define FD_ISSET(fd, set) rpl_fd_isset(fd, set)
-# endif
+#endif
/* Wrap everything else to use libc file descriptors for sockets. */
-# if @HAVE_WINSOCK2_H@ && !defined _GL_UNISTD_H
-# undef close
-# define close close_used_without_including_unistd_h
-# endif
+#if @HAVE_WINSOCK2_H@ && !defined _GL_UNISTD_H
+# undef close
+# define close close_used_without_including_unistd_h
+#endif
-# if @HAVE_WINSOCK2_H@ && !defined _GL_UNISTD_H
-# undef gethostname
-# define gethostname gethostname_used_without_including_unistd_h
-# endif
+#if @HAVE_WINSOCK2_H@ && !defined _GL_UNISTD_H
+# undef gethostname
+# define gethostname gethostname_used_without_including_unistd_h
+#endif
-# if @GNULIB_SOCKET@
-# if @HAVE_WINSOCK2_H@
+#if @GNULIB_SOCKET@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef socket
-# define socket rpl_socket
-extern int rpl_socket (int, int, int protocol);
+# define socket rpl_socket
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef socket
-# define socket socket_used_without_requesting_gnulib_module_socket
-# elif defined GNULIB_POSIXCHECK
-# undef socket
-# define socket(d,t,p) \
- (GL_LINK_WARNING ("socket is not always POSIX compliant - " \
- "use gnulib module socket for portability"), \
- socket (d, t, p))
-# endif
-
-# if @GNULIB_CONNECT@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (socket, int, (int domain, int type, int protocol));
+_GL_CXXALIAS_RPL (socket, int, (int domain, int type, int protocol));
+# else
+_GL_CXXALIAS_SYS (socket, int, (int domain, int type, int protocol));
+# endif
+_GL_CXXALIASWARN (socket);
+#elif @HAVE_WINSOCK2_H@
+# undef socket
+# define socket socket_used_without_requesting_gnulib_module_socket
+#elif defined GNULIB_POSIXCHECK
+# undef socket
+# if HAVE_RAW_DECL_SOCKET
+_GL_WARN_ON_USE (socket, "socket is not always POSIX compliant - "
+ "use gnulib module socket for portability");
+# endif
+#endif
+
+#if @GNULIB_CONNECT@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef connect
-# define connect rpl_connect
-extern int rpl_connect (int, struct sockaddr *, int) _GL_ARG_NONNULL ((2));
+# define connect rpl_connect
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef connect
-# define connect socket_used_without_requesting_gnulib_module_connect
-# elif defined GNULIB_POSIXCHECK
-# undef connect
-# define connect(s,a,l) \
- (GL_LINK_WARNING ("connect is not always POSIX compliant - " \
- "use gnulib module connect for portability"), \
- connect (s, a, l))
-# endif
-
-# if @GNULIB_ACCEPT@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (connect, int,
+ (int fd, const struct sockaddr *addr, socklen_t addrlen)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (connect, int,
+ (int fd, const struct sockaddr *addr, socklen_t addrlen));
+# else
+_GL_CXXALIAS_SYS (connect, int,
+ (int fd, const struct sockaddr *addr, socklen_t addrlen));
+# endif
+_GL_CXXALIASWARN (connect);
+#elif @HAVE_WINSOCK2_H@
+# undef connect
+# define connect socket_used_without_requesting_gnulib_module_connect
+#elif defined GNULIB_POSIXCHECK
+# undef connect
+# if HAVE_RAW_DECL_CONNECT
+_GL_WARN_ON_USE (connect, "connect is not always POSIX compliant - "
+ "use gnulib module connect for portability");
+# endif
+#endif
+
+#if @GNULIB_ACCEPT@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef accept
-# define accept rpl_accept
-extern int rpl_accept (int, struct sockaddr *, int *);
+# define accept rpl_accept
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef accept
-# define accept accept_used_without_requesting_gnulib_module_accept
-# elif defined GNULIB_POSIXCHECK
-# undef accept
-# define accept(s,a,l) \
- (GL_LINK_WARNING ("accept is not always POSIX compliant - " \
- "use gnulib module accept for portability"), \
- accept (s, a, l))
-# endif
-
-# if @GNULIB_BIND@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (accept, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+_GL_CXXALIAS_RPL (accept, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+# else
+/* Need to cast, because on Solaris 10 systems, the third parameter is
+ void *addrlen. */
+_GL_CXXALIAS_SYS_CAST (accept, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+# endif
+_GL_CXXALIASWARN (accept);
+#elif @HAVE_WINSOCK2_H@
+# undef accept
+# define accept accept_used_without_requesting_gnulib_module_accept
+#elif defined GNULIB_POSIXCHECK
+# undef accept
+# if HAVE_RAW_DECL_ACCEPT
+_GL_WARN_ON_USE (accept, "accept is not always POSIX compliant - "
+ "use gnulib module accept for portability");
+# endif
+#endif
+
+#if @GNULIB_BIND@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef bind
-# define bind rpl_bind
-extern int rpl_bind (int, struct sockaddr *, int) _GL_ARG_NONNULL ((2));
+# define bind rpl_bind
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef bind
-# define bind bind_used_without_requesting_gnulib_module_bind
-# elif defined GNULIB_POSIXCHECK
-# undef bind
-# define bind(s,a,l) \
- (GL_LINK_WARNING ("bind is not always POSIX compliant - " \
- "use gnulib module bind for portability"), \
- bind (s, a, l))
-# endif
-
-# if @GNULIB_GETPEERNAME@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (bind, int,
+ (int fd, const struct sockaddr *addr, socklen_t addrlen)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (bind, int,
+ (int fd, const struct sockaddr *addr, socklen_t addrlen));
+# else
+_GL_CXXALIAS_SYS (bind, int,
+ (int fd, const struct sockaddr *addr, socklen_t addrlen));
+# endif
+_GL_CXXALIASWARN (bind);
+#elif @HAVE_WINSOCK2_H@
+# undef bind
+# define bind bind_used_without_requesting_gnulib_module_bind
+#elif defined GNULIB_POSIXCHECK
+# undef bind
+# if HAVE_RAW_DECL_BIND
+_GL_WARN_ON_USE (bind, "bind is not always POSIX compliant - "
+ "use gnulib module bind for portability");
+# endif
+#endif
+
+#if @GNULIB_GETPEERNAME@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef getpeername
-# define getpeername rpl_getpeername
-extern int rpl_getpeername (int, struct sockaddr *, int *)
- _GL_ARG_NONNULL ((2, 3));
+# define getpeername rpl_getpeername
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef getpeername
-# define getpeername
getpeername_used_without_requesting_gnulib_module_getpeername
-# elif defined GNULIB_POSIXCHECK
-# undef getpeername
-# define getpeername(s,a,l) \
- (GL_LINK_WARNING ("getpeername is not always POSIX compliant - " \
- "use gnulib module getpeername for portability"), \
- getpeername (s, a, l))
-# endif
-
-# if @GNULIB_GETSOCKNAME@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (getpeername, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen)
+ _GL_ARG_NONNULL ((2, 3)));
+_GL_CXXALIAS_RPL (getpeername, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+# else
+/* Need to cast, because on Solaris 10 systems, the third parameter is
+ void *addrlen. */
+_GL_CXXALIAS_SYS_CAST (getpeername, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+# endif
+_GL_CXXALIASWARN (getpeername);
+#elif @HAVE_WINSOCK2_H@
+# undef getpeername
+# define getpeername
getpeername_used_without_requesting_gnulib_module_getpeername
+#elif defined GNULIB_POSIXCHECK
+# undef getpeername
+# if HAVE_RAW_DECL_GETPEERNAME
+_GL_WARN_ON_USE (getpeername, "getpeername is not always POSIX compliant - "
+ "use gnulib module getpeername for portability");
+# endif
+#endif
+
+#if @GNULIB_GETSOCKNAME@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef getsockname
-# define getsockname rpl_getsockname
-extern int rpl_getsockname (int, struct sockaddr *, int *)
- _GL_ARG_NONNULL ((2, 3));
+# define getsockname rpl_getsockname
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef getsockname
-# define getsockname
getsockname_used_without_requesting_gnulib_module_getsockname
-# elif defined GNULIB_POSIXCHECK
-# undef getsockname
-# define getsockname(s,a,l) \
- (GL_LINK_WARNING ("getsockname is not always POSIX compliant - " \
- "use gnulib module getsockname for portability"), \
- getsockname (s, a, l))
-# endif
-
-# if @GNULIB_GETSOCKOPT@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (getsockname, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen)
+ _GL_ARG_NONNULL ((2, 3)));
+_GL_CXXALIAS_RPL (getsockname, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+# else
+/* Need to cast, because on Solaris 10 systems, the third parameter is
+ void *addrlen. */
+_GL_CXXALIAS_SYS_CAST (getsockname, int,
+ (int fd, struct sockaddr *addr, socklen_t *addrlen));
+# endif
+_GL_CXXALIASWARN (getsockname);
+#elif @HAVE_WINSOCK2_H@
+# undef getsockname
+# define getsockname
getsockname_used_without_requesting_gnulib_module_getsockname
+#elif defined GNULIB_POSIXCHECK
+# undef getsockname
+# if HAVE_RAW_DECL_GETSOCKNAME
+_GL_WARN_ON_USE (getsockname, "getsockname is not always POSIX compliant - "
+ "use gnulib module getsockname for portability");
+# endif
+#endif
+
+#if @GNULIB_GETSOCKOPT@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef getsockopt
-# define getsockopt rpl_getsockopt
-extern int rpl_getsockopt (int, int, int, void *, socklen_t *)
- _GL_ARG_NONNULL ((4, 5));
+# define getsockopt rpl_getsockopt
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef getsockopt
-# define getsockopt
getsockopt_used_without_requesting_gnulib_module_getsockopt
-# elif defined GNULIB_POSIXCHECK
-# undef getsockopt
-# define getsockopt(s,lvl,o,v,l) \
- (GL_LINK_WARNING ("getsockopt is not always POSIX compliant - " \
- "use gnulib module getsockopt for portability"), \
- getsockopt (s, lvl, o, v, l))
-# endif
-
-# if @GNULIB_LISTEN@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (getsockopt, int, (int fd, int level, int optname,
+ void *optval, socklen_t *optlen)
+ _GL_ARG_NONNULL ((4, 5)));
+_GL_CXXALIAS_RPL (getsockopt, int, (int fd, int level, int optname,
+ void *optval, socklen_t *optlen));
+# else
+/* Need to cast, because on Solaris 10 systems, the fifth parameter is
+ void *optlen. */
+_GL_CXXALIAS_SYS_CAST (getsockopt, int, (int fd, int level, int optname,
+ void *optval, socklen_t *optlen));
+# endif
+_GL_CXXALIASWARN (getsockopt);
+#elif @HAVE_WINSOCK2_H@
+# undef getsockopt
+# define getsockopt getsockopt_used_without_requesting_gnulib_module_getsockopt
+#elif defined GNULIB_POSIXCHECK
+# undef getsockopt
+# if HAVE_RAW_DECL_GETSOCKOPT
+_GL_WARN_ON_USE (getsockopt, "getsockopt is not always POSIX compliant - "
+ "use gnulib module getsockopt for portability");
+# endif
+#endif
+
+#if @GNULIB_LISTEN@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef listen
-# define listen rpl_listen
-extern int rpl_listen (int, int);
+# define listen rpl_listen
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef listen
-# define listen listen_used_without_requesting_gnulib_module_listen
-# elif defined GNULIB_POSIXCHECK
-# undef listen
-# define listen(s,b) \
- (GL_LINK_WARNING ("listen is not always POSIX compliant - " \
- "use gnulib module listen for portability"), \
- listen (s, b))
-# endif
-
-# if @GNULIB_RECV@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (listen, int, (int fd, int backlog));
+_GL_CXXALIAS_RPL (listen, int, (int fd, int backlog));
+# else
+_GL_CXXALIAS_SYS (listen, int, (int fd, int backlog));
+# endif
+_GL_CXXALIASWARN (listen);
+#elif @HAVE_WINSOCK2_H@
+# undef listen
+# define listen listen_used_without_requesting_gnulib_module_listen
+#elif defined GNULIB_POSIXCHECK
+# undef listen
+# if HAVE_RAW_DECL_LISTEN
+_GL_WARN_ON_USE (listen, "listen is not always POSIX compliant - "
+ "use gnulib module listen for portability");
+# endif
+#endif
+
+#if @GNULIB_RECV@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef recv
-# define recv rpl_recv
-extern int rpl_recv (int, void *, int, int) _GL_ARG_NONNULL ((2));
+# define recv rpl_recv
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef recv
-# define recv recv_used_without_requesting_gnulib_module_recv
-# elif defined GNULIB_POSIXCHECK
-# undef recv
-# define recv(s,b,n,f) \
- (GL_LINK_WARNING ("recv is not always POSIX compliant - " \
- "use gnulib module recv for portability"), \
- recv (s, b, n, f))
-# endif
-
-# if @GNULIB_SEND@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (recv, ssize_t, (int fd, void *buf, size_t len, int flags)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (recv, ssize_t, (int fd, void *buf, size_t len, int flags));
+# else
+_GL_CXXALIAS_SYS (recv, ssize_t, (int fd, void *buf, size_t len, int flags));
+# endif
+_GL_CXXALIASWARN (recv);
+#elif @HAVE_WINSOCK2_H@
+# undef recv
+# define recv recv_used_without_requesting_gnulib_module_recv
+#elif defined GNULIB_POSIXCHECK
+# undef recv
+# if HAVE_RAW_DECL_RECV
+_GL_WARN_ON_USE (recv, "recv is not always POSIX compliant - "
+ "use gnulib module recv for portability");
+# endif
+#endif
+
+#if @GNULIB_SEND@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef send
-# define send rpl_send
-extern int rpl_send (int, const void *, int, int) _GL_ARG_NONNULL ((2));
+# define send rpl_send
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef send
-# define send send_used_without_requesting_gnulib_module_send
-# elif defined GNULIB_POSIXCHECK
-# undef send
-# define send(s,b,n,f) \
- (GL_LINK_WARNING ("send is not always POSIX compliant - " \
- "use gnulib module send for portability"), \
- send (s, b, n, f))
-# endif
-
-# if @GNULIB_RECVFROM@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (send, ssize_t,
+ (int fd, const void *buf, size_t len, int flags)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (send, ssize_t,
+ (int fd, const void *buf, size_t len, int flags));
+# else
+_GL_CXXALIAS_SYS (send, ssize_t,
+ (int fd, const void *buf, size_t len, int flags));
+# endif
+_GL_CXXALIASWARN (send);
+#elif @HAVE_WINSOCK2_H@
+# undef send
+# define send send_used_without_requesting_gnulib_module_send
+#elif defined GNULIB_POSIXCHECK
+# undef send
+# if HAVE_RAW_DECL_SEND
+_GL_WARN_ON_USE (send, "send is not always POSIX compliant - "
+ "use gnulib module send for portability");
+# endif
+#endif
+
+#if @GNULIB_RECVFROM@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef recvfrom
-# define recvfrom rpl_recvfrom
-extern int rpl_recvfrom (int, void *, int, int, struct sockaddr *, int *)
- _GL_ARG_NONNULL ((2));
+# define recvfrom rpl_recvfrom
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef recvfrom
-# define recvfrom recvfrom_used_without_requesting_gnulib_module_recvfrom
-# elif defined GNULIB_POSIXCHECK
-# undef recvfrom
-# define recvfrom(s,b,n,f,a,l) \
- (GL_LINK_WARNING ("recvfrom is not always POSIX compliant - " \
- "use gnulib module recvfrom for portability"), \
- recvfrom (s, b, n, f, a, l))
-# endif
-
-# if @GNULIB_SENDTO@
-# if @HAVE_WINSOCK2_H@
+_GL_FUNCDECL_RPL (recvfrom, ssize_t,
+ (int fd, void *buf, size_t len, int flags,
+ struct sockaddr *from, socklen_t *fromlen)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (recvfrom, ssize_t,
+ (int fd, void *buf, size_t len, int flags,
+ struct sockaddr *from, socklen_t *fromlen));
+# else
+/* Need to cast, because on Solaris 10 systems, the sixth parameter is
+ void *fromlen. */
+_GL_CXXALIAS_SYS_CAST (recvfrom, ssize_t,
+ (int fd, void *buf, size_t len, int flags,
+ struct sockaddr *from, socklen_t *fromlen));
+# endif
+_GL_CXXALIASWARN (recvfrom);
+#elif @HAVE_WINSOCK2_H@
+# undef recvfrom
+# define recvfrom recvfrom_used_without_requesting_gnulib_module_recvfrom
+#elif defined GNULIB_POSIXCHECK
+# undef recvfrom
+# if HAVE_RAW_DECL_RECVFROM
+_GL_WARN_ON_USE (recvfrom, "recvfrom is not always POSIX compliant - "
+ "use gnulib module recvfrom for portability");
+# endif
+#endif
+
+#if @GNULIB_SENDTO@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef sendto
-# define sendto rpl_sendto
-extern int rpl_sendto (int, const void *, int, int, struct sockaddr *, int)
- _GL_ARG_NONNULL ((2));
+# define sendto rpl_sendto
# endif
-# elif @HAVE_WINSOCK2_H@
-# undef sendto
-# define sendto sendto_used_without_requesting_gnulib_module_sendto
-# elif defined GNULIB_POSIXCHECK
-# undef sendto
-# define sendto(s,b,n,f,a,l) \
- (GL_LINK_WARNING ("sendto is not always POSIX compliant - " \
- "use gnulib module sendto for portability"), \
- sendto (s, b, n, f, a, l))
-# endif
-
-# if @GNULIB_SETSOCKOPT@
-# if @HAVE_WINSOCK2_H@
-# undef setsockopt
-# define setsockopt rpl_setsockopt
-extern int rpl_setsockopt (int, int, int, const void *, socklen_t)
- _GL_ARG_NONNULL ((4));
-# endif
-# elif @HAVE_WINSOCK2_H@
-# undef setsockopt
-# define setsockopt
setsockopt_used_without_requesting_gnulib_module_setsockopt
-# elif defined GNULIB_POSIXCHECK
-# undef setsockopt
-# define setsockopt(s,lvl,o,v,l) \
- (GL_LINK_WARNING ("setsockopt is not always POSIX compliant - " \
- "use gnulib module setsockopt for portability"), \
- setsockopt (s, lvl, o, v, l))
-# endif
-
-# if @GNULIB_SHUTDOWN@
-# if @HAVE_WINSOCK2_H@
-# undef shutdown
-# define shutdown rpl_shutdown
-extern int rpl_shutdown (int, int);
-# endif
-# elif @HAVE_WINSOCK2_H@
-# undef shutdown
-# define shutdown shutdown_used_without_requesting_gnulib_module_shutdown
-# elif defined GNULIB_POSIXCHECK
-# undef shutdown
-# define shutdown(s,h) \
- (GL_LINK_WARNING ("shutdown is not always POSIX compliant - " \
- "use gnulib module shutdown for portability"), \
- shutdown (s, h))
+_GL_FUNCDECL_RPL (sendto, ssize_t,
+ (int fd, const void *buf, size_t len, int flags,
+ const struct sockaddr *to, socklen_t tolen)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (sendto, ssize_t,
+ (int fd, const void *buf, size_t len, int flags,
+ const struct sockaddr *to, socklen_t tolen));
+# else
+_GL_CXXALIAS_SYS (sendto, ssize_t,
+ (int fd, const void *buf, size_t len, int flags,
+ const struct sockaddr *to, socklen_t tolen));
+# endif
+_GL_CXXALIASWARN (sendto);
+#elif @HAVE_WINSOCK2_H@
+# undef sendto
+# define sendto sendto_used_without_requesting_gnulib_module_sendto
+#elif defined GNULIB_POSIXCHECK
+# undef sendto
+# if HAVE_RAW_DECL_SENDTO
+_GL_WARN_ON_USE (sendto, "sendto is not always POSIX compliant - "
+ "use gnulib module sendto for portability");
# endif
+#endif
+#if @GNULIB_SETSOCKOPT@
# if @HAVE_WINSOCK2_H@
-# undef select
-# define select select_used_without_including_sys_select_h
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef setsockopt
+# define setsockopt rpl_setsockopt
+# endif
+_GL_FUNCDECL_RPL (setsockopt, int, (int fd, int level, int optname,
+ const void * optval, socklen_t optlen)
+ _GL_ARG_NONNULL ((4)));
+_GL_CXXALIAS_RPL (setsockopt, int, (int fd, int level, int optname,
+ const void * optval, socklen_t optlen));
+# else
+_GL_CXXALIAS_SYS (setsockopt, int, (int fd, int level, int optname,
+ const void * optval, socklen_t optlen));
+# endif
+_GL_CXXALIASWARN (setsockopt);
+#elif @HAVE_WINSOCK2_H@
+# undef setsockopt
+# define setsockopt setsockopt_used_without_requesting_gnulib_module_setsockopt
+#elif defined GNULIB_POSIXCHECK
+# undef setsockopt
+# if HAVE_RAW_DECL_SETSOCKOPT
+_GL_WARN_ON_USE (setsockopt, "setsockopt is not always POSIX compliant - "
+ "use gnulib module setsockopt for portability");
# endif
+#endif
-# ifdef __cplusplus
-}
+#if @GNULIB_SHUTDOWN@
+# if @HAVE_WINSOCK2_H@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef shutdown
+# define shutdown rpl_shutdown
+# endif
+_GL_FUNCDECL_RPL (shutdown, int, (int fd, int how));
+_GL_CXXALIAS_RPL (shutdown, int, (int fd, int how));
+# else
+_GL_CXXALIAS_SYS (shutdown, int, (int fd, int how));
+# endif
+_GL_CXXALIASWARN (shutdown);
+#elif @HAVE_WINSOCK2_H@
+# undef shutdown
+# define shutdown shutdown_used_without_requesting_gnulib_module_shutdown
+#elif defined GNULIB_POSIXCHECK
+# undef shutdown
+# if HAVE_RAW_DECL_SHUTDOWN
+_GL_WARN_ON_USE (shutdown, "shutdown is not always POSIX compliant - "
+ "use gnulib module shutdown for portability");
# endif
+#endif
-#endif /* HAVE_SYS_SOCKET_H */
-
-#ifdef __cplusplus
-extern "C" {
+#if @HAVE_WINSOCK2_H@
+# undef select
+# define select select_used_without_including_sys_select_h
#endif
#if @GNULIB_ACCEPT4@
@@ -442,21 +582,32 @@ extern "C" {
See also the Linux man page at
<http://www.kernel.org/doc/man-pages/online/pages/man2/accept4.2.html>. */
# if @HAVE_ACCEPT4@
-# define accept4 rpl_accept4
-# endif
-extern int accept4 (int sockfd, struct sockaddr *addr, socklen_t *addrlen,
- int flags);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define accept4 rpl_accept4
+# endif
+_GL_FUNCDECL_RPL (accept4, int,
+ (int sockfd, struct sockaddr *addr, socklen_t *addrlen,
+ int flags));
+_GL_CXXALIAS_RPL (accept4, int,
+ (int sockfd, struct sockaddr *addr, socklen_t *addrlen,
+ int flags));
+# else
+_GL_FUNCDECL_SYS (accept4, int,
+ (int sockfd, struct sockaddr *addr, socklen_t *addrlen,
+ int flags));
+_GL_CXXALIAS_SYS (accept4, int,
+ (int sockfd, struct sockaddr *addr, socklen_t *addrlen,
+ int flags));
+# endif
+_GL_CXXALIASWARN (accept4);
#elif defined GNULIB_POSIXCHECK
# undef accept4
-# define accept4(s,a,l,f) \
- (GL_LINK_WARNING ("accept4 is unportable - " \
- "use gnulib module accept4 for portability"), \
- accept4 (s, a, l, f))
-#endif
-
-#ifdef __cplusplus
-}
+# if HAVE_RAW_DECL_ACCEPT4
+_GL_WARN_ON_USE (accept4, "accept4 is unportable - "
+ "use gnulib module accept4 for portability");
+# endif
#endif
#endif /* _GL_SYS_SOCKET_H */
#endif /* _GL_SYS_SOCKET_H */
+#endif
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h
index 0db3c4d..571cfe4 100644
--- a/lib/sys_stat.in.h
+++ b/lib/sys_stat.in.h
@@ -1,5 +1,5 @@
/* Provide a more complete sys/stat header file.
- Copyright (C) 2005-2009 Free Software Foundation, Inc.
+ Copyright (C) 2005-2010 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
@@ -47,10 +47,12 @@
#ifndef _GL_SYS_STAT_H
#define _GL_SYS_STAT_H
-/* The definition of GL_LINK_WARNING is copied here. */
+/* 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. */
+
/* Before doing "#define mkdir rpl_mkdir" below, we need to include all
headers that may declare mkdir(). */
#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
@@ -290,63 +292,87 @@
#endif
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-
#if @GNULIB_FCHMODAT@
# if address@hidden@
-extern int fchmodat (int fd, char const *file, mode_t mode, int flag)
- _GL_ARG_NONNULL ((2));
+_GL_FUNCDECL_SYS (fchmodat, int,
+ (int fd, char const *file, mode_t mode, int flag)
+ _GL_ARG_NONNULL ((2)));
# endif
+_GL_CXXALIAS_SYS (fchmodat, int,
+ (int fd, char const *file, mode_t mode, int flag));
+_GL_CXXALIASWARN (fchmodat);
#elif defined GNULIB_POSIXCHECK
# undef fchmodat
-# define fchmodat(d,n,m,f) \
- (GL_LINK_WARNING ("fchmodat is not portable - " \
- "use gnulib module openat for portability"), \
- fchmodat (d, n, m, f))
+# if HAVE_RAW_DECL_FCHMODAT
+_GL_WARN_ON_USE (fchmodat, "fchmodat is not portable - "
+ "use gnulib module openat for portability");
+# endif
#endif
#if @REPLACE_FSTAT@
-# define fstat rpl_fstat
-extern int fstat (int fd, struct stat *buf) _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define fstat rpl_fstat
+# endif
+_GL_FUNCDECL_RPL (fstat, int, (int fd, struct stat *buf) _GL_ARG_NONNULL
((2)));
+_GL_CXXALIAS_RPL (fstat, int, (int fd, struct stat *buf));
+#else
+_GL_CXXALIAS_SYS (fstat, int, (int fd, struct stat *buf));
#endif
+_GL_CXXALIASWARN (fstat);
#if @GNULIB_FSTATAT@
# if @REPLACE_FSTATAT@
-# undef fstatat
-# define fstatat rpl_fstatat
-# endif
-# if address@hidden@ || @REPLACE_FSTATAT@
-extern int fstatat (int fd, char const *name, struct stat *st, int flags)
- _GL_ARG_NONNULL ((2, 3));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fstatat
+# define fstatat rpl_fstatat
+# endif
+_GL_FUNCDECL_RPL (fstatat, int,
+ (int fd, char const *name, struct stat *st, int flags)
+ _GL_ARG_NONNULL ((2, 3)));
+_GL_CXXALIAS_RPL (fstatat, int,
+ (int fd, char const *name, struct stat *st, int flags));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (fstatat, int,
+ (int fd, char const *name, struct stat *st, int flags)
+ _GL_ARG_NONNULL ((2, 3)));
+# endif
+_GL_CXXALIAS_SYS (fstatat, int,
+ (int fd, char const *name, struct stat *st, int flags));
# endif
+_GL_CXXALIASWARN (fstatat);
#elif defined GNULIB_POSIXCHECK
# undef fstatat
-# define fstatat(d,n,s,f) \
- (GL_LINK_WARNING ("fstatat is not portable - " \
- "use gnulib module openat for portability"), \
- fstatat (d, n, s, f))
+# if HAVE_RAW_DECL_FSTATAT
+_GL_WARN_ON_USE (fstatat, "fstatat is not portable - "
+ "use gnulib module openat for portability");
+# endif
#endif
#if @GNULIB_FUTIMENS@
# if @REPLACE_FUTIMENS@
-# undef futimens
-# define futimens rpl_futimens
-# endif
-# if address@hidden@ || @REPLACE_FUTIMENS@
-extern int futimens (int fd, struct timespec const times[2]);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef futimens
+# define futimens rpl_futimens
+# endif
+_GL_FUNCDECL_RPL (futimens, int, (int fd, struct timespec const times[2]));
+_GL_CXXALIAS_RPL (futimens, int, (int fd, struct timespec const times[2]));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (futimens, int, (int fd, struct timespec const times[2]));
+# endif
+_GL_CXXALIAS_SYS (futimens, int, (int fd, struct timespec const times[2]));
# endif
+_GL_CXXALIASWARN (futimens);
#elif defined GNULIB_POSIXCHECK
# undef futimens
-# define futimens(f,t) \
- (GL_LINK_WARNING ("futimens is not portable - " \
- "use gnulib module futimens for portability"), \
- futimens (f, t))
+# if HAVE_RAW_DECL_FUTIMENS
+_GL_WARN_ON_USE (futimens, "futimens is not portable - "
+ "use gnulib module futimens for portability");
+# endif
#endif
@@ -361,17 +387,24 @@ extern int futimens (int fd, struct timespec const
times[2]);
invocation of lchmod, but we know of no workarounds that are
reliable in general. You might try requesting support for lchmod
from your operating system supplier. */
-# define lchmod chmod
-# endif
-# if 0 /* assume already declared */
-extern int lchmod (const char *filename, mode_t mode) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define lchmod chmod
+# endif
+_GL_CXXALIAS_RPL_1 (lchmod, chmod, int, (const char *filename, mode_t mode));
+# else
+# if 0 /* assume already declared */
+_GL_FUNCDECL_SYS (lchmod, int, (const char *filename, mode_t mode)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (lchmod, int, (const char *filename, mode_t mode));
# endif
+_GL_CXXALIASWARN (lchmod);
#elif defined GNULIB_POSIXCHECK
# undef lchmod
-# define lchmod(f,m) \
- (GL_LINK_WARNING ("lchmod is unportable - " \
- "use gnulib module lchmod for portability"), \
- lchmod (f, m))
+# if HAVE_RAW_DECL_LCHMOD
+_GL_WARN_ON_USE (lchmod, "lchmod is unportable - "
+ "use gnulib module lchmod for portability");
+# endif
#endif
@@ -379,26 +412,39 @@ extern int lchmod (const char *filename, mode_t mode)
_GL_ARG_NONNULL ((1));
# if ! @HAVE_LSTAT@
/* mingw does not support symlinks, therefore it does not have lstat. But
without links, stat does just fine. */
-# define lstat stat
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define lstat stat
+# endif
+_GL_CXXALIAS_RPL_1 (lstat, stat, int, (const char *name, struct stat *buf));
# elif @REPLACE_LSTAT@
-# undef lstat
-# define lstat rpl_lstat
-extern int rpl_lstat (const char *name, struct stat *buf)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef lstat
+# define lstat rpl_lstat
+# endif
+_GL_FUNCDECL_RPL (lstat, int, (const char *name, struct stat *buf)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (lstat, int, (const char *name, struct stat *buf));
+# else
+_GL_CXXALIAS_SYS (lstat, int, (const char *name, struct stat *buf));
# endif
+_GL_CXXALIASWARN (lstat);
#elif defined GNULIB_POSIXCHECK
# undef lstat
-# define lstat(p,b) \
- (GL_LINK_WARNING ("lstat is unportable - " \
- "use gnulib module lstat for portability"), \
- lstat (p, b))
+# if HAVE_RAW_DECL_LSTAT
+_GL_WARN_ON_USE (lstat, "lstat is unportable - "
+ "use gnulib module lstat for portability");
+# endif
#endif
#if @REPLACE_MKDIR@
-# undef mkdir
-# define mkdir rpl_mkdir
-extern int mkdir (char const *name, mode_t mode) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mkdir
+# define mkdir rpl_mkdir
+# endif
+_GL_FUNCDECL_RPL (mkdir, int, (char const *name, mode_t mode)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mkdir, int, (char const *name, mode_t mode));
#else
/* mingw's _mkdir() function has 1 argument, but we pass 2 arguments.
Additionally, it declares _mkdir (and depending on compile flags, an
@@ -411,85 +457,116 @@ rpl_mkdir (char const *name, mode_t mode)
return _mkdir (name);
}
-# define mkdir rpl_mkdir
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define mkdir rpl_mkdir
+# endif
+_GL_CXXALIAS_RPL (mkdir, int, (char const *name, mode_t mode));
+# else
+_GL_CXXALIAS_SYS (mkdir, int, (char const *name, mode_t mode));
# endif
#endif
+_GL_CXXALIASWARN (mkdir);
#if @GNULIB_MKDIRAT@
# if address@hidden@
-extern int mkdirat (int fd, char const *file, mode_t mode)
- _GL_ARG_NONNULL ((2));
+_GL_FUNCDECL_SYS (mkdirat, int, (int fd, char const *file, mode_t mode)
+ _GL_ARG_NONNULL ((2)));
# endif
+_GL_CXXALIAS_SYS (mkdirat, int, (int fd, char const *file, mode_t mode));
+_GL_CXXALIASWARN (mkdirat);
#elif defined GNULIB_POSIXCHECK
# undef mkdirat
-# define mkdirat(d,n,m) \
- (GL_LINK_WARNING ("mkdirat is not portable - " \
- "use gnulib module openat for portability"), \
- mkdirat (d, n, m))
+# if HAVE_RAW_DECL_MKDIRAT
+_GL_WARN_ON_USE (mkdirat, "mkdirat is not portable - "
+ "use gnulib module openat for portability");
+# endif
#endif
#if @GNULIB_MKFIFO@
# if @REPLACE_MKFIFO@
-# undef mkfifo
-# define mkfifo rpl_mkfifo
-# endif
-# if address@hidden@ || @REPLACE_MKFIFO@
-extern int mkfifo (char const *file, mode_t mode) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mkfifo
+# define mkfifo rpl_mkfifo
+# endif
+_GL_FUNCDECL_RPL (mkfifo, int, (char const *file, mode_t mode)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mkfifo, int, (char const *file, mode_t mode));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mkfifo, int, (char const *file, mode_t mode)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (mkfifo, int, (char const *file, mode_t mode));
# endif
+_GL_CXXALIASWARN (mkfifo);
#elif defined GNULIB_POSIXCHECK
# undef mkfifo
-# define mkfifo(n,m) \
- (GL_LINK_WARNING ("mkfifo is not portable - " \
- "use gnulib module mkfifo for portability"), \
- mkfifo (n, m))
+# if HAVE_RAW_DECL_MKFIFO
+_GL_WARN_ON_USE (mkfifo, "mkfifo is not portable - "
+ "use gnulib module mkfifo for portability");
+# endif
#endif
#if @GNULIB_MKFIFOAT@
# if address@hidden@
-extern int mkfifoat (int fd, char const *file, mode_t mode)
- _GL_ARG_NONNULL ((2));
+_GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)
+ _GL_ARG_NONNULL ((2)));
# endif
+_GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode));
+_GL_CXXALIASWARN (mkfifoat);
#elif defined GNULIB_POSIXCHECK
# undef mkfifoat
-# define mkfifoat(d,n,m) \
- (GL_LINK_WARNING ("mkfifoat is not portable - " \
- "use gnulib module mkfifoat for portability"), \
- mkfifoat (d, n, m))
+# if HAVE_RAW_DECL_MKFIFOAT
+_GL_WARN_ON_USE (mkfifoat, "mkfifoat is not portable - "
+ "use gnulib module mkfifoat for portability");
+# endif
#endif
#if @GNULIB_MKNOD@
# if @REPLACE_MKNOD@
-# undef mknod
-# define mknod rpl_mknod
-# endif
-# if address@hidden@ || @REPLACE_MKNOD@
-extern int mknod (char const *file, mode_t mode, dev_t dev)
- _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mknod
+# define mknod rpl_mknod
+# endif
+_GL_FUNCDECL_RPL (mknod, int, (char const *file, mode_t mode, dev_t dev)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mknod, int, (char const *file, mode_t mode, dev_t dev));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mknod, int, (char const *file, mode_t mode, dev_t dev)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (mknod, int, (char const *file, mode_t mode, dev_t dev));
# endif
+_GL_CXXALIASWARN (mknod);
#elif defined GNULIB_POSIXCHECK
# undef mknod
-# define mknod(n,m,d) \
- (GL_LINK_WARNING ("mknod is not portable - " \
- "use gnulib module mknod for portability"), \
- mknod (n, m, d))
+# if HAVE_RAW_DECL_MKNOD
+_GL_WARN_ON_USE (mknod, "mknod is not portable - "
+ "use gnulib module mknod for portability");
+# endif
#endif
#if @GNULIB_MKNODAT@
# if address@hidden@
-extern int mknodat (int fd, char const *file, mode_t mode, dev_t dev)
- _GL_ARG_NONNULL ((2));
+_GL_FUNCDECL_SYS (mknodat, int,
+ (int fd, char const *file, mode_t mode, dev_t dev)
+ _GL_ARG_NONNULL ((2)));
# endif
+_GL_CXXALIAS_SYS (mknodat, int,
+ (int fd, char const *file, mode_t mode, dev_t dev));
+_GL_CXXALIASWARN (mknodat);
#elif defined GNULIB_POSIXCHECK
# undef mknodat
-# define mknodat(f,n,m,d) \
- (GL_LINK_WARNING ("mknodat is not portable - " \
- "use gnulib module mkfifoat for portability"), \
- mknodat (f, n, m, d))
+# if HAVE_RAW_DECL_MKNODAT
+_GL_WARN_ON_USE (mknodat, "mknodat is not portable - "
+ "use gnulib module mkfifoat for portability");
+# endif
#endif
@@ -508,38 +585,44 @@ extern int mknodat (int fd, char const *file, mode_t
mode, dev_t dev)
# else /* !_LARGE_FILES */
# define stat(name, st) rpl_stat (name, st)
# endif /* !_LARGE_FILES */
-extern int stat (const char *name, struct stat *buf) _GL_ARG_NONNULL ((1, 2));
+_GL_EXTERN_C int stat (const char *name, struct stat *buf) _GL_ARG_NONNULL
((1, 2));
# endif
#elif defined GNULIB_POSIXCHECK
# undef stat
-# define stat(p,b) \
- (GL_LINK_WARNING ("stat is unportable - " \
- "use gnulib module stat for portability"), \
- stat (p, b))
+# if HAVE_RAW_DECL_STAT
+_GL_WARN_ON_USE (stat, "stat is unportable - "
+ "use gnulib module stat for portability");
+# endif
#endif
#if @GNULIB_UTIMENSAT@
# if @REPLACE_UTIMENSAT@
-# undef utimensat
-# define utimensat rpl_utimensat
-# endif
-# if address@hidden@ || @REPLACE_UTIMENSAT@
- extern int utimensat (int fd, char const *name,
- struct timespec const times[2], int flag)
- _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef utimensat
+# define utimensat rpl_utimensat
+# endif
+_GL_FUNCDECL_RPL (utimensat, int, (int fd, char const *name,
+ struct timespec const times[2], int flag)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (utimensat, int, (int fd, char const *name,
+ struct timespec const times[2], int flag));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (utimensat, int, (int fd, char const *name,
+ struct timespec const times[2], int flag)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (utimensat, int, (int fd, char const *name,
+ struct timespec const times[2], int flag));
# endif
+_GL_CXXALIASWARN (utimensat);
#elif defined GNULIB_POSIXCHECK
# undef utimensat
-# define utimensat(d,n,t,f) \
- (GL_LINK_WARNING ("utimensat is not portable - " \
- "use gnulib module utimensat for portability"), \
- utimensat (d, n, t, f))
-#endif
-
-
-#ifdef __cplusplus
-}
+# if HAVE_RAW_DECL_UTIMENSAT
+_GL_WARN_ON_USE (utimensat, "utimensat is not portable - "
+ "use gnulib module utimensat for portability");
+# endif
#endif
diff --git a/lib/time.in.h b/lib/time.in.h
index eb35cc2..958de82 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -1,6 +1,6 @@
/* A more-standard <time.h>.
- Copyright (C) 2007-2009 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 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
@@ -40,8 +40,12 @@
/* NetBSD 5.0 mis-defines NULL. */
#include <stddef.h>
+/* 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
@@ -63,54 +67,117 @@ struct timespec
# endif
# endif
+# ifdef __cplusplus
+}
+# endif
+
/* Sleep for at least RQTP seconds unless interrupted, If interrupted,
return -1 and store the remaining time into RMTP. See
<http://www.opengroup.org/susv3xsh/nanosleep.html>. */
-# if @REPLACE_NANOSLEEP@
-# define nanosleep rpl_nanosleep
-extern int nanosleep (struct timespec const *__rqtp, struct timespec *__rmtp)
- _GL_ARG_NONNULL ((1));
+# if @GNULIB_NANOSLEEP@
+# if @REPLACE_NANOSLEEP@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define nanosleep rpl_nanosleep
+# endif
+_GL_FUNCDECL_RPL (nanosleep, int,
+ (struct timespec const *__rqtp, struct timespec *__rmtp)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (nanosleep, int,
+ (struct timespec const *__rqtp, struct timespec *__rmtp));
+# else
+_GL_CXXALIAS_SYS (nanosleep, int,
+ (struct timespec const *__rqtp, struct timespec *__rmtp));
+# endif
+_GL_CXXALIASWARN (nanosleep);
# endif
/* Return the 'time_t' representation of TP and normalize TP. */
-# if @REPLACE_MKTIME@
-# define mktime rpl_mktime
-extern time_t mktime (struct tm *__tp) _GL_ARG_NONNULL ((1));
+# if @GNULIB_MKTIME@
+# if @REPLACE_MKTIME@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define mktime rpl_mktime
+# endif
+_GL_FUNCDECL_RPL (mktime, time_t, (struct tm *__tp) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mktime, time_t, (struct tm *__tp));
+# else
+_GL_CXXALIAS_SYS (mktime, time_t, (struct tm *__tp));
+# endif
+_GL_CXXALIASWARN (mktime);
# endif
/* Convert TIMER to RESULT, assuming local time and UTC respectively. See
<http://www.opengroup.org/susv3xsh/localtime_r.html> and
<http://www.opengroup.org/susv3xsh/gmtime_r.html>. */
-# if @REPLACE_LOCALTIME_R@
-# undef localtime_r
-# define localtime_r rpl_localtime_r
-# undef gmtime_r
-# define gmtime_r rpl_gmtime_r
-extern struct tm *localtime_r (time_t const *restrict __timer,
- struct tm *restrict __result)
- _GL_ARG_NONNULL ((1, 2));
-extern struct tm *gmtime_r (time_t const *restrict __timer,
- struct tm *restrict __result)
- _GL_ARG_NONNULL ((1, 2));
+# if @GNULIB_TIME_R@
+# if @REPLACE_LOCALTIME_R@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef localtime_r
+# define localtime_r rpl_localtime_r
+# endif
+_GL_FUNCDECL_RPL (localtime_r, struct tm *, (time_t const *restrict __timer,
+ struct tm *restrict __result)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (localtime_r, struct tm *, (time_t const *restrict __timer,
+ struct tm *restrict __result));
+# else
+_GL_CXXALIAS_SYS (localtime_r, struct tm *, (time_t const *restrict __timer,
+ struct tm *restrict __result));
+# endif
+_GL_CXXALIASWARN (localtime_r);
+# if @REPLACE_LOCALTIME_R@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef gmtime_r
+# define gmtime_r rpl_gmtime_r
+# endif
+_GL_FUNCDECL_RPL (gmtime_r, struct tm *, (time_t const *restrict __timer,
+ struct tm *restrict __result)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (gmtime_r, struct tm *, (time_t const *restrict __timer,
+ struct tm *restrict __result));
+# else
+_GL_CXXALIAS_SYS (gmtime_r, struct tm *, (time_t const *restrict __timer,
+ struct tm *restrict __result));
+# endif
+_GL_CXXALIASWARN (gmtime_r);
# endif
/* Parse BUF as a time stamp, assuming FORMAT specifies its layout, and store
the resulting broken-down time into TM. See
<http://www.opengroup.org/susv3xsh/strptime.html>. */
-# if @REPLACE_STRPTIME@
-# undef strptime
-# define strptime rpl_strptime
-extern char *strptime (char const *restrict __buf,
- char const *restrict __format,
- struct tm *restrict __tm)
- _GL_ARG_NONNULL ((1, 2, 3));
+# if @GNULIB_STRPTIME@
+# if @REPLACE_STRPTIME@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef strptime
+# define strptime rpl_strptime
+# endif
+_GL_FUNCDECL_RPL (strptime, char *, (char const *restrict __buf,
+ char const *restrict __format,
+ struct tm *restrict __tm)
+ _GL_ARG_NONNULL ((1, 2, 3)));
+_GL_CXXALIAS_RPL (strptime, char *, (char const *restrict __buf,
+ char const *restrict __format,
+ struct tm *restrict __tm));
+# else
+_GL_CXXALIAS_SYS (strptime, char *, (char const *restrict __buf,
+ char const *restrict __format,
+ struct tm *restrict __tm));
+# endif
+_GL_CXXALIASWARN (strptime);
# endif
/* Convert TM to a time_t value, assuming UTC. */
-# if @REPLACE_TIMEGM@
-# undef timegm
-# define timegm rpl_timegm
-extern time_t timegm (struct tm *__tm) _GL_ARG_NONNULL ((1));
+# if @GNULIB_TIMEGM@
+# if @REPLACE_TIMEGM@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef timegm
+# define timegm rpl_timegm
+# endif
+_GL_FUNCDECL_RPL (timegm, time_t, (struct tm *__tm) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (timegm, time_t, (struct tm *__tm));
+# else
+_GL_CXXALIAS_SYS (timegm, time_t, (struct tm *__tm));
+# endif
+_GL_CXXALIASWARN (timegm);
# endif
/* Encourage applications to avoid unsafe functions that can overrun
@@ -127,8 +194,4 @@ extern time_t timegm (struct tm *__tm) _GL_ARG_NONNULL
((1));
# define ctime_r eschew_ctime_r
# endif
-# ifdef __cplusplus
-}
-# endif
-
#endif
diff --git a/lib/time_r.c b/lib/time_r.c
index 90dcf00..a4f2b4d 100644
--- a/lib/time_r.c
+++ b/lib/time_r.c
@@ -1,6 +1,6 @@
/* Reentrant time functions like localtime_r.
- Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2006, 2007, 2009, 2010 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
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index c6d1d13..7609d58 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -1,5 +1,5 @@
/* Substitute for and wrapper around <unistd.h>.
- Copyright (C) 2003-2009 Free Software Foundation, Inc.
+ Copyright (C) 2003-2010 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
@@ -33,23 +33,43 @@
#include <stddef.h>
/* mingw doesn't define the SEEK_* or *_FILENO macros in <unistd.h>. */
-#if !(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET)
+/* Cygwin 1.7.1 declares symlinkat in <stdio.h>, not in <unistd.h>. */
+/* But avoid namespace pollution on glibc systems. */
+#if (!(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET) \
+ || (@GNULIB_SYMLINKAT@ || defined GNULIB_POSIXCHECK)) \
+ && ! defined __GLIBC__
# include <stdio.h>
#endif
+/* Cygwin 1.7.1 declares unlinkat in <fcntl.h>, not in <unistd.h>. */
+/* But avoid namespace pollution on glibc systems. */
+#if (@GNULIB_UNLINKAT@ || defined GNULIB_POSIXCHECK) && ! defined __GLIBC__
+# include <fcntl.h>
+#endif
+
/* mingw fails to declare _exit in <unistd.h>. */
/* mingw, BeOS, Haiku declare environ in <stdlib.h>, not in <unistd.h>. */
-#include <stdlib.h>
+/* Solaris declares getcwd not only in <unistd.h> but also in <stdlib.h>. */
+/* But avoid namespace pollution on glibc systems. */
+#ifndef __GLIBC__
+# include <stdlib.h>
+#endif
-#if ((@GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@) \
- || (@GNULIB_READLINK@ && (address@hidden@ || @REPLACE_READLINK@)) \
- || (@GNULIB_READLINKAT@ && address@hidden@))
+/* mingw declares getcwd in <io.h>, not in <unistd.h>. */
+#if ((@GNULIB_GETCWD@ || defined GNULIB_POSIXCHECK) \
+ && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__))
+# include <io.h>
+#endif
+
+#if (@GNULIB_WRITE@ || @GNULIB_READLINK@ || @GNULIB_READLINKAT@ \
+ || @GNULIB_PREAD@ || defined GNULIB_POSIXCHECK)
/* Get ssize_t. */
# include <sys/types.h>
#endif
-/* Get getopt(), optarg, optind, opterr, optopt. */
-#if @GNULIB_UNISTD_H_GETOPT@ && !defined _GL_SYSTEM_GETOPT
+/* Get getopt(), optarg, optind, opterr, optopt.
+ But avoid namespace pollution on glibc systems. */
+#if @GNULIB_UNISTD_H_GETOPT@ && !defined __GLIBC__ && !defined
_GL_SYSTEM_GETOPT
# include <getopt.h>
#endif
@@ -94,10 +114,12 @@
# endif
#endif
-/* The definition of GL_LINK_WARNING is copied here. */
+/* 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. */
+
/* OS/2 EMX lacks these macros. */
#ifndef STDIN_FILENO
@@ -121,78 +143,107 @@
/* Declare overridden functions. */
-#ifdef __cplusplus
-extern "C" {
+
+#if defined GNULIB_POSIXCHECK
+/* The access() function is a security risk. */
+_GL_WARN_ON_USE (access, "the access function is a security risk - "
+ "use the gnulib module faccessat instead");
#endif
#if @GNULIB_CHOWN@
-# if @REPLACE_CHOWN@
-# undef chown
-# define chown rpl_chown
-# endif
-# if address@hidden@ || @REPLACE_CHOWN@
/* Change the owner of FILE to UID (if UID is not -1) and the group of FILE
to GID (if GID is not -1). Follow symbolic links.
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/chown.html>. */
-extern int chown (const char *file, uid_t uid, gid_t gid)
- _GL_ARG_NONNULL ((1));
+# if @REPLACE_CHOWN@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef chown
+# define chown rpl_chown
+# endif
+_GL_FUNCDECL_RPL (chown, int, (const char *file, uid_t uid, gid_t gid)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (chown, int, (const char *file, uid_t uid, gid_t gid));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (chown, int, (const char *file, uid_t uid, gid_t gid)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (chown, int, (const char *file, uid_t uid, gid_t gid));
# endif
+_GL_CXXALIASWARN (chown);
#elif defined GNULIB_POSIXCHECK
# undef chown
-# define chown(f,u,g) \
- (GL_LINK_WARNING ("chown fails to follow symlinks on some systems and " \
- "doesn't treat a uid or gid of -1 on some systems - " \
- "use gnulib module chown for portability"), \
- chown (f, u, g))
+# if HAVE_RAW_DECL_CHOWN
+_GL_WARN_ON_USE (chown, "chown fails to follow symlinks on some systems and "
+ "doesn't treat a uid or gid of -1 on some systems - "
+ "use gnulib module chown for portability");
+# endif
#endif
#if @GNULIB_CLOSE@
# if @REPLACE_CLOSE@
/* Automatically included by modules that need a replacement for close. */
-# undef close
-# define close rpl_close
-extern int close (int);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef close
+# define close rpl_close
+# endif
+_GL_FUNCDECL_RPL (close, int, (int fd));
+_GL_CXXALIAS_RPL (close, int, (int fd));
+# else
+_GL_CXXALIAS_SYS (close, int, (int fd));
# endif
+_GL_CXXALIASWARN (close);
#elif @UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS@
# undef close
# define close close_used_without_requesting_gnulib_module_close
#elif defined GNULIB_POSIXCHECK
# undef close
-# define close(f) \
- (GL_LINK_WARNING ("close does not portably work on sockets - " \
- "use gnulib module close for portability"), \
- close (f))
+/* Assume close is always declared. */
+_GL_WARN_ON_USE (close, "close does not portably work on sockets - "
+ "use gnulib module close for portability");
#endif
#if @REPLACE_DUP@
-# define dup rpl_dup
-extern int dup (int);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define dup rpl_dup
+# endif
+_GL_FUNCDECL_RPL (dup, int, (int oldfd));
+_GL_CXXALIAS_RPL (dup, int, (int oldfd));
+#else
+_GL_CXXALIAS_SYS (dup, int, (int oldfd));
#endif
+_GL_CXXALIASWARN (dup);
#if @GNULIB_DUP2@
-# if @REPLACE_DUP2@
-# define dup2 rpl_dup2
-# endif
-# if address@hidden@ || @REPLACE_DUP2@
/* Copy the file descriptor OLDFD into file descriptor NEWFD. Do nothing if
NEWFD = OLDFD, otherwise close NEWFD first if it is open.
Return newfd if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/dup2.html>. */
-extern int dup2 (int oldfd, int newfd);
+# if @REPLACE_DUP2@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define dup2 rpl_dup2
+# endif
+_GL_FUNCDECL_RPL (dup2, int, (int oldfd, int newfd));
+_GL_CXXALIAS_RPL (dup2, int, (int oldfd, int newfd));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (dup2, int, (int oldfd, int newfd));
+# endif
+_GL_CXXALIAS_SYS (dup2, int, (int oldfd, int newfd));
# endif
+_GL_CXXALIASWARN (dup2);
#elif defined GNULIB_POSIXCHECK
# undef dup2
-# define dup2(o,n) \
- (GL_LINK_WARNING ("dup2 is unportable - " \
- "use gnulib module dup2 for portability"), \
- dup2 (o, n))
+# if HAVE_RAW_DECL_DUP2
+_GL_WARN_ON_USE (dup2, "dup2 is unportable - "
+ "use gnulib module dup2 for portability");
+# endif
#endif
@@ -206,15 +257,22 @@ extern int dup2 (int oldfd, int newfd);
See the Linux man page at
<http://www.kernel.org/doc/man-pages/online/pages/man2/dup3.2.html>. */
# if @HAVE_DUP3@
-# define dup3 rpl_dup3
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define dup3 rpl_dup3
+# endif
+_GL_FUNCDECL_RPL (dup3, int, (int oldfd, int newfd, int flags));
+_GL_CXXALIAS_RPL (dup3, int, (int oldfd, int newfd, int flags));
+# else
+_GL_FUNCDECL_SYS (dup3, int, (int oldfd, int newfd, int flags));
+_GL_CXXALIAS_SYS (dup3, int, (int oldfd, int newfd, int flags));
# endif
-extern int dup3 (int oldfd, int newfd, int flags);
+_GL_CXXALIASWARN (dup3);
#elif defined GNULIB_POSIXCHECK
# undef dup3
-# define dup3(o,n,f) \
- (GL_LINK_WARNING ("dup3 is unportable - " \
- "use gnulib module dup3 for portability"), \
- dup3 (o, n, f))
+# if HAVE_RAW_DECL_DUP3
+_GL_WARN_ON_USE (dup3, "dup3 is unportable - "
+ "use gnulib module dup3 for portability");
+# endif
#endif
@@ -226,88 +284,128 @@ extern int dup3 (int oldfd, int newfd, int flags);
# include <crt_externs.h>
# define environ (*_NSGetEnviron ())
# else
+# ifdef __cplusplus
+extern "C" {
+# endif
extern char **environ;
+# ifdef __cplusplus
+}
+# endif
# endif
# endif
#elif defined GNULIB_POSIXCHECK
-# undef environ
-# define environ \
- (GL_LINK_WARNING ("environ is unportable - " \
- "use gnulib module environ for portability"), \
- environ)
+# if HAVE_RAW_DECL_ENVIRON
+static inline char ***
+rpl_environ (void)
+{
+ return &environ;
+}
+_GL_WARN_ON_USE (rpl_environ, "environ is unportable - "
+ "use gnulib module environ for portability");
+# undef environ
+# define environ (*rpl_environ ())
+# endif
#endif
#if @GNULIB_EUIDACCESS@
-# if address@hidden@
/* Like access(), except that it uses the effective user id and group id of
the current process. */
-extern int euidaccess (const char *filename, int mode) _GL_ARG_NONNULL ((1));
+# if address@hidden@
+_GL_FUNCDECL_SYS (euidaccess, int, (const char *filename, int mode)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (euidaccess, int, (const char *filename, int mode));
+_GL_CXXALIASWARN (euidaccess);
+# if defined GNULIB_POSIXCHECK
+/* Like access(), this function is a security risk. */
+_GL_WARN_ON_USE (euidaccess, "the euidaccess function is a security risk - "
+ "use the gnulib module faccessat instead");
# endif
#elif defined GNULIB_POSIXCHECK
# undef euidaccess
-# define euidaccess(f,m) \
- (GL_LINK_WARNING ("euidaccess is unportable - " \
- "use gnulib module euidaccess for portability"), \
- euidaccess (f, m))
+# if HAVE_RAW_DECL_EUIDACCESS
+_GL_WARN_ON_USE (euidaccess, "euidaccess is unportable - "
+ "use gnulib module euidaccess for portability");
+# endif
#endif
#if @GNULIB_FACCESSAT@
# if address@hidden@
-extern int faccessat (int fd, char const *file, int mode, int flag)
- _GL_ARG_NONNULL ((2));
+_GL_FUNCDECL_SYS (faccessat, int,
+ (int fd, char const *file, int mode, int flag)
+ _GL_ARG_NONNULL ((2)));
# endif
+_GL_CXXALIAS_SYS (faccessat, int,
+ (int fd, char const *file, int mode, int flag));
+_GL_CXXALIASWARN (faccessat);
#elif defined GNULIB_POSIXCHECK
# undef faccessat
-# define faccessat(d,n,m,f) \
- (GL_LINK_WARNING ("faccessat is not portable - " \
- "use gnulib module faccessat for portability"), \
- faccessat (d, n, m, f))
+# if HAVE_RAW_DECL_FACCESSAT
+_GL_WARN_ON_USE (faccessat, "faccessat is not portable - "
+ "use gnulib module faccessat for portability");
+# endif
#endif
#if @GNULIB_FCHDIR@
-# if @REPLACE_FCHDIR@
/* Change the process' current working directory to the directory on which
the given file descriptor is open.
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/fchdir.html>. */
-extern int fchdir (int /*fd*/);
+# if @REPLACE_FCHDIR@
+_GL_FUNCDECL_RPL (fchdir, int, (int /*fd*/));
+_GL_CXXALIAS_RPL (fchdir, int, (int /*fd*/));
/* Gnulib internal hooks needed to maintain the fchdir metadata. */
-extern int _gl_register_fd (int fd, const char *filename)
+_GL_EXTERN_C int _gl_register_fd (int fd, const char *filename)
_GL_ARG_NONNULL ((2));
-extern void _gl_unregister_fd (int fd);
-extern int _gl_register_dup (int oldfd, int newfd);
-extern const char *_gl_directory_name (int fd);
+_GL_EXTERN_C void _gl_unregister_fd (int fd);
+_GL_EXTERN_C int _gl_register_dup (int oldfd, int newfd);
+_GL_EXTERN_C const char *_gl_directory_name (int fd);
+# else
+_GL_CXXALIAS_SYS (fchdir, int, (int /*fd*/));
# endif
+_GL_CXXALIASWARN (fchdir);
#elif defined GNULIB_POSIXCHECK
# undef fchdir
-# define fchdir(f) \
- (GL_LINK_WARNING ("fchdir is unportable - " \
- "use gnulib module fchdir for portability"), \
- fchdir (f))
+# if HAVE_RAW_DECL_FCHDIR
+_GL_WARN_ON_USE (fchdir, "fchdir is unportable - "
+ "use gnulib module fchdir for portability");
+# endif
#endif
#if @GNULIB_FCHOWNAT@
# if @REPLACE_FCHOWNAT@
-# undef fchownat
-# define fchownat rpl_fchownat
-# endif
-# if address@hidden@ || @REPLACE_FCHOWNAT@
-extern int fchownat (int fd, char const *file, uid_t owner, gid_t group, int
flag)
- _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fchownat
+# define fchownat rpl_fchownat
+# endif
+_GL_FUNCDECL_RPL (fchownat, int, (int fd, char const *file,
+ uid_t owner, gid_t group, int flag)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (fchownat, int, (int fd, char const *file,
+ uid_t owner, gid_t group, int flag));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (fchownat, int, (int fd, char const *file,
+ uid_t owner, gid_t group, int flag)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (fchownat, int, (int fd, char const *file,
+ uid_t owner, gid_t group, int flag));
# endif
+_GL_CXXALIASWARN (fchownat);
#elif defined GNULIB_POSIXCHECK
# undef fchownat
-# define fchownat(d,n,o,g,f) \
- (GL_LINK_WARNING ("fchownat is not portable - " \
- "use gnulib module openat for portability"), \
- fchownat (d, n, o, g, f))
+# if HAVE_RAW_DECL_FCHOWNAT
+_GL_WARN_ON_USE (fchownat, "fchownat is not portable - "
+ "use gnulib module openat for portability");
+# endif
#endif
@@ -317,39 +415,39 @@ extern int fchownat (int fd, char const *file, uid_t
owner, gid_t group, int fla
See POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/fsync.html>. */
# if address@hidden@
-extern int fsync (int fd);
+_GL_FUNCDECL_SYS (fsync, int, (int fd));
# endif
+_GL_CXXALIAS_SYS (fsync, int, (int fd));
+_GL_CXXALIASWARN (fsync);
#elif defined GNULIB_POSIXCHECK
# undef fsync
-# define fsync(fd) \
- (GL_LINK_WARNING ("fsync is unportable - " \
- "use gnulib module fsync for portability"), \
- fsync (fd))
+# if HAVE_RAW_DECL_FSYNC
+_GL_WARN_ON_USE (fsync, "fsync is unportable - "
+ "use gnulib module fsync for portability");
+# endif
#endif
#if @GNULIB_FTRUNCATE@
-# if address@hidden@
/* Change the size of the file to which FD is opened to become equal to LENGTH.
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/ftruncate.html>. */
-extern int ftruncate (int fd, off_t length);
+# if address@hidden@
+_GL_FUNCDECL_SYS (ftruncate, int, (int fd, off_t length));
# endif
+_GL_CXXALIAS_SYS (ftruncate, int, (int fd, off_t length));
+_GL_CXXALIASWARN (ftruncate);
#elif defined GNULIB_POSIXCHECK
# undef ftruncate
-# define ftruncate(f,l) \
- (GL_LINK_WARNING ("ftruncate is unportable - " \
- "use gnulib module ftruncate for portability"), \
- ftruncate (f, l))
+# if HAVE_RAW_DECL_FTRUNCATE
+_GL_WARN_ON_USE (ftruncate, "ftruncate is unportable - "
+ "use gnulib module ftruncate for portability");
+# endif
#endif
#if @GNULIB_GETCWD@
-/* Include the headers that might declare getcwd so that they will not
- cause confusion if included after this file. */
-# include <stdlib.h>
-# if @REPLACE_GETCWD@
/* Get the name of the current working directory, and put it in SIZE bytes
of BUF.
Return BUF if successful, or NULL if the directory couldn't be determined
@@ -360,15 +458,22 @@ extern int ftruncate (int fd, off_t length);
extension: If BUF is NULL, an array is allocated with 'malloc'; the array
is SIZE bytes long, unless SIZE == 0, in which case it is as big as
necessary. */
-# define getcwd rpl_getcwd
-extern char * getcwd (char *buf, size_t size);
+# if @REPLACE_GETCWD@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define getcwd rpl_getcwd
+# endif
+_GL_FUNCDECL_RPL (getcwd, char *, (char *buf, size_t size));
+_GL_CXXALIAS_RPL (getcwd, char *, (char *buf, size_t size));
+# else
+_GL_CXXALIAS_SYS (getcwd, char *, (char *buf, size_t size));
# endif
+_GL_CXXALIASWARN (getcwd);
#elif defined GNULIB_POSIXCHECK
# undef getcwd
-# define getcwd(b,s) \
- (GL_LINK_WARNING ("getcwd is unportable - " \
- "use gnulib module getcwd for portability"), \
- getcwd (b, s))
+# if HAVE_RAW_DECL_GETCWD
+_GL_WARN_ON_USE (getcwd, "getcwd is unportable - "
+ "use gnulib module getcwd for portability");
+# endif
#endif
@@ -384,51 +489,65 @@ extern char * getcwd (char *buf, size_t size);
If the NIS domain name is longer than LEN, set errno = EINVAL and return -1.
Return 0 if successful, otherwise set errno and return -1. */
# if address@hidden@
-extern int getdomainname(char *name, size_t len) _GL_ARG_NONNULL ((1));
+_GL_FUNCDECL_SYS (getdomainname, int, (char *name, size_t len)
+ _GL_ARG_NONNULL ((1)));
# endif
+/* Need to cast, because on MacOS X 10.5 systems, the second parameter is
+ int len. */
+_GL_CXXALIAS_SYS_CAST (getdomainname, int, (char *name, size_t len));
+_GL_CXXALIASWARN (getdomainname);
#elif defined GNULIB_POSIXCHECK
# undef getdomainname
-# define getdomainname(n,l) \
- (GL_LINK_WARNING ("getdomainname is unportable - " \
- "use gnulib module getdomainname for portability"), \
- getdomainname (n, l))
+# if HAVE_RAW_DECL_GETDOMAINNAME
+_GL_WARN_ON_USE (getdomainname, "getdomainname is unportable - "
+ "use gnulib module getdomainname for portability");
+# endif
#endif
#if @GNULIB_GETDTABLESIZE@
-# if address@hidden@
/* Return the maximum number of file descriptors in the current process.
In POSIX, this is same as sysconf (_SC_OPEN_MAX). */
-extern int getdtablesize (void);
+# if address@hidden@
+_GL_FUNCDECL_SYS (getdtablesize, int, (void));
# endif
+_GL_CXXALIAS_SYS (getdtablesize, int, (void));
+_GL_CXXALIASWARN (getdtablesize);
#elif defined GNULIB_POSIXCHECK
# undef getdtablesize
-# define getdtablesize() \
- (GL_LINK_WARNING ("getdtablesize is unportable - " \
- "use gnulib module getdtablesize for portability"), \
- getdtablesize ())
+# if HAVE_RAW_DECL_GETDTABLESIZE
+_GL_WARN_ON_USE (getdtablesize, "getdtablesize is unportable - "
+ "use gnulib module getdtablesize for portability");
+# endif
#endif
#if @GNULIB_GETGROUPS@
-# if @REPLACE_GETGROUPS@
-# undef getgroups
-# define getgroups rpl_getgroups
-# endif
-# if address@hidden@ || @REPLACE_GETGROUPS@
/* Return the supplemental groups that the current process belongs to.
It is unspecified whether the effective group id is in the list.
If N is 0, return the group count; otherwise, N describes how many
entries are available in GROUPS. Return -1 and set errno if N is
not 0 and not large enough. Fails with ENOSYS on some systems. */
-int getgroups (int n, gid_t *groups);
+# if @REPLACE_GETGROUPS@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getgroups
+# define getgroups rpl_getgroups
+# endif
+_GL_FUNCDECL_RPL (getgroups, int, (int n, gid_t *groups));
+_GL_CXXALIAS_RPL (getgroups, int, (int n, gid_t *groups));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (getgroups, int, (int n, gid_t *groups));
+# endif
+_GL_CXXALIAS_SYS (getgroups, int, (int n, gid_t *groups));
# endif
+_GL_CXXALIASWARN (getgroups);
#elif defined GNULIB_POSIXCHECK
# undef getgroups
-# define getgroups(n,g) \
- (GL_LINK_WARNING ("getgroups is unportable - " \
- "use gnulib module getgroups for portability"), \
- getgroups (n, g))
+# if HAVE_RAW_DECL_GETGROUPS
+_GL_WARN_ON_USE (getgroups, "getgroups is unportable - "
+ "use gnulib module getgroups for portability");
+# endif
#endif
@@ -441,21 +560,57 @@ int getgroups (int n, gid_t *groups);
If the host name is longer than LEN, set errno = EINVAL and return -1.
Return 0 if successful, otherwise set errno and return -1. */
# if @UNISTD_H_HAVE_WINSOCK2_H@
-# undef gethostname
-# define gethostname rpl_gethostname
-# endif
-# if @UNISTD_H_HAVE_WINSOCK2_H@ || address@hidden@
-extern int gethostname(char *name, size_t len) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef gethostname
+# define gethostname rpl_gethostname
+# endif
+_GL_FUNCDECL_RPL (gethostname, int, (char *name, size_t len)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (gethostname, int, (char *name, size_t len));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (gethostname, int, (char *name, size_t len)
+ _GL_ARG_NONNULL ((1)));
+# endif
+/* Need to cast, because on Solaris 10 systems, the second parameter is
+ int len. */
+_GL_CXXALIAS_SYS_CAST (gethostname, int, (char *name, size_t len));
# endif
+_GL_CXXALIASWARN (gethostname);
#elif @UNISTD_H_HAVE_WINSOCK2_H@
# undef gethostname
# define gethostname
gethostname_used_without_requesting_gnulib_module_gethostname
#elif defined GNULIB_POSIXCHECK
# undef gethostname
-# define gethostname(n,l) \
- (GL_LINK_WARNING ("gethostname is unportable - " \
- "use gnulib module gethostname for portability"), \
- gethostname (n, l))
+# if HAVE_RAW_DECL_GETHOSTNAME
+_GL_WARN_ON_USE (gethostname, "gethostname is unportable - "
+ "use gnulib module gethostname for portability");
+# endif
+#endif
+
+
+#if @GNULIB_GETLOGIN@
+/* Returns the user's login name, or NULL if it cannot be found. Upon error,
+ returns NULL with errno set.
+
+ See <http://www.opengroup.org/susv3xsh/getlogin.html>.
+
+ Most programs don't need to use this function, because the information is
+ available through environment variables:
+ ${LOGNAME-$USER} on Unix platforms,
+ $USERNAME on native Windows platforms.
+ */
+# if address@hidden@
+_GL_FUNCDECL_SYS (getlogin, char *, (void));
+# endif
+_GL_CXXALIAS_SYS (getlogin, char *, (void));
+_GL_CXXALIASWARN (getlogin);
+#elif defined GNULIB_POSIXCHECK
+# undef getlogin
+# if HAVE_RAW_DECL_GETLOGIN
+_GL_WARN_ON_USE (getlogin, "getlogin is unportable - "
+ "use gnulib module getlogin for portability");
+# endif
#endif
@@ -468,186 +623,272 @@ extern int gethostname(char *name, size_t len)
_GL_ARG_NONNULL ((1));
provided (this case is hopefully rare but is left open by the POSIX spec).
See <http://www.opengroup.org/susv3xsh/getlogin.html>.
+
+ Most programs don't need to use this function, because the information is
+ available through environment variables:
+ ${LOGNAME-$USER} on Unix platforms,
+ $USERNAME on native Windows platforms.
*/
# if address@hidden@
-extern int getlogin_r (char *name, size_t size) _GL_ARG_NONNULL ((1));
+_GL_FUNCDECL_SYS (getlogin_r, int, (char *name, size_t size)
+ _GL_ARG_NONNULL ((1)));
# endif
+/* Need to cast, because on Solaris 10 systems, the second argument is
+ int size. */
+_GL_CXXALIAS_SYS_CAST (getlogin_r, int, (char *name, size_t size));
+_GL_CXXALIASWARN (getlogin_r);
#elif defined GNULIB_POSIXCHECK
# undef getlogin_r
-# define getlogin_r(n,s) \
- (GL_LINK_WARNING ("getlogin_r is unportable - " \
- "use gnulib module getlogin_r for portability"), \
- getlogin_r (n, s))
+# if HAVE_RAW_DECL_GETLOGIN_R
+_GL_WARN_ON_USE (getlogin_r, "getlogin_r is unportable - "
+ "use gnulib module getlogin_r for portability");
+# endif
#endif
#if @GNULIB_GETPAGESIZE@
# if @REPLACE_GETPAGESIZE@
-# define getpagesize rpl_getpagesize
-extern int getpagesize (void);
-# elif address@hidden@
-/* This is for POSIX systems. */
-# if !defined getpagesize && defined _SC_PAGESIZE
-# if ! (defined __VMS && __VMS_VER < 70000000)
-# define getpagesize() sysconf (_SC_PAGESIZE)
-# endif
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define getpagesize rpl_getpagesize
# endif
+_GL_FUNCDECL_RPL (getpagesize, int, (void));
+_GL_CXXALIAS_RPL (getpagesize, int, (void));
+# else
+# if address@hidden@
+# if !defined getpagesize
+/* This is for POSIX systems. */
+# if !defined _gl_getpagesize && defined _SC_PAGESIZE
+# if ! (defined __VMS && __VMS_VER < 70000000)
+# define _gl_getpagesize() sysconf (_SC_PAGESIZE)
+# endif
+# endif
/* This is for older VMS. */
-# if !defined getpagesize && defined __VMS
-# ifdef __ALPHA
-# define getpagesize() 8192
-# else
-# define getpagesize() 512
-# endif
-# endif
+# if !defined _gl_getpagesize && defined __VMS
+# ifdef __ALPHA
+# define _gl_getpagesize() 8192
+# else
+# define _gl_getpagesize() 512
+# endif
+# endif
/* This is for BeOS. */
-# if !defined getpagesize && @HAVE_OS_H@
-# include <OS.h>
-# if defined B_PAGE_SIZE
-# define getpagesize() B_PAGE_SIZE
-# endif
-# endif
+# if !defined _gl_getpagesize && @HAVE_OS_H@
+# include <OS.h>
+# if defined B_PAGE_SIZE
+# define _gl_getpagesize() B_PAGE_SIZE
+# endif
+# endif
/* This is for AmigaOS4.0. */
-# if !defined getpagesize && defined __amigaos4__
-# define getpagesize() 2048
-# endif
+# if !defined _gl_getpagesize && defined __amigaos4__
+# define _gl_getpagesize() 2048
+# endif
/* This is for older Unix systems. */
-# if !defined getpagesize && @HAVE_SYS_PARAM_H@
-# include <sys/param.h>
-# ifdef EXEC_PAGESIZE
-# define getpagesize() EXEC_PAGESIZE
-# else
-# ifdef NBPG
-# ifndef CLSIZE
-# define CLSIZE 1
+# if !defined _gl_getpagesize && @HAVE_SYS_PARAM_H@
+# include <sys/param.h>
+# ifdef EXEC_PAGESIZE
+# define _gl_getpagesize() EXEC_PAGESIZE
+# else
+# ifdef NBPG
+# ifndef CLSIZE
+# define CLSIZE 1
+# endif
+# define _gl_getpagesize() (NBPG * CLSIZE)
+# else
+# ifdef NBPC
+# define _gl_getpagesize() NBPC
+# endif
+# endif
# endif
-# define getpagesize() (NBPG * CLSIZE)
+# endif
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define getpagesize() _gl_getpagesize ()
# else
-# ifdef NBPC
-# define getpagesize() NBPC
-# endif
+static inline int
+getpagesize ()
+{
+ return _gl_getpagesize ();
+}
# endif
# endif
# endif
+/* Need to cast, because on Cygwin 1.5.x systems, the return type is size_t.
*/
+_GL_CXXALIAS_SYS_CAST (getpagesize, int, (void));
# endif
+_GL_CXXALIASWARN (getpagesize);
#elif defined GNULIB_POSIXCHECK
# undef getpagesize
-# define getpagesize() \
- (GL_LINK_WARNING ("getpagesize is unportable - " \
- "use gnulib module getpagesize for portability"), \
- getpagesize ())
+# if HAVE_RAW_DECL_GETPAGESIZE
+_GL_WARN_ON_USE (getpagesize, "getpagesize is unportable - "
+ "use gnulib module getpagesize for portability");
+# endif
#endif
#if @GNULIB_GETUSERSHELL@
-# if address@hidden@
/* Return the next valid login shell on the system, or NULL when the end of
the list has been reached. */
-extern char *getusershell (void);
+# if address@hidden@
+_GL_FUNCDECL_SYS (getusershell, char *, (void));
+# endif
+_GL_CXXALIAS_SYS (getusershell, char *, (void));
+_GL_CXXALIASWARN (getusershell);
+#elif defined GNULIB_POSIXCHECK
+# undef getusershell
+# if HAVE_RAW_DECL_GETUSERSHELL
+_GL_WARN_ON_USE (getusershell, "getusershell is unportable - "
+ "use gnulib module getusershell for portability");
+# endif
+#endif
+
+#if @GNULIB_GETUSERSHELL@
/* Rewind to pointer that is advanced at each getusershell() call. */
-extern void setusershell (void);
+# if address@hidden@
+_GL_FUNCDECL_SYS (setusershell, void, (void));
+# endif
+_GL_CXXALIAS_SYS (setusershell, void, (void));
+_GL_CXXALIASWARN (setusershell);
+#elif defined GNULIB_POSIXCHECK
+# undef setusershell
+# if HAVE_RAW_DECL_SETUSERSHELL
+_GL_WARN_ON_USE (setusershell, "setusershell is unportable - "
+ "use gnulib module getusershell for portability");
+# endif
+#endif
+
+#if @GNULIB_GETUSERSHELL@
/* Free the pointer that is advanced at each getusershell() call and
associated resources. */
-extern void endusershell (void);
+# if address@hidden@
+_GL_FUNCDECL_SYS (endusershell, void, (void));
# endif
+_GL_CXXALIAS_SYS (endusershell, void, (void));
+_GL_CXXALIASWARN (endusershell);
#elif defined GNULIB_POSIXCHECK
-# undef getusershell
-# define getusershell() \
- (GL_LINK_WARNING ("getusershell is unportable - " \
- "use gnulib module getusershell for portability"), \
- getusershell ())
-# undef setusershell
-# define setusershell() \
- (GL_LINK_WARNING ("setusershell is unportable - " \
- "use gnulib module getusershell for portability"), \
- setusershell ())
# undef endusershell
-# define endusershell() \
- (GL_LINK_WARNING ("endusershell is unportable - " \
- "use gnulib module getusershell for portability"), \
- endusershell ())
+# if HAVE_RAW_DECL_ENDUSERSHELL
+_GL_WARN_ON_USE (endusershell, "endusershell is unportable - "
+ "use gnulib module getusershell for portability");
+# endif
#endif
#if @GNULIB_LCHOWN@
-# if @REPLACE_LCHOWN@
-# undef lchown
-# define lchown rpl_lchown
-# endif
-# if address@hidden@ || @REPLACE_LCHOWN@
/* Change the owner of FILE to UID (if UID is not -1) and the group of FILE
to GID (if GID is not -1). Do not follow symbolic links.
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/lchown.html>. */
-extern int lchown (char const *file, uid_t owner, gid_t group)
- _GL_ARG_NONNULL ((1));
+# if @REPLACE_LCHOWN@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef lchown
+# define lchown rpl_lchown
+# endif
+_GL_FUNCDECL_RPL (lchown, int, (char const *file, uid_t owner, gid_t group)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (lchown, int, (char const *file, uid_t owner, gid_t group));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (lchown, int, (char const *file, uid_t owner, gid_t group)
+ _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (lchown, int, (char const *file, uid_t owner, gid_t group));
# endif
+_GL_CXXALIASWARN (lchown);
#elif defined GNULIB_POSIXCHECK
# undef lchown
-# define lchown(f,u,g) \
- (GL_LINK_WARNING ("lchown is unportable to pre-POSIX.1-2001 " \
- "systems - use gnulib module lchown for portability"), \
- lchown (f, u, g))
+# if HAVE_RAW_DECL_LCHOWN
+_GL_WARN_ON_USE (lchown, "lchown is unportable to pre-POSIX.1-2001 systems - "
+ "use gnulib module lchown for portability");
+# endif
#endif
#if @GNULIB_LINK@
-# if @REPLACE_LINK@
-# define link rpl_link
-# endif
/* Create a new hard link for an existing file.
Return 0 if successful, otherwise -1 and errno set.
See POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/link.html>. */
-# if address@hidden@ || @REPLACE_LINK@
-extern int link (const char *path1, const char *path2)
- _GL_ARG_NONNULL ((1, 2));
+# if @REPLACE_LINK@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define link rpl_link
+# endif
+_GL_FUNCDECL_RPL (link, int, (const char *path1, const char *path2)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (link, int, (const char *path1, const char *path2));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (link, int, (const char *path1, const char *path2)
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (link, int, (const char *path1, const char *path2));
# endif
+_GL_CXXALIASWARN (link);
#elif defined GNULIB_POSIXCHECK
# undef link
-# define link(path1,path2) \
- (GL_LINK_WARNING ("link is unportable - " \
- "use gnulib module link for portability"), \
- link (path1, path2))
+# if HAVE_RAW_DECL_LINK
+_GL_WARN_ON_USE (link, "link is unportable - "
+ "use gnulib module link for portability");
+# endif
#endif
+
#if @GNULIB_LINKAT@
-# if @REPLACE_LINKAT@
-# undef linkat
-# define linkat rpl_linkat
-# endif
/* Create a new hard link for an existing file, relative to two
directories. FLAG controls whether symlinks are followed.
Return 0 if successful, otherwise -1 and errno set. */
-# if address@hidden@ || @REPLACE_LINKAT@
-extern int linkat (int fd1, const char *path1, int fd2, const char *path2,
+# if @REPLACE_LINKAT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef linkat
+# define linkat rpl_linkat
+# endif
+_GL_FUNCDECL_RPL (linkat, int,
+ (int fd1, const char *path1, int fd2, const char *path2,
int flag)
- _GL_ARG_NONNULL ((2, 4));
+ _GL_ARG_NONNULL ((2, 4)));
+_GL_CXXALIAS_RPL (linkat, int,
+ (int fd1, const char *path1, int fd2, const char *path2,
+ int flag));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (linkat, int,
+ (int fd1, const char *path1, int fd2, const char *path2,
+ int flag)
+ _GL_ARG_NONNULL ((2, 4)));
+# endif
+_GL_CXXALIAS_SYS (linkat, int,
+ (int fd1, const char *path1, int fd2, const char *path2,
+ int flag));
# endif
+_GL_CXXALIASWARN (linkat);
#elif defined GNULIB_POSIXCHECK
# undef linkat
-# define link(f1,path1,f2,path2,f) \
- (GL_LINK_WARNING ("linkat is unportable - " \
- "use gnulib module linkat for portability"), \
- linkat (f1, path1, f2, path2,f))
+# if HAVE_RAW_DECL_LINKAT
+_GL_WARN_ON_USE (linkat, "linkat is unportable - "
+ "use gnulib module linkat for portability");
+# endif
#endif
+
#if @GNULIB_LSEEK@
-# if @REPLACE_LSEEK@
/* Set the offset of FD relative to SEEK_SET, SEEK_CUR, or SEEK_END.
Return the new offset if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/lseek.html>. */
-# define lseek rpl_lseek
- extern off_t lseek (int fd, off_t offset, int whence);
+# if @REPLACE_LSEEK@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define lseek rpl_lseek
+# endif
+_GL_FUNCDECL_RPL (lseek, off_t, (int fd, off_t offset, int whence));
+_GL_CXXALIAS_RPL (lseek, off_t, (int fd, off_t offset, int whence));
+# else
+_GL_CXXALIAS_SYS (lseek, off_t, (int fd, off_t offset, int whence));
# endif
+_GL_CXXALIASWARN (lseek);
#elif defined GNULIB_POSIXCHECK
# undef lseek
-# define lseek(f,o,w) \
- (GL_LINK_WARNING ("lseek does not fail with ESPIPE on pipes on some " \
- "systems - use gnulib module lseek for portability"), \
- lseek (f, o, w))
+# if HAVE_RAW_DECL_LSEEK
+_GL_WARN_ON_USE (lseek, "lseek does not fail with ESPIPE on pipes on some "
+ "systems - use gnulib module lseek for portability");
+# endif
#endif
@@ -661,209 +902,294 @@ extern int linkat (int fd1, const char *path1, int fd2,
const char *path2,
See also the Linux man page at
<http://www.kernel.org/doc/man-pages/online/pages/man2/pipe2.2.html>. */
# if @HAVE_PIPE2@
-# define pipe2 rpl_pipe2
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define pipe2 rpl_pipe2
+# endif
+_GL_FUNCDECL_RPL (pipe2, int, (int fd[2], int flags) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (pipe2, int, (int fd[2], int flags));
+# else
+_GL_FUNCDECL_SYS (pipe2, int, (int fd[2], int flags) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_SYS (pipe2, int, (int fd[2], int flags));
# endif
-extern int pipe2 (int fd[2], int flags) _GL_ARG_NONNULL ((1));
+_GL_CXXALIASWARN (pipe2);
#elif defined GNULIB_POSIXCHECK
# undef pipe2
-# define pipe2(f,o) \
- (GL_LINK_WARNING ("pipe2 is unportable - " \
- "use gnulib module pipe2 for portability"), \
- pipe2 (f, o))
+# if HAVE_RAW_DECL_PIPE2
+_GL_WARN_ON_USE (pipe2, "pipe2 is unportable - "
+ "use gnulib module pipe2 for portability");
+# endif
#endif
#if @GNULIB_PREAD@
-# if @REPLACE_PREAD@
-# define pread rpl_pread
-# endif
/* Read at most BUFSIZE bytes from FD into BUF, starting at OFFSET.
Return the number of bytes placed into BUF if successful, otherwise
set errno and return -1. 0 indicates EOF. See the POSIX:2001
specification <http://www.opengroup.org/susv3xsh/pread.html>. */
-# if address@hidden@ || @REPLACE_PREAD@
- extern ssize_t pread (int fd, void *buf, size_t bufsize, off_t offset)
- _GL_ARG_NONNULL ((2));
+# if @REPLACE_PREAD@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define pread rpl_pread
+# endif
+_GL_FUNCDECL_RPL (pread, ssize_t,
+ (int fd, void *buf, size_t bufsize, off_t offset)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (pread, ssize_t,
+ (int fd, void *buf, size_t bufsize, off_t offset));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (pread, ssize_t,
+ (int fd, void *buf, size_t bufsize, off_t offset)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (pread, ssize_t,
+ (int fd, void *buf, size_t bufsize, off_t offset));
# endif
+_GL_CXXALIASWARN (pread);
#elif defined GNULIB_POSIXCHECK
# undef pread
-# define pread(f,b,s,o) \
- (GL_LINK_WARNING ("pread is unportable - " \
- "use gnulib module pread for portability"), \
- pread (f, b, s, o))
+# if HAVE_RAW_DECL_PREAD
+_GL_WARN_ON_USE (pread, "pread is unportable - "
+ "use gnulib module pread for portability");
+# endif
#endif
#if @GNULIB_READLINK@
-# if @REPLACE_READLINK@
-# define readlink rpl_readlink
-# endif
/* Read the contents of the symbolic link FILE and place the first BUFSIZE
bytes of it into BUF. Return the number of bytes placed into BUF if
successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/readlink.html>. */
-# if address@hidden@ || @REPLACE_READLINK@
-extern ssize_t readlink (const char *file, char *buf, size_t bufsize)
- _GL_ARG_NONNULL ((1, 2));
+# if @REPLACE_READLINK@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define readlink rpl_readlink
+# endif
+_GL_FUNCDECL_RPL (readlink, ssize_t,
+ (const char *file, char *buf, size_t bufsize)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (readlink, ssize_t,
+ (const char *file, char *buf, size_t bufsize));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (readlink, ssize_t,
+ (const char *file, char *buf, size_t bufsize)
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (readlink, ssize_t,
+ (const char *file, char *buf, size_t bufsize));
# endif
+_GL_CXXALIASWARN (readlink);
#elif defined GNULIB_POSIXCHECK
# undef readlink
-# define readlink(f,b,s) \
- (GL_LINK_WARNING ("readlink is unportable - " \
- "use gnulib module readlink for portability"), \
- readlink (f, b, s))
+# if HAVE_RAW_DECL_READLINK
+_GL_WARN_ON_USE (readlink, "readlink is unportable - "
+ "use gnulib module readlink for portability");
+# endif
#endif
#if @GNULIB_READLINKAT@
# if address@hidden@
-extern ssize_t readlinkat (int fd, char const *file, char *buf, size_t len)
- _GL_ARG_NONNULL ((2, 3));
+_GL_FUNCDECL_SYS (readlinkat, ssize_t,
+ (int fd, char const *file, char *buf, size_t len)
+ _GL_ARG_NONNULL ((2, 3)));
# endif
+_GL_CXXALIAS_SYS (readlinkat, ssize_t,
+ (int fd, char const *file, char *buf, size_t len));
+_GL_CXXALIASWARN (readlinkat);
#elif defined GNULIB_POSIXCHECK
# undef readlinkat
-# define readlinkat(d,n,b,l) \
- (GL_LINK_WARNING ("readlinkat is not portable - " \
- "use gnulib module symlinkat for portability"), \
- readlinkat (d, n, b, l))
+# if HAVE_RAW_DECL_READLINKAT
+_GL_WARN_ON_USE (readlinkat, "readlinkat is not portable - "
+ "use gnulib module symlinkat for portability");
+# endif
#endif
#if @GNULIB_RMDIR@
-# if @REPLACE_RMDIR@
-# define rmdir rpl_rmdir
/* Remove the directory DIR. */
-extern int rmdir (char const *name) _GL_ARG_NONNULL ((1));
+# if @REPLACE_RMDIR@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define rmdir rpl_rmdir
+# endif
+_GL_FUNCDECL_RPL (rmdir, int, (char const *name) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (rmdir, int, (char const *name));
+# else
+_GL_CXXALIAS_SYS (rmdir, int, (char const *name));
# endif
+_GL_CXXALIASWARN (rmdir);
#elif defined GNULIB_POSIXCHECK
# undef rmdir
-# define rmdir(n) \
- (GL_LINK_WARNING ("rmdir is unportable - " \
- "use gnulib module rmdir for portability"), \
- rmdir (n))
+# if HAVE_RAW_DECL_RMDIR
+_GL_WARN_ON_USE (rmdir, "rmdir is unportable - "
+ "use gnulib module rmdir for portability");
+# endif
#endif
#if @GNULIB_SLEEP@
-# if @REPLACE_SLEEP@
-# undef sleep
-# define sleep rpl_sleep
-# endif
/* Pause the execution of the current thread for N seconds.
Returns the number of seconds left to sleep.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/sleep.html>. */
-# if address@hidden@ || @REPLACE_SLEEP@
-extern unsigned int sleep (unsigned int n);
+# if @REPLACE_SLEEP@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef sleep
+# define sleep rpl_sleep
+# endif
+_GL_FUNCDECL_RPL (sleep, unsigned int, (unsigned int n));
+_GL_CXXALIAS_RPL (sleep, unsigned int, (unsigned int n));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (sleep, unsigned int, (unsigned int n));
+# endif
+_GL_CXXALIAS_SYS (sleep, unsigned int, (unsigned int n));
# endif
+_GL_CXXALIASWARN (sleep);
#elif defined GNULIB_POSIXCHECK
# undef sleep
-# define sleep(n) \
- (GL_LINK_WARNING ("sleep is unportable - " \
- "use gnulib module sleep for portability"), \
- sleep (n))
+# if HAVE_RAW_DECL_SLEEP
+_GL_WARN_ON_USE (sleep, "sleep is unportable - "
+ "use gnulib module sleep for portability");
+# endif
#endif
#if @GNULIB_SYMLINK@
# if @REPLACE_SYMLINK@
-# undef symlink
-# define symlink rpl_symlink
-# endif
-# if address@hidden@ || @REPLACE_SYMLINK@
-extern int symlink (char const *contents, char const *file)
- _GL_ARG_NONNULL ((1, 2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef symlink
+# define symlink rpl_symlink
+# endif
+_GL_FUNCDECL_RPL (symlink, int, (char const *contents, char const *file)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (symlink, int, (char const *contents, char const *file));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (symlink, int, (char const *contents, char const *file)
+ _GL_ARG_NONNULL ((1, 2)));
+# endif
+_GL_CXXALIAS_SYS (symlink, int, (char const *contents, char const *file));
# endif
+_GL_CXXALIASWARN (symlink);
#elif defined GNULIB_POSIXCHECK
# undef symlink
-# define symlink(c,n) \
- (GL_LINK_WARNING ("symlink is not portable - " \
- "use gnulib module symlink for portability"), \
- symlink (c, n))
+# if HAVE_RAW_DECL_SYMLINK
+_GL_WARN_ON_USE (symlink, "symlink is not portable - "
+ "use gnulib module symlink for portability");
+# endif
#endif
#if @GNULIB_SYMLINKAT@
# if address@hidden@
-extern int symlinkat (char const *contents, int fd, char const *file)
- _GL_ARG_NONNULL ((1, 3));
+_GL_FUNCDECL_SYS (symlinkat, int,
+ (char const *contents, int fd, char const *file)
+ _GL_ARG_NONNULL ((1, 3)));
# endif
+_GL_CXXALIAS_SYS (symlinkat, int,
+ (char const *contents, int fd, char const *file));
+_GL_CXXALIASWARN (symlinkat);
#elif defined GNULIB_POSIXCHECK
# undef symlinkat
-# define symlinkat(c,d,n) \
- (GL_LINK_WARNING ("symlinkat is not portable - " \
- "use gnulib module symlinkat for portability"), \
- symlinkat (c, d, n))
+# if HAVE_RAW_DECL_SYMLINKAT
+_GL_WARN_ON_USE (symlinkat, "symlinkat is not portable - "
+ "use gnulib module symlinkat for portability");
+# endif
#endif
#if @GNULIB_UNLINK@
# if @REPLACE_UNLINK@
-# undef unlink
-# define unlink rpl_unlink
-extern int unlink (char const *file) _GL_ARG_NONNULL ((1));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef unlink
+# define unlink rpl_unlink
+# endif
+_GL_FUNCDECL_RPL (unlink, int, (char const *file) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (unlink, int, (char const *file));
+# else
+_GL_CXXALIAS_SYS (unlink, int, (char const *file));
# endif
+_GL_CXXALIASWARN (unlink);
#elif defined GNULIB_POSIXCHECK
# undef unlink
-# define unlink(n) \
- (GL_LINK_WARNING ("unlink is not portable - " \
- "use gnulib module unlink for portability"), \
- unlink (n))
+# if HAVE_RAW_DECL_UNLINK
+_GL_WARN_ON_USE (unlink, "unlink is not portable - "
+ "use gnulib module unlink for portability");
+# endif
#endif
#if @GNULIB_UNLINKAT@
# if @REPLACE_UNLINKAT@
-# undef unlinkat
-# define unlinkat rpl_unlinkat
-# endif
-# if address@hidden@ || @REPLACE_UNLINKAT@
-extern int unlinkat (int fd, char const *file, int flag) _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef unlinkat
+# define unlinkat rpl_unlinkat
+# endif
+_GL_FUNCDECL_RPL (unlinkat, int, (int fd, char const *file, int flag)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (unlinkat, int, (int fd, char const *file, int flag));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (unlinkat, int, (int fd, char const *file, int flag)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (unlinkat, int, (int fd, char const *file, int flag));
# endif
+_GL_CXXALIASWARN (unlinkat);
#elif defined GNULIB_POSIXCHECK
# undef unlinkat
-# define unlinkat(d,n,f) \
- (GL_LINK_WARNING ("unlinkat is not portable - " \
- "use gnulib module openat for portability"), \
- unlinkat (d, n, f))
+# if HAVE_RAW_DECL_UNLINKAT
+_GL_WARN_ON_USE (unlinkat, "unlinkat is not portable - "
+ "use gnulib module openat for portability");
+# endif
#endif
#if @GNULIB_USLEEP@
-# if @REPLACE_USLEEP@
-# undef usleep
-# define usleep rpl_usleep
-# endif
-# if address@hidden@ || @REPLACE_USLEEP@
/* Pause the execution of the current thread for N microseconds.
Returns 0 on completion, or -1 on range error.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/sleep.html>. */
-extern int usleep (useconds_t n);
+# if @REPLACE_USLEEP@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef usleep
+# define usleep rpl_usleep
+# endif
+_GL_FUNCDECL_RPL (usleep, int, (useconds_t n));
+_GL_CXXALIAS_RPL (usleep, int, (useconds_t n));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (usleep, int, (useconds_t n));
+# endif
+_GL_CXXALIAS_SYS (usleep, int, (useconds_t n));
# endif
+_GL_CXXALIASWARN (usleep);
#elif defined GNULIB_POSIXCHECK
# undef usleep
-# define usleep(n) \
- (GL_LINK_WARNING ("usleep is unportable - " \
- "use gnulib module usleep for portability"), \
- usleep (n))
+# if HAVE_RAW_DECL_USLEEP
+_GL_WARN_ON_USE (usleep, "usleep is unportable - "
+ "use gnulib module usleep for portability");
+# endif
#endif
-#if @GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@
+#if @GNULIB_WRITE@
/* Write up to COUNT bytes starting at BUF to file descriptor FD.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/write.html>. */
-# undef write
-# define write rpl_write
-extern ssize_t write (int fd, const void *buf, size_t count)
- _GL_ARG_NONNULL ((2));
-#endif
-
-
-#ifdef __cplusplus
-}
+# if @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef write
+# define write rpl_write
+# endif
+_GL_FUNCDECL_RPL (write, ssize_t, (int fd, const void *buf, size_t count)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (write, ssize_t, (int fd, const void *buf, size_t count));
+# else
+_GL_CXXALIAS_SYS (write, ssize_t, (int fd, const void *buf, size_t count));
+# endif
+_GL_CXXALIASWARN (write);
#endif
diff --git a/lib/unistr.h b/lib/unistr.h
index 35cd2da..26a3e33 100644
--- a/lib/unistr.h
+++ b/lib/unistr.h
@@ -1,5 +1,5 @@
/* Elementary Unicode string functions.
- Copyright (C) 2001-2002, 2005-2009 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2005-2010 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
@@ -19,6 +19,9 @@
#include "unitypes.h"
+/* Get common macros for C. */
+#include "unused-parameter.h"
+
/* Get bool. */
#include <stdbool.h>
@@ -183,7 +186,8 @@ extern int
u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n);
# else
static inline int
-u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n _UNUSED_PARAMETER_)
+u32_mbtouc_unsafe (ucs4_t *puc,
+ const uint32_t *s, size_t n _GL_UNUSED_PARAMETER)
{
uint32_t c = *s;
@@ -253,7 +257,7 @@ extern int
u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n);
# else
static inline int
-u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n _UNUSED_PARAMETER_)
+u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n _GL_UNUSED_PARAMETER)
{
uint32_t c = *s;
@@ -525,8 +529,8 @@ extern uint16_t *
extern uint32_t *
u32_strncpy (uint32_t *dest, const uint32_t *src, size_t n);
-/* Copy no more than N units of SRC to DEST, returning the address of
- the last unit written into DEST. */
+/* Copy no more than N units of SRC to DEST. Return a pointer past the last
+ non-NUL unit written into DEST. */
/* Similar to stpncpy(). */
extern uint8_t *
u8_stpncpy (uint8_t *dest, const uint8_t *src, size_t n);
diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c
index e0d20d9..c997589 100644
--- a/lib/unistr/u8-mbtouc-aux.c
+++ b/lib/unistr/u8-mbtouc-aux.c
@@ -1,5 +1,5 @@
/* Conversion UTF-8 to UCS-4.
- Copyright (C) 2001-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2001.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c
b/lib/unistr/u8-mbtouc-unsafe-aux.c
index 5318863..47590e3 100644
--- a/lib/unistr/u8-mbtouc-unsafe-aux.c
+++ b/lib/unistr/u8-mbtouc-unsafe-aux.c
@@ -1,5 +1,5 @@
/* Conversion UTF-8 to UCS-4.
- Copyright (C) 2001-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2001.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c
index 0772c0b..41583f9 100644
--- a/lib/unistr/u8-mbtouc-unsafe.c
+++ b/lib/unistr/u8-mbtouc-unsafe.c
@@ -1,5 +1,5 @@
/* Look at first character in UTF-8 string.
- Copyright (C) 1999-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2001.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c
index 2c29279..96cd5b7 100644
--- a/lib/unistr/u8-mbtouc.c
+++ b/lib/unistr/u8-mbtouc.c
@@ -1,5 +1,5 @@
/* Look at first character in UTF-8 string.
- Copyright (C) 1999-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2001.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c
index c93ec88..a749c48 100644
--- a/lib/unistr/u8-mbtoucr.c
+++ b/lib/unistr/u8-mbtoucr.c
@@ -1,5 +1,5 @@
/* Look at first character in UTF-8 string, returning an error code.
- Copyright (C) 1999-2002, 2006-2007 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2001.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c
index e97884e..97a27f5 100644
--- a/lib/unistr/u8-prev.c
+++ b/lib/unistr/u8-prev.c
@@ -1,5 +1,5 @@
/* Iterate over previous character in UTF-8 string.
- Copyright (C) 2002, 2006-2007 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2002.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c
index 5a6b6b5..695921d 100644
--- a/lib/unistr/u8-uctomb-aux.c
+++ b/lib/unistr/u8-uctomb-aux.c
@@ -1,5 +1,5 @@
/* Conversion UCS-4 to UTF-8.
- Copyright (C) 2002, 2006-2007 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006-2007, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2002.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c
index 81e41ad..fd33c05 100644
--- a/lib/unistr/u8-uctomb.c
+++ b/lib/unistr/u8-uctomb.c
@@ -1,5 +1,5 @@
/* Store a character in UTF-8 string.
- Copyright (C) 2002, 2005-2006, 2009 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2005-2006, 2009-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2002.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/unitypes.h b/lib/unitypes.h
index fe8d877..3e524f8 100644
--- a/lib/unitypes.h
+++ b/lib/unitypes.h
@@ -1,5 +1,5 @@
/* Elementary types for the GNU UniString library.
- Copyright (C) 2002, 2005-2006 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2005-2006, 2009-2010 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
diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c
index e218500..3d7955b 100644
--- a/lib/vasnprintf.c
+++ b/lib/vasnprintf.c
@@ -1,5 +1,5 @@
/* vsprintf with automatic memory allocation.
- Copyright (C) 1999, 2002-2009 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002-2010 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
@@ -2367,7 +2367,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
{
/* Use only as many wide characters as needed to produce
at most PRECISION bytes, from the left. */
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
# endif
@@ -2381,7 +2381,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
if (*arg_end == 0)
/* Found the terminating null wide character. */
break;
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
count = wcrtomb (cbuf, *arg_end, &state);
# else
count = wctomb (cbuf, *arg_end);
@@ -2412,7 +2412,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
{
/* Use the entire string, and count the number of
bytes. */
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
# endif
@@ -2426,7 +2426,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
if (*arg_end == 0)
/* Found the terminating null wide character. */
break;
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
count = wcrtomb (cbuf, *arg_end, &state);
# else
count = wctomb (cbuf, *arg_end);
@@ -2464,7 +2464,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
{
TCHAR_T *tmpptr = tmpsrc;
size_t remaining;
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
# endif
@@ -2475,7 +2475,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
if (*arg == 0)
abort ();
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
count = wcrtomb (cbuf, *arg, &state);
# else
count = wctomb (cbuf, *arg);
@@ -2545,7 +2545,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
{
/* We know the number of bytes in advance. */
size_t remaining;
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
# endif
@@ -2557,7 +2557,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
if (*arg == 0)
abort ();
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
count = wcrtomb (cbuf, *arg, &state);
# else
count = wctomb (cbuf, *arg);
@@ -2575,7 +2575,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
}
else
{
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
mbstate_t state;
memset (&state, '\0', sizeof (mbstate_t));
# endif
@@ -2586,7 +2586,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
if (*arg == 0)
abort ();
-# if HAVE_WCRTOMB
+# if HAVE_WCRTOMB && !defined GNULIB_defined_mbstate_t
count = wcrtomb (cbuf, *arg, &state);
# else
count = wctomb (cbuf, *arg);
diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h
index 5ceab44..b55faf5 100644
--- a/lib/vasnprintf.h
+++ b/lib/vasnprintf.h
@@ -1,5 +1,5 @@
/* vsprintf with automatic memory allocation.
- Copyright (C) 2002-2004, 2007-2008 Free Software Foundation, Inc.
+ Copyright (C) 2002-2004, 2007-2010 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
@@ -25,15 +25,14 @@
#include <stddef.h>
#ifndef __attribute__
-/* This feature is available in gcc versions 2.5 and later. */
-# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5)
-# define __attribute__(Spec) /* empty */
-# endif
-/* The __-protected variants of `format' and `printf' attributes
- are accepted by gcc versions 2.6.4 (effectively 2.7) and later. */
+/* The __attribute__ feature is available in gcc versions 2.5 and later.
+ The __-protected variants of the attributes 'format' and 'printf' are
+ accepted by gcc versions 2.6.4 (effectively 2.7) and later.
+ We enable __attribute__ only if these are supported too, because
+ gnulib and libintl do '#define printf __printf__' when they override
+ the 'printf' function. */
# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 7)
-# define __format__ format
-# define __printf__ printf
+# define __attribute__(Spec) /* empty */
# endif
#endif
diff --git a/lib/verify.h b/lib/verify.h
index 152a9fa..7773c79 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -1,6 +1,6 @@
/* Compile-time assert-like macros.
- Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2009-2010 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
diff --git a/lib/version-etc-fsf.c b/lib/version-etc-fsf.c
index efbb37e..926a696 100644
--- a/lib/version-etc-fsf.c
+++ b/lib/version-etc-fsf.c
@@ -1,5 +1,5 @@
/* Variable with FSF copyright information, for version-etc.
- Copyright (C) 1999-2006 Free Software Foundation, Inc.
+ Copyright (C) 1999-2006, 2009-2010 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
diff --git a/lib/version-etc.c b/lib/version-etc.c
index 35f3626..2648c9a 100644
--- a/lib/version-etc.c
+++ b/lib/version-etc.c
@@ -1,5 +1,5 @@
/* Print --version and bug-reporting information in a consistent format.
- Copyright (C) 1999-2009 Free Software Foundation, Inc.
+ Copyright (C) 1999-2010 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
@@ -38,7 +38,7 @@
# define PACKAGE PACKAGE_TARNAME
#endif
-enum { COPYRIGHT_YEAR = 2009 };
+enum { COPYRIGHT_YEAR = 2010 };
/* The three functions below display the --version information the
standard way.
diff --git a/lib/version-etc.h b/lib/version-etc.h
index b01d7ca..1cbbe32 100644
--- a/lib/version-etc.h
+++ b/lib/version-etc.h
@@ -1,5 +1,5 @@
/* Print --version and bug-reporting information in a consistent format.
- Copyright (C) 1999, 2003, 2005, 2009 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2003, 2005, 2009-2010 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
diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c
index c5ddd8e..35eba15 100644
--- a/lib/vsnprintf.c
+++ b/lib/vsnprintf.c
@@ -1,5 +1,5 @@
/* Formatted output to strings.
- Copyright (C) 2004, 2006-2008 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2006-2010 Free Software Foundation, Inc.
Written by Simon Josefsson and Yoann Vandoorselaere <address@hidden>.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/wchar.in.h b/lib/wchar.in.h
index b0cf255..28bfa06 100644
--- a/lib/wchar.in.h
+++ b/lib/wchar.in.h
@@ -1,6 +1,6 @@
/* A substitute for ISO C99 <wchar.h>, for platforms that have issues.
- Copyright (C) 2007-2009 Free Software Foundation, Inc.
+ Copyright (C) 2007-2010 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -30,9 +30,9 @@
@PRAGMA_SYSTEM_HEADER@
#endif
-#if defined __need_mbstate_t || (defined __hpux && ((defined
_INTTYPES_INCLUDED && !defined strtoimax) || defined
_GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H
+#if defined __need_mbstate_t || defined __need_wint_t || (defined __hpux &&
((defined _INTTYPES_INCLUDED && !defined strtoimax) || defined
_GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H
/* Special invocation convention:
- - Inside uClibc header files.
+ - Inside glibc and uClibc header files.
- On HP-UX 11.00 we have a sequence of nested includes
<wchar.h> -> <stdlib.h> -> <stdint.h>, and the latter includes <wchar.h>,
once indirectly <stdint.h> -> <sys/types.h> -> <inttypes.h> -> <wchar.h>
@@ -55,10 +55,13 @@
/* Tru64 with Desktop Toolkit C has a bug: <stdio.h> must be included before
<wchar.h>.
BSD/OS 4.0.1 has a bug: <stddef.h>, <stdio.h> and <time.h> must be
- included before <wchar.h>. */
-#include <stddef.h>
-#include <stdio.h>
-#include <time.h>
+ included before <wchar.h>.
+ But avoid namespace pollution on glibc systems. */
+#ifndef __GLIBC__
+# include <stddef.h>
+# include <stdio.h>
+# include <time.h>
+#endif
/* Include the original <wchar.h> if it exists.
Some builds of uClibc lack it. */
@@ -72,13 +75,11 @@
#ifndef _GL_WCHAR_H
#define _GL_WCHAR_H
-/* The definition of GL_LINK_WARNING is copied here. */
+/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
-#ifdef __cplusplus
-extern "C" {
-#endif
+/* The definition of _GL_WARN_ON_USE is copied here. */
/* Define wint_t. (Also done in wctype.in.h.) */
@@ -104,213 +105,320 @@ typedef int rpl_mbstate_t;
/* Convert a single-byte character to a wide character. */
#if @GNULIB_BTOWC@
# if @REPLACE_BTOWC@
-# undef btowc
-# define btowc rpl_btowc
-# endif
-# if address@hidden@ || @REPLACE_BTOWC@
-extern wint_t btowc (int c);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef btowc
+# define btowc rpl_btowc
+# endif
+_GL_FUNCDECL_RPL (btowc, wint_t, (int c));
+_GL_CXXALIAS_RPL (btowc, wint_t, (int c));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (btowc, wint_t, (int c));
+# endif
+_GL_CXXALIAS_SYS (btowc, wint_t, (int c));
# endif
+_GL_CXXALIASWARN (btowc);
#elif defined GNULIB_POSIXCHECK
# undef btowc
-# define btowc(c) \
- (GL_LINK_WARNING ("btowc is unportable - " \
- "use gnulib module btowc for portability"), \
- btowc (c))
+# if HAVE_RAW_DECL_BTOWC
+_GL_WARN_ON_USE (btowc, "btowc is unportable - "
+ "use gnulib module btowc for portability");
+# endif
#endif
/* Convert a wide character to a single-byte character. */
#if @GNULIB_WCTOB@
# if @REPLACE_WCTOB@
-# undef wctob
-# define wctob rpl_wctob
-# endif
-# if (!defined wctob && address@hidden@) || @REPLACE_WCTOB@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef wctob
+# define wctob rpl_wctob
+# endif
+_GL_FUNCDECL_RPL (wctob, int, (wint_t wc));
+_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. */
-extern int wctob (wint_t wc);
+_GL_FUNCDECL_SYS (wctob, int, (wint_t wc));
+# endif
+_GL_CXXALIAS_SYS (wctob, int, (wint_t wc));
# endif
+_GL_CXXALIASWARN (wctob);
#elif defined GNULIB_POSIXCHECK
# undef wctob
-# define wctob(w) \
- (GL_LINK_WARNING ("wctob is unportable - " \
- "use gnulib module wctob for portability"), \
- wctob (w))
+# if HAVE_RAW_DECL_WCTOB
+_GL_WARN_ON_USE (wctob, "wctob is unportable - "
+ "use gnulib module wctob for portability");
+# endif
#endif
/* Test whether *PS is in the initial state. */
#if @GNULIB_MBSINIT@
# if @REPLACE_MBSINIT@
-# undef mbsinit
-# define mbsinit rpl_mbsinit
-# endif
-# if address@hidden@ || @REPLACE_MBSINIT@
-extern int mbsinit (const mbstate_t *ps);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mbsinit
+# define mbsinit rpl_mbsinit
+# endif
+_GL_FUNCDECL_RPL (mbsinit, int, (const mbstate_t *ps));
+_GL_CXXALIAS_RPL (mbsinit, int, (const mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mbsinit, int, (const mbstate_t *ps));
+# endif
+_GL_CXXALIAS_SYS (mbsinit, int, (const mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (mbsinit);
#elif defined GNULIB_POSIXCHECK
# undef mbsinit
-# define mbsinit(p) \
- (GL_LINK_WARNING ("mbsinit is unportable - " \
- "use gnulib module mbsinit for portability"), \
- mbsinit (p))
+# if HAVE_RAW_DECL_MBSINIT
+_GL_WARN_ON_USE (mbsinit, "mbsinit is unportable - "
+ "use gnulib module mbsinit for portability");
+# endif
#endif
/* Convert a multibyte character to a wide character. */
#if @GNULIB_MBRTOWC@
# if @REPLACE_MBRTOWC@
-# undef mbrtowc
-# define mbrtowc rpl_mbrtowc
-# endif
-# if address@hidden@ || @REPLACE_MBRTOWC@
-extern size_t mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mbrtowc
+# define mbrtowc rpl_mbrtowc
+# endif
+_GL_FUNCDECL_RPL (mbrtowc, size_t,
+ (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps));
+_GL_CXXALIAS_RPL (mbrtowc, size_t,
+ (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mbrtowc, size_t,
+ (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps));
+# endif
+_GL_CXXALIAS_SYS (mbrtowc, size_t,
+ (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (mbrtowc);
#elif defined GNULIB_POSIXCHECK
# undef mbrtowc
-# define mbrtowc(w,s,n,p) \
- (GL_LINK_WARNING ("mbrtowc is unportable - " \
- "use gnulib module mbrtowc for portability"), \
- mbrtowc (w, s, n, p))
+# if HAVE_RAW_DECL_MBRTOWC
+_GL_WARN_ON_USE (mbrtowc, "mbrtowc is unportable - "
+ "use gnulib module mbrtowc for portability");
+# endif
#endif
/* Recognize a multibyte character. */
#if @GNULIB_MBRLEN@
# if @REPLACE_MBRLEN@
-# undef mbrlen
-# define mbrlen rpl_mbrlen
-# endif
-# if address@hidden@ || @REPLACE_MBRLEN@
-extern size_t mbrlen (const char *s, size_t n, mbstate_t *ps);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mbrlen
+# define mbrlen rpl_mbrlen
+# endif
+_GL_FUNCDECL_RPL (mbrlen, size_t, (const char *s, size_t n, mbstate_t *ps));
+_GL_CXXALIAS_RPL (mbrlen, size_t, (const char *s, size_t n, mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mbrlen, size_t, (const char *s, size_t n, mbstate_t *ps));
+# endif
+_GL_CXXALIAS_SYS (mbrlen, size_t, (const char *s, size_t n, mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (mbrlen);
#elif defined GNULIB_POSIXCHECK
# undef mbrlen
-# define mbrlen(s,n,p) \
- (GL_LINK_WARNING ("mbrlen is unportable - " \
- "use gnulib module mbrlen for portability"), \
- mbrlen (s, n, p))
+# if HAVE_RAW_DECL_MBRLEN
+_GL_WARN_ON_USE (mbrlen, "mbrlen is unportable - "
+ "use gnulib module mbrlen for portability");
+# endif
#endif
/* Convert a string to a wide string. */
#if @GNULIB_MBSRTOWCS@
# if @REPLACE_MBSRTOWCS@
-# undef mbsrtowcs
-# define mbsrtowcs rpl_mbsrtowcs
-# endif
-# if address@hidden@ || @REPLACE_MBSRTOWCS@
-extern size_t mbsrtowcs (wchar_t *dest, const char **srcp, size_t len,
mbstate_t *ps)
- _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mbsrtowcs
+# define mbsrtowcs rpl_mbsrtowcs
+# endif
+_GL_FUNCDECL_RPL (mbsrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t len, mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (mbsrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t len,
+ mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mbsrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t len, mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (mbsrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t len,
+ mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (mbsrtowcs);
#elif defined GNULIB_POSIXCHECK
# undef mbsrtowcs
-# define mbsrtowcs(d,s,l,p) \
- (GL_LINK_WARNING ("mbsrtowcs is unportable - " \
- "use gnulib module mbsrtowcs for portability"), \
- mbsrtowcs (d, s, l, p))
+# if HAVE_RAW_DECL_MBSRTOWCS
+_GL_WARN_ON_USE (mbsrtowcs, "mbsrtowcs is unportable - "
+ "use gnulib module mbsrtowcs for portability");
+# endif
#endif
/* Convert a string to a wide string. */
#if @GNULIB_MBSNRTOWCS@
# if @REPLACE_MBSNRTOWCS@
-# undef mbsnrtowcs
-# define mbsnrtowcs rpl_mbsnrtowcs
-# endif
-# if address@hidden@ || @REPLACE_MBSNRTOWCS@
-extern size_t mbsnrtowcs (wchar_t *dest, const char **srcp, size_t srclen,
size_t len, mbstate_t *ps)
- _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mbsnrtowcs
+# define mbsnrtowcs rpl_mbsnrtowcs
+# endif
+_GL_FUNCDECL_RPL (mbsnrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t srclen, size_t len,
+ mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (mbsnrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t srclen, size_t len,
+ mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (mbsnrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t srclen, size_t len,
+ mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (mbsnrtowcs, size_t,
+ (wchar_t *dest, const char **srcp, size_t srclen, size_t len,
+ mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (mbsnrtowcs);
#elif defined GNULIB_POSIXCHECK
# undef mbsnrtowcs
-# define mbsnrtowcs(d,s,n,l,p) \
- (GL_LINK_WARNING ("mbsnrtowcs is unportable - " \
- "use gnulib module mbsnrtowcs for portability"), \
- mbsnrtowcs (d, s, n, l, p))
+# if HAVE_RAW_DECL_MBSNRTOWCS
+_GL_WARN_ON_USE (mbsnrtowcs, "mbsnrtowcs is unportable - "
+ "use gnulib module mbsnrtowcs for portability");
+# endif
#endif
/* Convert a wide character to a multibyte character. */
#if @GNULIB_WCRTOMB@
# if @REPLACE_WCRTOMB@
-# undef wcrtomb
-# define wcrtomb rpl_wcrtomb
-# endif
-# if address@hidden@ || @REPLACE_WCRTOMB@
-extern size_t wcrtomb (char *s, wchar_t wc, mbstate_t *ps);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef wcrtomb
+# define wcrtomb rpl_wcrtomb
+# endif
+_GL_FUNCDECL_RPL (wcrtomb, size_t, (char *s, wchar_t wc, mbstate_t *ps));
+_GL_CXXALIAS_RPL (wcrtomb, size_t, (char *s, wchar_t wc, mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (wcrtomb, size_t, (char *s, wchar_t wc, mbstate_t *ps));
+# endif
+_GL_CXXALIAS_SYS (wcrtomb, size_t, (char *s, wchar_t wc, mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (wcrtomb);
#elif defined GNULIB_POSIXCHECK
# undef wcrtomb
-# define wcrtomb(s,w,p) \
- (GL_LINK_WARNING ("wcrtomb is unportable - " \
- "use gnulib module wcrtomb for portability"), \
- wcrtomb (s, w, p))
+# if HAVE_RAW_DECL_WCRTOMB
+_GL_WARN_ON_USE (wcrtomb, "wcrtomb is unportable - "
+ "use gnulib module wcrtomb for portability");
+# endif
#endif
/* Convert a wide string to a string. */
#if @GNULIB_WCSRTOMBS@
# if @REPLACE_WCSRTOMBS@
-# undef wcsrtombs
-# define wcsrtombs rpl_wcsrtombs
-# endif
-# if address@hidden@ || @REPLACE_WCSRTOMBS@
-extern size_t wcsrtombs (char *dest, const wchar_t **srcp, size_t len,
mbstate_t *ps)
- _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef wcsrtombs
+# define wcsrtombs rpl_wcsrtombs
+# endif
+_GL_FUNCDECL_RPL (wcsrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t len, mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (wcsrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t len,
+ mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (wcsrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t len, mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (wcsrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t len,
+ mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (wcsrtombs);
#elif defined GNULIB_POSIXCHECK
# undef wcsrtombs
-# define wcsrtombs(d,s,l,p) \
- (GL_LINK_WARNING ("wcsrtombs is unportable - " \
- "use gnulib module wcsrtombs for portability"), \
- wcsrtombs (d, s, l, p))
+# if HAVE_RAW_DECL_WCSRTOMBS
+_GL_WARN_ON_USE (wcsrtombs, "wcsrtombs is unportable - "
+ "use gnulib module wcsrtombs for portability");
+# endif
#endif
/* Convert a wide string to a string. */
#if @GNULIB_WCSNRTOMBS@
# if @REPLACE_WCSNRTOMBS@
-# undef wcsnrtombs
-# define wcsnrtombs rpl_wcsnrtombs
-# endif
-# if address@hidden@ || @REPLACE_WCSNRTOMBS@
-extern size_t wcsnrtombs (char *dest, const wchar_t **srcp, size_t srclen,
size_t len, mbstate_t *ps)
- _GL_ARG_NONNULL ((2));
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef wcsnrtombs
+# define wcsnrtombs rpl_wcsnrtombs
+# endif
+_GL_FUNCDECL_RPL (wcsnrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t srclen, size_t len,
+ mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (wcsnrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t srclen, size_t len,
+ mbstate_t *ps));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (wcsnrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t srclen, size_t len,
+ mbstate_t *ps)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (wcsnrtombs, size_t,
+ (char *dest, const wchar_t **srcp, size_t srclen, size_t len,
+ mbstate_t *ps));
# endif
+_GL_CXXALIASWARN (wcsnrtombs);
#elif defined GNULIB_POSIXCHECK
# undef wcsnrtombs
-# define wcsnrtombs(d,s,n,l,p) \
- (GL_LINK_WARNING ("wcsnrtombs is unportable - " \
- "use gnulib module wcsnrtombs for portability"), \
- wcsnrtombs (d, s, n, l, p))
+# if HAVE_RAW_DECL_WCSNRTOMBS
+_GL_WARN_ON_USE (wcsnrtombs, "wcsnrtombs is unportable - "
+ "use gnulib module wcsnrtombs for portability");
+# endif
#endif
/* Return the number of screen columns needed for WC. */
#if @GNULIB_WCWIDTH@
# if @REPLACE_WCWIDTH@
-# undef wcwidth
-# define wcwidth rpl_wcwidth
-extern int wcwidth (wchar_t);
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef wcwidth
+# define wcwidth rpl_wcwidth
+# endif
+_GL_FUNCDECL_RPL (wcwidth, int, (wchar_t));
+_GL_CXXALIAS_RPL (wcwidth, int, (wchar_t));
# else
# if !defined wcwidth && address@hidden@
/* wcwidth exists but is not declared. */
-extern int wcwidth (int /* actually wchar_t */);
+_GL_FUNCDECL_SYS (wcwidth, int, (wchar_t));
# endif
+_GL_CXXALIAS_SYS (wcwidth, int, (wchar_t));
# endif
+_GL_CXXALIASWARN (wcwidth);
#elif defined GNULIB_POSIXCHECK
# undef wcwidth
-# define wcwidth(w) \
- (GL_LINK_WARNING ("wcwidth is unportable - " \
- "use gnulib module wcwidth for portability"), \
- wcwidth (w))
+# if HAVE_RAW_DECL_WCWIDTH
+_GL_WARN_ON_USE (wcwidth, "wcwidth is unportable - "
+ "use gnulib module wcwidth for portability");
+# endif
#endif
-#ifdef __cplusplus
-}
-#endif
-
#endif /* _GL_WCHAR_H */
#endif /* _GL_WCHAR_H */
#endif
diff --git a/lib/write.c b/lib/write.c
index a99bf5b..8e64659 100644
--- a/lib/write.c
+++ b/lib/write.c
@@ -1,5 +1,5 @@
/* POSIX compatible write() function.
- Copyright (C) 2008-2009 Free Software Foundation, Inc.
+ Copyright (C) 2008-2010 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/xsize.h b/lib/xsize.h
index 0b30045..3382280 100644
--- a/lib/xsize.h
+++ b/lib/xsize.h
@@ -1,6 +1,6 @@
/* xsize.h -- Checked size_t computations.
- Copyright (C) 2003, 2008 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2008, 2009, 2010 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
diff --git a/libguile.h b/libguile.h
index 7a8b633..6f1b3f8 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 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008,
2009, 2010 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
@@ -50,6 +50,7 @@ extern "C" {
#include "libguile/feature.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
+#include "libguile/foreign.h"
#include "libguile/fports.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 3e93a98..a841c9f 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 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
2008, 2009, 2010 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -33,7 +33,7 @@ DEFAULT_INCLUDES =
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \
- -I$(top_srcdir)/lib -I$(top_builddir)/lib
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib $(LIBFFI_CFLAGS)
AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
@@ -43,7 +43,7 @@ gnulib_library = $(top_builddir)/lib/libgnu.la
ETAGS_ARGS =
--regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/'
\
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
-lib_LTLIBRARIES = libguile.la
+lib_LTLIBRARIES = address@hidden@.la
bin_PROGRAMS = guile
noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig
@@ -99,12 +99,12 @@ guile_filter_doc_snarfage$(EXEEXT):
$(guile_filter_doc_snarfage_OBJECTS) $(guile
guile_SOURCES = guile.c
guile_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
-guile_LDADD = libguile.la
+guile_LDADD = address@hidden@.la
guile_LDFLAGS = $(GUILE_CFLAGS)
-libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
address@hidden@_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
-libguile_la_SOURCES = \
address@hidden@_la_SOURCES = \
alist.c \
arbiters.c \
array-handle.c \
@@ -116,6 +116,7 @@ libguile_la_SOURCES = \
bitvectors.c \
bytevectors.c \
chars.c \
+ control.c \
continuations.c \
debug.c \
deprecated.c \
@@ -129,6 +130,7 @@ libguile_la_SOURCES = \
extensions.c \
feature.c \
fluids.c \
+ foreign.c \
fports.c \
frames.c \
gc-malloc.c \
@@ -149,7 +151,6 @@ libguile_la_SOURCES = \
instructions.c \
ioext.c \
keywords.c \
- lang.c \
list.c \
load.c \
macros.c \
@@ -216,6 +217,7 @@ DOT_X_FILES = \
bitvectors.x \
bytevectors.x \
chars.x \
+ control.x \
continuations.x \
debug.x \
deprecated.x \
@@ -230,6 +232,7 @@ DOT_X_FILES = \
extensions.x \
feature.x \
fluids.x \
+ foreign.x \
fports.x \
gc-malloc.x \
gc.x \
@@ -246,7 +249,6 @@ DOT_X_FILES = \
init.x \
ioext.x \
keywords.x \
- lang.x \
list.x \
load.x \
macros.x \
@@ -314,6 +316,7 @@ DOT_DOC_FILES = \
bitvectors.doc \
bytevectors.doc \
chars.doc \
+ control.doc \
continuations.doc \
debug.doc \
deprecated.doc \
@@ -328,6 +331,7 @@ DOT_DOC_FILES = \
extensions.doc \
feature.doc \
fluids.doc \
+ foreign.doc \
fports.doc \
gc-malloc.doc \
gc.doc \
@@ -344,7 +348,6 @@ DOT_DOC_FILES = \
init.doc \
ioext.doc \
keywords.doc \
- lang.doc \
list.doc \
load.doc \
macros.doc \
@@ -406,7 +409,7 @@ BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c
libpath.h \
version.h scmconfig.h \
$(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
-EXTRA_libguile_la_SOURCES = _scm.h \
address@hidden@_la_SOURCES = _scm.h \
memmove.c strerror.c \
dynl.c regex-posix.c \
filesys.c posix.c net_db.c socket.c \
@@ -426,7 +429,6 @@ install-exec-hook:
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
ieee-754.h \
- srfi-4.i.c \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
@@ -435,19 +437,20 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c
\
# vm instructions
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
-libguile_la_DEPENDENCIES = @LIBLOBJS@
-libguile_la_LIBADD = \
address@hidden@_la_DEPENDENCIES = @LIBLOBJS@
address@hidden@_la_LIBADD = \
@LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) \
- $(LTLIBUNISTRING) $(LTLIBICONV)
-libguile_la_LDFLAGS = \
- @LTLIBINTL@ $(INET_NTOP_LIB) $(INET_PTON_LIB)
\
+ $(LTLIBUNISTRING) $(LTLIBICONV) $(LTLIBINTL)
address@hidden@_la_LDFLAGS =
\
+ @LTLIBINTL@ $(LIBFFI_LIBS) $(INET_NTOP_LIB) $(INET_PTON_LIB)
\
+ $(GETADDRINFO_LIB) $(HOSTENT_LIB) $(SERVENT_LIB)
\
-version-info
@LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@
\
- -export-dynamic -no-undefined
\
+ -export-dynamic -no-undefined
\
$(GNU_LD_FLAGS)
if HAVE_LD_VERSION_SCRIPT
-libguile_la_LDFLAGS += -Wl,--version-script="$(srcdir)/libguile.map"
address@hidden@_la_LDFLAGS += -Wl,--version-script="$(srcdir)/libguile.map"
endif HAVE_LD_VERSION_SCRIPT
@@ -456,7 +459,7 @@ endif HAVE_LD_VERSION_SCRIPT
pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>.
-modincludedir = $(includedir)/libguile
+modincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)/libguile
modinclude_HEADERS = \
__scm.h \
alist.h \
@@ -471,6 +474,7 @@ modinclude_HEADERS = \
bitvectors.h \
bytevectors.h \
chars.h \
+ control.h \
continuations.h \
debug-malloc.h \
debug.h \
@@ -487,6 +491,7 @@ modinclude_HEADERS = \
feature.h \
filesys.h \
fluids.h \
+ foreign.h \
fports.h \
frames.h \
gc.h \
@@ -508,7 +513,6 @@ modinclude_HEADERS = \
ioext.h \
iselect.h \
keywords.h \
- lang.h \
list.h \
load.h \
macros.h \
@@ -566,7 +570,6 @@ modinclude_HEADERS = \
values.h \
variable.h \
vectors.h \
- vm-bootstrap.h \
vm-engine.h \
vm-expand.h \
vm.h \
@@ -593,11 +596,12 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads
\
## We use @-...-@ as the substitution brackets here, instead of the
## usual @...@, so autoconf doesn't go and substitute the values
## directly into the left-hand sides of the sed substitutions. *sigh*
-version.h: version.h.in
+version.h: version.h.in $(top_builddir)/config.status
sed < $(srcdir)/version.h.in > address@hidden \
-e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \
-e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \
- -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}:
+ -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}: \
+ -e s:@-GUILE_EFFECTIVE_VERSION-@:${GUILE_EFFECTIVE_VERSION}:
mv address@hidden $@
## FIXME: Consider using timestamp file, to avoid unnecessary rebuilds.
diff --git a/libguile/_scm.h b/libguile/_scm.h
index b5c818c..a1884ca 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -3,7 +3,7 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
-/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009, 2010 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
@@ -79,6 +79,8 @@
#include "libguile/boolean.h" /* Everyone wonders about the truth. */
#include "libguile/threads.h" /* You are not alone. */
#include "libguile/snarf.h" /* Everyone snarfs. */
+#include "libguile/foreign.h" /* Snarfing needs the foreign data structures.
*/
+#include "libguile/programs.h" /* ... and program.h. */
#include "libguile/variable.h"
#include "libguile/modules.h"
#include "libguile/inline.h"
@@ -176,7 +178,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION M
+#define SCM_OBJCODE_MINOR_VERSION P
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/alist.c b/libguile/alist.c
index 919bd22..fd2ccde 100644
--- a/libguile/alist.c
+++ b/libguile/alist.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008, 2010 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
@@ -25,7 +25,6 @@
#include "libguile/_scm.h"
#include "libguile/eq.h"
#include "libguile/list.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/pairs.h"
diff --git a/libguile/array-map.c b/libguile/array-map.c
index c673b4d..dd88136 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010 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
@@ -812,123 +812,63 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!",
2, 0, 0,
static int
-raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
+array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
+ size_t dim, unsigned long posx, unsigned long posy)
{
- unsigned long i0 = 0, i1 = 0;
- long inc0 = 1, inc1 = 1;
- unsigned long n;
- ra1 = SCM_CAR (ra1);
- if (SCM_I_ARRAYP(ra0))
- {
- n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- i0 = SCM_I_ARRAY_BASE (ra0);
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- }
+ if (dim == scm_array_handle_rank (hx))
+ return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
+ scm_array_handle_ref (hy, posy)));
else
- n = scm_c_generalized_vector_length (ra0);
-
- if (SCM_I_ARRAYP (ra1))
{
- i1 = SCM_I_ARRAY_BASE (ra1);
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- }
+ long incx, incy;
+ size_t i;
- if (scm_is_generalized_vector (ra0))
- {
- for (; n--; i0 += inc0, i1 += inc1)
- {
- if (scm_is_false (as_equal))
- {
- if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1,
i1))))
- return 0;
- }
- else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1,
i1))))
- return 0;
- }
+ if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
+ || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
+ return 0;
+
+ i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
+
+ incx = hx->dims[dim].inc;
+ incy = hy->dims[dim].inc;
+ posx += (i - 1) * incx;
+ posy += (i - 1) * incy;
+
+ for (; i > 0; i--, posx -= incx, posy -= incy)
+ if (!array_compare (hx, hy, dim + 1, posx, posy))
+ return 0;
return 1;
}
- else
- return 0;
}
-
-
-static int
-raeql (SCM ra0, SCM as_equal, SCM ra1)
+SCM
+scm_array_equal_p (SCM x, SCM y)
{
- SCM v0 = ra0, v1 = ra1;
- scm_t_array_dim dim0, dim1;
- scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
- unsigned long bas0 = 0, bas1 = 0;
- int k, unroll = 1, vlen = 1, ndim = 1;
- if (SCM_I_ARRAYP (ra0))
- {
- ndim = SCM_I_ARRAY_NDIM (ra0);
- s0 = SCM_I_ARRAY_DIMS (ra0);
- bas0 = SCM_I_ARRAY_BASE (ra0);
- v0 = SCM_I_ARRAY_V (ra0);
- }
- else
- {
- s0->inc = 1;
- s0->lbnd = 0;
- s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
- unroll = 0;
- }
- if (SCM_I_ARRAYP (ra1))
- {
- if (ndim != SCM_I_ARRAY_NDIM (ra1))
- return 0;
- s1 = SCM_I_ARRAY_DIMS (ra1);
- bas1 = SCM_I_ARRAY_BASE (ra1);
- v1 = SCM_I_ARRAY_V (ra1);
- }
- else
- {
- /*
- Huh ? Schizophrenic return type. --hwn
- */
- if (1 != ndim)
- return 0;
- s1->inc = 1;
- s1->lbnd = 0;
- s1->ubnd = scm_c_generalized_vector_length (v1) - 1;
- unroll = 0;
- }
- if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
- return 0;
- for (k = ndim; k--;)
- {
- if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
- return 0;
- if (unroll)
- {
- unroll = (s0[k].inc == s1[k].inc);
- vlen *= s0[k].ubnd - s1[k].lbnd + 1;
- }
- }
- if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
- return 1;
- return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
-}
+ scm_t_array_handle hx, hy;
+ SCM res;
+
+ scm_array_get_handle (x, &hx);
+ scm_array_get_handle (y, &hy);
+
+ res = scm_from_bool (hx.ndims == hy.ndims
+ && hx.element_type == hy.element_type);
+ if (scm_is_true (res))
+ res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
-SCM
-scm_raequal (SCM ra0, SCM ra1)
-{
- return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
+ scm_array_handle_release (&hy);
+ scm_array_handle_release (&hx);
+
+ return res;
}
+static SCM scm_i_array_equal_p (SCM, SCM, SCM);
SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
(SCM ra0, SCM ra1, SCM rest),
"Return @code{#t} iff all arguments are arrays with the same\n"
"shape, the same type, and have corresponding elements which are\n"
"either @code{equal?} or @code{array-equal?}. This function\n"
- "differs from @code{equal?} in that a one dimensional shared\n"
- "array may be @var{array-equal?} but not @var{equal?} to a\n"
- "vector or uniform vector.")
+ "differs from @code{equal?} in that all arguments must be arrays.")
#define FUNC_NAME s_scm_i_array_equal_p
{
if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
@@ -946,19 +886,10 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
#undef FUNC_NAME
-SCM
-scm_array_equal_p (SCM ra0, SCM ra1)
-{
- if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
- return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
- return scm_equal_p (ra0, ra1);
-}
-
-
void
scm_init_array_map (void)
{
- scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
+ scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_array_equal_p;
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
}
diff --git a/libguile/array-map.h b/libguile/array-map.h
index a198099..471861b 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -3,7 +3,7 @@
#ifndef SCM_ARRAY_MAP_H
#define SCM_ARRAY_MAP_H
-/* Copyright (C) 1995,1996,1997,2000, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,2000, 2006, 2008, 2009, 2010 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,7 +46,6 @@ SCM_API int scm_array_identity (SCM src, SCM dst);
SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
-SCM_API SCM scm_raequal (SCM ra0, SCM ra1);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 39d1067..89f5e9d 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010 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
@@ -260,6 +260,41 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds,
const void *bytes,
}
#undef FUNC_NAME
+SCM
+scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
+#define FUNC_NAME "scm_from_contiguous_array"
+{
+ size_t k, rlen = 1;
+ scm_t_array_dim *s;
+ SCM ra;
+ scm_t_array_handle h;
+
+ ra = scm_i_shap2ra (bounds);
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
+
+ while (k--)
+ {
+ s[k].inc = rlen;
+ SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+ rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+ }
+ if (rlen != len)
+ SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
+
+ SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
+ scm_array_get_handle (ra, &h);
+ memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
+ scm_array_handle_release (&h);
+
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ return SCM_I_ARRAY_V (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
@@ -570,150 +605,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
#undef FUNC_NAME
-SCM
-scm_ra2contig (SCM ra, int copy)
-{
- SCM ret;
- long inc = 1;
- size_t k, len = 1;
- for (k = SCM_I_ARRAY_NDIM (ra); k--;)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_I_ARRAY_NDIM (ra);
- if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k -
1].inc)))
- {
- if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- return ra;
- if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
- 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
- 0 == len % SCM_LONG_BIT))
- return ra;
- }
- ret = scm_i_make_array (k);
- SCM_I_ARRAY_BASE (ret) = 0;
- while (k--)
- {
- SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
- SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- }
- SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra),
- scm_from_long (inc),
- SCM_UNDEFINED);
- if (copy)
- scm_array_copy_x (ra, ret);
- return ret;
-}
-
-
-
-SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes]
[start] [end]\n"
- "Attempt to read all elements of @var{ura}, in lexicographic order,
as\n"
- "binary objects from @var{port-or-fdes}.\n"
- "If an end of file is encountered,\n"
- "the objects up to that point are put into @var{ura}\n"
- "(starting at the beginning) and the remainder of the array is\n"
- "unchanged.\n\n"
- "The optional arguments @var{start} and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "@code{uniform-array-read!} returns the number of objects read.\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults to
the value\n"
- "returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_array_read_x
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 0);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- if (!scm_is_eq (cra, ura))
- scm_array_copy_x (cra, ura);
- return ans;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "Writes all elements of @var{ura} as binary objects to\n"
- "@var{port-or-fdes}.\n\n"
- "The optional arguments @var{start}\n"
- "and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be
written.\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_array_write
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_write (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 1);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- return ans;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-
static void
list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
{
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 325bb9c..a5ce577 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -3,7 +3,7 @@
#ifndef SCM_ARRAY_H
#define SCM_ARRAY_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010
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
@@ -36,6 +36,8 @@
/** Arrays */
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
+SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts,
+ size_t len);
SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
const void *bytes,
@@ -46,15 +48,9 @@ SCM_API SCM scm_shared_array_increments (SCM ra);
SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict);
-SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
- SCM start, SCM end);
-SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
-SCM_API SCM scm_ra2contig (SCM ra, int copy);
-
/* internal. */
typedef struct scm_i_t_array
diff --git a/libguile/async.c b/libguile/async.c
index ddb2a21..e448dc1 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009,
2010 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
@@ -30,7 +30,6 @@
#include "libguile/throw.h"
#include "libguile/root.h"
#include "libguile/smob.h"
-#include "libguile/lang.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index f8b259f..bfd8d97 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -1,5 +1,5 @@
/* Printing of backtraces and error messages
- * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free
Software Foundation
+ * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010
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
@@ -45,7 +45,6 @@
#include "libguile/frames.h"
#include "libguile/validate.h"
-#include "libguile/lang.h"
#include "libguile/backtrace.h"
#include "libguile/filesys.h"
#include "libguile/private-options.h"
diff --git a/libguile/boolean.c b/libguile/boolean.c
index d7091bb..452b8ad 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009, 2010 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
@@ -26,7 +26,6 @@
#include "libguile/validate.h"
#include "libguile/boolean.h"
-#include "libguile/lang.h"
#include "libguile/tags.h"
#include "verify.h"
@@ -49,35 +48,34 @@ verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION
\
(SCM_ELISP_NIL, SCM_EOL));
verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
(SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, \
- SCM_XXX_ANOTHER_BOOLEAN_DONT_USE));
+ SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0));
verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
(SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, \
SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE));
SCM_DEFINE (scm_not, "not", 1, 0, 0,
(SCM x),
- "Return @code{#t} iff @var{x} is @code{#f}, else return
@code{#f}.")
+ "Return @code{#t} iff @var{x} is false, else return @code{#f}.")
#define FUNC_NAME s_scm_not
{
- return scm_from_bool (scm_is_false_or_nil (x));
+ return scm_from_bool (scm_is_false (x));
}
#undef FUNC_NAME
SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.")
+ "Return @code{#t} iff @var{obj} is @code{#t} or false.")
#define FUNC_NAME s_scm_boolean_p
{
- return scm_from_bool (scm_is_bool_or_nil (obj));
+ return scm_from_bool (scm_is_bool (obj));
}
#undef FUNC_NAME
int
scm_to_bool (SCM x)
{
- /* XXX Should this first test use scm_is_false_or_nil instead? */
- if (scm_is_eq (x, SCM_BOOL_F))
+ if (scm_is_false (x))
return 0;
else if (scm_is_eq (x, SCM_BOOL_T))
return 1;
@@ -85,6 +83,18 @@ scm_to_bool (SCM x)
scm_wrong_type_arg (NULL, 0, x);
}
+/* We keep this primitive as a function in addition to the same-named macro
+ because some applications (e.g., GNU LilyPond 2.13.9) expect it to be a
+ function. */
+#undef scm_is_bool
+int
+scm_is_bool (SCM obj)
+{
+ /* This must match the macro definition of `scm_is_bool ()'. */
+ return scm_is_bool_or_nil (obj);
+}
+
+
void
scm_init_boolean ()
{
diff --git a/libguile/boolean.h b/libguile/boolean.h
index 4c97a49..7084fdf 100644
--- a/libguile/boolean.h
+++ b/libguile/boolean.h
@@ -3,7 +3,7 @@
#ifndef SCM_BOOLEAN_H
#define SCM_BOOLEAN_H
-/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009 Free Software Foundation,
Inc.
+/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009, 2010 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 +27,21 @@
-/* Boolean Values
+/* Boolean Values. Obviously there are #t and #f, but there is also nil to deal
+ * with. We choose to treat nil as a false boolean. All options might silently
+ * break existing code, but this one seems most responsible.
*
*/
/*
* Use these macros if it's important (for correctness)
- * that %nil MUST be considered true
+ * that #nil MUST be considered true
*/
#define scm_is_false_and_not_nil(x) (scm_is_eq ((x), SCM_BOOL_F))
#define scm_is_true_or_nil(x) (!scm_is_eq ((x), SCM_BOOL_F))
/*
- * Use these macros if %nil will never be tested,
+ * Use these macros if #nil will never be tested,
* for increased efficiency.
*/
#define scm_is_false_assume_not_nil(x) (scm_is_eq ((x), SCM_BOOL_F))
@@ -50,16 +52,13 @@
* SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
* how the following macro works.
*/
-#if SCM_ENABLE_ELISP
-# define scm_is_false_or_nil(x) \
+#define scm_is_false_or_nil(x) \
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_BOOL_F))
-#else
-# define scm_is_false_or_nil(x) (scm_is_false_assume_not_nil (x))
-#endif
#define scm_is_true_and_not_nil(x) (!scm_is_false_or_nil (x))
-/* XXX Should these macros treat %nil as false by default? */
-#define scm_is_false(x) (scm_is_false_and_not_nil (x))
+/*
+#nil is false. */
+#define scm_is_false(x) (scm_is_false_or_nil (x))
#define scm_is_true(x) (!scm_is_false (x))
/*
@@ -75,21 +74,17 @@
*
* If SCM_ENABLE_ELISP is true, then scm_is_bool_or_nil(x)
* returns 1 if and only if x is one of the following: SCM_BOOL_F,
- * SCM_BOOL_T, SCM_ELISP_NIL, or SCM_XXX_ANOTHER_BOOLEAN_DONT_USE.
+ * SCM_BOOL_T, SCM_ELISP_NIL, or SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0.
* Otherwise, it returns 0.
*/
-#if SCM_ENABLE_ELISP
-# define scm_is_bool_or_nil(x) \
+#define scm_is_bool_or_nil(x) \
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_T, SCM_ELISP_NIL))
-#else
-# define scm_is_bool_or_nil(x) (scm_is_bool_and_not_nil (x))
-#endif
-
#define scm_is_bool_and_not_nil(x) \
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_F, SCM_BOOL_T))
-/* XXX Should scm_is_bool treat %nil as a boolean? */
-#define scm_is_bool(x) (scm_is_bool_and_not_nil (x))
+SCM_API int scm_is_bool (SCM);
+
+#define scm_is_bool(x) (scm_is_bool_or_nil (x))
#define scm_from_bool(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F)
SCM_API int scm_to_bool (SCM x);
@@ -114,11 +109,8 @@ SCM_API int scm_to_bool (SCM x);
* following: SCM_BOOL_F, SCM_ELISP_NIL, SCM_EOL or
* SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE. Otherwise, it returns 0.
*/
-#if SCM_ENABLE_ELISP
-# define scm_is_lisp_false(x) \
+#define scm_is_lisp_false(x) \
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_F, SCM_EOL))
-# define scm_is_lisp_true(x) (!scm_is_lisp_false(x))
-#endif
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index ac5bc16..853a3cf 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010 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
@@ -275,6 +275,13 @@ scm_c_make_bytevector (size_t len)
return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
+/* Return a new bytevector of size LEN elements. */
+SCM
+scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
+{
+ return make_bytevector (len, element_type);
+}
+
/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
SCM
@@ -283,6 +290,13 @@ scm_c_take_bytevector (signed char *contents, size_t len)
return make_bytevector_from_buffer (len, contents,
SCM_ARRAY_ELEMENT_TYPE_VU8);
}
+SCM
+scm_c_take_typed_bytevector (signed char *contents, size_t len,
+ scm_t_array_element_type element_type)
+{
+ return make_bytevector_from_buffer (len, contents, element_type);
+}
+
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
size) and return the new bytevector (possibly different from BV). */
SCM
@@ -497,7 +511,8 @@ SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
- if (c_len1 == c_len2)
+ if (c_len1 == c_len2 && (SCM_BYTEVECTOR_ELEMENT_TYPE (bv1)
+ == SCM_BYTEVECTOR_ELEMENT_TYPE (bv2)))
{
signed char *c_bv1, *c_bv2;
@@ -2081,7 +2096,7 @@ bytevector_ref_c32 (SCM bv, SCM idx)
{ /* FIXME add some checks */
const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
- return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
+ return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
}
static SCM
@@ -2089,7 +2104,7 @@ bytevector_ref_c64 (SCM bv, SCM idx)
{ /* FIXME add some checks */
const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
- return scm_c_make_rectangular (contents[i/16], contents[i/16 + 1]);
+ return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
}
typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
@@ -2126,23 +2141,22 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
return ref_fn (h->array, byte_index);
}
+/* FIXME add checks!!! */
static SCM
bytevector_set_c32 (SCM bv, SCM idx, SCM val)
-{ /* checks are unnecessary here */
- float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
+{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
- contents[i/8] = scm_c_real_part (val);
- contents[i/8 + 1] = scm_c_imag_part (val);
+ contents[i/4] = scm_c_real_part (val);
+ contents[i/4 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
static SCM
bytevector_set_c64 (SCM bv, SCM idx, SCM val)
-{ /* checks are unnecessary here */
- double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
+{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
size_t i = scm_to_size_t (idx);
- contents[i/16] = scm_c_real_part (val);
- contents[i/16 + 1] = scm_c_imag_part (val);
+ contents[i/8] = scm_c_real_part (val);
+ contents[i/8 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
@@ -2210,7 +2224,8 @@ scm_bootstrap_bytevectors (void)
scm_i_native_endianness = scm_from_locale_symbol ("little");
#endif
- scm_c_register_extension ("libguile", "scm_init_bytevectors",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_bytevectors",
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 59db89e..431b7dd 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -130,6 +130,10 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
+SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t,
scm_t_array_element_type);
+SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t,
+ scm_t_array_element_type);
+
SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex
index 938a5d2..dc72257 100644
--- a/libguile/c-tokenize.lex
+++ b/libguile/c-tokenize.lex
@@ -24,20 +24,6 @@ INTQUAL (l|L|ll|LL|lL|Ll|u|U)
an error for that. */
#define YY_NO_INPUT
-int yylex(void);
-
-int yyget_lineno (void);
-FILE *yyget_in (void);
-FILE *yyget_out (void);
-int yyget_leng (void);
-char *yyget_text (void);
-void yyset_lineno (int line_number);
-void yyset_in (FILE * in_str);
-void yyset_out (FILE * out_str);
-int yyget_debug (void);
-void yyset_debug (int bdebug);
-int yylex_destroy (void);
-
int filter_snarfage = 0;
int print = 1;
diff --git a/libguile/chars.c b/libguile/chars.c
index 68e6dc1..fcc43f3 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009, 2010
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
@@ -25,6 +25,7 @@
#include <ctype.h>
#include <limits.h>
#include <unicase.h>
+#include <unictype.h>
#include "libguile/_scm.h"
#include "libguile/validate.h"
@@ -43,6 +44,7 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
}
#undef FUNC_NAME
+static SCM scm_i_char_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is equal to
the\n"
@@ -73,6 +75,7 @@ SCM scm_char_eq_p (SCM x, SCM y)
#undef FUNC_NAME
+static SCM scm_i_char_less_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the code point of @var{x} is less than the
code\n"
@@ -102,6 +105,7 @@ SCM scm_char_less_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_leq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is less
than or\n"
@@ -131,6 +135,7 @@ SCM scm_char_leq_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_gr_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
@@ -160,6 +165,7 @@ SCM scm_char_gr_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_geq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
@@ -196,6 +202,7 @@ SCM scm_char_geq_p (SCM x, SCM y)
implementation would be to use that table and make a char-foldcase
function. */
+static SCM scm_i_char_ci_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the case-folded Unicode code point of @var{x}
is\n"
@@ -225,6 +232,7 @@ SCM scm_char_ci_eq_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_less_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the case-folded Unicode code point of @var{x}
is\n"
@@ -254,6 +262,7 @@ SCM scm_char_ci_less_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_leq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the case-folded Unicodd code point of
@var{x} is\n"
@@ -284,6 +293,7 @@ SCM scm_char_ci_leq_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_gr_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the case-folded code point of @var{x} is
greater\n"
@@ -313,6 +323,7 @@ SCM scm_char_ci_gr_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_geq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the case-folded Unicode code point of
@var{x} is\n"
@@ -391,7 +402,6 @@ SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1,
0, 0,
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is either uppercase or lowercase,
else\n"
@@ -458,6 +468,35 @@ SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_char_titlecase, "char-titlecase", 1, 0, 0,
+ (SCM chr),
+ "Return the titlecase character version of @var{chr}.")
+#define FUNC_NAME s_scm_char_titlecase
+{
+ SCM_VALIDATE_CHAR (1, chr);
+ return SCM_MAKE_CHAR (scm_c_titlecase (SCM_CHAR(chr)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_general_category, "char-general-category", 1, 0, 0,
+ (SCM chr),
+ "Return a symbol representing the Unicode general category of "
+ "@var{chr} or @code{#f} if a named category cannot be found.")
+#define FUNC_NAME s_scm_char_general_category
+{
+ const char *sym;
+ uc_general_category_t cat;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ cat = uc_general_category (SCM_CHAR (chr));
+ sym = uc_general_category_name (cat);
+
+ if (sym != NULL)
+ return scm_from_locale_symbol (sym);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
@@ -480,6 +519,12 @@ scm_c_downcase (scm_t_wchar c)
return uc_tolower ((int) c);
}
+scm_t_wchar
+scm_c_titlecase (scm_t_wchar c)
+{
+ return uc_totitle ((int) c);
+}
+
/* There are a few sets of character names: R5RS, Guile
@@ -491,11 +536,24 @@ static const char *const scm_r5rs_charnames[] = {
};
static const scm_t_uint32 const scm_r5rs_charnums[] = {
- 0x20, 0x0A
+ 0x20, 0x0a
};
#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *))
+static const char *const scm_r6rs_charnames[] = {
+ "nul", "alarm", "backspace", "tab", "linefeed", "vtab", "page",
+ "return", "esc", "delete"
+ /* 'space' and 'newline' are already included from the R5RS list. */
+};
+
+static const scm_t_uint32 const scm_r6rs_charnums[] = {
+ 0x00, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c,
+ 0x0d, 0x1b, 0x7f
+};
+
+#define SCM_N_R6RS_CHARNAMES (sizeof (scm_r6rs_charnames) / sizeof (char *))
+
/* The abbreviated names for control characters. */
static const char *const scm_C0_control_charnames[] = {
/* C0 controls */
@@ -517,11 +575,11 @@ static const scm_t_uint32 const scm_C0_control_charnums[]
= {
#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof
(char *))
static const char *const scm_alt_charnames[] = {
- "null", "backspace", "tab", "nl", "newline", "np", "page", "return",
+ "null", "nl", "np"
};
static const scm_t_uint32 const scm_alt_charnums[] = {
- 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
+ 0x00, 0x0a, 0x0c
};
#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *))
@@ -538,13 +596,19 @@ scm_i_charname (SCM chr)
if (scm_r5rs_charnums[c] == i)
return scm_r5rs_charnames[c];
+ for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++)
+ if (scm_r6rs_charnums[c] == i)
+ return scm_r6rs_charnames[c];
+
for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if (scm_C0_control_charnums[c] == i)
return scm_C0_control_charnames[c];
+ /* Since the characters in scm_alt_charnums is a subset of
+ scm_C0_control_charnums, this code is never reached. */
for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
if (scm_alt_charnums[c] == i)
- return scm_alt_charnames[i];
+ return scm_alt_charnames[c];
return NULL;
}
@@ -555,14 +619,21 @@ scm_i_charname_to_char (const char *charname, size_t
charname_len)
{
size_t c;
- /* The R5RS charnames. These are supposed to be case
- insensitive. */
+ /* The R5RS charnames. These are supposed to be case insensitive. */
for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
if ((strlen (scm_r5rs_charnames[c]) == charname_len)
&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
- /* Then come the controls. These are not case sensitive. */
+ /* The R6RS charnames. R6RS says that these should be case-sensitive. They
+ are left as case-insensitive to avoid confusion. */
+ for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++)
+ if ((strlen (scm_r6rs_charnames[c]) == charname_len)
+ && (!strncasecmp (scm_r6rs_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_r6rs_charnums[c]);
+
+ /* Then come the controls. By Guile convention, these are not case
+ sensitive. */
for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if ((strlen (scm_C0_control_charnames[c]) == charname_len)
&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
diff --git a/libguile/chars.h b/libguile/chars.h
index 04eb9f0..488dd25 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -80,8 +80,11 @@ SCM_API SCM scm_char_to_integer (SCM chr);
SCM_API SCM scm_integer_to_char (SCM n);
SCM_API SCM scm_char_upcase (SCM chr);
SCM_API SCM scm_char_downcase (SCM chr);
+SCM_API SCM scm_char_titlecase (SCM chr);
+SCM_API SCM scm_char_general_category (SCM chr);
SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c);
SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c);
+SCM_API scm_t_wchar scm_c_titlecase (scm_t_wchar c);
SCM_INTERNAL const char *scm_i_charname (SCM chr);
SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname,
size_t charname_len);
diff --git a/libguile/continuations.c b/libguile/continuations.c
index aeff62e..e662261 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,19 +34,141 @@
#include "libguile/smob.h"
#include "libguile/ports.h"
#include "libguile/dynwind.h"
-#include "libguile/values.h"
#include "libguile/eval.h"
#include "libguile/vm.h"
+#include "libguile/instructions.h"
#include "libguile/validate.h"
#include "libguile/continuations.h"
-/* {Continuations}
+static scm_t_bits tc16_continuation;
+#define SCM_CONTREGSP(x) SCM_TYP16_PREDICATE (tc16_continuation, x)
+
+#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
+
+#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
+#define SCM_SET_CONTINUATION_LENGTH(x, n)\
+ (SCM_CONTREGS (x)->num_stack_items = (n))
+#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
+#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
+#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
+#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
+
+
+
+/* scm_i_make_continuation will return a procedure whose objcode contains an
+ instruction to reinstate the continuation. Here, as in gsubr.c and smob.c,
we
+ define the form of that trampoline function.
*/
-scm_t_bits scm_tc16_continuation;
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
+#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
+#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+#define ROUND_UP(len,align) (((len-1)|(align-1))+1)
+#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
+
+#ifdef SCM_ALIGNED
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static const type sym[]
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
+static SCM_ALIGNED (alignment) const type sym[]
+#else
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static type *sym
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
+SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
+ sym = ALIGN_PTR (type, sym, alignment); \
+ memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
+static type *sym = NULL; \
+static const type sym##__unaligned[]
+#endif
+
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+#define SCM_STATIC_OBJCODE(sym) \
+ SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
+ SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
+ { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
+ { SCM_BOOL_F, SCM_PACK (0) } \
+ }; \
+ static const SCM sym = SCM_PACK (sym##__cells); \
+ SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
+
+
+SCM_STATIC_OBJCODE (cont_objcode) = {
+ /* This code is the same as in gsubr.c, except we use continuation_call
+ instead of subr_call. */
+ OBJCODE_HEADER (8, 19),
+ /* leave args on the stack */
+ /* 0 */ scm_op_object_ref, 0, /* push scm_t_contregs smob */
+ /* 2 */ scm_op_continuation_call, /* and longjmp (whee) */
+ /* 3 */ scm_op_nop, /* pad to 8 bytes */
+ /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,
+ /* 8 */
+
+ /* We could put some meta-info to say that this proc is a continuation. Not
sure
+ how to do that, though. */
+ META_HEADER (19),
+ /* 0 */ scm_op_make_eol, /* bindings */
+ /* 1 */ scm_op_make_eol, /* sources */
+ /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip
3 */
+ /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
+ /* 7 */ scm_op_make_int8_0, /* 0 optionals */
+ /* 8 */ scm_op_make_true, /* and a rest arg */
+ /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
+ /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
+ /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
+ /* 18 */ scm_op_return /* and return */
+ /* 19 */
+};
+
+
+SCM_STATIC_OBJCODE (call_cc_objcode) = {
+ /* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
+ call/cc. */
+ OBJCODE_HEADER (8, 17),
+ /* 0 */ scm_op_assert_nargs_ee, 0, 1, /* assert that nargs==1 */
+ /* 3 */ scm_op_local_ref, 0, /* push the proc */
+ /* 5 */ scm_op_tail_call_cc, /* and call/cc */
+ /* 6 */ scm_op_nop, scm_op_nop, /* pad to 8 bytes */
+ /* 8 */
+
+ META_HEADER (17),
+ /* 0 */ scm_op_make_eol, /* bindings */
+ /* 1 */ scm_op_make_eol, /* sources */
+ /* 2 */ scm_op_make_int8, 3, scm_op_make_int8, 6, /* arity: from ip 0 to ip
6 */
+ /* 6 */ scm_op_make_int8_1, /* the arity is 0 required args */
+ /* 7 */ scm_op_list, 0, 3, /* make a list of those 5 vals */
+ /* 10 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
+ /* 13 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
+ /* 16 */ scm_op_return /* and return */
+ /* 17 */
+};
+
+
+static SCM
+make_continuation_trampoline (SCM contregs)
+{
+ SCM ret = scm_make_program (cont_objcode,
+ scm_c_make_vector (1, contregs),
+ SCM_BOOL_F);
+ SCM_SET_CELL_WORD_0 (ret,
+ SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
+
+ return ret;
+}
+
+
+/* {Continuations}
+ */
static int
@@ -63,11 +185,11 @@ continuation_print (SCM obj, SCM port, scm_print_state
*state SCM_UNUSED)
}
/* this may return more than once: the first time with the escape
- procedure, then subsequently with the value to be passed to the
- continuation. */
-#define FUNC_NAME "scm_make_continuation"
+ procedure, then subsequently with SCM_UNDEFINED (the vals already having
been
+ placed on the VM stack). */
+#define FUNC_NAME "scm_i_make_continuation"
SCM
-scm_make_continuation (int *first)
+scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM cont;
@@ -82,7 +204,6 @@ scm_make_continuation (int *first)
"continuation");
continuation->num_stack_items = stack_size;
continuation->dynenv = scm_i_dynwinds ();
- continuation->throw_value = SCM_EOL;
continuation->root = thread->continuation_root;
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
@@ -90,9 +211,10 @@ scm_make_continuation (int *first)
#endif
continuation->offset = continuation->stack - src;
memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
- continuation->vm_conts = scm_vm_capture_continuations ();
+ continuation->vm = vm;
+ continuation->vm_cont = vm_cont;
- SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
+ SCM_NEWSMOB (cont, tc16_continuation, continuation);
*first = !SCM_I_SETJMP (continuation->jmpbuf);
if (*first)
@@ -110,18 +232,62 @@ scm_make_continuation (int *first)
(void *) thread->register_backing_store_base,
continuation->backing_store_size);
#endif /* __ia64__ */
- return cont;
+ return make_continuation_trampoline (cont);
}
else
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+ static SCM call_cc = SCM_BOOL_F;
+
+ if (scm_is_false (call_cc))
+ call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);
+
+ return scm_call_1 (call_cc, proc);
+}
+
+SCM
+scm_i_continuation_to_frame (SCM continuation)
+{
+ SCM contregs;
+ scm_t_contregs *cont;
+
+ contregs = scm_c_vector_ref (scm_program_objects (continuation), 0);
+ cont = SCM_CONTREGS (contregs);
+
+ if (scm_is_true (cont->vm_cont))
{
- SCM ret = continuation->throw_value;
- continuation->throw_value = SCM_BOOL_F;
- return ret;
+ struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
+ return scm_c_make_frame (cont->vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ra,
+ data->reloc);
}
+ else
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_i_contregs_vm (SCM contregs)
+{
+ return SCM_CONTREGS (contregs)->vm;
+}
+
+SCM
+scm_i_contregs_vm_cont (SCM contregs)
+{
+ return SCM_CONTREGS (contregs)->vm_cont;
}
-#undef FUNC_NAME
+/* {Apply}
+ */
+
/* Invoking a continuation proceeds as follows:
*
* - the stack is made large enough for the called continuation
@@ -134,7 +300,7 @@ scm_make_continuation (int *first)
* with their correct stack.
*/
-static void scm_dynthrow (SCM, SCM);
+static void scm_dynthrow (SCM);
/* Grow the stack by a fixed amount to provide space to copy in the
* continuation. Possibly this function has to be called several times
@@ -146,12 +312,12 @@ static void scm_dynthrow (SCM, SCM);
scm_t_bits scm_i_dummy;
static void
-grow_stack (SCM cont, SCM val)
+grow_stack (SCM cont)
{
scm_t_bits growth[100];
scm_i_dummy = (scm_t_bits) growth;
- scm_dynthrow (cont, val);
+ scm_dynthrow (cont);
}
@@ -171,14 +337,13 @@ copy_stack (void *data)
copy_stack_data *d = (copy_stack_data *)data;
memcpy (d->dst, d->continuation->stack,
sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
- scm_vm_reinstate_continuations (d->continuation->vm_conts);
#ifdef __ia64__
SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
#endif
}
static void
-copy_stack_and_call (scm_t_contregs *continuation, SCM val,
+copy_stack_and_call (scm_t_contregs *continuation,
SCM_STACKITEM * dst)
{
long delta;
@@ -189,7 +354,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
data.dst = dst;
scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
- continuation->throw_value = val;
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
@@ -215,7 +379,7 @@ scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
* actual copying and continuation calling.
*/
static void
-scm_dynthrow (SCM cont, SCM val)
+scm_dynthrow (SCM cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
@@ -230,36 +394,36 @@ scm_dynthrow (SCM cont, SCM val)
#if SCM_STACK_GROWS_UP
if (dst + continuation->num_stack_items >= &stack_top_element)
- grow_stack (cont, val);
+ grow_stack (cont);
#else
dst -= continuation->num_stack_items;
if (dst <= &stack_top_element)
- grow_stack (cont, val);
+ grow_stack (cont);
#endif /* def SCM_STACK_GROWS_UP */
SCM_FLUSH_REGISTER_WINDOWS;
- copy_stack_and_call (continuation, val, dst);
+ copy_stack_and_call (continuation, dst);
}
-static SCM
-continuation_apply (SCM cont, SCM args)
-#define FUNC_NAME "continuation_apply"
+void
+scm_i_check_continuation (SCM cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
if (continuation->root != thread->continuation_root)
- {
- SCM_MISC_ERROR
- ("invoking continuation would cross continuation barrier: ~A",
- scm_list_1 (cont));
- }
-
- scm_dynthrow (cont, scm_values (args));
- return SCM_UNSPECIFIED; /* not reached */
+ scm_misc_error
+ ("%continuation-call",
+ "invoking continuation would cross continuation barrier: ~A",
+ scm_list_1 (cont));
+}
+
+void
+scm_i_reinstate_continuation (SCM cont)
+{
+ scm_dynthrow (cont);
}
-#undef FUNC_NAME
SCM
scm_i_with_continuation_barrier (scm_t_catch_body body,
@@ -374,9 +538,8 @@ SCM_DEFINE (scm_with_continuation_barrier,
"with-continuation-barrier", 1,0,0,
void
scm_init_continuations ()
{
- scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
- scm_set_smob_print (scm_tc16_continuation, continuation_print);
- scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
+ tc16_continuation = scm_make_smob_type ("continuation", 0);
+ scm_set_smob_print (tc16_continuation, continuation_print);
#include "libguile/continuations.x"
}
diff --git a/libguile/continuations.h b/libguile/continuations.h
index a04c53f..e0a4556 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -3,7 +3,7 @@
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 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,6 +31,9 @@
#endif /* __ia64__ */
+#define SCM_CONTINUATIONP(x) \
+ (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))
+
/* a continuation SCM is a non-immediate pointing to a heap cell with:
word 0: bits 0-15: smob type tag: scm_tc16_continuation.
bits 16-31: unused.
@@ -39,11 +42,8 @@
in the num_stack_items field of the structure.
*/
-SCM_API scm_t_bits scm_tc16_continuation;
-
typedef struct
{
- SCM throw_value;
scm_i_jmp_buf jmpbuf;
SCM dynenv;
#ifdef __ia64__
@@ -52,7 +52,8 @@ typedef struct
#endif /* __ia64__ */
size_t num_stack_items; /* size of the saved stack. */
SCM root; /* continuation root identifier. */
- SCM vm_conts; /* vm continuations (they use separate stacks) */
+ SCM vm; /* vm */
+ SCM vm_cont; /* vm's stack and regs */
/* The offset from the live stack location to this copy. This is
used to adjust pointers from within the copied stack to the stack
@@ -67,22 +68,18 @@ typedef struct
SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */
} scm_t_contregs;
-#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x)
-#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
+
-#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
-#define SCM_SET_CONTINUATION_LENGTH(x, n)\
- (SCM_CONTREGS (x)->num_stack_items = (n))
-#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
-#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
-#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value)
-#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
-#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
+SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
+SCM_INTERNAL void scm_i_check_continuation (SCM cont);
+SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
-
+SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
-SCM_API SCM scm_make_continuation (int *first);
+SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
+SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
+SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
SCM_API SCM scm_with_continuation_barrier (SCM proc);
diff --git a/libguile/control.c b/libguile/control.c
new file mode 100644
index 0000000..bb35fdf
--- /dev/null
+++ b/libguile/control.c
@@ -0,0 +1,282 @@
+/* Copyright (C) 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/control.h"
+#include "libguile/objcodes.h"
+#include "libguile/instructions.h"
+#include "libguile/vm.h"
+
+
+
+
+SCM
+scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
+ scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie,
+ SCM winds)
+{
+ scm_t_bits tag;
+ struct scm_prompt_registers *regs;
+
+ tag = scm_tc7_prompt;
+ if (escape_only_p)
+ tag |= (SCM_F_PROMPT_ESCAPE<<8);
+
+ regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
+ regs->fp = fp;
+ regs->sp = sp;
+ regs->ip = abort_ip;
+ regs->cookie = vm_cookie;
+
+ return scm_double_cell (tag, SCM_UNPACK (k), (scm_t_bits)regs,
+ SCM_UNPACK (winds));
+}
+
+/* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
+SCM
+scm_i_prompt_pop_abort_args_x (SCM prompt)
+{
+ size_t i, n;
+ SCM vals = SCM_EOL;
+
+ n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]);
+ for (i = 0; i < n; i++)
+ vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)], vals);
+
+ /* The abort did reset the VM's registers, but then these values
+ were pushed on; so we need to pop them ourselves. */
+ SCM_VM_DATA (scm_the_vm ())->sp -= n + 1;
+ /* FIXME NULLSTACK */
+
+ return vals;
+}
+
+
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
+#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
+#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+#define ROUND_UP(len,align) (((len-1)|(align-1))+1)
+#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
+
+#ifdef SCM_ALIGNED
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static const type sym[]
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
+static SCM_ALIGNED (alignment) const type sym[]
+#else
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static type *sym
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
+SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
+ sym = ALIGN_PTR (type, sym, alignment); \
+ memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
+static type *sym = NULL; \
+static const type sym##__unaligned[]
+#endif
+
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+#define SCM_STATIC_OBJCODE(sym) \
+ SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
+ SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
+ { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
+ { SCM_BOOL_F, SCM_PACK (0) } \
+ }; \
+ static const SCM sym = SCM_PACK (sym##__cells); \
+ SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
+
+
+SCM_STATIC_OBJCODE (cont_objcode) = {
+ /* Like in continuations.c, but with partial-cont-call. */
+ OBJCODE_HEADER (8, 19),
+ /* leave args on the stack */
+ /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
+ /* 2 */ scm_op_object_ref, 1, /* push internal winds */
+ /* 4 */ scm_op_partial_cont_call, /* and go! */
+ /* 5 */ scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
+ /* 8 */
+
+ /* We could put some meta-info to say that this proc is a continuation. Not
sure
+ how to do that, though. */
+ META_HEADER (19),
+ /* 0 */ scm_op_make_eol, /* bindings */
+ /* 1 */ scm_op_make_eol, /* sources */
+ /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 5, /* arity: from ip 0 to ip
7 */
+ /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
+ /* 7 */ scm_op_make_int8_0, /* 0 optionals */
+ /* 8 */ scm_op_make_true, /* and a rest arg */
+ /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
+ /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
+ /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
+ /* 18 */ scm_op_return /* and return */
+ /* 19 */
+};
+
+
+static SCM
+reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
+ scm_t_int64 cookie)
+{
+ SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
+ scm_t_uint32 flags;
+
+ /* No need to reify if the continuation is never referenced in the handler.
*/
+ if (SCM_PROMPT_ESCAPE_P (prompt))
+ return SCM_BOOL_F;
+
+ dynwinds = scm_i_dynwinds ();
+ while (!scm_is_eq (dynwinds, extwinds))
+ {
+ intwinds = scm_cons (scm_car (dynwinds), intwinds);
+ dynwinds = scm_cdr (dynwinds);
+ }
+
+ flags = SCM_F_VM_CONT_PARTIAL;
+ if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
+ flags |= SCM_F_VM_CONT_REWINDABLE;
+
+ /* Since non-escape continuations should begin with a thunk application, the
+ first bit of the stack should be a frame, with the saved fp equal to the
fp
+ that was current when the prompt was made. */
+ if ((SCM*)(SCM_PROMPT_REGISTERS (prompt)->sp[1])
+ != SCM_PROMPT_REGISTERS (prompt)->fp)
+ abort ();
+
+ /* Capture from the top of the thunk application frame up to the end. Set an
+ MVRA only, as the post-abort code is in an MV context. */
+ vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp + 4,
+ SCM_VM_DATA (vm)->fp,
+ SCM_VM_DATA (vm)->sp,
+ NULL,
+ SCM_VM_DATA (vm)->ip,
+ flags);
+
+ ret = scm_make_program (cont_objcode,
+ scm_vector (scm_list_2 (vm_cont, intwinds)),
+ SCM_BOOL_F);
+ SCM_SET_CELL_WORD_0 (ret,
+ SCM_CELL_WORD_0 (ret) |
SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION);
+ return ret;
+}
+
+void
+scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
+{
+ SCM cont, winds, prompt = SCM_BOOL_F;
+ long delta;
+ size_t i;
+
+ /* Search the wind list for an appropriate prompt.
+ "Waiter, please bring us the wind list." */
+ for (winds = scm_i_dynwinds (), delta = 0;
+ scm_is_pair (winds);
+ winds = SCM_CDR (winds), delta++)
+ {
+ SCM elt = SCM_CAR (winds);
+ if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
+ {
+ prompt = elt;
+ break;
+ }
+ }
+
+ /* If we didn't find anything, raise an error. */
+ if (scm_is_false (prompt))
+ scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
+
+ cont = reify_partial_continuation (vm, prompt, winds, cookie);
+
+ /* Unwind once more, beyond the prompt. */
+ winds = SCM_CDR (winds), delta++;
+
+ /* Unwind */
+ scm_dowinds (winds, delta);
+
+ /* Restore VM regs */
+ SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
+ SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
+ SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;
+
+ /* Since we're jumping down, we should always have enough space */
+ if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
+ abort ();
+
+ /* Push vals */
+ *(++(SCM_VM_DATA (vm)->sp)) = cont;
+ for (i = 0; i < n; i++)
+ *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
+ *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation
*/
+
+ /* Jump! */
+ SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);
+
+ /* Shouldn't get here */
+ abort ();
+}
+
+SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
+ "Abort to the nearest prompt with tag @var{tag}.")
+#define FUNC_NAME s_scm_at_abort
+{
+ SCM *argv;
+ size_t i, n;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
+ argv = alloca (sizeof (SCM)*n);
+ for (i = 0; i < n; i++, args = scm_cdr (args))
+ argv[i] = scm_car (args);
+
+ scm_c_abort (scm_the_vm (), tag, n, argv, -1);
+
+ /* Oh, what, you're still here? The abort must have been reinstated.
Actually,
+ that's quite impossible, given that we're already in C-land here, so...
+ abort! */
+
+ abort ();
+}
+#undef FUNC_NAME
+
+void
+scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<prompt ", port);
+ scm_intprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+}
+
+void
+scm_init_control (void)
+{
+#include "libguile/control.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/control.h b/libguile/control.h
new file mode 100644
index 0000000..bbc4c20
--- /dev/null
+++ b/libguile/control.h
@@ -0,0 +1,60 @@
+/* Copyright (C) 2010 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
+ */
+
+#ifndef SCM_CONTROL_H
+#define SCM_CONTROL_H
+
+
+#define SCM_F_PROMPT_ESCAPE 0x1
+
+#define SCM_PROMPT_P(x) (!SCM_IMP (x) && SCM_TYP7(x) ==
scm_tc7_prompt)
+#define SCM_PROMPT_FLAGS(x) (SCM_CELL_WORD ((x), 0) >> 8)
+#define SCM_PROMPT_ESCAPE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
+#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1))
+#define SCM_PROMPT_REGISTERS(x) ((struct
scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
+#define SCM_PROMPT_DYNWINDS(x) (SCM_CELL_OBJECT ((x), 3))
+
+#define SCM_PROMPT_SETJMP(p) (SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
+
+struct scm_prompt_registers
+{
+ scm_t_uint8 *ip;
+ SCM *sp;
+ SCM *fp;
+ scm_t_int64 cookie;
+ scm_i_jmp_buf regs;
+};
+
+
+SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
+ scm_t_uint8 *abort_ip,
+ scm_t_uint8 escape_only_p,
+ scm_t_int64 vm_cookie,
+ SCM winds);
+SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM prompt);
+
+SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
+ scm_t_int64 cookie) SCM_NORETURN;
+SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;
+
+
+SCM_INTERNAL void scm_i_prompt_print (SCM exp, SCM port, scm_print_state
*pstate);
+SCM_INTERNAL void scm_init_control (void);
+
+
+#endif /* SCM_CONTROL_H */
diff --git a/libguile/debug.c b/libguile/debug.c
index 0f83ea0..c8e908f 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010 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
@@ -35,6 +35,7 @@
#include "libguile/throw.h"
#include "libguile/macros.h"
#include "libguile/smob.h"
+#include "libguile/struct.h"
#include "libguile/procprop.h"
#include "libguile/srcprop.h"
#include "libguile/alist.h"
@@ -136,18 +137,15 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
"Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
+ SCM name;
+
SCM_VALIDATE_PROC (1, proc);
- switch (SCM_TYP7 (proc)) {
- case scm_tc7_gsubr:
- return SCM_SUBR_NAME (proc);
- default:
- {
- SCM name = scm_procedure_property (proc, scm_sym_name);
- if (scm_is_false (name) && SCM_PROGRAM_P (proc))
- name = scm_program_name (proc);
- return name;
- }
- }
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ name = scm_procedure_property (proc, scm_sym_name);
+ if (scm_is_false (name) && SCM_PROGRAM_P (proc))
+ name = scm_program_name (proc);
+ return name;
}
#undef FUNC_NAME
@@ -210,15 +208,6 @@ scm_reverse_lookup (SCM env, SCM data)
return SCM_BOOL_F;
}
-SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
- (SCM id, SCM thunk),
- "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
-#define FUNC_NAME s_scm_sys_start_stack
-{
- return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
-}
-#undef FUNC_NAME
-
/* Undocumented debugging procedure */
diff --git a/libguile/debug.h b/libguile/debug.h
index 6a1ee5a..7c1d02f 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -42,7 +42,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk);
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index c53776c..4ff1bc2 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 Free Software Foundation, Inc.
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010 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
@@ -28,6 +28,11 @@
#include "libguile/_scm.h"
#include "libguile/async.h"
+#include "libguile/arrays.h"
+#include "libguile/array-map.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/bytevectors.h"
+#include "libguile/bitvectors.h"
#include "libguile/deprecated.h"
#include "libguile/discouraged.h"
#include "libguile/deprecation.h"
@@ -36,7 +41,6 @@
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/modules.h"
-#include "libguile/generalized-arrays.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/procprop.h"
@@ -48,12 +52,14 @@
#include "libguile/ports.h"
#include "libguile/eq.h"
#include "libguile/read.h"
+#include "libguile/r6rs-ports.h"
#include "libguile/strports.h"
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/keywords.h"
#include "libguile/socket.h"
#include "libguile/feature.h"
+#include "libguile/uniform.h"
#include <math.h>
#include <stdio.h>
@@ -508,38 +514,6 @@ SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
}
#undef FUNC_NAME
-SCM
-scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or "
- "`scm_c_define_subr' instead.");
-
- if (set)
- return scm_c_define_subr (name, type, fcn);
- else
- return scm_c_make_subr (name, type, fcn);
-}
-
-SCM
-scm_make_subr (const char *name, int type, SCM (*fcn) ())
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead.");
-
- return scm_c_define_subr (name, type, fcn);
-}
-
-SCM
-scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_subr_with_generic' is deprecated. Use "
- "`scm_c_define_subr_with_generic' instead.");
-
- return scm_c_define_subr_with_generic (name, type, fcn, gf);
-}
-
/* Call thunk(closure) underneath a top-level error handler.
* If an error occurs, pass the exitval through err_filter and return it.
* If no error occurs, return the value of thunk.
@@ -1359,65 +1333,245 @@ scm_vector_equal_p (SCM x, SCM y)
return scm_equal_p (x, y);
}
-int
-scm_i_arrayp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
- return SCM_I_ARRAYP(a);
-}
+SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Fill the elements of @var{uvec} by reading\n"
+ "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive) and @var{end}\n"
+ "(exclusive) allow a specified region to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be read, potentially blocking\n"
+ "while waiting formore input or end-of-file.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "read(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially filled before reaching end-of-file or in\n"
+ "the single call to read(2).\n\n"
+ "@code{uniform-vector-read!} returns the number of elements\n"
+ "read.\n\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults\n"
+ "to the value returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_read_x
+{
+ SCM result;
+ size_t c_width, c_start, c_end;
+
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-size_t
-scm_i_array_ndim (SCM a)
-{
scm_c_issue_deprecation_warning
- ("SCM_ARRAY_NDIM is deprecated. "
- "Use scm_c_array_rank or scm_array_handle_rank instead.");
- return scm_c_array_rank (a);
-}
+ ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
+ "`(rnrs io ports)' instead.");
-int
-scm_i_array_contp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_CONTP is deprecated. Do not use it.");
- return SCM_I_ARRAY_CONTP (a);
-}
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
-scm_t_array *
-scm_i_array_mem (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_MEM is deprecated. Do not use it.");
- return (scm_t_array *)SCM_I_ARRAY_MEM (a);
+ c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
+
+ c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
+ c_start *= c_width;
+
+ c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t
(end);
+ c_end *= c_width;
+
+ result = scm_get_bytevector_n_x (port_or_fd, uvec,
+ scm_from_size_t (c_start),
+ scm_from_size_t (c_end - c_start));
+
+ if (SCM_EOF_OBJECT_P (result))
+ result = SCM_INUM0;
+
+ return result;
}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Write the elements of @var{uvec} as raw bytes to\n"
+ "@var{port-or-fdes}, in the host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive)\n"
+ "and @var{end} (exclusive) allow\n"
+ "a specified region to be written.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be written, potentially blocking\n"
+ "while waiting for more room.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "write(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially written in the single call to write(2).\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_write
+{
+ size_t c_width, c_start, c_end;
+
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-SCM
-scm_i_array_v (SCM a)
-{
- /* We could use scm_shared_array_root here, but it is better to move
- them away from expecting vectors as the basic storage for arrays.
- */
scm_c_issue_deprecation_warning
- ("SCM_ARRAY_V is deprecated. Do not use it.");
- return SCM_I_ARRAY_V (a);
+ ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
+ "`(rnrs io ports)' instead.");
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
+
+ c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
+
+ c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
+ c_start *= c_width;
+
+ c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t
(end);
+ c_end *= c_width;
+
+ return scm_put_bytevector (port_or_fd, uvec,
+ scm_from_size_t (c_start),
+ scm_from_size_t (c_end - c_start));
}
+#undef FUNC_NAME
-size_t
-scm_i_array_base (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_BASE is deprecated. Do not use it.");
- return SCM_I_ARRAY_BASE (a);
+static SCM
+scm_ra2contig (SCM ra, int copy)
+{
+ SCM ret;
+ long inc = 1;
+ size_t k, len = 1;
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ k = SCM_I_ARRAY_NDIM (ra);
+ if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k -
1].inc)))
+ {
+ if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
+ return ra;
+ if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
+ 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
+ 0 == len % SCM_LONG_BIT))
+ return ra;
+ }
+ ret = scm_i_make_array (k);
+ SCM_I_ARRAY_BASE (ret) = 0;
+ while (k--)
+ {
+ SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
+ SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
+ inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ }
+ SCM_I_ARRAY_V (ret) =
+ scm_make_generalized_vector (scm_array_type (ra), scm_from_size_t (inc),
+ SCM_UNDEFINED);
+ if (copy)
+ scm_array_copy_x (ra, ret);
+ return ret;
+}
+
+SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes]
[start] [end]\n"
+ "Attempt to read all elements of @var{ura}, in lexicographic order,
as\n"
+ "binary objects from @var{port-or-fdes}.\n"
+ "If an end of file is encountered,\n"
+ "the objects up to that point are put into @var{ura}\n"
+ "(starting at the beginning) and the remainder of the array is\n"
+ "unchanged.\n\n"
+ "The optional arguments @var{start} and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "@code{uniform-array-read!} returns the number of objects read.\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults to
the value\n"
+ "returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_array_read_x
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 0);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ if (!scm_is_eq (cra, ura))
+ scm_array_copy_x (cra, ura);
+ return ans;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
}
+#undef FUNC_NAME
-scm_t_array_dim *
-scm_i_array_dims (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead.");
- return SCM_I_ARRAY_DIMS (a);
+SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "Writes all elements of @var{ura} as binary objects to\n"
+ "@var{port-or-fdes}.\n\n"
+ "The optional arguments @var{start}\n"
+ "and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be
written.\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_array_write
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_write (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 1);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ return ans;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
}
+#undef FUNC_NAME
SCM
scm_i_cur_inp (void)
@@ -1654,7 +1808,114 @@ scm_trampoline_2 (SCM proc)
return scm_call_2;
}
+int
+scm_i_subr_p (SCM x)
+{
+ scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use
SCM_PRIMITIVE_P instead.");
+ return SCM_PRIMITIVE_P (x);
+}
+
+
+
+SCM
+scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_lazy_catch' is no longer supported. Instead this call
will\n"
+ "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked
from\n"
+ "within the dynamic context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
+ "and adapt it (if necessary) to expect to be within the dynamic context\n"
+ "of the throw.");
+ return scm_c_with_throw_handler (tag, body, body_data, handler,
handler_data, 0);
+}
+
+SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
+ (SCM key, SCM thunk, SCM handler),
+ "This behaves exactly like @code{catch}, except that it does\n"
+ "not unwind the stack before invoking @var{handler}.\n"
+ "If the @var{handler} procedure returns normally, Guile\n"
+ "rethrows the same exception again to the next innermost catch,\n"
+ "lazy-catch or throw handler. If the @var{handler} exits\n"
+ "non-locally, that exit determines the continuation.")
+#define FUNC_NAME s_scm_lazy_catch
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
+
+ c.tag = key;
+ c.body_proc = thunk;
+
+ scm_c_issue_deprecation_warning
+ ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
+ "to `with-throw-handler'. Your handler will be invoked from within the\n"
+ "dynamic context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to use `with-throw-handler' directly, and\n"
+ "adapt it (if necessary) to expect to be within the dynamic context of\n"
+ "the throw.");
+
+ return scm_c_with_throw_handler (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler, 0);
+}
+#undef FUNC_NAME
+
+
+
+
+SCM
+scm_raequal (SCM ra0, SCM ra1)
+{
+ return scm_array_equal_p (ra0, ra1);
+}
+
+
+
+
+
+SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
+ (SCM func, SCM dobj, SCM args),
+ "Call the C function indicated by @var{func} and @var{dobj},\n"
+ "just like @code{dynamic-call}, but pass it some arguments and\n"
+ "return its return value. The C function is expected to take\n"
+ "two arguments and return an @code{int}, just like @code{main}:\n"
+ "@smallexample\n"
+ "int c_func (int argc, char **argv);\n"
+ "@end smallexample\n\n"
+ "The parameter @var{args} must be a list of strings and is\n"
+ "converted into an array of @code{char *}. The array is passed\n"
+ "in @var{argv} and its size in @var{argc}. The return value is\n"
+ "converted to a Scheme number and returned from the call to\n"
+ "@code{dynamic-args-call}.")
+#define FUNC_NAME s_scm_dynamic_args_call
+{
+ int (*fptr) (int argc, char **argv);
+ int result, argc;
+ char **argv;
+
+ if (scm_is_string (func))
+ func = scm_dynamic_func (func, dobj);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+
+ fptr = SCM_FOREIGN_POINTER (func, void);
+
+ argv = scm_i_allocate_string_pointers (args);
+ for (argc = 0; argv[argc]; argc++)
+ ;
+ result = (*fptr) (argc, argv);
+
+ return scm_from_int (result);
+}
+#undef FUNC_NAME
+
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index be56d37..021e319 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
-/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009 Free Software Foundation,
Inc.
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -24,7 +24,6 @@
*/
#include "libguile/__scm.h"
-#include "libguile/arrays.h"
#include "libguile/strings.h"
#include "libguile/eval.h"
@@ -172,16 +171,6 @@ SCM_DEPRECATED SCM scm_read_and_eval_x (SCM port);
#define SCM_SUBR_DOC(x) SCM_BOOL_F
-SCM_DEPRECATED SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
-SCM_DEPRECATED SCM scm_make_subr_with_generic (const char *name,
- int type,
- SCM (*fcn) (),
- SCM *gf);
-SCM_DEPRECATED SCM scm_make_subr_opt (const char *name,
- int type,
- SCM (*fcn) (),
- int set);
-
SCM_DEPRECATED SCM scm_call_catching_errors (SCM (*thunk)(), SCM
(*err_filter)(),
void * closure);
@@ -242,7 +231,6 @@ SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define scm_srcprops_chunk scm_t_srcprops_chunk
#define scm_array scm_t_array
#define scm_array_dim scm_t_array_dim
-#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS
#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME))
#define SCM_WTA(pos, scm) \
@@ -495,6 +483,15 @@ SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define SCM_ARRAY_BASE(a) scm_i_array_base(a)
#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
+SCM_DEPRECATED SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_DEPRECATED SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_DEPRECATED SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_DEPRECATED SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+
/* Deprecated because they should not be lvalues and we want people to
use the official interfaces.
*/
@@ -608,6 +605,30 @@ SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM
proc);
+/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */
+SCM_DEPRECATED int scm_i_subr_p (SCM x);
+#define scm_subr_p(x) (scm_i_subr_p (x))
+
+
+
+/* Deprecated 2010-01-31, use with-throw-handler instead */
+SCM_DEPRECATED SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
+SCM_DEPRECATED SCM scm_internal_lazy_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data);
+
+
+
+/* Deprecated 2010-03-31, use array-equal? instead */
+SCM_DEPRECATED SCM scm_raequal (SCM ra0, SCM ra1);
+
+/* Deprecated 2010-04-01, use the dynamic FFI instead */
+SCM_DEPRECATED SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
+
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/dynl.c b/libguile/dynl.c
index 52c43e5..b76e85c 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -1,7 +1,7 @@
/* dynl.c - dynamic linking
*
* Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
- * 2003, 2008, 2009 Free Software Foundation, Inc.
+ * 2003, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -55,9 +55,9 @@ maybe_drag_in_eprintf ()
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/deprecation.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
+#include "libguile/foreign.h"
#include <ltdl.h>
@@ -76,16 +76,23 @@ static void *
sysdep_dynl_link (const char *fname, const char *subr)
{
lt_dlhandle handle;
- handle = lt_dlopenext (fname);
+
+ if (fname != NULL)
+ handle = lt_dlopenext (fname);
+ else
+ /* Return a handle for the program as a whole. */
+ handle = lt_dlopen (NULL);
+
if (NULL == handle)
{
SCM fn;
SCM msg;
- fn = scm_from_locale_string (fname);
+ fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
msg = scm_from_locale_string (lt_dlerror ());
scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
}
+
return (void *) handle;
}
@@ -99,7 +106,7 @@ sysdep_dynl_unlink (void *handle, const char *subr)
}
static void *
-sysdep_dynl_func (const char *symb, void *handle, const char *subr)
+sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
void *fptr;
@@ -154,7 +161,7 @@ dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
}
-SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
+SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
(SCM filename),
"Find the shared object (shared library) denoted by\n"
"@var{filename} and link it into the running Guile\n"
@@ -164,18 +171,33 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
"Searching for object files is system dependent. Normally,\n"
"if @var{filename} does have an explicit directory it will\n"
"be searched for in locations\n"
- "such as @file{/usr/lib} and @file{/usr/local/lib}.")
+ "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
+ "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
+ "returned. This handle provides access to the symbols\n"
+ "available to the program at run-time, including those exported\n"
+ "by the program itself and the shared libraries already loaded.\n")
#define FUNC_NAME s_scm_dynamic_link
{
void *handle;
char *file;
scm_dynwind_begin (0);
- file = scm_to_locale_string (filename);
- scm_dynwind_free (file);
+
+ if (SCM_UNBNDP (filename))
+ file = NULL;
+ else
+ {
+ file = scm_to_locale_string (filename);
+ scm_dynwind_free (file);
+ }
+
handle = sysdep_dynl_link (file, FUNC_NAME);
scm_dynwind_end ();
- SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
+
+ SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
+ SCM_UNBNDP (filename)
+ ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
+ handle);
}
#undef FUNC_NAME
@@ -213,6 +235,51 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
+ (SCM name, SCM type, SCM dobj, SCM len),
+ "Return a ``handle'' for the pointer @var{name} in the\n"
+ "shared object referred to by @var{dobj}. The handle\n"
+ "aliases a C value, and is declared to be of type\n"
+ "@var{type}. Valid types are defined in the\n"
+ "@code{(system foreign)} module.\n\n"
+ "This facility works by asking the dynamic linker for\n"
+ "the address of a symbol, then assuming that it aliases a\n"
+ "value of a given type. Obviously, the user must be very\n"
+ "careful to ensure that the value actually is of the\n"
+ "declared type, or bad things will happen.\n\n"
+ "Regardless whether your C compiler prepends an underscore\n"
+ "@samp{_} to the global names in a program, you should\n"
+ "@strong{not} include this underscore in @var{name}\n"
+ "since it will be added automatically when necessary.")
+#define FUNC_NAME s_scm_dynamic_pointer
+{
+ void *val;
+ scm_t_foreign_type t;
+
+ SCM_VALIDATE_STRING (1, name);
+ t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
+ SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
+
+ if (DYNL_HANDLE (dobj) == NULL)
+ SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
+ else
+ {
+ char *chars;
+
+ scm_dynwind_begin (0);
+ chars = scm_to_locale_string (name);
+ scm_dynwind_free (chars);
+ val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
+ scm_dynwind_end ();
+
+ return scm_take_foreign_pointer (t, val,
+ SCM_UNBNDP (len) ? 0 : scm_to_size_t
(len),
+ NULL);
+ }
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
(SCM name, SCM dobj),
"Return a ``handle'' for the function @var{name} in the\n"
@@ -225,28 +292,10 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
{
- /* The returned handle is formed by casting the address of the function to a
- * long value and converting this to a scheme number
- */
-
- void (*func) ();
-
- SCM_VALIDATE_STRING (1, name);
- /*fixme* GC-problem */
- SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
- if (DYNL_HANDLE (dobj) == NULL) {
- SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
- } else {
- char *chars;
-
- scm_dynwind_begin (0);
- chars = scm_to_locale_string (name);
- scm_dynwind_free (chars);
- func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
- FUNC_NAME);
- scm_dynwind_end ();
- return scm_from_ulong ((unsigned long) func);
- }
+ return scm_dynamic_pointer (name,
+ scm_from_uint (SCM_FOREIGN_TYPE_VOID),
+ dobj,
+ SCM_UNDEFINED);
}
#undef FUNC_NAME
@@ -275,46 +324,14 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- fptr = (void (*) ()) scm_to_ulong (func);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+
+ fptr = SCM_FOREIGN_POINTER (func, void);
fptr ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
- (SCM func, SCM dobj, SCM args),
- "Call the C function indicated by @var{func} and @var{dobj},\n"
- "just like @code{dynamic-call}, but pass it some arguments and\n"
- "return its return value. The C function is expected to take\n"
- "two arguments and return an @code{int}, just like @code{main}:\n"
- "@smallexample\n"
- "int c_func (int argc, char **argv);\n"
- "@end smallexample\n\n"
- "The parameter @var{args} must be a list of strings and is\n"
- "converted into an array of @code{char *}. The array is passed\n"
- "in @var{argv} and its size in @var{argc}. The return value is\n"
- "converted to a Scheme number and returned from the call to\n"
- "@code{dynamic-args-call}.")
-#define FUNC_NAME s_scm_dynamic_args_call
-{
- int (*fptr) (int argc, char **argv);
- int result, argc;
- char **argv;
-
- if (scm_is_string (func))
- func = scm_dynamic_func (func, dobj);
-
- fptr = (int (*) (int, char **)) scm_to_ulong (func);
-
- argv = scm_i_allocate_string_pointers (args);
- for (argc = 0; argv[argc]; argc++)
- ;
- result = (*fptr) (argc, argv);
-
- return scm_from_int (result);
-}
-#undef FUNC_NAME
-
void
scm_init_dynamic_linking ()
{
diff --git a/libguile/dynl.h b/libguile/dynl.h
index eb318ae..3239d63 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -3,7 +3,7 @@
#ifndef SCM_DYNL_H
#define SCM_DYNL_H
-/* Copyright (C) 1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2006, 2008, 2010 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
@@ -30,9 +30,9 @@
SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj);
+SCM_API SCM scm_dynamic_pointer (SCM name, SCM type, SCM dobj, SCM len);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
-SCM_API SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
SCM_INTERNAL void scm_init_dynamic_linking (void);
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index b34f9be..f4d19bd 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010
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
@@ -26,6 +26,7 @@
#include <assert.h>
#include "libguile/_scm.h"
+#include "libguile/control.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
@@ -41,66 +42,17 @@
#<frame>
#<winder>
+ #<with-fluids>
+ #<prompt>
(enter-proc . leave-proc) dynamic-wind
- (tag . jmpbuf) catch
- (tag . pre-unwind-data) throw-handler / lazy-catch
- tag is either a symbol or a boolean
*/
-SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
- (SCM in_guard, SCM thunk, SCM out_guard),
- "All three arguments must be 0-argument procedures.\n"
- "@var{in_guard} is called, then @var{thunk}, then\n"
- "@var{out_guard}.\n"
- "\n"
- "If, any time during the execution of @var{thunk}, the\n"
- "continuation of the @code{dynamic_wind} expression is escaped\n"
- "non-locally, @var{out_guard} is called. If the continuation of\n"
- "the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n"
- "@var{in_guard} and @var{out_guard} may be called any number of\n"
- "times.\n"
- "@lisp\n"
- "(define x 'normal-binding)\n"
- "@result{} x\n"
- "(define a-cont (call-with-current-continuation\n"
- " (lambda (escape)\n"
- " (let ((old-x x))\n"
- " (dynamic-wind\n"
- " ;; in-guard:\n"
- " ;;\n"
- " (lambda () (set! x 'special-binding))\n"
- "\n"
- " ;; thunk\n"
- " ;;\n"
- " (lambda () (display x) (newline)\n"
- " (call-with-current-continuation
escape)\n"
- " (display x) (newline)\n"
- " x)\n"
- "\n"
- " ;; out-guard:\n"
- " ;;\n"
- " (lambda () (set! x old-x)))))))\n"
- "\n"
- ";; Prints:\n"
- "special-binding\n"
- ";; Evaluates to:\n"
- "@result{} a-cont\n"
- "x\n"
- "@result{} normal-binding\n"
- "(a-cont #f)\n"
- ";; Prints:\n"
- "special-binding\n"
- ";; Evaluates to:\n"
- "@result{} a-cont ;; the value of the (define a-cont...)\n"
- "x\n"
- "@result{} normal-binding\n"
- "a-cont\n"
- "@result{} special-binding\n"
- "@end lisp")
-#define FUNC_NAME s_scm_dynamic_wind
+SCM
+scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
+#define FUNC_NAME "dynamic-wind"
{
SCM ans, old_winds;
SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
@@ -288,7 +240,6 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void
*), void *data)
else if (delta < 0)
{
SCM wind_elt;
- SCM wind_key;
scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
wind_elt = SCM_CAR (to);
@@ -305,21 +256,18 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func)
(void *), void *data)
if (WINDER_REWIND_P (wind_elt))
WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
}
- else
+ else if (SCM_WITH_FLUIDS_P (wind_elt))
{
- wind_key = SCM_CAR (wind_elt);
- /* key = #t | symbol | thunk | list of variables */
- if (SCM_NIMP (wind_key))
- {
- if (scm_is_pair (wind_key))
- {
- if (SCM_VARIABLEP (SCM_CAR (wind_key)))
- scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
- }
- else if (scm_is_true (scm_thunk_p (wind_key)))
- scm_call_0 (wind_key);
- }
+ scm_i_swap_with_fluids (wind_elt,
+ SCM_I_CURRENT_THREAD->dynamic_state);
}
+ else if (SCM_PROMPT_P (wind_elt))
+ ; /* pass -- see vm_reinstate_partial_continuation */
+ else if (scm_is_pair (wind_elt))
+ scm_call_0 (SCM_CAR (wind_elt));
+ else
+ /* trash on the wind list */
+ abort ();
scm_i_set_dynwinds (to);
}
@@ -327,7 +275,6 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void
*), void *data)
{
SCM wind;
SCM wind_elt;
- SCM wind_key;
wind = scm_i_dynwinds ();
wind_elt = SCM_CAR (wind);
@@ -342,20 +289,18 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func)
(void *), void *data)
if (!WINDER_REWIND_P (wind_elt))
WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
}
- else
+ else if (SCM_WITH_FLUIDS_P (wind_elt))
{
- wind_key = SCM_CAR (wind_elt);
- if (SCM_NIMP (wind_key))
- {
- if (scm_is_pair (wind_key))
- {
- if (SCM_VARIABLEP (SCM_CAR (wind_key)))
- scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
- }
- else if (scm_is_true (scm_thunk_p (wind_key)))
- scm_call_0 (SCM_CDR (wind_elt));
- }
+ scm_i_swap_with_fluids (wind_elt,
+ SCM_I_CURRENT_THREAD->dynamic_state);
}
+ else if (SCM_PROMPT_P (wind_elt))
+ ; /* pass -- though we could invalidate the prompt */
+ else if (scm_is_pair (wind_elt))
+ scm_call_0 (SCM_CDR (wind_elt));
+ else
+ /* trash on the wind list */
+ abort ();
delta--;
goto tail; /* scm_dowinds(to, delta-1); */
diff --git a/libguile/eq.c b/libguile/eq.c
index eaf1acc..923fa77 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -48,6 +48,7 @@
#endif
+static SCM scm_i_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same object,\n"
@@ -120,6 +121,7 @@ real_eqv (double x, double y)
return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
}
+static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
#include <stdio.h>
SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
@@ -212,7 +214,7 @@ SCM scm_eqv_p (SCM x, SCM y)
#undef FUNC_NAME
-SCM scm_i_equal_p (SCM, SCM, SCM);
+static SCM scm_i_equal_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same
type, and\n"
@@ -319,7 +321,7 @@ scm_equal_p (SCM x, SCM y)
/* Vectors can be equal to one-dimensional arrays.
*/
- if (SCM_I_ARRAYP (x) || SCM_I_ARRAYP (y))
+ if (scm_is_array (x) && scm_is_array (y))
return scm_array_equal_p (x, y);
return SCM_BOOL_F;
diff --git a/libguile/eval.c b/libguile/eval.c
index 48d1d74..f775d31 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -24,6 +24,7 @@
#endif
#include <alloca.h>
+#include <assert.h>
#include "libguile/__scm.h"
@@ -31,6 +32,7 @@
#include "libguile/alist.h"
#include "libguile/async.h"
#include "libguile/continuations.h"
+#include "libguile/control.h"
#include "libguile/debug.h"
#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
@@ -40,7 +42,6 @@
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
-#include "libguile/lang.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/memoize.h"
@@ -111,7 +112,6 @@ static scm_t_bits scm_tc16_boot_closure;
-#if 0
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
#define CAAR(x) SCM_CAAR(x)
@@ -120,16 +120,6 @@ static scm_t_bits scm_tc16_boot_closure;
#define CDDR(x) SCM_CDDR(x)
#define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x)
-#else
-#define CAR(x) scm_car(x)
-#define CDR(x) scm_cdr(x)
-#define CAAR(x) scm_caar(x)
-#define CADR(x) scm_cadr(x)
-#define CDAR(x) scm_cdar(x)
-#define CDDR(x) scm_cddr(x)
-#define CADDR(x) scm_caddr(x)
-#define CDDDR(x) scm_cdddr(x)
-#endif
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
@@ -172,6 +162,7 @@ eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
+ unsigned int argc;
loop:
SCM_TICK;
@@ -215,6 +206,42 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), eval (CDR (mx), env));
return SCM_UNSPECIFIED;
+ case SCM_M_DYNWIND:
+ {
+ SCM in, out, res, old_winds;
+ in = eval (CAR (mx), env);
+ out = eval (CDDR (mx), env);
+ scm_call_0 (in);
+ old_winds = scm_i_dynwinds ();
+ scm_i_set_dynwinds (scm_acons (in, out, old_winds));
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (old_winds);
+ scm_call_0 (out);
+ return res;
+ }
+
+ case SCM_M_WITH_FLUIDS:
+ {
+ long i, len;
+ SCM *fluidv, *valuesv, walk, wf, res;
+ len = scm_ilength (CAR (mx));
+ fluidv = alloca (sizeof (SCM)*len);
+ for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
+ fluidv[i] = eval (CAR (walk), env);
+ valuesv = alloca (sizeof (SCM)*len);
+ for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
+ valuesv[i] = eval (CAR (walk), env);
+
+ wf = scm_i_make_with_fluids (len, fluidv, valuesv);
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ res = eval (CDDR (mx), env);
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+
+ return res;
+ }
+
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
@@ -253,7 +280,7 @@ eval (SCM x, SCM env)
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
- /* int nargs = CADR (mx); */
+ argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
if (BOOT_CLOSURE_P (proc))
@@ -262,7 +289,7 @@ eval (SCM x, SCM env)
SCM new_env = BOOT_CLOSURE_ENV (proc);
if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{
- if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
+ if (SCM_UNLIKELY (argc < nreq))
scm_wrong_num_args (proc);
for (; nreq; nreq--, mx = CDR (mx))
new_env = scm_cons (eval (CAR (mx), env), new_env);
@@ -287,27 +314,18 @@ eval (SCM x, SCM env)
}
else
{
- SCM rest = SCM_EOL;
- /* FIXME: use alloca */
- for (; scm_is_pair (mx); mx = CDR (mx))
- rest = scm_cons (eval (CAR (mx), env), rest);
- return scm_vm_apply (scm_the_vm (), proc, scm_reverse (rest));
+ SCM *argv;
+ unsigned int i;
+
+ argv = alloca (argc * sizeof (SCM));
+ for (i = 0; i < argc; i++, mx = CDR (mx))
+ argv[i] = eval (CAR (mx), env);
+
+ return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
}
-
- case SCM_M_CONT:
- {
- int first;
- SCM val = scm_make_continuation (&first);
- if (!first)
- return val;
- else
- {
- proc = eval (mx, env);
- args = scm_list_1 (val);
- goto apply_proc;
- }
- }
+ case SCM_M_CONT:
+ return scm_i_call_with_current_continuation (eval (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
@@ -354,7 +372,7 @@ eval (SCM x, SCM env)
else
{
while (scm_is_pair (env))
- env = scm_cdr (env);
+ env = CDR (env);
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
@@ -371,7 +389,7 @@ eval (SCM x, SCM env)
else
{
while (scm_is_pair (env))
- env = scm_cdr (env);
+ env = CDR (env);
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
val);
@@ -400,6 +418,30 @@ eval (SCM x, SCM env)
return SCM_UNSPECIFIED;
}
+ case SCM_M_PROMPT:
+ {
+ SCM vm, prompt, handler, res;
+
+ vm = scm_the_vm ();
+ prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
+ SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
+ 0, -1, scm_i_dynwinds ());
+ handler = eval (CDDR (mx), env);
+ scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+
+ if (SCM_PROMPT_SETJMP (prompt))
+ {
+ /* The prompt exited nonlocally. */
+ proc = handler;
+ args = scm_i_prompt_pop_abort_args_x (prompt);
+ goto apply_proc;
+ }
+
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ return res;
+ }
+
default:
abort ();
}
@@ -552,6 +594,12 @@ scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM
arg4)
return scm_c_vm_run (scm_the_vm (), proc, args, 4);
}
+SCM
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
+{
+ return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+}
+
/* Simple procedure applies
*/
diff --git a/libguile/eval.h b/libguile/eval.h
index 6341f14..0715e04 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -69,6 +69,7 @@ SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
+SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 84218b3..b397cbd 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010 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
@@ -71,21 +71,25 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1,
0, 0,
return SCM_BOOL_T;
case scm_tc3_imm24:
/* characters, booleans, other immediates */
- return scm_from_bool (!scm_is_null (obj));
+ return scm_from_bool (!scm_is_null_and_not_nil (obj));
case scm_tc3_cons:
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
+ case scm_tc7_foreign:
case scm_tc7_hashtable:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
+ case scm_tc7_frame:
+ case scm_tc7_objcode:
+ case scm_tc7_vm:
+ case scm_tc7_vm_cont:
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_program:
case scm_tc7_bytevector:
- case scm_tc7_gsubr:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 3a2a47e..5ca1233 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010
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
@@ -43,7 +43,6 @@
#include "libguile/iselect.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/lang.h"
#include "libguile/dynwind.h"
#include "libguile/validate.h"
@@ -405,7 +404,7 @@ SCM_SYMBOL (scm_sym_unknown, "unknown");
static SCM
scm_stat2scm (struct stat_or_stat64 *stat_temp)
{
- SCM ans = scm_c_make_vector (15, SCM_UNSPECIFIED);
+ SCM ans = scm_c_make_vector (18, SCM_UNSPECIFIED);
SCM_SIMPLE_VECTOR_SET(ans, 0, scm_from_ulong (stat_temp->st_dev));
SCM_SIMPLE_VECTOR_SET(ans, 1, scm_from_ino_t_or_ino64_t (stat_temp->st_ino));
@@ -490,6 +489,21 @@ scm_stat2scm (struct stat_or_stat64 *stat_temp)
*/
}
+#ifdef HAVE_STRUCT_STAT_ST_ATIM
+ SCM_SIMPLE_VECTOR_SET(ans, 15, scm_from_long (stat_temp->st_atim.tv_nsec));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 15, SCM_I_MAKINUM (0));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_MTIM
+ SCM_SIMPLE_VECTOR_SET(ans, 16, scm_from_long (stat_temp->st_mtim.tv_nsec));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 16, SCM_I_MAKINUM (0));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_CTIM
+ SCM_SIMPLE_VECTOR_SET(ans, 17, scm_from_ulong (stat_temp->st_ctim.tv_sec));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 17, SCM_I_MAKINUM (0));
+#endif
return ans;
}
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 427d406..9aa1eb2 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,7 +22,6 @@
#include <stdio.h>
#include <string.h>
-#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/print.h"
@@ -32,76 +31,48 @@
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/deprecation.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
+#include "libguile/bdw-gc.h"
-#define FLUID_GROW 20
-
-/* A lot of the complexity below stems from the desire to reuse fluid
- slots. Normally, fluids should be pretty global and long-lived
- things, so that reusing their slots should not be overly critical,
- but it is the right thing to do nevertheless. The code therefore
- puts the burdon on allocating and collection fluids and keeps
- accessing fluids lock free. This is achieved by manipulating the
- global state of the fluid machinery mostly in single threaded
- sections.
-
- Reusing a fluid slot means that it must be reset to #f in all
- dynamic states. We do this by maintaining a weak list of all
- dynamic states, which is used after a GC to do the resetting.
-
- Also, the fluid vectors in the dynamic states need to grow from
- time to time when more fluids are created. We do this in a single
- threaded section so that threads do not need to lock when accessing
- a fluid in the normal way.
-*/
-
-static scm_i_pthread_mutex_t fluid_admin_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
+/* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */
+#define FLUID_GROW 128
-/* Protected by fluid_admin_mutex, but also accessed during GC. See
- next_fluid_num for a discussion of this.
- */
+/* Vector of allocated fluids indexed by fluid numbers. Access is protected by
+ FLUID_ADMIN_MUTEX. */
+static void **allocated_fluids = NULL;
static size_t allocated_fluids_len = 0;
-static size_t allocated_fluids_num = 0;
-static char *allocated_fluids = NULL;
-#define IS_FLUID(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_fluid)
-#define FLUID_NUM(x) ((size_t)SCM_CELL_WORD_1(x))
+static scm_i_pthread_mutex_t fluid_admin_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+#define IS_FLUID(x) SCM_I_FLUID_P (x)
+#define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
-#define IS_DYNAMIC_STATE(x) (!SCM_IMP (x) && SCM_TYP7 (x) ==
scm_tc7_dynamic_state)
-#define DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
+#define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x)
+#define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x)
#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK
(y)))
-/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids. */
+/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may
+ be more than necessary since ALLOCATED_FLUIDS is sparse and the current
+ thread may not access all the fluids anyway. Memory usage could be improved
+ by using a 2-level array as is done in glibc for pthread keys (TODO). */
static void
grow_dynamic_state (SCM state)
{
SCM new_fluids;
SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
- size_t i, new_len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
+ size_t i, len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
- retry:
- new_len = allocated_fluids_num;
- new_fluids = scm_c_make_vector (new_len, SCM_BOOL_F);
+ /* Assume the assignment below is atomic. */
+ len = allocated_fluids_len;
- scm_i_pthread_mutex_lock (&fluid_admin_mutex);
- if (new_len != allocated_fluids_num)
- {
- /* We lost the race. */
- scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
- goto retry;
- }
-
- assert (allocated_fluids_num > old_len);
+ new_fluids = scm_c_make_vector (len, SCM_BOOL_F);
for (i = 0; i < old_len; i++)
SCM_SIMPLE_VECTOR_SET (new_fluids, i,
SCM_SIMPLE_VECTOR_REF (old_fluids, i));
SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
-
- scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
}
void
@@ -120,45 +91,61 @@ scm_i_dynamic_state_print (SCM exp, SCM port,
scm_print_state *pstate SCM_UNUSED
scm_putc ('>', port);
}
-static size_t
-next_fluid_num ()
+void
+scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<with-fluids ", port);
+ scm_intprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+}
+
+
+/* Return a new fluid. */
+static SCM
+new_fluid ()
{
- size_t n;
+ SCM fluid;
+ size_t trial, n;
+
+ /* Fluids are pointerless cells: the first word is the type tag; the second
+ word is the fluid number. */
+ fluid = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_cell), "fluid"));
+ SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid);
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex);
- if ((allocated_fluids_len > 0) &&
- (allocated_fluids_num == allocated_fluids_len))
- {
- /* All fluid numbers are in use. Run a GC to try to free some
- up.
- */
- scm_gc ();
- }
-
- if (allocated_fluids_num < allocated_fluids_len)
+ for (trial = 0; trial < 2; trial++)
{
+ /* Look for a free fluid number. */
for (n = 0; n < allocated_fluids_len; n++)
- if (allocated_fluids[n] == 0)
+ /* TODO: Use `__sync_bool_compare_and_swap' where available. */
+ if (allocated_fluids[n] == NULL)
break;
+
+ if (trial == 0 && n >= allocated_fluids_len)
+ /* All fluid numbers are in use. Run a GC and retry. Explicitly
+ running the GC is costly and bad-style. We only do this because
+ dynamic state fluid vectors would grow unreasonably if fluid numbers
+ weren't reused. */
+ scm_i_gc ("fluids");
}
- else
+
+ if (n >= allocated_fluids_len)
{
/* Grow the vector of allocated fluids. */
- /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
- the GC; therefore, all fluids remain reachable for the entire
- program lifetime. Hopefully this is not a problem in practice. */
- char *new_allocated_fluids =
- scm_gc_malloc (allocated_fluids_len + FLUID_GROW,
- "allocated fluids");
+ void **new_allocated_fluids =
+ scm_gc_malloc_pointerless ((allocated_fluids_len + FLUID_GROW)
+ * sizeof (*allocated_fluids),
+ "allocated fluids");
/* Copy over old values and initialize rest. GC can not run
during these two operations since there is no safe point in
- them.
- */
- memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len);
- memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
+ them. */
+ memcpy (new_allocated_fluids, allocated_fluids,
+ allocated_fluids_len * sizeof (*allocated_fluids));
+ memset (new_allocated_fluids + allocated_fluids_len, 0,
+ FLUID_GROW * sizeof (*allocated_fluids));
n = allocated_fluids_len;
/* Update the vector of allocated fluids. Dynamic states will
@@ -167,12 +154,15 @@ next_fluid_num ()
allocated_fluids = new_allocated_fluids;
allocated_fluids_len += FLUID_GROW;
}
-
- allocated_fluids_num += 1;
- allocated_fluids[n] = 1;
-
+
+ allocated_fluids[n] = SCM2PTR (fluid);
+ SCM_SET_CELL_WORD_1 (fluid, (scm_t_bits) n);
+
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
+ SCM2PTR (fluid));
+
scm_dynwind_end ();
- return n;
+ return fluid;
}
SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
@@ -186,7 +176,7 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
"with its own dynamic state, you can use fluids for thread local
storage.")
#define FUNC_NAME s_scm_make_fluid
{
- return scm_cell (scm_tc7_fluid, (scm_t_bits) next_fluid_num ());
+ return new_fluid ();
}
#undef FUNC_NAME
@@ -221,11 +211,6 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
- /* We should only get there when the current thread's dynamic state
- turns out to be too small compared to the set of currently allocated
- fluids. */
- assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
-
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
@@ -247,11 +232,6 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
- /* We should only get there when the current thread's dynamic state
- turns out to be too small compared to the set of currently allocated
- fluids. */
- assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
-
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
@@ -263,53 +243,85 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
}
#undef FUNC_NAME
-static void
-swap_fluids (SCM data)
+static SCM
+apply_thunk (void *thunk)
{
- SCM fluids = SCM_CAR (data), vals = SCM_CDR (data);
-
- while (!SCM_NULL_OR_NIL_P (fluids))
+ return scm_call_0 (SCM_PACK (thunk));
+}
+
+SCM
+scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
+{
+ SCM ret;
+
+ /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
+ but N will usually be small, so perhaps that's OK. */
+ {
+ size_t i, j = n;
+
+ while (j--)
+ for (i = 0; i < j; i++)
+ if (fluids[i] == fluids[j])
+ {
+ vals[i] = vals[j]; /* later bindings win */
+ n--;
+ break;
+ }
+ }
+
+ ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
+ SCM_SET_CELL_WORD_1 (ret, n);
+
+ while (n--)
{
- SCM fl = SCM_CAR (fluids);
- SCM old_val = scm_fluid_ref (fl);
- scm_fluid_set_x (fl, SCM_CAR (vals));
- SCM_SETCAR (vals, old_val);
- fluids = SCM_CDR (fluids);
- vals = SCM_CDR (vals);
+ if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
+ scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
+ SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
+ SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
}
+
+ return ret;
}
+
+void
+scm_i_swap_with_fluids (SCM wf, SCM dynstate)
+{
+ SCM fluids;
+ size_t i, max = 0;
-/* Swap the fluid values in reverse order. This is important when the
- same fluid appears multiple times in the fluids list.
-*/
+ fluids = DYNAMIC_STATE_FLUIDS (dynstate);
-static void
-swap_fluids_reverse_aux (SCM fluids, SCM vals)
-{
- if (!SCM_NULL_OR_NIL_P (fluids))
+ /* We could cache the max in the with-fluids, but that would take more mem,
+ and we're touching all the fluids anyway, so this per-swap traversal
should
+ be OK. */
+ for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
{
- SCM fl, old_val;
-
- swap_fluids_reverse_aux (SCM_CDR (fluids), SCM_CDR (vals));
- fl = SCM_CAR (fluids);
- old_val = scm_fluid_ref (fl);
- scm_fluid_set_x (fl, SCM_CAR (vals));
- SCM_SETCAR (vals, old_val);
+ size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
+ max = (max > num) ? max : num;
}
-}
-static void
-swap_fluids_reverse (SCM data)
-{
- swap_fluids_reverse_aux (SCM_CAR (data), SCM_CDR (data));
-}
+ if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ {
+ /* Lazily grow the current thread's dynamic state. */
+ grow_dynamic_state (dynstate);
-static SCM
-apply_thunk (void *thunk)
-{
- return scm_call_0 (SCM_PACK (thunk));
-}
+ fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ }
+ /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
+ for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
+ {
+ size_t fluid_num;
+ SCM x;
+
+ fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
+ x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
+ SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
+ SCM_WITH_FLUIDS_NTH_VAL (wf, i));
+ SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
+ }
+}
+
SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
(SCM fluids, SCM values, SCM thunk),
"Set @var{fluids} to @var{values} temporary, and call
@var{thunk}.\n"
@@ -327,26 +339,36 @@ SCM
scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluids"
{
- SCM ans, data;
- long flen, vlen;
+ SCM wf, ans;
+ long flen, vlen, i;
+ SCM *fluidsv, *valuesv;
SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
if (flen != vlen)
scm_out_of_range (s_scm_with_fluids, values);
- if (flen == 1)
- return scm_c_with_fluid (SCM_CAR (fluids), SCM_CAR (values),
- cproc, cdata);
+ if (SCM_UNLIKELY (flen == 0))
+ return cproc (cdata);
+
+ fluidsv = alloca (sizeof(SCM)*flen);
+ valuesv = alloca (sizeof(SCM)*flen);
- data = scm_cons (fluids, values);
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler_with_scm (swap_fluids, data,
- SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse, data,
- SCM_F_WIND_EXPLICITLY);
+ for (i = 0; i < flen; i++)
+ {
+ fluidsv[i] = SCM_CAR (fluids);
+ fluids = SCM_CDR (fluids);
+ valuesv[i] = SCM_CAR (values);
+ values = SCM_CDR (values);
+ }
+
+ wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
ans = cproc (cdata);
- scm_dynwind_end ();
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+
return ans;
}
#undef FUNC_NAME
@@ -366,12 +388,15 @@ SCM
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluid"
{
- SCM ans;
+ SCM ans, wf;
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_fluid (fluid, value);
+ wf = scm_i_make_with_fluids (1, &fluid, &value);
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
ans = cproc (cdata);
- scm_dynwind_end ();
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+
return ans;
}
#undef FUNC_NAME
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 3a651fb..aa01f24 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -3,7 +3,7 @@
#ifndef SCM_FLUIDS_H
#define SCM_FLUIDS_H
-/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009 Free Software Foundation,
Inc.
+/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010 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,6 +27,18 @@
#include "libguile/root.h"
#include "libguile/vectors.h"
+/* These "with-fluids" objects live on the dynamic stack, and record previous
+ values of fluids. Guile uses shallow binding, so the current fluid values
are
+ always in the same place for a given thread, in the dynamic-state vector.
+ */
+
+#define SCM_WITH_FLUIDS_P(x) (!SCM_IMP (x) && SCM_TYP7(x) ==
scm_tc7_with_fluids)
+#define SCM_WITH_FLUIDS_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
+#define SCM_WITH_FLUIDS_NTH_FLUID(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
+#define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
+#define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 +
(n)*2, (v)))
+
+
/* Fluids.
Fluids are objects of a certain type that can hold one SCM value per
@@ -42,13 +54,8 @@
grow.
*/
-/* The fastest way to acces/modify the value of a fluid. These macros
- do no error checking at all. The first argument is the index
- number of the fluid, obtained via SCM_FLUID_NUM, not the fluid
- itself. You must make sure that the fluid remains protected as
- long you use its number since numbers of unused fluids are reused
- eventually.
-*/
+#define SCM_I_FLUID_P(x) (!SCM_IMP (x) && SCM_TYP7 (x) ==
scm_tc7_fluid)
+#define SCM_I_FLUID_NUM(x) ((size_t)SCM_CELL_WORD_1(x))
SCM_API SCM scm_make_fluid (void);
SCM_API int scm_is_fluid (SCM obj);
@@ -56,6 +63,9 @@ SCM_API SCM scm_fluid_p (SCM fl);
SCM_API SCM scm_fluid_ref (SCM fluid);
SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
+SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
+SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
+
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val,
@@ -65,6 +75,9 @@ SCM_API SCM scm_with_fluid (SCM fluid, SCM val, SCM thunk);
SCM_API void scm_dynwind_fluid (SCM fluid, SCM value);
+#define SCM_I_DYNAMIC_STATE_P(x) (!SCM_IMP (x) && SCM_TYP7 (x) ==
scm_tc7_dynamic_state)
+#define SCM_I_DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
+
SCM_API SCM scm_make_dynamic_state (SCM parent);
SCM_API SCM scm_dynamic_state_p (SCM obj);
SCM_API int scm_is_dynamic_state (SCM obj);
@@ -79,6 +92,7 @@ SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void);
SCM_INTERNAL void scm_i_fluid_print (SCM exp, SCM port, scm_print_state
*pstate);
SCM_INTERNAL void scm_i_dynamic_state_print (SCM exp, SCM port,
scm_print_state *pstate);
+SCM_INTERNAL void scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state
*pstate);
SCM_INTERNAL void scm_init_fluids (void);
#endif /* SCM_FLUIDS_H */
diff --git a/libguile/foreign.c b/libguile/foreign.c
new file mode 100644
index 0000000..eaeea6c
--- /dev/null
+++ b/libguile/foreign.c
@@ -0,0 +1,1115 @@
+/* Copyright (C) 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <ffi.h>
+
+#include <alignof.h>
+#include <string.h>
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/instructions.h"
+#include "libguile/foreign.h"
+
+
+
+SCM_SYMBOL (sym_void, "void");
+SCM_SYMBOL (sym_float, "float");
+SCM_SYMBOL (sym_double, "double");
+SCM_SYMBOL (sym_uint8, "uint8");
+SCM_SYMBOL (sym_int8, "int8");
+SCM_SYMBOL (sym_uint16, "uint16");
+SCM_SYMBOL (sym_int16, "int16");
+SCM_SYMBOL (sym_uint32, "uint32");
+SCM_SYMBOL (sym_int32, "int32");
+SCM_SYMBOL (sym_uint64, "uint64");
+SCM_SYMBOL (sym_int64, "int64");
+SCM_SYMBOL (sym_int, "int");
+SCM_SYMBOL (sym_long, "long");
+SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
+SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
+SCM_SYMBOL (sym_size_t, "size_t");
+
+/* that's for pointers, you know. */
+SCM_SYMBOL (sym_asterisk, "*");
+
+SCM_SYMBOL (sym_null, "%null-pointer");
+SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
+
+/* The cell representing the null pointer. */
+static const scm_t_bits null_pointer[2] =
+ {
+ scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8UL),
+ 0
+ };
+
+/* Raise a null pointer dereference error. */
+static void
+null_pointer_error (const char *func_name)
+{
+ scm_error (sym_null_pointer_error, func_name,
+ "null pointer dereference", SCM_EOL, SCM_EOL);
+}
+
+
+static SCM cif_to_procedure (SCM cif, SCM func_ptr);
+
+
+static SCM foreign_weak_refs = SCM_BOOL_F;
+
+static void
+register_weak_reference (SCM from, SCM to)
+{
+ scm_hashq_set_x (foreign_weak_refs, from, to);
+}
+
+static void
+foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+{
+ scm_t_foreign_finalizer finalizer = data;
+ finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
+}
+
+SCM
+scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
+ scm_t_foreign_finalizer finalizer)
+{
+ SCM ret;
+ scm_t_bits word0;
+
+ word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
+ | (finalizer ? (1<<16) : 0) | (len<<17));
+ if (SCM_UNLIKELY ((word0 >> 17) != len))
+ scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
+
+ ret = scm_cell (word0, (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),
+ foreign_finalizer_trampoline,
+ finalizer,
+ &prev_finalizer,
+ &prev_finalizer_data);
+ }
+
+ return ret;
+}
+
+SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
+ (SCM foreign),
+ "Reference the foreign value pointed to by @var{foreign}.\n\n"
+ "The value will be referenced according to its type.")
+#define FUNC_NAME s_scm_foreign_ref
+{
+ scm_t_foreign_type ftype;
+ scm_t_uint8 *ptr;
+
+ SCM_VALIDATE_FOREIGN (1, foreign);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
+ ftype = SCM_FOREIGN_TYPE (foreign);
+
+ /* FIXME: is there a window in which we can see ptr but not foreign? */
+ /* FIXME: accessing unaligned pointers */
+ switch (ftype)
+ {
+ case SCM_FOREIGN_TYPE_VOID:
+ return scm_from_ulong ((unsigned long)ptr);
+ case SCM_FOREIGN_TYPE_FLOAT:
+ return scm_from_double (*(float*)ptr);
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ return scm_from_double (*(double*)ptr);
+ case SCM_FOREIGN_TYPE_UINT8:
+ return scm_from_uint8 (*(scm_t_uint8*)ptr);
+ case SCM_FOREIGN_TYPE_INT8:
+ return scm_from_int8 (*(scm_t_int8*)ptr);
+ case SCM_FOREIGN_TYPE_UINT16:
+ return scm_from_uint16 (*(scm_t_uint16*)ptr);
+ case SCM_FOREIGN_TYPE_INT16:
+ return scm_from_int16 (*(scm_t_int16*)ptr);
+ case SCM_FOREIGN_TYPE_UINT32:
+ return scm_from_uint32 (*(scm_t_uint32*)ptr);
+ case SCM_FOREIGN_TYPE_INT32:
+ return scm_from_int32 (*(scm_t_int32*)ptr);
+ case SCM_FOREIGN_TYPE_UINT64:
+ return scm_from_uint64 (*(scm_t_uint64*)ptr);
+ case SCM_FOREIGN_TYPE_INT64:
+ return scm_from_int64 (*(scm_t_int64*)ptr);
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, foreign, "foreign");
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
+ (SCM foreign, SCM val),
+ "Set the foreign value pointed to by @var{foreign}.\n\n"
+ "The value will be set according to its type.")
+#define FUNC_NAME s_scm_foreign_set_x
+{
+ scm_t_foreign_type ftype;
+ scm_t_uint8 *ptr;
+
+ SCM_VALIDATE_FOREIGN (1, foreign);
+
+ if (SCM_UNLIKELY (scm_is_eq (foreign, PTR2SCM (&null_pointer))))
+ /* Attempting to modify the pointer value of NULL_POINTER (which is
+ read-only anyway), so raise an error. */
+ null_pointer_error (FUNC_NAME);
+
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
+ ftype = SCM_FOREIGN_TYPE (foreign);
+
+ /* FIXME: is there a window in which we can see ptr but not foreign? */
+ /* FIXME: unaligned access */
+ switch (ftype)
+ {
+ case SCM_FOREIGN_TYPE_VOID:
+ SCM_SET_CELL_WORD_1 (foreign, scm_to_ulong (val));
+ break;
+ case SCM_FOREIGN_TYPE_FLOAT:
+ *(float*)ptr = scm_to_double (val);
+ break;
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ *(double*)ptr = scm_to_double (val);
+ break;
+ case SCM_FOREIGN_TYPE_UINT8:
+ *(scm_t_uint8*)ptr = scm_to_uint8 (val);
+ break;
+ case SCM_FOREIGN_TYPE_INT8:
+ *(scm_t_int8*)ptr = scm_to_int8 (val);
+ break;
+ case SCM_FOREIGN_TYPE_UINT16:
+ *(scm_t_uint16*)ptr = scm_to_uint16 (val);
+ break;
+ case SCM_FOREIGN_TYPE_INT16:
+ *(scm_t_int16*)ptr = scm_to_int16 (val);
+ break;
+ case SCM_FOREIGN_TYPE_UINT32:
+ *(scm_t_uint32*)ptr = scm_to_uint32 (val);
+ break;
+ case SCM_FOREIGN_TYPE_INT32:
+ *(scm_t_int32*)ptr = scm_to_int32 (val);
+ break;
+ case SCM_FOREIGN_TYPE_UINT64:
+ *(scm_t_uint64*)ptr = scm_to_uint64 (val);
+ break;
+ case SCM_FOREIGN_TYPE_INT64:
+ *(scm_t_int64*)ptr = scm_to_int64 (val);
+ break;
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, val, "foreign");
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
+ (SCM foreign, SCM uvec_type, SCM offset, SCM len),
+ "Return a bytevector aliasing the memory pointed to by\n"
+ "@var{foreign}.\n\n"
+ "@var{foreign} must be a void pointer, a foreign whose type is\n"
+ "@var{void}. By default, the resulting bytevector will alias\n"
+ "all of the memory pointed to by @var{foreign}, from beginning\n"
+ "to end, treated as a @code{vu8} array.\n\n"
+ "The user may specify an alternate default interpretation for\n"
+ "the memory by passing the @var{uvec_type} argument, to indicate\n"
+ "that the memory is an array of elements of that type.\n"
+ "@var{uvec_type} should be something that\n"
+ "@code{uniform-vector-element-type} would return, like
@code{f32}\n"
+ "or @code{s16}.\n\n"
+ "Users may also specify that the bytevector should only alias a\n"
+ "subset of the memory, by specifying @var{offset} and @var{len}\n"
+ "arguments.")
+#define FUNC_NAME s_scm_foreign_to_bytevector
+{
+ SCM ret;
+ scm_t_int8 *ptr;
+ size_t boffset, blen;
+ scm_t_array_element_type btype;
+
+ SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8);
+
+ if (SCM_UNLIKELY (ptr == NULL))
+ null_pointer_error (FUNC_NAME);
+
+ if (SCM_UNBNDP (uvec_type))
+ btype = SCM_ARRAY_ELEMENT_TYPE_VU8;
+ else
+ {
+ int i;
+ for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
+ if (scm_is_eq (uvec_type, scm_i_array_element_types[i]))
+ break;
+ switch (i)
+ {
+ case SCM_ARRAY_ELEMENT_TYPE_VU8:
+ case SCM_ARRAY_ELEMENT_TYPE_U8:
+ case SCM_ARRAY_ELEMENT_TYPE_S8:
+ case SCM_ARRAY_ELEMENT_TYPE_U16:
+ case SCM_ARRAY_ELEMENT_TYPE_S16:
+ case SCM_ARRAY_ELEMENT_TYPE_U32:
+ case SCM_ARRAY_ELEMENT_TYPE_S32:
+ case SCM_ARRAY_ELEMENT_TYPE_U64:
+ case SCM_ARRAY_ELEMENT_TYPE_S64:
+ case SCM_ARRAY_ELEMENT_TYPE_F32:
+ case SCM_ARRAY_ELEMENT_TYPE_F64:
+ case SCM_ARRAY_ELEMENT_TYPE_C32:
+ case SCM_ARRAY_ELEMENT_TYPE_C64:
+ btype = i;
+ break;
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec_type,
+ "uniform vector type");
+ }
+ }
+
+ if (SCM_UNBNDP (offset))
+ boffset = 0;
+ else if (SCM_FOREIGN_LEN (foreign))
+ boffset = scm_to_unsigned_integer (offset, 0,
+ SCM_FOREIGN_LEN (foreign) - 1);
+ else
+ boffset = scm_to_size_t (offset);
+
+ if (SCM_UNBNDP (len))
+ {
+ if (SCM_FOREIGN_LEN (foreign))
+ blen = SCM_FOREIGN_LEN (foreign) - boffset;
+ else
+ scm_misc_error (FUNC_NAME,
+ "length needed to convert foreign pointer to
bytevector",
+ SCM_EOL);
+ }
+ else
+ {
+ if (SCM_FOREIGN_LEN (foreign))
+ blen = scm_to_unsigned_integer (len, 0,
+ SCM_FOREIGN_LEN (foreign) - boffset);
+ else
+ blen = scm_to_size_t (len);
+ }
+
+ ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
+ register_weak_reference (ret, foreign);
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_to_foreign, "bytevector->foreign", 1, 2, 0,
+ (SCM bv, SCM offset, SCM len),
+ "Return a foreign pointer aliasing the memory pointed to by\n"
+ "@var{bv}.\n\n"
+ "The resulting foreign will be a void pointer, a foreign whose\n"
+ "type is @code{void}. By default it will alias all of the\n"
+ "memory pointed to by @var{bv}, from beginning to end.\n\n"
+ "Users may explicily specify that the foreign should only alias
a\n"
+ "subset of the memory, by specifying @var{offset} and @var{len}\n"
+ "arguments.")
+#define FUNC_NAME s_scm_bytevector_to_foreign
+{
+ SCM ret;
+ scm_t_int8 *ptr;
+ size_t boffset, blen;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ ptr = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (SCM_UNBNDP (offset))
+ boffset = 0;
+ else
+ boffset = scm_to_unsigned_integer (offset, 0,
+ SCM_BYTEVECTOR_LENGTH (bv) - 1);
+
+ if (SCM_UNBNDP (len))
+ blen = SCM_BYTEVECTOR_LENGTH (bv) - boffset;
+ else
+ blen = scm_to_unsigned_integer (len, 0,
+ SCM_BYTEVECTOR_LENGTH (bv) - boffset);
+
+ ret = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, ptr + boffset, blen,
+ NULL);
+ register_weak_reference (ret, bv);
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
+ (SCM foreign, SCM finalizer),
+ "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
+ "called on the pointer wrapped by @var{foreign} when
@var{foreign}\n"
+ "becomes unreachable. Note: the C procedure should not call into\n"
+ "Scheme. If you need a Scheme finalizer, use guardians.")
+#define FUNC_NAME s_scm_foreign_set_finalizer_x
+{
+ void *c_finalizer;
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+
+ SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
+ SCM_VALIDATE_FOREIGN_TYPED (2, finalizer, VOID);
+
+ c_finalizer = SCM_FOREIGN_POINTER (finalizer, void);
+
+ SCM_SET_CELL_WORD_0 (foreign, SCM_CELL_WORD_0 (foreign) | (1<<16));
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (foreign),
+ foreign_finalizer_trampoline,
+ c_finalizer,
+ &prev_finalizer,
+ &prev_finalizer_data);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+void
+scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<foreign ", port);
+ switch (SCM_FOREIGN_TYPE (foreign))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ scm_puts ("float ", port);
+ break;
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ scm_puts ("double ", port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT8:
+ scm_puts ("uint8 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_INT8:
+ scm_puts ("int8 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT16:
+ scm_puts ("uint16 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_INT16:
+ scm_puts ("int16 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT32:
+ scm_puts ("uint32 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_INT32:
+ scm_puts ("int32 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT64:
+ scm_puts ("uint64 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_INT64:
+ scm_puts ("int64 ", port);
+ break;
+ case SCM_FOREIGN_TYPE_VOID:
+ scm_puts ("pointer ", port);
+ break;
+ default:
+ scm_wrong_type_arg_msg ("%print-foreign", 1, foreign, "foreign");
+ }
+ scm_display (scm_foreign_ref (foreign), port);
+ scm_putc ('>', port);
+}
+
+
+
+
+#define ROUND_UP(len,align) (align?(((len-1)|(align-1))+1):len)
+
+SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type),
+ "Return the alignment of @var{type}, in bytes.\n\n"
+ "@var{type} should be a valid C type, like @code{int}.\n"
+ "Alternately @var{type} may be the symbol @code{*}, in which\n"
+ "case the alignment of a pointer is returned. @var{type} may\n"
+ "also be a list of types, in which case the alignment of a\n"
+ "@code{struct} with ABI-conventional packing is returned.")
+#define FUNC_NAME s_scm_alignof
+{
+ if (SCM_I_INUMP (type))
+ {
+ switch (SCM_I_INUM (type))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ return scm_from_size_t (alignof (float));
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ return scm_from_size_t (alignof (double));
+ case SCM_FOREIGN_TYPE_UINT8:
+ return scm_from_size_t (alignof (scm_t_uint8));
+ case SCM_FOREIGN_TYPE_INT8:
+ return scm_from_size_t (alignof (scm_t_int8));
+ case SCM_FOREIGN_TYPE_UINT16:
+ return scm_from_size_t (alignof (scm_t_uint16));
+ case SCM_FOREIGN_TYPE_INT16:
+ return scm_from_size_t (alignof (scm_t_int16));
+ case SCM_FOREIGN_TYPE_UINT32:
+ return scm_from_size_t (alignof (scm_t_uint32));
+ case SCM_FOREIGN_TYPE_INT32:
+ return scm_from_size_t (alignof (scm_t_int32));
+ case SCM_FOREIGN_TYPE_UINT64:
+ return scm_from_size_t (alignof (scm_t_uint64));
+ case SCM_FOREIGN_TYPE_INT64:
+ return scm_from_size_t (alignof (scm_t_int64));
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+ }
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ return scm_from_size_t (alignof (void*));
+ else if (scm_is_pair (type))
+ /* a struct, yo */
+ return scm_alignof (scm_car (type));
+ else
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type),
+ "Return the size of @var{type}, in bytes.\n\n"
+ "@var{type} should be a valid C type, like @code{int}.\n"
+ "Alternately @var{type} may be the symbol @code{*}, in which\n"
+ "case the size of a pointer is returned. @var{type} may also\n"
+ "be a list of types, in which case the size of a @code{struct}\n"
+ "with ABI-conventional packing is returned.")
+#define FUNC_NAME s_scm_sizeof
+{
+ if (SCM_I_INUMP (type))
+ {
+ switch (SCM_I_INUM (type))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ return scm_from_size_t (sizeof (float));
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ return scm_from_size_t (sizeof (double));
+ case SCM_FOREIGN_TYPE_UINT8:
+ return scm_from_size_t (sizeof (scm_t_uint8));
+ case SCM_FOREIGN_TYPE_INT8:
+ return scm_from_size_t (sizeof (scm_t_int8));
+ case SCM_FOREIGN_TYPE_UINT16:
+ return scm_from_size_t (sizeof (scm_t_uint16));
+ case SCM_FOREIGN_TYPE_INT16:
+ return scm_from_size_t (sizeof (scm_t_int16));
+ case SCM_FOREIGN_TYPE_UINT32:
+ return scm_from_size_t (sizeof (scm_t_uint32));
+ case SCM_FOREIGN_TYPE_INT32:
+ return scm_from_size_t (sizeof (scm_t_int32));
+ case SCM_FOREIGN_TYPE_UINT64:
+ return scm_from_size_t (sizeof (scm_t_uint64));
+ case SCM_FOREIGN_TYPE_INT64:
+ return scm_from_size_t (sizeof (scm_t_int64));
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+ }
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ return scm_from_size_t (sizeof (void*));
+ else if (scm_is_pair (type))
+ {
+ /* a struct */
+ size_t off = 0;
+ while (scm_is_pair (type))
+ {
+ off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
+ off += scm_to_size_t (scm_sizeof (scm_car (type)));
+ type = scm_cdr (type);
+ }
+ return scm_from_size_t (off);
+ }
+ else
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+}
+#undef FUNC_NAME
+
+
+/* return 1 on success, 0 on failure */
+static int
+parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
+{
+ if (SCM_I_INUMP (type))
+ {
+ if ((SCM_I_INUM (type) < 0 )
+ || (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
+ return 0;
+ else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
+ return 0;
+ else
+ return 1;
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ return 1;
+ else
+ {
+ long len;
+
+ len = scm_ilength (type);
+ if (len < 1)
+ return 0;
+ while (len--)
+ {
+ if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
+ return 0;
+ (*n_struct_elts)++;
+ type = scm_cdr (type);
+ }
+ (*n_structs)++;
+ return 1;
+ }
+}
+
+static void
+fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
+ ffi_type **types)
+{
+ if (SCM_I_INUMP (type))
+ {
+ switch (SCM_I_INUM (type))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ *ftype = ffi_type_float;
+ return;
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ *ftype = ffi_type_double;
+ return;
+ case SCM_FOREIGN_TYPE_UINT8:
+ *ftype = ffi_type_uint8;
+ return;
+ case SCM_FOREIGN_TYPE_INT8:
+ *ftype = ffi_type_sint8;
+ return;
+ case SCM_FOREIGN_TYPE_UINT16:
+ *ftype = ffi_type_uint16;
+ return;
+ case SCM_FOREIGN_TYPE_INT16:
+ *ftype = ffi_type_sint16;
+ return;
+ case SCM_FOREIGN_TYPE_UINT32:
+ *ftype = ffi_type_uint32;
+ return;
+ case SCM_FOREIGN_TYPE_INT32:
+ *ftype = ffi_type_sint32;
+ return;
+ case SCM_FOREIGN_TYPE_UINT64:
+ *ftype = ffi_type_uint64;
+ return;
+ case SCM_FOREIGN_TYPE_INT64:
+ *ftype = ffi_type_sint64;
+ return;
+ case SCM_FOREIGN_TYPE_VOID:
+ *ftype = ffi_type_void;
+ return;
+ default:
+ scm_wrong_type_arg_msg ("make-foreign-function", 0, type,
+ "foreign type");
+ }
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ {
+ *ftype = ffi_type_pointer;
+ return;
+ }
+ else
+ {
+ long i, len;
+
+ len = scm_ilength (type);
+
+ ftype->size = 0;
+ ftype->alignment = 0;
+ ftype->type = FFI_TYPE_STRUCT;
+ ftype->elements = *type_ptrs;
+ *type_ptrs += len + 1;
+
+ for (i = 0; i < len; i++)
+ {
+ ftype->elements[i] = *types;
+ *types += 1;
+ fill_ffi_type (scm_car (type), ftype->elements[i],
+ type_ptrs, types);
+ type = scm_cdr (type);
+ }
+ ftype->elements[i] = NULL;
+ }
+}
+
+SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
+ (SCM return_type, SCM func_ptr, SCM arg_types),
+ "Make a foreign function.\n\n"
+ "Given the foreign void pointer @var{func_ptr}, its argument and\n"
+ "return types @var{arg_types} and @var{return_type}, return a\n"
+ "procedure that will pass arguments to the foreign function\n"
+ "and return appropriate values.\n\n"
+ "@var{arg_types} should be a list of foreign types.\n"
+ "@code{return_type} should be a foreign type.")
+#define FUNC_NAME s_scm_make_foreign_function
+{
+ SCM walk, scm_cif;
+ long i, nargs, n_structs, n_struct_elts;
+ size_t cif_len;
+ char *mem;
+ ffi_cif *cif;
+ ffi_type **type_ptrs;
+ ffi_type *types;
+
+ SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
+ nargs = scm_ilength (arg_types);
+ SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
+ /* fixme: assert nargs < 1<<32 */
+ n_structs = n_struct_elts = 0;
+
+ /* For want of talloc, we're going to have to do this in two passes: first we
+ figure out how much memory is needed for all types, then we allocate the
+ cif and the types all in one block. */
+ if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
+ scm_wrong_type_arg (FUNC_NAME, 1, return_type);
+ for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
+ if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
+ scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
+
+ /* the memory: with space for the cif itself */
+ cif_len = sizeof (ffi_cif);
+
+ /* then ffi_type pointers: one for each arg, one for each struct
+ element, and one for each struct (for null-termination) */
+ cif_len = (ROUND_UP (cif_len, alignof(void*))
+ + (nargs + n_structs + n_struct_elts)*sizeof(void*));
+
+ /* then the ffi_type structs themselves, one per arg and struct element, and
+ one for the return val */
+ cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
+ + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
+
+ mem = scm_gc_malloc_pointerless (cif_len, "foreign");
+ scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem,
+ cif_len, NULL);
+ cif = (ffi_cif *) mem;
+
+ /* reuse cif_len to walk through the mem */
+ cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
+ type_ptrs = (ffi_type**)(mem + cif_len);
+ cif_len = ROUND_UP (cif_len
+ + (nargs + n_structs + n_struct_elts)*sizeof(void*),
+ alignof(ffi_type));
+ types = (ffi_type*)(mem + cif_len);
+
+ /* whew. now knit the pointers together. */
+ cif->rtype = types++;
+ fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
+ cif->arg_types = type_ptrs;
+ type_ptrs += nargs;
+ for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
+ {
+ cif->arg_types[i] = types++;
+ fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
+ }
+
+ /* round out the cif, and we're done. */
+ cif->abi = FFI_DEFAULT_ABI;
+ cif->nargs = nargs;
+ cif->bytes = 0;
+ cif->flags = 0;
+
+ if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
+ cif->arg_types))
+ scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
+
+ return cif_to_procedure (scm_cif, func_ptr);
+}
+#undef FUNC_NAME
+
+
+
+/* Pre-generate trampolines for less than 10 arguments. */
+
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
+#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
+#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+#define CODE(nreq) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
+ /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function
pointer */ \
+ /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well)
*/ \
+ /* 7 */ scm_op_nop, \
+ /* 8 */ META (3, 7, nreq)
+
+#define META(start, end, nreq) \
+ 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_list, 0, 3, /* make a list of those 3 vals */ \
+ /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */ \
+ /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
+ /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
+ /* 24 */ scm_op_cons, /* make a pair for the properties */ \
+ /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list
*/ \
+ /* 28 */ scm_op_return, /* and return */ \
+ /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
+ /* 32 */
+
+static const struct
+{
+ scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way
*/
+ const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
+ + sizeof (struct scm_objcode) + 32)];
+} raw_bytecode = {
+ 0,
+ {
+ CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
+ CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
+ }
+};
+
+#undef CODE
+#undef META
+#undef OBJCODE_HEADER
+#undef META_HEADER
+
+/*
+ (defun generate-objcode-cells (n)
+ "Generate objcode cells for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (< i n)
+ (insert
+ (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d)
},\n"
+ (* (+ 4 4 8 4 4 32) i)))
+ (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
+ (setq i (1+ i)))))
+*/
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+static const struct
+{
+ scm_t_uint64 dummy; /* alignment */
+ scm_t_cell cells[10 * 2]; /* 10 double cells */
+} objcode_cells = {
+ 0,
+ /* C-u 1 0 M-x generate-objcode-cells RET */
+ {
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
+ { 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 + 504) },
+ { SCM_BOOL_F, SCM_PACK (0) }
+ }
+};
+
+static const SCM objcode_trampolines[10] = {
+ SCM_PACK (objcode_cells.cells+0),
+ SCM_PACK (objcode_cells.cells+2),
+ SCM_PACK (objcode_cells.cells+4),
+ SCM_PACK (objcode_cells.cells+6),
+ 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),
+ SCM_PACK (objcode_cells.cells+18),
+};
+
+static SCM
+cif_to_procedure (SCM cif, SCM func_ptr)
+{
+ unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
+ SCM objcode, table, ret;
+
+ if (nargs < 10)
+ objcode = objcode_trampolines[nargs];
+ else
+ scm_misc_error ("make-foreign-function", "args >= 10 currently
unimplemented",
+ SCM_EOL);
+
+ table = scm_c_make_vector (2, SCM_UNDEFINED);
+ SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
+ SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
+ ret = scm_make_program (objcode, table, SCM_BOOL_F);
+
+ return ret;
+}
+
+/* Set *LOC to the foreign representation of X with TYPE. */
+static void
+unpack (const ffi_type *type, void *loc, SCM x)
+{
+ switch (type->type)
+ {
+ case FFI_TYPE_FLOAT:
+ *(float *) loc = scm_to_double (x);
+ break;
+ case FFI_TYPE_DOUBLE:
+ *(double *) loc = scm_to_double (x);
+ break;
+ case FFI_TYPE_UINT8:
+ *(scm_t_uint8 *) loc = scm_to_uint8 (x);
+ break;
+ case FFI_TYPE_SINT8:
+ *(scm_t_int8 *) loc = scm_to_int8 (x);
+ break;
+ case FFI_TYPE_UINT16:
+ *(scm_t_uint16 *) loc = scm_to_uint16 (x);
+ break;
+ case FFI_TYPE_SINT16:
+ *(scm_t_int16 *) loc = scm_to_int16 (x);
+ break;
+ case FFI_TYPE_UINT32:
+ *(scm_t_uint32 *) loc = scm_to_uint32 (x);
+ break;
+ case FFI_TYPE_SINT32:
+ *(scm_t_int32 *) loc = scm_to_int32 (x);
+ break;
+ case FFI_TYPE_UINT64:
+ *(scm_t_uint64 *) loc = scm_to_uint64 (x);
+ break;
+ case FFI_TYPE_SINT64:
+ *(scm_t_int64 *) loc = scm_to_int64 (x);
+ break;
+ case FFI_TYPE_STRUCT:
+ if (!SCM_FOREIGN_TYPED_P (x, VOID))
+ scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
+ if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
+ scm_wrong_type_arg_msg ("foreign-call", 0, x,
+ "foreign void pointer of correct length");
+ memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
+ break;
+ case FFI_TYPE_POINTER:
+ if (!SCM_FOREIGN_TYPED_P (x, VOID))
+ scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
+ *(void **) loc = SCM_FOREIGN_POINTER (x, void);
+ break;
+ default:
+ abort ();
+ }
+}
+
+/* Return a Scheme representation of the foreign value at LOC of type TYPE. */
+static SCM
+pack (const ffi_type * type, const void *loc)
+{
+ switch (type->type)
+ {
+ case FFI_TYPE_VOID:
+ return SCM_UNSPECIFIED;
+ case FFI_TYPE_FLOAT:
+ return scm_from_double (*(float *) loc);
+ case FFI_TYPE_DOUBLE:
+ return scm_from_double (*(double *) loc);
+ case FFI_TYPE_UINT8:
+ return scm_from_uint8 (*(scm_t_uint8 *) loc);
+ case FFI_TYPE_SINT8:
+ return scm_from_int8 (*(scm_t_int8 *) loc);
+ case FFI_TYPE_UINT16:
+ return scm_from_uint16 (*(scm_t_uint16 *) loc);
+ case FFI_TYPE_SINT16:
+ return scm_from_int16 (*(scm_t_int16 *) loc);
+ case FFI_TYPE_UINT32:
+ return scm_from_uint32 (*(scm_t_uint32 *) loc);
+ case FFI_TYPE_SINT32:
+ return scm_from_int32 (*(scm_t_int32 *) loc);
+ case FFI_TYPE_UINT64:
+ return scm_from_uint64 (*(scm_t_uint64 *) loc);
+ case FFI_TYPE_SINT64:
+ return scm_from_int64 (*(scm_t_int64 *) loc);
+ case FFI_TYPE_STRUCT:
+ {
+ void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
+ memcpy (mem, loc, type->size);
+ return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ mem, type->size, NULL);
+ }
+ case FFI_TYPE_POINTER:
+ return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ *(void **) loc, 0, NULL);
+ default:
+ abort ();
+ }
+}
+
+
+SCM
+scm_i_foreign_call (SCM foreign, const SCM *argv)
+{
+ /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
+ objtable. */
+ ffi_cif *cif;
+ void (*func) (void);
+ scm_t_uint8 *data;
+ void *rvalue;
+ void **args;
+ unsigned i;
+ size_t arg_size;
+ scm_t_ptrdiff off;
+
+ cif = SCM_FOREIGN_POINTER (SCM_CAR (foreign), ffi_cif);
+ func = SCM_FOREIGN_POINTER (SCM_CDR (foreign), void);
+
+ /* Argument pointers. */
+ args = alloca (sizeof (void *) * cif->nargs);
+
+ /* Compute the amount of memory needed to store all the argument values.
+ Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero, so it
+ can't be used for that purpose. */
+ for (i = 0, arg_size = 0;
+ i < cif->nargs;
+ i++, arg_size)
+ arg_size += ROUND_UP (cif->arg_types[i]->size,
+ cif->arg_types[i]->alignment);
+
+ /* Space for argument values, followed by return value. */
+ data = alloca (arg_size
+ + ROUND_UP (cif->rtype->size, cif->rtype->alignment));
+
+ /* Unpack ARGV to native values, setting ARGV pointers. */
+ for (i = 0, off = 0;
+ i < cif->nargs;
+ off += cif->arg_types[i]->size, i++)
+ {
+ off = ROUND_UP (off, cif->arg_types[i]->alignment);
+ args[i] = data + off;
+ unpack (cif->arg_types[i], args[i], argv[i]);
+ }
+
+ /* Prepare space for the return value. */
+ off = ROUND_UP (off, cif->rtype->alignment);
+ rvalue = data + off;
+
+ /* off we go! */
+ ffi_call (cif, func, rvalue, args);
+
+ return pack (cif->rtype, rvalue);
+}
+
+
+
+static void
+scm_init_foreign (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/foreign.x"
+#endif
+ scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
+ scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
+ scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
+ scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
+ scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
+ scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
+ scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
+ scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
+ scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
+ scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
+ scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
+
+ scm_define (sym_int,
+#if SIZEOF_INT == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SIZEOF_INT == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#else
+# error unsupported sizeof (int)
+#endif
+ );
+
+ scm_define (sym_unsigned_int,
+#if SIZEOF_UNSIGNED_INT == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
+#elif SIZEOF_UNSIGNED_INT == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
+#else
+# error unsupported sizeof (unsigned int)
+#endif
+ );
+
+ scm_define (sym_long,
+#if SIZEOF_LONG == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SIZEOF_LONG == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#else
+# error unsupported sizeof (long)
+#endif
+ );
+
+ scm_define (sym_unsigned_long,
+#if SIZEOF_UNSIGNED_LONG == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
+#elif SIZEOF_UNSIGNED_LONG == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
+#else
+# error unsupported sizeof (unsigned long)
+#endif
+ );
+
+ scm_define (sym_size_t,
+#if SIZEOF_SIZE_T == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
+#elif SIZEOF_SIZE_T == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
+#else
+# error unsupported sizeof (size_t)
+#endif
+ );
+
+ scm_define (sym_null, PTR2SCM (&null_pointer));
+}
+
+void
+scm_register_foreign (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_foreign",
+ (scm_t_extension_init_func)scm_init_foreign,
+ NULL);
+ foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/foreign.h b/libguile/foreign.h
new file mode 100644
index 0000000..a162d5d
--- /dev/null
+++ b/libguile/foreign.h
@@ -0,0 +1,131 @@
+#ifndef SCM_FOREIGN_H
+#define SCM_FOREIGN_H
+
+/* Copyright (C) 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include "libguile/__scm.h"
+
+/* A foreign value is some value that exists outside of Guile. It is
represented
+ by a cell whose second word is a pointer. The first word has the
+ scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its
+ lower 16 bits.
+
+ There are numeric types, like uint32 and float, and there is a "generic
+ pointer" type, void. Void pointers also have a length associated with them,
+ in the high bits of the first word of the SCM object, but since they really
+ are pointers out into the wild wooly world of C, perhaps we don't actually
+ know how much memory they take up. In that, most general case, the "len"
+ will be stored as 0.
+
+ The basic idea is that we can help the programmer to avoid cutting herself,
+ but we won't take away her knives.
+*/
+typedef enum
+ {
+ SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */
+ SCM_FOREIGN_TYPE_FLOAT,
+ SCM_FOREIGN_TYPE_DOUBLE,
+ SCM_FOREIGN_TYPE_UINT8,
+ SCM_FOREIGN_TYPE_INT8,
+ SCM_FOREIGN_TYPE_UINT16,
+ SCM_FOREIGN_TYPE_INT16,
+ SCM_FOREIGN_TYPE_UINT32,
+ SCM_FOREIGN_TYPE_INT32,
+ SCM_FOREIGN_TYPE_UINT64,
+ SCM_FOREIGN_TYPE_INT64,
+ SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
+ } scm_t_foreign_type;
+
+
+typedef void (*scm_t_foreign_finalizer) (void *);
+
+#define SCM_FOREIGN_P(x) \
+ (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign)
+#define SCM_VALIDATE_FOREIGN(pos, x) \
+ SCM_MAKE_VALIDATE (pos, x, FOREIGN_P)
+#define SCM_FOREIGN_TYPE(x) \
+ ((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff))
+#define SCM_FOREIGN_POINTER(x, ctype) \
+ ((ctype*)SCM_CELL_WORD_1 (x))
+#define SCM_FOREIGN_VALUE_REF(x, ctype) \
+ (*SCM_FOREIGN_POINTER (x, ctype))
+#define SCM_FOREIGN_VALUE_SET(x, ctype, val) \
+ (*SCM_FOREIGN_POINTER (x, ctype) = (val))
+#define SCM_FOREIGN_HAS_FINALIZER(x) \
+ ((SCM_CELL_WORD_0 (x) >> 16) & 0x1)
+#define SCM_FOREIGN_LEN(x) \
+ ((size_t)(SCM_CELL_WORD_0 (x) >> 17))
+
+#define SCM_FOREIGN_TYPED_P(x, type) \
+ (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type)
+#define SCM_VALIDATE_FOREIGN_TYPED(pos, x, type) \
+ do { \
+ SCM_ASSERT_TYPE (SCM_FOREIGN_TYPED_P (x, type), x, pos, FUNC_NAME, \
+ "FOREIGN_"#type"_P"); \
+ } while (0)
+
+#define SCM_FOREIGN_VALUE_P(x) \
+ (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID)
+#define SCM_VALIDATE_FOREIGN_VALUE(pos, x) \
+ SCM_MAKE_VALIDATE (pos, x, FOREIGN_VALUE_P)
+
+SCM_API SCM scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr,
+ size_t len,
+ scm_t_foreign_finalizer finalizer);
+
+SCM_API SCM scm_alignof (SCM type);
+SCM_API SCM scm_sizeof (SCM type);
+SCM_API SCM scm_foreign_type (SCM foreign);
+SCM_API SCM scm_foreign_ref (SCM foreign);
+SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val);
+SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type,
+ SCM offset, SCM len);
+SCM_API SCM scm_foreign_set_finalizer_x (SCM foreign, SCM finalizer);
+SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len);
+
+SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
+ scm_print_state *pstate);
+
+
+
+/* Foreign functions */
+
+/* The goal is to make it so that calling a foreign function doesn't cause any
+ heap allocation. That means we need native Scheme formats for all kinds of
+ arguments.
+
+ For "value" types like s64 or f32, we just use native Scheme value types.
+ (Note that in both these cases, allocation is possible / likely, as the
+ value might need to be boxed, but perhaps we won't worry about that. Hmm.)
+
+ For everything else, we use foreign pointers. This includes arrays, pointer
+ arguments and return vals, struct args and return vals, and out and in/out
+ arguments.
+ */
+
+SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
+ SCM arg_types);
+SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);
+
+
+
+SCM_INTERNAL void scm_register_foreign (void);
+
+
+#endif /* SCM_FOREIGN_H */
diff --git a/libguile/fports.c b/libguile/fports.c
index 3e911f2..232c436 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010 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
@@ -688,29 +688,9 @@ fport_truncate (SCM port, scm_t_off length)
scm_syserror ("ftruncate");
}
-/* helper for fport_write: try to write data, using multiple system
- calls if required. */
-#define FUNC_NAME "write_all"
-static void write_all (SCM port, const void *data, size_t remaining)
-{
- int fdes = SCM_FSTREAM (port)->fdes;
-
- while (remaining > 0)
- {
- size_t done;
-
- SCM_SYSCALL (done = write (fdes, data, remaining));
-
- if (done == -1)
- SCM_SYSERROR;
- remaining -= done;
- data = ((const char *) data) + done;
- }
-}
-#undef FUNC_NAME
-
static void
fport_write (SCM port, const void *data, size_t size)
+#define FUNC_NAME "fport_write"
{
/* this procedure tries to minimize the number of writes/flushes. */
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -718,9 +698,11 @@ fport_write (SCM port, const void *data, size_t size)
if (pt->write_buf == &pt->shortbuf
|| (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
{
- /* "unbuffered" port, or
- port with empty buffer and data won't fit in buffer. */
- write_all (port, data, size);
+ /* Unbuffered port, or port with empty buffer and data won't fit in
+ buffer. */
+ if (full_write (SCM_FPORT_FDES (port), data, size) < size)
+ SCM_SYSERROR;
+
return;
}
@@ -750,7 +732,9 @@ fport_write (SCM port, const void *data, size_t size)
if (size >= pt->write_buf_size)
{
- write_all (port, ptr, remaining);
+ if (full_write (SCM_FPORT_FDES (port), ptr, remaining)
+ < remaining)
+ SCM_SYSERROR;
return;
}
else
@@ -766,6 +750,7 @@ fport_write (SCM port, const void *data, size_t size)
fport_flush (port);
}
}
+#undef FUNC_NAME
/* becomes 1 when process is exiting: normal exception handling won't
work by this time. */
diff --git a/libguile/frames.c b/libguile/frames.c
index 5c61eb0..f8eed86 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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
@@ -23,12 +23,9 @@
#include <stdlib.h>
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "frames.h"
-scm_t_bits scm_tc16_frame;
-
#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM
@@ -42,11 +39,11 @@ scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
p->sp = sp;
p->ip = ip;
p->offset = offset;
- SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
+ return scm_cell (scm_tc7_frame, (scm_t_bits)p);
}
-static int
-frame_print (SCM frame, SCM port, scm_print_state *pstate)
+void
+scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
scm_puts ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
@@ -54,8 +51,6 @@ frame_print (SCM frame, SCM port, scm_print_state *pstate)
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts (">", port);
-
- return 1;
}
@@ -97,24 +92,17 @@ SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_frame_source
+SCM
+scm_frame_source (SCM frame)
{
- SCM *fp;
- struct scm_objcode *bp;
+ static SCM var = SCM_BOOL_F;
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ if (scm_is_false (var))
+ var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
+ "frame-source");
- return scm_c_program_source (SCM_FRAME_PROGRAM (fp),
- SCM_VM_FRAME_IP (frame)
- - SCM_C_OBJCODE_BASE (bp));
+ return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
-#undef FUNC_NAME
/* The number of locals would be a simple thing to compute, if it weren't for
the presence of not-yet-active frames on the stack. So we have a cheap
@@ -300,19 +288,8 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
void
-scm_bootstrap_frames (void)
-{
- scm_tc16_frame = scm_make_smob_type ("frame", 0);
- scm_set_smob_print (scm_tc16_frame, frame_print);
- scm_c_register_extension ("libguile", "scm_init_frames",
- (scm_t_extension_init_func)scm_init_frames, NULL);
-}
-
-void
scm_init_frames (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/frames.x"
#endif
diff --git a/libguile/frames.h b/libguile/frames.h
index 0636fe8..33432eb 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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
@@ -87,8 +87,6 @@
* Heap frames
*/
-SCM_API scm_t_bits scm_tc16_frame;
-
struct scm_frame
{
SCM stack_holder;
@@ -98,8 +96,8 @@ struct scm_frame
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, x)
-#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_CELL_WORD_1 (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
@@ -122,7 +120,8 @@ SCM_API SCM scm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_frame_dynamic_link (SCM frame);
SCM_API SCM scm_frame_previous (SCM frame);
-SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_i_frame_print (SCM frame, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index 9f6c376..e409b6e 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2008, 2009, 2010 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
@@ -180,17 +180,6 @@ scm_gc_malloc_pointerless (size_t size, const char *what)
void *
scm_gc_malloc (size_t size, const char *what)
{
- /*
- The straightforward implementation below has the problem
- that it might call the GC twice, once in scm_malloc and then
- again in scm_gc_register_collectable_memory. We don't really
- want the second GC since it will not find new garbage.
-
- Note: this is a theoretical peeve. In reality, malloc () never
- returns NULL. Usually, memory is overcommitted, and when you try
- to write it the program is killed with signal 11. --hwn
- */
-
void *ptr;
if (size == 0)
@@ -255,17 +244,11 @@ scm_gc_strdup (const char *str, const char *what)
* scm_done_free
*
* These functions provide services comparable to malloc, realloc, and
- * free. They should be used when allocating memory that will be under
- * control of the garbage collector, i.e., if the memory may be freed
- * during garbage collection.
+ * free.
*
- * They are deprecated because they weren't really used the way
- * outlined above, and making sure to return the right amount from
- * smob free routines was sometimes difficult when dealing with nested
- * data structures. We basically want everybody to review their code
- * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
- * instead. In some cases, where scm_must_malloc has been used
- * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
+ * There has been a fair amount of confusion around the use of these functions;
+ * see "Memory Blocks" in the manual. They are totally unnecessary in 2.0 given
+ * the Boehm GC.
*/
void *
@@ -323,7 +306,7 @@ scm_must_free (void *obj)
scm_malloc_unregister (obj);
#endif
- free (obj);
+ GC_FREE (obj);
}
#undef FUNC_NAME
diff --git a/libguile/gc.c b/libguile/gc.c
index e33d43e..fc405f3 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 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010 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
@@ -89,7 +89,10 @@ int scm_debug_cells_gc_interval = 0;
*/
int scm_i_cell_validation_already_running ;
-static SCM protects;
+/* Hash table that keeps a reference to objects the user wants to protect from
+ garbage collection. It could arguably be private but applications have come
+ to rely on it (e.g., Lilypond 2.13.9). */
+SCM scm_protects;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
@@ -507,7 +510,7 @@ scm_gc_protect_object (SCM obj)
critsec/mutex inconsistency here. */
SCM_CRITICAL_SECTION_START;
- handle = scm_hashq_create_handle_x (protects, obj, scm_from_int (0));
+ handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
protected_obj_count ++;
@@ -537,7 +540,7 @@ scm_gc_unprotect_object (SCM obj)
abort ();
}
- handle = scm_hashq_get_handle (protects, obj);
+ handle = scm_hashq_get_handle (scm_protects, obj);
if (scm_is_false (handle))
{
@@ -548,7 +551,7 @@ scm_gc_unprotect_object (SCM obj)
{
SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
if (scm_is_eq (count, scm_from_int (0)))
- scm_hashq_remove_x (protects, obj);
+ scm_hashq_remove_x (scm_protects, obj);
else
SCM_SETCDR (handle, count);
}
@@ -636,7 +639,7 @@ scm_storage_prehistory ()
/* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */
- if (!GC_is_visible (&protects))
+ if (!GC_is_visible (&scm_protects))
abort ();
scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
@@ -651,7 +654,7 @@ scm_i_pthread_mutex_t scm_i_gc_admin_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
void
scm_init_gc_protect_object ()
{
- protects = scm_c_make_hash_table (31);
+ scm_protects = scm_c_make_hash_table (31);
#if 0
/* We can't have a cleanup handler since we have no thread to run it
@@ -748,12 +751,22 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)";
case scm_tcs_cons_nimcar:
return "cons (non-immediate car)";
+ case scm_tc7_foreign:
+ return "foreign";
case scm_tc7_hashtable:
return "hashtable";
case scm_tc7_fluid:
return "fluid";
case scm_tc7_dynamic_state:
return "dynamic state";
+ case scm_tc7_frame:
+ return "frame";
+ case scm_tc7_objcode:
+ return "objcode";
+ case scm_tc7_vm:
+ return "vm";
+ case scm_tc7_vm_cont:
+ return "vm continuation";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
@@ -787,9 +800,6 @@ scm_i_tag_name (scm_t_bits tag)
case scm_tc7_variable:
return "variable";
break;
- case scm_tc7_gsubr:
- return "gsubr";
- break;
case scm_tc7_port:
return "port";
break;
diff --git a/libguile/gc.h b/libguile/gc.h
index 05b08af..8f05aab 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -3,7 +3,7 @@
#ifndef SCM_GC_H
#define SCM_GC_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007,
2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007,
2008, 2009, 2010 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
@@ -237,6 +237,7 @@ SCM_API void scm_gc_register_root (SCM *p);
SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
+SCM_API SCM scm_protects;
SCM_INTERNAL void scm_storage_prehistory (void);
SCM_INTERNAL void scm_init_gc_protect_object (void);
SCM_INTERNAL void scm_init_gc (void);
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index cf5f6c7..851578f 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -219,14 +219,6 @@ main (int argc, char *argv[])
pf ("#define GUILE_DEBUG 1 /* defined or undefined */\n");
else
pf ("/* #undef GUILE_DEBUG */\n");
-
- /*** GUILE_DEBUG_FREELIST (deined or undefined) ***/
- pf ("\n");
- pf ("/* Define this to debug the free list (helps w/ GC bugs). */\n");
- if (SCM_I_GSC_GUILE_DEBUG_FREELIST)
- pf ("#define GUILE_DEBUG_FREELIST 1 /* defined or undefined */\n");
- else
- pf ("/* #undef GUILE_DEBUG_FREELIST */\n");
/*** SCM_ENABLE_DISCOURAGED (0 or 1) ***/
pf ("\n");
@@ -240,11 +232,6 @@ main (int argc, char *argv[])
pf ("/* (value will be 0 or 1). */\n");
pf ("#define SCM_ENABLE_DEPRECATED %d\n", SCM_I_GSC_ENABLE_DEPRECATED);
- /*** SCM_ENABLE_ELISP (0 or 1) ***/
- pf ("\n");
- pf ("/* Set to 1 to add Elisp support (in addition to Scheme). */\n");
- pf ("#define SCM_ENABLE_ELISP %d /* 0 or 1 */\n", SCM_I_GSC_ENABLE_ELISP);
-
/*** SCM_STACK_GROWS_UP (0 or 1) ***/
pf ("\n");
pf ("/* Set to 1 if the stack grows up, 0 otherwise. */\n");
diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in
index 5d569f6..11c5197 100644
--- a/libguile/gen-scmconfig.h.in
+++ b/libguile/gen-scmconfig.h.in
@@ -7,10 +7,8 @@
*/
#define SCM_I_GSC_GUILE_DEBUG @SCM_I_GSC_GUILE_DEBUG@
-#define SCM_I_GSC_GUILE_DEBUG_FREELIST @SCM_I_GSC_GUILE_DEBUG_FREELIST@
#define SCM_I_GSC_ENABLE_DISCOURAGED @SCM_I_GSC_ENABLE_DISCOURAGED@
#define SCM_I_GSC_ENABLE_DEPRECATED @SCM_I_GSC_ENABLE_DEPRECATED@
-#define SCM_I_GSC_ENABLE_ELISP @SCM_I_GSC_ENABLE_ELISP@
#define SCM_I_GSC_STACK_GROWS_UP @SCM_I_GSC_STACK_GROWS_UP@
#define SCM_I_GSC_C_INLINE @SCM_I_GSC_C_INLINE@
#define SCM_I_GSC_NEEDS_STDINT_H @SCM_I_GSC_NEEDS_STDINT_H@
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 8bbbed4..a04b5fa 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010 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
@@ -138,9 +138,6 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0,
0,
}
#undef FUNC_NAME
-/* HACK*/
-#include "libguile/bytevectors.h"
-
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
(SCM ra),
"")
@@ -149,10 +146,6 @@ SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
scm_t_array_handle h;
SCM type;
- /* a hack, until srfi-4 and bytevectors are reunited */
- if (scm_is_bytevector (ra))
- return scm_from_locale_symbol ("vu8");
-
scm_array_get_handle (ra, &h);
type = scm_array_handle_element_type (&h);
scm_array_handle_release (&h);
@@ -243,14 +236,13 @@ array_to_list (scm_t_array_handle *h, size_t dim,
unsigned long pos)
{
SCM res = SCM_EOL;
long inc;
- size_t i, lbnd;
+ size_t i;
- i = h->dims[dim].ubnd;
- lbnd = h->dims[dim].lbnd;
+ i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
inc = h->dims[dim].inc;
- pos += (i - h->dims[dim].ubnd) * inc;
+ pos += (i - 1) * inc;
- for (; i >= lbnd; i--, pos -= inc)
+ for (; i > 0; i--, pos -= inc)
res = scm_cons (array_to_list (h, dim + 1, pos), res);
return res;
}
@@ -258,8 +250,14 @@ array_to_list (scm_t_array_handle *h, size_t dim, unsigned
long pos)
SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
(SCM array),
- "FIXME description a list consisting of all the elements, in order,
of\n"
- "@var{array}.")
+ "Return a list representation of @var{array}.\n\n"
+ "It is easiest to specify the behavior of this function by\n"
+ "example:\n"
+ "@example\n"
+ "(array->list #0(a)) @result{} 1\n"
+ "(array->list #1(a b)) @result{} (a b)\n"
+ "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
+ "@end example\n")
#define FUNC_NAME s_scm_array_to_list
{
scm_t_array_handle h;
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 4e3b924..bb53dda 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010 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
@@ -178,10 +178,9 @@ SCM_DEFINE (scm_generalized_vector_to_list,
"generalized-vector->list", 1, 0, 0,
ssize_t pos, i = 0;
scm_t_array_handle h;
scm_generalized_vector_get_handle (v, &h);
- /* FIXME CHECKME */
- for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd + 1);
+ for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd);
i >= 0;
- pos += h.dims[0].inc)
+ pos -= h.dims[0].inc, i--)
ret = scm_cons (h.impl->vref (&h, pos), ret);
scm_array_handle_release (&h);
return ret;
diff --git a/libguile/goops.c b/libguile/goops.c
index fe54ce7..6fc073b 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -39,6 +39,7 @@
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
#include "libguile/eval.h"
+#include "libguile/gsubr.h"
#include "libguile/hashtab.h"
#include "libguile/keywords.h"
#include "libguile/macros.h"
@@ -157,9 +158,16 @@ SCM scm_class_protected_hidden,
scm_class_protected_opaque, scm_class_protected_
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
+static SCM class_foreign;
static SCM class_hashtable;
static SCM class_fluid;
static SCM class_dynamic_state;
+static SCM class_frame;
+static SCM class_objcode;
+static SCM class_vm;
+static SCM class_vm_cont;
+static SCM class_bytevector;
+static SCM class_uvec;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
@@ -213,12 +221,27 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_class_vector;
+ case scm_tc7_foreign:
+ return class_foreign;
case scm_tc7_hashtable:
return class_hashtable;
case scm_tc7_fluid:
return class_fluid;
case scm_tc7_dynamic_state:
return class_dynamic_state;
+ case scm_tc7_frame:
+ return class_frame;
+ case scm_tc7_objcode:
+ return class_objcode;
+ case scm_tc7_vm:
+ return class_vm;
+ case scm_tc7_vm_cont:
+ return class_vm_cont;
+ case scm_tc7_bytevector:
+ if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
+ return class_bytevector;
+ else
+ return class_uvec;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
@@ -232,13 +255,11 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_gsubr:
- if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ case scm_tc7_program:
+ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
else
return scm_class_procedure;
- case scm_tc7_program:
- return scm_class_procedure;
case scm_tc7_smob:
{
@@ -1690,9 +1711,7 @@ SCM_DEFINE (scm_generic_capability_p,
"generic-capability?", 1, 0, 0,
{
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
- return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1705,12 +1724,11 @@ SCM_DEFINE (scm_enable_primitive_generic_x,
"enable-primitive-generic!", 0, 0, 1
while (!scm_is_null (subrs))
{
SCM subr = SCM_CAR (subrs);
- SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
- subr, SCM_ARGn, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr)
- = scm_make (scm_list_3 (scm_class_generic,
- k_name,
- SCM_SUBR_NAME (subr)));
+ SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
+ SCM_SET_SUBR_GENERIC (subr,
+ scm_make (scm_list_3 (scm_class_generic,
+ k_name,
+ SCM_SUBR_NAME (subr))));
subrs = SCM_CDR (subrs);
}
return SCM_UNSPECIFIED;
@@ -1722,10 +1740,9 @@ SCM_DEFINE (scm_set_primitive_generic_x,
"set-primitive-generic!", 2, 0, 0,
"")
#define FUNC_NAME s_scm_set_primitive_generic_x
{
- SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
- subr, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr) = generic;
+ SCM_SET_SUBR_GENERIC (subr, generic);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1735,7 +1752,7 @@ SCM_DEFINE (scm_primitive_generic_generic,
"primitive-generic-generic", 1, 0, 0,
"")
#define FUNC_NAME s_scm_primitive_generic_generic
{
- if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
+ if (SCM_PRIMITIVE_GENERIC_P (subr))
{
if (!*SCM_SUBR_GENERIC (subr))
scm_enable_primitive_generic_x (scm_list_1 (subr));
@@ -2033,7 +2050,9 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args)
#undef FUNC_NAME
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
-SCM_VARIABLE_INIT (var_compute_applicable_methods,
"compute-applicable-methods", scm_c_define_gsubr
(s_sys_compute_applicable_methods, 2, 0, 0,
scm_sys_compute_applicable_methods));
+SCM_VARIABLE_INIT (var_compute_applicable_methods,
"compute-applicable-methods",
+ scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0,
0,
+ scm_sys_compute_applicable_methods));
/******************************************************************************
*
@@ -2394,12 +2413,26 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_vector, "<vector>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_foreign, "<foreign>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_hashtable, "<hashtable>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_fluid, "<fluid>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_dynamic_state, "<dynamic-state>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_frame, "<frame>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_objcode, "<objcode>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_vm, "<vm>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_vm_cont, "<vm-continuation>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_bytevector, "<bytevector>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_uvec, "<uvec>",
+ scm_class_class, class_bytevector, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",
@@ -2648,14 +2681,6 @@ scm_ensure_accessor (SCM name)
return gf;
}
-SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
-
-void
-scm_add_method (SCM gf, SCM m)
-{
- scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
-}
-
#ifdef GUILE_DEBUG
/*
* Debugging utilities
diff --git a/libguile/goops.h b/libguile/goops.h
index b775ae3..06ade43 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -237,7 +237,6 @@ SCM_API void scm_load_goops (void);
SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
SCM_API SCM scm_ensure_accessor (SCM name);
-SCM_API void scm_add_method (SCM gf, SCM m);
SCM_API SCM scm_class_of (SCM obj);
/* Low level functions exported */
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 24ba670..de4bff6 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010
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
@@ -21,17 +21,16 @@
# include <config.h>
#endif
-#include <alloca.h>
-
#include <stdio.h>
#include <stdarg.h>
#include "libguile/_scm.h"
-#include "libguile/procprop.h"
-#include "libguile/root.h"
-
#include "libguile/gsubr.h"
-#include "libguile/deprecation.h"
+#include "libguile/foreign.h"
+#include "libguile/instructions.h"
+#include "libguile/objcodes.h"
+#include "libguile/srfi-4.h"
+#include "libguile/programs.h"
#include "libguile/private-options.h"
@@ -43,68 +42,793 @@
/* #define GSUBR_TEST */
-SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
+
-static SCM
-create_gsubr (int define, const char *name,
- unsigned int req, unsigned int opt, unsigned int rst,
- SCM (*fcn) ())
-{
- SCM subr;
- unsigned type;
+/* OK here goes nothing: we're going to define VM assembly trampolines for
+ invoking subrs, along with their meta-information, and then wrap them into
+ statically allocated objcode values. Ready? Right!
+*/
- type = SCM_GSUBR_MAKTYPE (req, opt, rst);
- if (SCM_GSUBR_REQ (type) != req
- || SCM_GSUBR_OPT (type) != opt
- || SCM_GSUBR_REST (type) != rst)
- scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
+/* There's a maximum of 10 args, so the number of possible combinations is:
+ (REQ-OPT-REST)
+ for 0 args: 1 (000) (1 + 0)
+ for 1 arg: 3 (100, 010, 001) (2 + 1)
+ for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
+ for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
+ for N args: 2N+1
+
+ and the index at which N args starts:
+ for 0 args: 0
+ for 1 args: 1
+ for 2 args: 4
+ for 3 args: 9
+ for N args: N^2
+
+ One can prove this:
+
+ (1 + 3 + 5 + ... + (2N+1))
+ = ((2N+1)+1)/2 * (N+1)
+ = 2(N+1)/2 * (N+1)
+ = (N+1)^2
+
+ Thus the total sum is 11^2 = 121. Let's just generate all of them as
+ read-only data.
+*/
- subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
- fcn);
+#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
- if (define)
- scm_define (SCM_SUBR_NAME (subr), subr);
+/* 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_subr_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 subr
pointer */ \
+ /* 8 */ scm_op_subr_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 subr
pointer */ \
+ /* 5 */ scm_op_subr_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 subr
pointer */ \
+ /* 11 */ scm_op_subr_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 subr
pointer */ \
+ /* 8 */ scm_op_subr_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 subr
pointer */ \
+ /* 8 */ scm_op_subr_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 subr
pointer */ \
+ /* 11 */ scm_op_subr_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)
+
+#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 */
- return subr;
-}
+/*
+ (defun generate-bytecode (n)
+ "Generate bytecode for N arguments"
+ (interactive "p")
+ (insert (format "/\* %d arguments *\/\n " n))
+ (let ((nreq n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq)))
+ (insert
+ (if (< 0 nreq)
+ (if (< 0 nopt)
+ (format "AB(%d,%d), " nreq nopt)
+ (format "A(%d), " nreq))
+ (if (< 0 nopt)
+ (format "B(%d), " nopt)
+ (format "A(0), "))))
+ (setq nreq (1- nreq))))
+ (insert "\n ")
+ (setq nreq (1- n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq 1)))
+ (insert
+ (if (< 0 nreq)
+ (if (< 0 nopt)
+ (format "ABC(%d,%d), " nreq nopt)
+ (format "AC(%d), " nreq))
+ (if (< 0 nopt)
+ (format "BC(%d), " nopt)
+ (format "C(), "))))
+ (setq nreq (1- nreq))))
+ (insert "\n\n ")))
+
+ (defun generate-bytecodes (n)
+ "Generate bytecodes for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-bytecode i)
+ (setq i (1+ i)))))
+*/
+static const struct
+{
+ scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way
*/
+ const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
+ + sizeof (struct scm_objcode) + 32)];
+} raw_bytecode = {
+ 0,
+ {
+ /* C-u 1 0 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),
+
+ /* 4 arguments */
+ A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
+ AC(3), ABC(2,1), ABC(1,2), BC(3),
+
+ /* 5 arguments */
+ A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
+ AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
+
+ /* 6 arguments */
+ A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
+ AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
+
+ /* 7 arguments */
+ A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
+ AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
+
+ /* 8 arguments */
+ A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
+ AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
+
+ /* 9 arguments */
+ A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7),
AB(1,8), B(9),
+ AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6),
ABC(1,7), BC(8),
+
+ /* 10 arguments */
+ A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7),
AB(2,8), AB(1,9), B(10),
+ AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6),
ABC(2,7), ABC(1,8), BC(9)
+ }
+};
+
+#undef A
+#undef B
+#undef C
+#undef AB
+#undef AC
+#undef BC
+#undef ABC
+#undef OBJCODE_HEADER
+#undef META_HEADER
+#undef META
-SCM
-scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+/*
+ ;; (nargs * nargs) + nopt + rest * (nargs + 1)
+ (defun generate-objcode-cells-helper (n)
+ "Generate objcode cells for N arguments"
+ (interactive "p")
+ (insert (format " /\* %d arguments *\/\n" n))
+ (let ((nreq n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq)))
+ (insert
+ (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes +
%d) },\n"
+ (* (+ 4 4 16 4 4 32)
+ (+ (* n n) nopt))))
+ (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
+ (setq nreq (1- nreq))))
+ (insert "\n")
+ (setq nreq (1- n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq 1)))
+ (insert
+ (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes +
%d) },\n"
+ (* (+ 4 4 16 4 4 32)
+ (+ (* n n) nopt n 1))))
+ (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
+ (setq nreq (1- nreq))))
+ (insert "\n")))
+
+ (defun generate-objcode-cells (n)
+ "Generate objcode cells for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-objcode-cells-helper i)
+ (setq i (1+ i)))))
+*/
+
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+static const struct
{
- return create_gsubr (0, name, req, opt, rst, fcn);
-}
+ scm_t_uint64 dummy; /* alignment */
+ scm_t_cell cells[121 * 2]; /* 11*11 double cells */
+} objcode_cells = {
+ 0,
+ /* C-u 1 0 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) },
+
+ /* 4 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 5 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 6 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 7 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 8 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 9 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 10 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
+ { SCM_BOOL_F, SCM_PACK (0) }
+ }
+};
+
+/*
+ (defun generate-objcode (n)
+ "Generate objcode for N arguments"
+ (interactive "p")
+ (insert (format " /\* %d arguments *\/\n" n))
+ (let ((i (* n n)))
+ (while (< i (* (1+ n) (1+ n)))
+ (insert (format " SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+ (defun generate-objcodes (n)
+ "Generate objcodes for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-objcode i)
+ (setq i (1+ i)))))
+*/
+static const SCM scm_subr_objcode_trampolines[121] = {
+ /* C-u 1 0 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),
+
+ /* 4 arguments */
+ SCM_PACK (objcode_cells.cells+32),
+ SCM_PACK (objcode_cells.cells+34),
+ SCM_PACK (objcode_cells.cells+36),
+ SCM_PACK (objcode_cells.cells+38),
+ SCM_PACK (objcode_cells.cells+40),
+ SCM_PACK (objcode_cells.cells+42),
+ SCM_PACK (objcode_cells.cells+44),
+ SCM_PACK (objcode_cells.cells+46),
+ SCM_PACK (objcode_cells.cells+48),
+
+ /* 5 arguments */
+ SCM_PACK (objcode_cells.cells+50),
+ SCM_PACK (objcode_cells.cells+52),
+ SCM_PACK (objcode_cells.cells+54),
+ SCM_PACK (objcode_cells.cells+56),
+ SCM_PACK (objcode_cells.cells+58),
+ SCM_PACK (objcode_cells.cells+60),
+ SCM_PACK (objcode_cells.cells+62),
+ SCM_PACK (objcode_cells.cells+64),
+ SCM_PACK (objcode_cells.cells+66),
+ SCM_PACK (objcode_cells.cells+68),
+ SCM_PACK (objcode_cells.cells+70),
+
+ /* 6 arguments */
+ SCM_PACK (objcode_cells.cells+72),
+ SCM_PACK (objcode_cells.cells+74),
+ SCM_PACK (objcode_cells.cells+76),
+ SCM_PACK (objcode_cells.cells+78),
+ SCM_PACK (objcode_cells.cells+80),
+ SCM_PACK (objcode_cells.cells+82),
+ SCM_PACK (objcode_cells.cells+84),
+ SCM_PACK (objcode_cells.cells+86),
+ SCM_PACK (objcode_cells.cells+88),
+ SCM_PACK (objcode_cells.cells+90),
+ SCM_PACK (objcode_cells.cells+92),
+ SCM_PACK (objcode_cells.cells+94),
+ SCM_PACK (objcode_cells.cells+96),
+
+ /* 7 arguments */
+ SCM_PACK (objcode_cells.cells+98),
+ SCM_PACK (objcode_cells.cells+100),
+ SCM_PACK (objcode_cells.cells+102),
+ SCM_PACK (objcode_cells.cells+104),
+ SCM_PACK (objcode_cells.cells+106),
+ SCM_PACK (objcode_cells.cells+108),
+ SCM_PACK (objcode_cells.cells+110),
+ SCM_PACK (objcode_cells.cells+112),
+ SCM_PACK (objcode_cells.cells+114),
+ SCM_PACK (objcode_cells.cells+116),
+ SCM_PACK (objcode_cells.cells+118),
+ SCM_PACK (objcode_cells.cells+120),
+ SCM_PACK (objcode_cells.cells+122),
+ SCM_PACK (objcode_cells.cells+124),
+ SCM_PACK (objcode_cells.cells+126),
+
+ /* 8 arguments */
+ SCM_PACK (objcode_cells.cells+128),
+ SCM_PACK (objcode_cells.cells+130),
+ SCM_PACK (objcode_cells.cells+132),
+ SCM_PACK (objcode_cells.cells+134),
+ SCM_PACK (objcode_cells.cells+136),
+ SCM_PACK (objcode_cells.cells+138),
+ SCM_PACK (objcode_cells.cells+140),
+ SCM_PACK (objcode_cells.cells+142),
+ SCM_PACK (objcode_cells.cells+144),
+ SCM_PACK (objcode_cells.cells+146),
+ SCM_PACK (objcode_cells.cells+148),
+ SCM_PACK (objcode_cells.cells+150),
+ SCM_PACK (objcode_cells.cells+152),
+ SCM_PACK (objcode_cells.cells+154),
+ SCM_PACK (objcode_cells.cells+156),
+ SCM_PACK (objcode_cells.cells+158),
+ SCM_PACK (objcode_cells.cells+160),
+
+ /* 9 arguments */
+ SCM_PACK (objcode_cells.cells+162),
+ SCM_PACK (objcode_cells.cells+164),
+ SCM_PACK (objcode_cells.cells+166),
+ SCM_PACK (objcode_cells.cells+168),
+ SCM_PACK (objcode_cells.cells+170),
+ SCM_PACK (objcode_cells.cells+172),
+ SCM_PACK (objcode_cells.cells+174),
+ SCM_PACK (objcode_cells.cells+176),
+ SCM_PACK (objcode_cells.cells+178),
+ SCM_PACK (objcode_cells.cells+180),
+ SCM_PACK (objcode_cells.cells+182),
+ SCM_PACK (objcode_cells.cells+184),
+ SCM_PACK (objcode_cells.cells+186),
+ SCM_PACK (objcode_cells.cells+188),
+ SCM_PACK (objcode_cells.cells+190),
+ SCM_PACK (objcode_cells.cells+192),
+ SCM_PACK (objcode_cells.cells+194),
+ SCM_PACK (objcode_cells.cells+196),
+ SCM_PACK (objcode_cells.cells+198),
+
+ /* 10 arguments */
+ SCM_PACK (objcode_cells.cells+200),
+ SCM_PACK (objcode_cells.cells+202),
+ SCM_PACK (objcode_cells.cells+204),
+ SCM_PACK (objcode_cells.cells+206),
+ SCM_PACK (objcode_cells.cells+208),
+ SCM_PACK (objcode_cells.cells+210),
+ SCM_PACK (objcode_cells.cells+212),
+ SCM_PACK (objcode_cells.cells+214),
+ SCM_PACK (objcode_cells.cells+216),
+ SCM_PACK (objcode_cells.cells+218),
+ SCM_PACK (objcode_cells.cells+220),
+ SCM_PACK (objcode_cells.cells+222),
+ SCM_PACK (objcode_cells.cells+224),
+ SCM_PACK (objcode_cells.cells+226),
+ SCM_PACK (objcode_cells.cells+228),
+ SCM_PACK (objcode_cells.cells+230),
+ SCM_PACK (objcode_cells.cells+232),
+ SCM_PACK (objcode_cells.cells+234),
+ SCM_PACK (objcode_cells.cells+236),
+ SCM_PACK (objcode_cells.cells+238),
+ SCM_PACK (objcode_cells.cells+240)
+};
+
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \
+ scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+ + nopt + rest * (nreq + nopt + rest + 1)]
SCM
-scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
+ unsigned int rest)
{
- return create_gsubr (1, name, req, opt, rst, fcn);
+ if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
+ scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
+
+ return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
}
static SCM
-create_gsubr_with_generic (int define,
- const char *name,
- int req,
- int opt,
- int rst,
- SCM (*fcn)(),
- SCM *gf)
+create_gsubr (int define, const char *name,
+ unsigned int nreq, unsigned int nopt, unsigned int rest,
+ SCM (*fcn) (), SCM *generic_loc)
{
- SCM subr;
- unsigned type;
-
- type = SCM_GSUBR_MAKTYPE (req, opt, rst);
- if (SCM_GSUBR_REQ (type) != req
- || SCM_GSUBR_OPT (type) != opt
- || SCM_GSUBR_REST (type) != rst)
- scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
+ SCM ret;
+ SCM sname;
+ SCM table;
+ scm_t_bits flags;
+
+ /* make objtable */
+ sname = scm_from_locale_symbol (name);
+ table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
+ SCM_SIMPLE_VECTOR_SET (table, 0,
+ scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ fcn, 0, NULL));
+ SCM_SIMPLE_VECTOR_SET (table, 1, sname);
+ if (generic_loc)
+ SCM_SIMPLE_VECTOR_SET (table, 2,
+ scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ generic_loc, 0, NULL));
+
+ /* make program */
+ ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
+ table, SCM_BOOL_F);
+
+ /* set flags */
+ flags = SCM_F_PROGRAM_IS_PRIMITIVE;
+ flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
+ SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
+
+ /* define, if needed */
+ if (define)
+ scm_define (sname, ret);
- subr = scm_c_make_subr_with_generic (name, scm_tc7_gsubr | (type << 8U),
- fcn, gf);
+ /* et voila. */
+ return ret;
+}
- if (define)
- scm_define (SCM_SUBR_NAME (subr), subr);
+SCM
+scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ return create_gsubr (0, name, req, opt, rst, fcn, NULL);
+}
- return subr;
+SCM
+scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ return create_gsubr (1, name, req, opt, rst, fcn, NULL);
}
SCM
@@ -115,7 +839,7 @@ scm_c_make_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf)
{
- return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
+ return create_gsubr (0, name, req, opt, rst, fcn, gf);
}
SCM
@@ -126,186 +850,8 @@ scm_c_define_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf)
{
- return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
-}
-
-/* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to
- match the number of arguments of the underlying C function. */
-static SCM
-gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
-{
- SCM (*fcn) ();
- unsigned int type, argc_max;
-
- type = SCM_GSUBR_TYPE (proc);
- argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
- + SCM_GSUBR_REST (type);
-
- if (SCM_UNLIKELY (argc != argc_max))
- /* We expect the exact argument count. */
- scm_wrong_num_args (SCM_SUBR_NAME (proc));
-
- fcn = SCM_SUBRF (proc);
-
- switch (argc)
- {
- case 0:
- return (*fcn) ();
- case 1:
- return (*fcn) (argv[0]);
- case 2:
- return (*fcn) (argv[0], argv[1]);
- case 3:
- return (*fcn) (argv[0], argv[1], argv[2]);
- case 4:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
- case 5:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
- case 6:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
- case 7:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6]);
- case 8:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6], argv[7]);
- case 9:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6], argv[7], argv[8]);
- case 10:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6], argv[7], argv[8], argv[9]);
- default:
- scm_misc_error ((char *) SCM_SUBR_NAME (proc),
- "gsubr invocation with more than 10 arguments not
implemented",
- SCM_EOL);
- }
-
- return SCM_BOOL_F; /* Never reached. */
-}
-
-/* Apply PROC, a gsubr, to the given arguments. Missing optional arguments
- are added, and rest arguments are turned into a list. */
-SCM
-scm_i_gsubr_apply (SCM proc, SCM arg, ...)
-{
- unsigned int type, argc, argc_max;
- SCM *argv;
- va_list arg_list;
-
- type = SCM_GSUBR_TYPE (proc);
- argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
- argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
-
- va_start (arg_list, arg);
-
- for (argc = 0;
- !SCM_UNBNDP (arg) && argc < argc_max;
- argc++, arg = va_arg (arg_list, SCM))
- argv[argc] = arg;
-
- if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
- /* too few args */
- scm_wrong_num_args (SCM_SUBR_NAME (proc));
- if (SCM_UNLIKELY (!SCM_UNBNDP (arg) && !SCM_GSUBR_REST (type)))
- /* too many args */
- scm_wrong_num_args (SCM_SUBR_NAME (proc));
-
- /* Fill in optional arguments that were not passed. */
- while (argc < argc_max)
- argv[argc++] = SCM_UNDEFINED;
-
- if (SCM_GSUBR_REST (type))
- {
- /* Accumulate rest arguments in a list. */
- SCM *rest_loc;
-
- argv[argc_max] = SCM_EOL;
-
- for (rest_loc = &argv[argc_max];
- !SCM_UNBNDP (arg);
- rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
- *rest_loc = scm_cons (arg, SCM_EOL);
-
- argc = argc_max + 1;
- }
-
- va_end (arg_list);
-
- return gsubr_apply_raw (proc, argc, argv);
-}
-
-/* Apply SELF, a gsubr, to the arguments listed in ARGS. Missing optional
- arguments are added, and rest arguments are kept into a list. */
-SCM
-scm_i_gsubr_apply_list (SCM self, SCM args)
-#define FUNC_NAME "scm_i_gsubr_apply"
-{
- SCM v[SCM_GSUBR_MAX];
- unsigned int typ = SCM_GSUBR_TYPE (self);
- long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
-
- for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
- if (scm_is_null (args))
- scm_wrong_num_args (SCM_SUBR_NAME (self));
- v[i] = SCM_CAR(args);
- args = SCM_CDR(args);
- }
- for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
- if (SCM_NIMP (args)) {
- v[i] = SCM_CAR (args);
- args = SCM_CDR(args);
- }
- else
- v[i] = SCM_UNDEFINED;
- }
- if (SCM_GSUBR_REST(typ))
- v[i] = args;
- else if (!scm_is_null (args))
- scm_wrong_num_args (SCM_SUBR_NAME (self));
-
- return gsubr_apply_raw (self, n, v);
-}
-#undef FUNC_NAME
-
-/* Apply SELF, a gsubr, to the arguments in ARGS. Missing optional
- arguments are added, and rest arguments are consed into a list. */
-SCM
-scm_i_gsubr_apply_array (SCM self, SCM *args, int nargs, int headroom)
-#define FUNC_NAME "scm_i_gsubr_apply"
-{
- unsigned int typ = SCM_GSUBR_TYPE (self);
- long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
-
- if (SCM_UNLIKELY (nargs < SCM_GSUBR_REQ (typ)))
- scm_wrong_num_args (SCM_SUBR_NAME (self));
-
- if (SCM_UNLIKELY (headroom < n - nargs))
- {
- /* fallback on apply-list */
- SCM arglist = SCM_EOL;
- while (nargs--)
- arglist = scm_cons (args[nargs], arglist);
- return scm_i_gsubr_apply_list (self, arglist);
- }
-
- for (i = nargs; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++)
- args[i] = SCM_UNDEFINED;
-
- if (SCM_GSUBR_REST(typ))
- {
- SCM rest = SCM_EOL;
- /* fallback on apply-list */
- while (nargs-- >= n)
- rest = scm_cons (args[nargs], rest);
- args[n - 1] = rest;
- }
- else if (nargs > n)
- scm_wrong_num_args (SCM_SUBR_NAME (self));
-
- return gsubr_apply_raw (self, n, args);
+ return create_gsubr (1, name, req, opt, rst, fcn, gf);
}
-#undef FUNC_NAME
#ifdef GSUBR_TEST
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index e75658d..e94d0d0 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -3,7 +3,7 @@
#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010 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
@@ -25,18 +25,32 @@
#include "libguile/__scm.h"
+
-/* Return an integer describing the arity of GSUBR, a subr of type
- `scm_tc7_gsubr'. The result can be interpreted with `SCM_GSUBR_REQ ()'
- and similar. */
-#define SCM_GSUBR_TYPE(gsubr) (SCM_CELL_TYPE (gsubr) >> 8)
-#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
-#define SCM_GSUBR_MAX 33
-#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
-#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
-#define SCM_GSUBR_REST(x) ((long)(x)>>8)
+SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
+ unsigned int nopt,
+ unsigned int rest);
+
+
+/* Subrs
+ */
+
+/* Max number of args to the C procedure backing a gsubr */
+#define SCM_GSUBR_MAX 10
+
+#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
+#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) &&
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
+
+#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF
(SCM_PROGRAM_OBJTABLE (x), 0), void)))
+#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
+#define SCM_SUBR_GENERIC(x) \
+ (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2),
SCM))
+#define SCM_SET_SUBR_GENERIC(x, g) \
+ (*SCM_SUBR_GENERIC (x) = (g))
+
+
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, SCM (*fcn) ());
@@ -49,10 +63,6 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char
*name,
int req, int opt, int rst,
SCM (*fcn) (), SCM *gf);
-SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
-SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
-SCM_INTERNAL SCM scm_i_gsubr_apply_array (SCM proc, SCM *args, int nargs,
- int headroom);
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_H */
diff --git a/libguile/hash.c b/libguile/hash.c
index e56fab0..d2ce575 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009,
2010 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
@@ -169,8 +169,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
else return 1;
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- /* case scm_tcs_closures: */
- case scm_tc7_gsubr:
+ case scm_tc7_program:
return 262 % n;
}
}
diff --git a/libguile/hooks.c b/libguile/hooks.c
index d7bf018..abba606 100644
--- a/libguile/hooks.c
+++ b/libguile/hooks.c
@@ -276,6 +276,17 @@ scm_c_run_hook (SCM hook, SCM args)
}
}
+void
+scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs)
+{
+ SCM procs = SCM_HOOK_PROCEDURES (hook);
+ while (SCM_NIMP (procs))
+ {
+ scm_call_n (SCM_CAR (procs), argv, nargs);
+ procs = SCM_CDR (procs);
+ }
+}
+
SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0,
(SCM hook),
diff --git a/libguile/hooks.h b/libguile/hooks.h
index 15b57fa..dc930cb 100644
--- a/libguile/hooks.h
+++ b/libguile/hooks.h
@@ -3,7 +3,7 @@
#ifndef SCM_HOOKS_H
#define SCM_HOOKS_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -87,6 +87,7 @@ SCM_API SCM scm_remove_hook_x (SCM hook, SCM thunk);
SCM_API SCM scm_reset_hook_x (SCM hook);
SCM_API SCM scm_run_hook (SCM hook, SCM args);
SCM_API void scm_c_run_hook (SCM hook, SCM args);
+SCM_API void scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs);
SCM_API SCM scm_hook_to_list (SCM hook);
SCM_INTERNAL void scm_init_hooks (void);
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 3a6cb06..9c78bfc 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -59,10 +59,16 @@
#include "libguile/posix.h" /* for `scm_i_locale_mutex' */
-#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
+#ifdef HAVE_LANGINFO_H
# include <langinfo.h>
+#endif
+#ifdef HAVE_NL_TYPES_H
# include <nl_types.h>
#endif
+#ifndef HAVE_NL_ITEM
+/* Cygwin has <langinfo.h> but lacks <nl_types.h> and `nl_item'. */
+typedef int nl_item;
+#endif
#ifndef HAVE_SETLOCALE
static inline char *
@@ -1098,22 +1104,19 @@ u32_locale_tocase (const scm_t_uint32 *c_s1, size_t len,
}
-
-SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
- (SCM chr, SCM locale),
- "Return the lowercase character that corresponds to @var{chr} "
- "according to either @var{locale} or the current locale.")
-#define FUNC_NAME s_scm_char_locale_downcase
+static SCM
+chr_to_case (SCM chr, scm_t_locale c_locale,
+ scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t, const char *,
+ uninorm_t, scm_t_uint32 *, size_t *),
+ const char *func_name,
+ int *err)
+#define FUNC_NAME func_name
{
int ret;
- scm_t_locale c_locale;
scm_t_wchar *buf;
- scm_t_uint32 *downbuf;
- size_t downlen;
- SCM str, downchar;
-
- SCM_VALIDATE_CHAR (1, chr);
- SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+ scm_t_uint32 *convbuf;
+ size_t convlen;
+ SCM str, convchar;
str = scm_i_make_wide_string (1, &buf);
buf[0] = SCM_CHAR (chr);
@@ -1121,26 +1124,50 @@ SCM_DEFINE (scm_char_locale_downcase,
"char-locale-downcase", 1, 1, 0,
if (c_locale != NULL)
RUN_IN_LOCALE_SECTION (c_locale, ret =
u32_locale_tocase ((scm_t_uint32 *) buf, 1,
- &downbuf,
- &downlen, u32_tolower));
+ &convbuf,
+ &convlen, func));
else
ret =
- u32_locale_tocase ((scm_t_uint32 *) buf, 1, &downbuf,
- &downlen, u32_tolower);
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1, &convbuf,
+ &convlen, func);
if (SCM_UNLIKELY (ret != 0))
{
- errno = ret;
- scm_syserror (FUNC_NAME);
+ *err = ret;
+ return NULL;
}
- if (downlen == 1)
- downchar = SCM_MAKE_CHAR ((scm_t_wchar) downbuf[0]);
+ if (convlen == 1)
+ convchar = SCM_MAKE_CHAR ((scm_t_wchar) convbuf[0]);
else
- downchar = chr;
- free (downbuf);
+ convchar = chr;
+ free (convbuf);
- return downchar;
+ return convchar;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
+ (SCM chr, SCM locale),
+ "Return the lowercase character that corresponds to @var{chr} "
+ "according to either @var{locale} or the current locale.")
+#define FUNC_NAME s_scm_char_locale_downcase
+{
+ scm_t_locale c_locale;
+ SCM ret;
+ int err = 0;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+ ret = chr_to_case (chr, c_locale, u32_tolower, FUNC_NAME, &err);
+
+ if (err != 0)
+ {
+ errno = err;
+ scm_syserror (FUNC_NAME);
+ }
+ return ret;
}
#undef FUNC_NAME
@@ -1150,59 +1177,62 @@ SCM_DEFINE (scm_char_locale_upcase,
"char-locale-upcase", 1, 1, 0,
"according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_upcase
{
- int ret;
scm_t_locale c_locale;
- scm_t_wchar *buf;
- scm_t_uint32 *upbuf;
- size_t uplen;
- SCM str, upchar;
+ SCM ret;
+ int err = 0;
SCM_VALIDATE_CHAR (1, chr);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- str = scm_i_make_wide_string (1, &buf);
- buf[0] = SCM_CHAR (chr);
+ ret = chr_to_case (chr, c_locale, u32_toupper, FUNC_NAME, &err);
- if (c_locale != NULL)
- RUN_IN_LOCALE_SECTION (c_locale, ret =
- u32_locale_tocase ((scm_t_uint32 *) buf, 1,
- &upbuf,
- &uplen, u32_toupper));
- else
- ret =
- u32_locale_tocase ((scm_t_uint32 *) buf, 1, &upbuf,
- &uplen, u32_toupper);
+ if (err != 0)
+ {
+ errno = err;
+ scm_syserror (FUNC_NAME);
+ }
+ return ret;
+}
+#undef FUNC_NAME
- if (SCM_UNLIKELY (ret != 0))
+SCM_DEFINE (scm_char_locale_titlecase, "char-locale-titlecase", 1, 1, 0,
+ (SCM chr, SCM locale),
+ "Return the titlecase character that corresponds to @var{chr} "
+ "according to either @var{locale} or the current locale.")
+#define FUNC_NAME s_scm_char_locale_titlecase
+{
+ scm_t_locale c_locale;
+ SCM ret;
+ int err = 0;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+ ret = chr_to_case (chr, c_locale, u32_totitle, FUNC_NAME, &err);
+
+ if (err != 0)
{
- errno = ret;
+ errno = err;
scm_syserror (FUNC_NAME);
}
- if (uplen == 1)
- upchar = SCM_MAKE_CHAR ((scm_t_wchar) upbuf[0]);
- else
- upchar = chr;
- free (upbuf);
- return upchar;
+ return ret;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
- (SCM str, SCM locale),
- "Return a new string that is the uppercase version of "
- "@var{str} according to either @var{locale} or the current "
- "locale.")
-#define FUNC_NAME s_scm_string_locale_upcase
+static SCM
+str_to_case (SCM str, scm_t_locale c_locale,
+ scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t, const char *,
+ uninorm_t, scm_t_uint32 *, size_t *),
+ const char *func_name,
+ int *err)
+#define FUNC_NAME func_name
{
scm_t_wchar *c_str, *c_buf;
- scm_t_uint32 *c_upstr;
- size_t len, uplen;
+ scm_t_uint32 *c_convstr;
+ size_t len, convlen;
int ret;
- scm_t_locale c_locale;
- SCM upstr;
+ SCM convstr;
- SCM_VALIDATE_STRING (1, str);
- SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
len = scm_i_string_length (str);
if (len == 0)
return scm_nullstr;
@@ -1211,28 +1241,53 @@ SCM_DEFINE (scm_string_locale_upcase,
"string-locale-upcase", 1, 1, 0,
if (c_locale)
RUN_IN_LOCALE_SECTION (c_locale, ret =
u32_locale_tocase ((scm_t_uint32 *) c_str, len,
- &c_upstr,
- &uplen, u32_toupper));
+ &c_convstr,
+ &convlen, func));
else
ret =
u32_locale_tocase ((scm_t_uint32 *) c_str, len,
- &c_upstr, &uplen, u32_toupper);
+ &c_convstr, &convlen, func);
scm_remember_upto_here (str);
if (SCM_UNLIKELY (ret != 0))
{
- errno = ret;
- scm_syserror (FUNC_NAME);
+ *err = ret;
+ return NULL;
}
- upstr = scm_i_make_wide_string (uplen, &c_buf);
- memcpy (c_buf, c_upstr, uplen * sizeof (scm_t_wchar));
- free (c_upstr);
+ convstr = scm_i_make_wide_string (convlen, &c_buf);
+ memcpy (c_buf, c_convstr, convlen * sizeof (scm_t_wchar));
+ free (c_convstr);
- scm_i_try_narrow_string (upstr);
+ scm_i_try_narrow_string (convstr);
- return upstr;
+ return convstr;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
+ (SCM str, SCM locale),
+ "Return a new string that is the uppercase version of "
+ "@var{str} according to either @var{locale} or the current "
+ "locale.")
+#define FUNC_NAME s_scm_string_locale_upcase
+{
+ scm_t_locale c_locale;
+ SCM ret;
+ int err = 0;
+
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+ ret = str_to_case (str, c_locale, u32_toupper, FUNC_NAME, &err);
+
+ if (err != 0)
+ {
+ errno = err;
+ scm_syserror (FUNC_NAME);
+ }
+ return ret;
}
#undef FUNC_NAME
@@ -1243,45 +1298,46 @@ SCM_DEFINE (scm_string_locale_downcase,
"string-locale-downcase", 1, 1, 0,
"locale.")
#define FUNC_NAME s_scm_string_locale_downcase
{
- scm_t_wchar *c_str, *c_buf;
- scm_t_uint32 *c_downstr;
- size_t len, downlen;
- int ret;
scm_t_locale c_locale;
- SCM downstr;
+ SCM ret;
+ int err = 0;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- len = scm_i_string_length (str);
- if (len == 0)
- return scm_nullstr;
- SCM_STRING_TO_U32_BUF (str, c_str);
-
- if (c_locale)
- RUN_IN_LOCALE_SECTION (c_locale, ret =
- u32_locale_tocase ((scm_t_uint32 *) c_str, len,
- &c_downstr,
- &downlen, u32_tolower));
- else
- ret =
- u32_locale_tocase ((scm_t_uint32 *) c_str, len,
- &c_downstr, &downlen, u32_tolower);
- scm_remember_upto_here (str);
+ ret = str_to_case (str, c_locale, u32_tolower, FUNC_NAME, &err);
- if (SCM_UNLIKELY (ret != 0))
+ if (err != 0)
{
- errno = ret;
+ errno = err;
scm_syserror (FUNC_NAME);
}
+ return ret;
+}
+#undef FUNC_NAME
- downstr = scm_i_make_wide_string (downlen, &c_buf);
- memcpy (c_buf, c_downstr, downlen * sizeof (scm_t_wchar));
- free (c_downstr);
+SCM_DEFINE (scm_string_locale_titlecase, "string-locale-titlecase", 1, 1, 0,
+ (SCM str, SCM locale),
+ "Return a new string that is the title-case version of "
+ "@var{str} according to either @var{locale} or the current "
+ "locale.")
+#define FUNC_NAME s_scm_string_locale_titlecase
+{
+ scm_t_locale c_locale;
+ SCM ret;
+ int err = 0;
- scm_i_try_narrow_string (downstr);
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- return downstr;
+ ret = str_to_case (str, c_locale, u32_totitle, FUNC_NAME, &err);
+
+ if (err != 0)
+ {
+ errno = err;
+ scm_syserror (FUNC_NAME);
+ }
+ return ret;
}
#undef FUNC_NAME
@@ -1409,7 +1465,10 @@ SCM_DEFINE (scm_locale_string_to_inexact,
"locale-string->inexact",
setting of the current locale. If nl_langinfo supports CODESET,
we can convert the string properly using scm_from_stringn. If
CODESET is not supported, we won't be able to make much sense of
- the returned string. */
+ the returned string.
+
+ Note: We don't use Gnulib's `nl_langinfo' module because it's currently not
+ as complete as the compatibility hacks in `i18n.scm'. */
SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
@@ -1807,7 +1866,8 @@ scm_init_i18n ()
void
scm_bootstrap_i18n ()
{
- scm_c_register_extension ("libguile", "scm_init_i18n",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_i18n",
(scm_t_extension_init_func) scm_init_i18n,
NULL);
diff --git a/libguile/i18n.h b/libguile/i18n.h
index 16045eb..c2792ac 100644
--- a/libguile/i18n.h
+++ b/libguile/i18n.h
@@ -38,8 +38,10 @@ SCM_API SCM scm_char_locale_ci_gt (SCM c1, SCM c2, SCM
locale);
SCM_API SCM scm_char_locale_ci_eq (SCM c1, SCM c2, SCM locale);
SCM_API SCM scm_char_locale_upcase (SCM chr, SCM locale);
SCM_API SCM scm_char_locale_downcase (SCM chr, SCM locale);
+SCM_API SCM scm_char_locale_titlecase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
+SCM_API SCM scm_string_locale_titlecase (SCM chr, SCM locale);
SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);
diff --git a/libguile/init.c b/libguile/init.c
index 0571d6b..0d4f8c2 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -41,6 +41,7 @@
#include "libguile/boolean.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
+#include "libguile/control.h"
#include "libguile/continuations.h"
#include "libguile/debug.h"
#ifdef GUILE_DEBUG_MALLOC
@@ -57,6 +58,7 @@
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
+#include "libguile/frames.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
@@ -68,10 +70,10 @@
#include "libguile/hooks.h"
#include "libguile/gettext.h"
#include "libguile/i18n.h"
+#include "libguile/instructions.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
-#include "libguile/lang.h"
#include "libguile/list.h"
#include "libguile/load.h"
#include "libguile/macros.h"
@@ -80,6 +82,7 @@
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
+#include "libguile/objcodes.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
@@ -91,6 +94,7 @@
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/procs.h"
+#include "libguile/programs.h"
#include "libguile/promises.h"
#include "libguile/properties.h"
#include "libguile/array-map.h"
@@ -122,7 +126,7 @@
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
-#include "libguile/vm-bootstrap.h"
+#include "libguile/vm.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
@@ -443,9 +447,14 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_symbols_prehistory (); /* requires weaks_prehistory */
scm_modules_prehistory ();
scm_init_array_handle ();
- scm_init_generalized_arrays ();
- scm_init_generalized_vectors ();
- scm_init_strings (); /* Requires array-handle,
generalized-vectors */
+ scm_bootstrap_bytevectors (); /* Requires array-handle */
+ scm_bootstrap_instructions ();
+ scm_bootstrap_objcodes ();
+ scm_bootstrap_programs ();
+ scm_bootstrap_vm ();
+ scm_register_foreign ();
+
+ scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */
scm_smob_prehistory ();
scm_init_variable ();
@@ -467,6 +476,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_eq ();
scm_init_error ();
scm_init_fluids ();
+ scm_init_control (); /* requires fluids */
scm_init_feature ();
scm_init_backtrace ();
scm_init_fports ();
@@ -509,16 +519,15 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_srcprop (); /* requires smob_prehistory */
scm_init_stackchk ();
- scm_init_vectors (); /* Requires array-handle, generalized-vectors */
+ scm_init_generalized_arrays ();
+ scm_init_generalized_vectors ();
+ scm_init_vectors (); /* Requires array-handle, */
scm_init_uniform ();
- scm_init_bitvectors (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
- scm_bootstrap_bytevectors (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
- scm_init_srfi_4 (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
+ scm_init_bitvectors (); /* Requires smob_prehistory, array-handle */
+ scm_init_srfi_4 (); /* Requires smob_prehistory, array-handle */
scm_init_arrays (); /* Requires smob_prehistory, array-handle */
scm_init_array_map ();
- scm_bootstrap_vm (); /* requires smob_prehistory, gc_permanent_object */
-
scm_init_frames (); /* Requires smob_prehistory */
scm_init_stacks (); /* Requires strings, struct, frames */
scm_init_symbols ();
@@ -547,9 +556,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_simpos ();
scm_init_dynamic_linking (); /* Requires smob_prehistory */
scm_bootstrap_i18n ();
-#if SCM_ENABLE_ELISP
- scm_init_lang ();
-#endif /* SCM_ENABLE_ELISP */
scm_init_script ();
scm_init_goops ();
@@ -576,6 +582,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
atexit (cleanup_for_exit);
scm_load_startup_files ();
+ scm_init_load_should_autocompile ();
}
/*
diff --git a/libguile/inline.h b/libguile/inline.h
index 09a1b5a..018e6c6 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -3,7 +3,7 @@
#ifndef SCM_INLINE_H
#define SCM_INLINE_H
-/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010 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
@@ -87,6 +87,9 @@ SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
SCM_API SCM scm_immutable_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);
+/* no immutable words for now, would require initialization at the same time as
+ allocation */
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);
@@ -241,6 +244,42 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
SCM_C_EXTERN_INLINE
#endif
SCM
+scm_words (scm_t_bits car, scm_t_uint16 n_words)
+{
+ SCM z;
+
+ z = SCM_PACK ((scm_t_bits) (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;
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
diff --git a/libguile/instructions.c b/libguile/instructions.c
index c8d95cc..4981635 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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
@@ -23,7 +23,6 @@
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "instructions.h"
struct scm_instruction {
@@ -197,7 +196,8 @@ SCM_DEFINE (scm_opcode_to_instruction,
"opcode->instruction", 1, 0, 0,
void
scm_bootstrap_instructions (void)
{
- scm_c_register_extension ("libguile", "scm_init_instructions",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_instructions",
(scm_t_extension_init_func)scm_init_instructions,
NULL);
}
@@ -205,8 +205,6 @@ scm_bootstrap_instructions (void)
void
scm_init_instructions (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/instructions.x"
#endif
diff --git a/libguile/lang.c b/libguile/lang.c
deleted file mode 100644
index 85da680..0000000
--- a/libguile/lang.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/* Copyright (C) 1999, 2000, 2001, 2006, 2008 Free Software Foundation,
Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-
-#include "libguile/eval.h"
-#include "libguile/macros.h"
-#include "libguile/root.h"
-
-#include "libguile/validate.h"
-#include "libguile/lang.h"
-
-
-
-/* {Multi-language support}
- */
-
-#if SCM_ENABLE_ELISP
-
-void
-scm_init_lang ()
-{
-#include "libguile/lang.x"
-
- scm_c_define ("%nil", SCM_ELISP_NIL);
-}
-
-#endif /* SCM_ENABLE_ELISP */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/lang.h b/libguile/lang.h
deleted file mode 100644
index b86fb2e..0000000
--- a/libguile/lang.h
+++ /dev/null
@@ -1,50 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_LANG_H
-#define SCM_LANG_H
-
-/* Copyright (C) 1998, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-
-#include "libguile/__scm.h"
-
-
-
-#if SCM_ENABLE_ELISP
-
-#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))
-
-SCM_INTERNAL void scm_init_lang (void);
-
-#else /* ! SCM_ENABLE_ELISP */
-
-#define SCM_NILP(x) 0
-
-#endif /* ! SCM_ENABLE_ELISP */
-
-#define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
-
-#endif /* SCM_LANG_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/list.c b/libguile/list.c
index ba4b249..23ef404 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -25,7 +25,6 @@
#include "libguile/_scm.h"
#include "libguile/eq.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/list.h"
diff --git a/libguile/load.c b/libguile/load.c
index 83fb353..0e4894e 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2008, 2009, 2010
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,6 +27,7 @@
#include <stdio.h>
#include "libguile/_scm.h"
+#include "libguile/private-gc.h" /* scm_getenv_int */
#include "libguile/libpath.h"
#include "libguile/fports.h"
#include "libguile/read.h"
@@ -37,7 +38,6 @@
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/modules.h"
-#include "libguile/lang.h"
#include "libguile/chars.h"
#include "libguile/srfi-13.h"
@@ -239,8 +239,8 @@ scm_init_load_path ()
else if (env)
path = scm_parse_path (scm_from_locale_string (env), path);
else
- path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR),
- scm_from_locale_string (SCM_LIBRARY_DIR),
+ path = scm_list_3 (scm_from_locale_string (SCM_LIBRARY_DIR),
+ scm_from_locale_string (SCM_SITE_DIR),
scm_from_locale_string (SCM_PKGDATA_DIR));
env = getenv ("GUILE_SYSTEM_COMPILED_PATH");
@@ -407,11 +407,12 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
SCM extensions, require_exts;
SCM result = SCM_BOOL_F;
- if (scm_is_null (rest))
+ if (SCM_UNBNDP (rest) || scm_is_null (rest))
{
/* Called either by Scheme code that didn't provide the optional
arguments, or C code that used the Guile 1.8 signature (2 required,
- 1 optional arg) and passed '() as the EXTENSIONS argument. */
+ 1 optional arg) and passed '() or nothing as the EXTENSIONS
+ argument. */
extensions = SCM_EOL;
require_exts = SCM_UNDEFINED;
}
@@ -899,7 +900,6 @@ scm_init_load ()
scm_loc_compile_fallback_path
= SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F));
-
scm_loc_load_should_autocompile
= SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F));
@@ -907,11 +907,24 @@ scm_init_load ()
scm_fluid_set_x (the_reader, SCM_BOOL_F);
scm_c_define("current-reader", the_reader);
+ scm_c_define ("load-compiled",
+ scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
+ scm_load_compiled_with_vm));
+
init_build_info ();
#include "libguile/load.x"
}
+void
+scm_init_load_should_autocompile ()
+{
+ *scm_loc_load_should_autocompile =
+ scm_from_bool (scm_getenv_int ("GUILE_AUTO_COMPILE", 1));
+}
+
+
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/load.h b/libguile/load.h
index 0feabad..0bff53c 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -39,6 +39,7 @@ SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
SCM_INTERNAL void scm_init_load_path (void);
SCM_INTERNAL void scm_init_load (void);
+SCM_INTERNAL void scm_init_load_should_autocompile (void);
SCM_INTERNAL void scm_init_eval_in_scheme (void);
#endif /* SCM_LOAD_H */
diff --git a/libguile/macros.c b/libguile/macros.c
index 0d71400..b3fea93 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
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009,
2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,296 +22,161 @@
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/_scm.h"
-#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
-#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/print.h"
-#include "libguile/root.h"
#include "libguile/smob.h"
-#include "libguile/deprecation.h"
-
#include "libguile/validate.h"
-#include "libguile/programs.h"
#include "libguile/macros.h"
#include "libguile/private-options.h"
-scm_t_bits scm_tc16_macro;
+static scm_t_bits scm_tc16_macro;
-static int
-macro_print (SCM macro, SCM port, scm_print_state *pstate)
-{
- SCM code = SCM_MACRO_CODE (macro);
+#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
+#define SCM_MACRO_PRIMITIVE(m) ((scm_t_macro_primitive)SCM_SMOB_DATA (m))
+#define SCM_MACRO_NAME(m) (SCM_SMOB_OBJECT_2 (m))
+#define SCM_MACRO_TYPE(m) (SCM_SMOB_OBJECT_3 (m))
+#define SCM_MACRO_BINDING(m) (SCM_CELL_OBJECT ((m), 4))
+#define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP)
- scm_puts ("#<", port);
- if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
- scm_puts ("extended-", port);
+SCM_API scm_t_bits scm_tc16_macro;
- /* FIXME: doesn't catch boot closures; but do we care? */
- if (!SCM_PROGRAM_P (code))
- scm_puts ("primitive-", port);
- if (SCM_MACRO_TYPE (macro) == 0)
- scm_puts ("syntax", port);
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_MACRO_TYPE (macro) == 1)
- scm_puts ("macro", port);
-#endif
- if (SCM_MACRO_TYPE (macro) == 2)
- scm_puts ("macro!", port);
- if (SCM_MACRO_TYPE (macro) == 3)
- scm_puts ("builtin-macro!", port);
- if (SCM_MACRO_TYPE (macro) == 4)
- scm_puts ("syncase-macro", port);
-
- scm_putc (' ', port);
+static int
+macro_print (SCM macro, SCM port, scm_print_state *pstate)
+{
+ if (scm_is_false (SCM_MACRO_TYPE (macro)))
+ scm_puts ("#<primitive-syntax-transformer ", port);
+ else
+ scm_puts ("#<syntax-transformer ", port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
-
- if (SCM_MACRO_IS_EXTENDED (macro))
- {
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_2 (macro), port);
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_3 (macro), port);
- }
-
scm_putc ('>', port);
return 1;
}
-static SCM
-makmac (SCM code, scm_t_bits flags)
-{
- SCM z;
- SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code));
- SCM_SET_SMOB_FLAGS (z, flags);
- return z;
-}
-
/* Return a mmacro that is known to be one of guile's built in macros. */
SCM
-scm_i_makbimacro (SCM code)
-#define FUNC_NAME "scm_i_makbimacro"
+scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
{
- SCM_VALIDATE_PROC (1, code);
- return makmac (code, 3);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0,
- (SCM code),
- "Return a @dfn{macro} which, when a symbol defined to this value\n"
- "appears as the first symbol in an expression, evaluates the\n"
- "result of applying @var{code} to the expression and the\n"
- "environment.\n\n"
- "@code{procedure->memoizing-macro} is the same as\n"
- "@code{procedure->macro}, except that the expression returned by\n"
- "@var{code} replaces the original macro expression in the
memoized\n"
- "form of the containing code.")
-#define FUNC_NAME s_scm_makmmacro
-{
- SCM_VALIDATE_PROC (1, code);
- return makmac (code, 2);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0,
- (SCM code),
- "Return a @dfn{macro} which, when a symbol defined to this value\n"
- "appears as the first symbol in an expression, returns the\n"
- "result of applying @var{code} to the expression and the\n"
- "environment.")
-#define FUNC_NAME s_scm_makacro
-{
- SCM_VALIDATE_PROC (1, code);
- return makmac (code, 0);
+ SCM z = scm_words (scm_tc16_macro, 5);
+ SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
+ SCM_SET_SMOB_DATA_N (z, 2, scm_from_locale_symbol (name));
+ SCM_SET_SMOB_DATA_N (z, 3, SCM_BOOL_F);
+ SCM_SET_SMOB_DATA_N (z, 4, SCM_BOOL_F);
+ return z;
}
-#undef FUNC_NAME
-
-#if SCM_ENABLE_DEPRECATED == 1
-
-SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
- (SCM code),
- "Return a @dfn{macro} which, when a symbol defined to this value\n"
- "appears as the first symbol in an expression, evaluates the\n"
- "result of applying @var{code} to the expression and the\n"
- "environment. For example:\n"
- "\n"
- "@lisp\n"
- "(define trace\n"
- " (procedure->macro\n"
- " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr
x))))))\n\n"
- "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo}
'@i{foo})).\n"
- "@end lisp")
-#define FUNC_NAME s_scm_makmacro
+scm_t_macro_primitive
+scm_i_macro_primitive (SCM macro)
{
- scm_c_issue_deprecation_warning
- ("The function procedure->macro is deprecated, and so are"
- " non-memoizing macros in general. Use memoizing macros"
- " or r5rs macros instead.");
-
- SCM_VALIDATE_PROC (1, code);
- return makmac (code, 1);
+ return SCM_MACRO_PRIMITIVE (macro);
}
-#undef FUNC_NAME
-#endif
-SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0,
- (SCM type, SCM binding),
- "Return a @dfn{macro} that requires expansion by syntax-case.\n"
- "While users should not call this function, it is useful to know\n"
- "that syntax-case macros are represented as Guile primitive
macros.")
-#define FUNC_NAME s_scm_make_syncase_macro
+SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0,
+ (SCM name, SCM type, SCM binding),
+ "Construct a @dfn{syntax transformer}.\n\n"
+ "This function is part of Guile's low-level support for the
psyntax\n"
+ "syntax expander. Users should not call this function.")
+#define FUNC_NAME s_scm_make_syntax_transformer
{
SCM z;
- SCM_VALIDATE_SYMBOL (1, type);
+ SCM (*prim)(SCM,SCM) = NULL;
- SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type),
- SCM_UNPACK (binding));
- SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED);
- return z;
-}
-#undef FUNC_NAME
+ if (scm_is_true (name))
+ {
+ SCM existing_var;
+
+ SCM_VALIDATE_SYMBOL (1, name);
+ existing_var = scm_sym2var (name, scm_current_module_lookup_closure (),
+ SCM_BOOL_F);
+ if (scm_is_true (existing_var)
+ && scm_is_true (scm_variable_bound_p (existing_var))
+ && SCM_MACROP (SCM_VARIABLE_REF (existing_var)))
+ prim = SCM_MACRO_PRIMITIVE (SCM_VARIABLE_REF (existing_var));
+ }
-SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3,
0, 0,
- (SCM m, SCM type, SCM binding),
- "Extend a core macro @var{m} with a syntax-case binding.")
-#define FUNC_NAME s_scm_make_extended_syncase_macro
-{
- SCM z;
- SCM_VALIDATE_SMOB (1, m, macro);
SCM_VALIDATE_SYMBOL (2, type);
- SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type),
- SCM_UNPACK (binding));
- SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED);
+ z = scm_words (scm_tc16_macro, 5);
+ SCM_SET_SMOB_DATA_N (z, 1, prim);
+ SCM_SET_SMOB_DATA_N (z, 2, name);
+ SCM_SET_SMOB_DATA_N (z, 3, type);
+ SCM_SET_SMOB_DATA_N (z, 4, binding);
return z;
}
#undef FUNC_NAME
-
-
SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} if @var{obj} is a regular macro, a memoizing
macro, a\n"
- "syntax transformer, or a syntax-case macro.")
+ "Return @code{#t} if @var{obj} is a syntax transformer (an object
that "
+ "transforms Scheme expressions at expansion-time).\n\n"
+ "Macros are actually just one kind of syntax transformer; this\n"
+ "procedure has its name due to historical reasons.")
#define FUNC_NAME s_scm_macro_p
{
- return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
+ return scm_from_bool (SCM_MACROP (obj));
}
#undef FUNC_NAME
-
-SCM_SYMBOL (scm_sym_syntax, "syntax");
-#if SCM_ENABLE_DEPRECATED == 1
-SCM_SYMBOL (scm_sym_macro, "macro");
-#endif
-SCM_SYMBOL (scm_sym_mmacro, "macro!");
-SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
-SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro");
-
SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
(SCM m),
- "Return one of the symbols @code{syntax}, @code{macro},\n"
- "@code{macro!}, or @code{syntax-case}, depending on whether\n"
- "@var{m} is a syntax transformer, a regular macro, a memoizing\n"
- "macro, or a syntax-case macro, respectively. If @var{m} is\n"
- "not a macro, @code{#f} is returned.")
+ "Return the type of the syntax transformer @var{m}, as passed to\n"
+ "@code{make-syntax-transformer}. If @var{m} is a primitive
syntax\n"
+ "transformer, @code{#f} will be returned.")
#define FUNC_NAME s_scm_macro_type
{
- if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
- return SCM_BOOL_F;
- switch (SCM_MACRO_TYPE (m))
- {
- case 0: return scm_sym_syntax;
-#if SCM_ENABLE_DEPRECATED == 1
- case 1: return scm_sym_macro;
-#endif
- case 2: return scm_sym_mmacro;
- case 3: return scm_sym_bimacro;
- case 4: return scm_sym_syncase_macro;
- default: scm_wrong_type_arg (FUNC_NAME, 1, m);
- }
+ SCM_VALIDATE_MACRO (1, m);
+ return SCM_MACRO_TYPE (m);
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
(SCM m),
- "Return the name of the macro @var{m}.")
+ "Return the name of the syntax transformer @var{m}.")
#define FUNC_NAME s_scm_macro_name
{
- SCM_VALIDATE_SMOB (1, m, macro);
- if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m))))
- return scm_procedure_name (SCM_SMOB_OBJECT (m));
- return SCM_BOOL_F;
+ SCM_VALIDATE_MACRO (1, m);
+ return SCM_MACRO_NAME (m);
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
(SCM m),
- "Return the transformer of the macro @var{m}.")
+ "Return the transformer procedure of the macro @var{m}.\n\n"
+ "If @var{m} is a syntax transformer but not a macro, @code{#f}\n"
+ "will be returned. (This can happen, for example, with primitive\n"
+ "syntax transformers).")
#define FUNC_NAME s_scm_macro_transformer
{
- SCM data;
-
- SCM_VALIDATE_SMOB (1, m, macro);
- data = SCM_PACK (SCM_SMOB_DATA (m));
-
- if (scm_is_true (scm_procedure_p (data)))
- return data;
+ SCM_VALIDATE_MACRO (1, m);
+ /* here we rely on knowledge of how psyntax represents macro bindings, but
+ hey, there is code out there that calls this function, and expects to get
+ a procedure in return... */
+ if (scm_is_pair (SCM_MACRO_BINDING (m))
+ && scm_is_true (scm_procedure_p (scm_car (SCM_MACRO_BINDING (m)))))
+ return scm_car (SCM_MACRO_BINDING (m));
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0,
+SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
(SCM m),
- "Return the type of the macro @var{m}.")
-#define FUNC_NAME s_scm_syncase_macro_type
+ "Return the binding of the syntax transformer @var{m}, as passed
to\n"
+ "@code{make-syntax-transformer}. If @var{m} is a primitive
syntax\n"
+ "transformer, @code{#f} will be returned.")
+#define FUNC_NAME s_scm_macro_binding
{
- SCM_VALIDATE_SMOB (1, m, macro);
-
- if (SCM_MACRO_IS_EXTENDED (m))
- return SCM_SMOB_OBJECT_2 (m);
- else
- return SCM_BOOL_F;
+ SCM_VALIDATE_MACRO (1, m);
+ return SCM_MACRO_BINDING (m);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0,
- (SCM m),
- "Return the binding of the macro @var{m}.")
-#define FUNC_NAME s_scm_syncase_macro_binding
-{
- SCM_VALIDATE_SMOB (1, m, macro);
-
- if (SCM_MACRO_IS_EXTENDED (m))
- return SCM_SMOB_OBJECT_3 (m);
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM
-scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
-{
- SCM var = scm_c_define (name, SCM_UNDEFINED);
- SCM transformer = scm_c_make_gsubr (name, 2, 0, 0, fcn);
- SCM_VARIABLE_SET (var, macroizer (transformer));
- return SCM_UNSPECIFIED;
-}
void
scm_init_macros ()
diff --git a/libguile/macros.h b/libguile/macros.h
index f05d2f1..de2496e 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -3,7 +3,7 @@
#ifndef SCM_MACROS_H
#define SCM_MACROS_H
-/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010 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,42 +27,22 @@
-#define SCM_ASSYNT(_cond, _msg, _subr) \
- if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
+typedef SCM (*scm_t_macro_primitive) (SCM, SCM);
-#define SCM_MACRO_TYPE_BITS (3)
-#define SCM_MACRO_TYPE_MASK ((1<<SCM_MACRO_TYPE_BITS)-1)
-#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
-
-#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
-#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
-#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
-#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
-#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
-#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
-
-SCM_API scm_t_bits scm_tc16_macro;
-
-SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
-SCM_API SCM scm_makmmacro (SCM code);
-SCM_API SCM scm_makacro (SCM code);
-SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
-SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
- SCM binding);
+SCM_API SCM scm_make_syntax_transformer (SCM name_or_existing_definition,
+ SCM type, SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
+SCM_API SCM scm_macro_binding (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
-SCM_API SCM scm_syncase_macro_type (SCM m);
-SCM_API SCM scm_syncase_macro_binding (SCM m);
-SCM_API SCM scm_make_synt (const char *name,
- SCM (*macroizer) (SCM),
- SCM (*fcn) ());
+
+SCM_INTERNAL SCM scm_i_make_primitive_macro (const char *name,
+ scm_t_macro_primitive fn);
+SCM_INTERNAL scm_t_macro_primitive scm_i_macro_primitive (SCM m);
+
SCM_INTERNAL void scm_init_macros (void);
-#if SCM_ENABLE_DEPRECATED == 1
-SCM_DEPRECATED SCM scm_makmacro (SCM code);
-#endif
#endif /* SCM_MACROS_H */
diff --git a/libguile/memoize.c b/libguile/memoize.c
index d2504dc..0427cea 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -42,7 +42,6 @@
-#if 0
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
#define CAAR(x) SCM_CAAR(x)
@@ -51,18 +50,7 @@
#define CDDR(x) SCM_CDDR(x)
#define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x)
-#define CADDDR(x) SCM_CDDDR(x)
-#else
-#define CAR(x) scm_car(x)
-#define CDR(x) scm_cdr(x)
-#define CAAR(x) scm_caar(x)
-#define CADR(x) scm_cadr(x)
-#define CDAR(x) scm_cdar(x)
-#define CDDR(x) scm_cddr(x)
-#define CADDR(x) scm_caddr(x)
-#define CDDDR(x) scm_cdddr(x)
-#define CADDDR(x) scm_cadddr(x)
-#endif
+#define CADDDR(x) SCM_CADDDR(x)
static const char s_bad_expression[] = "Bad expression";
@@ -199,6 +187,10 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_DYNWIND(in, expr, out) \
+ MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
+#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
+ MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
#define MAKMEMO_APPLY(exp) \
MAKMEMO (SCM_M_APPLY, exp)
#define MAKMEMO_CONT(proc) \
@@ -219,6 +211,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
#define MAKMEMO_MOD_SET(val, mod, var, public) \
MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var,
public))))
+#define MAKMEMO_PROMPT(tag, exp, handler) \
+ MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
@@ -231,6 +225,8 @@ static const char *const memoized_tags[] =
"let",
"quote",
"define",
+ "dynwind",
+ "with-fluids",
"apply",
"call/cc",
"call-with-values",
@@ -241,6 +237,7 @@ static const char *const memoized_tags[] =
"toplevel-set!",
"module-ref",
"module-set!",
+ "prompt",
};
static int
@@ -261,6 +258,8 @@ static SCM scm_m_cont (SCM xorig, SCM env);
static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
static SCM scm_m_cond (SCM xorig, SCM env);
static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_at_dynamic_wind (SCM xorig, SCM env);
+static SCM scm_m_with_fluids (SCM xorig, SCM env);
static SCM scm_m_eval_when (SCM xorig, SCM env);
static SCM scm_m_if (SCM xorig, SCM env);
static SCM scm_m_lambda (SCM xorig, SCM env);
@@ -268,6 +267,7 @@ static SCM scm_m_let (SCM xorig, SCM env);
static SCM scm_m_letrec (SCM xorig, SCM env);
static SCM scm_m_letstar (SCM xorig, SCM env);
static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_at_prompt (SCM xorig, SCM env);
static SCM scm_m_quote (SCM xorig, SCM env);
static SCM scm_m_set_x (SCM xorig, SCM env);
@@ -275,9 +275,7 @@ static SCM scm_m_set_x (SCM xorig, SCM env);
-typedef SCM (*t_syntax_transformer) (SCM, SCM);
-
-static t_syntax_transformer
+static scm_t_macro_primitive
memoize_env_ref_transformer (SCM env, SCM x)
{
SCM var;
@@ -287,15 +285,8 @@ memoize_env_ref_transformer (SCM env, SCM x)
var = scm_module_variable (env, x);
if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
- && SCM_MACROP (scm_variable_ref (var)))
- {
- SCM mac = scm_variable_ref (var);
- if (SCM_IMP (SCM_MACRO_CODE (mac))
- || (SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_gsubr))
- syntax_error ("bad macro", x, SCM_UNDEFINED);
- else
- return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /*
global macro */
- }
+ && scm_is_true (scm_macro_p (scm_variable_ref (var))))
+ return scm_i_macro_primitive (scm_variable_ref (var));
else
return NULL; /* anything else */
}
@@ -331,7 +322,7 @@ memoize (SCM exp, SCM env)
if (scm_is_pair (exp))
{
SCM CAR;
- t_syntax_transformer trans;
+ scm_t_macro_primitive trans;
CAR = CAR (exp);
if (scm_is_symbol (CAR))
@@ -383,34 +374,41 @@ memoize_sequence (const SCM forms, const SCM env)
{
ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
scm_cons (scm_sym_begin, forms));
- return MAKMEMO_BEGIN (memoize_exprs (forms, env));
+ if (scm_is_null (CDR (forms)))
+ return memoize (CAR (forms), env);
+ else
+ return MAKMEMO_BEGIN (memoize_exprs (forms, env));
}
/* Memoization. */
-/* bimacros (built-in macros) have isym codes.
- mmacros don't exist at runtime, they just expand out to more primitive
- forms. */
-SCM_SYNTAX (s_at, "@", scm_i_makbimacro, scm_m_at);
-SCM_SYNTAX (s_atat, "@@", scm_i_makbimacro, scm_m_atat);
-SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
-SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
-SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro,
scm_m_cont);
-SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro,
scm_m_at_call_with_values);
-SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
-SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
-SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
-SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
-SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
-SCM_SYNTAX (s_let, "let", scm_i_makbimacro, scm_m_let);
-SCM_SYNTAX (s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
-SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
-SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
-SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
-SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x);
-SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
+#define SCM_SYNTAX(RANAME, STR, CFN) \
+SCM_SNARF_HERE(static const char RANAME[]=STR)\
+SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_make_primitive_macro (RANAME, CFN)))
+
+SCM_SYNTAX (s_at, "@", scm_m_at);
+SCM_SYNTAX (s_atat, "@@", scm_m_atat);
+SCM_SYNTAX (s_and, "and", scm_m_and);
+SCM_SYNTAX (s_begin, "begin", scm_m_begin);
+SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_m_cont);
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values",
scm_m_at_call_with_values);
+SCM_SYNTAX (s_cond, "cond", scm_m_cond);
+SCM_SYNTAX (s_define, "define", scm_m_define);
+SCM_SYNTAX (s_at_dynamic_wind, "@dynamic-wind", scm_m_at_dynamic_wind);
+SCM_SYNTAX (s_with_fluids, "with-fluids", scm_m_with_fluids);
+SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when);
+SCM_SYNTAX (s_if, "if", scm_m_if);
+SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda);
+SCM_SYNTAX (s_let, "let", scm_m_let);
+SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec);
+SCM_SYNTAX (s_letstar, "let*", scm_m_letstar);
+SCM_SYNTAX (s_or, "or", scm_m_or);
+SCM_SYNTAX (s_at_prompt, "@prompt", scm_m_at_prompt);
+SCM_SYNTAX (s_quote, "quote", scm_m_quote);
+SCM_SYNTAX (s_set_x, "set!", scm_m_set_x);
+SCM_SYNTAX (s_atapply, "@apply", scm_m_apply);
SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
@@ -424,6 +422,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
+SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
+SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
@@ -432,6 +432,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
+SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_eval, "eval");
@@ -624,6 +625,40 @@ scm_m_define (SCM expr, SCM env)
}
static SCM
+scm_m_at_dynamic_wind (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_bad_expression, expr);
+
+ return MAKMEMO_DYNWIND (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env),
+ memoize (CADDDR (expr), env));
+}
+
+static SCM
+scm_m_with_fluids (SCM expr, SCM env)
+{
+ SCM binds, fluids, vals;
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ binds = CADR (expr);
+ ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
+ for (fluids = SCM_EOL, vals = SCM_EOL;
+ scm_is_pair (binds);
+ binds = CDR (binds))
+ {
+ SCM binding = CAR (binds);
+ ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
+ binding, expr);
+ fluids = scm_cons (memoize (CAR (binding), env), fluids);
+ vals = scm_cons (memoize (CADR (binding), env), vals);
+ }
+
+ return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids, SCM_UNDEFINED),
+ scm_reverse_x (vals, SCM_UNDEFINED),
+ memoize_sequence (CDDR (expr), env));
+}
+
+static SCM
scm_m_eval_when (SCM expr, SCM env)
{
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
@@ -940,6 +975,17 @@ scm_m_or (SCM expr, SCM env SCM_UNUSED)
}
static SCM
+scm_m_at_prompt (SCM expr, SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (expr) == 4, s_expression, expr);
+
+ return MAKMEMO_PROMPT (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env),
+ memoize (CADDDR (expr), env));
+}
+
+static SCM
scm_m_quote (SCM expr, SCM env SCM_UNUSED)
{
SCM quotee;
@@ -1066,6 +1112,23 @@ unmemoize (const SCM expr)
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_DYNWIND:
+ return scm_list_4 (scm_sym_at_dynamic_wind,
+ unmemoize (CAR (args)),
+ unmemoize (CADR (args)),
+ unmemoize (CDDR (args)));
+ case SCM_M_WITH_FLUIDS:
+ {
+ SCM binds = SCM_EOL, fluids, vals;
+ for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
+ fluids = CDR (fluids), vals = CDR (vals))
+ binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
+ unmemoize (CAR (vals))),
+ binds);
+ return scm_list_3 (scm_sym_with_fluids,
+ scm_reverse_x (binds, SCM_UNDEFINED),
+ unmemoize (CDDR (args)));
+ }
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr
(args)));
@@ -1089,16 +1152,23 @@ unmemoize (const SCM expr)
case SCM_M_TOPLEVEL_SET:
return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
case SCM_M_MODULE_REF:
- return scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
- scm_i_finite_list_copy (CAR (args)),
- CADR (args));
+ return SCM_VARIABLEP (args) ? args
+ : scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CAR (args)),
+ CADR (args));
case SCM_M_MODULE_SET:
return scm_list_3 (scm_sym_set_x,
- scm_list_3 (scm_is_true (CDDDR (args))
- ? scm_sym_at : scm_sym_atat,
- scm_i_finite_list_copy (CADR (args)),
- CADDR (args)),
+ SCM_VARIABLEP (CDR (args)) ? CDR (args)
+ : scm_list_3 (scm_is_true (CDDDR (args))
+ ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CADR (args)),
+ CADDR (args)),
unmemoize (CAR (args)));
+ case SCM_M_PROMPT:
+ return scm_list_4 (scm_sym_at_prompt,
+ unmemoize (CAR (args)),
+ unmemoize (CADR (args)),
+ unmemoize (CDDR (args)));
default:
abort ();
}
@@ -1129,7 +1199,9 @@ SCM_DEFINE (scm_memoized_expression_typecode,
"memoized-expression-typecode", 1,
#define FUNC_NAME s_scm_memoized_expression_typecode
{
SCM_VALIDATE_MEMOIZED (1, m);
- return scm_from_uint16 (SCM_MEMOIZED_TAG (m));
+
+ /* The tag is a 16-bit integer so it fits in an inum. */
+ return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m));
}
#undef FUNC_NAME
diff --git a/libguile/memoize.h b/libguile/memoize.h
index e033e67..26bd5b1 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -3,7 +3,7 @@
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -44,13 +44,16 @@ SCM_API SCM scm_sym_quote;
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
+SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
+SCM_API SCM scm_sym_at_prompt;
SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_at_dynamic_wind;
SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
@@ -75,6 +78,8 @@ enum
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
+ SCM_M_DYNWIND,
+ SCM_M_WITH_FLUIDS,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,
@@ -84,7 +89,8 @@ enum
SCM_M_TOPLEVEL_REF,
SCM_M_TOPLEVEL_SET,
SCM_M_MODULE_REF,
- SCM_M_MODULE_SET
+ SCM_M_MODULE_SET,
+ SCM_M_PROMPT
};
diff --git a/libguile/modules.c b/libguile/modules.c
index 545281a..fc6ff3b 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 Free
Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010 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
@@ -801,6 +801,8 @@ SCM_DEFINE (scm_module_reverse_lookup,
"module-reverse-lookup", 2, 0, 0,
obarray = SCM_MODULE_OBARRAY (module);
}
+ SCM_VALIDATE_VARIABLE (SCM_ARG2, variable);
+
if (!SCM_HASHTABLE_P (obarray))
return SCM_BOOL_F;
@@ -830,17 +832,18 @@ SCM_DEFINE (scm_module_reverse_lookup,
"module-reverse-lookup", 2, 0, 0,
}
}
- /* Try the `uses' list. */
- {
- SCM uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
- {
- SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
- if (scm_is_true (sym))
- return sym;
- uses = SCM_CDR (uses);
- }
- }
+ if (!scm_is_false (module))
+ {
+ /* Try the `uses' list. */
+ SCM uses = SCM_MODULE_USES (module);
+ while (scm_is_pair (uses))
+ {
+ SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
+ if (scm_is_true (sym))
+ return sym;
+ uses = SCM_CDR (uses);
+ }
+ }
return SCM_BOOL_F;
}
diff --git a/libguile/net_db.c b/libguile/net_db.c
index 4307091..bcba18e 100644
--- a/libguile/net_db.c
+++ b/libguile/net_db.c
@@ -1,5 +1,5 @@
/* "net_db.c" network database support
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009 Free Software
Foundation, Inc.
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009, 2010 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
@@ -30,6 +30,7 @@
# include <config.h>
#endif
+#include <verify.h>
#include <errno.h>
#include "libguile/_scm.h"
@@ -40,6 +41,7 @@
#include "libguile/validate.h"
#include "libguile/net_db.h"
+#include "libguile/socket.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -449,8 +451,299 @@ SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
#undef FUNC_NAME
#endif
+
+/* Protocol-independent name resolution with getaddrinfo(3) & co. */
+
+SCM_SYMBOL (sym_getaddrinfo_error, "getaddrinfo-error");
+
+/* Make sure the `AI_*' flags can be stored as INUMs. */
+verify (SCM_I_INUM (SCM_I_MAKINUM (AI_ALL)) == AI_ALL);
+
+/* Valid values for the `ai_flags' to `struct addrinfo'. */
+SCM_VARIABLE_INIT (sym_ai_passive, "AI_PASSIVE",
+ SCM_I_MAKINUM (AI_PASSIVE));
+SCM_VARIABLE_INIT (sym_ai_canonname, "AI_CANONNAME",
+ SCM_I_MAKINUM (AI_CANONNAME));
+SCM_VARIABLE_INIT (sym_ai_numerichost, "AI_NUMERICHOST",
+ SCM_I_MAKINUM (AI_NUMERICHOST));
+SCM_VARIABLE_INIT (sym_ai_numericserv, "AI_NUMERICSERV",
+ SCM_I_MAKINUM (AI_NUMERICSERV));
+SCM_VARIABLE_INIT (sym_ai_v4mapped, "AI_V4MAPPED",
+ SCM_I_MAKINUM (AI_V4MAPPED));
+SCM_VARIABLE_INIT (sym_ai_all, "AI_ALL",
+ SCM_I_MAKINUM (AI_ALL));
+SCM_VARIABLE_INIT (sym_ai_addrconfig, "AI_ADDRCONFIG",
+ SCM_I_MAKINUM (AI_ADDRCONFIG));
+
+/* Return a Scheme vector whose elements correspond to the fields of C_AI,
+ ignoring the `ai_next' field. This function is not exported because the
+ definition of `struct addrinfo' is provided by Gnulib. */
+static SCM
+scm_from_addrinfo (const struct addrinfo *c_ai)
+{
+ SCM ai;
+
+ /* Note: The indices here must be kept synchronized with those used by the
+ `addrinfo:' procedures in `networking.scm'. */
+
+ ai = scm_c_make_vector (6, SCM_UNDEFINED);
+ SCM_SIMPLE_VECTOR_SET (ai, 0, scm_from_int (c_ai->ai_flags));
+ SCM_SIMPLE_VECTOR_SET (ai, 1, scm_from_int (c_ai->ai_family));
+ SCM_SIMPLE_VECTOR_SET (ai, 2, scm_from_int (c_ai->ai_socktype));
+ SCM_SIMPLE_VECTOR_SET (ai, 3, scm_from_int (c_ai->ai_protocol));
+ SCM_SIMPLE_VECTOR_SET (ai, 4,
+ scm_from_sockaddr (c_ai->ai_addr, c_ai->ai_addrlen));
+ SCM_SIMPLE_VECTOR_SET (ai, 5,
+ c_ai->ai_canonname != NULL
+ ? scm_from_locale_string (c_ai->ai_canonname)
+ : SCM_BOOL_F);
+
+ return ai;
+}
+
+SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0,
+ (SCM name, SCM service, SCM hint_flags, SCM hint_family,
+ SCM hint_socktype, SCM hint_protocol),
+ "Return a list of @code{addrinfo} structures containing "
+ "a socket address and associated information for host @var{name} "
+ "and/or @var{service} to be used in creating a socket with "
+ "which to address the specified service.\n\n"
+ "@example\n"
+ "(let* ((ai (car (getaddrinfo \"www.gnu.org\" \"http\")))\n"
+ " (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)\n"
+ " (addrinfo:protocol ai))))\n"
+ " (connect s (addrinfo:addr ai))\n"
+ " s)\n"
+ "@end example\n\n"
+ "When @var{service} is omitted or is @code{#f}, return "
+ "network-level addresses for @var{name}. When @var{name} "
+ "is @code{#f} @var{service} must be provided and service "
+ "locations local to the caller are returned.\n"
+ "\n"
+ "Additional hints can be provided. When specified, "
+ "@var{hint_flags} should be a bitwise-or of zero or more "
+ "constants among the following:\n\n"
+ "@table @code\n"
+ "@item AI_PASSIVE\n"
+ "Socket address is intended for @code{bind}.\n\n"
+ "@item AI_CANONNAME\n"
+ "Request for canonical host name, available via "
+ "@code{addrinfo:canonname}. This makes sense mainly when "
+ "DNS lookups are involved.\n\n"
+ "@item AI_NUMERICHOST\n"
+ "Specifies that @var{name} is a numeric host address string "
+ "(e.g., @code{\"127.0.0.1\"}), meaning that name resolution "
+ "will not be used.\n\n"
+ "@item AI_NUMERICSERV\n"
+ "Likewise, specifies that @var{service} is a numeric port "
+ "string (e.g., @code{\"80\"}).\n\n"
+ "@item AI_ADDRCONFIG\n"
+ "Return only addresses configured on the local system. It is "
+ "highly recommended to provide this flag when the returned "
+ "socket addresses are to be used to make connections; "
+ "otherwise, some of the returned addresses could be unreachable "
+ "or use a protocol that is not supported.\n\n"
+ "@item AI_V4MAPPED\n"
+ "When looking up IPv6 addresses, return mapped "
+ "IPv4 addresses if there is no IPv6 address available at all.\n\n"
+ "@item AI_ALL\n"
+ "If this flag is set along with @code{AI_V4MAPPED} when looking "
+ "up IPv6 addresses, return all IPv6 addresses "
+ "as well as all IPv4 addresses, the latter mapped to IPv6 "
+ "format.\n"
+ "@end table\n\n"
+ "When given, @var{hint_family} should specify the requested "
+ "address family, e.g., @code{AF_INET6}. Similarly, "
+ "@var{hint_socktype} should specify the requested socket type "
+ "(e.g., @code{SOCK_DGRAM}), and @var{hint_protocol} should "
+ "specify the requested protocol (its value is interpretered "
+ "as in calls to @code{socket}).\n"
+ "\n"
+ "On error, an exception with key @code{getaddrinfo-error} is "
+ "thrown, with an error code (an integer) as its argument:\n\n"
+ "@example\n"
+ "(catch 'getaddrinfo-error\n"
+ " (lambda ()\n"
+ " (getaddrinfo \"www.gnu.org\" \"gopher\"))\n"
+ " (lambda (key errcode)\n"
+ " (cond ((= errcode EAI_SERVICE)\n"
+ " (display \"doesn't know about Gopher!\\n\"))\n"
+ " ((= errcode EAI_NONAME)\n"
+ " (display \"www.gnu.org not found\\n\"))\n"
+ " (else\n"
+ " (format #t \"something wrong: ~a\\n\"\n"
+ " (gai-strerror errcode))))))\n"
+ "@end example\n"
+ "\n"
+ "Error codes are:\n\n"
+ "@table @code\n"
+ "@item EAI_AGAIN\n"
+ "The name or service could not be resolved at this time. Future "
+ "attempts may succeed.\n\n"
+ "@item EAI_BADFLAGS\n"
+ "@var{hint_flags} contains an invalid value.\n\n"
+ "@item EAI_FAIL\n"
+ "A non-recoverable error occurred when attempting to "
+ "resolve the name.\n\n"
+ "@item EAI_FAMILY\n"
+ "@var{hint_family} was not recognized.\n\n"
+ "@item EAI_NONAME\n"
+ "Either @var{name} does not resolve for the supplied parameters, "
+ "or neither @var{name} nor @var{service} were supplied.\n\n"
+ "@item EAI_SERVICE\n"
+ "@var{service} was not recognized for the specified socket
type.\n\n"
+ "@item EAI_SOCKTYPE\n"
+ "@var{hint_socktype} was not recognized.\n\n"
+ "@item EAI_SYSTEM\n"
+ "A system error occurred; the error code can be found in "
+ "@code{errno}.\n"
+ "@end table\n"
+ "\n"
+ "Users are encouraged to read the "
+
"@url{http://www.opengroup.org/onlinepubs/9699919799/functions/getaddrinfo.html,";
+ "POSIX specification} for more details.\n")
+#define FUNC_NAME s_scm_getaddrinfo
+{
+ int err;
+ char *c_name, *c_service;
+ struct addrinfo c_hints, *c_result;
+ SCM result = SCM_EOL;
+
+ if (scm_is_true (name))
+ SCM_VALIDATE_STRING (SCM_ARG1, name);
+
+ if (!SCM_UNBNDP (service) && scm_is_true (service))
+ SCM_VALIDATE_STRING (SCM_ARG2, service);
+
+ scm_dynwind_begin (0);
+
+ if (scm_is_string (name))
+ {
+ c_name = scm_to_locale_string (name);
+ scm_dynwind_free (c_name);
+ }
+ else
+ c_name = NULL;
+
+ if (scm_is_string (service))
+ {
+ c_service = scm_to_locale_string (service);
+ scm_dynwind_free (c_service);
+ }
+ else
+ c_service = NULL;
+
+ memset (&c_hints, 0, sizeof (c_hints));
+ if (!SCM_UNBNDP (hint_flags))
+ {
+ c_hints.ai_flags = scm_to_int (hint_flags);
+ if (!SCM_UNBNDP (hint_family))
+ {
+ c_hints.ai_family = scm_to_int (hint_family);
+ if (!SCM_UNBNDP (hint_socktype))
+ {
+ c_hints.ai_socktype = scm_to_int (hint_socktype);
+ if (!SCM_UNBNDP (hint_family))
+ c_hints.ai_family = scm_to_int (hint_family);
+ }
+ }
+ }
+
+ err = getaddrinfo (c_name, c_service, &c_hints, &c_result);
+ if (err == 0)
+ {
+ SCM *prev_addr;
+ struct addrinfo *a;
-void
+ for (prev_addr = &result, a = c_result;
+ a != NULL;
+ a = a->ai_next, prev_addr = SCM_CDRLOC (*prev_addr))
+ *prev_addr = scm_list_1 (scm_from_addrinfo (a));
+
+ freeaddrinfo (c_result);
+ }
+ else
+ scm_throw (sym_getaddrinfo_error, scm_list_1 (scm_from_int (err)));
+
+ scm_dynwind_end ();
+
+ return result;
+}
+#undef FUNC_NAME
+
+/* Make sure the `EAI_*' flags can be stored as INUMs. */
+verify (SCM_I_INUM (SCM_I_MAKINUM (EAI_BADFLAGS)) == EAI_BADFLAGS);
+
+/* Error codes returned by `getaddrinfo'. */
+SCM_VARIABLE_INIT (sym_eai_badflags, "EAI_BADFLAGS",
+ SCM_I_MAKINUM (EAI_BADFLAGS));
+SCM_VARIABLE_INIT (sym_eai_noname, "EAI_NONAME",
+ SCM_I_MAKINUM (EAI_NONAME));
+SCM_VARIABLE_INIT (sym_eai_again, "EAI_AGAIN",
+ SCM_I_MAKINUM (EAI_AGAIN));
+SCM_VARIABLE_INIT (sym_eai_fail, "EAI_FAIL",
+ SCM_I_MAKINUM (EAI_FAIL));
+SCM_VARIABLE_INIT (sym_eai_family, "EAI_FAMILY",
+ SCM_I_MAKINUM (EAI_FAMILY));
+SCM_VARIABLE_INIT (sym_eai_socktype, "EAI_SOCKTYPE",
+ SCM_I_MAKINUM (EAI_SOCKTYPE));
+SCM_VARIABLE_INIT (sym_eai_service, "EAI_SERVICE",
+ SCM_I_MAKINUM (EAI_SERVICE));
+SCM_VARIABLE_INIT (sym_eai_memory, "EAI_MEMORY",
+ SCM_I_MAKINUM (EAI_MEMORY));
+SCM_VARIABLE_INIT (sym_eai_system, "EAI_SYSTEM",
+ SCM_I_MAKINUM (EAI_SYSTEM));
+SCM_VARIABLE_INIT (sym_eai_overflow, "EAI_OVERFLOW",
+ SCM_I_MAKINUM (EAI_OVERFLOW));
+
+/* The following values are GNU extensions. */
+#ifdef EAI_NODATA
+SCM_VARIABLE_INIT (sym_eai_nodata, "EAI_NODATA",
+ SCM_I_MAKINUM (EAI_NODATA));
+#endif
+#ifdef EAI_ADDRFAMILY
+SCM_VARIABLE_INIT (sym_eai_addrfamily, "EAI_ADDRFAMILY",
+ SCM_I_MAKINUM (EAI_ADDRFAMILY));
+#endif
+#ifdef EAI_INPROGRESS
+SCM_VARIABLE_INIT (sym_eai_inprogress, "EAI_INPROGRESS",
+ SCM_I_MAKINUM (EAI_INPROGRESS));
+#endif
+#ifdef EAI_CANCELED
+SCM_VARIABLE_INIT (sym_eai_canceled, "EAI_CANCELED",
+ SCM_I_MAKINUM (EAI_CANCELED));
+#endif
+#ifdef EAI_NOTCANCELED
+SCM_VARIABLE_INIT (sym_eai_notcanceled, "EAI_NOTCANCELED",
+ SCM_I_MAKINUM (EAI_NOTCANCELED));
+#endif
+#ifdef EAI_ALLDONE
+SCM_VARIABLE_INIT (sym_eai_alldone, "EAI_ALLDONE",
+ SCM_I_MAKINUM (EAI_ALLDONE));
+#endif
+#ifdef EAI_INTR
+SCM_VARIABLE_INIT (sym_eai_intr, "EAI_INTR",
+ SCM_I_MAKINUM (EAI_INTR));
+#endif
+#ifdef EAI_IDN_ENCODE
+SCM_VARIABLE_INIT (sym_eai_idn_encode, "EAI_IDN_ENCODE",
+ SCM_I_MAKINUM (EAI_IDN_ENCODE));
+#endif
+
+SCM_DEFINE (scm_gai_strerror, "gai-strerror", 1, 0, 0,
+ (SCM error),
+ "Return a string describing @var{error}, an integer error code "
+ "returned by @code{getaddrinfo}.")
+#define FUNC_NAME s_scm_gai_strerror
+{
+ return scm_from_locale_string (gai_strerror (scm_to_int (error)));
+}
+#undef FUNC_NAME
+
+/* TODO: Add a getnameinfo(3) wrapper. */
+
+
+void
scm_init_net_db ()
{
scm_add_feature ("net-db");
diff --git a/libguile/net_db.h b/libguile/net_db.h
index 4b6327f..68b2a8b 100644
--- a/libguile/net_db.h
+++ b/libguile/net_db.h
@@ -3,7 +3,7 @@
#ifndef SCM_NET_DB_H
#define SCM_NET_DB_H
-/* Copyright (C) 1995,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,2000,2001, 2006, 2008, 2010 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,6 +35,8 @@ SCM_API SCM scm_sethost (SCM arg);
SCM_API SCM scm_setnet (SCM arg);
SCM_API SCM scm_setproto (SCM arg);
SCM_API SCM scm_setserv (SCM arg);
+SCM_API SCM scm_getaddrinfo (SCM, SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_gai_strerror (SCM);
SCM_INTERNAL void scm_init_net_db (void);
#endif /* SCM_NET_DB_H */
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 87ffaa5..2931468 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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
@@ -30,7 +30,6 @@
#include <alignof.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
@@ -43,8 +42,6 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
* Objcode type
*/
-scm_t_bits scm_tc16_objcode;
-
static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
@@ -91,9 +88,10 @@ make_objcode_by_mmap (int fd)
+ data->metalen)));
}
- SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
- SCM_PACK (SCM_BOOL_F), fd);
- SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+ sret = scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_MMAP<<8),
+ (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
+ SCM_UNPACK (SCM_BOOL_F),
+ (scm_t_bits)fd);
/* FIXME: we leak ourselves and the file descriptor. but then again so does
dlopen(). */
@@ -107,7 +105,6 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
{
const struct scm_objcode *data, *parent_data;
const scm_t_uint8 *parent_base;
- SCM ret;
SCM_VALIDATE_OBJCODE (1, parent);
parent_data = SCM_OBJCODE_DATA (parent);
@@ -131,9 +128,8 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
<= parent_base + parent_data->len + parent_data->metalen);
- SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
- SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
- return ret;
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_SLICE<<8),
+ (scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME
@@ -172,32 +168,27 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode",
1, 0, 0,
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
- ssize_t increment;
- scm_t_array_handle handle;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
- SCM objcode;
- if (scm_is_false (scm_u8vector_p (bytecode)))
+ if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ size = SCM_BYTEVECTOR_LENGTH (bytecode);
+ c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
+
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
- SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
- scm_array_handle_release (&handle);
- SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
if (data->len + data->metalen != (size - sizeof (*data)))
- scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+ scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
scm_list_2 (scm_from_size_t (size),
scm_from_uint32 (sizeof (*data) + data->len +
data->metalen)));
- assert (increment == 1);
- SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
-
+
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
-
- return objcode;
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_BYTEVECTOR<<8),
+ (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
}
#undef FUNC_NAME
@@ -225,17 +216,17 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode",
1, 0, 0,
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
- scm_t_uint8 *u8vector;
+ scm_t_int8 *s8vector;
scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- u8vector = scm_malloc (len);
- memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+ s8vector = scm_malloc (len);
+ memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
- return scm_take_u8vector (u8vector, len);
+ return scm_c_take_bytevector (s8vector, len);
}
#undef FUNC_NAME
@@ -255,12 +246,20 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
}
#undef FUNC_NAME
+void
+scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<objcode ", port);
+ scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
+ scm_puts (">", port);
+}
+
void
scm_bootstrap_objcodes (void)
{
- scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
- scm_c_register_extension ("libguile", "scm_init_objcodes",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_objcodes",
(scm_t_extension_init_func)scm_init_objcodes,
NULL);
}
@@ -275,8 +274,6 @@ scm_bootstrap_objcodes (void)
void
scm_init_objcodes (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/objcodes.x"
#endif
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 4627cfb..2bff9aa 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,14 +35,13 @@ struct scm_objcode
#define SCM_C_OBJCODE_BASE(obj) \
((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))
-#define SCM_F_OBJCODE_IS_MMAP (1<<0)
-#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
-#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+#define SCM_F_OBJCODE_IS_MMAP (1<<0)
+#define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
+#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+#define SCM_F_OBJCODE_IS_STATIC (1<<3)
-SCM_API scm_t_bits scm_tc16_objcode;
-
-#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
-#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_OBJCODE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) ==
scm_tc7_objcode)
+#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
@@ -50,9 +49,10 @@ SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN
(x))
#define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))
-#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
-#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) &
SCM_F_OBJCODE_IS_U8VECTOR)
-#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
+#define SCM_OBJCODE_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 8)
+#define SCM_OBJCODE_IS_MMAP(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_FLAGS (x) &
SCM_F_OBJCODE_IS_BYTEVECTOR)
+#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_FLAGS (x) &
SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_load_objcode (SCM file);
@@ -62,6 +62,8 @@ SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
+SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_objcodes (void);
SCM_INTERNAL void scm_init_objcodes (void);
diff --git a/libguile/options.c b/libguile/options.c
index ba2e95e..6e4c187 100644
--- a/libguile/options.c
+++ b/libguile/options.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software
Foundation
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010 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
@@ -24,7 +24,6 @@
#include "libguile/_scm.h"
#include "libguile/mallocs.h"
#include "libguile/strings.h"
-#include "libguile/lang.h"
#include "libguile/options.h"
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 81d89b5..0e98162 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -3,7 +3,7 @@
#ifndef SCM_PAIRS_H
#define SCM_PAIRS_H
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009, 2010 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
@@ -36,12 +36,13 @@
/*
* Use scm_is_null_and_not_nil if it's important (for correctness)
- * that %nil must NOT be considered null.
+ * that #nil must NOT be considered null.
*/
#define scm_is_null_and_not_nil(x) (scm_is_eq ((x), SCM_EOL))
/*
- * Use scm_is_null_assume_not_nil if %nil will never be tested,
+ * Use scm_is_null_assume_not_nil if
+#nil will never be tested,
* for increased efficiency.
*/
#define scm_is_null_assume_not_nil(x) (scm_is_eq ((x), SCM_EOL))
@@ -51,15 +52,17 @@
* SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
* how the following macro works.
*/
-#if SCM_ENABLE_ELISP
-# define scm_is_null_or_nil(x) \
+#define scm_is_null_or_nil(x) \
(SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_EOL))
-#else
-# define scm_is_null_or_nil(x) (scm_is_null_assume_not_nil (x))
-#endif
-/* XXX Should scm_is_null treat %nil as null by default? */
-#define scm_is_null(x) (scm_is_null_and_not_nil(x))
+
+/* Older spellings for these nil predicates. */
+#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))
+#define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
+
+
+/* #nil is null. */
+#define scm_is_null(x) (scm_is_null_or_nil(x))
#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
diff --git a/libguile/ports.c b/libguile/ports.c
index f56c092..7328767 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
2008, 2009, 2010 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
@@ -2042,7 +2042,7 @@ SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
if (enc)
return scm_from_locale_string (pt->encoding);
else
- return scm_from_locale_string ("NONE");
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
diff --git a/libguile/posix.c b/libguile/posix.c
index 5187ff9..3244e6e 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -37,7 +37,6 @@
#include "libguile/srfi-14.h"
#include "libguile/vectors.h"
#include "libguile/values.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/posix.h"
@@ -983,6 +982,18 @@ SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_SETSID */
+#ifdef HAVE_GETSID
+SCM_DEFINE (scm_getsid, "getsid", 1, 0, 0,
+ (SCM pid),
+ "Returns the session ID of process @var{pid}. (The session\n"
+ "ID of a process is the process group ID of its session leader.)")
+#define FUNC_NAME s_scm_getsid
+{
+ return scm_from_int (getsid (scm_to_int (pid)));
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETSID */
+
/* ttyname returns its result in a single static buffer, hence
scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads
@@ -1361,13 +1372,18 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
- (SCM pathname, SCM actime, SCM modtime),
+SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
+ (SCM pathname, SCM actime, SCM modtime, SCM actimens, SCM
modtimens,
+ SCM flags),
"@code{utime} sets the access and modification times for the\n"
"file named by @var{path}. If @var{actime} or @var{modtime} is\n"
"not supplied, then the current time is used. @var{actime} and\n"
"@var{modtime} must be integer time values as returned by the\n"
- "@code{current-time} procedure.\n"
+ "@code{current-time} procedure.\n\n"
+ "The optional @var{actimens} and @var{modtimens} are nanoseconds\n"
+ "to add @var{actime} and @var{modtime}. Nanosecond precision is\n"
+ "only supported on some combinations of filesystems and
operating\n"
+ "systems.\n"
"@lisp\n"
"(utime \"foo\" (- (current-time) 3600))\n"
"@end lisp\n"
@@ -1376,20 +1392,75 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
#define FUNC_NAME s_scm_utime
{
int rv;
- struct utimbuf utm_tmp;
-
+ time_t atim_sec, mtim_sec;
+ long atim_nsec, mtim_nsec;
+ int f;
+
if (SCM_UNBNDP (actime))
- SCM_SYSCALL (time (&utm_tmp.actime));
+ {
+#ifdef HAVE_UTIMENSAT
+ atim_sec = 0;
+ atim_nsec = UTIME_NOW;
+#else
+ SCM_SYSCALL (time (&atim_sec));
+ atim_nsec = 0;
+#endif
+ }
else
- utm_tmp.actime = SCM_NUM2ULONG (2, actime);
-
+ {
+ atim_sec = SCM_NUM2ULONG (2, actime);
+ if (SCM_UNBNDP (actimens))
+ atim_nsec = 0;
+ else
+ atim_nsec = SCM_NUM2LONG (4, actimens);
+ }
+
if (SCM_UNBNDP (modtime))
- SCM_SYSCALL (time (&utm_tmp.modtime));
+ {
+#ifdef HAVE_UTIMENSAT
+ mtim_sec = 0;
+ mtim_nsec = UTIME_NOW;
+#else
+ SCM_SYSCALL (time (&mtim_sec));
+ mtim_nsec = 0;
+#endif
+ }
+ else
+ {
+ mtim_sec = SCM_NUM2ULONG (3, modtime);
+ if (SCM_UNBNDP (modtimens))
+ mtim_nsec = 0;
+ else
+ mtim_nsec = SCM_NUM2LONG (5, modtimens);
+ }
+
+ if (SCM_UNBNDP (flags))
+ f = 0;
else
- utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
+ f = SCM_NUM2INT (6, flags);
+
+#ifdef HAVE_UTIMENSAT
+ {
+ struct timespec times[2];
+ times[0].tv_sec = atim_sec;
+ times[0].tv_nsec = atim_nsec;
+ times[1].tv_sec = mtim_sec;
+ times[1].tv_nsec = mtim_nsec;
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utimensat (AT_FDCWD, c_pathname, times, f));
+ }
+#else
+ {
+ struct utimbuf utm;
+ utm.actime = atim_sec;
+ utm.modtime = mtim_sec;
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utime (c_pathname, &utm));
+ }
+#endif
- STRING_SYSCALL (pathname, c_pathname,
- rv = utime (c_pathname, &utm_tmp));
if (rv != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
diff --git a/libguile/posix.h b/libguile/posix.h
index 4171332..420311e 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -33,6 +33,7 @@ SCM_API SCM scm_tcsetpgrp (SCM port, SCM pgid);
SCM_API SCM scm_tcgetpgrp (SCM port);
SCM_API SCM scm_ctermid (void);
SCM_API SCM scm_setsid (void);
+SCM_API SCM scm_getsid (SCM pid);
SCM_API SCM scm_setpgid (SCM pid, SCM pgid);
SCM_API SCM scm_pipe (void);
SCM_API SCM scm_getgroups (void);
@@ -69,7 +70,8 @@ SCM_API SCM scm_tmpnam (void);
SCM_API SCM scm_mkstemp (SCM tmpl);
SCM_API SCM scm_open_pipe (SCM pipestr, SCM modes);
SCM_API SCM scm_close_pipe (SCM port);
-SCM_API SCM scm_utime (SCM pathname, SCM actime, SCM modtime);
+SCM_API SCM scm_utime (SCM pathname, SCM actime, SCM modtime,
+ SCM actimens, SCM modtimens, SCM flags);
SCM_API SCM scm_access (SCM path, SCM how);
SCM_API SCM scm_getpid (void);
SCM_API SCM scm_putenv (SCM str);
diff --git a/libguile/print.c b/libguile/print.c
index d50df2d..e469277 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010
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
@@ -30,6 +30,7 @@
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/smob.h"
+#include "libguile/control.h"
#include "libguile/eval.h"
#include "libguile/macros.h"
#include "libguile/procprop.h"
@@ -43,8 +44,8 @@
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
-#include "libguile/lang.h"
#include "libguile/numbers.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/print.h"
@@ -66,7 +67,9 @@ static const char *iflagnames[] =
"#<XXX UNUSED LISP FALSE -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
"()",
"#t",
- "#<XXX UNUSED BOOLEAN -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "#<XXX UNUSED BOOLEAN 0 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "#<XXX UNUSED BOOLEAN 1 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "#<XXX UNUSED BOOLEAN 2 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
"#<unspecified>",
"#<undefined>",
"#<eof>",
@@ -408,6 +411,22 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display,
g_display);
static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
+
+/* Print a character as an octal or hex escape. */
+#define PRINT_CHAR_ESCAPE(i, port) \
+ do \
+ { \
+ if (!SCM_R6RS_ESCAPES_P) \
+ scm_intprint (i, 8, port); \
+ else \
+ { \
+ scm_puts ("x", port); \
+ scm_intprint (i, 16, port); \
+ } \
+ } \
+ while (0)
+
+
void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
@@ -487,7 +506,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
else
/* Character is graphic but unrepresentable in
this port's encoding. */
- scm_intprint (i, 8, port);
+ PRINT_CHAR_ESCAPE (i, port);
}
else
{
@@ -506,12 +525,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
else
/* Character is graphic but unrepresentable in
this port's encoding. */
- scm_intprint (i, 8, port);
+ PRINT_CHAR_ESCAPE (i, port);
}
}
else
/* Character is a non-graphical character. */
- scm_intprint (i, 8, port);
+ PRINT_CHAR_ESCAPE (i, port);
}
else
scm_i_charprint (i, port);
@@ -578,9 +597,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_string:
if (SCM_WRITINGP (pstate))
{
- size_t i, j, len;
+ size_t i, len;
static char const hex[] = "0123456789abcdef";
- char buf[8];
+ char buf[9];
scm_putc ('"', port);
@@ -646,37 +665,61 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
/* Character is graphic but unrepresentable in
this port's encoding or is not graphic. */
- if (ch <= 0xFF)
+ if (!SCM_R6RS_ESCAPES_P)
{
- buf[0] = '\\';
- buf[1] = 'x';
- buf[2] = hex[ch / 16];
- buf[3] = hex[ch % 16];
- scm_lfwrite (buf, 4, port);
- }
- else if (ch <= 0xFFFF)
- {
- buf[0] = '\\';
- buf[1] = 'u';
- buf[2] = hex[(ch & 0xF000) >> 12];
- buf[3] = hex[(ch & 0xF00) >> 8];
- buf[4] = hex[(ch & 0xF0) >> 4];
- buf[5] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 6, port);
- j = i + 1;
+ if (ch <= 0xFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'x';
+ buf[2] = hex[ch / 16];
+ buf[3] = hex[ch % 16];
+ scm_lfwrite (buf, 4, port);
+ }
+ else if (ch <= 0xFFFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'u';
+ buf[2] = hex[(ch & 0xF000) >> 12];
+ buf[3] = hex[(ch & 0xF00) >> 8];
+ buf[4] = hex[(ch & 0xF0) >> 4];
+ buf[5] = hex[(ch & 0xF)];
+ scm_lfwrite (buf, 6, port);
+ }
+ else if (ch > 0xFFFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'U';
+ buf[2] = hex[(ch & 0xF00000) >> 20];
+ buf[3] = hex[(ch & 0xF0000) >> 16];
+ buf[4] = hex[(ch & 0xF000) >> 12];
+ buf[5] = hex[(ch & 0xF00) >> 8];
+ buf[6] = hex[(ch & 0xF0) >> 4];
+ buf[7] = hex[(ch & 0xF)];
+ scm_lfwrite (buf, 8, port);
+ }
}
- else if (ch > 0xFFFF)
+ else
{
- buf[0] = '\\';
- buf[1] = 'U';
- buf[2] = hex[(ch & 0xF00000) >> 20];
- buf[3] = hex[(ch & 0xF0000) >> 16];
- buf[4] = hex[(ch & 0xF000) >> 12];
- buf[5] = hex[(ch & 0xF00) >> 8];
- buf[6] = hex[(ch & 0xF0) >> 4];
- buf[7] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 8, port);
- j = i + 1;
+ scm_t_wchar ch2 = ch;
+
+ /* Print an R6RS variable-length hex escape:
"\xNNNN;"
+ */
+ int i = 8;
+ buf[i] = ';';
+ i --;
+ if (ch == 0)
+ buf[i--] = '0';
+ else
+ while (ch2 > 0)
+ {
+ buf[i] = hex[ch2 & 0xF];
+ ch2 >>= 4;
+ i --;
+ }
+ buf[i] = 'x';
+ i --;
+ buf[i] = '\\';
+ scm_lfwrite (buf + i, 9 - i, port);
}
}
}
@@ -708,6 +751,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
+ case scm_tc7_foreign:
+ scm_i_foreign_print (exp, port, pstate);
+ break;
case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate);
break;
@@ -717,6 +763,24 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_dynamic_state:
scm_i_dynamic_state_print (exp, port, pstate);
break;
+ case scm_tc7_frame:
+ scm_i_frame_print (exp, port, pstate);
+ break;
+ case scm_tc7_objcode:
+ scm_i_objcode_print (exp, port, pstate);
+ break;
+ case scm_tc7_vm:
+ scm_i_vm_print (exp, port, pstate);
+ break;
+ case scm_tc7_vm_cont:
+ scm_i_vm_cont_print (exp, port, pstate);
+ break;
+ case scm_tc7_prompt:
+ scm_i_prompt_print (exp, port, pstate);
+ break;
+ case scm_tc7_with_fluids:
+ scm_i_with_fluids_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
@@ -773,17 +837,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
EXIT_NESTED_DATA (pstate);
break;
- case scm_tc7_gsubr:
- {
- SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
- scm_puts (SCM_SUBR_GENERIC (exp)
- ? "#<primitive-generic "
- : "#<primitive-procedure ",
- port);
- scm_lfwrite_str (name, port);
- scm_putc ('>', port);
- break;
- }
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);
diff --git a/libguile/private-options.h b/libguile/private-options.h
index 703ca8a..7ef19c9 100644
--- a/libguile/private-options.h
+++ b/libguile/private-options.h
@@ -4,7 +4,7 @@
* We put this in a private header, since layout of data structures
* is an implementation detail that we want to hide.
*
- * Copyright (C) 2007, 2009 Free Software Foundation, Inc.
+ * Copyright (C) 2007, 2009, 2010 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
@@ -91,12 +91,11 @@ SCM_API scm_t_option scm_read_opts[];
#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
#define SCM_KEYWORD_STYLE scm_read_opts[3].val
-#if SCM_ENABLE_ELISP
#define SCM_ELISP_VECTORS_P scm_read_opts[4].val
#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val
-#define SCM_N_READ_OPTIONS 6
-#else
-#define SCM_N_READ_OPTIONS 4
-#endif
+#define SCM_R6RS_ESCAPES_P scm_read_opts[6].val
+#define SCM_SQUARE_BRACKETS_P scm_read_opts[7].val
+
+#define SCM_N_READ_OPTIONS 8
#endif /* PRIVATE_OPTIONS */
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 7cfd2e6..b3c6c86 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010
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
@@ -40,6 +40,7 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM props;
static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -47,40 +48,27 @@ static scm_i_pthread_mutex_t props_lock =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
int
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
- if (SCM_IMP (proc))
- return 0;
- loop:
- switch (SCM_TYP7 (proc))
+ while (!SCM_PROGRAM_P (proc))
{
- case scm_tc7_program:
- return scm_i_program_arity (proc, req, opt, rest);
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- {
- int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
- *req = SCM_GSUBR_REQ (type);
- *opt = SCM_GSUBR_OPT (type);
- *rest = SCM_GSUBR_REST (type);
- return 1;
- }
- else
+ if (SCM_IMP (proc))
return 0;
- case scm_tc7_gsubr:
- {
- unsigned int type = SCM_GSUBR_TYPE (proc);
- *req = SCM_GSUBR_REQ (type);
- *opt = SCM_GSUBR_OPT (type);
- *rest = SCM_GSUBR_REST (type);
- return 1;
- }
- case scm_tcs_struct:
- if (!SCM_STRUCT_APPLICABLE_P (proc))
- return 0;
- proc = SCM_STRUCT_PROCEDURE (proc);
- goto loop;
- default:
- return 0;
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ return 0;
+ proc = scm_i_smob_apply_trampoline (proc);
+ break;
+ case scm_tcs_struct:
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return 0;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ break;
+ default:
+ return 0;
+ }
}
+ return scm_i_program_arity (proc, req, opt, rest);
}
/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
diff --git a/libguile/procs.c b/libguile/procs.c
index 6c03911..10ae885 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -41,53 +41,6 @@
*/
-SCM
-scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
-{
- register SCM z;
- SCM sname;
- SCM *meta_info;
-
- meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
- sname = scm_from_locale_symbol (name);
- meta_info[0] = sname;
- meta_info[1] = SCM_EOL; /* properties */
-
- z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn,
- 0 /* generic */, (scm_t_bits) meta_info);
-
- scm_remember_upto_here_1 (sname);
-
- return z;
-}
-
-SCM
-scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
-{
- SCM subr = scm_c_make_subr (name, type, fcn);
- scm_define (SCM_SUBR_NAME (subr), subr);
- return subr;
-}
-
-SCM
-scm_c_make_subr_with_generic (const char *name,
- long type, SCM (*fcn) (), SCM *gf)
-{
- SCM subr = scm_c_make_subr (name, type, fcn);
- SCM_SET_SUBR_GENERIC_LOC (subr, gf);
- return subr;
-}
-
-SCM
-scm_c_define_subr_with_generic (const char *name,
- long type, SCM (*fcn) (), SCM *gf)
-{
- SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
- scm_define (SCM_SUBR_NAME (subr), subr);
- return subr;
-}
-
-
SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a procedure.")
@@ -100,7 +53,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
|| SCM_STRUCT_APPLICABLE_P (obj)))
break;
- case scm_tc7_gsubr:
case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
@@ -123,21 +75,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#undef FUNC_NAME
-/* Only used internally. */
-int
-scm_subr_p (SCM obj)
-{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tc7_gsubr:
- return 1;
- default:
- ;
- }
- return 0;
-}
-
SCM_SYMBOL (sym_documentation, "documentation");
SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
@@ -187,14 +124,7 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
- switch (SCM_TYP7 (procedure)) {
- case scm_tc7_gsubr:
- name = SCM_SUBR_NAME (procedure);
- break;
- default:
- name = scm_procedure_property (procedure, scm_sym_name);
- break;
- }
+ name = scm_procedure_property (procedure, scm_sym_name);
if (scm_is_true (name))
scm_set_procedure_property_x (ret, scm_sym_name, name);
return ret;
diff --git a/libguile/procs.h b/libguile/procs.h
index a832cd0..a4dfaff 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -27,36 +27,8 @@
-
-/* Subrs
- */
-
-#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
-#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
-#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
-#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
-#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
-#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
-#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits)
g))
-
-/* Return the most suitable subr type for a subr with REQ required arguments,
- OPT optional arguments, and REST (0 or 1) arguments. This has to be in
- sync with `create_gsubr ()'. */
-#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
- (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
-
-
-
-
-SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
-SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
- SCM (*fcn)(), SCM *gf);
-SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)());
-SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
- SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
-SCM_API int scm_subr_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
diff --git a/libguile/programs.c b/libguile/programs.c
index 336e621..79b1c32 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,7 +22,6 @@
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
#include "programs.h"
@@ -43,13 +42,30 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
objtable = SCM_BOOL_F;
else if (scm_is_true (objtable))
SCM_VALIDATE_VECTOR (2, objtable);
- if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
- free_variables = SCM_BOOL_F;
- else if (free_variables != SCM_BOOL_F)
- SCM_VALIDATE_VECTOR (3, free_variables);
- return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode,
- (scm_t_bits)objtable, (scm_t_bits)free_variables);
+ if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
+ {
+ SCM ret = scm_words (scm_tc7_program, 3);
+ SCM_SET_CELL_OBJECT_1 (ret, objcode);
+ SCM_SET_CELL_OBJECT_2 (ret, objtable);
+ return ret;
+ }
+ else
+ {
+ size_t i, len;
+ SCM ret;
+ SCM_VALIDATE_VECTOR (3, free_variables);
+ len = scm_c_vector_length (free_variables);
+ if (SCM_UNLIKELY (len >> 16))
+ SCM_OUT_OF_RANGE (3, free_variables);
+ ret = scm_words (scm_tc7_program | (len<<16), 3 + len);
+ SCM_SET_CELL_OBJECT_1 (ret, objcode);
+ SCM_SET_CELL_OBJECT_2 (ret, objtable);
+ for (i = 0; i < len; i++)
+ SCM_SET_CELL_OBJECT (ret, 3+i,
+ SCM_SIMPLE_VECTOR_REF (free_variables, i));
+ return ret;
+ }
}
#undef FUNC_NAME
@@ -63,10 +79,24 @@ scm_i_program_print (SCM program, SCM port, scm_print_state
*pstate)
(scm_c_resolve_module ("system vm program"),
scm_from_locale_symbol ("write-program"));
- if (scm_is_false (write_program) || print_error)
+ if (SCM_PROGRAM_IS_CONTINUATION (program))
+ {
+ /* twingliness */
+ scm_puts ("#<continuation ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
+ {
+ /* twingliness */
+ scm_puts ("#<partial-continuation ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else if (scm_is_false (write_program) || print_error)
{
scm_puts ("#<program ", port);
- scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port);
}
else
@@ -138,7 +168,8 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
if (scm_is_true (metaobj))
- return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F);
+ return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
+ SCM_BOOL_F);
else
return SCM_BOOL_F;
}
@@ -264,13 +295,42 @@ scm_c_program_source (SCM program, size_t ip)
return source; /* (addr . (filename . (line . column))) */
}
-SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
+SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1,
0, 0,
(SCM program),
"")
-#define FUNC_NAME s_scm_program_free_variables
+#define FUNC_NAME s_scm_program_num_free_variables
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0,
0,
+ (SCM program, SCM i),
+ "")
+#define FUNC_NAME s_scm_program_free_variable_ref
+{
+ unsigned long idx;
+ SCM_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3,
0, 0,
+ (SCM program, SCM i, SCM x),
+ "")
+#define FUNC_NAME s_scm_program_free_variable_set_x
{
+ unsigned long idx;
SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_FREE_VARIABLES (program);
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -330,15 +390,14 @@ scm_bootstrap_programs (void)
/* arglist can't be snarfed, because snarfage is only loaded when (system vm
program) is loaded. perhaps static-alloc will fix this. */
sym_arglist = scm_from_locale_symbol ("arglist");
- scm_c_register_extension ("libguile", "scm_init_programs",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_programs",
(scm_t_extension_init_func)scm_init_programs,
NULL);
}
void
scm_init_programs (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/programs.x"
#endif
diff --git a/libguile/programs.h b/libguile/programs.h
index 836f1ff..c8e3bf6 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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,14 +27,25 @@
*/
#define SCM_F_PROGRAM_IS_BOOT 0x100
+#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
+#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
+#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
+#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
-#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_3 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 3))
+#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
+#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES
(x)[i]=(v))
+#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
+#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE)
+#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
+#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_CONTINUATION)
+#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
@@ -49,7 +60,9 @@ SCM_API SCM scm_program_properties (SCM program);
SCM_API SCM scm_program_name (SCM program);
SCM_API SCM scm_program_objects (SCM program);
SCM_API SCM scm_program_module (SCM program);
-SCM_API SCM scm_program_free_variables (SCM program);
+SCM_API SCM scm_program_num_free_variables (SCM program);
+SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i);
+SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x);
SCM_API SCM scm_program_objcode (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
diff --git a/libguile/promises.c b/libguile/promises.c
index fc34cc8..45a76a9 100644
--- a/libguile/promises.c
+++ b/libguile/promises.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -41,7 +41,6 @@
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
-#include "libguile/lang.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/memoize.h"
diff --git a/libguile/read.c b/libguile/read.c
index 6388084..c54fbb6 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008,
2009 Free Software
+/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008,
2009, 2010 Free Software
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -60,6 +60,7 @@
SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
SCM_SYMBOL (scm_keyword_prefix, "prefix");
SCM_SYMBOL (scm_keyword_postfix, "postfix");
+SCM_SYMBOL (sym_nil, "nil");
scm_t_option scm_read_opts[] = {
{ SCM_OPTION_BOOLEAN, "copy", 0,
@@ -70,12 +71,14 @@ scm_t_option scm_read_opts[] = {
"Convert symbols to lower case."},
{ SCM_OPTION_SCM, "keywords", (unsigned long) SCM_BOOL_F,
"Style of keyword recognition: #f, 'prefix or 'postfix."},
-#if SCM_ENABLE_ELISP
{ SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
"Support Elisp vector syntax, namely `[...]'."},
{ SCM_OPTION_BOOLEAN, "elisp-strings", 0,
"Support `\\(' and `\\)' in strings."},
-#endif
+ { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
+ "Use R6RS variable-length character and string hex escapes."},
+ { SCM_OPTION_BOOLEAN, "square-brackets", 1,
+ "Treat `[' and `]' as parentheses, for R6RS compatibility."},
{ 0, },
};
@@ -171,7 +174,8 @@ static SCM *scm_read_hash_procedures;
structure''). */
#define CHAR_IS_R5RS_DELIMITER(c) \
(CHAR_IS_BLANK (c) \
- || (c == ')') || (c == '(') || (c == ';') || (c == '"'))
+ || (c == ')') || (c == '(') || (c == ';') || (c == '"') \
+ || (SCM_SQUARE_BRACKETS_P && ((c == '[') || (c == ']'))))
#define CHAR_IS_DELIMITER CHAR_IS_R5RS_DELIMITER
@@ -187,64 +191,82 @@ static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
static SCM scm_read_commented_expression (scm_t_wchar, SCM);
static SCM scm_get_hash_procedure (int);
-/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
- zero if the whole token fits in BUF, non-zero otherwise. */
+/* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the
+ result in the pre-allocated buffer BUF. Return zero if the whole token has
+ fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number
of
+ bytes actually read. */
static inline int
-read_token (SCM port, SCM buf, size_t *read)
-{
- scm_t_wchar chr;
- *read = 0;
+read_token (SCM port, char *buf, const size_t buf_size, size_t *read)
+ {
+ *read = 0;
- buf = scm_i_string_start_writing (buf);
- while (*read < scm_i_string_length (buf))
- {
- chr = scm_getc (port);
+ while (*read < buf_size)
+ {
+ int chr;
- if (chr == EOF)
- {
- scm_i_string_stop_writing ();
- return 0;
- }
-
- chr = (SCM_CASE_INSENSITIVE_P ? uc_tolower (chr) : chr);
-
- if (CHAR_IS_DELIMITER (chr))
- {
- scm_i_string_stop_writing ();
- scm_ungetc (chr, port);
- return 0;
- }
+ chr = scm_get_byte_or_eof (port);
- scm_i_string_set_x (buf, *read, chr);
- (*read)++;
- }
- scm_i_string_stop_writing ();
+ if (chr == EOF)
+ return 0;
+ else if (CHAR_IS_DELIMITER (chr))
+ {
+ scm_unget_byte (chr, port);
+ return 0;
+ }
+ else
+ {
+ *buf = (char) chr;
+ buf++, (*read)++;
+ }
+ }
- return 1;
-}
+ return 1;
+ }
-static SCM
-read_complete_token (SCM port, size_t *read)
+/* 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)
{
- SCM buffer, str = SCM_EOL;
- size_t len;
- int overflow;
+ int overflow = 0;
+ size_t bytes_read, overflow_size;
- buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL);
- overflow = read_token (port, buffer, read);
- if (!overflow)
- return scm_i_substring (buffer, 0, *read);
+ *overflow_buffer = NULL;
+ overflow_size = 0;
- str = scm_string_copy (buffer);
do
{
- overflow = read_token (port, buffer, &len);
- str = scm_string_append (scm_list_2 (str, buffer));
- *read += len;
+ overflow = read_token (port, buffer, buffer_size, &bytes_read);
+ if (bytes_read == 0)
+ break;
+ if (overflow || overflow_size != 0)
+ {
+ if (overflow_size == 0)
+ {
+ *overflow_buffer = scm_malloc (bytes_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);
+ overflow_size += bytes_read;
+ }
+ }
}
while (overflow);
- return scm_i_substring (str, 0, *read);
+ if (overflow_size)
+ *read = overflow_size;
+ else
+ *read = bytes_read;
+
+ return (overflow_size != 0);
}
/* Skip whitespace from PORT and return the first non-whitespace character
@@ -334,7 +356,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
register SCM tmp;
register SCM tl, ans = SCM_EOL;
SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
- static const int terminating_char = ')';
+ const int terminating_char = ((chr == '[') ? ']' : ')');
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
@@ -414,6 +436,41 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
}
#undef FUNC_NAME
+
+/* Read a hexadecimal number NDIGITS in length. Put its value into the
variable
+ C. If TERMINATOR is non-null, terminate early if the TERMINATOR character
is
+ found. */
+#define SCM_READ_HEX_ESCAPE(ndigits, terminator) \
+ do \
+ { \
+ scm_t_wchar a; \
+ size_t i = 0; \
+ c = 0; \
+ while (i < ndigits) \
+ { \
+ a = scm_getc (port); \
+ if (a == EOF) \
+ goto str_eof; \
+ if (terminator \
+ && (a == (scm_t_wchar) terminator) \
+ && (i > 0)) \
+ break; \
+ if ('0' <= a && a <= '9') \
+ a -= '0'; \
+ else if ('A' <= a && a <= 'F') \
+ a = a - 'A' + 10; \
+ else if ('a' <= a && a <= 'f') \
+ a = a - 'a' + 10; \
+ else \
+ { \
+ c = a; \
+ goto bad_escaped; \
+ } \
+ c = c * 16 + a; \
+ i ++; \
+ } \
+ } while (0)
+
static SCM
scm_read_string (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
@@ -451,13 +508,11 @@ scm_read_string (int chr, SCM port)
case '"':
case '\\':
break;
-#if SCM_ENABLE_ELISP
case '(':
case ')':
if (SCM_ESCAPED_PARENS_P)
break;
goto bad_escaped;
-#endif
case '\n':
continue;
case '0':
@@ -481,90 +536,27 @@ scm_read_string (int chr, SCM port)
case 'v':
c = '\v';
break;
+ case 'b':
+ c = '\010';
+ break;
case 'x':
- {
- scm_t_wchar a, b;
- a = scm_getc (port);
- if (a == EOF)
- goto str_eof;
- b = scm_getc (port);
- if (b == EOF)
- goto str_eof;
- if ('0' <= a && a <= '9')
- a -= '0';
- else if ('A' <= a && a <= 'F')
- a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f')
- a = a - 'a' + 10;
- else
- {
- c = a;
- goto bad_escaped;
- }
- if ('0' <= b && b <= '9')
- b -= '0';
- else if ('A' <= b && b <= 'F')
- b = b - 'A' + 10;
- else if ('a' <= b && b <= 'f')
- b = b - 'a' + 10;
- else
- {
- c = b;
- goto bad_escaped;
- }
- c = a * 16 + b;
- break;
- }
+ if (SCM_R6RS_ESCAPES_P)
+ SCM_READ_HEX_ESCAPE (10, ';');
+ else
+ SCM_READ_HEX_ESCAPE (2, '\0');
+ break;
case 'u':
- {
- scm_t_wchar a;
- int i;
- c = 0;
- for (i = 0; i < 4; i++)
- {
- a = scm_getc (port);
- if (a == EOF)
- goto str_eof;
- if ('0' <= a && a <= '9')
- a -= '0';
- else if ('A' <= a && a <= 'F')
- a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f')
- a = a - 'a' + 10;
- else
- {
- c = a;
- goto bad_escaped;
- }
- c = c * 16 + a;
- }
- break;
- }
+ if (!SCM_R6RS_ESCAPES_P)
+ {
+ SCM_READ_HEX_ESCAPE (4, '\0');
+ break;
+ }
case 'U':
- {
- scm_t_wchar a;
- int i;
- c = 0;
- for (i = 0; i < 6; i++)
- {
- a = scm_getc (port);
- if (a == EOF)
- goto str_eof;
- if ('0' <= a && a <= '9')
- a -= '0';
- else if ('A' <= a && a <= 'F')
- a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f')
- a = a - 'a' + 10;
- else
- {
- c = a;
- goto bad_escaped;
- }
- c = c * 16 + a;
- }
- break;
- }
+ if (!SCM_R6RS_ESCAPES_P)
+ {
+ SCM_READ_HEX_ESCAPE (6, '\0');
+ break;
+ }
default:
bad_escaped:
scm_i_input_error (FUNC_NAME, port,
@@ -581,7 +573,7 @@ scm_read_string (int chr, SCM port)
{
return scm_i_substring_copy (str, 0, c_str_len);
}
-
+
return scm_nullstr;
}
#undef FUNC_NAME
@@ -590,17 +582,35 @@ scm_read_string (int chr, SCM port)
static SCM
scm_read_number (scm_t_wchar chr, SCM port)
{
- SCM result;
- SCM buffer;
- size_t read;
+ SCM result, str = SCM_EOL;
+ char buffer[READER_BUFFER_SIZE];
+ char *overflow_buffer = NULL;
+ size_t bytes_read;
+ int overflow;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
scm_ungetc (chr, port);
- buffer = read_complete_token (port, &read);
- result = scm_string_to_number (buffer, SCM_UNDEFINED);
+ overflow = read_complete_token (port, buffer, sizeof (buffer),
+ &overflow_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);
+
+ result = scm_string_to_number (str, SCM_UNDEFINED);
if (!scm_is_true (result))
- /* Return a symbol instead of a number. */
- result = scm_string_to_symbol (buffer);
+ {
+ /* Return a symbol instead of a number */
+ 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;
}
@@ -609,20 +619,52 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
{
SCM result;
int ends_with_colon = 0;
- SCM buffer;
- size_t read = 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;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ SCM str;
scm_ungetc (chr, port);
- buffer = read_complete_token (port, &read);
- if (read > 0)
- ends_with_colon = scm_i_string_ref (buffer, read - 1) == ':';
+ overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
+ &overflow_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] == ':';
+ }
+
+ 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);
- if (postfix && ends_with_colon && (read > 1))
- result = scm_symbol_to_keyword (scm_string_to_symbol (scm_i_substring
(buffer, 0, read - 1)));
+ if (SCM_CASE_INSENSITIVE_P)
+ str = scm_string_downcase_x (str);
+ result = scm_symbol_to_keyword (scm_string_to_symbol (str));
+ }
else
- result = scm_string_to_symbol (buffer);
+ {
+ 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);
+ 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;
}
@@ -632,8 +674,11 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
{
SCM result;
size_t read;
- SCM buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL);
+ char buffer[READER_BUFFER_SIZE], *overflow_buffer;
+ int overflow;
unsigned int radix;
+ SCM str;
+ scm_t_port *pt;
switch (chr)
{
@@ -663,8 +708,22 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
radix = 10;
}
- buffer = read_complete_token (port, &read);
- result = scm_string_to_number (buffer, scm_from_uint (radix));
+ overflow = read_complete_token (port, buffer, sizeof (buffer),
+ &overflow_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);
+
+ 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))
return result;
@@ -789,6 +848,19 @@ scm_read_syntax (int chr, SCM port)
}
static inline SCM
+scm_read_nil (int chr, SCM port)
+{
+ SCM id = scm_read_mixed_case_symbol (chr, port);
+
+ if (!scm_is_eq (id, sym_nil))
+ scm_i_input_error ("scm_read_nil", port,
+ "unexpected input while reading #nil: ~a",
+ scm_list_1 (id));
+
+ return SCM_ELISP_NIL;
+}
+
+static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
int c;
@@ -798,7 +870,7 @@ scm_read_semicolon_comment (int chr, SCM port)
always represents itself no matter what the encoding is. */
for (c = scm_get_byte_or_eof (port);
(c != EOF) && (c != '\n');
- c = scm_getc (port));
+ c = scm_get_byte_or_eof (port));
return SCM_UNSPECIFIED;
}
@@ -827,18 +899,18 @@ static SCM
scm_read_character (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
- SCM charname = scm_i_make_string (READER_CHAR_NAME_MAX_SIZE, NULL);
- size_t charname_len;
+ char buffer[READER_CHAR_NAME_MAX_SIZE];
+ SCM charname;
+ size_t charname_len, bytes_read;
scm_t_wchar cp;
int overflow;
+ scm_t_port *pt;
- overflow = read_token (port, charname, &charname_len);
- charname = scm_c_substring (charname, 0, charname_len);
-
+ overflow = read_token (port, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read);
if (overflow)
goto char_error;
- if (charname_len == 0)
+ if (bytes_read == 0)
{
chr = scm_getc (port);
if (chr == EOF)
@@ -849,10 +921,29 @@ scm_read_character (scm_t_wchar chr, SCM port)
return (SCM_MAKE_CHAR (chr));
}
- if (charname_len == 1)
- return SCM_MAKE_CHAR (scm_i_string_ref (charname, 0));
+ pt = SCM_PTAB_ENTRY (port);
+
+ /* Simple ASCII characters can be processed immediately. Also, simple
+ ISO-8859-1 characters can be processed immediately if the encoding for
this
+ port is ISO-8859-1. */
+ if (bytes_read == 1 && ((unsigned char) buffer[0] <= 127 || pt->encoding ==
NULL))
+ {
+ SCM_COL (port) += 1;
+ return SCM_MAKE_CHAR (buffer[0]);
+ }
+ /* Otherwise, convert the buffer into a proper scheme string for
+ processing. */
+ charname = scm_from_stringn (buffer, bytes_read, pt->encoding,
+ pt->ilseq_handler);
+ charname_len = scm_i_string_length (charname);
+ SCM_COL (port) += charname_len;
cp = scm_i_string_ref (charname, 0);
+ if (charname_len == 1)
+ return SCM_MAKE_CHAR (cp);
+
+ /* Ignore dotted circles, which may be used to keep combining characters from
+ combining with the backslash in #\charname. */
if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2)
return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1));
@@ -874,6 +965,25 @@ scm_read_character (scm_t_wchar chr, SCM port)
}
}
+ if (cp == 'x' && (charname_len > 1) && SCM_R6RS_ESCAPES_P)
+ {
+ SCM p;
+
+ /* Convert from hex, skipping the initial 'x' character in CHARNAME */
+ p = scm_string_to_number (scm_c_substring (charname, 1, charname_len),
+ scm_from_uint (16));
+ if (SCM_I_INUMP (p))
+ {
+ scm_t_wchar c = SCM_I_INUM (p);
+ if (SCM_IS_UNICODE_CHAR (c))
+ return SCM_MAKE_CHAR (c);
+ else
+ scm_i_input_error (FUNC_NAME, port,
+ "out-of-range hex character escape: ~a",
+ scm_list_1 (charname));
+ }
+ }
+
/* The names of characters should never have non-Latin1
characters. */
if (scm_i_is_narrow_string (charname)
@@ -1220,6 +1330,8 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
case '\'':
case ',':
return (scm_read_syntax (chr, port));
+ case 'n':
+ return (scm_read_nil (chr, port));
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
@@ -1262,6 +1374,10 @@ scm_read_expression (SCM port)
case ';':
(void) scm_read_semicolon_comment (chr, port);
break;
+ case '[':
+ if (!SCM_SQUARE_BRACKETS_P)
+ return (scm_read_mixed_case_symbol (chr, port));
+ /* otherwise fall through */
case '(':
return (scm_read_sexp (chr, port));
case '"':
diff --git a/libguile/script.c b/libguile/script.c
index 89ff7a0..7b606ae 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
2005, 2006, 2007, 2008, 2009, 2010 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
@@ -457,8 +457,6 @@ scm_compile_shell_switches (int argc, char **argv)
int use_emacs_interface = 0;
int turn_on_debugging = 0;
int dont_turn_on_debugging = 0;
- int turn_on_autocompile = 0;
- int dont_turn_on_autocompile = 0;
int i;
char *argv0 = guile;
@@ -595,17 +593,15 @@ scm_compile_shell_switches (int argc, char **argv)
turn_on_debugging = 0;
}
+ /* Do autocompile on/off now, because the form itself might need this
+ decision. */
else if (! strcmp (argv[i], "--autocompile"))
- {
- turn_on_autocompile = 1;
- dont_turn_on_autocompile = 0;
- }
+ scm_variable_set_x (scm_c_lookup ("%load-should-autocompile"),
+ SCM_BOOL_T);
else if (! strcmp (argv[i], "--no-autocompile"))
- {
- dont_turn_on_autocompile = 1;
- turn_on_autocompile = 0;
- }
+ scm_variable_set_x (scm_c_lookup ("%load-should-autocompile"),
+ SCM_BOOL_F);
else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
use_emacs_interface = 1;
@@ -720,16 +716,6 @@ scm_compile_shell_switches (int argc, char **argv)
tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
}
- /* If GUILE_AUTO_COMPILE is not set and no args are given, default to
- autocompilation. */
- if (turn_on_autocompile || (scm_getenv_int ("GUILE_AUTO_COMPILE", 1)
- && !dont_turn_on_autocompile))
- {
- tail = scm_cons (scm_list_3 (sym_set_x, sym_sys_load_should_autocompile,
- SCM_BOOL_T),
- tail);
- }
-
/* If debugging was requested, or we are interactive and debugging
was not explicitly turned off, turn on debugging. */
if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
@@ -740,6 +726,13 @@ scm_compile_shell_switches (int argc, char **argv)
{
SCM val = scm_cons (sym_begin, tail);
+ /* Wrap the expression in a prompt. */
+ val = scm_list_2 (scm_list_3 (scm_sym_at,
+ scm_list_2 (scm_from_locale_symbol
("ice-9"),
+ scm_from_locale_symbol
("control")),
+ scm_from_locale_symbol ("%")),
+ val);
+
#if 0
scm_write (val, SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
diff --git a/libguile/smob.c b/libguile/smob.c
index d96a043..171db8d 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 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -29,7 +29,9 @@
#include "libguile/async.h"
#include "libguile/goops.h"
-#include "libguile/ports.h"
+#include "libguile/instructions.h"
+#include "libguile/objcodes.h"
+#include "libguile/programs.h"
#ifdef HAVE_MALLOC_H
#include <malloc.h>
@@ -117,159 +119,237 @@ scm_smob_print (SCM exp, SCM port, scm_print_state
*pstate SCM_UNUSED)
return 1;
}
+
/* {Apply}
*/
-#define SCM_SMOB_APPLY0(SMOB) \
- SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
-#define SCM_SMOB_APPLY1(SMOB, A1) \
- SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
-#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
- SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
-#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
- SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
-
-static SCM
-scm_smob_apply_0_010 (SCM smob)
-{
- return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_0_020 (SCM smob)
-{
- return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_0_030 (SCM smob)
-{
- return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_0_001 (SCM smob)
-{
- return SCM_SMOB_APPLY1 (smob, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_0_011 (SCM smob)
-{
- return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_0_021 (SCM smob)
-{
- return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_0_error (SCM smob)
-{
- scm_wrong_num_args (smob);
-}
-
-static SCM
-scm_smob_apply_1_020 (SCM smob, SCM a1)
-{
- return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_1_030 (SCM smob, SCM a1)
-{
- return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_1_001 (SCM smob, SCM a1)
-{
- return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
-}
-
-static SCM
-scm_smob_apply_1_011 (SCM smob, SCM a1)
-{
- return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_1_021 (SCM smob, SCM a1)
-{
- return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
-{
- scm_wrong_num_args (smob);
-}
-
-static SCM
-scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
-{
- return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
-}
-
-static SCM
-scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
-{
- return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
-}
-
-static SCM
-scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
-{
- return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
-}
-
-static SCM
-scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
-{
- return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
-}
-
-static SCM
-scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
-{
- scm_wrong_num_args (smob);
-}
-
-static SCM
-scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
- if (!scm_is_null (SCM_CDR (rst)))
- scm_wrong_num_args (smob);
- return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
-}
-
-static SCM
-scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
- return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
-}
-
-static SCM
-scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
- return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
-}
+#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
-static SCM
-scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
-{
- return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
-}
+/* 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)
+
+#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
+{
+ 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_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+static const struct
+{
+ 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)
+};
+
+/* (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
-scm_smob_apply_3_error (SCM smob,
- SCM a1 SCM_UNUSED,
- SCM a2 SCM_UNUSED,
- SCM rst SCM_UNUSED)
+scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
+ unsigned int rest)
{
- scm_wrong_num_args (smob);
+ 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);
}
@@ -329,113 +409,40 @@ void
scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
unsigned int req, unsigned int opt, unsigned int rst)
{
- SCM (*apply_0) (SCM);
- SCM (*apply_1) (SCM, SCM);
- SCM (*apply_2) (SCM, SCM, SCM);
- SCM (*apply_3) (SCM, SCM, SCM, SCM);
- int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
-
- if (rst > 1 || req + opt + rst > 3)
- {
- puts ("Unsupported smob application type");
- abort ();
- }
-
- switch (type)
- {
- case SCM_GSUBR_MAKTYPE (0, 0, 0):
- apply_0 = apply; break;
- case SCM_GSUBR_MAKTYPE (0, 1, 0):
- apply_0 = scm_smob_apply_0_010; break;
- case SCM_GSUBR_MAKTYPE (0, 2, 0):
- apply_0 = scm_smob_apply_0_020; break;
- case SCM_GSUBR_MAKTYPE (0, 3, 0):
- apply_0 = scm_smob_apply_0_030; break;
- case SCM_GSUBR_MAKTYPE (0, 0, 1):
- apply_0 = scm_smob_apply_0_001; break;
- case SCM_GSUBR_MAKTYPE (0, 1, 1):
- apply_0 = scm_smob_apply_0_011; break;
- case SCM_GSUBR_MAKTYPE (0, 2, 1):
- apply_0 = scm_smob_apply_0_021; break;
- default:
- apply_0 = scm_smob_apply_0_error; break;
- }
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
+ = scm_smob_objcode_trampoline (req, opt, rst);
- switch (type)
- {
- case SCM_GSUBR_MAKTYPE (1, 0, 0):
- case SCM_GSUBR_MAKTYPE (0, 1, 0):
- apply_1 = apply; break;
- case SCM_GSUBR_MAKTYPE (1, 1, 0):
- case SCM_GSUBR_MAKTYPE (0, 2, 0):
- apply_1 = scm_smob_apply_1_020; break;
- case SCM_GSUBR_MAKTYPE (1, 2, 0):
- case SCM_GSUBR_MAKTYPE (0, 3, 0):
- apply_1 = scm_smob_apply_1_030; break;
- case SCM_GSUBR_MAKTYPE (0, 0, 1):
- apply_1 = scm_smob_apply_1_001; break;
- case SCM_GSUBR_MAKTYPE (1, 0, 1):
- case SCM_GSUBR_MAKTYPE (0, 1, 1):
- apply_1 = scm_smob_apply_1_011; break;
- case SCM_GSUBR_MAKTYPE (1, 1, 1):
- case SCM_GSUBR_MAKTYPE (0, 2, 1):
- apply_1 = scm_smob_apply_1_021; break;
- default:
- apply_1 = scm_smob_apply_1_error; break;
- }
+ if (SCM_UNPACK (scm_smob_class[0]) != 0)
+ scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
+}
- switch (type)
- {
- case SCM_GSUBR_MAKTYPE (2, 0, 0):
- case SCM_GSUBR_MAKTYPE (1, 1, 0):
- case SCM_GSUBR_MAKTYPE (0, 2, 0):
- apply_2 = apply; break;
- case SCM_GSUBR_MAKTYPE (2, 1, 0):
- case SCM_GSUBR_MAKTYPE (1, 2, 0):
- case SCM_GSUBR_MAKTYPE (0, 3, 0):
- apply_2 = scm_smob_apply_2_030; break;
- case SCM_GSUBR_MAKTYPE (0, 0, 1):
- apply_2 = scm_smob_apply_2_001; break;
- case SCM_GSUBR_MAKTYPE (1, 0, 1):
- case SCM_GSUBR_MAKTYPE (0, 1, 1):
- apply_2 = scm_smob_apply_2_011; break;
- case SCM_GSUBR_MAKTYPE (2, 0, 1):
- case SCM_GSUBR_MAKTYPE (1, 1, 1):
- case SCM_GSUBR_MAKTYPE (0, 2, 1):
- apply_2 = scm_smob_apply_2_021; break;
- default:
- apply_2 = scm_smob_apply_2_error; break;
- }
+static SCM tramp_weak_map = SCM_BOOL_F;
+SCM
+scm_i_smob_apply_trampoline (SCM smob)
+{
+ /* could use hashq-create-handle!, but i don't know what to do if it returns
a
+ weak pair */
+ SCM tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
- switch (type)
+ if (scm_is_true (tramp))
+ return tramp;
+ else
{
- case SCM_GSUBR_MAKTYPE (3, 0, 0):
- case SCM_GSUBR_MAKTYPE (2, 1, 0):
- case SCM_GSUBR_MAKTYPE (1, 2, 0):
- case SCM_GSUBR_MAKTYPE (0, 3, 0):
- apply_3 = scm_smob_apply_3_030; break;
- case SCM_GSUBR_MAKTYPE (0, 0, 1):
- apply_3 = scm_smob_apply_3_001; break;
- case SCM_GSUBR_MAKTYPE (1, 0, 1):
- case SCM_GSUBR_MAKTYPE (0, 1, 1):
- apply_3 = scm_smob_apply_3_011; break;
- case SCM_GSUBR_MAKTYPE (2, 0, 1):
- case SCM_GSUBR_MAKTYPE (1, 1, 1):
- case SCM_GSUBR_MAKTYPE (0, 2, 1):
- apply_3 = scm_smob_apply_3_021; break;
- default:
- apply_3 = scm_smob_apply_3_error; break;
+ 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);
+ scm_hashq_set_x (tramp_weak_map, smob, tramp);
+ return tramp;
}
-
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
- scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
-
- if (SCM_UNPACK (scm_smob_class[0]) != 0)
- scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}
SCM
@@ -609,12 +616,10 @@ scm_smob_prehistory ()
scm_smobs[i].print = scm_smob_print;
scm_smobs[i].equalp = 0;
scm_smobs[i].apply = 0;
- scm_smobs[i].apply_0 = 0;
- scm_smobs[i].apply_1 = 0;
- scm_smobs[i].apply_2 = 0;
- scm_smobs[i].apply_3 = 0;
- scm_smobs[i].gsubr_type = 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 f9b5110..07deebd 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -3,7 +3,7 @@
#ifndef SCM_SMOB_H
#define SCM_SMOB_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -41,11 +41,7 @@ typedef struct scm_smob_descriptor
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM);
SCM (*apply) ();
- SCM (*apply_0) (SCM);
- SCM (*apply_1) (SCM, SCM);
- SCM (*apply_2) (SCM, SCM, SCM);
- SCM (*apply_3) (SCM, SCM, SCM, SCM);
- int gsubr_type; /* Used in procprop.c */
+ SCM apply_trampoline_objcode;
} scm_smob_descriptor;
@@ -170,10 +166,10 @@ while (0)
#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_SMOB_DESCRIPTOR (x).apply_0 (x))
-#define SCM_SMOB_APPLY_1(x, a1) (SCM_SMOB_DESCRIPTOR
(x).apply_1 (x, (a1)))
-#define SCM_SMOB_APPLY_2(x, a1, a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x,
(a1), (a2)))
-#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (SCM_SMOB_DESCRIPTOR
(x).apply_3 (x, (a1), (a2), (rst)))
+#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
@@ -217,6 +213,8 @@ 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/snarf.h b/libguile/snarf.h
index ef1fcd0..98f6601 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -3,7 +3,7 @@
#ifndef SCM_SNARF_H
#define SCM_SNARF_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006,
2009, 2010 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
@@ -99,22 +99,35 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ,
OPT, VAR, DOCSTRING)
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
/* Static subr allocation. */
+/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
-SCM_SNARF_HERE( \
+SCM_SNARF_HERE(
\
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \
- SCM_IMMUTABLE_SUBR (scm_i_paste (FNAME, __subr), \
- scm_i_paste (FNAME, __name), \
- REQ, OPT, VAR, &FNAME); \
+ SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
+ (scm_t_bits) &FNAME); /* the subr */ \
+ SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
+ /* FIXME: directly be the foreign */ \
+ SCM_BOOL_F); \
+ /* FIXME: be immutable. grr */ \
+ SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \
+ SCM_BOOL_F, \
+ SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \
+ SCM_BOOL_F); \
SCM FNAME ARGLIST \
) \
SCM_SNARF_INIT( \
+ /* Initialize the foreign. */ \
+ scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME,
__subr_foreign); \
/* Initialize the procedure name (an interned symbol). */ \
- scm_i_paste (FNAME, __subr_meta_info)[0] = scm_i_paste (FNAME, __name); \
+ scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
+ /* Initialize the objcode trampoline. */ \
+ SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
+ scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
\
/* Define the subr. */ \
- scm_c_define (scm_i_paste (s_, FNAME), scm_i_paste (FNAME, __subr)); \
+ scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
) \
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
@@ -152,26 +165,6 @@ scm_c_export (s_ ## FNAME, NULL); \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
-#define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
-SCM_SNARF_HERE(\
-static const char s_ ## FNAME [] = PRIMNAME; \
-SCM FNAME ARGLIST\
-)\
-SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \
-SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
-
-#define SCM_PRIMITIVE_GENERIC_1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
-SCM_SNARF_HERE(\
-static const char s_ ## FNAME [] = PRIMNAME; \
-static SCM g_ ## FNAME; \
-SCM FNAME ARGLIST\
-)\
-SCM_SNARF_INIT(\
-g_ ## FNAME = SCM_PACK (0); \
-scm_c_define_subr_with_generic (s_ ## FNAME, TYPE, FNAME, &g_ ## FNAME); \
-)\
-SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
-
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
SCM_SNARF_HERE(static const char RANAME[]=STR) \
SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
@@ -194,27 +187,6 @@ scm_c_define_gsubr_with_generic (RANAME, REQ, OPT, VAR, \
(SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
)
-#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
-SCM_SNARF_HERE(static const char RANAME[]=STR) \
-SCM_SNARF_INIT(\
-scm_c_define_subr (RANAME, TYPE, (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN) \
-)
-
-
-#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
-SCM_SNARF_HERE(\
-static const char RANAME[]=STR; \
-static SCM GF \
-)SCM_SNARF_INIT(\
-GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \
-scm_c_define_subr_with_generic (RANAME, TYPE, \
- (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
-)
-
-#define SCM_SYNTAX(RANAME, STR, TYPE, CFN) \
-SCM_SNARF_HERE(static const char RANAME[]=STR)\
-SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN))
-
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
# define SCM_SYMBOL(c_name, scheme_name) \
@@ -338,6 +310,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+#define SCM_IMMUTABLE_CELL(c_name, car, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
+ c_name ## _raw_scell = \
+ { \
+ SCM_PACK (car), \
+ SCM_PACK (cdr) \
+ }; \
+ static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_scell)
+
#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
c_name ## _raw_cell [2] = \
@@ -347,6 +328,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
}; \
static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+#define SCM_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell \
+ c_name ## _raw_cell [2] = \
+ { \
+ { SCM_PACK (car), SCM_PACK (cbr) }, \
+ { SCM_PACK (ccr), SCM_PACK (cdr) } \
+ }; \
+ static SCM_UNUSED SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+
#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \
static SCM_UNUSED const \
struct \
@@ -371,17 +361,27 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
(scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1)
-#define SCM_IMMUTABLE_SUBR(c_name, name, req, opt, rest, fcn) \
- static SCM_UNUSED SCM scm_i_paste (c_name, _meta_info)[2] = \
- { \
- SCM_BOOL_F, /* The name, initialized at run-time. */ \
- SCM_EOL /* The procedure properties. */ \
- }; \
- SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
- SCM_SUBR_ARITY_TO_TYPE (req, opt, rest), \
- (scm_t_bits) fcn, \
- (scm_t_bits) 0 /* no generic */, \
- (scm_t_bits) & scm_i_paste (c_name, _meta_info));
+#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
+ SCM_IMMUTABLE_CELL (c_name, \
+ scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
+ ptr)
+
+/* for primitive-generics, add a foreign to the end */
+#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
+ static SCM_ALIGNED (8) SCM c_name[4] = \
+ { \
+ SCM_PACK (scm_tc7_vector | (2 << 8)), \
+ SCM_PACK (0), \
+ foreign, \
+ SCM_BOOL_F, /* the name */ \
+ }; \
+
+#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
+ SCM_STATIC_DOUBLE_CELL (c_name, \
+ scm_tc7_program | (SCM_F_PROGRAM_IS_PRIMITIVE<<8), \
+ (scm_t_bits) objcode, \
+ (scm_t_bits) objtable, \
+ (scm_t_bits) freevars)
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
diff --git a/libguile/sort.c b/libguile/sort.c
index 763978f..5fdbb17 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008, 2009, 2010 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
@@ -43,7 +43,6 @@
#include "libguile/array-map.h"
#include "libguile/feature.h"
#include "libguile/vectors.h"
-#include "libguile/lang.h"
#include "libguile/async.h"
#include "libguile/dynwind.h"
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index cf2abfc..c4e8571 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -2198,7 +2198,7 @@ string_titlecase_x (SCM str, size_t start, size_t end)
{
if (!in_word)
{
- scm_i_string_set_x (str, i, uc_toupper (SCM_CHAR (ch)));
+ scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch)));
in_word = 1;
}
else
diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c
index fd537da..ace61df 100644
--- a/libguile/srfi-14.i.c
+++ b/libguile/srfi-14.i.c
@@ -559,6 +559,8 @@ scm_t_char_range cs_lower_case_ranges[] = {
,
{0x0523, 0x0523}
,
+ {0x0525, 0x0525}
+ ,
{0x0561, 0x0587}
,
{0x1930, 0x1938}
@@ -1055,7 +1057,7 @@ scm_t_char_range cs_lower_case_ranges[] = {
};
scm_t_char_set cs_lower_case = {
- 523,
+ 524,
cs_lower_case_ranges
};
@@ -1586,6 +1588,8 @@ scm_t_char_range cs_upper_case_ranges[] = {
,
{0x0522, 0x0522}
,
+ {0x0524, 0x0524}
+ ,
{0x0531, 0x0556}
,
{0x10a0, 0x10c5}
@@ -2042,11 +2046,35 @@ scm_t_char_range cs_upper_case_ranges[] = {
,
{0x10400, 0x10427}
,
+ {0x1f110, 0x1f12c}
+ ,
+ {0x1f131, 0x1f131}
+ ,
+ {0x1f13d, 0x1f13d}
+ ,
+ {0x1f13f, 0x1f13f}
+ ,
+ {0x1f142, 0x1f142}
+ ,
+ {0x1f146, 0x1f146}
+ ,
+ {0x1f157, 0x1f157}
+ ,
+ {0x1f15f, 0x1f15f}
+ ,
+ {0x1f179, 0x1f179}
+ ,
+ {0x1f17b, 0x1f17c}
+ ,
+ {0x1f17f, 0x1f17f}
+ ,
+ {0x1f18a, 0x1f18a}
+ ,
{0xe0041, 0xe005a}
};
scm_t_char_set cs_upper_case = {
- 492,
+ 505,
cs_upper_case_ranges
};
@@ -2120,7 +2148,7 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x03f7, 0x0481}
,
- {0x048a, 0x0523}
+ {0x048a, 0x0525}
,
{0x0531, 0x0556}
,
@@ -2162,6 +2190,14 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x07fa, 0x07fa}
,
+ {0x0800, 0x0815}
+ ,
+ {0x081a, 0x081a}
+ ,
+ {0x0824, 0x0824}
+ ,
+ {0x0828, 0x0828}
+ ,
{0x0904, 0x0939}
,
{0x093d, 0x093d}
@@ -2172,7 +2208,7 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x0971, 0x0972}
,
- {0x097b, 0x097f}
+ {0x0979, 0x097f}
,
{0x0985, 0x098c}
,
@@ -2404,13 +2440,7 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x10fc, 0x10fc}
,
- {0x1100, 0x1159}
- ,
- {0x115f, 0x11a2}
- ,
- {0x11a8, 0x11f9}
- ,
- {0x1200, 0x1248}
+ {0x1100, 0x1248}
,
{0x124a, 0x124d}
,
@@ -2448,7 +2478,7 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x1401, 0x166c}
,
- {0x166f, 0x1676}
+ {0x166f, 0x167f}
,
{0x1681, 0x169a}
,
@@ -2478,18 +2508,24 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x18aa, 0x18aa}
,
+ {0x18b0, 0x18f5}
+ ,
{0x1900, 0x191c}
,
{0x1950, 0x196d}
,
{0x1970, 0x1974}
,
- {0x1980, 0x19a9}
+ {0x1980, 0x19ab}
,
{0x19c1, 0x19c7}
,
{0x1a00, 0x1a16}
,
+ {0x1a20, 0x1a54}
+ ,
+ {0x1aa7, 0x1aa7}
+ ,
{0x1b05, 0x1b33}
,
{0x1b45, 0x1b4b}
@@ -2504,6 +2540,10 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x1c5a, 0x1c7d}
,
+ {0x1ce9, 0x1cec}
+ ,
+ {0x1cee, 0x1cf1}
+ ,
{0x1d00, 0x1dbf}
,
{0x1e00, 0x1f15}
@@ -2582,11 +2622,9 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x2c30, 0x2c5e}
,
- {0x2c60, 0x2c6f}
- ,
- {0x2c71, 0x2c7d}
+ {0x2c60, 0x2ce4}
,
- {0x2c80, 0x2ce4}
+ {0x2ceb, 0x2cee}
,
{0x2d00, 0x2d25}
,
@@ -2638,10 +2676,12 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x3400, 0x4db5}
,
- {0x4e00, 0x9fc3}
+ {0x4e00, 0x9fcb}
,
{0xa000, 0xa48c}
,
+ {0xa4d0, 0xa4fd}
+ ,
{0xa500, 0xa60c}
,
{0xa610, 0xa61f}
@@ -2654,6 +2694,8 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0xa67f, 0xa697}
,
+ {0xa6a0, 0xa6e5}
+ ,
{0xa717, 0xa71f}
,
{0xa722, 0xa788}
@@ -2672,21 +2714,55 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0xa882, 0xa8b3}
,
+ {0xa8f2, 0xa8f7}
+ ,
+ {0xa8fb, 0xa8fb}
+ ,
{0xa90a, 0xa925}
,
{0xa930, 0xa946}
,
+ {0xa960, 0xa97c}
+ ,
+ {0xa984, 0xa9b2}
+ ,
+ {0xa9cf, 0xa9cf}
+ ,
{0xaa00, 0xaa28}
,
{0xaa40, 0xaa42}
,
{0xaa44, 0xaa4b}
,
+ {0xaa60, 0xaa76}
+ ,
+ {0xaa7a, 0xaa7a}
+ ,
+ {0xaa80, 0xaaaf}
+ ,
+ {0xaab1, 0xaab1}
+ ,
+ {0xaab5, 0xaab6}
+ ,
+ {0xaab9, 0xaabd}
+ ,
+ {0xaac0, 0xaac0}
+ ,
+ {0xaac2, 0xaac2}
+ ,
+ {0xaadb, 0xaadd}
+ ,
+ {0xabc0, 0xabe2}
+ ,
{0xac00, 0xd7a3}
,
+ {0xd7b0, 0xd7c6}
+ ,
+ {0xd7cb, 0xd7fb}
+ ,
{0xf900, 0xfa2d}
,
- {0xfa30, 0xfa6a}
+ {0xfa30, 0xfa6d}
,
{0xfa70, 0xfad9}
,
@@ -2778,7 +2854,7 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x1083c, 0x1083c}
,
- {0x1083f, 0x1083f}
+ {0x1083f, 0x10855}
,
{0x10900, 0x10915}
,
@@ -2792,8 +2868,22 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x10a19, 0x10a33}
,
+ {0x10a60, 0x10a7c}
+ ,
+ {0x10b00, 0x10b35}
+ ,
+ {0x10b40, 0x10b55}
+ ,
+ {0x10b60, 0x10b72}
+ ,
+ {0x10c00, 0x10c48}
+ ,
+ {0x11083, 0x110af}
+ ,
{0x12000, 0x1236e}
,
+ {0x13000, 0x1342e}
+ ,
{0x1d400, 0x1d454}
,
{0x1d456, 0x1d49c}
@@ -2856,11 +2946,13 @@ scm_t_char_range cs_letter_ranges[] = {
,
{0x20000, 0x2a6d6}
,
+ {0x2a700, 0x2b734}
+ ,
{0x2f800, 0x2fa1d}
};
scm_t_char_set cs_letter = {
- 390,
+ 422,
cs_letter_ranges
};
@@ -2907,7 +2999,11 @@ scm_t_char_range cs_digit_ranges[] = {
,
{0x1946, 0x194f}
,
- {0x19d0, 0x19d9}
+ {0x19d0, 0x19da}
+ ,
+ {0x1a80, 0x1a89}
+ ,
+ {0x1a90, 0x1a99}
,
{0x1b50, 0x1b59}
,
@@ -2923,8 +3019,12 @@ scm_t_char_range cs_digit_ranges[] = {
,
{0xa900, 0xa909}
,
+ {0xa9d0, 0xa9d9}
+ ,
{0xaa50, 0xaa59}
,
+ {0xabf0, 0xabf9}
+ ,
{0xff10, 0xff19}
,
{0x104a0, 0x104a9}
@@ -2933,7 +3033,7 @@ scm_t_char_range cs_digit_ranges[] = {
};
scm_t_char_set cs_digit = {
- 33,
+ 37,
cs_digit_ranges
};
@@ -2995,7 +3095,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x03f7, 0x0481}
,
- {0x048a, 0x0523}
+ {0x048a, 0x0525}
,
{0x0531, 0x0556}
,
@@ -3037,6 +3137,14 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x07fa, 0x07fa}
,
+ {0x0800, 0x0815}
+ ,
+ {0x081a, 0x081a}
+ ,
+ {0x0824, 0x0824}
+ ,
+ {0x0828, 0x0828}
+ ,
{0x0904, 0x0939}
,
{0x093d, 0x093d}
@@ -3049,7 +3157,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x0971, 0x0972}
,
- {0x097b, 0x097f}
+ {0x0979, 0x097f}
,
{0x0985, 0x098c}
,
@@ -3303,13 +3411,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x10fc, 0x10fc}
,
- {0x1100, 0x1159}
- ,
- {0x115f, 0x11a2}
- ,
- {0x11a8, 0x11f9}
- ,
- {0x1200, 0x1248}
+ {0x1100, 0x1248}
,
{0x124a, 0x124d}
,
@@ -3347,7 +3449,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x1401, 0x166c}
,
- {0x166f, 0x1676}
+ {0x166f, 0x167f}
,
{0x1681, 0x169a}
,
@@ -3381,20 +3483,30 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x18aa, 0x18aa}
,
+ {0x18b0, 0x18f5}
+ ,
{0x1900, 0x191c}
,
{0x1946, 0x196d}
,
{0x1970, 0x1974}
,
- {0x1980, 0x19a9}
+ {0x1980, 0x19ab}
,
{0x19c1, 0x19c7}
,
- {0x19d0, 0x19d9}
+ {0x19d0, 0x19da}
,
{0x1a00, 0x1a16}
,
+ {0x1a20, 0x1a54}
+ ,
+ {0x1a80, 0x1a89}
+ ,
+ {0x1a90, 0x1a99}
+ ,
+ {0x1aa7, 0x1aa7}
+ ,
{0x1b05, 0x1b33}
,
{0x1b45, 0x1b4b}
@@ -3411,6 +3523,10 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x1c4d, 0x1c7d}
,
+ {0x1ce9, 0x1cec}
+ ,
+ {0x1cee, 0x1cf1}
+ ,
{0x1d00, 0x1dbf}
,
{0x1e00, 0x1f15}
@@ -3489,11 +3605,9 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x2c30, 0x2c5e}
,
- {0x2c60, 0x2c6f}
- ,
- {0x2c71, 0x2c7d}
+ {0x2c60, 0x2ce4}
,
- {0x2c80, 0x2ce4}
+ {0x2ceb, 0x2cee}
,
{0x2d00, 0x2d25}
,
@@ -3545,10 +3659,12 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x3400, 0x4db5}
,
- {0x4e00, 0x9fc3}
+ {0x4e00, 0x9fcb}
,
{0xa000, 0xa48c}
,
+ {0xa4d0, 0xa4fd}
+ ,
{0xa500, 0xa60c}
,
{0xa610, 0xa62b}
@@ -3559,6 +3675,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0xa67f, 0xa697}
,
+ {0xa6a0, 0xa6e5}
+ ,
{0xa717, 0xa71f}
,
{0xa722, 0xa788}
@@ -3579,10 +3697,20 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0xa8d0, 0xa8d9}
,
+ {0xa8f2, 0xa8f7}
+ ,
+ {0xa8fb, 0xa8fb}
+ ,
{0xa900, 0xa925}
,
{0xa930, 0xa946}
,
+ {0xa960, 0xa97c}
+ ,
+ {0xa984, 0xa9b2}
+ ,
+ {0xa9cf, 0xa9d9}
+ ,
{0xaa00, 0xaa28}
,
{0xaa40, 0xaa42}
@@ -3591,11 +3719,37 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0xaa50, 0xaa59}
,
+ {0xaa60, 0xaa76}
+ ,
+ {0xaa7a, 0xaa7a}
+ ,
+ {0xaa80, 0xaaaf}
+ ,
+ {0xaab1, 0xaab1}
+ ,
+ {0xaab5, 0xaab6}
+ ,
+ {0xaab9, 0xaabd}
+ ,
+ {0xaac0, 0xaac0}
+ ,
+ {0xaac2, 0xaac2}
+ ,
+ {0xaadb, 0xaadd}
+ ,
+ {0xabc0, 0xabe2}
+ ,
+ {0xabf0, 0xabf9}
+ ,
{0xac00, 0xd7a3}
,
+ {0xd7b0, 0xd7c6}
+ ,
+ {0xd7cb, 0xd7fb}
+ ,
{0xf900, 0xfa2d}
,
- {0xfa30, 0xfa6a}
+ {0xfa30, 0xfa6d}
,
{0xfa70, 0xfad9}
,
@@ -3691,7 +3845,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x1083c, 0x1083c}
,
- {0x1083f, 0x1083f}
+ {0x1083f, 0x10855}
,
{0x10900, 0x10915}
,
@@ -3705,8 +3859,22 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x10a19, 0x10a33}
,
+ {0x10a60, 0x10a7c}
+ ,
+ {0x10b00, 0x10b35}
+ ,
+ {0x10b40, 0x10b55}
+ ,
+ {0x10b60, 0x10b72}
+ ,
+ {0x10c00, 0x10c48}
+ ,
+ {0x11083, 0x110af}
+ ,
{0x12000, 0x1236e}
,
+ {0x13000, 0x1342e}
+ ,
{0x1d400, 0x1d454}
,
{0x1d456, 0x1d49c}
@@ -3771,11 +3939,13 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = {
,
{0x20000, 0x2a6d6}
,
+ {0x2a700, 0x2b734}
+ ,
{0x2f800, 0x2fa1d}
};
scm_t_char_set cs_letter_plus_digit = {
- 411,
+ 446,
cs_letter_plus_digit_ranges
};
@@ -3794,7 +3964,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x038e, 0x03a1}
,
- {0x03a3, 0x0523}
+ {0x03a3, 0x0525}
,
{0x0531, 0x0556}
,
@@ -3826,15 +3996,19 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x07c0, 0x07fa}
,
- {0x0901, 0x0939}
+ {0x0800, 0x082d}
+ ,
+ {0x0830, 0x083e}
,
- {0x093c, 0x094d}
+ {0x0900, 0x0939}
,
- {0x0950, 0x0954}
+ {0x093c, 0x094e}
+ ,
+ {0x0950, 0x0955}
,
{0x0958, 0x0972}
,
- {0x097b, 0x097f}
+ {0x0979, 0x097f}
,
{0x0981, 0x0983}
,
@@ -3862,7 +4036,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x09df, 0x09e3}
,
- {0x09e6, 0x09fa}
+ {0x09e6, 0x09fb}
,
{0x0a01, 0x0a03}
,
@@ -4138,21 +4312,13 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x0fbe, 0x0fcc}
,
- {0x0fce, 0x0fd4}
- ,
- {0x1000, 0x1099}
+ {0x0fce, 0x0fd8}
,
- {0x109e, 0x10c5}
+ {0x1000, 0x10c5}
,
{0x10d0, 0x10fc}
,
- {0x1100, 0x1159}
- ,
- {0x115f, 0x11a2}
- ,
- {0x11a8, 0x11f9}
- ,
- {0x1200, 0x1248}
+ {0x1100, 0x1248}
,
{0x124a, 0x124d}
,
@@ -4190,7 +4356,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x13a0, 0x13f4}
,
- {0x1401, 0x1676}
+ {0x1400, 0x167f}
,
{0x1681, 0x169c}
,
@@ -4226,6 +4392,8 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x1880, 0x18aa}
,
+ {0x18b0, 0x18f5}
+ ,
{0x1900, 0x191c}
,
{0x1920, 0x192b}
@@ -4238,15 +4406,23 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x1970, 0x1974}
,
- {0x1980, 0x19a9}
+ {0x1980, 0x19ab}
,
{0x19b0, 0x19c9}
,
- {0x19d0, 0x19d9}
+ {0x19d0, 0x19da}
,
{0x19de, 0x1a1b}
,
- {0x1a1e, 0x1a1f}
+ {0x1a1e, 0x1a5e}
+ ,
+ {0x1a60, 0x1a7c}
+ ,
+ {0x1a7f, 0x1a89}
+ ,
+ {0x1a90, 0x1a99}
+ ,
+ {0x1aa0, 0x1aad}
,
{0x1b00, 0x1b4b}
,
@@ -4262,9 +4438,11 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x1c4d, 0x1c7f}
,
+ {0x1cd0, 0x1cf2}
+ ,
{0x1d00, 0x1de6}
,
- {0x1dfe, 0x1f15}
+ {0x1dfd, 0x1f15}
,
{0x1f18, 0x1f1d}
,
@@ -4306,25 +4484,25 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x2090, 0x2094}
,
- {0x20a0, 0x20b5}
+ {0x20a0, 0x20b8}
,
{0x20d0, 0x20f0}
,
- {0x2100, 0x214f}
- ,
- {0x2153, 0x2188}
+ {0x2100, 0x2189}
,
- {0x2190, 0x23e7}
+ {0x2190, 0x23e8}
,
{0x2400, 0x2426}
,
{0x2440, 0x244a}
,
- {0x2460, 0x269d}
+ {0x2460, 0x26cd}
,
- {0x26a0, 0x26bc}
+ {0x26cf, 0x26e1}
,
- {0x26c0, 0x26c3}
+ {0x26e3, 0x26e3}
+ ,
+ {0x26e8, 0x26ff}
,
{0x2701, 0x2704}
,
@@ -4338,9 +4516,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x274f, 0x2752}
,
- {0x2756, 0x2756}
- ,
- {0x2758, 0x275e}
+ {0x2756, 0x275e}
,
{0x2761, 0x2794}
,
@@ -4354,17 +4530,13 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x27d0, 0x2b4c}
,
- {0x2b50, 0x2b54}
+ {0x2b50, 0x2b59}
,
{0x2c00, 0x2c2e}
,
{0x2c30, 0x2c5e}
,
- {0x2c60, 0x2c6f}
- ,
- {0x2c71, 0x2c7d}
- ,
- {0x2c80, 0x2cea}
+ {0x2c60, 0x2cf1}
,
{0x2cf9, 0x2d25}
,
@@ -4390,7 +4562,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x2dd8, 0x2dde}
,
- {0x2de0, 0x2e30}
+ {0x2de0, 0x2e31}
,
{0x2e80, 0x2e99}
,
@@ -4416,19 +4588,17 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x31f0, 0x321e}
,
- {0x3220, 0x3243}
- ,
- {0x3250, 0x32fe}
+ {0x3220, 0x32fe}
,
{0x3300, 0x4db5}
,
- {0x4dc0, 0x9fc3}
+ {0x4dc0, 0x9fcb}
,
{0xa000, 0xa48c}
,
{0xa490, 0xa4c6}
,
- {0xa500, 0xa62b}
+ {0xa4d0, 0xa62b}
,
{0xa640, 0xa65f}
,
@@ -4436,19 +4606,31 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0xa67c, 0xa697}
,
+ {0xa6a0, 0xa6f7}
+ ,
{0xa700, 0xa78c}
,
{0xa7fb, 0xa82b}
,
+ {0xa830, 0xa839}
+ ,
{0xa840, 0xa877}
,
{0xa880, 0xa8c4}
,
{0xa8ce, 0xa8d9}
,
+ {0xa8e0, 0xa8fb}
+ ,
{0xa900, 0xa953}
,
- {0xa95f, 0xa95f}
+ {0xa95f, 0xa97c}
+ ,
+ {0xa980, 0xa9cd}
+ ,
+ {0xa9cf, 0xa9d9}
+ ,
+ {0xa9de, 0xa9df}
,
{0xaa00, 0xaa36}
,
@@ -4456,13 +4638,25 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0xaa50, 0xaa59}
,
- {0xaa5c, 0xaa5f}
+ {0xaa5c, 0xaa7b}
+ ,
+ {0xaa80, 0xaac2}
+ ,
+ {0xaadb, 0xaadf}
+ ,
+ {0xabc0, 0xabed}
+ ,
+ {0xabf0, 0xabf9}
,
{0xac00, 0xd7a3}
,
+ {0xd7b0, 0xd7c6}
+ ,
+ {0xd7cb, 0xd7fb}
+ ,
{0xf900, 0xfa2d}
,
- {0xfa30, 0xfa6a}
+ {0xfa30, 0xfa6d}
,
{0xfa70, 0xfad9}
,
@@ -4574,9 +4768,11 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x1083c, 0x1083c}
,
- {0x1083f, 0x1083f}
+ {0x1083f, 0x10855}
,
- {0x10900, 0x10919}
+ {0x10857, 0x1085f}
+ ,
+ {0x10900, 0x1091b}
,
{0x1091f, 0x10939}
,
@@ -4598,12 +4794,32 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x10a50, 0x10a58}
,
+ {0x10a60, 0x10a7f}
+ ,
+ {0x10b00, 0x10b35}
+ ,
+ {0x10b39, 0x10b55}
+ ,
+ {0x10b58, 0x10b72}
+ ,
+ {0x10b78, 0x10b7f}
+ ,
+ {0x10c00, 0x10c48}
+ ,
+ {0x10e60, 0x10e7e}
+ ,
+ {0x11080, 0x110bc}
+ ,
+ {0x110be, 0x110c1}
+ ,
{0x12000, 0x1236e}
,
{0x12400, 0x12462}
,
{0x12470, 0x12473}
,
+ {0x13000, 0x1342e}
+ ,
{0x1d000, 0x1d0f5}
,
{0x1d100, 0x1d126}
@@ -4664,15 +4880,53 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x1f030, 0x1f093}
,
+ {0x1f100, 0x1f10a}
+ ,
+ {0x1f110, 0x1f12e}
+ ,
+ {0x1f131, 0x1f131}
+ ,
+ {0x1f13d, 0x1f13d}
+ ,
+ {0x1f13f, 0x1f13f}
+ ,
+ {0x1f142, 0x1f142}
+ ,
+ {0x1f146, 0x1f146}
+ ,
+ {0x1f14a, 0x1f14e}
+ ,
+ {0x1f157, 0x1f157}
+ ,
+ {0x1f15f, 0x1f15f}
+ ,
+ {0x1f179, 0x1f179}
+ ,
+ {0x1f17b, 0x1f17c}
+ ,
+ {0x1f17f, 0x1f17f}
+ ,
+ {0x1f18a, 0x1f18d}
+ ,
+ {0x1f190, 0x1f190}
+ ,
+ {0x1f200, 0x1f200}
+ ,
+ {0x1f210, 0x1f231}
+ ,
+ {0x1f240, 0x1f248}
+ ,
{0x20000, 0x2a6d6}
,
+ {0x2a700, 0x2b734}
+ ,
{0x2f800, 0x2fa1d}
,
{0xe0100, 0xe01ef}
};
scm_t_char_set cs_graphic = {
- 445,
+ 487,
cs_graphic_ranges
};
@@ -4720,7 +4974,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x038e, 0x03a1}
,
- {0x03a3, 0x0523}
+ {0x03a3, 0x0525}
,
{0x0531, 0x0556}
,
@@ -4752,15 +5006,19 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x07c0, 0x07fa}
,
- {0x0901, 0x0939}
+ {0x0800, 0x082d}
+ ,
+ {0x0830, 0x083e}
+ ,
+ {0x0900, 0x0939}
,
- {0x093c, 0x094d}
+ {0x093c, 0x094e}
,
- {0x0950, 0x0954}
+ {0x0950, 0x0955}
,
{0x0958, 0x0972}
,
- {0x097b, 0x097f}
+ {0x0979, 0x097f}
,
{0x0981, 0x0983}
,
@@ -4788,7 +5046,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x09df, 0x09e3}
,
- {0x09e6, 0x09fa}
+ {0x09e6, 0x09fb}
,
{0x0a01, 0x0a03}
,
@@ -5064,21 +5322,13 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x0fbe, 0x0fcc}
,
- {0x0fce, 0x0fd4}
+ {0x0fce, 0x0fd8}
,
- {0x1000, 0x1099}
- ,
- {0x109e, 0x10c5}
+ {0x1000, 0x10c5}
,
{0x10d0, 0x10fc}
,
- {0x1100, 0x1159}
- ,
- {0x115f, 0x11a2}
- ,
- {0x11a8, 0x11f9}
- ,
- {0x1200, 0x1248}
+ {0x1100, 0x1248}
,
{0x124a, 0x124d}
,
@@ -5116,9 +5366,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x13a0, 0x13f4}
,
- {0x1401, 0x1676}
- ,
- {0x1680, 0x169c}
+ {0x1400, 0x169c}
,
{0x16a0, 0x16f0}
,
@@ -5152,6 +5400,8 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x1880, 0x18aa}
,
+ {0x18b0, 0x18f5}
+ ,
{0x1900, 0x191c}
,
{0x1920, 0x192b}
@@ -5164,15 +5414,23 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x1970, 0x1974}
,
- {0x1980, 0x19a9}
+ {0x1980, 0x19ab}
,
{0x19b0, 0x19c9}
,
- {0x19d0, 0x19d9}
+ {0x19d0, 0x19da}
,
{0x19de, 0x1a1b}
,
- {0x1a1e, 0x1a1f}
+ {0x1a1e, 0x1a5e}
+ ,
+ {0x1a60, 0x1a7c}
+ ,
+ {0x1a7f, 0x1a89}
+ ,
+ {0x1a90, 0x1a99}
+ ,
+ {0x1aa0, 0x1aad}
,
{0x1b00, 0x1b4b}
,
@@ -5188,9 +5446,11 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x1c4d, 0x1c7f}
,
+ {0x1cd0, 0x1cf2}
+ ,
{0x1d00, 0x1de6}
,
- {0x1dfe, 0x1f15}
+ {0x1dfd, 0x1f15}
,
{0x1f18, 0x1f1d}
,
@@ -5234,25 +5494,25 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x2090, 0x2094}
,
- {0x20a0, 0x20b5}
+ {0x20a0, 0x20b8}
,
{0x20d0, 0x20f0}
,
- {0x2100, 0x214f}
- ,
- {0x2153, 0x2188}
+ {0x2100, 0x2189}
,
- {0x2190, 0x23e7}
+ {0x2190, 0x23e8}
,
{0x2400, 0x2426}
,
{0x2440, 0x244a}
,
- {0x2460, 0x269d}
+ {0x2460, 0x26cd}
+ ,
+ {0x26cf, 0x26e1}
,
- {0x26a0, 0x26bc}
+ {0x26e3, 0x26e3}
,
- {0x26c0, 0x26c3}
+ {0x26e8, 0x26ff}
,
{0x2701, 0x2704}
,
@@ -5266,9 +5526,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x274f, 0x2752}
,
- {0x2756, 0x2756}
- ,
- {0x2758, 0x275e}
+ {0x2756, 0x275e}
,
{0x2761, 0x2794}
,
@@ -5282,17 +5540,13 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x27d0, 0x2b4c}
,
- {0x2b50, 0x2b54}
+ {0x2b50, 0x2b59}
,
{0x2c00, 0x2c2e}
,
{0x2c30, 0x2c5e}
,
- {0x2c60, 0x2c6f}
- ,
- {0x2c71, 0x2c7d}
- ,
- {0x2c80, 0x2cea}
+ {0x2c60, 0x2cf1}
,
{0x2cf9, 0x2d25}
,
@@ -5318,7 +5572,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x2dd8, 0x2dde}
,
- {0x2de0, 0x2e30}
+ {0x2de0, 0x2e31}
,
{0x2e80, 0x2e99}
,
@@ -5344,19 +5598,17 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x31f0, 0x321e}
,
- {0x3220, 0x3243}
- ,
- {0x3250, 0x32fe}
+ {0x3220, 0x32fe}
,
{0x3300, 0x4db5}
,
- {0x4dc0, 0x9fc3}
+ {0x4dc0, 0x9fcb}
,
{0xa000, 0xa48c}
,
{0xa490, 0xa4c6}
,
- {0xa500, 0xa62b}
+ {0xa4d0, 0xa62b}
,
{0xa640, 0xa65f}
,
@@ -5364,19 +5616,31 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0xa67c, 0xa697}
,
+ {0xa6a0, 0xa6f7}
+ ,
{0xa700, 0xa78c}
,
{0xa7fb, 0xa82b}
,
+ {0xa830, 0xa839}
+ ,
{0xa840, 0xa877}
,
{0xa880, 0xa8c4}
,
{0xa8ce, 0xa8d9}
,
+ {0xa8e0, 0xa8fb}
+ ,
{0xa900, 0xa953}
,
- {0xa95f, 0xa95f}
+ {0xa95f, 0xa97c}
+ ,
+ {0xa980, 0xa9cd}
+ ,
+ {0xa9cf, 0xa9d9}
+ ,
+ {0xa9de, 0xa9df}
,
{0xaa00, 0xaa36}
,
@@ -5384,13 +5648,25 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0xaa50, 0xaa59}
,
- {0xaa5c, 0xaa5f}
+ {0xaa5c, 0xaa7b}
+ ,
+ {0xaa80, 0xaac2}
+ ,
+ {0xaadb, 0xaadf}
+ ,
+ {0xabc0, 0xabed}
+ ,
+ {0xabf0, 0xabf9}
,
{0xac00, 0xd7a3}
,
+ {0xd7b0, 0xd7c6}
+ ,
+ {0xd7cb, 0xd7fb}
+ ,
{0xf900, 0xfa2d}
,
- {0xfa30, 0xfa6a}
+ {0xfa30, 0xfa6d}
,
{0xfa70, 0xfad9}
,
@@ -5502,9 +5778,11 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x1083c, 0x1083c}
,
- {0x1083f, 0x1083f}
+ {0x1083f, 0x10855}
,
- {0x10900, 0x10919}
+ {0x10857, 0x1085f}
+ ,
+ {0x10900, 0x1091b}
,
{0x1091f, 0x10939}
,
@@ -5526,12 +5804,32 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x10a50, 0x10a58}
,
+ {0x10a60, 0x10a7f}
+ ,
+ {0x10b00, 0x10b35}
+ ,
+ {0x10b39, 0x10b55}
+ ,
+ {0x10b58, 0x10b72}
+ ,
+ {0x10b78, 0x10b7f}
+ ,
+ {0x10c00, 0x10c48}
+ ,
+ {0x10e60, 0x10e7e}
+ ,
+ {0x11080, 0x110bc}
+ ,
+ {0x110be, 0x110c1}
+ ,
{0x12000, 0x1236e}
,
{0x12400, 0x12462}
,
{0x12470, 0x12473}
,
+ {0x13000, 0x1342e}
+ ,
{0x1d000, 0x1d0f5}
,
{0x1d100, 0x1d126}
@@ -5592,15 +5890,53 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x1f030, 0x1f093}
,
+ {0x1f100, 0x1f10a}
+ ,
+ {0x1f110, 0x1f12e}
+ ,
+ {0x1f131, 0x1f131}
+ ,
+ {0x1f13d, 0x1f13d}
+ ,
+ {0x1f13f, 0x1f13f}
+ ,
+ {0x1f142, 0x1f142}
+ ,
+ {0x1f146, 0x1f146}
+ ,
+ {0x1f14a, 0x1f14e}
+ ,
+ {0x1f157, 0x1f157}
+ ,
+ {0x1f15f, 0x1f15f}
+ ,
+ {0x1f179, 0x1f179}
+ ,
+ {0x1f17b, 0x1f17c}
+ ,
+ {0x1f17f, 0x1f17f}
+ ,
+ {0x1f18a, 0x1f18d}
+ ,
+ {0x1f190, 0x1f190}
+ ,
+ {0x1f200, 0x1f200}
+ ,
+ {0x1f210, 0x1f231}
+ ,
+ {0x1f240, 0x1f248}
+ ,
{0x20000, 0x2a6d6}
,
+ {0x2a700, 0x2b734}
+ ,
{0x2f800, 0x2fa1d}
,
{0xe0100, 0xe01ef}
};
scm_t_char_set cs_printing = {
- 447,
+ 488,
cs_printing_ranges
};
@@ -5678,6 +6014,8 @@ scm_t_char_range cs_punctuation_ranges[] = {
,
{0x07f7, 0x07f9}
,
+ {0x0830, 0x083e}
+ ,
{0x0964, 0x0965}
,
{0x0970, 0x0970}
@@ -5702,6 +6040,8 @@ scm_t_char_range cs_punctuation_ranges[] = {
,
{0x1361, 0x1368}
,
+ {0x1400, 0x1400}
+ ,
{0x166d, 0x166e}
,
{0x169b, 0x169c}
@@ -5722,12 +6062,18 @@ scm_t_char_range cs_punctuation_ranges[] = {
,
{0x1a1e, 0x1a1f}
,
+ {0x1aa0, 0x1aa6}
+ ,
+ {0x1aa8, 0x1aad}
+ ,
{0x1b5a, 0x1b60}
,
{0x1c3b, 0x1c3f}
,
{0x1c7e, 0x1c7f}
,
+ {0x1cd3, 0x1cd3}
+ ,
{0x2010, 0x2027}
,
{0x2030, 0x2043}
@@ -5760,7 +6106,7 @@ scm_t_char_range cs_punctuation_ranges[] = {
,
{0x2e00, 0x2e2e}
,
- {0x2e30, 0x2e30}
+ {0x2e30, 0x2e31}
,
{0x3001, 0x3003}
,
@@ -5776,22 +6122,36 @@ scm_t_char_range cs_punctuation_ranges[] = {
,
{0x30fb, 0x30fb}
,
+ {0xa4fe, 0xa4ff}
+ ,
{0xa60d, 0xa60f}
,
{0xa673, 0xa673}
,
{0xa67e, 0xa67e}
,
+ {0xa6f2, 0xa6f7}
+ ,
{0xa874, 0xa877}
,
{0xa8ce, 0xa8cf}
,
+ {0xa8f8, 0xa8fa}
+ ,
{0xa92e, 0xa92f}
,
{0xa95f, 0xa95f}
,
+ {0xa9c1, 0xa9cd}
+ ,
+ {0xa9de, 0xa9df}
+ ,
{0xaa5c, 0xaa5f}
,
+ {0xaade, 0xaadf}
+ ,
+ {0xabeb, 0xabeb}
+ ,
{0xfd3e, 0xfd3f}
,
{0xfe10, 0xfe19}
@@ -5832,17 +6192,27 @@ scm_t_char_range cs_punctuation_ranges[] = {
,
{0x103d0, 0x103d0}
,
+ {0x10857, 0x10857}
+ ,
{0x1091f, 0x1091f}
,
{0x1093f, 0x1093f}
,
{0x10a50, 0x10a58}
,
+ {0x10a7f, 0x10a7f}
+ ,
+ {0x10b39, 0x10b3f}
+ ,
+ {0x110bb, 0x110bc}
+ ,
+ {0x110be, 0x110c1}
+ ,
{0x12470, 0x12473}
};
scm_t_char_set cs_punctuation = {
- 112,
+ 129,
cs_punctuation_ranges
};
@@ -5909,7 +6279,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x09f2, 0x09f3}
,
- {0x09fa, 0x09fa}
+ {0x09fa, 0x09fb}
,
{0x0af1, 0x0af1}
,
@@ -5943,6 +6313,8 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x0fce, 0x0fcf}
,
+ {0x0fd5, 0x0fd8}
+ ,
{0x109e, 0x109f}
,
{0x1360, 0x1360}
@@ -5979,7 +6351,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x208a, 0x208c}
,
- {0x20a0, 0x20b5}
+ {0x20a0, 0x20b8}
,
{0x2100, 0x2101}
,
@@ -6011,7 +6383,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x2190, 0x2328}
,
- {0x232b, 0x23e7}
+ {0x232b, 0x23e8}
,
{0x2400, 0x2426}
,
@@ -6019,11 +6391,13 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x249c, 0x24e9}
,
- {0x2500, 0x269d}
+ {0x2500, 0x26cd}
+ ,
+ {0x26cf, 0x26e1}
,
- {0x26a0, 0x26bc}
+ {0x26e3, 0x26e3}
,
- {0x26c0, 0x26c3}
+ {0x26e8, 0x26ff}
,
{0x2701, 0x2704}
,
@@ -6037,9 +6411,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x274f, 0x2752}
,
- {0x2756, 0x2756}
- ,
- {0x2758, 0x275e}
+ {0x2756, 0x275e}
,
{0x2761, 0x2767}
,
@@ -6065,7 +6437,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x29fe, 0x2b4c}
,
- {0x2b50, 0x2b54}
+ {0x2b50, 0x2b59}
,
{0x2ce5, 0x2cea}
,
@@ -6097,9 +6469,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x3200, 0x321e}
,
- {0x322a, 0x3243}
- ,
- {0x3250, 0x3250}
+ {0x322a, 0x3250}
,
{0x3260, 0x327f}
,
@@ -6121,6 +6491,10 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0xa828, 0xa82b}
,
+ {0xa836, 0xa839}
+ ,
+ {0xaa77, 0xaa79}
+ ,
{0xfb29, 0xfb29}
,
{0xfdfc, 0xfdfd}
@@ -6204,10 +6578,44 @@ scm_t_char_range cs_symbol_ranges[] = {
{0x1f000, 0x1f02b}
,
{0x1f030, 0x1f093}
+ ,
+ {0x1f110, 0x1f12e}
+ ,
+ {0x1f131, 0x1f131}
+ ,
+ {0x1f13d, 0x1f13d}
+ ,
+ {0x1f13f, 0x1f13f}
+ ,
+ {0x1f142, 0x1f142}
+ ,
+ {0x1f146, 0x1f146}
+ ,
+ {0x1f14a, 0x1f14e}
+ ,
+ {0x1f157, 0x1f157}
+ ,
+ {0x1f15f, 0x1f15f}
+ ,
+ {0x1f179, 0x1f179}
+ ,
+ {0x1f17b, 0x1f17c}
+ ,
+ {0x1f17f, 0x1f17f}
+ ,
+ {0x1f18a, 0x1f18d}
+ ,
+ {0x1f190, 0x1f190}
+ ,
+ {0x1f200, 0x1f200}
+ ,
+ {0x1f210, 0x1f231}
+ ,
+ {0x1f240, 0x1f248}
};
scm_t_char_set cs_symbol = {
- 179,
+ 198,
cs_symbol_ranges
};
@@ -6241,7 +6649,7 @@ scm_t_char_range cs_ascii_ranges[] = {
};
scm_t_char_set cs_ascii = {
- 0,
+ 1,
cs_ascii_ranges
};
@@ -6264,7 +6672,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x038e, 0x03a1}
,
- {0x03a3, 0x0523}
+ {0x03a3, 0x0525}
,
{0x0531, 0x0556}
,
@@ -6296,15 +6704,19 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x07c0, 0x07fa}
,
- {0x0901, 0x0939}
+ {0x0800, 0x082d}
+ ,
+ {0x0830, 0x083e}
,
- {0x093c, 0x094d}
+ {0x0900, 0x0939}
,
- {0x0950, 0x0954}
+ {0x093c, 0x094e}
+ ,
+ {0x0950, 0x0955}
,
{0x0958, 0x0972}
,
- {0x097b, 0x097f}
+ {0x0979, 0x097f}
,
{0x0981, 0x0983}
,
@@ -6332,7 +6744,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x09df, 0x09e3}
,
- {0x09e6, 0x09fa}
+ {0x09e6, 0x09fb}
,
{0x0a01, 0x0a03}
,
@@ -6608,21 +7020,13 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x0fbe, 0x0fcc}
,
- {0x0fce, 0x0fd4}
- ,
- {0x1000, 0x1099}
+ {0x0fce, 0x0fd8}
,
- {0x109e, 0x10c5}
+ {0x1000, 0x10c5}
,
{0x10d0, 0x10fc}
,
- {0x1100, 0x1159}
- ,
- {0x115f, 0x11a2}
- ,
- {0x11a8, 0x11f9}
- ,
- {0x1200, 0x1248}
+ {0x1100, 0x1248}
,
{0x124a, 0x124d}
,
@@ -6660,9 +7064,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x13a0, 0x13f4}
,
- {0x1401, 0x1676}
- ,
- {0x1680, 0x169c}
+ {0x1400, 0x169c}
,
{0x16a0, 0x16f0}
,
@@ -6694,6 +7096,8 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x1880, 0x18aa}
,
+ {0x18b0, 0x18f5}
+ ,
{0x1900, 0x191c}
,
{0x1920, 0x192b}
@@ -6706,15 +7110,23 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x1970, 0x1974}
,
- {0x1980, 0x19a9}
+ {0x1980, 0x19ab}
,
{0x19b0, 0x19c9}
,
- {0x19d0, 0x19d9}
+ {0x19d0, 0x19da}
,
{0x19de, 0x1a1b}
,
- {0x1a1e, 0x1a1f}
+ {0x1a1e, 0x1a5e}
+ ,
+ {0x1a60, 0x1a7c}
+ ,
+ {0x1a7f, 0x1a89}
+ ,
+ {0x1a90, 0x1a99}
+ ,
+ {0x1aa0, 0x1aad}
,
{0x1b00, 0x1b4b}
,
@@ -6730,9 +7142,11 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x1c4d, 0x1c7f}
,
+ {0x1cd0, 0x1cf2}
+ ,
{0x1d00, 0x1de6}
,
- {0x1dfe, 0x1f15}
+ {0x1dfd, 0x1f15}
,
{0x1f18, 0x1f1d}
,
@@ -6772,25 +7186,25 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x2090, 0x2094}
,
- {0x20a0, 0x20b5}
+ {0x20a0, 0x20b8}
,
{0x20d0, 0x20f0}
,
- {0x2100, 0x214f}
- ,
- {0x2153, 0x2188}
+ {0x2100, 0x2189}
,
- {0x2190, 0x23e7}
+ {0x2190, 0x23e8}
,
{0x2400, 0x2426}
,
{0x2440, 0x244a}
,
- {0x2460, 0x269d}
+ {0x2460, 0x26cd}
,
- {0x26a0, 0x26bc}
+ {0x26cf, 0x26e1}
,
- {0x26c0, 0x26c3}
+ {0x26e3, 0x26e3}
+ ,
+ {0x26e8, 0x26ff}
,
{0x2701, 0x2704}
,
@@ -6804,9 +7218,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x274f, 0x2752}
,
- {0x2756, 0x2756}
- ,
- {0x2758, 0x275e}
+ {0x2756, 0x275e}
,
{0x2761, 0x2794}
,
@@ -6820,17 +7232,13 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x27d0, 0x2b4c}
,
- {0x2b50, 0x2b54}
+ {0x2b50, 0x2b59}
,
{0x2c00, 0x2c2e}
,
{0x2c30, 0x2c5e}
,
- {0x2c60, 0x2c6f}
- ,
- {0x2c71, 0x2c7d}
- ,
- {0x2c80, 0x2cea}
+ {0x2c60, 0x2cf1}
,
{0x2cf9, 0x2d25}
,
@@ -6856,7 +7264,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x2dd8, 0x2dde}
,
- {0x2de0, 0x2e30}
+ {0x2de0, 0x2e31}
,
{0x2e80, 0x2e99}
,
@@ -6882,19 +7290,17 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x31f0, 0x321e}
,
- {0x3220, 0x3243}
- ,
- {0x3250, 0x32fe}
+ {0x3220, 0x32fe}
,
{0x3300, 0x4db5}
,
- {0x4dc0, 0x9fc3}
+ {0x4dc0, 0x9fcb}
,
{0xa000, 0xa48c}
,
{0xa490, 0xa4c6}
,
- {0xa500, 0xa62b}
+ {0xa4d0, 0xa62b}
,
{0xa640, 0xa65f}
,
@@ -6902,19 +7308,31 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0xa67c, 0xa697}
,
+ {0xa6a0, 0xa6f7}
+ ,
{0xa700, 0xa78c}
,
{0xa7fb, 0xa82b}
,
+ {0xa830, 0xa839}
+ ,
{0xa840, 0xa877}
,
{0xa880, 0xa8c4}
,
{0xa8ce, 0xa8d9}
,
+ {0xa8e0, 0xa8fb}
+ ,
{0xa900, 0xa953}
,
- {0xa95f, 0xa95f}
+ {0xa95f, 0xa97c}
+ ,
+ {0xa980, 0xa9cd}
+ ,
+ {0xa9cf, 0xa9d9}
+ ,
+ {0xa9de, 0xa9df}
,
{0xaa00, 0xaa36}
,
@@ -6922,13 +7340,25 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0xaa50, 0xaa59}
,
- {0xaa5c, 0xaa5f}
+ {0xaa5c, 0xaa7b}
+ ,
+ {0xaa80, 0xaac2}
+ ,
+ {0xaadb, 0xaadf}
+ ,
+ {0xabc0, 0xabed}
+ ,
+ {0xabf0, 0xabf9}
,
{0xac00, 0xd7a3}
,
+ {0xd7b0, 0xd7c6}
+ ,
+ {0xd7cb, 0xd7fb}
+ ,
{0xe000, 0xfa2d}
,
- {0xfa30, 0xfa6a}
+ {0xfa30, 0xfa6d}
,
{0xfa70, 0xfad9}
,
@@ -7042,9 +7472,11 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x1083c, 0x1083c}
,
- {0x1083f, 0x1083f}
+ {0x1083f, 0x10855}
+ ,
+ {0x10857, 0x1085f}
,
- {0x10900, 0x10919}
+ {0x10900, 0x1091b}
,
{0x1091f, 0x10939}
,
@@ -7066,12 +7498,30 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x10a50, 0x10a58}
,
+ {0x10a60, 0x10a7f}
+ ,
+ {0x10b00, 0x10b35}
+ ,
+ {0x10b39, 0x10b55}
+ ,
+ {0x10b58, 0x10b72}
+ ,
+ {0x10b78, 0x10b7f}
+ ,
+ {0x10c00, 0x10c48}
+ ,
+ {0x10e60, 0x10e7e}
+ ,
+ {0x11080, 0x110c1}
+ ,
{0x12000, 0x1236e}
,
{0x12400, 0x12462}
,
{0x12470, 0x12473}
,
+ {0x13000, 0x1342e}
+ ,
{0x1d000, 0x1d0f5}
,
{0x1d100, 0x1d126}
@@ -7130,8 +7580,46 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x1f030, 0x1f093}
,
+ {0x1f100, 0x1f10a}
+ ,
+ {0x1f110, 0x1f12e}
+ ,
+ {0x1f131, 0x1f131}
+ ,
+ {0x1f13d, 0x1f13d}
+ ,
+ {0x1f13f, 0x1f13f}
+ ,
+ {0x1f142, 0x1f142}
+ ,
+ {0x1f146, 0x1f146}
+ ,
+ {0x1f14a, 0x1f14e}
+ ,
+ {0x1f157, 0x1f157}
+ ,
+ {0x1f15f, 0x1f15f}
+ ,
+ {0x1f179, 0x1f179}
+ ,
+ {0x1f17b, 0x1f17c}
+ ,
+ {0x1f17f, 0x1f17f}
+ ,
+ {0x1f18a, 0x1f18d}
+ ,
+ {0x1f190, 0x1f190}
+ ,
+ {0x1f200, 0x1f200}
+ ,
+ {0x1f210, 0x1f231}
+ ,
+ {0x1f240, 0x1f248}
+ ,
{0x20000, 0x2a6d6}
,
+ {0x2a700, 0x2b734}
+ ,
{0x2f800, 0x2fa1d}
,
{0xe0001, 0xe0001}
@@ -7146,6 +7634,6 @@ scm_t_char_range cs_designated_ranges[] = {
};
scm_t_char_set cs_designated = {
- 445,
+ 485,
cs_designated_ranges
};
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 7388619..85fbc2d 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -1,6 +1,6 @@
/* srfi-4.c --- Uniform numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,809 +22,199 @@
# include <config.h>
#endif
-#include <string.h>
-#include <errno.h>
-#include <stdio.h>
-
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
-#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
-#include "libguile/generalized-vectors.h"
-#include "libguile/uniform.h"
#include "libguile/error.h"
#include "libguile/eval.h"
-#include "libguile/read.h"
-#include "libguile/ports.h"
-#include "libguile/chars.h"
-#include "libguile/vectors.h"
-#include "libguile/arrays.h"
-#include "libguile/strings.h"
-#include "libguile/strports.h"
-#include "libguile/dynwind.h"
-#include "libguile/deprecation.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
+#include "libguile/extensions.h"
+#include "libguile/uniform.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/validate.h"
-#ifdef HAVE_IO_H
-#include <io.h>
-#endif
-/* Smob type code for uniform numeric vectors. */
-int scm_tc16_uvec = 0;
-
-#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
-
-/* Accessor macros for the three components of a uniform numeric
- vector:
- - The type tag (one of the symbolic constants below).
- - The vector's length (counted in elements).
- - The address of the data area (holding the elements of the
- vector). */
-#define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u))
-#define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u))
-#define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u))
-
-
-/* Symbolic constants encoding the various types of uniform
- numeric vectors. */
-#define SCM_UVEC_U8 0
-#define SCM_UVEC_S8 1
-#define SCM_UVEC_U16 2
-#define SCM_UVEC_S16 3
-#define SCM_UVEC_U32 4
-#define SCM_UVEC_S32 5
-#define SCM_UVEC_U64 6
-#define SCM_UVEC_S64 7
-#define SCM_UVEC_F32 8
-#define SCM_UVEC_F64 9
-#define SCM_UVEC_C32 10
-#define SCM_UVEC_C64 11
-
-
-/* This array maps type tags to the size of the elements. */
-static const int uvec_sizes[12] = {
- 1, 1,
- 2, 2,
- 4, 4,
-#if SCM_HAVE_T_INT64
- 8, 8,
-#else
- sizeof (SCM), sizeof (SCM),
-#endif
- sizeof(float), sizeof(double),
- 2*sizeof(float), 2*sizeof(double)
-};
-
-static const char *uvec_tags[12] = {
- "u8", "s8",
- "u16", "s16",
- "u32", "s32",
- "u64", "s64",
- "f32", "f64",
- "c32", "c64",
-};
-
-static const char *uvec_names[12] = {
- "u8vector", "s8vector",
- "u16vector", "s16vector",
- "u32vector", "s32vector",
- "u64vector", "s64vector",
- "f32vector", "f64vector",
- "c32vector", "c64vector"
-};
-
-/* ================================================================ */
-/* SMOB procedures. */
-/* ================================================================ */
-
-
-/* Smob print hook for uniform vectors. */
-static int
-uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
-{
- union {
- scm_t_uint8 *u8;
- scm_t_int8 *s8;
- scm_t_uint16 *u16;
- scm_t_int16 *s16;
- scm_t_uint32 *u32;
- scm_t_int32 *s32;
-#if SCM_HAVE_T_INT64
- scm_t_uint64 *u64;
- scm_t_int64 *s64;
-#endif
- float *f32;
- double *f64;
- SCM *fake_64;
- } np;
-
- size_t i = 0;
- const size_t uvlen = SCM_UVEC_LENGTH (uvec);
- void *uptr = SCM_UVEC_BASE (uvec);
-
- switch (SCM_UVEC_TYPE (uvec))
- {
- case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
- case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
- case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
- case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
- case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
- case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
-#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
- case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
-#else
- case SCM_UVEC_U64:
- case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break;
-#endif
- case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
- case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
- case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
- case SCM_UVEC_C64: np.f64 = (double *) uptr; break;
- default:
- abort (); /* Sanity check. */
- break;
+#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
+ SCM cname (SCM arg1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
}
- scm_putc ('#', port);
- scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
- scm_putc ('(', port);
-
- while (i < uvlen)
- {
- if (i != 0) scm_puts (" ", port);
- switch (SCM_UVEC_TYPE (uvec))
- {
- case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
- case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
- case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
- case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
- case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
- case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
-#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
- case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
-#else
- case SCM_UVEC_U64:
- case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate);
- np.fake_64++; break;
-#endif
- case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
- case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
- case SCM_UVEC_C32:
- scm_i_print_complex (np.f32[0], np.f32[1], port);
- np.f32 += 2;
- break;
- case SCM_UVEC_C64:
- scm_i_print_complex (np.f64[0], np.f64[1], port);
- np.f64 += 2;
- break;
- default:
- abort (); /* Sanity check. */
- break;
- }
- i++;
- }
- scm_remember_upto_here_1 (uvec);
- scm_puts (")", port);
- return 1;
-}
-
-const char *
-scm_i_uniform_vector_tag (SCM uvec)
-{
- return uvec_tags[SCM_UVEC_TYPE (uvec)];
-}
-
-static SCM
-uvec_equalp (SCM a, SCM b)
-{
- SCM result = SCM_BOOL_T;
- if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
- result = SCM_BOOL_F;
- else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
- result = SCM_BOOL_F;
-#if SCM_HAVE_T_INT64 == 0
- else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64
- || SCM_UVEC_TYPE (a) == SCM_UVEC_S64)
- {
- SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b);
- size_t len = SCM_UVEC_LENGTH (a), i;
- for (i = 0; i < len; i++)
- if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++)))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
-#endif
- else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
- SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
- result = SCM_BOOL_F;
-
- scm_remember_upto_here_2 (a, b);
- return result;
-}
-
-
-/* ================================================================ */
-/* Utility procedures. */
-/* ================================================================ */
-
-static SCM_C_INLINE_KEYWORD int
-is_uvec (int type, SCM obj)
-{
- if (SCM_IS_UVEC (obj))
- return SCM_UVEC_TYPE (obj) == type;
- if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
- {
- SCM v = SCM_I_ARRAY_V (obj);
- return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
- }
- return 0;
-}
+#define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \
+ SCM cname (SCM args) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_apply_0 (SCM_VARIABLE_REF (var), args); \
+ }
-static SCM_C_INLINE_KEYWORD SCM
-uvec_p (int type, SCM obj)
-{
- return scm_from_bool (is_uvec (type, obj));
-}
+#define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM opt1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ if (SCM_UNBNDP (opt1)) \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
+ else \
+ return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \
+ }
-static SCM_C_INLINE_KEYWORD void
-uvec_assert (int type, SCM obj)
-{
- if (!is_uvec (type, obj))
- scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
-}
+#define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM arg2) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2); \
+ }
-/* Invoke free(3) on DATA, a user-provided buffer passed to one of the
- `scm_take_' functions. */
-static void
-free_user_data (GC_PTR data, GC_PTR unused)
-{
- free (data);
-}
+#define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM arg2, SCM arg3) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3); \
+ }
-static SCM
-take_uvec (int type, void *base, size_t len)
-{
- SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
-}
+#define DEFPROXY100(cname, scmname) \
+ DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+#define DEFPROXY110(cname, scmname) \
+ DEFINE_SCHEME_PROXY110 (cname, MOD, scmname)
+#define DEFPROXY001(cname, scmname) \
+ DEFINE_SCHEME_PROXY001 (cname, MOD, scmname)
+#define DEFPROXY200(cname, scmname) \
+ DEFINE_SCHEME_PROXY200 (cname, MOD, scmname)
+#define DEFPROXY300(cname, scmname) \
+ DEFINE_SCHEME_PROXY300 (cname, MOD, scmname)
+
+#define DEFVECT(sym, str, func)\
+
+#define DEFINE_SRFI_4_PROXIES(tag) \
+ DEFPROXY100 (scm_##tag##vector_p, #tag "vector?"); \
+ DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector"); \
+ DEFPROXY001 (scm_##tag##vector, #tag "vector"); \
+ DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length"); \
+ DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref"); \
+ DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!"); \
+ DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector"); \
+ DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list"); \
-/* Create a new, uninitialized uniform numeric vector of type TYPE
- with space for LEN elements. */
-static SCM
-alloc_uvec (int type, size_t len)
-{
- void *base;
- if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
- scm_out_of_range (NULL, scm_from_size_t (len));
- base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
-#if SCM_HAVE_T_INT64 == 0
- if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64)
- {
- SCM *ptr = (SCM *)base;
- size_t i;
- for (i = 0; i < len; i++)
- *ptr++ = SCM_UNSPECIFIED;
- }
-#endif
- return take_uvec (type, base, len);
-}
-
-/* GCC doesn't seem to want to optimize unused switch clauses away,
- so we use a big 'if' in the next two functions.
-*/
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_fast_ref (int type, const void *base, size_t c_idx)
-{
- if (type == SCM_UVEC_U8)
- return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
- else if (type == SCM_UVEC_S8)
- return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
- else if (type == SCM_UVEC_U16)
- return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
- else if (type == SCM_UVEC_S16)
- return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
- else if (type == SCM_UVEC_U32)
- return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
- else if (type == SCM_UVEC_S32)
- return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
-#if SCM_HAVE_T_INT64
- else if (type == SCM_UVEC_U64)
- return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
- else if (type == SCM_UVEC_S64)
- return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
-#else
- else if (type == SCM_UVEC_U64)
- return ((SCM *)base)[c_idx];
- else if (type == SCM_UVEC_S64)
- return ((SCM *)base)[c_idx];
-#endif
- else if (type == SCM_UVEC_F32)
- return scm_from_double (((float*)base)[c_idx]);
- else if (type == SCM_UVEC_F64)
- return scm_from_double (((double*)base)[c_idx]);
- else if (type == SCM_UVEC_C32)
- return scm_c_make_rectangular (((float*)base)[2*c_idx],
- ((float*)base)[2*c_idx+1]);
- else if (type == SCM_UVEC_C64)
- return scm_c_make_rectangular (((double*)base)[2*c_idx],
- ((double*)base)[2*c_idx+1]);
- else
- return SCM_BOOL_F;
-}
-
-#if SCM_HAVE_T_INT64 == 0
-static SCM scm_uint64_min, scm_uint64_max;
-static SCM scm_int64_min, scm_int64_max;
-
-static void
-assert_exact_integer_range (SCM val, SCM min, SCM max)
-{
- if (!scm_is_integer (val)
- || scm_is_false (scm_exact_p (val)))
- scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
- if (scm_is_true (scm_less_p (val, min))
- || scm_is_true (scm_gr_p (val, max)))
- scm_out_of_range (NULL, val);
-}
-#endif
-
-static SCM_C_INLINE_KEYWORD void
-uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
-{
- if (type == SCM_UVEC_U8)
- (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
- else if (type == SCM_UVEC_S8)
- (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
- else if (type == SCM_UVEC_U16)
- (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
- else if (type == SCM_UVEC_S16)
- (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
- else if (type == SCM_UVEC_U32)
- (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
- else if (type == SCM_UVEC_S32)
- (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
-#if SCM_HAVE_T_INT64
- else if (type == SCM_UVEC_U64)
- (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
- else if (type == SCM_UVEC_S64)
- (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
-#else
- else if (type == SCM_UVEC_U64)
- {
- assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max);
- ((SCM *)base)[c_idx] = val;
- }
- else if (type == SCM_UVEC_S64)
- {
- assert_exact_integer_range (val, scm_int64_min, scm_int64_max);
- ((SCM *)base)[c_idx] = val;
- }
-#endif
- else if (type == SCM_UVEC_F32)
- (((float*)base)[c_idx]) = scm_to_double (val);
- else if (type == SCM_UVEC_F64)
- (((double*)base)[c_idx]) = scm_to_double (val);
- else if (type == SCM_UVEC_C32)
- {
- (((float*)base)[2*c_idx]) = scm_c_real_part (val);
- (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
- }
- else if (type == SCM_UVEC_C64)
- {
- (((double*)base)[2*c_idx]) = scm_c_real_part (val);
- (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
- }
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-make_uvec (int type, SCM len, SCM fill)
-{
- size_t c_len = scm_to_size_t (len);
- SCM uvec = alloc_uvec (type, c_len);
- if (!SCM_UNBNDP (fill))
- {
- size_t idx;
- void *base = SCM_UVEC_BASE (uvec);
- for (idx = 0; idx < c_len; idx++)
- uvec_fast_set_x (type, base, idx, fill);
- }
- return uvec;
-}
-
-static SCM_C_INLINE_KEYWORD void *
-uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
- size_t *lenp, ssize_t *incp)
-{
- if (type >= 0)
- {
- SCM v = uvec;
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
- uvec_assert (type, v);
- }
-
- return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
-}
-
-static SCM_C_INLINE_KEYWORD const void *
-uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
- size_t *lenp, ssize_t *incp)
-{
- return uvec_writable_elements (type, uvec, handle, lenp, incp);
-}
-
-static int
-uvec_type (scm_t_array_handle *h)
-{
- SCM v = h->array;
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
- return SCM_UVEC_TYPE (v);
-}
-
-static SCM
-uvec_to_list (int type, SCM uvec)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t i, inc;
- const void *elts;
- SCM res = SCM_EOL;
-
- elts = uvec_elements (type, uvec, &handle, &len, &inc);
- for (i = len - 1; i >= 0; i--)
- res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
- scm_array_handle_release (&handle);
- return res;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_length (int type, SCM uvec)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t inc;
- uvec_elements (type, uvec, &handle, &len, &inc);
- scm_array_handle_release (&handle);
- return scm_from_size_t (len);
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_ref (int type, SCM uvec, SCM idx)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const void *elts;
- SCM res;
-
- elts = uvec_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
- i = scm_to_unsigned_integer (idx, 0, len-1);
- res = uvec_fast_ref (type, elts, i*inc);
- scm_array_handle_release (&handle);
- return res;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- void *elts;
-
- elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
- i = scm_to_unsigned_integer (idx, 0, len-1);
- uvec_fast_set_x (type, elts, i*inc, val);
- scm_array_handle_release (&handle);
- return SCM_UNSPECIFIED;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-list_to_uvec (int type, SCM list)
-{
- SCM uvec;
- void *base;
- long idx;
- long len = scm_ilength (list);
- if (len < 0)
- scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
-
- uvec = alloc_uvec (type, len);
- base = SCM_UVEC_BASE (uvec);
- idx = 0;
- while (scm_is_pair (list) && idx < len)
- {
- uvec_fast_set_x (type, base, idx, SCM_CAR (list));
- list = SCM_CDR (list);
- idx++;
- }
- return uvec;
-}
-
-SCM_SYMBOL (scm_sym_a, "a");
-SCM_SYMBOL (scm_sym_b, "b");
-
-SCM
-scm_i_generalized_vector_type (SCM v)
-{
- if (scm_is_vector (v))
- return SCM_BOOL_T;
- else if (scm_is_string (v))
- return scm_sym_a;
- else if (scm_is_bitvector (v))
- return scm_sym_b;
- else if (scm_is_uniform_vector (v))
- return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
- else if (scm_is_bytevector (v))
- return scm_from_locale_symbol ("vu8");
- else
- return SCM_BOOL_F;
-}
-
-SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Fill the elements of @var{uvec} by reading\n"
- "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
- "The optional arguments @var{start} (inclusive) and @var{end}\n"
- "(exclusive) allow a specified region to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be read, potentially blocking\n"
- "while waiting formore input or end-of-file.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "read(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially filled before reaching end-of-file or in\n"
- "the single call to read(2).\n\n"
- "@code{uniform-vector-read!} returns the number of elements\n"
- "read.\n\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults\n"
- "to the value returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_read_x
-{
- scm_t_array_handle handle;
- size_t vlen, sz, ans;
- ssize_t inc;
- size_t cstart, cend;
- size_t remaining, off;
- char *base;
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
- else
- SCM_ASSERT (scm_is_integer (port_or_fd)
- || (SCM_OPINPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
-
- if (!scm_is_uniform_vector (uvec))
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-
- base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
- sz = scm_array_handle_uniform_element_size (&handle);
-
- if (inc != 1)
- {
- /* XXX - we should of course support non contiguous vectors. */
- scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
- scm_list_1 (uvec));
- }
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- remaining = (cend - cstart) * sz;
- off = cstart * sz;
+
+#define ETYPE(TAG) \
+ SCM_ARRAY_ELEMENT_TYPE_##TAG
- if (SCM_NIMP (port_or_fd))
- {
- ans = cend - cstart;
- remaining -= scm_c_read (port_or_fd, base + off, remaining);
- if (remaining % sz != 0)
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- ans -= remaining / sz;
- }
- else /* file descriptor. */
- {
- int fd = scm_to_int (port_or_fd);
- int n;
-
- SCM_SYSCALL (n = read (fd, base + off, remaining));
- if (n == -1)
- SCM_SYSERROR;
- if (n % sz != 0)
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- ans = n / sz;
- }
+#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \
+ SCM scm_take_##tag##vector (ctype *data, size_t n) \
+ { \
+ return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \
+ } \
+ const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
+ { \
+ if (h->element_type != ETYPE (TAG)) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
+ return ((const ctype*) h->elements) + h->base*width; \
+ } \
+ ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
+ { \
+ if (h->element_type != ETYPE (TAG)) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
+ return ((ctype*) h->writable_elements) + h->base*width; \
+ } \
+ const ctype *scm_##tag##vector_elements (SCM uvec, \
+ scm_t_array_handle *h, \
+ size_t *lenp, ssize_t *incp) \
+ { \
+ return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
+ } \
+ ctype *scm_##tag##vector_writable_elements (SCM uvec, \
+ scm_t_array_handle *h, \
+ size_t *lenp, ssize_t *incp) \
+ { \
+ scm_uniform_vector_elements (uvec, h, lenp, incp); \
+ if (h->element_type == ETYPE (TAG)) \
+ return ((ctype*)h->writable_elements) + h->base*width; \
+ /* otherwise... */ \
+ else \
+ { \
+ size_t sfrom, sto, lfrom, lto; \
+ if (h->dims != &h->dim0) \
+ { \
+ h->dim0 = h->dims[0]; \
+ h->dims = &h->dim0; \
+ } \
+ sfrom = scm_i_array_element_type_sizes [h->element_type]; \
+ sto = scm_i_array_element_type_sizes [ETYPE (TAG)]; \
+ lfrom = h->dim0.ubnd - h->dim0.lbnd + 1; \
+ lto = lfrom * sfrom / sto; \
+ if (lto * sto != lfrom * sfrom) \
+ { \
+ scm_array_handle_release (h); \
+ scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
+ } \
+ h->dim0.ubnd = h->dim0.lbnd + lto; \
+ h->base = h->base * sto / sfrom; \
+ h->element_type = ETYPE (TAG); \
+ return ((ctype*)h->writable_elements) + h->base*width; \
+ } \
+ }
- scm_array_handle_release (&handle);
- return scm_from_size_t (ans);
-}
-#undef FUNC_NAME
+#define MOD "srfi srfi-4"
-SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Write the elements of @var{uvec} as raw bytes to\n"
- "@var{port-or-fdes}, in the host byte order.\n\n"
- "The optional arguments @var{start} (inclusive)\n"
- "and @var{end} (exclusive) allow\n"
- "a specified region to be written.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be written, potentially blocking\n"
- "while waiting for more room.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "write(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially written in the single call to write(2).\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_write
-{
- scm_t_array_handle handle;
- size_t vlen, sz, ans;
- ssize_t inc;
- size_t cstart, cend;
- size_t amount, off;
- const char *base;
-
- port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
- else
- SCM_ASSERT (scm_is_integer (port_or_fd)
- || (SCM_OPOUTPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
-
- base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
- sz = scm_array_handle_uniform_element_size (&handle);
-
- if (inc != 1)
- {
- /* XXX - we should of course support non contiguous vectors. */
- scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
- scm_list_1 (uvec));
- }
+DEFINE_SRFI_4_PROXIES (u8);
+DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1);
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
+DEFINE_SRFI_4_PROXIES (s8);
+DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1);
- amount = (cend - cstart) * sz;
- off = cstart * sz;
+DEFINE_SRFI_4_PROXIES (u16);
+DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1);
- if (SCM_NIMP (port_or_fd))
- {
- scm_lfwrite (base + off, amount, port_or_fd);
- ans = cend - cstart;
- }
- else /* file descriptor. */
- {
- int fd = scm_to_int (port_or_fd), n;
- SCM_SYSCALL (n = write (fd, base + off, amount));
- if (n == -1)
- SCM_SYSERROR;
- if (n % sz != 0)
- SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
- ans = n / sz;
- }
+DEFINE_SRFI_4_PROXIES (s16);
+DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1);
- scm_array_handle_release (&handle);
+DEFINE_SRFI_4_PROXIES (u32);
+DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1);
- return scm_from_size_t (ans);
-}
-#undef FUNC_NAME
+DEFINE_SRFI_4_PROXIES (s32);
+DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);
-/* ================================================================ */
-/* Exported procedures. */
-/* ================================================================ */
-
-#define TYPE SCM_UVEC_U8
-#define TAG u8
-#define CTYPE scm_t_uint8
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S8
-#define TAG s8
-#define CTYPE scm_t_int8
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U16
-#define TAG u16
-#define CTYPE scm_t_uint16
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S16
-#define TAG s16
-#define CTYPE scm_t_int16
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U32
-#define TAG u32
-#define CTYPE scm_t_uint32
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S32
-#define TAG s32
-#define CTYPE scm_t_int32
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U64
-#define TAG u64
-#if SCM_HAVE_T_UINT64
-#define CTYPE scm_t_uint64
+DEFINE_SRFI_4_PROXIES (u64);
+#if SCM_HAVE_T_INT64
+DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);
#endif
-#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_S64
-#define TAG s64
+DEFINE_SRFI_4_PROXIES (s64);
#if SCM_HAVE_T_INT64
-#define CTYPE scm_t_int64
+DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);
#endif
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_F32
-#define TAG f32
-#define CTYPE float
-#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_F64
-#define TAG f64
-#define CTYPE double
-#include "libguile/srfi-4.i.c"
+DEFINE_SRFI_4_PROXIES (f32);
+DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);
-#define TYPE SCM_UVEC_C32
-#define TAG c32
-#define CTYPE float
-#include "libguile/srfi-4.i.c"
+DEFINE_SRFI_4_PROXIES (f64);
+DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1);
-#define TYPE SCM_UVEC_C64
-#define TAG c64
-#define CTYPE double
-#include "libguile/srfi-4.i.c"
+#undef MOD
+#define MOD "srfi srfi-4 gnu"
-#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
- SCM cname (SCM arg1) \
- { \
- static SCM var = SCM_BOOL_F; \
- if (scm_is_false (var)) \
- var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
- return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
- }
+DEFINE_SRFI_4_PROXIES (c32);
+DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2);
-#define DEFPROXY100(cname, scmname) \
- DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+DEFINE_SRFI_4_PROXIES (c64);
+DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2);
#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
+#undef MOD
#define MOD "srfi srfi-4 gnu"
DEFINE_SRFI_4_GNU_PROXIES (u8);
DEFINE_SRFI_4_GNU_PROXIES (s8);
@@ -840,68 +230,67 @@ DEFINE_SRFI_4_GNU_PROXIES (c32);
DEFINE_SRFI_4_GNU_PROXIES (c64);
-static scm_i_t_array_ref uvec_reffers[12] = {
- u8ref, s8ref,
- u16ref, s16ref,
- u32ref, s32ref,
- u64ref, s64ref,
- f32ref, f64ref,
- c32ref, c64ref
-};
-
-static scm_i_t_array_set uvec_setters[12] = {
- u8set, s8set,
- u16set, s16set,
- u32set, s32set,
- u64set, s64set,
- f32set, f64set,
- c32set, c64set
-};
-
-static SCM
-uvec_handle_ref (scm_t_array_handle *h, size_t index)
-{
- return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index);
-}
-
-static void
-uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val)
+SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
+ (SCM type, SCM len, SCM fill),
+ "Make a srfi-4 vector")
+#define FUNC_NAME s_scm_make_srfi_4_vector
{
- uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
-}
-
-static void
-uvec_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8;
- h->elements = h->writable_elements = SCM_UVEC_BASE (v);
+ int i;
+ for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
+ if (scm_is_eq (type, scm_i_array_element_types[i]))
+ break;
+ if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
+ switch (i)
+ {
+ case SCM_ARRAY_ELEMENT_TYPE_U8:
+ case SCM_ARRAY_ELEMENT_TYPE_S8:
+ case SCM_ARRAY_ELEMENT_TYPE_U16:
+ case SCM_ARRAY_ELEMENT_TYPE_S16:
+ case SCM_ARRAY_ELEMENT_TYPE_U32:
+ case SCM_ARRAY_ELEMENT_TYPE_S32:
+ case SCM_ARRAY_ELEMENT_TYPE_U64:
+ case SCM_ARRAY_ELEMENT_TYPE_S64:
+ case SCM_ARRAY_ELEMENT_TYPE_F32:
+ case SCM_ARRAY_ELEMENT_TYPE_F64:
+ case SCM_ARRAY_ELEMENT_TYPE_C32:
+ case SCM_ARRAY_ELEMENT_TYPE_C64:
+ {
+ SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);
+
+ if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0))
+ ; /* pass */
+ else if (scm_is_true (scm_zero_p (fill)))
+ memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
+ SCM_BYTEVECTOR_LENGTH (ret));
+ else
+ {
+ scm_t_array_handle h;
+ size_t len;
+ ssize_t pos, inc;
+
+ scm_uniform_vector_writable_elements (ret, &h, &len, &inc);
+
+ for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
+ scm_array_handle_set (&h, pos, fill);
+
+ /* Initialize the last element. */
+ scm_array_handle_set (&h, pos, fill);
+
+ scm_array_handle_release (&h);
+ }
+ return ret;
+ }
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector
type");
+ return SCM_BOOL_F; /* not reached */
+ }
}
-
-SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec),
- SCM_SMOB_TYPE_MASK,
- uvec_handle_ref, uvec_handle_set,
- uvec_get_handle)
+#undef FUNC_NAME
void
scm_init_srfi_4 (void)
{
- scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
- scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
- scm_set_smob_print (scm_tc16_uvec, uvec_print);
-
-#if SCM_HAVE_T_INT64 == 0
- scm_uint64_min = scm_from_int (0);
- scm_uint64_max = scm_c_read_string ("18446744073709551615");
- scm_int64_min = scm_c_read_string ("-9223372036854775808");
- scm_int64_max = scm_c_read_string ("9223372036854775807");
-#endif
-
#define REGISTER(tag, TAG) \
scm_i_register_vector_constructor \
(scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
@@ -921,7 +310,6 @@ scm_init_srfi_4 (void)
REGISTER (c64, C64);
#include "libguile/srfi-4.x"
-
}
/* End of srfi-4.c. */
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index 48001ab..18b1cb1 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -23,6 +23,9 @@
#include "libguile/__scm.h"
+SCM_API SCM scm_make_srfi_4_vector (SCM type, SCM len, SCM fill);
+
+
/* Specific procedures.
*/
diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c
deleted file mode 100644
index 098752e..0000000
--- a/libguile/srfi-4.i.c
+++ /dev/null
@@ -1,207 +0,0 @@
-/* This file defines the procedures related to one type of uniform
- numeric vector. It is included multiple time in srfi-4.c, once for
- each type.
-
- Before inclusion, the following macros must be defined. They are
- undefined at the end of this file to get back to a clean slate for
- the next inclusion.
-
- - TYPE
-
- The type tag of the vector, for example SCM_UVEC_U8
-
- - TAG
-
- The tag name of the vector, for example u8. The tag is used to
- form the function names and is included in the docstrings, for
- example.
-
- - CTYPE
-
- The C type of the elements, for example scm_t_uint8. The code
- below will never do sizeof (CTYPE), thus you can use just 'float'
- for the c32 type, for example.
-
- When CTYPE is not defined, the functions using it are excluded.
-*/
-
-/* The first level does not expand macros in the arguments. */
-#define paste(a1,a2,a3) a1##a2##a3
-#define s_paste(a1,a2,a3) s_##a1##a2##a3
-#define stringify(a) #a
-
-/* But the second level does. */
-#define F(pre,T,suf) paste(pre,T,suf)
-#define s_F(pre,T,suf) s_paste(pre,T,suf)
-#define S(T) stringify(T)
-
-SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a vector of type " S(TAG) ",\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_F(scm_, TAG, vector_p)
-{
- return uvec_p (TYPE, obj);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
- (SCM len, SCM fill),
- "Return a newly allocated uniform numeric vector which can\n"
- "hold @var{len} elements. If @var{fill} is given, it is used to\n"
- "initialize the elements, otherwise the contents of the vector\n"
- "is unspecified.")
-#define FUNC_NAME s_S(scm_make_,TAG,vector)
-{
- return make_uvec (TYPE, len, fill);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
- (SCM l),
- "Return a newly allocated uniform numeric vector containing\n"
- "all argument values.")
-#define FUNC_NAME s_F(scm_,TAG,vector)
-{
- return list_to_uvec (TYPE, l);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
- (SCM uvec),
- "Return the number of elements in the uniform numeric vector\n"
- "@var{uvec}.")
-#define FUNC_NAME s_F(scm_,TAG,vector_length)
-{
- return uvec_length (TYPE, uvec);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
- (SCM uvec, SCM index),
- "Return the element at @var{index} in the uniform numeric\n"
- "vector @var{uvec}.")
-#define FUNC_NAME s_F(scm_,TAG,vector_ref)
-{
- return uvec_ref (TYPE, uvec, index);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
- (SCM uvec, SCM index, SCM value),
- "Set the element at @var{index} in the uniform numeric\n"
- "vector @var{uvec} to @var{value}. The return value is not\n"
- "specified.")
-#define FUNC_NAME s_F(scm_,TAG,vector_set_x)
-{
- return uvec_set_x (TYPE, uvec, index, value);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
- (SCM uvec),
- "Convert the uniform numeric vector @var{uvec} to a list.")
-#define FUNC_NAME s_F(scm_,TAG,vector_to_list)
-{
- return uvec_to_list (TYPE, uvec);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
- (SCM l),
- "Convert the list @var{l} to a numeric uniform vector.")
-#define FUNC_NAME s_F(scm_list_to_,TAG,vector)
-{
- return list_to_uvec (TYPE, l);
-}
-#undef FUNC_NAME
-
-#ifdef CTYPE
-
-SCM
-F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
-{
- /* The manual says "Return a new uniform numeric vector [...] that uses the
- memory pointed to by DATA". We *have* to use DATA as the underlying
- storage; thus we must register a finalizer to eventually free(3) it. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalization_data;
-
- GC_REGISTER_FINALIZER_NO_ORDER (data, free_user_data, 0,
- &prev_finalizer,
- &prev_finalization_data);
-
- return take_uvec (TYPE, data, n);
-}
-
-const CTYPE *
-F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
-{
- return F(scm_array_handle_,TAG,_writable_elements) (h);
-}
-
-CTYPE *
-F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- uvec_assert (TYPE, vec);
- if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
- return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
- else
- return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
-}
-
-const CTYPE *
-F(scm_,TAG,vector_elements) (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
-}
-
-CTYPE *
-F(scm_,TAG,vector_writable_elements) (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- scm_generalized_vector_get_handle (uvec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return F(scm_array_handle_,TAG,_writable_elements) (h);
-}
-
-#endif
-
-static SCM
-F(,TAG,ref) (scm_t_array_handle *handle, size_t pos)
-{
- return uvec_fast_ref (TYPE, handle->elements, pos);
-}
-
-static void
-F(,TAG,set) (scm_t_array_handle *handle, size_t pos, SCM val)
-{
- uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
-}
-
-#undef paste
-#undef s_paste
-#undef stringify
-#undef F
-#undef s_F
-#undef S
-
-#undef TYPE
-#undef TAG
-#undef CTYPE
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
index ed14906..68dec76 100644
--- a/libguile/stackchk.h
+++ b/libguile/stackchk.h
@@ -3,7 +3,7 @@
#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H
-/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -37,12 +37,10 @@
#if defined BUILDING_LIBGUILE && defined STACK_CHECKING
# if SCM_STACK_GROWS_UP
# define SCM_STACK_OVERFLOW_P(s)\
- (SCM_STACK_PTR (s) \
- > (SCM_I_CURRENT_THREAD->base + SCM_STACK_LIMIT))
+ ((SCM_STACK_PTR (s) - SCM_I_CURRENT_THREAD->base) > SCM_STACK_LIMIT)
# else
# define SCM_STACK_OVERFLOW_P(s)\
- (SCM_STACK_PTR (s) \
- < (SCM_I_CURRENT_THREAD->base - SCM_STACK_LIMIT))
+ ((SCM_I_CURRENT_THREAD->base - SCM_STACK_PTR (s)) > SCM_STACK_LIMIT)
# endif
# define SCM_CHECK_STACK\
{\
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 61b7be3..a7ebda0 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 Free Software
Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010 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
@@ -24,6 +24,7 @@
#endif
#include "libguile/_scm.h"
+#include "libguile/control.h"
#include "libguile/eval.h"
#include "libguile/debug.h"
#include "libguile/continuations.h"
@@ -41,6 +42,8 @@
#include "libguile/private-options.h"
+static SCM scm_sys_stacks;
+
/* {Stacks}
*
@@ -59,17 +62,14 @@
-static SCM stack_id_with_fp (SCM frame, SCM **fp);
-
/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (SCM frame, SCM *fp)
+stack_depth (SCM frame)
{
- long n;
+ long n = 0;
/* count frames, skipping boot frames */
- for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
- frame = scm_frame_previous (frame))
+ for (; scm_is_true (frame); frame = scm_frame_previous (frame))
++n;
return n;
}
@@ -95,6 +95,21 @@ stack_depth (SCM frame, SCM *fp)
* encountered.
*/
+static SCM
+find_prompt (SCM key)
+{
+ SCM winds;
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
+ {
+ SCM elt = scm_car (winds);
+ if (SCM_PROMPT_P (elt) && SCM_PROMPT_TAG (elt) == key)
+ return elt;
+ }
+ scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
+ scm_list_1 (key));
+ return SCM_BOOL_F; /* not reached */
+}
+
static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
@@ -105,25 +120,35 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long
outer, SCM outer_key)
frame = SCM_STACK_FRAME (stack);
/* Cut inner part. */
- if (scm_is_eq (inner_key, SCM_BOOL_T))
+ if (scm_is_true (scm_procedure_p (inner_key)))
{
- /* Cut specified number of frames. */
- for (; inner && len; --inner)
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
{
+ SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_frame_previous (frame);
+ if (scm_is_eq (proc, inner_key))
+ break;
}
}
+ else if (scm_is_symbol (inner_key))
+ {
+ /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+ symbols. */
+ SCM prompt = find_prompt (inner_key);
+ for (; len; len--, frame = scm_frame_previous (frame))
+ if (SCM_PROMPT_REGISTERS (prompt)->fp
+ == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ break;
+ }
else
{
- /* Cut until the given procedure is seen. */
- for (; inner && len ; --inner)
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
{
- SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_frame_previous (frame);
- if (scm_is_eq (proc, inner_key))
- break;
}
}
@@ -131,12 +156,39 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long
outer, SCM outer_key)
SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */
- for (; outer && len ; --outer)
+ if (scm_is_true (scm_procedure_p (outer_key)))
+ {
+ /* Cut until the given procedure is seen. */
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+ break;
+ }
+ }
+ else if (scm_is_symbol (outer_key))
+ {
+ /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+ symbols. */
+ SCM prompt = find_prompt (outer_key);
+ while (len)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (SCM_PROMPT_REGISTERS (prompt)->fp
+ == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ break;
+ }
+ }
+ else
{
- frame = scm_stack_ref (stack, scm_from_long (len - 1));
- len--;
- if (scm_is_eq (scm_frame_procedure (frame), outer_key))
- break;
+ /* Cut specified number of frames. */
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ }
}
SCM_SET_STACK_LENGTH (stack, len);
@@ -163,24 +215,33 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"Create a new stack. If @var{obj} is @code{#t}, the current\n"
"evaluation stack is used for creating the stack frames,\n"
"otherwise the frames are taken from @var{obj} (which must be\n"
- "either a debug object or a continuation).\n\n"
+ "a continuation or a frame object).\n"
+ "\n"
"@var{args} should be a list containing any combination of\n"
- "integer, procedure and @code{#t} values.\n\n"
+ "integer, procedure, prompt tag and @code{#t} values.\n"
+ "\n"
"These values specify various ways of cutting away uninteresting\n"
"stack frames from the top and bottom of the stack that\n"
"@code{make-stack} returns. They come in pairs like this:\n"
"@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
- "@var{outer_cut_2} @dots{})}.\n\n"
- "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
- "procedure. @code{#t} means to cut away all frames up to but\n"
- "excluding the first user module frame. An integer means to cut\n"
- "away exactly that number of frames. A procedure means to cut\n"
- "away all frames up to but excluding the application frame whose\n"
- "procedure matches the specified one.\n\n"
- "Each @var{outer_cut_N} can be an integer or a procedure. An\n"
- "integer means to cut away that number of frames. A procedure\n"
- "means to cut away frames down to but excluding the application\n"
- "frame whose procedure matches the specified one.\n\n"
+ "@var{outer_cut_2} @dots{})}.\n"
+ "\n"
+ "Each @var{inner_cut_N} can be @code{#t}, an integer, a prompt\n"
+ "tag, or a procedure. @code{#t} means to cut away all frames up\n"
+ "to but excluding the first user module frame. An integer means\n"
+ "to cut away exactly that number of frames. A prompt tag means\n"
+ "to cut away all frames that are inside a prompt with the given\n"
+ "tag. A procedure means to cut away all frames up to but\n"
+ "excluding the application frame whose procedure matches the\n"
+ "specified one.\n"
+ "\n"
+ "Each @var{outer_cut_N} can be an integer, a prompt tag, or a\n"
+ "procedure. An integer means to cut away that number of frames.\n"
+ "A prompt tag means to cut away all frames that are outside a\n"
+ "prompt with the given tag. A procedure means to cut away\n"
+ "frames down to but excluding the application frame whose\n"
+ "procedure matches the specified one.\n"
+ "\n"
"If the @var{outer_cut_N} of the last pair is missing, it is\n"
"taken as 0.")
#define FUNC_NAME s_scm_make_stack
@@ -189,7 +250,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
int maxp;
SCM frame;
SCM stack;
- SCM id, *id_fp;
SCM inner_cut, outer_cut;
/* Extract a pointer to the innermost frame of whatever object
@@ -199,31 +259,19 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
SCM cont;
struct scm_vm_cont *c;
- cont = scm_cdar (scm_vm_capture_continuations ());
+ cont = scm_i_vm_capture_continuation (scm_the_vm ());
c = SCM_VM_CONT_DATA (cont);
frame = scm_c_make_frame (cont, c->fp + c->reloc,
- c->sp + c->reloc, c->ip,
+ c->sp + c->reloc, c->ra,
c->reloc);
}
else if (SCM_VM_FRAME_P (obj))
frame = obj;
else if (SCM_CONTINUATIONP (obj))
- {
- scm_t_contregs *cont = SCM_CONTREGS (obj);
- if (!scm_is_null (cont->vm_conts))
- { SCM vm_cont;
- struct scm_vm_cont *data;
- vm_cont = scm_cdr (scm_car (cont->vm_conts));
- data = SCM_VM_CONT_DATA (vm_cont);
- frame = scm_c_make_frame (vm_cont,
- data->fp + data->reloc,
- data->sp + data->reloc,
- data->ip,
- data->reloc);
- } else
- frame = SCM_BOOL_F;
- }
+ /* FIXME: Narrowing to prompt tags should narrow with respect to the
prompts
+ that were in place when the continuation was captured. */
+ frame = scm_i_continuation_to_frame (obj);
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
@@ -238,20 +286,16 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
if (scm_is_false (frame))
return SCM_BOOL_F;
- /* Get ID of the stack corresponding to the given frame. */
- id = stack_id_with_fp (frame, &id_fp);
-
/* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
- id = SCM_BOOL_F;
maxp = 0;
- n = stack_depth (frame, id_fp);
+ n = stack_depth (frame);
/* Make the stack object. */
stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
SCM_SET_STACK_LENGTH (stack, n);
- SCM_SET_STACK_ID (stack, id);
+ SCM_SET_STACK_ID (stack, scm_stack_id (obj));
SCM_SET_STACK_FRAME (stack, frame);
/* Narrow the stack according to the arguments given to scm_make_stack. */
@@ -272,9 +316,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
narrow_stack (stack,
scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
- scm_is_integer (inner_cut) ? 0 : inner_cut,
+ scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
- scm_is_integer (outer_cut) ? 0 : outer_cut);
+ scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
n = SCM_STACK_LENGTH (stack);
}
@@ -291,58 +335,26 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
"Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id
{
- SCM frame, *id_fp;
-
- if (scm_is_eq (stack, SCM_BOOL_T))
+ if (scm_is_eq (stack, SCM_BOOL_T)
+ /* FIXME: frame case assumes frame still live on the stack, and no
+ intervening start-stack. Hmm... */
+ || SCM_VM_FRAME_P (stack))
{
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
+ /* Fetch most recent start-stack tag. */
+ SCM stacks = scm_fluid_ref (scm_sys_stacks);
+ return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
}
- else if (SCM_VM_FRAME_P (stack))
- frame = stack;
else if (SCM_CONTINUATIONP (stack))
- {
- scm_t_contregs *cont = SCM_CONTREGS (stack);
- if (!scm_is_null (cont->vm_conts))
- { SCM vm_cont;
- struct scm_vm_cont *data;
- vm_cont = scm_cdr (scm_car (cont->vm_conts));
- data = SCM_VM_CONT_DATA (vm_cont);
- frame = scm_c_make_frame (vm_cont,
- data->fp + data->reloc,
- data->sp + data->reloc,
- data->ip,
- data->reloc);
- } else
- frame = SCM_BOOL_F;
- }
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
/* not reached */
}
-
- return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME
-static SCM
-stack_id_with_fp (SCM frame, SCM **fp)
-{
- SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
-
- if (SCM_VM_CONT_P (holder))
- {
- *fp = NULL;
- return SCM_BOOL_F;
- }
- else
- {
- *fp = NULL;
- return SCM_BOOL_F;
- }
-}
-
SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
(SCM stack, SCM index),
"Return the @var{index}'th frame from @var{stack}.")
@@ -375,6 +387,9 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
void
scm_init_stacks ()
{
+ scm_sys_stacks = scm_make_fluid ();
+ scm_c_define ("%stacks", scm_sys_stacks);
+
scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
SCM_UNDEFINED);
scm_set_struct_vtable_name_x (scm_stack_type,
diff --git a/libguile/strings.c b/libguile/strings.c
index 711da9c..d136d98 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010 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
@@ -25,6 +25,7 @@
#include <string.h>
#include <stdio.h>
#include <ctype.h>
+#include <uninorm.h>
#include <unistr.h>
#include <uniconv.h>
@@ -34,9 +35,11 @@
#include "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/error.h"
#include "libguile/generalized-vectors.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
+#include "libguile/private-options.h"
@@ -1385,6 +1388,28 @@ scm_is_string (SCM obj)
return IS_STRING (obj);
}
+
+/* Conversion to/from other encodings. */
+
+SCM_SYMBOL (scm_encoding_error_key, "encoding-error");
+static void
+scm_encoding_error (const char *subr, int err, const char *message,
+ const char *from, const char *to, SCM string_or_bv)
+{
+ /* Raise an exception that conveys all the information needed to debug the
+ problem. Only perform locale conversions that are safe; in particular,
+ don't try to display STRING_OR_BV when it's a string since converting it
to
+ the output locale may fail. */
+ scm_throw (scm_encoding_error_key,
+ scm_list_n (scm_from_locale_string (subr),
+ scm_from_locale_string (message),
+ scm_from_int (err),
+ scm_from_locale_string (from),
+ scm_from_locale_string (to),
+ string_or_bv,
+ SCM_UNDEFINED));
+}
+
SCM
scm_from_stringn (const char *str, size_t len, const char *encoding,
scm_t_string_failed_conversion_handler handler)
@@ -1414,22 +1439,20 @@ scm_from_stringn (const char *str, size_t len, const
char *encoding,
NULL,
NULL, &u32len);
- if (u32 == NULL)
+ if (SCM_UNLIKELY (u32 == NULL))
{
- if (errno == ENOMEM)
- scm_memory_error ("locale string conversion");
- else
- {
- /* There are invalid sequences in the input string. */
- SCM errstr;
- char *dst;
- errstr = scm_i_make_string (len, &dst);
- memcpy (dst, str, len);
- scm_misc_error (NULL, "input locale conversion error from ~s: ~s",
- scm_list_2 (scm_from_locale_string (encoding),
- errstr));
- scm_remember_upto_here_1 (errstr);
- }
+ /* Raise an error and pass the raw C string as a bytevector to the
`throw'
+ handler. */
+ SCM bv;
+ signed char *buf;
+
+ buf = scm_gc_malloc_pointerless (len, "bytevector");
+ memcpy (buf, str, len);
+ bv = scm_c_take_bytevector (buf, len);
+
+ scm_encoding_error (__func__, errno,
+ "input locale conversion error",
+ encoding, "UTF-32", bv);
}
i = 0;
@@ -1583,6 +1606,80 @@ unistring_escapes_to_guile_escapes (char **bufp, size_t
*lenp)
after = scm_realloc (after, j);
}
+/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXXXX; */
+static void
+unistring_escapes_to_r6rs_escapes (char **bufp, size_t *lenp)
+{
+ char *before, *after;
+ size_t i, j;
+ /* The worst case is if the input string contains all 4-digit hex escapes.
+ "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */
+ size_t max_out_len = (*lenp * 7) / 6 + 1;
+ size_t nzeros, ndigits;
+
+ before = *bufp;
+ after = alloca (max_out_len);
+ i = 0;
+ j = 0;
+ while (i < *lenp)
+ {
+ if (((i <= *lenp - 6) && before[i] == '\\' && before[i + 1] == 'u')
+ || ((i <= *lenp - 10) && before[i] == '\\' && before[i + 1] == 'U'))
+ {
+ if (before[i + 1] == 'u')
+ ndigits = 4;
+ else if (before[i + 1] == 'U')
+ ndigits = 8;
+ else
+ abort ();
+
+ /* Add the R6RS hex escape initial sequence. */
+ after[j] = '\\';
+ after[j + 1] = 'x';
+
+ /* Move string positions to the start of the hex numbers. */
+ i += 2;
+ j += 2;
+
+ /* Find the number of initial zeros in this hex number. */
+ nzeros = 0;
+ while (before[i + nzeros] == '0' && nzeros < ndigits)
+ nzeros++;
+
+ /* Copy the number, skipping initial zeros, and then move the string
+ positions. */
+ if (nzeros == ndigits)
+ {
+ after[j] = '0';
+ i += ndigits;
+ j += 1;
+ }
+ else
+ {
+ int pos;
+ for (pos = 0; pos < ndigits - nzeros; pos++)
+ after[j + pos] = tolower ((int) before[i + nzeros + pos]);
+ i += ndigits;
+ j += (ndigits - nzeros);
+ }
+
+ /* Add terminating semicolon. */
+ after[j] = ';';
+ j++;
+ }
+ else
+ {
+ after[j] = before[i];
+ i++;
+ j++;
+ }
+ }
+ *lenp = j;
+ before = scm_realloc (before, j);
+ memcpy (before, after, j);
+}
+
+
char *
scm_to_locale_stringn (SCM str, size_t *lenp)
{
@@ -1604,7 +1701,10 @@ scm_to_locale_stringn (SCM str, size_t *lenp)
scm_i_get_conversion_strategy (SCM_BOOL_F));
}
-/* Low-level scheme to C string conversion function. */
+/* Return a malloc(3)-allocated buffer containing the contents of STR encoded
+ according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
+ the returned buffer. If the conversion to ENCODING fails, apply the
strategy
+ defined by HANDLER. */
char *
scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
scm_t_string_failed_conversion_handler handler)
@@ -1667,31 +1767,29 @@ scm_to_stringn (SCM str, size_t *lenp, const char
*encoding,
(enum iconv_ilseq_handler) handler, NULL,
&buf, &len);
- if (ret == 0 && handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
- unistring_escapes_to_guile_escapes (&buf, &len);
-
if (ret != 0)
- {
- scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
- scm_list_2 (scm_from_locale_string (enc),
- str));
- }
+ scm_encoding_error (__func__, errno,
+ "cannot convert to output locale",
+ "ISO-8859-1", enc, str);
}
else
{
- buf = u32_conv_to_encoding (enc,
+ buf = u32_conv_to_encoding (enc,
(enum iconv_ilseq_handler) handler,
- (scm_t_uint32 *) scm_i_string_wide_chars
(str),
+ (scm_t_uint32 *) scm_i_string_wide_chars
(str),
ilen,
NULL,
NULL, &len);
if (buf == NULL)
- {
- scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
- scm_list_2 (scm_from_locale_string (enc),
- str));
- }
- if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ scm_encoding_error (__func__, errno,
+ "cannot convert to output locale",
+ "UTF-32", enc, str);
+ }
+ if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ {
+ if (SCM_R6RS_ESCAPES_P)
+ unistring_escapes_to_r6rs_escapes (&buf, &len);
+ else
unistring_escapes_to_guile_escapes (&buf, &len);
}
if (lenp)
@@ -1736,6 +1834,86 @@ scm_to_locale_stringbuf (SCM str, char *buf, size_t
max_len)
return len;
}
+
+/* Unicode string normalization. */
+
+/* This function is a partial clone of SCM_STRING_TO_U32_BUF from
+ libguile/i18n.c. It would be useful to have this factored out into a more
+ convenient location, but its use of alloca makes that tricky to do. */
+
+static SCM
+normalize_str (SCM string, uninorm_t form)
+{
+ SCM ret;
+ scm_t_uint32 *w_str;
+ scm_t_wchar *cbuf;
+ size_t rlen, len = scm_i_string_length (string);
+
+ if (scm_i_is_narrow_string (string))
+ {
+ size_t i;
+ const char *buf = scm_i_string_chars (string);
+
+ w_str = alloca (sizeof (scm_t_wchar) * (len + 1));
+
+ for (i = 0; i < len; i ++)
+ w_str[i] = (unsigned char) buf[i];
+ w_str[len] = 0;
+ }
+ else
+ w_str = (scm_t_uint32 *) scm_i_string_wide_chars (string);
+
+ w_str = u32_normalize (form, w_str, len, NULL, &rlen);
+
+ ret = scm_i_make_wide_string (rlen, &cbuf);
+ u32_cpy ((scm_t_uint32 *) cbuf, w_str, rlen);
+ free (w_str);
+
+ scm_i_try_narrow_string (ret);
+
+ return ret;
+}
+
+SCM_DEFINE (scm_string_normalize_nfc, "string-normalize-nfc", 1, 0, 0,
+ (SCM string),
+ "Returns the NFC normalized form of @var{string}.")
+#define FUNC_NAME s_scm_string_normalize_nfc
+{
+ SCM_VALIDATE_STRING (1, string);
+ return normalize_str (string, UNINORM_NFC);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_normalize_nfd, "string-normalize-nfd", 1, 0, 0,
+ (SCM string),
+ "Returns the NFD normalized form of @var{string}.")
+#define FUNC_NAME s_scm_string_normalize_nfd
+{
+ SCM_VALIDATE_STRING (1, string);
+ return normalize_str (string, UNINORM_NFD);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_normalize_nfkc, "string-normalize-nfkc", 1, 0, 0,
+ (SCM string),
+ "Returns the NFKC normalized form of @var{string}.")
+#define FUNC_NAME s_scm_string_normalize_nfkc
+{
+ SCM_VALIDATE_STRING (1, string);
+ return normalize_str (string, UNINORM_NFKC);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_normalize_nfkd, "string-normalize-nfkd", 1, 0, 0,
+ (SCM string),
+ "Returns the NFKD normalized form of @var{string}.")
+#define FUNC_NAME s_scm_string_normalize_nfkd
+{
+ SCM_VALIDATE_STRING (1, string);
+ return normalize_str (string, UNINORM_NFKD);
+}
+#undef FUNC_NAME
+
/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
SCM
@@ -1891,7 +2069,7 @@ string_get_handle (SCM v, scm_t_array_handle *h)
h->elements = h->writable_elements = NULL;
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2,
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f,
string_handle_ref, string_handle_set,
string_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
diff --git a/libguile/strings.h b/libguile/strings.h
index edff0f8..6eafafa 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -142,6 +142,11 @@ SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp,
SCM_INTERNAL scm_t_uint8 *scm_i_to_utf8_string (SCM str);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
+SCM_API SCM scm_string_normalize_nfd (SCM str);
+SCM_API SCM scm_string_normalize_nfkd (SCM str);
+SCM_API SCM scm_string_normalize_nfc (SCM str);
+SCM_API SCM scm_string_normalize_nfkc (SCM str);
+
SCM_API SCM scm_makfromstrs (int argc, char **argv);
diff --git a/libguile/strorder.c b/libguile/strorder.c
index 0338c65..a51ce17 100644
--- a/libguile/strorder.c
+++ b/libguile/strorder.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -42,6 +42,7 @@ srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM,
SCM, SCM))
return SCM_BOOL_F;
}
+static SCM scm_i_string_equal_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic equality predicate; return @code{#t} if the two\n"
@@ -75,6 +76,7 @@ SCM scm_string_equal_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_equal_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case-insensitive string equality predicate; return @code{#t} if\n"
@@ -104,6 +106,7 @@ SCM scm_string_ci_equal_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_less_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -131,6 +134,7 @@ SCM scm_string_less_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_leq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -158,6 +162,7 @@ SCM scm_string_leq_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_gr_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -185,6 +190,7 @@ SCM scm_string_gr_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_geq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -212,6 +218,7 @@ SCM scm_string_geq_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_less_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
@@ -240,6 +247,7 @@ SCM scm_string_ci_less_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_leq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
@@ -268,6 +276,7 @@ SCM scm_string_ci_leq_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_gr_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
@@ -296,6 +305,7 @@ SCM scm_string_ci_gr_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_geq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
diff --git a/libguile/strports.c b/libguile/strports.c
index 95e93c9..625b753 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009,
2010 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
@@ -289,84 +289,60 @@ st_truncate (SCM port, scm_t_off length)
pt->write_pos = pt->read_end;
}
-SCM
-scm_i_mkstrport (SCM pos, const char *utf8_str, size_t str_len, long modes,
const char *caller)
+SCM
+scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
- SCM z, str;
+ SCM z;
scm_t_port *pt;
- size_t c_pos;
- char *buf;
-
- /* Because ports are inherently 8-bit, strings need to be converted
- to a locale representation for storage. But, since string ports
- rely on string functionality for their memory management, we need
- to create a new string that has the 8-bit locale representation
- of the underlying string.
+ size_t str_len, c_pos;
+ char *buf, *c_str;
- locale_str is already in the locale of the port. */
- str = scm_i_make_string (str_len, &buf);
- memcpy (buf, utf8_str, str_len);
-
- c_pos = scm_to_unsigned_integer (pos, 0, str_len);
+ SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
+ c_pos = scm_to_unsigned_integer (pos, 0, scm_i_string_length (str));
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ scm_dynwind_begin (0);
+ 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_SETSTREAM (z, SCM_UNPACK (str));
- SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes);
- pt->write_buf = pt->read_buf = (unsigned char *) scm_i_string_chars (str);
+ SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
+
+ /* Create a copy of STR in the encoding of Z. */
+ buf = scm_to_stringn (str, &str_len, pt->encoding,
+ SCM_FAILED_CONVERSION_ERROR);
+ c_str = scm_gc_malloc (str_len, "strport");
+ memcpy (c_str, buf, str_len);
+ free (buf);
+
+ pt->write_buf = pt->read_buf = (unsigned char *) c_str;
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
pt->write_buf_size = pt->read_buf_size = str_len;
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
pt->rw_random = 1;
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
- /* ensure write_pos is writable. */
+ scm_dynwind_end ();
+
+ /* Ensure WRITE_POS is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
st_flush (z);
- scm_i_set_port_encoding_x (z, "UTF-8");
scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
return z;
}
-SCM
-scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
-{
- SCM z;
- size_t str_len;
- char *buf;
-
- SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
-
- /* Because ports are inherently 8-bit, strings need to be converted
- to a locale representation for storage. But, since string ports
- rely on string functionality for their memory management, we need
- to create a new string that has the 8-bit locale representation
- of the underlying string. This violates the guideline that the
- internal encoding of characters in strings is in unicode
- codepoints. */
-
- /* String ports are are always initialized with "UTF-8" as their
- encoding. */
- buf = scm_to_stringn (str, &str_len, "UTF-8", SCM_FAILED_CONVERSION_ERROR);
- z = scm_i_mkstrport (pos, buf, str_len, modes, caller);
- free (buf);
- return z;
-}
-
-/* Create a new string from a string port's buffer, converting from
- the port's 8-bit locale-specific representation to the standard
- string representation. */
-SCM scm_strport_to_string (SCM port)
+/* Create a new string from the buffer of PORT, a string port, converting from
+ PORT's encoding to the standard string representation. */
+SCM
+scm_strport_to_string (SCM port)
{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
-
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
if (pt->rw_active == SCM_PORT_WRITE)
st_flush (port);
diff --git a/libguile/strports.h b/libguile/strports.h
index d93266a..3a9c3ec 100644
--- a/libguile/strports.h
+++ b/libguile/strports.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRPORTS_H
#define SCM_STRPORTS_H
-/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008, 2010 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
@@ -44,8 +44,6 @@ SCM_API scm_t_bits scm_tc16_strport;
SCM_API SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller);
-SCM_INTERNAL SCM scm_i_mkstrport (SCM pos, const char *locale_str, size_t
str_len,
- long modes, const char *caller);
SCM_API SCM scm_strport_to_string (SCM port);
SCM_API SCM scm_object_to_string (SCM obj, SCM printer);
SCM_API SCM scm_call_with_output_string (SCM proc);
diff --git a/libguile/struct.c b/libguile/struct.c
index 321f2f1..c28a76d 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 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008,
2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,6 +22,7 @@
#endif
#include <alloca.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
@@ -151,7 +152,59 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout",
1, 0, 0,
#undef FUNC_NAME
+/* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
+ or only "pw" fields) and update its flags accordingly. */
+static void
+set_vtable_layout_flags (SCM vtable)
+{
+ size_t len, field;
+ SCM layout;
+ const char *c_layout;
+ scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE;
+
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ c_layout = scm_i_symbol_chars (layout);
+ len = scm_i_symbol_length (layout);
+
+ assert (len % 2 == 0);
+
+ /* Update FLAGS according to LAYOUT. */
+ for (field = 0;
+ field < len && flags & SCM_VTABLE_FLAG_SIMPLE;
+ field += 2)
+ {
+ if (c_layout[field] != 'p')
+ flags = 0;
+ else
+ switch (c_layout[field + 1])
+ {
+ case 'w':
+ case 'W':
+ if (field == 0)
+ flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
+ break;
+
+ case 'r':
+ case 'R':
+ flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
+ break;
+
+ default:
+ flags = 0;
+ }
+ }
+
+ if (flags & SCM_VTABLE_FLAG_SIMPLE)
+ {
+ /* VTABLE is simple so update its flags and record the size of its
+ instances. */
+ SCM_SET_VTABLE_FLAGS (vtable, flags);
+ SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2);
+ }
+}
+/* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
+ vtable-vtable and OBJ is an instance of VTABLE. */
void
scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
#define FUNC_NAME "%inherit-vtable-magic"
@@ -162,17 +215,18 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
Both of these questions also imply a certain layout of the structure. So
instead of checking the layout at runtime, what we do is pre-verify the
layout -- so that at runtime we can just check the applicable flag and
- dispatch directly to the Scheme procedure in slot 0.
- */
+ dispatch directly to the Scheme procedure in slot 0. */
SCM olayout;
- /* verify that obj is a valid vtable */
+ /* Verify that OBJ is a valid vtable. */
if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
- /* if obj's vtable is compatible with the required vtable (class) layout, it
- is a metaclass */
+ set_vtable_layout_flags (obj);
+
+ /* If OBJ's vtable is compatible with the required vtable (class) layout, it
+ is a metaclass. */
olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
scm_string_length (olayout)))
@@ -183,8 +237,8 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
scm_string_length
(required_vtable_fields))))
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
- /* finally if obj is an applicable class, verify that its vtable is
- compatible with the required applicable layout */
+ /* Finally, if OBJ is an applicable class, verify that its vtable is
+ compatible with the required applicable layout. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
{
if (scm_is_false (scm_string_eq (olayout,
required_applicable_with_setter_fields,
@@ -215,60 +269,74 @@ static void
scm_struct_init (SCM handle, SCM layout, size_t n_tail,
size_t n_inits, scm_t_bits *inits)
{
- scm_t_wchar prot = 0;
- int n_fields = scm_i_symbol_length (layout) / 2;
- int tailp = 0;
- int i;
- size_t inits_idx = 0;
- scm_t_bits *mem = SCM_STRUCT_DATA (handle);
-
- i = -2;
- while (n_fields)
+ SCM vtable;
+ scm_t_bits *mem;
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ mem = SCM_STRUCT_DATA (handle);
+
+ if (SCM_UNPACK (vtable) != 0
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && n_tail == 0
+ && n_inits == SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size))
+ /* The fast path: HANDLE has N_INITS "p" fields. */
+ memcpy (mem, inits, n_inits * sizeof (SCM));
+ else
{
- if (!tailp)
+ scm_t_wchar prot = 0;
+ int n_fields = scm_i_symbol_length (layout) / 2;
+ int tailp = 0;
+ int i;
+ size_t inits_idx = 0;
+
+ i = -2;
+ while (n_fields)
{
- i += 2;
- prot = scm_i_symbol_ref (layout, i+1);
- if (SCM_LAYOUT_TAILP (prot))
+ if (!tailp)
{
- tailp = 1;
- prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = (scm_t_bits)n_tail;
- n_fields += n_tail - 1;
- if (n_fields == 0)
- break;
+ i += 2;
+ prot = scm_i_symbol_ref (layout, i+1);
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
+ if (n_fields == 0)
+ break;
+ }
}
- }
- switch (scm_i_symbol_ref (layout, i))
- {
- case 'u':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
- *mem = 0;
- else
+ switch (scm_i_symbol_ref (layout, i))
{
- *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
- inits_idx++;
+ case 'u':
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ *mem = 0;
+ else
+ {
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
+ }
+ break;
+
+ case 'p':
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ *mem = SCM_UNPACK (SCM_BOOL_F);
+ else
+ {
+ *mem = inits[inits_idx];
+ inits_idx++;
+ }
+
+ break;
+
+ case 's':
+ *mem = SCM_UNPACK (handle);
+ break;
}
- break;
- case 'p':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
- *mem = SCM_UNPACK (SCM_BOOL_F);
- else
- {
- *mem = inits[inits_idx];
- inits_idx++;
- }
-
- break;
-
- case 's':
- *mem = SCM_UNPACK (handle);
- break;
+ n_fields--;
+ mem++;
}
-
- n_fields--;
- mem++;
}
}
@@ -504,11 +572,8 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
"@end lisp")
#define FUNC_NAME s_scm_make_vtable_vtable
{
- SCM fields;
- SCM layout;
- size_t basic_size;
- size_t n_tail, i, n_init;
- SCM obj;
+ SCM fields, layout, obj;
+ size_t basic_size, n_tail, i, n_init;
long ilen;
scm_t_bits *v;
@@ -539,11 +604,13 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
SCM_CRITICAL_SECTION_START;
obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
- /* magic magic magic */
- SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
+ /* Make it so that the vtable of OBJ is itself. */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
+
scm_struct_init (obj, layout, n_tail, n_init, v);
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+
return obj;
}
#undef FUNC_NAME
@@ -627,71 +694,79 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
"integer value small enough to fit in one machine word.")
#define FUNC_NAME s_scm_struct_ref
{
- SCM answer = SCM_UNDEFINED;
- scm_t_bits * data;
- SCM layout;
- size_t layout_len;
+ SCM vtable, answer = SCM_UNDEFINED;
+ scm_t_bits *data;
size_t p;
- scm_t_bits n_fields;
- scm_t_wchar field_type = 0;
-
SCM_VALIDATE_STRUCT (1, handle);
- layout = SCM_STRUCT_LAYOUT (handle);
+ vtable = SCM_STRUCT_VTABLE (handle);
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
-
- SCM_ASSERT_RANGE(1, pos, p < n_fields);
-
- if (p * 2 < layout_len)
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
+ /* The fast path: HANDLE is a struct with only "p" fields. */
+ answer = SCM_PACK (data[p]);
+ else
{
- scm_t_wchar ref;
- field_type = scm_i_symbol_ref (layout, p * 2);
- ref = scm_i_symbol_ref (layout, p * 2 + 1);
- if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
+ SCM layout;
+ size_t layout_len, n_fields;
+ scm_t_wchar field_type = 0;
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
+
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
{
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+ scm_t_wchar ref;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ ref = scm_i_symbol_ref (layout, p * 2 + 1);
+ if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+ }
}
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
- field_type = scm_i_symbol_ref(layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
- {
- case 'u':
- answer = scm_from_ulong (data[p]);
- break;
+ else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
+ field_type = scm_i_symbol_ref(layout, layout_len - 2);
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+
+ switch (field_type)
+ {
+ case 'u':
+ answer = scm_from_ulong (data[p]);
+ break;
#if 0
- case 'i':
- answer = scm_from_long (data[p]);
- break;
+ case 'i':
+ answer = scm_from_long (data[p]);
+ break;
- case 'd':
- answer = scm_make_real (*((double *)&(data[p])));
- break;
+ case 'd':
+ answer = scm_make_real (*((double *)&(data[p])));
+ break;
#endif
- case 's':
- case 'p':
- answer = SCM_PACK (data[p]);
- break;
+ case 's':
+ case 'p':
+ answer = SCM_PACK (data[p]);
+ break;
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
}
return answer;
@@ -706,65 +781,76 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
"to.")
#define FUNC_NAME s_scm_struct_set_x
{
- scm_t_bits * data;
- SCM layout;
- size_t layout_len;
+ SCM vtable;
+ scm_t_bits *data;
size_t p;
- int n_fields;
- scm_t_wchar field_type = 0;
SCM_VALIDATE_STRUCT (1, handle);
- layout = SCM_STRUCT_LAYOUT (handle);
+ vtable = SCM_STRUCT_VTABLE (handle);
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)
+ && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
+ /* The fast path: HANDLE is a struct with only "pw" fields. */
+ data[p] = SCM_UNPACK (val);
+ else
+ {
+ SCM layout;
+ size_t layout_len, n_fields;
+ scm_t_wchar field_type = 0;
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
- if (p * 2 < layout_len)
- {
- char set_x;
- field_type = scm_i_symbol_ref (layout, p * 2);
- set_x = scm_i_symbol_ref (layout, p * 2 + 1);
- if (set_x != 'w' && set_x != 'h')
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
+ {
+ char set_x;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ set_x = scm_i_symbol_ref (layout, p * 2 + 1);
+ if (set_x != 'w' && set_x != 'h')
+ SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+ }
+ else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
+ field_type = scm_i_symbol_ref (layout, layout_len - 2);
+ else
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
- field_type = scm_i_symbol_ref (layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
- {
- case 'u':
- data[p] = SCM_NUM2ULONG (3, val);
- break;
+
+ switch (field_type)
+ {
+ case 'u':
+ data[p] = SCM_NUM2ULONG (3, val);
+ break;
#if 0
- case 'i':
- data[p] = SCM_NUM2LONG (3, val);
- break;
+ case 'i':
+ data[p] = SCM_NUM2LONG (3, val);
+ break;
- case 'd':
- *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
- break;
+ case 'd':
+ *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
+ break;
#endif
- case 'p':
- data[p] = SCM_UNPACK (val);
- break;
+ case 'p':
+ data[p] = SCM_UNPACK (val);
+ break;
- case 's':
- SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
+ case 's':
+ SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
}
return val;
@@ -899,9 +985,15 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
void
scm_init_struct ()
{
- GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data
pointer */
- GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
- + scm_tc3_struct); /* for the vtable data pointer
*/
+ /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
+ scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
+ default. */
+ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits) + scm_tc3_struct);
+
+ /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
+ beginning of a GC-allocated region; that region is different from that of
+ OBJ once OBJ has undergone class redefinition. */
+ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
diff --git a/libguile/struct.h b/libguile/struct.h
index 537ef90..d2a05af 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 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010 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,20 +33,48 @@
in turn means we need support for changing the "class" (vtable) of an
"instance" (struct). This necessitates some indirection and trickery.
- I would like to write this all up here, but for now:
+ To summarize, structs are laid out this way:
+
+ .-------.
+ | |
+ .----------------+---v------------- -
+ | vtable | data | slot0 | slot1 |
+ `----------------+----------------- -
+ | .-------.
+ | | |
+ .---v------------+---v------------- -
+ | vtable | data | slot0 | slot1 |
+ `----------------+----------------- -
+ |
+ v
+
+ ...
+ .-------.
+ | | |
+ .---v------------+---v------------- -
+ .-| vtable | data | slot0 | slot1 |
+ | `----------------+----------------- -
+ | ^
+ `-----'
+
+ The DATA indirection (which corresponds to `SCM_STRUCT_DATA ()') is
necessary
+ to implement class redefinition.
+
+ For more details, see:
http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile
+
*/
/* All vtables have the following fields. */
#define SCM_VTABLE_BASE_LAYOUT \
"pr" /* layout */ \
- "uh" /* flags */ \
+ "uh" /* flags */ \
"sr" /* self */ \
"uh" /* finalizer */ \
"pw" /* printer */ \
"ph" /* name (hidden from make-struct for back-compat reasons) */ \
- "uh" /* reserved */ \
+ "uh" /* size */ \
"uh" /* reserved */
#define scm_vtable_index_layout 0 /* A symbol describing the
physical arrangement of this type. */
@@ -55,7 +83,7 @@
#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of
this struct type. */
#define scm_vtable_index_instance_printer 4 /* A printer for this struct
type. */
#define scm_vtable_index_name 5 /* Name of this vtable. */
-#define scm_vtable_index_reserved_6 6
+#define scm_vtable_index_size 6 /* Number of fields, for simple
structs. */
#define scm_vtable_index_reserved_7 7
#define scm_vtable_offset_user 8 /* Where do user fields start in
the vtable? */
@@ -79,8 +107,8 @@
#define SCM_VTABLE_FLAG_APPLICABLE (1L << 2) /* instances of this vtable are
applicable? */
#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 3) /* instances of this vtable
are applicable-with-setter vtables? */
#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are
applicable-with-setters? */
-#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 5)
-#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 6)
+#define SCM_VTABLE_FLAG_SIMPLE (1L << 5) /* instances of this vtable have only
"p" fields */
+#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 6) /* instances of this vtable have
only "pw" fields */
#define SCM_VTABLE_FLAG_SMOB_0 (1L << 7)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
diff --git a/libguile/tags.h b/libguile/tags.h
index e1e0913..d11bf68 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -411,18 +411,18 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_stringbuf 39
#define scm_tc7_bytevector 77
-#define scm_tc7_unused_1 31
+#define scm_tc7_foreign 31
#define scm_tc7_hashtable 29
#define scm_tc7_fluid 37
#define scm_tc7_dynamic_state 45
-#define scm_tc7_unused_4 47
-#define scm_tc7_unused_5 53
-#define scm_tc7_unused_6 55
-#define scm_tc7_unused_7 71
+#define scm_tc7_frame 47
+#define scm_tc7_objcode 53
+#define scm_tc7_vm 55
+#define scm_tc7_vm_cont 71
-#define scm_tc7_unused_17 61
-#define scm_tc7_gsubr 63
+#define scm_tc7_prompt 61
+#define scm_tc7_with_fluids 63
#define scm_tc7_unused_19 69
#define scm_tc7_program 79
#define scm_tc7_unused_9 85
@@ -498,7 +498,7 @@ enum scm_tc8_tags
* must all be equal except for two bit positions.
* (used to implement scm_is_lisp_false)
*
- * - SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, SCM_XXX_ANOTHER_BOOLEAN_DONT_USE
+ * - SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0
* must all be equal except for two bit positions.
* (used to implement scm_is_bool_or_nil)
*
@@ -519,12 +519,14 @@ enum scm_tc8_tags
#define SCM_BOOL_T SCM_MAKIFLAG (4)
#ifdef BUILDING_LIBGUILE
-#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE SCM_MAKIFLAG (5)
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0 SCM_MAKIFLAG (5)
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_1 SCM_MAKIFLAG (6)
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_2 SCM_MAKIFLAG (7)
#endif
-#define SCM_UNSPECIFIED SCM_MAKIFLAG (6)
-#define SCM_UNDEFINED SCM_MAKIFLAG (7)
-#define SCM_EOF_VAL SCM_MAKIFLAG (8)
+#define SCM_UNSPECIFIED SCM_MAKIFLAG (8)
+#define SCM_UNDEFINED SCM_MAKIFLAG (9)
+#define SCM_EOF_VAL SCM_MAKIFLAG (10)
/* When a variable is unbound this is marked by the SCM_UNDEFINED
* value. The following is an unbound value which can be handled on
@@ -534,7 +536,7 @@ enum scm_tc8_tags
* the code which handles this value in C so that SCM_UNDEFINED can be
* used instead. It is not ideal to let this kind of unique and
* strange values loose on the Scheme level. */
-#define SCM_UNBOUND SCM_MAKIFLAG (9)
+#define SCM_UNBOUND SCM_MAKIFLAG (11)
#define SCM_UNBNDP(x) (scm_is_eq ((x), SCM_UNDEFINED))
@@ -648,11 +650,6 @@ enum scm_tc8_tags
case scm_tc3_struct + 112:\
case scm_tc3_struct + 120
-/* For subrs
- */
-#define scm_tcs_subrs \
- case scm_tc7_gsubr
-
#if (SCM_ENABLE_DEPRECATED == 1)
diff --git a/libguile/throw.c b/libguile/throw.c
index fd08e6e..3e95fb3 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009,
2010 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
@@ -25,102 +25,137 @@
#include <stdio.h>
#include <unistdio.h>
#include "libguile/_scm.h"
-#include "libguile/async.h"
#include "libguile/smob.h"
-#include "libguile/alist.h"
#include "libguile/eval.h"
#include "libguile/eq.h"
-#include "libguile/dynwind.h"
+#include "libguile/control.h"
+#include "libguile/deprecation.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
-#include "libguile/continuations.h"
#include "libguile/stackchk.h"
#include "libguile/stacks.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
+#include "libguile/vm.h"
#include "libguile/throw.h"
#include "libguile/init.h"
#include "libguile/strings.h"
-#include "libguile/vm.h"
#include "libguile/private-options.h"
+/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
+ prompt, abort, and the %exception-handler fluid. This file just provides
+ shims so that it's easy to have catch functionality from C.
+
+ All of these function names and prototypes carry a fair bit of historical
+ baggage. */
+
+
+#define CACHE_VAR(var,name) \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ { \
+ var = scm_module_variable (scm_the_root_module (), \
+ scm_from_locale_symbol (name)); \
+ if (scm_is_false (var)) \
+ abort (); \
+ }
+
-/* the jump buffer data structure */
-static scm_t_bits tc16_jmpbuffer;
-#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+ CACHE_VAR (var, "catch");
-#define JBACTIVE(OBJ) (SCM_SMOB_FLAGS (OBJ) & 1L)
-#define ACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 1L))
-#define DEACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 0L))
+ return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
+}
-#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_SMOB_DATA_1 (OBJ))
-#define SETJBJMPBUF(x, v) (SCM_SET_SMOB_DATA_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_SMOB_DATA_3
(x))
-#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_SMOB_DATA_3 ((x), (scm_t_bits) (v)))
+SCM
+scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
+ SCM pre_unwind_handler)
+{
+ if (SCM_UNBNDP (pre_unwind_handler))
+ return scm_catch (key, thunk, handler);
+ else
+ {
+ CACHE_VAR (var, "catch");
+
+ return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
+ pre_unwind_handler);
+ }
+}
-static int
-jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+SCM
+scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
{
- scm_puts ("#<jmpbuffer ", port);
- scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
- scm_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port);
- scm_putc ('>', port);
- return 1 ;
+ CACHE_VAR (var, "with-throw-handler");
+
+ return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
}
-static SCM
-make_jmpbuf (void)
+SCM
+scm_throw (SCM key, SCM args)
{
- SCM answer;
- SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
- SETJBJMPBUF(answer, (scm_i_jmp_buf *)0);
- DEACTIVATEJB(answer);
- return answer;
+ CACHE_VAR (var, "throw");
+
+ return scm_apply_1 (scm_variable_ref (var), key, args);
}
-/* scm_c_catch (the guts of catch) */
-struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
-{
- scm_i_jmp_buf buf; /* must be first */
- SCM throw_tag;
- SCM retval;
-};
+/* Now some support for C bodies and catch handlers */
-/* These are the structures we use to store pre-unwind handling (aka
- "lazy") information for a regular catch, and put on the wind list
- for a "lazy" catch. They store the pre-unwind handler function to
- call, and the data pointer to pass through to it. It's not a
- Scheme closure, but it is a function with data, so the term
- "closure" is appropriate in its broader sense.
-
- (We don't need anything like this to run the normal (post-unwind)
- catch handler, because the same C frame runs both the body and the
- handler.) */
-
-struct pre_unwind_data {
- scm_t_catch_handler handler;
- void *handler_data;
- int running;
- int lazy_catch_p;
+static scm_t_bits tc16_catch_closure;
+
+enum {
+ CATCH_CLOSURE_BODY,
+ CATCH_CLOSURE_HANDLER
};
+static SCM
+make_catch_body_closure (scm_t_catch_body body, void *body_data)
+{
+ SCM ret;
+ SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
+ SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
+ return ret;
+}
+
+static SCM
+make_catch_handler_closure (scm_t_catch_handler handler, void *handler_data)
+{
+ SCM ret;
+ SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
+ SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
+ return ret;
+}
-/* scm_c_catch is the guts of catch. It handles all the mechanics of
- setting up a catch target, invoking the catch body, and perhaps
- invoking the handler if the body does a throw.
+static SCM
+apply_catch_closure (SCM clo, SCM args)
+{
+ void *data = (void*)SCM_SMOB_DATA_2 (clo);
- The function is designed to be usable from C code, but is general
- enough to implement all the semantics Guile Scheme expects from
- throw.
+ switch (SCM_SMOB_FLAGS (clo))
+ {
+ case CATCH_CLOSURE_BODY:
+ {
+ scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
+ return body (data);
+ }
+ case CATCH_CLOSURE_HANDLER:
+ {
+ scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
+ return handler (data, scm_car (args), scm_cdr (args));
+ }
+ default:
+ abort ();
+ }
+}
- TAG is the catch tag. Typically, this is a symbol, but this
+/* TAG is the catch tag. Typically, this is a symbol, but this
function doesn't actually care about that.
BODY is a pointer to a C function which runs the body of the catch;
@@ -165,83 +200,18 @@ scm_c_catch (SCM tag,
scm_t_catch_handler handler, void *handler_data,
scm_t_catch_handler pre_unwind_handler, void
*pre_unwind_handler_data)
{
- struct jmp_buf_and_retval jbr;
- SCM jmpbuf;
- SCM answer;
- SCM vm;
- SCM *sp = NULL, *fp = NULL; /* to reset the vm */
- struct pre_unwind_data pre_unwind;
-
- vm = scm_the_vm ();
- if (scm_is_true (vm))
- {
- sp = SCM_VM_DATA (vm)->sp;
- fp = SCM_VM_DATA (vm)->fp;
- }
-
- jmpbuf = make_jmpbuf ();
- answer = SCM_EOL;
- scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
- SETJBJMPBUF(jmpbuf, &jbr.buf);
-
- pre_unwind.handler = pre_unwind_handler;
- pre_unwind.handler_data = pre_unwind_handler_data;
- pre_unwind.running = 0;
- pre_unwind.lazy_catch_p = 0;
- SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);
-
- if (SCM_I_SETJMP (jbr.buf))
- {
- SCM throw_tag;
- SCM throw_args;
-
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- SCM_CRITICAL_SECTION_START;
- DEACTIVATEJB (jmpbuf);
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- SCM_CRITICAL_SECTION_END;
- throw_args = jbr.retval;
- throw_tag = jbr.throw_tag;
- jbr.throw_tag = SCM_EOL;
- jbr.retval = SCM_EOL;
- if (scm_is_true (vm))
- {
- SCM_VM_DATA (vm)->sp = sp;
- SCM_VM_DATA (vm)->fp = fp;
-#ifdef VM_ENABLE_STACK_NULLING
- /* see vm.c -- you'll have to enable this manually */
- memset (sp + 1, 0,
- (SCM_VM_DATA (vm)->stack_size
- - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM));
-#endif
- }
- else if (scm_is_true ((vm = scm_the_vm ())))
- {
- /* oof, it's possible this catch was called before the vm was
- booted... yick. anyway, try to reset the vm stack. */
- SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1;
- SCM_VM_DATA (vm)->fp = NULL;
-#ifdef VM_ENABLE_STACK_NULLING
- /* see vm.c -- you'll have to enable this manually */
- memset (SCM_VM_DATA (vm)->stack_base, 0,
- SCM_VM_DATA (vm)->stack_size * sizeof(SCM));
-#endif
- }
-
- answer = handler (handler_data, throw_tag, throw_args);
- }
+ SCM sbody, shandler, spre_unwind_handler;
+
+ sbody = make_catch_body_closure (body, body_data);
+ shandler = make_catch_handler_closure (handler, handler_data);
+ if (pre_unwind_handler)
+ spre_unwind_handler = make_catch_handler_closure (pre_unwind_handler,
+ pre_unwind_handler_data);
else
- {
- ACTIVATEJB (jmpbuf);
- answer = body (body_data);
- SCM_CRITICAL_SECTION_START;
- DEACTIVATEJB (jmpbuf);
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- SCM_CRITICAL_SECTION_END;
- }
- return answer;
+ spre_unwind_handler = SCM_UNDEFINED;
+
+ return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
+ spre_unwind_handler);
}
SCM
@@ -249,46 +219,13 @@ scm_internal_catch (SCM tag,
scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data)
{
- return scm_c_catch(tag,
- body, body_data,
- handler, handler_data,
- NULL, NULL);
+ return scm_c_catch (tag,
+ body, body_data,
+ handler, handler_data,
+ NULL, NULL);
}
-
-/* The smob tag for pre_unwind_data smobs. */
-static scm_t_bits tc16_pre_unwind_data;
-
-/* Strictly speaking, we could just pass a zero for our print
- function, because we don't need to print them. They should never
- appear in normal data structures, only in the wind list. However,
- it might be nice for debugging someday... */
-static int
-pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate
SCM_UNUSED)
-{
- struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_SMOB_DATA_1
(closure);
- char buf[200];
-
- sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
- (long) c->handler, (long) c->handler_data);
- scm_puts (buf, port);
-
- return 1;
-}
-
-
-/* Given a pointer to a pre_unwind_data structure, return a smob for it,
- suitable for inclusion in the wind list. ("Ah yes, a Château
- Gollombiere '72, non?"). */
-static SCM
-make_pre_unwind_data (struct pre_unwind_data *c)
-{
- SCM_RETURN_NEWSMOB (tc16_pre_unwind_data, c);
-}
-
-#define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data,
obj))
-
SCM
scm_c_with_throw_handler (SCM tag,
scm_t_catch_body body,
@@ -297,35 +234,22 @@ scm_c_with_throw_handler (SCM tag,
void *handler_data,
int lazy_catch_p)
{
- SCM pre_unwind, answer;
- struct pre_unwind_data c;
-
- c.handler = handler;
- c.handler_data = handler_data;
- c.running = 0;
- c.lazy_catch_p = lazy_catch_p;
- pre_unwind = make_pre_unwind_data (&c);
-
- SCM_CRITICAL_SECTION_START;
- scm_i_set_dynwinds (scm_acons (tag, pre_unwind, scm_i_dynwinds ()));
- SCM_CRITICAL_SECTION_END;
-
- answer = (*body) (body_data);
-
- SCM_CRITICAL_SECTION_START;
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- SCM_CRITICAL_SECTION_END;
-
- return answer;
-}
-
-/* Exactly like scm_internal_catch, except:
- - It does not unwind the stack (this is the major difference).
- - The handler is not allowed to return. */
-SCM
-scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data)
-{
- return scm_c_with_throw_handler (tag, body, body_data, handler,
handler_data, 1);
+ SCM sbody, shandler;
+
+ if (lazy_catch_p)
+ scm_c_issue_deprecation_warning
+ ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no
longer.\n"
+ "supported. Instead the handler will be invoked from within the
dynamic\n"
+ "context of the corresponding `throw'.\n"
+ "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
+ "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
+ "and adapt it (if necessary) to expect to be within the dynamic
context\n"
+ "of the throw.");
+
+ sbody = make_catch_body_closure (body, body_data);
+ shandler = make_catch_handler_closure (handler, handler_data);
+
+ return scm_with_throw_handler (tag, sbody, shandler);
}
@@ -354,7 +278,7 @@ static SCM
cwss_body (void *data)
{
struct cwss_data *d = data;
- return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
+ return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL,
0);
}
SCM
@@ -564,348 +488,63 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM
tag, SCM args)
return SCM_UNSPECIFIED; /* never returns */
}
-
-
-/* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
-
-SCM_DEFINE (scm_catch_with_pre_unwind_handler, "catch", 3, 1, 0,
- (SCM key, SCM thunk, SCM handler, SCM pre_unwind_handler),
- "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
- "exceptions matching @var{key}. If thunk throws to the symbol\n"
- "@var{key}, then @var{handler} is invoked this way:\n"
- "@lisp\n"
- "(handler key args ...)\n"
- "@end lisp\n"
- "\n"
- "@var{key} is a symbol or @code{#t}.\n"
- "\n"
- "@var{thunk} takes no arguments. If @var{thunk} returns\n"
- "normally, that is the return value of @code{catch}.\n"
- "\n"
- "Handler is invoked outside the scope of its own @code{catch}.\n"
- "If @var{handler} again throws to the same key, a new handler\n"
- "from further up the call chain is invoked.\n"
- "\n"
- "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
- "match this call to @code{catch}.\n"
- "\n"
- "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
- "an exception that matches @var{key}, Guile calls the\n"
- "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
- "invoking the main @var{handler}. @var{pre-unwind-handler}
should\n"
- "be a procedure with the same signature as @var{handler}, that\n"
- "is @code{(lambda (key . args))}. It is typically used to save\n"
- "the stack at the point where the exception occurred, but can
also\n"
- "query other parts of the dynamic state at that point, such as\n"
- "fluid values.\n"
- "\n"
- "A @var{pre-unwind-handler} can exit either normally or
non-locally.\n"
- "If it exits normally, Guile unwinds the stack and dynamic
context\n"
- "and then calls the normal (third argument) handler. If it exits\n"
- "non-locally, that exit determines the continuation.")
-#define FUNC_NAME s_scm_catch_with_pre_unwind_handler
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- /* scm_c_catch takes care of all the mechanics of setting up a catch
- key; we tell it to call scm_body_thunk to run the body, and
- scm_handle_by_proc to deal with any throws to this catch. The
- former receives a pointer to c, telling it how to behave. The
- latter receives a pointer to HANDLER, so it knows who to
- call. */
- return scm_c_catch (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler,
- SCM_UNBNDP (pre_unwind_handler) ? NULL :
scm_handle_by_proc,
- &pre_unwind_handler);
-}
-#undef FUNC_NAME
-
-/* The following function exists to provide backwards compatibility
- for the C scm_catch API. Otherwise we could just change
- "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
SCM
-scm_catch (SCM key, SCM thunk, SCM handler)
-{
- return scm_catch_with_pre_unwind_handler (key, thunk, handler,
SCM_UNDEFINED);
-}
-
-
-SCM_DEFINE (scm_with_throw_handler, "with-throw-handler", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
- "Add @var{handler} to the dynamic context as a throw handler\n"
- "for key @var{key}, then invoke @var{thunk}.")
-#define FUNC_NAME s_scm_with_throw_handler
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- /* scm_c_with_throw_handler takes care of the mechanics of setting
- up a throw handler; we tell it to call scm_body_thunk to run the
- body, and scm_handle_by_proc to deal with any throws to this
- handler. The former receives a pointer to c, telling it how to
- behave. The latter receives a pointer to HANDLER, so it knows
- who to call. */
- return scm_c_with_throw_handler (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler,
- 0);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
- "This behaves exactly like @code{catch}, except that it does\n"
- "not unwind the stack before invoking @var{handler}.\n"
- "If the @var{handler} procedure returns normally, Guile\n"
- "rethrows the same exception again to the next innermost catch,\n"
- "lazy-catch or throw handler. If the @var{handler} exits\n"
- "non-locally, that exit determines the continuation.")
-#define FUNC_NAME s_scm_lazy_catch
+scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- /* scm_internal_lazy_catch takes care of all the mechanics of
- setting up a lazy catch key; we tell it to call scm_body_thunk to
- run the body, and scm_handle_by_proc to deal with any throws to
- this catch. The former receives a pointer to c, telling it how
- to behave. The latter receives a pointer to HANDLER, so it knows
- who to call. */
- return scm_internal_lazy_catch (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler);
+ return scm_throw (key, args);
}
-#undef FUNC_NAME
+/* Unfortunately we have to support catch and throw before boot-9 has, um,
+ booted. So here are lame versions, which will get replaced with their scheme
+ equivalents. */
-
-/* throwing */
+SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
-static void toggle_pre_unwind_running (void *data)
-{
- struct pre_unwind_data *pre_unwind = (struct pre_unwind_data *)data;
- pre_unwind->running = !pre_unwind->running;
-}
-
-SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
- (SCM key, SCM args),
- "Invoke the catch form matching @var{key}, passing @var{args} to
the\n"
- "@var{handler}. \n\n"
- "@var{key} is a symbol. It will match catches of the same symbol
or of\n"
- "@code{#t}.\n\n"
- "If there is no handler at all, Guile prints an error and then
exits.")
-#define FUNC_NAME s_scm_throw
-{
- SCM_VALIDATE_SYMBOL (1, key);
- return scm_ithrow (key, args, 1);
-}
-#undef FUNC_NAME
-
-SCM
-scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
+static SCM
+pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- SCM jmpbuf = SCM_UNDEFINED;
- SCM wind_goal;
-
- SCM dynpair = SCM_UNDEFINED;
- SCM winds;
-
- if (SCM_I_CURRENT_THREAD->critical_section_level)
- {
- SCM s = args;
- int i = 0;
-
- /*
- We have much better routines for displaying Scheme, but we're
- already inside a pernicious error, and it's unlikely that they
- are available to us. We try to print something useful anyway,
- so users don't need a debugger to find out what went wrong.
- */
- fprintf (stderr, "throw from within critical section.\n");
- if (scm_is_symbol (key))
- {
- if (scm_i_is_narrow_symbol (key))
- fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key));
- else
- ulc_fprintf (stderr, "error key: %llU\n", scm_i_symbol_wide_chars
(key));
- }
-
- for (; scm_is_pair (s); s = scm_cdr (s), i++)
- {
- char const *str = NULL;
- if (scm_is_string (scm_car (s)))
- str = scm_i_string_chars (scm_car (s));
- else if (scm_is_symbol (scm_car (s)))
- str = scm_i_symbol_chars (scm_car (s));
-
- if (str != NULL)
- fprintf (stderr, "argument %d: %s\n", i, str);
- }
- abort ();
- }
-
- rethrow:
-
- /* Search the wind list for an appropriate catch.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
- {
- dynpair = SCM_CAR (winds);
- if (scm_is_pair (dynpair))
- {
- SCM this_key = SCM_CAR (dynpair);
-
- if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
- {
- jmpbuf = SCM_CDR (dynpair);
-
- if (!SCM_PRE_UNWIND_DATA_P (jmpbuf))
- break;
- else
- {
- struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
- if (!c->running)
- break;
- }
- }
- }
- }
+ SCM vm, prompt, res;
- /* If we didn't find anything, print a message and abort the process
- right here. If you don't want this, establish a catch-all around
- any code that might throw up. */
- if (scm_is_null (winds))
- {
- scm_handle_by_message (NULL, key, args);
- abort ();
- }
-
- /* If the wind list is malformed, bail. */
- if (!scm_is_pair (winds))
+ /* Only handle catch-alls without pre-unwind handlers */
+ if (!SCM_UNBNDP (pre_unwind_handler))
+ abort ();
+ if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
abort ();
-
- for (wind_goal = scm_i_dynwinds ();
- (!scm_is_pair (SCM_CAR (wind_goal))
- || !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf));
- wind_goal = SCM_CDR (wind_goal))
- ;
-
- /* Is this a throw handler (or lazy catch)? In a wind list entry
- for a throw handler or lazy catch, the key is bound to a
- pre_unwind_data smob, not a jmpbuf. */
- if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
- {
- struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
- SCM handle, answer;
-
- /* For old-style lazy-catch behaviour, we unwind the dynamic
- context before invoking the handler. */
- if (c->lazy_catch_p)
- {
- scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
- - scm_ilength (wind_goal)));
- SCM_CRITICAL_SECTION_START;
- handle = scm_i_dynwinds ();
- scm_i_set_dynwinds (SCM_CDR (handle));
- SCM_CRITICAL_SECTION_END;
- }
- /* Call the handler, with framing to set the pre-unwind
- structure's running field while the handler is running, so we
- can avoid recursing into the same handler again. Note that
- if the handler returns normally, the running flag stays
- set until some kind of non-local jump occurs. */
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (toggle_pre_unwind_running,
- c,
- SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (toggle_pre_unwind_running, c, 0);
- answer = (c->handler) (c->handler_data, key, args);
-
- /* There is deliberately no scm_dynwind_end call here. This
- means that the unwind handler (toggle_pre_unwind_running)
- stays in place until a non-local exit occurs, and will then
- reset the pre-unwind structure's running flag. For sample
- code where this makes a difference, see the "again but with
- two chained throw handlers" test case in exceptions.test. */
-
- /* If the handler returns, rethrow the same key and args. */
- goto rethrow;
- }
+ vm = scm_the_vm ();
+ prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
+ SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
+ SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
+ scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
- /* Otherwise, it's a normal catch. */
- else if (SCM_JMPBUFP (jmpbuf))
+ if (SCM_PROMPT_SETJMP (prompt))
{
- struct pre_unwind_data * pre_unwind;
- struct jmp_buf_and_retval * jbr;
-
- /* Before unwinding anything, run the pre-unwind handler if
- there is one, and if it isn't already running. */
- pre_unwind = SCM_JBPREUNWIND (jmpbuf);
- if (pre_unwind->handler && !pre_unwind->running)
- {
- /* Use framing to detect and avoid possible reentry into
- this handler, which could otherwise cause an infinite
- loop. */
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (toggle_pre_unwind_running,
- pre_unwind,
- SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (toggle_pre_unwind_running,
- pre_unwind,
- SCM_F_WIND_EXPLICITLY);
- (pre_unwind->handler) (pre_unwind->handler_data, key, args);
- scm_dynwind_end ();
- }
-
- /* Now unwind and jump. */
- scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
- - scm_ilength (wind_goal)));
- jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
- jbr->throw_tag = key;
- jbr->retval = args;
- SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
+ /* nonlocal exit */
+ SCM args = scm_i_prompt_pop_abort_args_x (prompt);
+ /* cdr past the continuation */
+ return scm_apply_0 (handler, scm_cdr (args));
}
- /* Otherwise, it's some random piece of junk. */
- else
- abort ();
+ res = scm_call_0 (thunk);
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
-#ifdef __ia64__
- /* On IA64, we #define longjmp as setcontext, and GCC appears not to
- know that that doesn't return. */
- return SCM_UNSPECIFIED;
-#endif
+ return res;
}
+static SCM
+pre_init_throw (SCM args)
+{
+ return scm_at_abort (sym_pre_init_catch_tag, args);
+}
void
scm_init_throw ()
{
- tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
- scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
+ tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
+ scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
- tc16_pre_unwind_data = scm_make_smob_type ("pre-unwind-data", 0);
- scm_set_smob_print (tc16_pre_unwind_data, pre_unwind_data_print);
+ scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
+ scm_c_define ("throw", scm_c_make_gsubr ("throw", 0, 0, 1, pre_init_throw));
#include "libguile/throw.x"
}
diff --git a/libguile/throw.h b/libguile/throw.h
index 1ed6ba6..d14cbf8 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -52,12 +52,6 @@ SCM_API SCM scm_internal_catch (SCM tag,
scm_t_catch_handler handler,
void *handler_data);
-SCM_API SCM scm_internal_lazy_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data);
-
SCM_API SCM scm_internal_stack_catch (SCM tag,
scm_t_catch_body body,
void *body_data,
@@ -91,7 +85,6 @@ SCM_API int scm_exit_status (SCM args);
SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM
handler, SCM lazy_handler);
SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
-SCM_API SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);
SCM_API SCM scm_throw (SCM key, SCM args);
diff --git a/libguile/trees.c b/libguile/trees.c
index cbfd427..76bb686 100644
--- a/libguile/trees.c
+++ b/libguile/trees.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -25,7 +25,6 @@
#include "libguile/_scm.h"
#include "libguile/eq.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/list.h"
diff --git a/libguile/unidata_to_charset.pl b/libguile/unidata_to_charset.pl
index d086c8e..16468a0 100755
--- a/libguile/unidata_to_charset.pl
+++ b/libguile/unidata_to_charset.pl
@@ -1,18 +1,18 @@
#!/usr/bin/perl
# unidata_to_charset.pl --- Compute SRFI-14 charsets from UnicodeData.txt
#
-# Copyright (C) 2009 Free Software Foundation, Inc.
-#
+# Copyright (C) 2009, 2010 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
@@ -340,8 +340,9 @@ sub compute {
$rend[$len] = $end;
$len++;
} elsif ($len == 0) {
- $rstart[0] = $start;
- $rend[0] = $end;
+ $rstart[0] = $start;
+ $rend[0] = $end;
+ $len++;
}
}
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 7875328..321b499 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010 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
@@ -26,16 +26,11 @@
#include "libguile/eq.h"
#include "libguile/root.h"
#include "libguile/strings.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/vectors.h"
+#include "libguile/arrays.h" /* Hit me with the ugly stick */
#include "libguile/generalized-vectors.h"
-#include "libguile/arrays.h"
-#include "libguile/bitvectors.h"
-#include "libguile/bytevectors.h"
-#include "libguile/array-map.h"
-#include "libguile/srfi-4.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/dynwind.h"
@@ -625,12 +620,11 @@ vector_get_handle (SCM v, scm_t_array_handle *h)
h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
}
+/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
+ tags.h. */
SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
vector_handle_ref, vector_handle_set,
vector_get_handle)
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2,
- vector_handle_ref, vector_handle_set,
- vector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
diff --git a/libguile/vectors.h b/libguile/vectors.h
index a74c8a9..3746e90 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -24,7 +24,6 @@
#include "libguile/__scm.h"
-#include "libguile/arrays.h"
@@ -69,6 +68,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
#define SCM_I_VECTOR_HEADER_SIZE 2U
#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
+#define SCM_I_IS_NONWEAK_VECTOR(x) (!SCM_IMP(x) &&
(SCM_TYP7(x)==scm_tc7_vector))
#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x,
SCM_I_VECTOR_HEADER_SIZE))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
diff --git a/libguile/version.c b/libguile/version.c
index db1bc9f..f1bd3c3 100644
--- a/libguile/version.c
+++ b/libguile/version.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996, 1999, 2000, 2001, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996, 1999, 2000, 2001, 2006, 2008, 2010 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,14 +105,7 @@ SCM_DEFINE (scm_effective_version, "effective-version", 0,
0, 0,
"@end lisp")
#define FUNC_NAME s_scm_effective_version
{
-
- char version_str[2 * 4 + 3];
-
-#if (SCM_MAJOR_VERSION > 9999 || SCM_MINOR_VERSION > 9999)
-# error version string may overflow buffer
-#endif
- sprintf (version_str, "%d.%d", SCM_MAJOR_VERSION, SCM_MINOR_VERSION);
- return scm_from_locale_string (version_str);
+ return scm_from_locale_string (SCM_EFFECTIVE_VERSION);
}
#undef FUNC_NAME
diff --git a/libguile/version.h.in b/libguile/version.h.in
index 394bbdb..49d26c2 100644
--- a/libguile/version.h.in
+++ b/libguile/version.h.in
@@ -3,7 +3,7 @@
#ifndef SCM_VERSION_H
#define SCM_VERSION_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2010 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
@@ -30,6 +30,7 @@
#define SCM_MAJOR_VERSION @-GUILE_MAJOR_VERSION-@
#define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@
#define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@
+#define SCM_EFFECTIVE_VERSION "@-GUILE_EFFECTIVE_VERSION-@"
SCM_API SCM scm_major_version (void);
SCM_API SCM scm_minor_version (void);
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
deleted file mode 100644
index 7ba1a93..0000000
--- a/libguile/vm-bootstrap.h
+++ /dev/null
@@ -1,30 +0,0 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifndef _SCM_VM_BOOTSTRAP_H_
-#define _SCM_VM_BOOTSTRAP_H_
-
-SCM_INTERNAL void scm_bootstrap_vm (void);
-
-#endif /* _SCM_VM_BOOTSTRAP_H_ */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2d28bbf..1976f71 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,29 +34,27 @@
static SCM
-VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
+VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
{
/* VM registers */
register scm_t_uint8 *ip IP_REG; /* instruction pointer */
register SCM *sp SP_REG; /* stack pointer */
register SCM *fp FP_REG; /* frame pointer */
+ struct scm_vm *vp = SCM_VM_DATA (vm);
/* Cache variables */
struct scm_objcode *bp = NULL; /* program base pointer */
- SCM *free_vars = NULL; /* free variables */
- size_t free_vars_count = 0; /* length of FREE_VARS */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
+ SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
+ scm_t_int64 vm_cookie = vp->cookie++;
+
/* Internal variables */
int nvalues = 0;
SCM finish_args; /* used both for returns: both in error
and normal situations */
-#if VM_USE_HOOKS
- SCM hook_args = SCM_EOL;
-#endif
-
#ifdef HAVE_LABELS_AS_VALUES
static void **jump_table = NULL;
#endif
@@ -133,6 +131,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
{
SCM err_msg;
+ /* FIXME: need to sync regs before allocating anything, in each case. */
+
vm_error_bad_instruction:
err_msg = scm_from_locale_string ("VM: Bad instruction: ~s");
finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
@@ -148,19 +148,24 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
goto vm_error;
vm_error_kwargs_length_not_even:
- err_msg = scm_from_locale_string ("Bad keyword argument list: odd
length");
- finish_args = SCM_EOL;
- goto vm_error;
+ SYNC_ALL ();
+ err_msg = scm_from_locale_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:
- err_msg = scm_from_locale_string ("Bad keyword argument list: expected
keyword");
- finish_args = SCM_EOL;
- goto vm_error;
+ /* FIXME say which one it was */
+ SYNC_ALL ();
+ err_msg = scm_from_locale_string ("Invalid keyword");
+ scm_error_scm (sym_keyword_argument_error, program, err_msg,
+ SCM_EOL, SCM_BOOL_F);
vm_error_kwargs_unrecognized_keyword:
- err_msg = scm_from_locale_string ("Bad keyword argument list:
unrecognized keyword");
- finish_args = SCM_EOL;
- goto vm_error;
+ /* FIXME say which one it was */
+ SYNC_ALL ();
+ err_msg = scm_from_locale_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_locale_string ("VM: Too many arguments");
@@ -212,6 +217,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* shouldn't get here */
goto vm_error;
+ vm_error_not_a_thunk:
+ SYNC_ALL ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "thunk");
+ /* shouldn't get here */
+ goto vm_error;
+
vm_error_no_values:
err_msg = scm_from_locale_string ("Zero values returned to single-valued
continuation");
finish_args = SCM_EOL;
@@ -222,6 +233,11 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
finish_args = SCM_EOL;
goto vm_error;
+ vm_error_continuation_not_rewindable:
+ err_msg = scm_from_locale_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_locale_string ("VM: Bad wide string length: ~S");
goto vm_error;
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 949e9c4..66e03c8 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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
@@ -102,6 +102,7 @@
#endif
+/* Cache the VM's instruction, stack, and frame pointer in local variables. */
#define CACHE_REGISTER() \
{ \
ip = vp->ip; \
@@ -109,6 +110,9 @@
fp = vp->fp; \
}
+/* Update the registers in VP, a pointer to the current VM. This must be done
+ at least before any GC invocation so that `vp->sp' is up-to-date and the
+ whole stack gets marked. */
#define SYNC_REGISTER() \
{ \
vp->ip = ip; \
@@ -154,19 +158,6 @@
object_count = 0; \
} \
} \
- { \
- SCM c = SCM_PROGRAM_FREE_VARIABLES (program); \
- if (SCM_I_IS_VECTOR (c)) \
- { \
- free_vars = SCM_I_VECTOR_WELTS (c); \
- free_vars_count = SCM_I_VECTOR_LENGTH (c); \
- } \
- else \
- { \
- free_vars = NULL; \
- free_vars_count = 0; \
- } \
- } \
}
#define SYNC_BEFORE_GC() \
@@ -193,8 +184,11 @@
#endif
#if VM_CHECK_FREE_VARIABLES
-#define CHECK_FREE_VARIABLE(_num) \
- do { if (SCM_UNLIKELY ((_num) >= free_vars_count)) goto
vm_error_free_variable; } while (0)
+#define CHECK_FREE_VARIABLE(_num) \
+ do { \
+ if (SCM_UNLIKELY ((_num) >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))) \
+ goto vm_error_free_variable; \
+ } while (0)
#else
#define CHECK_FREE_VARIABLE(_num)
#endif
@@ -205,18 +199,29 @@
*/
#undef RUN_HOOK
+#undef RUN_HOOK1
#if VM_USE_HOOKS
-#define RUN_HOOK(h) \
-{ \
- if (SCM_UNLIKELY (scm_is_true (vp->hooks[h])))\
- { \
- SYNC_REGISTER (); \
- vm_dispatch_hook (vp, vp->hooks[h], hook_args); \
- CACHE_REGISTER (); \
- } \
-}
+#define RUN_HOOK(h) \
+ { \
+ if (SCM_UNLIKELY (vp->trace_level > 0)) \
+ { \
+ SYNC_REGISTER (); \
+ vm_dispatch_hook (vm, h); \
+ } \
+ }
+#define RUN_HOOK1(h, x) \
+ { \
+ if (SCM_UNLIKELY (vp->trace_level > 0)) \
+ { \
+ PUSH (x); \
+ SYNC_REGISTER (); \
+ vm_dispatch_hook (vm, h); \
+ DROP(); \
+ } \
+ }
#else
#define RUN_HOOK(h)
+#define RUN_HOOK1(h, x)
#endif
#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK)
@@ -226,7 +231,7 @@
#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK)
#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK)
#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK)
-#define RETURN_HOOK() RUN_HOOK (SCM_VM_RETURN_HOOK)
+#define RETURN_HOOK(n) RUN_HOOK1 (SCM_VM_RETURN_HOOK, SCM_I_MAKINUM (n))
#define VM_HANDLE_INTERRUPTS \
SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index ef53cdd..a9326c9 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010 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,7 +20,7 @@
/* This file is included in vm_engine.c */
-VM_DEFINE_LOADER (82, load_number, "load-number")
+VM_DEFINE_LOADER (101, load_number, "load-number")
{
size_t len;
@@ -33,7 +33,7 @@ VM_DEFINE_LOADER (82, load_number, "load-number")
NEXT;
}
-VM_DEFINE_LOADER (83, load_string, "load-string")
+VM_DEFINE_LOADER (102, load_string, "load-string")
{
size_t len;
char *buf;
@@ -46,7 +46,7 @@ VM_DEFINE_LOADER (83, load_string, "load-string")
NEXT;
}
-VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
+VM_DEFINE_LOADER (103, load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
@@ -57,7 +57,7 @@ VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
NEXT;
}
-VM_DEFINE_LOADER (86, load_program, "load-program")
+VM_DEFINE_LOADER (104, load_program, "load-program")
{
scm_t_uint32 len;
SCM objs, objcode;
@@ -78,7 +78,7 @@ VM_DEFINE_LOADER (86, load_program, "load-program")
NEXT;
}
-VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (105, link_now, "link-now", 0, 1, 1)
{
SCM what;
POP (what);
@@ -87,7 +87,7 @@ VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
NEXT;
}
-VM_DEFINE_LOADER (89, load_array, "load-array")
+VM_DEFINE_LOADER (106, load_array, "load-array")
{
SCM type, shape;
size_t len;
@@ -100,7 +100,7 @@ VM_DEFINE_LOADER (89, load_array, "load-array")
NEXT;
}
-VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
+VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string")
{
size_t len;
scm_t_wchar *wbuf;
@@ -124,7 +124,7 @@ VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
- (let ((counter 79)) (goto-char (point-min))
+ (let ((counter 100)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 6faab9b..3e31691 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -29,43 +29,43 @@
#define RETURN(x) do { *sp = x; NEXT; } while (0)
-VM_DEFINE_FUNCTION (100, not, "not", 1)
+VM_DEFINE_FUNCTION (128, not, "not", 1)
{
ARGS1 (x);
- RETURN (scm_from_bool (scm_is_false_or_nil (x)));
+ RETURN (scm_from_bool (scm_is_false (x)));
}
-VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
+VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
{
ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_false_or_nil (x)));
+ RETURN (scm_from_bool (!scm_is_false (x)));
}
-VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
+VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
{
ARGS2 (x, y);
RETURN (scm_from_bool (scm_is_eq (x, y)));
}
-VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
+VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
{
ARGS2 (x, y);
RETURN (scm_from_bool (!scm_is_eq (x, y)));
}
-VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
+VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
{
ARGS1 (x);
- RETURN (scm_from_bool (scm_is_null_or_nil (x)));
+ RETURN (scm_from_bool (scm_is_null (x)));
}
-VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
+VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
{
ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_null_or_nil (x)));
+ RETURN (scm_from_bool (!scm_is_null (x)));
}
-VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
+VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@@ -76,7 +76,7 @@ VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
RETURN (scm_eqv_p (x, y));
}
-VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
+VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@@ -87,13 +87,13 @@ VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
RETURN (scm_equal_p (x, y));
}
-VM_DEFINE_FUNCTION (108, pairp, "pair?", 1)
+VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_pair (x)));
}
-VM_DEFINE_FUNCTION (109, listp, "list?", 1)
+VM_DEFINE_FUNCTION (137, listp, "list?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_ilength (x) >= 0));
@@ -104,7 +104,7 @@ VM_DEFINE_FUNCTION (109, listp, "list?", 1)
* Basic data
*/
-VM_DEFINE_FUNCTION (110, cons, "cons", 2)
+VM_DEFINE_FUNCTION (138, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
@@ -117,21 +117,21 @@ VM_DEFINE_FUNCTION (110, cons, "cons", 2)
goto vm_error_not_a_pair; \
}
-VM_DEFINE_FUNCTION (111, car, "car", 1)
+VM_DEFINE_FUNCTION (139, car, "car", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CAR (x));
}
-VM_DEFINE_FUNCTION (112, cdr, "cdr", 1)
+VM_DEFINE_FUNCTION (140, cdr, "cdr", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CDR (x));
}
-VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (141, set_car, "set-car!", 0, 2, 0)
{
SCM x, y;
POP (y);
@@ -141,7 +141,7 @@ VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (142, set_cdr, "set-cdr!", 0, 2, 0)
{
SCM x, y;
POP (y);
@@ -166,27 +166,27 @@ VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
RETURN (srel (x, y)); \
}
-VM_DEFINE_FUNCTION (115, ee, "ee?", 2)
+VM_DEFINE_FUNCTION (143, ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
-VM_DEFINE_FUNCTION (116, lt, "lt?", 2)
+VM_DEFINE_FUNCTION (144, lt, "lt?", 2)
{
REL (<, scm_less_p);
}
-VM_DEFINE_FUNCTION (117, le, "le?", 2)
+VM_DEFINE_FUNCTION (145, le, "le?", 2)
{
REL (<=, scm_leq_p);
}
-VM_DEFINE_FUNCTION (118, gt, "gt?", 2)
+VM_DEFINE_FUNCTION (146, gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
-VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
+VM_DEFINE_FUNCTION (147, ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
@@ -210,12 +210,12 @@ VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
RETURN (SFUNC (x, y)); \
}
-VM_DEFINE_FUNCTION (120, add, "add", 2)
+VM_DEFINE_FUNCTION (148, add, "add", 2)
{
FUNC2 (+, scm_sum);
}
-VM_DEFINE_FUNCTION (167, add1, "add1", 1)
+VM_DEFINE_FUNCTION (149, add1, "add1", 1)
{
ARGS1 (x);
if (SCM_I_INUMP (x))
@@ -228,12 +228,12 @@ VM_DEFINE_FUNCTION (167, add1, "add1", 1)
RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
}
-VM_DEFINE_FUNCTION (121, sub, "sub", 2)
+VM_DEFINE_FUNCTION (150, sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
-VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
+VM_DEFINE_FUNCTION (151, sub1, "sub1", 1)
{
ARGS1 (x);
if (SCM_I_INUMP (x))
@@ -246,58 +246,71 @@ VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
}
-VM_DEFINE_FUNCTION (122, mul, "mul", 2)
+VM_DEFINE_FUNCTION (152, mul, "mul", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_product (x, y));
}
-VM_DEFINE_FUNCTION (123, div, "div", 2)
+VM_DEFINE_FUNCTION (153, div, "div", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_divide (x, y));
}
-VM_DEFINE_FUNCTION (124, quo, "quo", 2)
+VM_DEFINE_FUNCTION (154, quo, "quo", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_quotient (x, y));
}
-VM_DEFINE_FUNCTION (125, rem, "rem", 2)
+VM_DEFINE_FUNCTION (155, rem, "rem", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_remainder (x, y));
}
-VM_DEFINE_FUNCTION (126, mod, "mod", 2)
+VM_DEFINE_FUNCTION (156, mod, "mod", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_modulo (x, y));
}
-VM_DEFINE_FUNCTION (170, ash, "ash", 2)
+VM_DEFINE_FUNCTION (157, ash, "ash", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
{
if (SCM_I_INUM (y) < 0)
+ /* Right shift, will be a fixnum. */
RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
- else if ((SCM_I_INUM (x) << SCM_I_INUM (y)) >> SCM_I_INUM (y)
- == SCM_I_INUM (x))
- RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) << SCM_I_INUM (y)));
+ else
+ /* Left shift. See comments in scm_ash. */
+ {
+ long nn, bits_to_shift;
+
+ nn = SCM_I_INUM (x);
+ bits_to_shift = SCM_I_INUM (y);
+
+ if (bits_to_shift < SCM_I_FIXNUM_BIT-1
+ && ((unsigned long)
+ (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
+ <= 1))
+ RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
+ /* fall through */
+ }
/* fall through */
}
SYNC_REGISTER ();
RETURN (scm_ash (x, y));
}
-VM_DEFINE_FUNCTION (171, logand, "logand", 2)
+VM_DEFINE_FUNCTION (158, logand, "logand", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -306,7 +319,7 @@ VM_DEFINE_FUNCTION (171, logand, "logand", 2)
RETURN (scm_logand (x, y));
}
-VM_DEFINE_FUNCTION (172, logior, "logior", 2)
+VM_DEFINE_FUNCTION (159, logior, "logior", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -315,7 +328,7 @@ VM_DEFINE_FUNCTION (172, logior, "logior", 2)
RETURN (scm_logior (x, y));
}
-VM_DEFINE_FUNCTION (173, logxor, "logxor", 2)
+VM_DEFINE_FUNCTION (160, logxor, "logxor", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -326,39 +339,14 @@ VM_DEFINE_FUNCTION (173, logxor, "logxor", 2)
/*
- * GOOPS support
+ * Vectors and arrays
*/
-VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
-{
- ARGS1 (obj);
- RETURN (SCM_INSTANCEP (obj) ? SCM_CLASS_OF (obj) : scm_class_of (obj));
-}
-
-VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2)
-{
- size_t slot;
- ARGS2 (instance, idx);
- slot = SCM_I_INUM (idx);
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
-}
-
-VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0)
-{
- SCM instance, idx, val;
- size_t slot;
- POP (val);
- POP (idx);
- POP (instance);
- slot = SCM_I_INUM (idx);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
- NEXT;
-}
-VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
+VM_DEFINE_FUNCTION (161, vector_ref, "vector-ref", 2)
{
long i = 0;
ARGS2 (vect, idx);
- if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)
+ if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
&& SCM_I_INUMP (idx)
&& ((i = SCM_I_INUM (idx)) >= 0)
&& i < SCM_I_VECTOR_LENGTH (vect)))
@@ -370,12 +358,12 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
}
}
-VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (162, vector_set, "vector-set", 0, 3, 0)
{
long i = 0;
SCM vect, idx, val;
POP (val); POP (idx); POP (vect);
- if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)
+ if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
&& SCM_I_INUMP (idx)
&& ((i = SCM_I_INUM (idx)) >= 0)
&& i < SCM_I_VECTOR_LENGTH (vect)))
@@ -388,6 +376,175 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0,
3, 0)
NEXT;
}
+VM_DEFINE_INSTRUCTION (163, make_array, "make-array", 3, -1, 1)
+{
+ scm_t_uint32 len;
+ SCM shape, ret;
+
+ len = FETCH ();
+ len = (len << 8) + FETCH ();
+ len = (len << 8) + FETCH ();
+ POP (shape);
+ SYNC_REGISTER ();
+ ret = scm_from_contiguous_array (shape, sp - len + 1, len);
+ DROPN (len);
+ PUSH (ret);
+ NEXT;
+}
+
+
+/*
+ * Structs
+ */
+#define VM_VALIDATE_STRUCT(obj) \
+ if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
+ { \
+ finish_args = (obj); \
+ goto vm_error_not_a_struct; \
+ }
+
+VM_DEFINE_FUNCTION (164, struct_p, "struct?", 1)
+{
+ ARGS1 (obj);
+ RETURN (scm_from_bool (SCM_STRUCTP (obj)));
+}
+
+VM_DEFINE_FUNCTION (165, struct_vtable, "struct-vtable", 1)
+{
+ ARGS1 (obj);
+ VM_VALIDATE_STRUCT (obj);
+ RETURN (SCM_STRUCT_VTABLE (obj));
+}
+
+VM_DEFINE_INSTRUCTION (166, make_struct, "make-struct", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ scm_t_bits n_args = ((h << 8U) + l);
+ SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
+ const SCM *inits = sp - n_args + 3;
+
+ sp -= n_args - 1;
+
+ SYNC_REGISTER ();
+
+ if (SCM_LIKELY (SCM_STRUCTP (vtable)
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (n_tail)))
+ {
+ scm_t_bits n_inits, len;
+
+ n_inits = SCM_I_INUM (n_tail) + n_args - 2;
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+
+ if (SCM_LIKELY (n_inits == len))
+ {
+ SCM obj;
+
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), n_inits);
+ memcpy (SCM_STRUCT_DATA (obj), inits, n_inits * sizeof (SCM));
+
+ RETURN (obj);
+ }
+ }
+
+ RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
+ n_args - 2, (scm_t_bits *) inits));
+}
+
+VM_DEFINE_FUNCTION (167, struct_ref, "struct-ref", 2)
+{
+ ARGS2 (obj, pos);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (pos)))
+ {
+ SCM vtable;
+ scm_t_bits index, len;
+
+ index = SCM_I_INUM (pos);
+ vtable = SCM_STRUCT_VTABLE (obj);
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+
+ if (SCM_LIKELY (index < len))
+ {
+ scm_t_bits *data = SCM_STRUCT_DATA (obj);
+ RETURN (SCM_PACK (data[index]));
+ }
+ }
+
+ SYNC_REGISTER ();
+ RETURN (scm_struct_ref (obj, pos));
+}
+
+VM_DEFINE_FUNCTION (168, struct_set, "struct-set", 3)
+{
+ ARGS3 (obj, pos, val);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE_RW)
+ && SCM_I_INUMP (pos)))
+ {
+ SCM vtable;
+ scm_t_bits index, len;
+
+ index = SCM_I_INUM (pos);
+ vtable = SCM_STRUCT_VTABLE (obj);
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ if (SCM_LIKELY (index < len))
+ {
+ scm_t_bits *data = SCM_STRUCT_DATA (obj);
+ data[index] = SCM_UNPACK (val);
+ RETURN (val);
+ }
+ }
+
+ SYNC_REGISTER ();
+ RETURN (scm_struct_set_x (obj, pos, val));
+}
+
+
+/*
+ * GOOPS support
+ */
+VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
+{
+ ARGS1 (obj);
+ if (SCM_INSTANCEP (obj))
+ RETURN (SCM_CLASS_OF (obj));
+ SYNC_REGISTER ();
+ RETURN (scm_class_of (obj));
+}
+
+VM_DEFINE_FUNCTION (170, slot_ref, "slot-ref", 2)
+{
+ size_t slot;
+ ARGS2 (instance, idx);
+ slot = SCM_I_INUM (idx);
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+}
+
+VM_DEFINE_INSTRUCTION (171, slot_set, "slot-set", 0, 3, 0)
+{
+ SCM instance, idx, val;
+ size_t slot;
+ POP (val);
+ POP (idx);
+ POP (instance);
+ slot = SCM_I_INUM (idx);
+ SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
+ NEXT;
+}
+
+
+/*
+ * Bytevectors
+ */
#define VM_VALIDATE_BYTEVECTOR(x) \
if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
{ finish_args = x; \
@@ -402,104 +559,115 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set",
0, 3, 0)
goto VM_LABEL (bv_##stem##_native_ref); \
{ \
ARGS2 (bv, idx); \
+ SYNC_REGISTER (); \
RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
} \
}
-VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3)
+VM_DEFINE_FUNCTION (172, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3)
+VM_DEFINE_FUNCTION (173, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3)
+VM_DEFINE_FUNCTION (174, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3)
+VM_DEFINE_FUNCTION (175, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3)
+VM_DEFINE_FUNCTION (176, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3)
+VM_DEFINE_FUNCTION (177, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3)
+VM_DEFINE_FUNCTION (178, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3)
+VM_DEFINE_FUNCTION (179, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
-#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
-{ \
- long i = 0; \
- ARGS2 (bv, idx); \
- VM_VALIDATE_BYTEVECTOR (bv); \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && ((i = SCM_I_INUM (idx)) >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (i % size == 0))) \
- RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \
- (SCM_BYTEVECTOR_CONTENTS (bv) + i))); \
- else \
- RETURN (scm_bytevector_##fn_stem##_ref (bv, idx)); \
-}
-
-#define BV_INT_REF(stem, type, size) \
-{ \
- long i = 0; \
- ARGS2 (bv, idx); \
- VM_VALIDATE_BYTEVECTOR (bv); \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && ((i = SCM_I_INUM (idx)) >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (i % size == 0))) \
+#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
+{ \
+ long i = 0; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \
+ (SCM_BYTEVECTOR_CONTENTS (bv) + i))); \
+ else \
+ { \
+ SYNC_REGISTER ();
\
+ RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
+ } \
+}
+
+#define BV_INT_REF(stem, type, size) \
+{ \
+ long i = 0; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
{ scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \
- if (SCM_FIXABLE (x)) \
- RETURN (SCM_I_MAKINUM (x)); \
- else \
- RETURN (scm_from_##type (x)); \
- } \
- else \
- RETURN (scm_bytevector_##stem##_native_ref (bv, idx)); \
-}
-
-#define BV_FLOAT_REF(stem, fn_stem, type, size) \
-{ \
- long i = 0; \
- ARGS2 (bv, idx); \
- VM_VALIDATE_BYTEVECTOR (bv); \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && ((i = SCM_I_INUM (idx)) >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (i % size == 0))) \
+ if (SCM_FIXABLE (x)) \
+ RETURN (SCM_I_MAKINUM (x)); \
+ else \
+ { \
+ SYNC_REGISTER (); \
+ RETURN (scm_from_ ## type (x)); \
+ } \
+ } \
+ else \
+ { \
+ SYNC_REGISTER ();
\
+ RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
+ } \
+}
+
+#define BV_FLOAT_REF(stem, fn_stem, type, size)
\
+{ \
+ long i = 0; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ SYNC_REGISTER (); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \
- else \
- RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \
+ else \
+ RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
-VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2)
+VM_DEFINE_FUNCTION (180, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2)
+VM_DEFINE_FUNCTION (181, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2)
+VM_DEFINE_FUNCTION (182, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
+VM_DEFINE_FUNCTION (183, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
+VM_DEFINE_FUNCTION (184, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
-VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
+VM_DEFINE_FUNCTION (185, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
-VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
+VM_DEFINE_FUNCTION (186, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
+VM_DEFINE_FUNCTION (187, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2)
+VM_DEFINE_FUNCTION (188, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2)
+VM_DEFINE_FUNCTION (189, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
@@ -521,21 +689,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
} \
}
-VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (190, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (191, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (192, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (193, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (194, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (195, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (196, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (197, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
@@ -588,79 +756,45 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (198, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (199, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (200, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (201, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX,
2)
-VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (202, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
-VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (203, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX,
4)
#else
BV_INT_SET (s32, int32, 4)
#endif
-VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (204, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (205, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (206, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (207, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET
#undef BV_INT_SET
#undef BV_FLOAT_SET
-#define VM_VALIDATE_STRUCT(obj) \
- if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
- { \
- finish_args = (obj); \
- goto vm_error_not_a_struct; \
- }
-
-VM_DEFINE_FUNCTION (174, struct_p, "struct?", 1)
-{
- ARGS1 (obj);
- RETURN (scm_from_bool (SCM_STRUCTP (obj)));
-}
-
-VM_DEFINE_FUNCTION (175, struct_vtable, "struct-vtable", 1)
-{
- ARGS1 (obj);
- VM_VALIDATE_STRUCT (obj);
- RETURN (SCM_STRUCT_VTABLE (obj));
-}
-
-VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- int n_args = ((h << 8U) + l);
- SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
- const SCM *inits = sp - n_args + 3;
-
- sp -= n_args - 1;
-
- RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
- n_args - 2, (scm_t_bits *) inits));
-}
-
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
- (let ((counter 99)) (goto-char (point-min))
+ (let ((counter 127)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 09da85f..c1d9491 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010 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,7 @@ VM_DEFINE_INSTRUCTION (19, vector, "vector", 2, -1, 1)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
-#define FREE_VARIABLE_REF(i) free_vars[i]
+#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
/* ref */
@@ -322,7 +322,7 @@ VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0,
1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 1, 1)
{
if (VARIABLE_BOUNDP (*sp))
*sp = SCM_BOOL_T;
@@ -484,12 +484,12 @@ VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0)
VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0)
{
- BR (scm_is_true_and_not_nil (*sp));
+ BR (scm_is_true (*sp));
}
VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0)
{
- BR (scm_is_false_or_nil (*sp));
+ BR (scm_is_false (*sp));
}
VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0)
@@ -506,12 +506,12 @@ VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq",
3, 0, 0)
VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0)
{
- BR (scm_is_null_or_nil (*sp));
+ BR (scm_is_null (*sp));
}
VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
- BR (!scm_is_null_or_nil (*sp));
+ BR (!scm_is_null (*sp));
}
@@ -744,83 +744,70 @@ VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0,
3)
VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
{
- SCM x;
nargs = FETCH ();
vm_call:
- x = sp[-nargs];
+ program = sp[-nargs];
VM_HANDLE_INTERRUPTS;
- /*
- * Subprogram call
- */
- if (SCM_PROGRAM_P (x))
- {
- program = x;
- CACHE_PROGRAM ();
- fp = sp - nargs + 1;
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- ip = SCM_C_OBJCODE_BASE (bp);
- ENTER_HOOK ();
- APPLY_HOOK ();
- NEXT;
- }
- if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
- goto vm_call;
- }
- /*
- * Other interpreted or compiled call
- */
- if (!scm_is_false (scm_procedure_p (x)))
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
{
- SCM ret;
- /* At this point, the stack contains the frame, the procedure and each
one
- of its arguments. */
- SYNC_REGISTER ();
- ret = apply_foreign (sp[-nargs],
- sp - nargs + 1,
- nargs,
- vp->stack_limit - sp + 1);
- NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROPN (nargs + 1); /* drop args and procedure */
- DROP_FRAME ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+ if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
{
- /* truncate values */
- ret = scm_struct_ref (ret, SCM_INUM0);
- if (scm_is_null (ret))
- goto vm_error_not_enough_values;
- PUSH (SCM_CAR (ret));
+ 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
- PUSH (ret);
- NEXT;
+ goto vm_error_wrong_type_apply;
}
- program = x;
- goto vm_error_wrong_type_apply;
+ CACHE_PROGRAM ();
+ fp = sp - nargs + 1;
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
+ ip = SCM_C_OBJCODE_BASE (bp);
+ ENTER_HOOK ();
+ APPLY_HOOK ();
+ NEXT;
}
-VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
{
- register SCM x;
nargs = FETCH ();
- vm_goto_args:
- x = sp[-nargs];
+
+ vm_tail_call:
+ program = sp[-nargs];
VM_HANDLE_INTERRUPTS;
- /*
- * Tail call
- */
- if (SCM_PROGRAM_P (x))
+ 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;
#ifdef VM_ENABLE_STACK_NULLING
@@ -831,7 +818,6 @@ VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1, -1, 1)
EXIT_HOOK ();
/* switch programs */
- program = x;
CACHE_PROGRAM ();
/* shuffle down the program and the arguments */
for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
@@ -847,55 +833,205 @@ VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1,
-1, 1)
APPLY_HOOK ();
NEXT;
}
- if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
+}
+
+VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1)
+{
+ SCM foreign, ret;
+ SCM (*subr)();
+ nargs = FETCH ();
+ POP (foreign);
+
+ subr = SCM_FOREIGN_POINTER (foreign, void);
+
+ VM_HANDLE_INTERRUPTS;
+ SYNC_REGISTER ();
+
+ switch (nargs)
{
- sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
- goto vm_goto_args;
+ case 0:
+ ret = subr ();
+ break;
+ case 1:
+ ret = subr (sp[0]);
+ break;
+ case 2:
+ ret = subr (sp[-1], sp[0]);
+ break;
+ case 3:
+ ret = subr (sp[-2], sp[-1], sp[0]);
+ break;
+ case 4:
+ ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
+ break;
+ case 5:
+ ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+ break;
+ case 6:
+ ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+ break;
+ case 7:
+ ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+ break;
+ case 8:
+ ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1],
sp[0]);
+ break;
+ case 9:
+ ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2],
sp[-1], sp[0]);
+ break;
+ case 10:
+ ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3],
sp[-2], sp[-1], sp[0]);
+ break;
+ default:
+ abort ();
}
- /*
- * Other interpreted or compiled call
- */
- if (!scm_is_false (scm_procedure_p (x)))
+
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
{
- SCM ret;
- SYNC_REGISTER ();
- ret = apply_foreign (sp[-nargs],
- sp - nargs + 1,
- nargs,
- vp->stack_limit - sp + 1);
- NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROPN (nargs + 1); /* drop args and procedure */
+ /* multiple values returned to continuation */
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ nvalues = scm_ilength (ret);
+ PUSH_LIST (ret, scm_is_null);
+ goto vm_return_values;
+ }
+ else
+ {
+ PUSH (ret);
+ goto vm_return;
+ }
+}
+
+VM_DEFINE_INSTRUCTION (57, smob_call, "smob-call", 1, -1, -1)
+{
+ SCM smob, ret;
+ SCM (*subr)();
+ nargs = FETCH ();
+ POP (smob);
+
+ subr = SCM_SMOB_DESCRIPTOR (smob).apply;
+
+ VM_HANDLE_INTERRUPTS;
+ SYNC_REGISTER ();
+
+ switch (nargs)
+ {
+ case 0:
+ ret = subr (smob);
+ break;
+ case 1:
+ ret = subr (smob, sp[0]);
+ break;
+ case 2:
+ ret = subr (smob, sp[-1], sp[0]);
+ break;
+ case 3:
+ ret = subr (smob, sp[-2], sp[-1], sp[0]);
+ break;
+ default:
+ abort ();
+ }
+
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+ {
+ /* multiple values returned to continuation */
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ nvalues = scm_ilength (ret);
+ PUSH_LIST (ret, scm_is_null);
+ goto vm_return_values;
}
+ else
+ {
+ PUSH (ret);
+ goto vm_return;
+ }
+}
- program = x;
+VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1)
+{
+ SCM foreign, ret;
+ nargs = FETCH ();
+ POP (foreign);
- goto vm_error_wrong_type_apply;
+ VM_HANDLE_INTERRUPTS;
+ SYNC_REGISTER ();
+
+ ret = scm_i_foreign_call (foreign, sp - nargs + 1);
+
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+ {
+ /* multiple values returned to continuation */
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ nvalues = scm_ilength (ret);
+ PUSH_LIST (ret, scm_is_null);
+ goto vm_return_values;
+ }
+ else
+ {
+ PUSH (ret);
+ goto vm_return;
+ }
+}
+
+VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0)
+{
+ SCM contregs;
+ POP (contregs);
+
+ SYNC_ALL ();
+ scm_i_check_continuation (contregs);
+ vm_return_to_continuation (scm_i_contregs_vm (contregs),
+ scm_i_contregs_vm_cont (contregs),
+ sp - (fp - 1), fp);
+ scm_i_reinstate_continuation (contregs);
+
+ /* no NEXT */
+ abort ();
+}
+
+VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
+{
+ SCM vmcont, intwinds, prevwinds;
+ POP (intwinds);
+ POP (vmcont);
+ SYNC_REGISTER ();
+ if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
+ { finish_args = vmcont;
+ goto vm_error_continuation_not_rewindable;
+ }
+ prevwinds = scm_i_dynwinds ();
+ vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
+ vm_cookie);
+
+ /* Rewind prompt jmpbuffers, if any. */
+ {
+ SCM winds = scm_i_dynwinds ();
+ for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
+ if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car
(winds)))
+ break;
+ }
+
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ NEXT;
}
-VM_DEFINE_INSTRUCTION (56, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (59, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
nargs = scm_to_int (x);
/* FIXME: should truncate values? */
- goto vm_goto_args;
+ goto vm_tail_call;
}
-VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (60, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -904,9 +1040,8 @@ VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0,
1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
+VM_DEFINE_INSTRUCTION (61, mv_call, "mv-call", 4, -1, 1)
{
- SCM x;
scm_t_int32 offset;
scm_t_uint8 *mvra;
@@ -915,66 +1050,41 @@ VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
mvra = ip + offset;
vm_mv_call:
- x = sp[-nargs];
+ program = sp[-nargs];
- /*
- * Subprogram call
- */
- if (SCM_PROGRAM_P (x))
- {
- program = x;
- CACHE_PROGRAM ();
- fp = sp - nargs + 1;
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- ip = SCM_C_OBJCODE_BASE (bp);
- ENTER_HOOK ();
- APPLY_HOOK ();
- NEXT;
- }
- if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
- goto vm_mv_call;
- }
- /*
- * Other interpreted or compiled call
- */
- if (!scm_is_false (scm_procedure_p (x)))
+ VM_HANDLE_INTERRUPTS;
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
{
- SCM ret;
- /* At this point, the stack contains the frame, the procedure and each
one
- of its arguments. */
- SYNC_REGISTER ();
- ret = apply_foreign (sp[-nargs],
- sp - nargs + 1,
- nargs,
- vp->stack_limit - sp + 1);
- NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROPN (nargs + 1); /* drop args and procedure */
- DROP_FRAME ();
-
- if (SCM_VALUESP (ret))
+ 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))
{
- SCM len;
- ret = scm_struct_ref (ret, SCM_INUM0);
- len = scm_length (ret);
- PUSH_LIST (ret, scm_is_null);
- PUSH (len);
- ip = mvra;
+ SYNC_REGISTER ();
+ sp[-nargs] = scm_i_smob_apply_trampoline (program);
+ goto vm_mv_call;
}
else
- PUSH (ret);
- NEXT;
+ goto vm_error_wrong_type_apply;
}
- program = x;
- goto vm_error_wrong_type_apply;
+ CACHE_PROGRAM ();
+ fp = sp - nargs + 1;
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+ ip = SCM_C_OBJCODE_BASE (bp);
+ ENTER_HOOK ();
+ APPLY_HOOK ();
+ NEXT;
}
-VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (62, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -993,7 +1103,7 @@ VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (60, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -1009,16 +1119,17 @@ VM_DEFINE_INSTRUCTION (60, goto_apply, "goto/apply", 1,
-1, 1)
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
nargs += len - 2;
- goto vm_goto_args;
+ goto vm_tail_call;
}
-VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
{
int first;
- SCM proc, cont;
+ SCM proc, vm_cont, cont;
POP (proc);
SYNC_ALL ();
- cont = scm_make_continuation (&first);
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
+ cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
PUSH ((SCM)fp); /* dynamic link */
@@ -1029,63 +1140,56 @@ VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
nargs = 1;
goto vm_call;
}
- ASSERT (sp == vp->sp);
- ASSERT (fp == vp->fp);
- else if (SCM_VALUESP (cont))
+ else
{
- /* multiple values returned to continuation */
- SCM values;
- values = scm_struct_ref (cont, SCM_INUM0);
- if (scm_is_null (values))
- goto vm_error_no_values;
- /* non-tail context does not accept multiple values? */
- PUSH (SCM_CAR (values));
- NEXT;
- }
- else
- {
- PUSH (cont);
+ /* otherwise, the vm continuation was reinstated, and
+ scm_i_vm_return_to_continuation pushed on one value. So pull our regs
+ back down from the vp, and march on to the next instruction. */
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
NEXT;
}
}
-VM_DEFINE_INSTRUCTION (62, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
int first;
- SCM proc, cont;
+ SCM proc, vm_cont, cont;
POP (proc);
SYNC_ALL ();
- cont = scm_make_continuation (&first);
- ASSERT (sp == vp->sp);
- ASSERT (fp == vp->fp);
+ /* In contrast to call/cc, tail-call/cc captures the continuation without the
+ stack frame. */
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base,
+ SCM_FRAME_DYNAMIC_LINK (fp),
+ SCM_FRAME_LOWER_ADDRESS (fp) - 1,
+ SCM_FRAME_RETURN_ADDRESS (fp),
+ SCM_FRAME_MV_RETURN_ADDRESS (fp),
+ 0);
+ cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
PUSH (proc);
PUSH (cont);
nargs = 1;
- goto vm_goto_args;
- }
- else if (SCM_VALUESP (cont))
- {
- /* multiple values returned to continuation */
- SCM values;
- values = scm_struct_ref (cont, SCM_INUM0);
- nvalues = scm_ilength (values);
- PUSH_LIST (values, scm_is_null);
- goto vm_return_values;
+ goto vm_tail_call;
}
else
{
- PUSH (cont);
- goto vm_return;
+ /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
+ does a return from the frame, either to the RA or MVRA. */
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ NEXT;
}
}
-VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
- RETURN_HOOK ();
+ RETURN_HOOK (1);
VM_HANDLE_INTERRUPTS;
@@ -1118,14 +1222,16 @@ VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (67, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say.
*/
nvalues = FETCH ();
vm_return_values:
EXIT_HOOK ();
- RETURN_HOOK ();
+ RETURN_HOOK (nvalues);
+
+ VM_HANDLE_INTERRUPTS;
if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
@@ -1173,7 +1279,7 @@ VM_DEFINE_INSTRUCTION (64, return_values,
"return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (65, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (68, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1196,7 +1302,16 @@ VM_DEFINE_INSTRUCTION (65, return_values_star,
"return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (66, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (88, return_nvalues, "return/nvalues", 0, 1, -1)
+{
+ SCM n;
+ POP (n);
+ nvalues = scm_to_int (n);
+ ASSERT (nvalues >= 0);
+ goto vm_return_values;
+}
+
+VM_DEFINE_INSTRUCTION (69, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1219,7 +1334,7 @@ VM_DEFINE_INSTRUCTION (66, truncate_values,
"truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (70, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1233,7 +1348,7 @@ VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (71, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1241,7 +1356,7 @@ VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0,
0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (69, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (72, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1249,7 +1364,7 @@ VM_DEFINE_INSTRUCTION (69, local_boxed_ref,
"local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (70, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (73, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1259,7 +1374,7 @@ VM_DEFINE_INSTRUCTION (70, local_boxed_set,
"local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (74, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1270,7 +1385,7 @@ VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (72, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (75, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1281,7 +1396,7 @@ VM_DEFINE_INSTRUCTION (72, free_boxed_ref,
"free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (73, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (76, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1293,18 +1408,26 @@ VM_DEFINE_INSTRUCTION (73, free_boxed_set,
"free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (77, make_closure, "make-closure", 2, -1, 1)
{
- SCM vect;
- POP (vect);
+ size_t n, len;
+ SCM closure;
+
+ len = FETCH ();
+ len <<= 8;
+ len += FETCH ();
SYNC_BEFORE_GC ();
- /* fixme underflow */
- *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE
(*sp),
- (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp),
(scm_t_bits)vect);
+ closure = scm_words (scm_tc7_program | (len<<16), len + 3);
+ SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
+ SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
+ sp[-len] = closure;
+ for (n = 0; n < len; n++)
+ SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
+ DROPN (len);
NEXT;
}
-VM_DEFINE_INSTRUCTION (75, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (78, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1312,21 +1435,24 @@ VM_DEFINE_INSTRUCTION (75, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (79, fix_closure, "fix-closure", 2, -1, 0)
{
- SCM x, vect;
+ SCM x;
unsigned int i = FETCH ();
+ size_t n, len;
i <<= 8;
i += FETCH ();
- POP (vect);
/* FIXME CHECK_LOCAL (i) */
x = LOCAL_REF (i);
/* FIXME ASSERT_PROGRAM (x); */
- SCM_SET_CELL_WORD_3 (x, vect);
+ len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
+ for (n = 0; n < len; n++)
+ SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
+ DROPN (len);
NEXT;
}
-VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (80, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1338,7 +1464,7 @@ VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (81, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1346,7 +1472,7 @@ VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword",
0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1354,6 +1480,148 @@ VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol",
0, 1, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
+{
+ scm_t_int32 offset;
+ scm_t_uint8 escape_only_p;
+ SCM k, prompt;
+
+ escape_only_p = FETCH ();
+ FETCH_OFFSET (offset);
+ POP (k);
+
+ SYNC_REGISTER ();
+ /* Push the prompt onto the dynamic stack. */
+ prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
+ scm_i_dynwinds ());
+ scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
+ if (SCM_PROMPT_SETJMP (prompt))
+ {
+ /* The prompt exited nonlocally. Cache the regs back from the vp, and go
+ to the handler.
+
+ Note, at this point, we must assume that any variable local to
+ vm_engine that can be assigned *has* been assigned. So we need to pull
+ all our state back from the ip/fp/sp.
+ */
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ NEXT;
+ }
+
+ /* Otherwise setjmp returned for the first time, so we go to execute the
+ prompt's body. */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
+{
+ SCM wind, unwind;
+ POP (unwind);
+ POP (wind);
+ SYNC_REGISTER ();
+ /* 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;
+ }
+ scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1)
+{
+ unsigned n = FETCH ();
+ SYNC_REGISTER ();
+ if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
+ goto vm_error_stack_underflow;
+ vm_abort (vm, n, vm_cookie);
+ /* vm_abort should not return */
+ abort ();
+}
+
+VM_DEFINE_INSTRUCTION (87, unwind, "unwind", 0, 0, 0)
+{
+ /* A normal exit from the dynamic extent of an expression. Pop the top entry
+ off of the dynamic stack. */
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (90, wind_fluids, "wind-fluids", 1, -1, 0)
+{
+ unsigned n = FETCH ();
+ SCM wf;
+
+ if (sp - 2*n < SCM_FRAME_UPPER_ADDRESS (fp))
+ goto vm_error_stack_underflow;
+
+ SYNC_REGISTER ();
+ wf = scm_i_make_with_fluids (n, sp + 1 - 2*n, sp + 1 - n);
+ scm_i_swap_with_fluids (wf, dynstate);
+ scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (91, unwind_fluids, "unwind-fluids", 0, 0, 0)
+{
+ SCM wf;
+ wf = scm_car (scm_i_dynwinds ());
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_i_swap_with_fluids (wf, dynstate);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (92, fluid_ref, "fluid-ref", 0, 1, 1)
+{
+ size_t num;
+ SCM fluids;
+
+ CHECK_UNDERFLOW ();
+ fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
+ if (SCM_UNLIKELY (!SCM_I_FLUID_P (*sp))
+ || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ {
+ /* Punt dynstate expansion and error handling to the C proc. */
+ SYNC_REGISTER ();
+ *sp = scm_fluid_ref (*sp);
+ }
+ else
+ *sp = SCM_SIMPLE_VECTOR_REF (fluids, num);
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (93, fluid_set, "fluid-set", 0, 2, 0)
+{
+ size_t num;
+ SCM val, fluid, fluids;
+
+ POP (val);
+ POP (fluid);
+ fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
+ if (SCM_UNLIKELY (!SCM_I_FLUID_P (fluid))
+ || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH
(fluids)))
+ {
+ /* Punt dynstate expansion and error handling to the C proc. */
+ SYNC_REGISTER ();
+ scm_fluid_set_x (fluid, val);
+ }
+ else
+ SCM_SIMPLE_VECTOR_SET (fluids, num, val);
+
+ NEXT;
+}
+
/*
(defun renumber-ops ()
diff --git a/libguile/vm.c b/libguile/vm.c
index cac3354..54a143e 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 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
@@ -28,12 +28,11 @@
#include <gc/gc_mark.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
+#include "control.h"
#include "frames.h"
#include "instructions.h"
#include "objcodes.h"
#include "programs.h"
-#include "lang.h" /* NULL_OR_NIL_P */
#include "vm.h"
/* I sometimes use this for debugging. */
@@ -72,98 +71,236 @@
* VM Continuation
*/
-scm_t_bits scm_tc16_vm_cont;
+void
+scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm-continuation ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
-static SCM
-capture_vm_cont (struct scm_vm *vp)
+/* In theory, a number of vm instances can be active in the call trace, and we
+ only want to reify the continuations of those in the current continuation
+ root. I don't see a nice way to do this -- ideally it would involve
dynwinds,
+ and previous values of the *the-vm* fluid within the current continuation
+ root. But we don't have access to continuation roots in the dynwind stack.
+ So, just punt for now, we just capture the continuation for the current VM.
+
+ While I'm on the topic, ideally we could avoid copying the C stack if the
+ continuation root is inside VM code, and call/cc was invoked within that
same
+ call to vm_run; but that's currently not implemented.
+ */
+SCM
+scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
+ scm_t_uint8 *mvra, scm_t_uint32 flags)
{
- struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
- p->stack_size = vp->sp - vp->stack_base + 1;
+ struct scm_vm_cont *p;
+
+ p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = sp - stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
-#ifdef VM_ENABLE_STACK_NULLING
- if (vp->sp >= vp->stack_base)
+#if defined(VM_ENABLE_STACK_NULLING) && 0
+ /* Tail continuations leave their frame on the stack for subsequent
+ application, but don't capture the frame -- so there are some elements on
+ the stack then, and this check doesn't work, so disable it for now. */
+ if (sp >= vp->stack_base)
if (!vp->sp[0] || vp->sp[1])
abort ();
memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
#endif
- p->ip = vp->ip;
- p->sp = vp->sp;
- p->fp = vp->fp;
- memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
- p->reloc = p->stack_base - vp->stack_base;
- SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+ p->ra = ra;
+ p->mvra = mvra;
+ p->sp = sp;
+ p->fp = fp;
+ memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
+ p->reloc = p->stack_base - stack_base;
+ p->flags = flags;
+ return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
static void
-reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
- if (vp->stack_size < p->stack_size)
- {
- /* puts ("FIXME: Need to expand"); */
- abort ();
- }
+ struct scm_vm *vp;
+ struct scm_vm_cont *cp;
+ SCM *argv_copy;
+
+ argv_copy = alloca (n * sizeof(SCM));
+ memcpy (argv_copy, argv, n * sizeof(SCM));
+
+ vp = SCM_VM_DATA (vm);
+ cp = SCM_VM_CONT_DATA (cont);
+
+ if (n == 0 && !cp->mvra)
+ scm_misc_error (NULL, "Too few values returned to continuation",
+ SCM_EOL);
+
+ if (vp->stack_size < cp->stack_size + n + 1)
+ scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
+ scm_list_2 (vm, cont));
+
#ifdef VM_ENABLE_STACK_NULLING
{
- scm_t_ptrdiff nzero = (vp->sp - p->sp);
+ scm_t_ptrdiff nzero = (vp->sp - cp->sp);
if (nzero > 0)
- memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+ memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
/* actually nzero should always be negative, because vm_reset_stack will
unwind the stack to some point *below* this continuation */
}
#endif
- vp->ip = p->ip;
- vp->sp = p->sp;
- vp->fp = p->fp;
- memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
-}
+ vp->sp = cp->sp;
+ vp->fp = cp->fp;
+ memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
-/* In theory, a number of vm instances can be active in the call trace, and we
- only want to reify the continuations of those in the current continuation
- root. I don't see a nice way to do this -- ideally it would involve
dynwinds,
- and previous values of the *the-vm* fluid within the current continuation
- root. But we don't have access to continuation roots in the dynwind stack.
- So, just punt for now -- take the current value of *the-vm*.
+ if (n == 1 || !cp->mvra)
+ {
+ vp->ip = cp->ra;
+ vp->sp++;
+ *vp->sp = argv_copy[0];
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->sp++;
+ *vp->sp = scm_from_size_t (n);
+ vp->ip = cp->mvra;
+ }
+}
- While I'm on the topic, ideally we could avoid copying the C stack if the
- continuation root is inside VM code, and call/cc was invoked within that
same
- call to vm_run; but that's currently not implemented.
- */
SCM
-scm_vm_capture_continuations (void)
+scm_i_vm_capture_continuation (SCM vm)
{
- SCM vm = scm_the_vm ();
- return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL,
0);
}
-void
-scm_vm_reinstate_continuations (SCM conts)
+static void
+vm_dispatch_hook (SCM vm, int hook_num)
{
- for (; conts != SCM_EOL; conts = SCM_CDR (conts))
- reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
+ struct scm_vm *vp;
+ SCM hook;
+ SCM frame;
+
+ vp = SCM_VM_DATA (vm);
+ hook = vp->hooks[hook_num];
+
+ if (SCM_LIKELY (scm_is_false (hook))
+ || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
+ return;
+
+ vp->trace_level--;
+ frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
+ scm_c_run_hookn (hook, &frame, 1);
+ vp->trace_level++;
}
-static void enfalsen_frame (void *p)
-{
- struct scm_vm *vp = p;
- vp->trace_frame = SCM_BOOL_F;
+static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
+static void
+vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
+{
+ size_t i;
+ ssize_t tail_len;
+ SCM tag, tail, *argv;
+
+ /* FIXME: VM_ENABLE_STACK_NULLING */
+ tail = *(SCM_VM_DATA (vm)->sp--);
+ /* NULLSTACK (1) */
+ tail_len = scm_ilength (tail);
+ if (tail_len < 0)
+ scm_misc_error ("vm-engine", "tail values to abort should be a list",
+ scm_list_1 (tail));
+
+ tag = SCM_VM_DATA (vm)->sp[-n];
+ argv = alloca ((n + tail_len) * sizeof (SCM));
+ for (i = 0; i < n; i++)
+ argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
+ for (; i < n + tail_len; i++, tail = scm_cdr (tail))
+ argv[i] = scm_car (tail);
+ /* NULLSTACK (n + 1) */
+ SCM_VM_DATA (vm)->sp -= n + 1;
+
+ scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
}
static void
-vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
+vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
+ size_t n, SCM *argv, scm_t_int64 vm_cookie)
{
- if (!scm_is_false (vp->trace_frame))
- return;
+ struct scm_vm *vp;
+ struct scm_vm_cont *cp;
+ SCM *argv_copy, *base;
+ size_t i;
+
+ argv_copy = alloca (n * sizeof(SCM));
+ memcpy (argv_copy, argv, n * sizeof(SCM));
+
+ vp = SCM_VM_DATA (vm);
+ cp = SCM_VM_CONT_DATA (cont);
+ base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
+
+#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
+
+ if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
+ scm_misc_error ("vm-engine",
+ "not enough space to instate partial continuation",
+ scm_list_2 (vm, cont));
+
+ memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
- scm_dynwind_begin (0);
- /* FIXME, stack holder should be the vm */
- vp->trace_frame = scm_c_make_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
- scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
+ /* now relocate frame pointers */
+ {
+ SCM *fp;
+ for (fp = RELOC (cp->fp);
+ SCM_FRAME_LOWER_ADDRESS (fp) > base;
+ fp = SCM_FRAME_DYNAMIC_LINK (fp))
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
+ }
- scm_c_run_hook (hook, hook_args);
+ vp->sp = base - 1 + cp->stack_size;
+ vp->fp = RELOC (cp->fp);
+ vp->ip = cp->mvra;
- scm_dynwind_end ();
+ /* now push args. ip is in a MV context. */
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->sp++;
+ *vp->sp = scm_from_size_t (n);
+
+ /* Finally, rewind the dynamic state.
+
+ We have to treat prompts specially, because we could be rewinding the
+ dynamic state from a different thread, or just a different position on the
+ C and/or VM stack -- so we need to reset the jump buffers so that an abort
+ comes back here, with appropriately adjusted sp and fp registers. */
+ {
+ long delta = 0;
+ SCM newwinds = scm_i_dynwinds ();
+ for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
+ {
+ SCM x = scm_car (intwinds);
+ if (SCM_PROMPT_P (x))
+ /* the jmpbuf will be reset by our caller */
+ x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
+ RELOC (SCM_PROMPT_REGISTERS (x)->fp),
+ RELOC (SCM_PROMPT_REGISTERS (x)->sp),
+ SCM_PROMPT_REGISTERS (x)->ip,
+ SCM_PROMPT_ESCAPE_P (x),
+ vm_cookie,
+ newwinds);
+ newwinds = scm_cons (x, newwinds);
+ }
+ scm_dowinds (newwinds, delta);
+ }
+#undef RELOC
}
@@ -171,9 +308,17 @@ vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM
hook_args)
* VM Internal functions
*/
-static SCM sym_vm_run;
-static SCM sym_vm_error;
-static SCM sym_debug;
+/* Unfortunately we can't snarf these: snarfed things are only loaded up from
+ (system vm vm), which might not be loaded before an error happens. */
+static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
+
+void
+scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
static SCM
really_make_boot_program (long nargs)
@@ -185,7 +330,9 @@ really_make_boot_program (long nargs)
SCM ret;
if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
- abort ();
+ scm_misc_error ("vm-engine", "too many args when making boot procedure",
+ scm_list_1 (scm_from_long (nargs)));
+
text[1] = (scm_t_uint8)nargs;
bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
@@ -193,8 +340,8 @@ really_make_boot_program (long nargs)
bp->len = sizeof(text);
bp->metalen = 0;
- u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
+ u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
+ sizeof (struct scm_objcode) + sizeof (text));
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
@@ -261,41 +408,6 @@ resolve_variable (SCM what, SCM program_module)
}
}
-static SCM
-apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
-{
- SCM_ASRTGO (SCM_NIMP (proc), badproc);
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badproc;
- switch (nargs)
- {
- case 0:
- return SCM_SMOB_APPLY_0 (proc);
- case 1:
- return SCM_SMOB_APPLY_1 (proc, args[0]);
- case 2:
- return SCM_SMOB_APPLY_2 (proc, args[0], args[1]);
- default:
- {
- SCM arglist = SCM_EOL;
- while (nargs-- > 2)
- arglist = scm_cons (args[nargs], arglist);
- return SCM_SMOB_APPLY_3 (proc, args[0], args[1], arglist);
- }
- }
- case scm_tc7_gsubr:
- return scm_i_gsubr_apply_array (proc, args, nargs, headroom);
- default:
- badproc:
- scm_wrong_type_arg ("apply", SCM_ARG1, proc);
- }
-}
-
-
#define VM_DEFAULT_STACK_SIZE (64 * 1024)
#define VM_NAME vm_regular_engine
@@ -317,8 +429,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
static const scm_t_vm_engine vm_engines[] =
{ vm_regular_engine, vm_debug_engine };
-scm_t_bits scm_tc16_vm;
-
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
/* The GC "kind" for the VM stack. */
@@ -333,16 +443,13 @@ make_vm (void)
int i;
struct scm_vm *vp;
- if (!scm_tc16_vm)
- return SCM_BOOL_F; /* not booted yet */
-
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
vp->stack_size = VM_DEFAULT_STACK_SIZE;
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
- vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM),
- vm_stack_gc_kind);
+ vp->stack_base = (SCM *)
+ GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
/* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
top is. */
@@ -363,10 +470,11 @@ make_vm (void)
vp->fp = NULL;
vp->engine = SCM_VM_DEBUG_ENGINE;
vp->options = SCM_EOL;
+ vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
- vp->trace_frame = SCM_BOOL_F;
- SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
+ vp->cookie = 0;
+ return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME
@@ -406,12 +514,13 @@ SCM
scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
- return vm_engines[vp->engine](vp, program, argv, nargs);
+ return vm_engines[vp->engine](vm, program, argv, nargs);
}
-SCM
-scm_vm_apply (SCM vm, SCM program, SCM args)
-#define FUNC_NAME "scm_vm_apply"
+SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
+ (SCM vm, SCM program, SCM args),
+ "")
+#define FUNC_NAME s_scm_vm_apply
{
SCM *argv;
int i, nargs;
@@ -434,12 +543,6 @@ scm_vm_apply (SCM vm, SCM program, SCM args)
}
#undef FUNC_NAME
-SCM
-scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
-{
- return scm_c_vm_run (vm, thunk, NULL, 0);
-}
-
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
@@ -618,13 +721,24 @@ SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0,
0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_trace_frame
+#define FUNC_NAME s_scm_vm_trace_level
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->trace_frame;
+ return scm_from_int (SCM_VM_DATA (vm)->trace_level);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
+ (SCM vm, SCM level),
+ "")
+#define FUNC_NAME s_scm_set_vm_trace_level_x
+{
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -644,34 +758,15 @@ SCM scm_load_compiled_with_vm (SCM file)
void
scm_bootstrap_vm (void)
{
- static int strappage = 0;
-
- if (strappage)
- return;
-
- scm_bootstrap_frames ();
- scm_bootstrap_instructions ();
- scm_bootstrap_objcodes ();
- scm_bootstrap_programs ();
-
- scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
-
- scm_tc16_vm = scm_make_smob_type ("vm", 0);
- scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
-
- scm_c_define ("load-compiled",
- scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
- scm_load_compiled_with_vm));
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_vm",
+ (scm_t_extension_init_func)scm_init_vm, NULL);
sym_vm_run = scm_from_locale_symbol ("vm-run");
sym_vm_error = scm_from_locale_symbol ("vm-error");
+ sym_keyword_argument_error = scm_from_locale_symbol
("keyword-argument-error");
sym_debug = scm_from_locale_symbol ("debug");
- scm_c_register_extension ("libguile", "scm_init_vm",
- (scm_t_extension_init_func)scm_init_vm, NULL);
-
- strappage = 1;
-
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
GC_new_kind (GC_new_free_list (),
@@ -684,8 +779,6 @@ scm_bootstrap_vm (void)
void
scm_init_vm (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/vm.x"
#endif
diff --git a/libguile/vm.h b/libguile/vm.h
index cbd0c55..8e22d02 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,7 +34,7 @@
struct scm_vm;
-typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int
nargs);
+typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, int nargs);
#define SCM_VM_REGULAR_ENGINE 0
#define SCM_VM_DEBUG_ENGINE 1
@@ -50,20 +50,20 @@ struct scm_vm {
int engine; /* which vm engine we're using */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
SCM options; /* options */
- SCM trace_frame; /* a frame being traced */
+ int trace_level; /* traces enabled if trace_level > 0 */
+ scm_t_int64 cookie; /* used to detect unrewindable continuations */
};
SCM_API SCM scm_the_vm_fluid;
-#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
-#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VM_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
+#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_CELL_WORD_1 (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id);
SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
@@ -83,26 +83,38 @@ SCM_API SCM scm_vm_exit_hook (SCM vm);
SCM_API SCM scm_vm_return_hook (SCM vm);
SCM_API SCM scm_vm_option (SCM vm, SCM key);
SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-SCM_API SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_vm_trace_level (SCM vm);
+SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
+
+#define SCM_F_VM_CONT_PARTIAL 0x1
+#define SCM_F_VM_CONT_REWINDABLE 0x2
struct scm_vm_cont {
- scm_t_uint8 *ip;
SCM *sp;
SCM *fp;
+ scm_t_uint8 *ra, *mvra;
scm_t_ptrdiff stack_size;
SCM *stack_base;
scm_t_ptrdiff reloc;
+ scm_t_uint32 flags;
};
-SCM_API scm_t_bits scm_tc16_vm_cont;
-#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_SMOB_DATA_1 (CONT))
-
-SCM_API SCM scm_vm_capture_continuations (void);
-SCM_API void scm_vm_reinstate_continuations (SCM conts);
+#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) ==
scm_tc7_vm_cont)
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags &
SCM_F_VM_CONT_PARTIAL)
+#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags &
SCM_F_VM_CONT_REWINDABLE)
SCM_API SCM scm_load_compiled_with_vm (SCM file);
+SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
+ scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
+SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
+ scm_t_uint8 *ra, scm_t_uint8 *mvra,
+ scm_t_uint32 flags);
+SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
+ scm_print_state *pstate);
+SCM_INTERNAL void scm_bootstrap_vm (void);
SCM_INTERNAL void scm_init_vm (void);
#endif /* _SCM_VM_H_ */
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 913166f..1d5fcf4 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010 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
@@ -26,7 +26,6 @@
#include "libguile/_scm.h"
#include "libguile/vectors.h"
-#include "libguile/lang.h"
#include "libguile/hashtab.h"
#include "libguile/validate.h"
diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4
index d4d04d1..301469b 100644
--- a/m4/00gnulib.m4
+++ b/m4/00gnulib.m4
@@ -1,5 +1,5 @@
# 00gnulib.m4 serial 2
-dnl Copyright (C) 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2010 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.
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index 4b978e1..f3ee343 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,5 +1,6 @@
# alloca.m4 serial 9
-dnl Copyright (C) 2002-2004, 2006, 2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2006-2007, 2009-2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4
index a6e63df..4360dd8 100644
--- a/m4/arpa_inet_h.m4
+++ b/m4/arpa_inet_h.m4
@@ -1,5 +1,5 @@
-# arpa_inet_h.m4 serial 5
-dnl Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+# arpa_inet_h.m4 serial 7
+dnl Copyright (C) 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -16,20 +16,28 @@ AC_DEFUN([gl_HEADER_ARPA_INET],
if test $ac_cv_header_arpa_inet_h = yes; then
HAVE_ARPA_INET_H=1
else
- ARPA_INET_H='arpa/inet.h'
HAVE_ARPA_INET_H=0
fi
AC_SUBST([HAVE_ARPA_INET_H])
- dnl Execute this unconditionally, because ARPA_INET_H may be set by other
- dnl modules, after this code is executed.
+ dnl <arpa/inet.h> is always overridden, because of GNULIB_POSIXCHECK.
gl_CHECK_NEXT_HEADERS([arpa/inet.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([[
+/* On some systems, this header is not self-consistent. */
+#ifndef __GLIBC__
+# include <sys/socket.h>
+#endif
+#include <arpa/inet.h>
+ ]], [inet_ntop inet_pton])
])
dnl Unconditionally enables the replacement of <arpa/inet.h>.
AC_DEFUN([gl_REPLACE_ARPA_INET_H],
[
- AC_REQUIRE([gl_ARPA_INET_H_DEFAULTS])
- ARPA_INET_H='arpa/inet.h'
+ dnl This is a no-op, because <arpa/inet.h> is always overridden.
+ :
])
AC_DEFUN([gl_ARPA_INET_MODULE_INDICATOR],
@@ -46,5 +54,4 @@ AC_DEFUN([gl_ARPA_INET_H_DEFAULTS],
dnl Assume proper GNU behavior unless another module says otherwise.
HAVE_DECL_INET_NTOP=1; AC_SUBST([HAVE_DECL_INET_NTOP])
HAVE_DECL_INET_PTON=1; AC_SUBST([HAVE_DECL_INET_PTON])
- ARPA_INET_H=''; AC_SUBST([ARPA_INET_H])
])
diff --git a/m4/autobuild.m4 b/m4/autobuild.m4
index a025e73..93ccb54 100644
--- a/m4/autobuild.m4
+++ b/m4/autobuild.m4
@@ -1,5 +1,6 @@
# autobuild.m4 serial 7
-dnl Copyright (C) 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/byteswap.m4 b/m4/byteswap.m4
index ad13f22..2afd6a2 100644
--- a/m4/byteswap.m4
+++ b/m4/byteswap.m4
@@ -1,5 +1,5 @@
# byteswap.m4 serial 3
-dnl Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2007, 2009, 2010 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.
diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4
index 119ebb7..d418de8 100644
--- a/m4/canonicalize.m4
+++ b/m4/canonicalize.m4
@@ -1,6 +1,6 @@
# canonicalize.m4 serial 16
-dnl Copyright (C) 2003-2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003-2007, 2009-2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
diff --git a/m4/codeset.m4 b/m4/codeset.m4
index 413217b..a53c042 100644
--- a/m4/codeset.m4
+++ b/m4/codeset.m4
@@ -1,5 +1,5 @@
# codeset.m4 serial 4 (gettext-0.18)
-dnl Copyright (C) 2000-2002, 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2000-2002, 2006, 2008-2010 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.
diff --git a/m4/dos.m4 b/m4/dos.m4
index 5c3593c..5660542 100644
--- a/m4/dos.m4
+++ b/m4/dos.m4
@@ -3,7 +3,7 @@
# Define some macros required for proper operation of code in lib/*.c
# on MSDOS/Windows systems.
-# Copyright (C) 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+# Copyright (C) 2000-2001, 2004-2006, 2009-2010 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.
diff --git a/m4/double-slash-root.m4 b/m4/double-slash-root.m4
index b982594..66a79c0 100644
--- a/m4/double-slash-root.m4
+++ b/m4/double-slash-root.m4
@@ -1,5 +1,5 @@
# double-slash-root.m4 serial 4 -*- Autoconf -*-
-dnl Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2008-2010 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.
diff --git a/m4/duplocale.m4 b/m4/duplocale.m4
index 7e0a071..a444bfc 100644
--- a/m4/duplocale.m4
+++ b/m4/duplocale.m4
@@ -1,5 +1,5 @@
-# duplocale.m4 serial 1
-dnl Copyright (C) 2009 Free Software Foundation, Inc.
+# duplocale.m4 serial 2
+dnl Copyright (C) 2009, 2010 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.
@@ -41,6 +41,8 @@ int main ()
case "$gl_cv_func_duplocale_works" in
*no) REPLACE_DUPLOCALE=1 ;;
esac
+ else
+ HAVE_DUPLOCALE=0
fi
if test $REPLACE_DUPLOCALE = 1; then
gl_REPLACE_LOCALE_H
diff --git a/m4/eealloc.m4 b/m4/eealloc.m4
index 3c9c0b5..63dd920 100644
--- a/m4/eealloc.m4
+++ b/m4/eealloc.m4
@@ -1,5 +1,5 @@
# eealloc.m4 serial 2
-dnl Copyright (C) 2003, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2009, 2010 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.
diff --git a/m4/environ.m4 b/m4/environ.m4
index 1803820..5f50d6e 100644
--- a/m4/environ.m4
+++ b/m4/environ.m4
@@ -1,5 +1,5 @@
# environ.m4 serial 3
-dnl Copyright (C) 2001-2004, 2006-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2004, 2006-2010 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.
diff --git a/m4/errno_h.m4 b/m4/errno_h.m4
index 4ce1ccb..d02a039 100644
--- a/m4/errno_h.m4
+++ b/m4/errno_h.m4
@@ -1,5 +1,5 @@
# errno_h.m4 serial 6
-dnl Copyright (C) 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2004, 2006, 2008, 2009, 2010 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.
diff --git a/m4/extensions.m4 b/m4/extensions.m4
index 99fba9f..7d9458a 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,7 +1,7 @@
-# serial 8 -*- Autoconf -*-
+# serial 9 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
-# Copyright (C) 2003, 2006-2009 Free Software Foundation, Inc.
+# Copyright (C) 2003, 2006-2010 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.
@@ -12,6 +12,20 @@
# enough in this area it's likely we'll need to redefine
# AC_USE_SYSTEM_EXTENSIONS for quite some time.
+# If autoconf reports a warning
+# warning: AC_COMPILE_IFELSE was called before AC_USE_SYSTEM_EXTENSIONS
+# or warning: AC_RUN_IFELSE was called before AC_USE_SYSTEM_EXTENSIONS
+# the fix is
+# 1) to ensure that AC_USE_SYSTEM_EXTENSIONS is never directly invoked
+# but always AC_REQUIREd,
+# 2) to ensure that for each occurrence of
+# AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+# or
+# AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+# the corresponding gnulib module description has 'extensions' among
+# its dependencies. This will ensure that the gl_USE_SYSTEM_EXTENSIONS
+# invocation occurs in gl_EARLY, not in gl_INIT.
+
# AC_USE_SYSTEM_EXTENSIONS
# ------------------------
# Enable extensions on systems that normally disable them,
diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4
new file mode 100644
index 0000000..67167cb
--- /dev/null
+++ b/m4/fcntl-o.m4
@@ -0,0 +1,81 @@
+# fcntl-o.m4 serial 1
+dnl Copyright (C) 2006, 2009, 2010 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl Written by Paul Eggert.
+
+# Test whether the flags O_NOATIME and O_NOFOLLOW actually work.
+# Define HAVE_WORKING_O_NOATIME to 1 if O_NOATIME works, or to 0 otherwise.
+# Define HAVE_WORKING_O_NOFOLLOW to 1 if O_NOFOLLOW works, or to 0 otherwise.
+AC_DEFUN([gl_FCNTL_O_FLAGS],
+[
+ dnl Persuade glibc <fcntl.h> to define O_NOATIME and O_NOFOLLOW.
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+ AC_CACHE_CHECK([for working fcntl.h], [gl_cv_header_working_fcntl_h],
+ [AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/types.h>
+ #include <sys/stat.h>
+ #include <unistd.h>
+ #include <fcntl.h>
+ #ifndef O_NOATIME
+ #define O_NOATIME 0
+ #endif
+ #ifndef O_NOFOLLOW
+ #define O_NOFOLLOW 0
+ #endif
+ static int const constants[] =
+ {
+ O_CREAT, O_EXCL, O_NOCTTY, O_TRUNC, O_APPEND,
+ O_NONBLOCK, O_SYNC, O_ACCMODE, O_RDONLY, O_RDWR, O_WRONLY
+ };
+ ]],
+ [[
+ int status = !constants;
+ {
+ static char const sym[] = "conftest.sym";
+ if (symlink (".", sym) != 0
+ || close (open (sym, O_RDONLY | O_NOFOLLOW)) == 0)
+ status |= 32;
+ unlink (sym);
+ }
+ {
+ static char const file[] = "confdefs.h";
+ int fd = open (file, O_RDONLY | O_NOATIME);
+ char c;
+ struct stat st0, st1;
+ if (fd < 0
+ || fstat (fd, &st0) != 0
+ || sleep (1) != 0
+ || read (fd, &c, 1) != 1
+ || close (fd) != 0
+ || stat (file, &st1) != 0
+ || st0.st_atime != st1.st_atime)
+ status |= 64;
+ }
+ return status;]])],
+ [gl_cv_header_working_fcntl_h=yes],
+ [case $? in #(
+ 32) gl_cv_header_working_fcntl_h='no (bad O_NOFOLLOW)';; #(
+ 64) gl_cv_header_working_fcntl_h='no (bad O_NOATIME)';; #(
+ 96) gl_cv_header_working_fcntl_h='no (bad O_NOATIME, O_NOFOLLOW)';; #(
+ *) gl_cv_header_working_fcntl_h='no';;
+ esac],
+ [gl_cv_header_working_fcntl_h=cross-compiling])])
+
+ case $gl_cv_header_working_fcntl_h in #(
+ *O_NOATIME* | no | cross-compiling) ac_val=0;; #(
+ *) ac_val=1;;
+ esac
+ AC_DEFINE_UNQUOTED([HAVE_WORKING_O_NOATIME], [$ac_val],
+ [Define to 1 if O_NOATIME works.])
+
+ case $gl_cv_header_working_fcntl_h in #(
+ *O_NOFOLLOW* | no | cross-compiling) ac_val=0;; #(
+ *) ac_val=1;;
+ esac
+ AC_DEFINE_UNQUOTED([HAVE_WORKING_O_NOFOLLOW], [$ac_val],
+ [Define to 1 if O_NOFOLLOW works.])
+])
diff --git a/m4/fcntl_h.m4 b/m4/fcntl_h.m4
deleted file mode 100644
index 40a1803..0000000
--- a/m4/fcntl_h.m4
+++ /dev/null
@@ -1,108 +0,0 @@
-# serial 6
-# Configure fcntl.h.
-dnl Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
-dnl This file is free software; the Free Software Foundation
-dnl gives unlimited permission to copy and/or distribute it,
-dnl with or without modifications, as long as this notice is preserved.
-
-dnl Written by Paul Eggert.
-
-AC_DEFUN([gl_FCNTL_H],
-[
- AC_REQUIRE([gl_FCNTL_H_DEFAULTS])
- AC_REQUIRE([gl_FCNTL_O_FLAGS])
- gl_CHECK_NEXT_HEADERS([fcntl.h])
- FCNTL_H='fcntl.h'
- AC_SUBST([FCNTL_H])
-])
-
-# Test whether the flags O_NOATIME and O_NOFOLLOW actually work.
-# Define HAVE_WORKING_O_NOATIME to 1 if O_NOATIME works, or to 0 otherwise.
-# Define HAVE_WORKING_O_NOFOLLOW to 1 if O_NOFOLLOW works, or to 0 otherwise.
-AC_DEFUN([gl_FCNTL_O_FLAGS],
-[
- dnl Persuade glibc <fcntl.h> to define O_NOATIME and O_NOFOLLOW.
- AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
- AC_CACHE_CHECK([for working fcntl.h], [gl_cv_header_working_fcntl_h],
- [AC_RUN_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <sys/types.h>
- #include <sys/stat.h>
- #include <unistd.h>
- #include <fcntl.h>
- #ifndef O_NOATIME
- #define O_NOATIME 0
- #endif
- #ifndef O_NOFOLLOW
- #define O_NOFOLLOW 0
- #endif
- static int const constants[] =
- {
- O_CREAT, O_EXCL, O_NOCTTY, O_TRUNC, O_APPEND,
- O_NONBLOCK, O_SYNC, O_ACCMODE, O_RDONLY, O_RDWR, O_WRONLY
- };
- ]],
- [[
- int status = !constants;
- {
- static char const sym[] = "conftest.sym";
- if (symlink (".", sym) != 0
- || close (open (sym, O_RDONLY | O_NOFOLLOW)) == 0)
- status |= 32;
- unlink (sym);
- }
- {
- static char const file[] = "confdefs.h";
- int fd = open (file, O_RDONLY | O_NOATIME);
- char c;
- struct stat st0, st1;
- if (fd < 0
- || fstat (fd, &st0) != 0
- || sleep (1) != 0
- || read (fd, &c, 1) != 1
- || close (fd) != 0
- || stat (file, &st1) != 0
- || st0.st_atime != st1.st_atime)
- status |= 64;
- }
- return status;]])],
- [gl_cv_header_working_fcntl_h=yes],
- [case $? in #(
- 32) gl_cv_header_working_fcntl_h='no (bad O_NOFOLLOW)';; #(
- 64) gl_cv_header_working_fcntl_h='no (bad O_NOATIME)';; #(
- 96) gl_cv_header_working_fcntl_h='no (bad O_NOATIME, O_NOFOLLOW)';; #(
- *) gl_cv_header_working_fcntl_h='no';;
- esac],
- [gl_cv_header_working_fcntl_h=cross-compiling])])
-
- case $gl_cv_header_working_fcntl_h in #(
- *O_NOATIME* | no | cross-compiling) ac_val=0;; #(
- *) ac_val=1;;
- esac
- AC_DEFINE_UNQUOTED([HAVE_WORKING_O_NOATIME], [$ac_val],
- [Define to 1 if O_NOATIME works.])
-
- case $gl_cv_header_working_fcntl_h in #(
- *O_NOFOLLOW* | no | cross-compiling) ac_val=0;; #(
- *) ac_val=1;;
- esac
- AC_DEFINE_UNQUOTED([HAVE_WORKING_O_NOFOLLOW], [$ac_val],
- [Define to 1 if O_NOFOLLOW works.])
-])
-
-AC_DEFUN([gl_FCNTL_MODULE_INDICATOR],
-[
- dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
- AC_REQUIRE([gl_FCNTL_H_DEFAULTS])
-
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
-])
-
-AC_DEFUN([gl_FCNTL_H_DEFAULTS],
-[
- GNULIB_OPEN=0; AC_SUBST([GNULIB_OPEN])
- GNULIB_OPENAT=0; AC_SUBST([GNULIB_OPENAT])
- dnl Assume proper GNU behavior unless another module says otherwise.
- HAVE_OPENAT=1; AC_SUBST([HAVE_OPENAT])
- REPLACE_OPEN=0; AC_SUBST([REPLACE_OPEN])
- REPLACE_OPENAT=0; AC_SUBST([REPLACE_OPENAT])
-])
diff --git a/m4/float_h.m4 b/m4/float_h.m4
index d36e3a4..a74a0d9 100644
--- a/m4/float_h.m4
+++ b/m4/float_h.m4
@@ -1,5 +1,5 @@
# float_h.m4 serial 3
-dnl Copyright (C) 2007 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009, 2010 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.
diff --git a/m4/flock.m4 b/m4/flock.m4
index 96475fc..ca6e24f 100644
--- a/m4/flock.m4
+++ b/m4/flock.m4
@@ -1,5 +1,5 @@
# flock.m4 serial 1
-dnl Copyright (C) 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2010 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.
diff --git a/m4/fpieee.m4 b/m4/fpieee.m4
index 9f4a92c..532802d 100644
--- a/m4/fpieee.m4
+++ b/m4/fpieee.m4
@@ -1,5 +1,5 @@
# fpieee.m4 serial 1
-dnl Copyright (C) 2007 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009, 2010 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.
diff --git a/m4/func.m4 b/m4/func.m4
new file mode 100644
index 0000000..698c528
--- /dev/null
+++ b/m4/func.m4
@@ -0,0 +1,20 @@
+# func.m4 serial 2
+dnl Copyright (C) 2008, 2009, 2010 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.
+
+# Written by Simon Josefsson
+
+AC_DEFUN([gl_FUNC],
+[
+ AC_CACHE_CHECK([whether __func__ is available], [gl_cv_var_func],
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[]], [[const char *str = __func__;]])],
+ [gl_cv_var_func=yes],
+ [gl_cv_var_func=no]))
+ if test "$gl_cv_var_func" != yes; then
+ AC_DEFINE([__func__], ["<unknown function>"],
+ [Define as a replacement for the ISO C99 __func__ variable.])
+ fi
+])
diff --git a/m4/getaddrinfo.m4 b/m4/getaddrinfo.m4
new file mode 100644
index 0000000..05fd2b6
--- /dev/null
+++ b/m4/getaddrinfo.m4
@@ -0,0 +1,173 @@
+# getaddrinfo.m4 serial 22
+dnl Copyright (C) 2004-2010 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_GETADDRINFO],
+[
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])dnl for HAVE_SYS_SOCKET_H, HAVE_WINSOCK2_H
+ AC_REQUIRE([gl_HEADER_NETDB])dnl for HAVE_NETDB_H
+ AC_MSG_NOTICE([checking how to do getaddrinfo, freeaddrinfo and getnameinfo])
+ GETADDRINFO_LIB=
+ gai_saved_LIBS="$LIBS"
+
+ dnl Where is getaddrinfo()?
+ dnl - On Solaris, it is in libsocket.
+ dnl - On Haiku, it is in libnetwork.
+ dnl - On BeOS, it is in libnet.
+ dnl - On native Windows, it is in ws2_32.dll.
+ dnl - Otherwise it is in libc.
+ AC_SEARCH_LIBS([getaddrinfo], [socket network net],
+ [if test "$ac_cv_search_getaddrinfo" != "none required"; then
+ GETADDRINFO_LIB="$ac_cv_search_getaddrinfo"
+ fi])
+ LIBS="$gai_saved_LIBS $GETADDRINFO_LIB"
+
+ AC_CACHE_CHECK([for getaddrinfo], [gl_cv_func_getaddrinfo], [
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([[
+#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_NETDB_H
+#include <netdb.h>
+#endif
+#include <stddef.h>
+]], [[getaddrinfo("", "", NULL, NULL);]])],
+ [gl_cv_func_getaddrinfo=yes],
+ [gl_cv_func_getaddrinfo=no])])
+ if test $gl_cv_func_getaddrinfo = no; then
+ AC_CACHE_CHECK([for getaddrinfo in ws2tcpip.h and -lws2_32],
+ gl_cv_w32_getaddrinfo, [
+ gl_cv_w32_getaddrinfo=no
+ am_save_LIBS="$LIBS"
+ LIBS="$LIBS -lws2_32"
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([[
+#ifdef HAVE_WS2TCPIP_H
+#include <ws2tcpip.h>
+#endif
+#include <stddef.h>
+]], [[getaddrinfo(NULL, NULL, NULL, NULL);]])], [gl_cv_w32_getaddrinfo=yes])
+ LIBS="$am_save_LIBS"
+ ])
+ if test "$gl_cv_w32_getaddrinfo" = "yes"; then
+ GETADDRINFO_LIB="-lws2_32"
+ LIBS="$gai_saved_LIBS $GETADDRINFO_LIB"
+ else
+ AC_LIBOBJ([getaddrinfo])
+ fi
+ fi
+
+ # We can't use AC_REPLACE_FUNCS here because gai_strerror may be an
+ # inline function declared in ws2tcpip.h, so we need to get that
+ # header included somehow.
+ AC_CACHE_CHECK([for gai_strerror (possibly via ws2tcpip.h)],
+ gl_cv_func_gai_strerror, [
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([[
+#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_NETDB_H
+#include <netdb.h>
+#endif
+#ifdef HAVE_WS2TCPIP_H
+#include <ws2tcpip.h>
+#endif
+#include <stddef.h>
+]], [[gai_strerror (NULL);]])],
+ [gl_cv_func_gai_strerror=yes],
+ [gl_cv_func_gai_strerror=no])])
+ if test $gl_cv_func_gai_strerror = no; then
+ AC_LIBOBJ([gai_strerror])
+ fi
+
+ LIBS="$gai_saved_LIBS"
+
+ gl_PREREQ_GETADDRINFO
+
+ AC_SUBST([GETADDRINFO_LIB])
+])
+
+# Prerequisites of lib/netdb.in.h and lib/getaddrinfo.c.
+AC_DEFUN([gl_PREREQ_GETADDRINFO], [
+ AC_REQUIRE([gl_NETDB_H_DEFAULTS])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])dnl for HAVE_SYS_SOCKET_H, HAVE_WINSOCK2_H
+ AC_REQUIRE([gl_HOSTENT]) dnl for HOSTENT_LIB
+ AC_REQUIRE([gl_SERVENT]) dnl for SERVENT_LIB
+ AC_REQUIRE([gl_INET_NTOP]) dnl for INET_NTOP_LIB
+ AC_REQUIRE([AC_C_RESTRICT])
+ AC_REQUIRE([gl_SOCKET_FAMILIES])
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])
+ AC_REQUIRE([AC_C_INLINE])
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+
+ dnl Including sys/socket.h is wrong for Windows, but Windows does not
+ dnl have sa_len so the result is correct anyway.
+ AC_CHECK_MEMBERS([struct sockaddr.sa_len], , , [#include <sys/socket.h>])
+
+ AC_CHECK_HEADERS_ONCE([netinet/in.h])
+
+ AC_CHECK_DECLS([getaddrinfo, freeaddrinfo, gai_strerror, getnameinfo],,,[
+ /* sys/types.h is not needed according to POSIX, but the
+ sys/socket.h in i386-unknown-freebsd4.10 and
+ powerpc-apple-darwin5.5 required it. */
+#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_NETDB_H
+#include <netdb.h>
+#endif
+#ifdef HAVE_WS2TCPIP_H
+#include <ws2tcpip.h>
+#endif
+])
+ if test $ac_cv_have_decl_getaddrinfo = no; then
+ HAVE_DECL_GETADDRINFO=0
+ fi
+ if test $ac_cv_have_decl_freeaddrinfo = no; then
+ HAVE_DECL_FREEADDRINFO=0
+ fi
+ if test $ac_cv_have_decl_gai_strerror = no; then
+ HAVE_DECL_GAI_STRERROR=0
+ fi
+ if test $ac_cv_have_decl_getnameinfo = no; then
+ HAVE_DECL_GETNAMEINFO=0
+ fi
+
+ AC_CHECK_TYPES([struct addrinfo],,,[
+#include <sys/types.h>
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+#ifdef HAVE_NETDB_H
+#include <netdb.h>
+#endif
+#ifdef HAVE_WS2TCPIP_H
+#include <ws2tcpip.h>
+#endif
+])
+ if test $ac_cv_type_struct_addrinfo = no; then
+ HAVE_STRUCT_ADDRINFO=0
+ fi
+
+ dnl Append $HOSTENT_LIB to GETADDRINFO_LIB, avoiding gratuitous duplicates.
+ case " $GETADDRINFO_LIB " in
+ *" $HOSTENT_LIB "*) ;;
+ *) GETADDRINFO_LIB="$GETADDRINFO_LIB $HOSTENT_LIB" ;;
+ esac
+
+ dnl Append $SERVENT_LIB to GETADDRINFO_LIB, avoiding gratuitous duplicates.
+ case " $GETADDRINFO_LIB " in
+ *" $SERVENT_LIB "*) ;;
+ *) GETADDRINFO_LIB="$GETADDRINFO_LIB $SERVENT_LIB" ;;
+ esac
+
+ dnl Append $INET_NTOP_LIB to GETADDRINFO_LIB, avoiding gratuitous duplicates.
+ case " $GETADDRINFO_LIB " in
+ *" $INET_NTOP_LIB "*) ;;
+ *) GETADDRINFO_LIB="$GETADDRINFO_LIB $INET_NTOP_LIB" ;;
+ esac
+])
diff --git a/m4/glibc21.m4 b/m4/glibc21.m4
index 12cddfe..68ada9d 100644
--- a/m4/glibc21.m4
+++ b/m4/glibc21.m4
@@ -1,5 +1,5 @@
# glibc21.m4 serial 4
-dnl Copyright (C) 2000-2002, 2004, 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2000-2002, 2004, 2008-2010 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.
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 31b8f31..53a7892 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -1,4 +1,4 @@
-# Copyright (C) 2002-2009 Free Software Foundation, Inc.
+# Copyright (C) 2002-2010 Free Software Foundation, Inc.
#
# This file is free software, distributed under the terms of the GNU
# General Public License. As a special exception to the GNU General
@@ -15,7 +15,7 @@
# Specification in the form of a command-line invocation:
-# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4
--doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --libtool
--macro-prefix=gl --no-vc-files alignof alloca-opt announce-gen autobuild
byteswap canonicalize-lgpl duplocale environ extensions flock fpieee full-read
full-write gendocs gitlog-to-changelog gnu-web-doc-update gnupload havelib
iconv_open-utf inet_ntop inet_pton lib-symbol-versions lib-symbol-visibility
libunistring locale maintainer-makefile putenv stdlib strcase strftime
striconveh string sys_stat verify version-etc-fsf vsnprintf warnings
+# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4
--doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --libtool
--macro-prefix=gl --no-vc-files alignof alloca-opt announce-gen autobuild
byteswap canonicalize-lgpl duplocale environ extensions flock fpieee full-read
full-write func gendocs getaddrinfo gitlog-to-changelog gnu-web-doc-update
gnupload havelib iconv_open-utf inet_ntop inet_pton lib-symbol-versions
lib-symbol-visibility libunistring locale maintainer-makefile putenv stdlib
strcase strftime striconveh string sys_stat verify version-etc-fsf vsnprintf
warnings
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([])
@@ -33,7 +33,9 @@ gl_MODULES([
fpieee
full-read
full-write
+ func
gendocs
+ getaddrinfo
gitlog-to-changelog
gnu-web-doc-update
gnupload
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 75da53d..80ba263 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,5 +1,5 @@
-# gnulib-common.m4 serial 11
-dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
+# gnulib-common.m4 serial 13
+dnl Copyright (C) 2007-2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -23,14 +23,17 @@ AC_DEFUN([gl_COMMON_BODY], [
# define __GNUC_STDC_INLINE__ 1
#endif])
AH_VERBATIM([unused_parameter],
-[/* Define as a marker that can be attached to function parameter declarations
- for parameters that are not used. This helps to reduce warnings, such as
- from GCC -Wunused-parameter. */
+[/* Define as a marker that can be attached to declarations that might not
+ be used. This helps to reduce warnings, such as from
+ GCC -Wunused-parameter. */
#if __GNUC__ >= 3 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7)
-# define _UNUSED_PARAMETER_ __attribute__ ((__unused__))
+# define _GL_UNUSED __attribute__ ((__unused__))
#else
-# define _UNUSED_PARAMETER_
+# define _GL_UNUSED
#endif
+/* The name _UNUSED_PARAMETER_ is an earlier spelling, although the name
+ is a misnomer outside of parameter lists. */
+#define _UNUSED_PARAMETER_ _GL_UNUSED
])
])
@@ -49,10 +52,25 @@ m4_ifndef([m4_foreach_w],
[m4_define([m4_foreach_w],
[m4_foreach([$1], m4_split(m4_normalize([$2]), [ ]), [$3])])])
+# AS_VAR_IF(VAR, VALUE, [IF-MATCH], [IF-NOT-MATCH])
+# ----------------------------------------------------
+# Backport of autoconf-2.63b's macro.
+# Remove this macro when we can assume autoconf >= 2.64.
+m4_ifndef([AS_VAR_IF],
+[m4_define([AS_VAR_IF],
+[AS_IF([test x"AS_VAR_GET([$1])" = x""$2], [$3], [$4])])])
+
# AC_PROG_MKDIR_P
-# is a backport of autoconf-2.60's AC_PROG_MKDIR_P.
-# Remove this macro when we can assume autoconf >= 2.60.
-m4_ifdef([AC_PROG_MKDIR_P], [], [
+# is a backport of autoconf-2.60's AC_PROG_MKDIR_P, with a fix
+# for interoperability with automake-1.9.6 from autoconf-2.62.
+# Remove this macro when we can assume autoconf >= 2.62 or
+# autoconf >= 2.60 && automake >= 1.10.
+m4_ifdef([AC_PROG_MKDIR_P], [
+ dnl For automake-1.9.6 && autoconf < 2.62: Ensure MKDIR_P is AC_SUBSTed.
+ m4_define([AC_PROG_MKDIR_P],
+ m4_defn([AC_PROG_MKDIR_P])[
+ AC_SUBST([MKDIR_P])])], [
+ dnl For autoconf < 2.60: Backport of AC_PROG_MKDIR_P.
AC_DEFUN_ONCE([AC_PROG_MKDIR_P],
[AC_REQUIRE([AM_PROG_MKDIR_P])dnl defined by automake
MKDIR_P='$(mkdir_p)'
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index de12109..16d6ca6 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -1,5 +1,5 @@
# DO NOT EDIT! GENERATED AUTOMATICALLY!
-# Copyright (C) 2002-2009 Free Software Foundation, Inc.
+# Copyright (C) 2002-2010 Free Software Foundation, Inc.
#
# This file is free software, distributed under the terms of the GNU
# General Public License. As a special exception to the GNU General
@@ -26,14 +26,120 @@ AC_DEFUN([gl_EARLY],
m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable
AC_REQUIRE([AC_PROG_RANLIB])
AC_REQUIRE([AM_PROG_CC_C_O])
+ # Code from module alignof:
+ # Code from module alloca-opt:
+ # Code from module announce-gen:
+ # Code from module arg-nonnull:
+ # Code from module arpa_inet:
+ # Code from module autobuild:
AB_INIT
+ # Code from module byteswap:
+ # Code from module c++defs:
+ # Code from module c-ctype:
+ # Code from module c-strcase:
+ # Code from module c-strcaseeq:
+ # Code from module canonicalize-lgpl:
+ # Code from module configmake:
+ # Code from module duplocale:
+ # Code from module environ:
+ # Code from module errno:
+ # Code from module extensions:
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ # Code from module float:
+ # Code from module flock:
+ # Code from module fpieee:
AC_REQUIRE([gl_FP_IEEE])
+ # Code from module full-read:
+ # Code from module full-write:
+ # Code from module func:
+ # Code from module gendocs:
+ # Code from module getaddrinfo:
+ # Code from module gettext-h:
+ # Code from module gitlog-to-changelog:
+ # Code from module gnu-web-doc-update:
+ # Code from module gnumakefile:
+ # Code from module gnupload:
+ # Code from module gperf:
+ # Code from module havelib:
+ # Code from module hostent:
+ # Code from module iconv:
+ # Code from module iconv-h:
+ # Code from module iconv_open:
+ # Code from module iconv_open-utf:
+ # Code from module include_next:
+ # Code from module inet_ntop:
+ # Code from module inet_pton:
+ # Code from module inline:
+ # Code from module lib-symbol-versions:
+ # Code from module lib-symbol-visibility:
+ # Code from module libunistring:
+ # Code from module localcharset:
+ # Code from module locale:
+ # Code from module lstat:
+ # Code from module maintainer-makefile:
+ # Code from module malloc-posix:
+ # Code from module malloca:
+ # Code from module mbrlen:
+ # Code from module mbrtowc:
+ # Code from module mbsinit:
+ # Code from module memchr:
+ # Code from module multiarch:
+ # Code from module netdb:
+ # Code from module netinet_in:
+ # Code from module pathmax:
+ # Code from module putenv:
+ # Code from module readlink:
+ # Code from module safe-read:
+ # Code from module safe-write:
+ # Code from module servent:
+ # Code from module size_max:
+ # Code from module snprintf:
+ # Code from module socklen:
+ # Code from module ssize_t:
+ # Code from module stat:
+ # Code from module stdarg:
dnl Some compilers (e.g., AIX 5.3 cc) need to be in c99 mode
dnl for the builtin va_copy to work. With Autoconf 2.60 or later,
dnl AC_PROG_CC_STDC arranges for this. With older Autoconf AC_PROG_CC_STDC
dnl shouldn't hurt, though installers are on their own to set c99 mode.
AC_REQUIRE([AC_PROG_CC_STDC])
+ # Code from module stdbool:
+ # Code from module stddef:
+ # 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:
+ # Code from module time:
+ # Code from module time_r:
+ # Code from module unistd:
+ # Code from module unistr/base:
+ # Code from module unistr/u8-mbtouc:
+ # Code from module unistr/u8-mbtouc-unsafe:
+ # Code from module unistr/u8-mbtoucr:
+ # Code from module unistr/u8-prev:
+ # Code from module unistr/u8-uctomb:
+ # Code from module unitypes:
+ # Code from module unused-parameter:
+ # Code from module useless-if-before-free:
+ # Code from module vasnprintf:
+ # Code from module vc-list-files:
+ # Code from module verify:
+ # Code from module version-etc:
+ # Code from module version-etc-fsf:
+ # Code from module vsnprintf:
+ # Code from module warn-on-use:
+ # Code from module warnings:
+ # Code from module wchar:
+ # Code from module write:
+ # Code from module xsize:
])
# This macro should be invoked from ./configure.ac, in the section
@@ -49,24 +155,56 @@ AC_DEFUN([gl_INIT],
m4_pushdef([gl_LIBSOURCES_DIR], [])
gl_COMMON
gl_source_base='lib'
+ # Code from module alignof:
+ # Code from module alloca-opt:
gl_FUNC_ALLOCA
+ # Code from module announce-gen:
+ # Code from module arg-nonnull:
+ # Code from module arpa_inet:
gl_HEADER_ARPA_INET
AC_PROG_MKDIR_P
+ # Code from module autobuild:
+ # Code from module byteswap:
gl_BYTESWAP
+ # Code from module c++defs:
+ # Code from module c-ctype:
+ # Code from module c-strcase:
+ # Code from module c-strcaseeq:
+ # Code from module canonicalize-lgpl:
gl_CANONICALIZE_LGPL
gl_MODULE_INDICATOR([canonicalize-lgpl])
gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name])
gl_STDLIB_MODULE_INDICATOR([realpath])
+ # Code from module configmake:
+ # Code from module duplocale:
gl_FUNC_DUPLOCALE
gl_LOCALE_MODULE_INDICATOR([duplocale])
+ # Code from module environ:
gl_ENVIRON
gl_UNISTD_MODULE_INDICATOR([environ])
+ # Code from module errno:
gl_HEADER_ERRNO_H
+ # Code from module extensions:
+ # Code from module float:
gl_FLOAT_H
+ # Code from module flock:
gl_FUNC_FLOCK
gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock])
+ # Code from module fpieee:
+ # Code from module full-read:
+ # Code from module full-write:
+ # Code from module func:
+ gl_FUNC
+ # Code from module gendocs:
+ # Code from module getaddrinfo:
+ gl_GETADDRINFO
+ gl_NETDB_MODULE_INDICATOR([getaddrinfo])
+ # Code from module gettext-h:
AC_SUBST([LIBINTL])
AC_SUBST([LTLIBINTL])
+ # Code from module gitlog-to-changelog:
+ # Code from module gnu-web-doc-update:
+ # Code from module gnumakefile:
# Autoconf 2.61a.99 and earlier don't support linking a file only
# in VPATH builds. But since GNUmakefile is for maintainer use
# only, it does not matter if we skip the link with older autoconf.
@@ -77,86 +215,172 @@ AC_DEFUN([gl_INIT],
m4_defn([m4_PACKAGE_VERSION])), [1], [],
[AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [],
[GNUmakefile=$GNUmakefile])])
+ # Code from module gnupload:
+ # Code from module gperf:
+ # Code from module havelib:
+ # Code from module hostent:
+ gl_HOSTENT
+ # Code from module iconv:
AM_ICONV
+ # Code from module iconv-h:
gl_ICONV_H
+ # Code from module iconv_open:
gl_FUNC_ICONV_OPEN
+ # Code from module iconv_open-utf:
gl_FUNC_ICONV_OPEN_UTF
+ # Code from module include_next:
+ # Code from module inet_ntop:
gl_INET_NTOP
gl_ARPA_INET_MODULE_INDICATOR([inet_ntop])
+ # Code from module inet_pton:
gl_INET_PTON
gl_ARPA_INET_MODULE_INDICATOR([inet_pton])
+ # Code from module inline:
gl_INLINE
+ # Code from module lib-symbol-versions:
gl_LD_VERSION_SCRIPT
+ # Code from module lib-symbol-visibility:
gl_VISIBILITY
+ # Code from module libunistring:
gl_LIBUNISTRING
+ # Code from module localcharset:
gl_LOCALCHARSET
LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\""
AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
+ # Code from module locale:
gl_LOCALE_H
+ # Code from module lstat:
gl_FUNC_LSTAT
gl_SYS_STAT_MODULE_INDICATOR([lstat])
+ # Code from module maintainer-makefile:
+ AC_CONFIG_COMMANDS_PRE([m4_ifdef([AH_HEADER],
+ [AC_SUBST([CONFIG_INCLUDE], m4_defn([AH_HEADER]))])])
+ # Code from module malloc-posix:
gl_FUNC_MALLOC_POSIX
gl_STDLIB_MODULE_INDICATOR([malloc-posix])
+ # Code from module malloca:
gl_MALLOCA
+ # Code from module mbrlen:
gl_FUNC_MBRLEN
gl_WCHAR_MODULE_INDICATOR([mbrlen])
+ # Code from module mbrtowc:
gl_FUNC_MBRTOWC
gl_WCHAR_MODULE_INDICATOR([mbrtowc])
+ # Code from module mbsinit:
gl_FUNC_MBSINIT
gl_WCHAR_MODULE_INDICATOR([mbsinit])
+ # Code from module memchr:
gl_FUNC_MEMCHR
gl_STRING_MODULE_INDICATOR([memchr])
+ # Code from module multiarch:
gl_MULTIARCH
+ # Code from module netdb:
+ gl_HEADER_NETDB
+ # Code from module netinet_in:
gl_HEADER_NETINET_IN
AC_PROG_MKDIR_P
+ # Code from module pathmax:
gl_PATHMAX
+ # Code from module putenv:
gl_FUNC_PUTENV
gl_STDLIB_MODULE_INDICATOR([putenv])
+ # Code from module readlink:
gl_FUNC_READLINK
gl_UNISTD_MODULE_INDICATOR([readlink])
+ # Code from module safe-read:
gl_SAFE_READ
+ # Code from module safe-write:
gl_SAFE_WRITE
+ # Code from module servent:
+ gl_SERVENT
+ # Code from module size_max:
gl_SIZE_MAX
+ # Code from module snprintf:
+ gl_FUNC_SNPRINTF
+ gl_STDIO_MODULE_INDICATOR([snprintf])
+ # Code from module socklen:
gl_TYPE_SOCKLEN_T
+ # Code from module ssize_t:
gt_TYPE_SSIZE_T
+ # Code from module stat:
gl_FUNC_STAT
gl_SYS_STAT_MODULE_INDICATOR([stat])
+ # Code from module stdarg:
gl_STDARG_H
+ # Code from module stdbool:
AM_STDBOOL_H
+ # Code from module stddef:
gl_STDDEF_H
+ # Code from module stdint:
gl_STDINT_H
+ # Code from module stdio:
gl_STDIO_H
+ # Code from module stdlib:
gl_STDLIB_H
+ # Code from module strcase:
gl_STRCASE
+ # Code from module streq:
+ # Code from module strftime:
gl_FUNC_GNU_STRFTIME
+ # Code from module striconveh:
if test $gl_cond_libtool = false; then
gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV"
gl_libdeps="$gl_libdeps $LIBICONV"
fi
+ # Code from module string:
gl_HEADER_STRING_H
+ # Code from module strings:
gl_HEADER_STRINGS_H
+ # Code from module sys_file:
gl_HEADER_SYS_FILE_H
AC_PROG_MKDIR_P
+ # Code from module sys_socket:
gl_HEADER_SYS_SOCKET
AC_PROG_MKDIR_P
+ # Code from module sys_stat:
gl_HEADER_SYS_STAT_H
AC_PROG_MKDIR_P
+ # Code from module time:
gl_HEADER_TIME_H
+ # Code from module time_r:
gl_TIME_R
+ gl_TIME_MODULE_INDICATOR([time_r])
+ # Code from module unistd:
gl_UNISTD_H
+ # Code from module unistr/base:
+ # Code from module unistr/u8-mbtouc:
gl_MODULE_INDICATOR([unistr/u8-mbtouc])
+ # Code from module unistr/u8-mbtouc-unsafe:
gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe])
+ # Code from module unistr/u8-mbtoucr:
gl_MODULE_INDICATOR([unistr/u8-mbtoucr])
+ # Code from module unistr/u8-prev:
+ # Code from module unistr/u8-uctomb:
gl_MODULE_INDICATOR([unistr/u8-uctomb])
+ # Code from module unitypes:
+ # Code from module unused-parameter:
+ # Code from module useless-if-before-free:
+ # Code from module vasnprintf:
gl_FUNC_VASNPRINTF
+ # Code from module vc-list-files:
+ # Code from module verify:
+ # Code from module version-etc:
gl_VERSION_ETC
+ # Code from module version-etc-fsf:
+ # Code from module vsnprintf:
gl_FUNC_VSNPRINTF
gl_STDIO_MODULE_INDICATOR([vsnprintf])
+ # Code from module warn-on-use:
+ # Code from module warnings:
AC_SUBST([WARN_CFLAGS])
+ # Code from module wchar:
gl_WCHAR_H
+ # Code from module write:
gl_FUNC_WRITE
gl_UNISTD_MODULE_INDICATOR([write])
+ # Code from module xsize:
gl_XSIZE
+ # End of code from modules
m4_ifval(gl_LIBSOURCES_LIST, [
m4_syscmd([test ! -d ]m4_defn([gl_LIBSOURCES_DIR])[ ||
for gl_file in ]gl_LIBSOURCES_LIST[ ; do
@@ -287,14 +511,16 @@ AC_DEFUN([gltests_LIBSOURCES], [
AC_DEFUN([gl_FILE_LIST], [
build-aux/announce-gen
build-aux/arg-nonnull.h
+ build-aux/c++defs.h
build-aux/config.rpath
build-aux/gendocs.sh
build-aux/gitlog-to-changelog
build-aux/gnu-web-doc-update
build-aux/gnupload
- build-aux/link-warning.h
+ build-aux/unused-parameter.h
build-aux/useless-if-before-free
build-aux/vc-list-files
+ build-aux/warn-on-use.h
doc/gendocs_template
lib/alignof.h
lib/alloca.in.h
@@ -318,6 +544,8 @@ AC_DEFUN([gl_FILE_LIST], [
lib/full-read.h
lib/full-write.c
lib/full-write.h
+ lib/gai_strerror.c
+ lib/getaddrinfo.c
lib/gettext.h
lib/iconv.c
lib/iconv.in.h
@@ -344,6 +572,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/mbsinit.c
lib/memchr.c
lib/memchr.valgrind
+ lib/netdb.in.h
lib/netinet_in.in.h
lib/pathmax.h
lib/printf-args.c
@@ -359,6 +588,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/safe-write.c
lib/safe-write.h
lib/size_max.h
+ lib/snprintf.c
lib/stat.c
lib/stdarg.in.h
lib/stdbool.in.h
@@ -416,12 +646,15 @@ AC_DEFUN([gl_FILE_LIST], [
m4/environ.m4
m4/errno_h.m4
m4/extensions.m4
- m4/fcntl_h.m4
+ m4/fcntl-o.m4
m4/float_h.m4
m4/flock.m4
m4/fpieee.m4
+ m4/func.m4
+ m4/getaddrinfo.m4
m4/glibc21.m4
m4/gnulib-common.m4
+ m4/hostent.m4
m4/iconv.m4
m4/iconv_h.m4
m4/iconv_open.m4
@@ -452,6 +685,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/memchr.m4
m4/mmap-anon.m4
m4/multiarch.m4
+ m4/netdb_h.m4
m4/netinet_in_h.m4
m4/pathmax.m4
m4/printf.m4
@@ -459,7 +693,9 @@ AC_DEFUN([gl_FILE_LIST], [
m4/readlink.m4
m4/safe-read.m4
m4/safe-write.m4
+ m4/servent.m4
m4/size_max.m4
+ m4/snprintf.m4
m4/socklen.m4
m4/sockpfaf.m4
m4/ssize_t.m4
@@ -486,8 +722,9 @@ AC_DEFUN([gl_FILE_LIST], [
m4/version-etc.m4
m4/visibility.m4
m4/vsnprintf.m4
+ m4/warn-on-use.m4
m4/warnings.m4
- m4/wchar.m4
+ m4/wchar_h.m4
m4/wchar_t.m4
m4/wint_t.m4
m4/write.m4
diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4
index 4438d48..69e7733 100644
--- a/m4/gnulib-tool.m4
+++ b/m4/gnulib-tool.m4
@@ -1,5 +1,5 @@
# gnulib-tool.m4 serial 2
-dnl Copyright (C) 2004-2005 Free Software Foundation, Inc.
+dnl Copyright (C) 2004-2005, 2009-2010 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.
diff --git a/m4/hostent.m4 b/m4/hostent.m4
new file mode 100644
index 0000000..1111041
--- /dev/null
+++ b/m4/hostent.m4
@@ -0,0 +1,45 @@
+# hostent.m4 serial 1
+dnl Copyright (C) 2008, 2009, 2010 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_HOSTENT],
+[
+ dnl Where are gethostent(), sethostent(), endhostent(), gethostbyname(),
+ dnl gethostbyaddr() defined?
+ dnl - On Solaris, they are in libnsl. Ignore libxnet.
+ dnl - On Haiku, they are in libnetwork.
+ dnl - On BeOS, they are in libnet.
+ dnl - On native Windows, they are in ws2_32.dll.
+ dnl - Otherwise they are in libc.
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])dnl for HAVE_SYS_SOCKET_H, HAVE_WINSOCK2_H
+ HOSTENT_LIB=
+ gl_saved_libs="$LIBS"
+ AC_SEARCH_LIBS([gethostbyname], [nsl network net],
+ [if test "$ac_cv_search_gethostbyname" != "none required"; then
+ HOSTENT_LIB="$ac_cv_search_gethostbyname"
+ fi])
+ LIBS="$gl_saved_libs"
+ if test -z "$HOSTENT_LIB"; then
+ AC_CHECK_FUNCS([gethostbyname], , [
+ AC_CACHE_CHECK([for gethostbyname in winsock2.h and -lws2_32],
+ [gl_cv_w32_gethostbyname],
+ [gl_cv_w32_gethostbyname=no
+ gl_save_LIBS="$LIBS"
+ LIBS="$LIBS -lws2_32"
+ AC_TRY_LINK([
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif
+#include <stddef.h>
+], [gethostbyname(NULL);], [gl_cv_w32_gethostbyname=yes])
+ LIBS="$gl_save_LIBS"
+ ])
+ if test "$gl_cv_w32_gethostbyname" = "yes"; then
+ HOSTENT_LIB="-lws2_32"
+ fi
+ ])
+ fi
+ AC_SUBST([HOSTENT_LIB])
+])
diff --git a/m4/iconv.m4 b/m4/iconv.m4
index ce21b0b..f46ff14 100644
--- a/m4/iconv.m4
+++ b/m4/iconv.m4
@@ -1,5 +1,5 @@
-# iconv.m4 serial AM8 (gettext-0.18)
-dnl Copyright (C) 2000-2002, 2007-2009 Free Software Foundation, Inc.
+# iconv.m4 serial 9 (gettext-0.18)
+dnl Copyright (C) 2000-2002, 2007-2010 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.
@@ -58,7 +58,7 @@ AC_DEFUN([AM_ICONV_LINK],
])
if test "$am_cv_func_iconv" = yes; then
AC_CACHE_CHECK([for working iconv], [am_cv_func_iconv_works], [
- dnl This tests against bugs in AIX 5.1 and HP-UX 11.11.
+ dnl This tests against bugs in AIX 5.1, HP-UX 11.11, Solaris 10.
am_save_LIBS="$LIBS"
if test $am_cv_lib_iconv = yes; then
LIBS="$LIBS $LIBICONV"
@@ -87,6 +87,25 @@ int main ()
return 1;
}
}
+ /* Test against Solaris 10 bug: Failures are not distinguishable from
+ successful returns. */
+ {
+ iconv_t cd_ascii_to_88591 = iconv_open ("ISO8859-1", "646");
+ if (cd_ascii_to_88591 != (iconv_t)(-1))
+ {
+ static const char input[] = "\263";
+ char buf[10];
+ const char *inptr = input;
+ size_t inbytesleft = strlen (input);
+ char *outptr = buf;
+ size_t outbytesleft = sizeof (buf);
+ size_t res = iconv (cd_ascii_to_88591,
+ (char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ if (res == 0)
+ return 1;
+ }
+ }
#if 0 /* This bug could be worked around by the caller. */
/* Test against HP-UX 11.11 bug: Positive return value instead of 0. */
{
diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4
index c56a489..8881473 100644
--- a/m4/iconv_h.m4
+++ b/m4/iconv_h.m4
@@ -1,5 +1,5 @@
# iconv_h.m4 serial 5
-dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2010 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.
diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4
index 6bf78bc..60f62ca 100644
--- a/m4/iconv_open.m4
+++ b/m4/iconv_open.m4
@@ -1,5 +1,5 @@
-# iconv_open.m4 serial 6
-dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
+# iconv_open.m4 serial 7
+dnl Copyright (C) 2007-2010 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.
@@ -10,6 +10,8 @@ AC_DEFUN([gl_FUNC_ICONV_OPEN],
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([gl_ICONV_H_DEFAULTS])
if test "$am_cv_func_iconv" = yes; then
+ dnl Provide the <iconv.h> override, for the sake of the C++ aliases.
+ gl_REPLACE_ICONV_H
dnl Test whether iconv_open accepts standardized encoding names.
dnl We know that GNU libiconv and GNU libc do.
AC_EGREP_CPP([gnu_iconv], [
diff --git a/m4/include_next.m4 b/m4/include_next.m4
index 2e6273f..c7e0672 100644
--- a/m4/include_next.m4
+++ b/m4/include_next.m4
@@ -1,5 +1,5 @@
# include_next.m4 serial 14
-dnl Copyright (C) 2006-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2010 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.
diff --git a/m4/inet_ntop.m4 b/m4/inet_ntop.m4
index 2a8ff20..20e8d7c 100644
--- a/m4/inet_ntop.m4
+++ b/m4/inet_ntop.m4
@@ -1,5 +1,5 @@
# inet_ntop.m4 serial 11
-dnl Copyright (C) 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2006, 2008, 2009, 2010 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.
diff --git a/m4/inet_pton.m4 b/m4/inet_pton.m4
index e890b9b..e0b7942 100644
--- a/m4/inet_pton.m4
+++ b/m4/inet_pton.m4
@@ -1,5 +1,5 @@
# inet_pton.m4 serial 9
-dnl Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2008, 2009, 2010 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.
diff --git a/m4/inline.m4 b/m4/inline.m4
index cee5109..4ef768d 100644
--- a/m4/inline.m4
+++ b/m4/inline.m4
@@ -1,5 +1,5 @@
# inline.m4 serial 4
-dnl Copyright (C) 2006, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2009, 2010 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.
diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4
index 264cb57..975caac 100644
--- a/m4/intmax_t.m4
+++ b/m4/intmax_t.m4
@@ -1,5 +1,6 @@
# intmax_t.m4 serial 7
-dnl Copyright (C) 1997-2004, 2006-2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 1997-2004, 2006-2007, 2009-2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4
index f4ca160..782d77e 100644
--- a/m4/inttypes_h.m4
+++ b/m4/inttypes_h.m4
@@ -1,5 +1,5 @@
# inttypes_h.m4 serial 9
-dnl Copyright (C) 1997-2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 1997-2004, 2006, 2008-2010 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.
diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4
index 43b725b..43c1ef1 100644
--- a/m4/ld-version-script.m4
+++ b/m4/ld-version-script.m4
@@ -1,5 +1,5 @@
# ld-version-script.m4 serial 1
-dnl Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2009, 2010 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.
diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4
index 4b4db07..ebb3052 100644
--- a/m4/lib-ld.m4
+++ b/m4/lib-ld.m4
@@ -1,5 +1,5 @@
# lib-ld.m4 serial 4 (gettext-0.18)
-dnl Copyright (C) 1996-2003, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 1996-2003, 2009-2010 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.
diff --git a/m4/lib-link.m4 b/m4/lib-link.m4
index 2f8b7ff..90e1ac9 100644
--- a/m4/lib-link.m4
+++ b/m4/lib-link.m4
@@ -1,5 +1,5 @@
# lib-link.m4 serial 20 (gettext-0.18)
-dnl Copyright (C) 2001-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2010 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.
diff --git a/m4/lib-prefix.m4 b/m4/lib-prefix.m4
index 4b7ee33..1601cea 100644
--- a/m4/lib-prefix.m4
+++ b/m4/lib-prefix.m4
@@ -1,5 +1,5 @@
# lib-prefix.m4 serial 7 (gettext-0.18)
-dnl Copyright (C) 2001-2005, 2008-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2005, 2008-2010 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.
diff --git a/m4/libunistring.m4 b/m4/libunistring.m4
index 52ff06b..8f9f07b 100644
--- a/m4/libunistring.m4
+++ b/m4/libunistring.m4
@@ -1,5 +1,5 @@
# libunistring.m4 serial 1
-dnl Copyright (C) 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2009, 2010 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.
diff --git a/m4/localcharset.m4 b/m4/localcharset.m4
index 90b9403..ee2e801 100644
--- a/m4/localcharset.m4
+++ b/m4/localcharset.m4
@@ -1,5 +1,5 @@
# localcharset.m4 serial 7
-dnl Copyright (C) 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2004, 2006, 2009, 2010 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.
diff --git a/m4/locale-fr.m4 b/m4/locale-fr.m4
index 653a5bc..001f539 100644
--- a/m4/locale-fr.m4
+++ b/m4/locale-fr.m4
@@ -1,5 +1,5 @@
# locale-fr.m4 serial 11
-dnl Copyright (C) 2003, 2005-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2010 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.
diff --git a/m4/locale-ja.m4 b/m4/locale-ja.m4
index 9360576..0eedaf1 100644
--- a/m4/locale-ja.m4
+++ b/m4/locale-ja.m4
@@ -1,5 +1,5 @@
# locale-ja.m4 serial 7
-dnl Copyright (C) 2003, 2005-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2010 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.
diff --git a/m4/locale-zh.m4 b/m4/locale-zh.m4
index 36a5f1d..777fd14 100644
--- a/m4/locale-zh.m4
+++ b/m4/locale-zh.m4
@@ -1,5 +1,5 @@
# locale-zh.m4 serial 6
-dnl Copyright (C) 2003, 2005-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2010 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.
diff --git a/m4/locale_h.m4 b/m4/locale_h.m4
index 35b8b32..743e6a8 100644
--- a/m4/locale_h.m4
+++ b/m4/locale_h.m4
@@ -1,5 +1,5 @@
-# locale_h.m4 serial 5
-dnl Copyright (C) 2007, 2009 Free Software Foundation, Inc.
+# locale_h.m4 serial 9
+dnl Copyright (C) 2007, 2009, 2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -48,8 +48,7 @@ locale_t x;], [],
fi
AC_SUBST([HAVE_XLOCALE_H])
- dnl Execute this unconditionally, because LOCALE_H may be set by other
- dnl modules, after this code is executed.
+ dnl <locale.h> is always overridden, because of GNULIB_POSIXCHECK.
gl_CHECK_NEXT_HEADERS([locale.h])
if test -n "$STDDEF_H" \
@@ -57,13 +56,22 @@ locale_t x;], [],
|| test $gl_cv_header_locale_h_needs_xlocale_h = yes; then
gl_REPLACE_LOCALE_H
fi
+
+ 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([[#include <locale.h>
+/* Some systems provide declarations in a non-standard header. */
+#if HAVE_XLOCALE_H
+# include <xlocale.h>
+#endif
+ ]], [duplocale])
])
dnl Unconditionally enables the replacement of <locale.h>.
AC_DEFUN([gl_REPLACE_LOCALE_H],
[
- AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
- LOCALE_H=locale.h
+ dnl This is a no-op, because <locale.h> is always overridden.
+ :
])
AC_DEFUN([gl_LOCALE_MODULE_INDICATOR],
@@ -71,12 +79,14 @@ AC_DEFUN([gl_LOCALE_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_LOCALE_H_DEFAULTS],
[
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_DUPLOCALE=0; AC_SUBST([REPLACE_DUPLOCALE])
- LOCALE_H=''; AC_SUBST([LOCALE_H])
])
diff --git a/m4/longlong.m4 b/m4/longlong.m4
index 6d17ea3..cca3c1a 100644
--- a/m4/longlong.m4
+++ b/m4/longlong.m4
@@ -1,5 +1,5 @@
# longlong.m4 serial 14
-dnl Copyright (C) 1999-2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 1999-2007, 2009-2010 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.
diff --git a/m4/lstat.m4 b/m4/lstat.m4
index 089d0ff..5dbd16e 100644
--- a/m4/lstat.m4
+++ b/m4/lstat.m4
@@ -1,6 +1,6 @@
# serial 20
-# Copyright (C) 1997-2001, 2003-2009 Free Software Foundation, Inc.
+# Copyright (C) 1997-2001, 2003-2010 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/malloc.m4 b/m4/malloc.m4
index 8070171..910ac92 100644
--- a/m4/malloc.m4
+++ b/m4/malloc.m4
@@ -1,5 +1,5 @@
# malloc.m4 serial 9
-dnl Copyright (C) 2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009, 2010 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.
diff --git a/m4/malloca.m4 b/m4/malloca.m4
index 2841ae8..e07c6d9 100644
--- a/m4/malloca.m4
+++ b/m4/malloca.m4
@@ -1,5 +1,6 @@
# malloca.m4 serial 1
-dnl Copyright (C) 2003-2004, 2006-2007 Free Software Foundation, Inc.
+dnl Copyright (C) 2003-2004, 2006-2007, 2009-2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/mbrlen.m4 b/m4/mbrlen.m4
index 5623ed5..6049d1a 100644
--- a/m4/mbrlen.m4
+++ b/m4/mbrlen.m4
@@ -1,5 +1,5 @@
# mbrlen.m4 serial 2
-dnl Copyright (C) 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2009, 2010 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.
diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4
index 2fddcc8..9ec93f5 100644
--- a/m4/mbrtowc.m4
+++ b/m4/mbrtowc.m4
@@ -1,5 +1,6 @@
# mbrtowc.m4 serial 16
-dnl Copyright (C) 2001-2002, 2004-2005, 2008, 2009 Free Software Foundation,
Inc.
+dnl Copyright (C) 2001-2002, 2004-2005, 2008-2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4
index 03b055c..13907a5 100644
--- a/m4/mbsinit.m4
+++ b/m4/mbsinit.m4
@@ -1,5 +1,5 @@
# mbsinit.m4 serial 3
-dnl Copyright (C) 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2009, 2010 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.
diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4
index 08f85d6..3e2df29 100644
--- a/m4/mbstate_t.m4
+++ b/m4/mbstate_t.m4
@@ -1,5 +1,5 @@
# mbstate_t.m4 serial 12
-dnl Copyright (C) 2000-2002, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2000-2002, 2008-2010 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.
diff --git a/m4/memchr.m4 b/m4/memchr.m4
index 81531ca..94596ef 100644
--- a/m4/memchr.m4
+++ b/m4/memchr.m4
@@ -1,5 +1,5 @@
# memchr.m4 serial 7
-dnl Copyright (C) 2002, 2003, 2004, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2009-2010 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.
diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4
index 14b6270..a6b7b9a 100644
--- a/m4/mmap-anon.m4
+++ b/m4/mmap-anon.m4
@@ -1,5 +1,5 @@
# mmap-anon.m4 serial 8
-dnl Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2007, 2009-2010 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.
diff --git a/m4/multiarch.m4 b/m4/multiarch.m4
index ec377ba..389bd2b 100644
--- a/m4/multiarch.m4
+++ b/m4/multiarch.m4
@@ -1,5 +1,5 @@
# multiarch.m4 serial 5
-dnl Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2009, 2010 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.
diff --git a/m4/netdb_h.m4 b/m4/netdb_h.m4
new file mode 100644
index 0000000..84afce6
--- /dev/null
+++ b/m4/netdb_h.m4
@@ -0,0 +1,46 @@
+# netdb_h.m4 serial 6
+dnl Copyright (C) 2008, 2009, 2010 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_HEADER_NETDB],
+[
+ AC_REQUIRE([gl_NETDB_H_DEFAULTS])
+ AC_CHECK_HEADERS_ONCE([netdb.h])
+ gl_CHECK_NEXT_HEADERS([netdb.h])
+ if test $ac_cv_header_netdb_h = yes; then
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[
+ #include <netdb.h>
+ struct addrinfo a;
+ int b = EAI_OVERFLOW;
+ int c = AI_NUMERICSERV;
+ ]])],
+ [NETDB_H=''], [NETDB_H='netdb.h'])
+ HAVE_NETDB_H=1
+ else
+ NETDB_H='netdb.h'
+ HAVE_NETDB_H=0
+ fi
+ AC_SUBST([HAVE_NETDB_H])
+ AC_SUBST([NETDB_H])
+])
+
+AC_DEFUN([gl_NETDB_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_NETDB_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_NETDB_H_DEFAULTS],
+[
+ GNULIB_GETADDRINFO=0; AC_SUBST([GNULIB_GETADDRINFO])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_STRUCT_ADDRINFO=1; AC_SUBST([HAVE_STRUCT_ADDRINFO])
+ HAVE_DECL_FREEADDRINFO=1; AC_SUBST([HAVE_DECL_FREEADDRINFO])
+ HAVE_DECL_GAI_STRERROR=1; AC_SUBST([HAVE_DECL_GAI_STRERROR])
+ HAVE_DECL_GETADDRINFO=1; AC_SUBST([HAVE_DECL_GETADDRINFO])
+ HAVE_DECL_GETNAMEINFO=1; AC_SUBST([HAVE_DECL_GETNAMEINFO])
+])
diff --git a/m4/netinet_in_h.m4 b/m4/netinet_in_h.m4
index 47fd9cc..cc7a44c 100644
--- a/m4/netinet_in_h.m4
+++ b/m4/netinet_in_h.m4
@@ -1,5 +1,5 @@
# netinet_in_h.m4 serial 4
-dnl Copyright (C) 2006-2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2010 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.
diff --git a/m4/pathmax.m4 b/m4/pathmax.m4
index 4651801..6a3f857 100644
--- a/m4/pathmax.m4
+++ b/m4/pathmax.m4
@@ -1,5 +1,6 @@
# pathmax.m4 serial 8
-dnl Copyright (C) 2002, 2003, 2005, 2006, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2006, 2009-2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/printf.m4 b/m4/printf.m4
index 87aa45c..ebca536 100644
--- a/m4/printf.m4
+++ b/m4/printf.m4
@@ -1,5 +1,5 @@
# printf.m4 serial 33
-dnl Copyright (C) 2003, 2007-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2007-2010 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.
diff --git a/m4/putenv.m4 b/m4/putenv.m4
index e04f864..dd9140c 100644
--- a/m4/putenv.m4
+++ b/m4/putenv.m4
@@ -1,5 +1,5 @@
# putenv.m4 serial 16
-dnl Copyright (C) 2002-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2010 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.
diff --git a/m4/readlink.m4 b/m4/readlink.m4
index e61c1a1..36cd41f 100644
--- a/m4/readlink.m4
+++ b/m4/readlink.m4
@@ -1,5 +1,5 @@
-# readlink.m4 serial 8
-dnl Copyright (C) 2003, 2007, 2009 Free Software Foundation, Inc.
+# readlink.m4 serial 9
+dnl Copyright (C) 2003, 2007, 2009, 2010 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.
@@ -35,7 +35,7 @@ AC_DEFUN([gl_FUNC_READLINK],
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"])
- rm -f conftest.link])
+ 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.])
diff --git a/m4/safe-read.m4 b/m4/safe-read.m4
index 7a89d0a..d087bd3 100644
--- a/m4/safe-read.m4
+++ b/m4/safe-read.m4
@@ -1,5 +1,6 @@
# safe-read.m4 serial 5
-dnl Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2006, 2009-2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/safe-write.m4 b/m4/safe-write.m4
index db119ff..2ff11d2 100644
--- a/m4/safe-write.m4
+++ b/m4/safe-write.m4
@@ -1,5 +1,5 @@
# safe-write.m4 serial 3
-dnl Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2005-2006, 2009-2010 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.
diff --git a/m4/servent.m4 b/m4/servent.m4
new file mode 100644
index 0000000..2ed961a
--- /dev/null
+++ b/m4/servent.m4
@@ -0,0 +1,47 @@
+# servent.m4 serial 1
+dnl Copyright (C) 2008, 2009, 2010 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_SERVENT],
+[
+ dnl Where are getservent(), setservent(), endservent(), getservbyname(),
+ dnl getservbyport() defined?
+ dnl Where are getprotoent(), setprotoent(), endprotoent(), getprotobyname(),
+ dnl getprotobynumber() defined?
+ dnl - On Solaris, they are in libsocket. Ignore libxnet.
+ dnl - On Haiku, they are in libnetwork.
+ dnl - On BeOS, they are in libnet.
+ dnl - On native Windows, they are in ws2_32.dll.
+ dnl - Otherwise they are in libc.
+ AC_REQUIRE([gl_HEADER_SYS_SOCKET])dnl for HAVE_SYS_SOCKET_H, HAVE_WINSOCK2_H
+ SERVENT_LIB=
+ gl_saved_libs="$LIBS"
+ AC_SEARCH_LIBS([getservbyname], [socket network net],
+ [if test "$ac_cv_search_getservbyname" != "none required"; then
+ SERVENT_LIB="$ac_cv_search_getservbyname"
+ fi])
+ LIBS="$gl_saved_libs"
+ if test -z "$SERVENT_LIB"; then
+ AC_CHECK_FUNCS([getservbyname], , [
+ AC_CACHE_CHECK([for getservbyname in winsock2.h and -lws2_32],
+ [gl_cv_w32_getservbyname],
+ [gl_cv_w32_getservbyname=no
+ gl_save_LIBS="$LIBS"
+ LIBS="$LIBS -lws2_32"
+ AC_TRY_LINK([
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif
+#include <stddef.h>
+], [getservbyname(NULL,NULL);], [gl_cv_w32_getservbyname=yes])
+ LIBS="$gl_save_LIBS"
+ ])
+ if test "$gl_cv_w32_getservbyname" = "yes"; then
+ SERVENT_LIB="-lws2_32"
+ fi
+ ])
+ fi
+ AC_SUBST([SERVENT_LIB])
+])
diff --git a/m4/size_max.m4 b/m4/size_max.m4
index 35bd3d6..ce992db 100644
--- a/m4/size_max.m4
+++ b/m4/size_max.m4
@@ -1,5 +1,5 @@
# size_max.m4 serial 9
-dnl Copyright (C) 2003, 2005-2006, 2008-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2006, 2008-2010 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.
diff --git a/m4/snprintf.m4 b/m4/snprintf.m4
new file mode 100644
index 0000000..522b107
--- /dev/null
+++ b/m4/snprintf.m4
@@ -0,0 +1,40 @@
+# snprintf.m4 serial 5
+dnl Copyright (C) 2002-2004, 2007-2010 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_SNPRINTF],
+[
+ AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ gl_cv_func_snprintf_usable=no
+ AC_CHECK_FUNCS([snprintf])
+ if test $ac_cv_func_snprintf = yes; then
+ gl_SNPRINTF_SIZE1
+ case "$gl_cv_func_snprintf_size1" in
+ *yes)
+ gl_cv_func_snprintf_usable=yes
+ ;;
+ esac
+ fi
+ if test $gl_cv_func_snprintf_usable = no; then
+ gl_REPLACE_SNPRINTF
+ fi
+ AC_CHECK_DECLS_ONCE([snprintf])
+ if test $ac_cv_have_decl_snprintf = no; then
+ HAVE_DECL_SNPRINTF=0
+ fi
+])
+
+AC_DEFUN([gl_REPLACE_SNPRINTF],
+[
+ AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ AC_LIBOBJ([snprintf])
+ if test $ac_cv_func_snprintf = yes; then
+ REPLACE_SNPRINTF=1
+ fi
+ gl_PREREQ_SNPRINTF
+])
+
+# Prerequisites of lib/snprintf.c.
+AC_DEFUN([gl_PREREQ_SNPRINTF], [:])
diff --git a/m4/socklen.m4 b/m4/socklen.m4
index 36436ed..2933d4b 100644
--- a/m4/socklen.m4
+++ b/m4/socklen.m4
@@ -1,5 +1,5 @@
# socklen.m4 serial 7
-dnl Copyright (C) 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2006, 2007, 2009, 2010 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.
diff --git a/m4/sockpfaf.m4 b/m4/sockpfaf.m4
index bbdfabc..8a0c236 100644
--- a/m4/sockpfaf.m4
+++ b/m4/sockpfaf.m4
@@ -1,5 +1,5 @@
# sockpfaf.m4 serial 7
-dnl Copyright (C) 2004, 2006, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2004, 2006, 2009, 2010 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.
diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4
index 4eaef93..e0ccee3 100644
--- a/m4/ssize_t.m4
+++ b/m4/ssize_t.m4
@@ -1,5 +1,5 @@
# ssize_t.m4 serial 4 (gettext-0.15)
-dnl Copyright (C) 2001-2003, 2006 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2003, 2006, 2009-2010 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.
diff --git a/m4/stat.m4 b/m4/stat.m4
index ce6933b..acd32d8 100644
--- a/m4/stat.m4
+++ b/m4/stat.m4
@@ -1,6 +1,6 @@
-# serial 3
+# serial 4
-# Copyright (C) 2009 Free Software Foundation, Inc.
+# Copyright (C) 2009, 2010 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -57,5 +57,7 @@ AC_DEFUN([gl_FUNC_STAT],
esac
if test $REPLACE_STAT = 1; then
AC_LIBOBJ([stat])
+ dnl Prerequisites of lib/stat.c.
+ AC_REQUIRE([AC_C_INLINE])
fi
])
diff --git a/m4/stdarg.m4 b/m4/stdarg.m4
index a9ada4f..5c87bd8 100644
--- a/m4/stdarg.m4
+++ b/m4/stdarg.m4
@@ -1,5 +1,5 @@
# stdarg.m4 serial 3
-dnl Copyright (C) 2006, 2008-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2008-2010 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.
diff --git a/m4/stdbool.m4 b/m4/stdbool.m4
index 5e22d7a..3d672d7 100644
--- a/m4/stdbool.m4
+++ b/m4/stdbool.m4
@@ -1,6 +1,6 @@
# Check for stdbool.h that conforms to C99.
-dnl Copyright (C) 2002-2006, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2006, 2009-2010 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.
diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4
index 682e9c6..c8572de 100644
--- a/m4/stddef_h.m4
+++ b/m4/stddef_h.m4
@@ -1,6 +1,6 @@
dnl A placeholder for POSIX 2008 <stddef.h>, for platforms that have issues.
# stddef_h.m4 serial 1
-dnl Copyright (C) 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2009, 2010 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.
diff --git a/m4/stdint.m4 b/m4/stdint.m4
index 819d629..1cc57e6 100644
--- a/m4/stdint.m4
+++ b/m4/stdint.m4
@@ -1,5 +1,5 @@
# stdint.m4 serial 34
-dnl Copyright (C) 2001-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2010 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.
diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4
index 82f0c24..b8e3c6c 100644
--- a/m4/stdint_h.m4
+++ b/m4/stdint_h.m4
@@ -1,5 +1,5 @@
# stdint_h.m4 serial 8
-dnl Copyright (C) 1997-2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 1997-2004, 2006, 2008-2010 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.
diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4
index 256efe1..681fd8b 100644
--- a/m4/stdio_h.m4
+++ b/m4/stdio_h.m4
@@ -1,5 +1,5 @@
-# stdio_h.m4 serial 21
-dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
+# stdio_h.m4 serial 26
+dnl Copyright (C) 2007-2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -7,6 +7,7 @@ dnl with or without modifications, as long as this notice is
preserved.
AC_DEFUN([gl_STDIO_H],
[
AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ AC_REQUIRE([AC_C_INLINE])
gl_CHECK_NEXT_HEADERS([stdio.h])
dnl No need to create extra modules for these functions. Everyone who uses
dnl <stdio.h> likely needs them.
@@ -30,6 +31,13 @@ AC_DEFUN([gl_STDIO_H],
AC_LIBOBJ([stdio-write])
fi
])
+
+ 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.
+ gl_WARN_ON_USE_PREPARE([[#include <stdio.h>
+ ]], [dprintf fpurge fseeko ftello getdelim getline popen renameat
+ snprintf vdprintf vsnprintf])
])
AC_DEFUN([gl_STDIO_MODULE_INDICATOR],
@@ -37,6 +45,8 @@ AC_DEFUN([gl_STDIO_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_STDIO_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_STDIO_H_DEFAULTS],
@@ -89,8 +99,6 @@ AC_DEFUN([gl_STDIO_H_DEFAULTS],
HAVE_DECL_SNPRINTF=1; AC_SUBST([HAVE_DECL_SNPRINTF])
HAVE_DECL_VSNPRINTF=1; AC_SUBST([HAVE_DECL_VSNPRINTF])
HAVE_DPRINTF=1; AC_SUBST([HAVE_DPRINTF])
- HAVE_FSEEKO=1; AC_SUBST([HAVE_FSEEKO])
- HAVE_FTELLO=1; AC_SUBST([HAVE_FTELLO])
HAVE_RENAMEAT=1; AC_SUBST([HAVE_RENAMEAT])
HAVE_VASPRINTF=1; AC_SUBST([HAVE_VASPRINTF])
HAVE_VDPRINTF=1; AC_SUBST([HAVE_VDPRINTF])
@@ -105,6 +113,7 @@ AC_DEFUN([gl_STDIO_H_DEFAULTS],
REPLACE_FSEEKO=0; AC_SUBST([REPLACE_FSEEKO])
REPLACE_FTELL=0; AC_SUBST([REPLACE_FTELL])
REPLACE_FTELLO=0; AC_SUBST([REPLACE_FTELLO])
+ REPLACE_GETDELIM=0; AC_SUBST([REPLACE_GETDELIM])
REPLACE_GETLINE=0; AC_SUBST([REPLACE_GETLINE])
REPLACE_OBSTACK_PRINTF=0; AC_SUBST([REPLACE_OBSTACK_PRINTF])
REPLACE_PERROR=0; AC_SUBST([REPLACE_PERROR])
diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4
index 10e010e..77344bd 100644
--- a/m4/stdlib_h.m4
+++ b/m4/stdlib_h.m4
@@ -1,5 +1,5 @@
-# stdlib_h.m4 serial 21
-dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
+# stdlib_h.m4 serial 23
+dnl Copyright (C) 2007-2010 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.
@@ -22,6 +22,20 @@ AC_DEFUN([gl_STDLIB_H],
# include <random.h>
#endif
]])
+
+ 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.
+ gl_WARN_ON_USE_PREPARE([[#include <stdlib.h>
+#if HAVE_SYS_LOADAVG_H
+# include <sys/loadavg.h>
+#endif
+#if HAVE_RANDOM_H
+# include <random.h>
+#endif
+ ]], [atoll canonicalize_file_name getloadavg getsubopt mkdtemp
+ mkostemp mkostemps mkstemp mkstemps random_r initstat_r srandom_r
+ setstate_r realpath rpmatch setenv strtod strtoll strtoull unsetenv])
])
AC_DEFUN([gl_STDLIB_MODULE_INDICATOR],
@@ -29,6 +43,8 @@ AC_DEFUN([gl_STDLIB_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_STDLIB_H_DEFAULTS],
diff --git a/m4/strcase.m4 b/m4/strcase.m4
index 0dfdb1a..33de423 100644
--- a/m4/strcase.m4
+++ b/m4/strcase.m4
@@ -1,5 +1,5 @@
# strcase.m4 serial 10
-dnl Copyright (C) 2002, 2005-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2005-2010 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.
diff --git a/m4/strftime.m4 b/m4/strftime.m4
index 15a8770..3562240 100644
--- a/m4/strftime.m4
+++ b/m4/strftime.m4
@@ -1,7 +1,6 @@
# serial 32
-# Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-# 2006, 2007, 2009 Free Software Foundation, Inc.
+# Copyright (C) 1996-1997, 1999-2007, 2009-2010 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/string_h.m4 b/m4/string_h.m4
index e870534..a8a366c 100644
--- a/m4/string_h.m4
+++ b/m4/string_h.m4
@@ -1,11 +1,11 @@
# Configure a GNU-like replacement for <string.h>.
-# Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+# Copyright (C) 2007-2010 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
-# serial 9
+# serial 12
# Written by Paul Eggert.
@@ -21,6 +21,13 @@ AC_DEFUN([gl_HEADER_STRING_H_BODY],
AC_REQUIRE([AC_C_RESTRICT])
AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS])
gl_CHECK_NEXT_HEADERS([string.h])
+
+ 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.
+ gl_WARN_ON_USE_PREPARE([[#include <string.h>
+ ]], [memmem mempcpy memrchr rawmemchr stpcpy stpncpy strchrnul strdup
+ strndup strnlen strpbrk strsep strcasestr strtok_r strsignal strverscmp])
])
AC_DEFUN([gl_STRING_MODULE_INDICATOR],
@@ -28,6 +35,8 @@ AC_DEFUN([gl_STRING_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
@@ -64,7 +73,8 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
GNULIB_MBSTOK_R=0; AC_SUBST([GNULIB_MBSTOK_R])
GNULIB_STRERROR=0; AC_SUBST([GNULIB_STRERROR])
GNULIB_STRSIGNAL=0; AC_SUBST([GNULIB_STRSIGNAL])
- GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP])
+ GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP])
+ HAVE_MBSLEN=0; AC_SUBST([HAVE_MBSLEN])
dnl Assume proper GNU behavior unless another module says otherwise.
HAVE_DECL_MEMMEM=1; AC_SUBST([HAVE_DECL_MEMMEM])
HAVE_MEMPCPY=1; AC_SUBST([HAVE_MEMPCPY])
diff --git a/m4/strings_h.m4 b/m4/strings_h.m4
index 03ac182..26aa1f7 100644
--- a/m4/strings_h.m4
+++ b/m4/strings_h.m4
@@ -1,6 +1,7 @@
# Configure a replacement for <string.h>.
+# serial 2
-# Copyright (C) 2007 Free Software Foundation, Inc.
+# Copyright (C) 2007, 2009, 2010 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.
@@ -16,6 +17,11 @@ AC_DEFUN([gl_HEADER_STRINGS_H_BODY],
[
AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
gl_CHECK_NEXT_HEADERS([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([[#include <strings.h>
+ ]], [strcasecmp strncasecmp])
])
AC_DEFUN([gl_STRINGS_MODULE_INDICATOR],
diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4
index 436c6fe..fac106a 100644
--- a/m4/sys_file_h.m4
+++ b/m4/sys_file_h.m4
@@ -1,6 +1,7 @@
# Configure a replacement for <sys/file.h>.
+# serial 4
-# Copyright (C) 2008 Free Software Foundation, Inc.
+# Copyright (C) 2008-2010 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.
@@ -11,13 +12,8 @@ AC_DEFUN([gl_HEADER_SYS_FILE_H],
[
AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS])
- dnl Only flock is defined in a working <sys/file.h>. If that
- dnl function is already there, we don't want to do any substitution.
- AC_CHECK_FUNCS_ONCE([flock])
-
+ dnl <sys/file.h> is always overridden, because of GNULIB_POSIXCHECK.
gl_CHECK_NEXT_HEADERS([sys/file.h])
- SYS_FILE_H='sys/file.h'
- AC_SUBST([SYS_FILE_H])
AC_CHECK_HEADERS_ONCE([sys/file.h])
if test $ac_cv_header_sys_file_h = yes; then
@@ -26,6 +22,11 @@ AC_DEFUN([gl_HEADER_SYS_FILE_H],
HAVE_SYS_FILE_H=0
fi
AC_SUBST([HAVE_SYS_FILE_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([[#include <sys/file.h>
+ ]], [flock])
])
AC_DEFUN([gl_HEADER_SYS_FILE_MODULE_INDICATOR],
diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4
index e864b2c..993514c 100644
--- a/m4/sys_socket_h.m4
+++ b/m4/sys_socket_h.m4
@@ -1,5 +1,5 @@
-# sys_socket_h.m4 serial 13
-dnl Copyright (C) 2005-2009 Free Software Foundation, Inc.
+# sys_socket_h.m4 serial 16
+dnl Copyright (C) 2005-2010 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.
@@ -19,7 +19,6 @@ AC_DEFUN([gl_HEADER_SYS_SOCKET],
[gl_cv_header_sys_socket_h_selfcontained=no])
])
if test $gl_cv_header_sys_socket_h_selfcontained = yes; then
- SYS_SOCKET_H=''
dnl If the shutdown function exists, <sys/socket.h> should define
dnl SHUT_RD, SHUT_WR, SHUT_RDWR.
AC_CHECK_FUNCS([shutdown])
@@ -37,8 +36,6 @@ AC_DEFUN([gl_HEADER_SYS_SOCKET],
SYS_SOCKET_H='sys/socket.h'
fi
fi
- else
- SYS_SOCKET_H='sys/socket.h'
fi
# We need to check for ws2tcpip.h now.
gl_PREREQ_SYS_H_SOCKET
@@ -56,16 +53,23 @@ AC_DEFUN([gl_HEADER_SYS_SOCKET],
])
if test $ac_cv_type_struct_sockaddr_storage = no; then
HAVE_STRUCT_SOCKADDR_STORAGE=0
- SYS_SOCKET_H='sys/socket.h'
fi
if test $ac_cv_type_sa_family_t = no; then
HAVE_SA_FAMILY_T=0
- SYS_SOCKET_H='sys/socket.h'
- fi
- if test -n "$SYS_SOCKET_H"; then
- gl_PREREQ_SYS_H_WINSOCK2
fi
- AC_SUBST([SYS_SOCKET_H])
+ gl_PREREQ_SYS_H_WINSOCK2
+
+ 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([[
+/* Some systems require prerequisite headers. */
+#include <sys/types.h>
+#if !defined __GLIBC__ && HAVE_SYS_TIME_H
+# include <sys/time.h>
+#endif
+#include <sys/select.h>
+ ]], [socket connect accept bind getpeername getsockname getsockopt
+ listen recv send recvfrom sendto setsockopt shutdown accept4])
])
AC_DEFUN([gl_PREREQ_SYS_H_SOCKET],
@@ -122,6 +126,8 @@ AC_DEFUN([gl_SYS_SOCKET_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_SYS_SOCKET_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_SYS_SOCKET_H_DEFAULTS],
diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4
index 838cf48..54d74ca 100644
--- a/m4/sys_stat_h.m4
+++ b/m4/sys_stat_h.m4
@@ -1,5 +1,5 @@
-# sys_stat_h.m4 serial 21 -*- Autoconf -*-
-dnl Copyright (C) 2006-2009 Free Software Foundation, Inc.
+# sys_stat_h.m4 serial 23 -*- Autoconf -*-
+dnl Copyright (C) 2006-2010 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.
@@ -27,6 +27,11 @@ AC_DEFUN([gl_HEADER_SYS_STAT_H],
[#include <sys/types.h>
#include <sys/stat.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([[#include <sys/stat.h>
+ ]], [fchmodat fstatat futimens lchmod lstat mkdirat mkfifo mkfifoat
+ mknod mknodat stat utimensat])
]) # gl_HEADER_SYS_STAT_H
AC_DEFUN([gl_SYS_STAT_MODULE_INDICATOR],
@@ -34,6 +39,8 @@ AC_DEFUN([gl_SYS_STAT_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_SYS_STAT_H_DEFAULTS],
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index c038b17..f572b85 100644
--- a/m4/time_h.m4
+++ b/m4/time_h.m4
@@ -1,6 +1,6 @@
# Configure a more-standard replacement for <time.h>.
-# Copyright (C) 2000-2001, 2003-2007, 2009 Free Software Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009-2010 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -23,18 +23,6 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY],
AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC])
])
-AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS],
-[
- dnl If another module says to replace or to not replace, do that.
- dnl Otherwise, replace only if someone compiles with -DGNULIB_PORTCHECK;
- dnl this lets maintainers check for portability.
- REPLACE_LOCALTIME_R=GNULIB_PORTCHECK; AC_SUBST([REPLACE_LOCALTIME_R])
- REPLACE_MKTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_MKTIME])
- REPLACE_NANOSLEEP=GNULIB_PORTCHECK; AC_SUBST([REPLACE_NANOSLEEP])
- REPLACE_STRPTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_STRPTIME])
- REPLACE_TIMEGM=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMEGM])
-])
-
dnl Define HAVE_STRUCT_TIMESPEC if `struct timespec' is declared
dnl in time.h or sys/time.h.
@@ -72,3 +60,29 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC],
AC_SUBST([TIME_H_DEFINES_STRUCT_TIMESPEC])
AC_SUBST([SYS_TIME_H_DEFINES_STRUCT_TIMESPEC])
])
+
+AC_DEFUN([gl_TIME_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
+])
+
+AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS],
+[
+ GNULIB_MKTIME=0; AC_SUBST([GNULIB_MKTIME])
+ GNULIB_NANOSLEEP=0; AC_SUBST([GNULIB_NANOSLEEP])
+ GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME])
+ GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM])
+ GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R])
+ dnl If another module says to replace or to not replace, do that.
+ dnl Otherwise, replace only if someone compiles with -DGNULIB_PORTCHECK;
+ dnl this lets maintainers check for portability.
+ REPLACE_LOCALTIME_R=GNULIB_PORTCHECK; AC_SUBST([REPLACE_LOCALTIME_R])
+ REPLACE_MKTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_MKTIME])
+ REPLACE_NANOSLEEP=GNULIB_PORTCHECK; AC_SUBST([REPLACE_NANOSLEEP])
+ REPLACE_STRPTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_STRPTIME])
+ REPLACE_TIMEGM=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMEGM])
+])
diff --git a/m4/time_r.m4 b/m4/time_r.m4
index de22db9..b5938e7 100644
--- a/m4/time_r.m4
+++ b/m4/time_r.m4
@@ -1,6 +1,7 @@
dnl Reentrant time functions like localtime_r.
-dnl Copyright (C) 2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2006, 2007, 2008, 2009, 2010 Free Software Foundation,
+dnl 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.
diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4
index 911af0a..43bda96 100644
--- a/m4/tm_gmtoff.m4
+++ b/m4/tm_gmtoff.m4
@@ -1,5 +1,5 @@
# tm_gmtoff.m4 serial 3
-dnl Copyright (C) 2002, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2009-2010 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.
diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4
index cb50d50..f6c35d2 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,5 +1,5 @@
-# unistd_h.m4 serial 36
-dnl Copyright (C) 2006-2009 Free Software Foundation, Inc.
+# unistd_h.m4 serial 40
+dnl Copyright (C) 2006-2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -11,6 +11,7 @@ AC_DEFUN([gl_UNISTD_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_UNISTD_H_DEFAULTS])
+ AC_REQUIRE([AC_C_INLINE])
gl_CHECK_NEXT_HEADERS([unistd.h])
@@ -21,6 +22,24 @@ AC_DEFUN([gl_UNISTD_H],
HAVE_UNISTD_H=0
fi
AC_SUBST([HAVE_UNISTD_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([[#include <unistd.h>
+/* Some systems declare various items in the wrong headers. */
+#ifndef __GLIBC__
+# include <fcntl.h>
+# include <stdio.h>
+# include <stdlib.h>
+# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# include <io.h>
+# endif
+#endif
+ ]], [chown dup2 dup3 environ euidaccess faccessat fchdir fchownat
+ fsync ftruncate getcwd getdomainname getdtablesize getgroups
+ gethostname getlogin getlogin_r getpagesize getusershell setusershell
+ endusershell lchown link linkat lseek pipe2 pread readlink readlinkat
+ rmdir sleep symlink symlinkat unlink unlinkat usleep])
])
AC_DEFUN([gl_UNISTD_MODULE_INDICATOR],
@@ -28,6 +47,8 @@ AC_DEFUN([gl_UNISTD_MODULE_INDICATOR],
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
])
AC_DEFUN([gl_UNISTD_H_DEFAULTS],
@@ -48,6 +69,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
GNULIB_GETDTABLESIZE=0; AC_SUBST([GNULIB_GETDTABLESIZE])
GNULIB_GETGROUPS=0; AC_SUBST([GNULIB_GETGROUPS])
GNULIB_GETHOSTNAME=0; AC_SUBST([GNULIB_GETHOSTNAME])
+ GNULIB_GETLOGIN=0; AC_SUBST([GNULIB_GETLOGIN])
GNULIB_GETLOGIN_R=0; AC_SUBST([GNULIB_GETLOGIN_R])
GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE])
GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL])
@@ -82,6 +104,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
HAVE_GETDTABLESIZE=1; AC_SUBST([HAVE_GETDTABLESIZE])
HAVE_GETGROUPS=1; AC_SUBST([HAVE_GETGROUPS])
HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME])
+ HAVE_GETLOGIN=1; AC_SUBST([HAVE_GETLOGIN])
HAVE_GETPAGESIZE=1; AC_SUBST([HAVE_GETPAGESIZE])
HAVE_GETUSERSHELL=1; AC_SUBST([HAVE_GETUSERSHELL])
HAVE_LCHOWN=1; AC_SUBST([HAVE_LCHOWN])
diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4
index 3a1d1e0..50a20cc 100644
--- a/m4/vasnprintf.m4
+++ b/m4/vasnprintf.m4
@@ -1,5 +1,5 @@
# vasnprintf.m4 serial 29
-dnl Copyright (C) 2002-2004, 2006-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2006-2010 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.
diff --git a/m4/version-etc.m4 b/m4/version-etc.m4
index 87389de..2c572b4 100644
--- a/m4/version-etc.m4
+++ b/m4/version-etc.m4
@@ -1,5 +1,5 @@
# version-etc.m4 serial 1
-# Copyright (C) 2009 Free Software Foundation, Inc.
+# Copyright (C) 2009-2010 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.
diff --git a/m4/visibility.m4 b/m4/visibility.m4
index 70bca56..35a6dc0 100644
--- a/m4/visibility.m4
+++ b/m4/visibility.m4
@@ -1,5 +1,5 @@
# visibility.m4 serial 2 (gettext-0.18)
-dnl Copyright (C) 2005, 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2008, 2009, 2010 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.
diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4
index 3b37d46..ed189c2 100644
--- a/m4/vsnprintf.m4
+++ b/m4/vsnprintf.m4
@@ -1,5 +1,5 @@
# vsnprintf.m4 serial 5
-dnl Copyright (C) 2002-2004, 2007-2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2007-2010 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.
diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4
new file mode 100644
index 0000000..42daae8
--- /dev/null
+++ b/m4/warn-on-use.m4
@@ -0,0 +1,45 @@
+# warn-on-use.m4 serial 2
+dnl Copyright (C) 2010 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+# gl_WARN_ON_USE_PREPARE(INCLUDES, NAMES)
+# ---------------------------------------
+# For each whitespace-separated element in the list of NAMES, define
+# HAVE_RAW_DECL_name if the function has a declaration among INCLUDES
+# even after being undefined as a macro.
+#
+# See warn-on-use.h for some hints on how to poison function names, as
+# well as ideas on poisoning global variables and macros. NAMES may
+# include global variables, but remember that only functions work with
+# _GL_WARN_ON_USE. Typically, INCLUDES only needs to list a single
+# header, but if the replacement header pulls in other headers because
+# 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
+# needing gl_WARN_ON_USE_PREPARE.
+AC_DEFUN([gl_WARN_ON_USE_PREPARE],
+[
+ m4_foreach_w([gl_decl], [$2],
+ [AH_TEMPLATE([HAVE_RAW_DECL_]AS_TR_CPP(m4_defn([gl_decl])),
+ [Define to 1 if ]m4_defn([gl_decl])[ is declared even after
+ undefining macros.])])dnl
+ for gl_func in m4_flatten([$2]); do
+ AS_VAR_PUSHDEF([gl_Symbol], [gl_cv_have_raw_decl_$gl_func])dnl
+ AC_CACHE_CHECK([whether $gl_func is declared without a macro],
+ gl_Symbol,
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([$1],
address@hidden:@undef $gl_func
+ (void) $gl_func;])],
+ [AS_VAR_SET(gl_Symbol, [yes])], [AS_VAR_SET(gl_Symbol, [no])])])
+ AS_VAR_IF(gl_Symbol, [yes],
+ [AC_DEFINE_UNQUOTED(AS_TR_CPP([HAVE_RAW_DECL_$gl_func]), [1])
+ dnl shortcut - if the raw declaration exists, then set a cache
+ dnl variable to allow skipping any later AC_CHECK_DECL efforts
+ eval ac_cv_have_decl_$gl_func=yes])
+ AS_VAR_POPDEF([gl_Symbol])dnl
+ done
+])
diff --git a/m4/warnings.m4 b/m4/warnings.m4
index 1639c03..dad5c1f 100644
--- a/m4/warnings.m4
+++ b/m4/warnings.m4
@@ -1,19 +1,11 @@
# warnings.m4 serial 2
-dnl Copyright (C) 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Simon Josefsson
-# gl_AS_VAR_IF(VAR, VALUE, [IF-MATCH], [IF-NOT-MATCH])
-# ----------------------------------------------------
-# Provide the functionality of AS_VAR_IF if Autoconf does not have it.
-m4_ifdef([AS_VAR_IF],
-[m4_copy([AS_VAR_IF], [gl_AS_VAR_IF])],
-[m4_define([gl_AS_VAR_IF],
-[AS_IF([test x"AS_VAR_GET([$1])" = x""$2], [$3], [$4])])])
-
# gl_AS_VAR_APPEND(VAR, VALUE)
# ----------------------------
# Provide the functionality of AS_VAR_APPEND if Autoconf does not have it.
@@ -37,7 +29,7 @@ AC_CACHE_CHECK([whether compiler handles $1], [gl_Warn], [
CPPFLAGS="$save_CPPFLAGS"
])
AS_VAR_PUSHDEF([gl_Flags], m4_if([$2], [], [[WARN_CFLAGS]], [[$2]]))dnl
-gl_AS_VAR_IF([gl_Warn], [yes], [gl_AS_VAR_APPEND([gl_Flags], [" $1"])])
+AS_VAR_IF([gl_Warn], [yes], [gl_AS_VAR_APPEND([gl_Flags], [" $1"])])
AS_VAR_POPDEF([gl_Flags])dnl
AS_VAR_POPDEF([gl_Warn])dnl
m4_ifval([$2], [AS_LITERAL_IF([$2], [AC_SUBST([$2])], [])])dnl
diff --git a/m4/wchar.m4 b/m4/wchar.m4
deleted file mode 100644
index 9f22e33..0000000
--- a/m4/wchar.m4
+++ /dev/null
@@ -1,105 +0,0 @@
-dnl A placeholder for ISO C99 <wchar.h>, for platforms that have issues.
-
-dnl Copyright (C) 2007-2009 Free Software Foundation, Inc.
-dnl This file is free software; the Free Software Foundation
-dnl gives unlimited permission to copy and/or distribute it,
-dnl with or without modifications, as long as this notice is preserved.
-
-dnl Written by Eric Blake.
-
-# wchar.m4 serial 26
-
-AC_DEFUN([gl_WCHAR_H],
-[
- AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
- AC_CACHE_CHECK([whether <wchar.h> is standalone],
- [gl_cv_header_wchar_h_standalone],
- [AC_COMPILE_IFELSE([[#include <wchar.h>
-wchar_t w;]],
- [gl_cv_header_wchar_h_standalone=yes],
- [gl_cv_header_wchar_h_standalone=no])])
-
- AC_REQUIRE([gt_TYPE_WINT_T])
- if test $gt_cv_c_wint_t = yes; then
- HAVE_WINT_T=1
- else
- HAVE_WINT_T=0
- fi
- AC_SUBST([HAVE_WINT_T])
-
- dnl If <stddef.h> is replaced, then <wchar.h> must also be replaced.
- AC_REQUIRE([gl_STDDEF_H])
-
- if test $gl_cv_header_wchar_h_standalone != yes || test $gt_cv_c_wint_t !=
yes || test -n "$STDDEF_H"; then
- WCHAR_H=wchar.h
- fi
-
- dnl Prepare for creating substitute <wchar.h>.
- dnl Do it always: WCHAR_H may be empty here but can be set later.
- dnl Check for <wchar.h> (missing in Linux uClibc when built without wide
- dnl character support).
- AC_CHECK_HEADERS_ONCE([wchar.h])
- if test $ac_cv_header_wchar_h = yes; then
- HAVE_WCHAR_H=1
- else
- HAVE_WCHAR_H=0
- fi
- AC_SUBST([HAVE_WCHAR_H])
- dnl Execute this unconditionally, because WCHAR_H may be set by other
- dnl modules, after this code is executed.
- gl_CHECK_NEXT_HEADERS([wchar.h])
-])
-
-dnl Unconditionally enables the replacement of <wchar.h>.
-AC_DEFUN([gl_REPLACE_WCHAR_H],
-[
- AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
- WCHAR_H=wchar.h
-])
-
-AC_DEFUN([gl_WCHAR_MODULE_INDICATOR],
-[
- dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
- AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
-
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
-])
-
-AC_DEFUN([gl_WCHAR_H_DEFAULTS],
-[
- GNULIB_BTOWC=0; AC_SUBST([GNULIB_BTOWC])
- GNULIB_WCTOB=0; AC_SUBST([GNULIB_WCTOB])
- GNULIB_MBSINIT=0; AC_SUBST([GNULIB_MBSINIT])
- GNULIB_MBRTOWC=0; AC_SUBST([GNULIB_MBRTOWC])
- GNULIB_MBRLEN=0; AC_SUBST([GNULIB_MBRLEN])
- GNULIB_MBSRTOWCS=0; AC_SUBST([GNULIB_MBSRTOWCS])
- GNULIB_MBSNRTOWCS=0; AC_SUBST([GNULIB_MBSNRTOWCS])
- GNULIB_WCRTOMB=0; AC_SUBST([GNULIB_WCRTOMB])
- GNULIB_WCSRTOMBS=0; AC_SUBST([GNULIB_WCSRTOMBS])
- GNULIB_WCSNRTOMBS=0; AC_SUBST([GNULIB_WCSNRTOMBS])
- GNULIB_WCWIDTH=0; AC_SUBST([GNULIB_WCWIDTH])
- dnl Assume proper GNU behavior unless another module says otherwise.
- HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC])
- HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT])
- HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC])
- HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN])
- HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS])
- HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS])
- HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB])
- HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS])
- HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS])
- HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB])
- HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH])
- REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T])
- REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC])
- REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB])
- REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT])
- REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC])
- REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN])
- REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS])
- REPLACE_MBSNRTOWCS=0; AC_SUBST([REPLACE_MBSNRTOWCS])
- REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB])
- REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS])
- REPLACE_WCSNRTOMBS=0; AC_SUBST([REPLACE_WCSNRTOMBS])
- REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH])
- WCHAR_H=''; AC_SUBST([WCHAR_H])
-])
diff --git a/m4/wchar_h.m4 b/m4/wchar_h.m4
new file mode 100644
index 0000000..0bce51c
--- /dev/null
+++ b/m4/wchar_h.m4
@@ -0,0 +1,152 @@
+dnl A placeholder for ISO C99 <wchar.h>, for platforms that have issues.
+
+dnl Copyright (C) 2007-2010 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl Written by Eric Blake.
+
+# wchar_h.m4 serial 32
+
+AC_DEFUN([gl_WCHAR_H],
+[
+ AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
+ AC_REQUIRE([gl_WCHAR_H_INLINE_OK])
+ dnl Prepare for creating substitute <wchar.h>.
+ dnl Check for <wchar.h> (missing in Linux uClibc when built without wide
+ dnl character support).
+ dnl <wchar.h> is always overridden, because of GNULIB_POSIXCHECK.
+ AC_CHECK_HEADERS_ONCE([wchar.h])
+ gl_CHECK_NEXT_HEADERS([wchar.h])
+ if test $ac_cv_header_wchar_h = yes; then
+ HAVE_WCHAR_H=1
+ else
+ HAVE_WCHAR_H=0
+ fi
+ AC_SUBST([HAVE_WCHAR_H])
+
+ AC_REQUIRE([gt_TYPE_WINT_T])
+ if test $gt_cv_c_wint_t = yes; then
+ HAVE_WINT_T=1
+ else
+ HAVE_WINT_T=0
+ fi
+ AC_SUBST([HAVE_WINT_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([[
+/* Some systems require additional headers. */
+#ifndef __GLIBC__
+# include <stddef.h>
+# include <stdio.h>
+# include <time.h>
+#endif
+#include <wchar.h>
+ ]], [btowc wctob mbsinit mbrtowc mbrlen mbsrtowcs mbsnrtowcs wcrtomb
+ wcsrtombs wcsnrtombs wcwidth])
+])
+
+dnl Check whether <wchar.h> is usable at all.
+AC_DEFUN([gl_WCHAR_H_INLINE_OK],
+[
+ dnl Test whether <wchar.h> suffers due to the transition from '__inline' to
+ dnl 'gnu_inline'. See <http://sourceware.org/bugzilla/show_bug.cgi?id=4022>
+ dnl and <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=42440>. In summary,
+ dnl glibc version 2.5 or older, together with gcc version 4.3 or newer and
+ dnl the option -std=c99 or -std=gnu99, leads to a broken <wchar.h>.
+ AC_CACHE_CHECK([whether <wchar.h> uses 'inline' correctly],
+ [gl_cv_header_wchar_h_correct_inline],
+ [gl_cv_header_wchar_h_correct_inline=yes
+ AC_LANG_CONFTEST([
+ AC_LANG_SOURCE([[#define wcstod renamed_wcstod
+#include <wchar.h>
+extern int zero (void);
+int main () { return zero(); }
+]])])
+ if AC_TRY_EVAL([ac_compile]); then
+ mv conftest.$ac_objext conftest1.$ac_objext
+ AC_LANG_CONFTEST([
+ AC_LANG_SOURCE([[#define wcstod renamed_wcstod
+#include <wchar.h>
+int zero (void) { return 0; }
+]])])
+ if AC_TRY_EVAL([ac_compile]); then
+ mv conftest.$ac_objext conftest2.$ac_objext
+ if $CC -o conftest$ac_exeext $CFLAGS $LDFLAGS conftest1.$ac_objext
conftest2.$ac_objext $LIBS >&AS_MESSAGE_LOG_FD 2>&1; then
+ :
+ else
+ gl_cv_header_wchar_h_correct_inline=no
+ fi
+ fi
+ fi
+ rm -f conftest1.$ac_objext conftest2.$ac_objext conftest$ac_exeext
+ ])
+ if test $gl_cv_header_wchar_h_correct_inline = no; then
+ AC_MSG_ERROR([<wchar.h> cannot be used with this compiler ($CC $CFLAGS
$CPPFLAGS).
+This is a known interoperability problem of glibc <= 2.5 with gcc >= 4.3 in
+C99 mode. You have four options:
+ - Add the flag -fgnu89-inline to CC and reconfigure, or
+ - Fix your include files, using parts of
+
<http://sourceware.org/git/?p=glibc.git;a=commitdiff;h=b037a293a48718af30d706c2e18c929d0e69a621>,
or
+ - Use a gcc version older than 4.3, or
+ - Don't use the flags -std=c99 or -std=gnu99.
+Configuration aborted.])
+ fi
+])
+
+dnl Unconditionally enables the replacement of <wchar.h>.
+AC_DEFUN([gl_REPLACE_WCHAR_H],
+[
+ dnl This is a no-op, because <wchar.h> is always overridden.
+ :
+])
+
+AC_DEFUN([gl_WCHAR_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR([$1])
+])
+
+AC_DEFUN([gl_WCHAR_H_DEFAULTS],
+[
+ GNULIB_BTOWC=0; AC_SUBST([GNULIB_BTOWC])
+ GNULIB_WCTOB=0; AC_SUBST([GNULIB_WCTOB])
+ GNULIB_MBSINIT=0; AC_SUBST([GNULIB_MBSINIT])
+ GNULIB_MBRTOWC=0; AC_SUBST([GNULIB_MBRTOWC])
+ GNULIB_MBRLEN=0; AC_SUBST([GNULIB_MBRLEN])
+ GNULIB_MBSRTOWCS=0; AC_SUBST([GNULIB_MBSRTOWCS])
+ GNULIB_MBSNRTOWCS=0; AC_SUBST([GNULIB_MBSNRTOWCS])
+ GNULIB_WCRTOMB=0; AC_SUBST([GNULIB_WCRTOMB])
+ GNULIB_WCSRTOMBS=0; AC_SUBST([GNULIB_WCSRTOMBS])
+ GNULIB_WCSNRTOMBS=0; AC_SUBST([GNULIB_WCSNRTOMBS])
+ GNULIB_WCWIDTH=0; AC_SUBST([GNULIB_WCWIDTH])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC])
+ HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT])
+ HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC])
+ HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN])
+ HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS])
+ HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS])
+ HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB])
+ HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS])
+ HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS])
+ HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB])
+ HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH])
+ REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T])
+ REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC])
+ REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB])
+ REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT])
+ REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC])
+ REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN])
+ REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS])
+ REPLACE_MBSNRTOWCS=0; AC_SUBST([REPLACE_MBSNRTOWCS])
+ REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB])
+ REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS])
+ REPLACE_WCSNRTOMBS=0; AC_SUBST([REPLACE_WCSNRTOMBS])
+ REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH])
+])
diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4
index fb27a7f..ed804e6 100644
--- a/m4/wchar_t.m4
+++ b/m4/wchar_t.m4
@@ -1,5 +1,5 @@
# wchar_t.m4 serial 3 (gettext-0.18)
-dnl Copyright (C) 2002-2003, 2008, 2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2008-2010 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.
diff --git a/m4/wint_t.m4 b/m4/wint_t.m4
index 47a4363..a6c7d15 100644
--- a/m4/wint_t.m4
+++ b/m4/wint_t.m4
@@ -1,5 +1,5 @@
# wint_t.m4 serial 4 (gettext-0.18)
-dnl Copyright (C) 2003, 2007-2009 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2007-2010 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.
diff --git a/m4/write.m4 b/m4/write.m4
index 812b19b..56325ab 100644
--- a/m4/write.m4
+++ b/m4/write.m4
@@ -1,5 +1,5 @@
# write.m4 serial 1
-dnl Copyright (C) 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2009, 2010 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.
diff --git a/m4/xsize.m4 b/m4/xsize.m4
index 631893c..b653693 100644
--- a/m4/xsize.m4
+++ b/m4/xsize.m4
@@ -1,5 +1,5 @@
# xsize.m4 serial 4
-dnl Copyright (C) 2003-2004, 2008 Free Software Foundation, Inc.
+dnl Copyright (C) 2003-2004, 2008-2010 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.
diff --git a/maint.mk b/maint.mk
index be061a6..7d84b6c 100644
--- a/maint.mk
+++ b/maint.mk
@@ -2,7 +2,7 @@
# This Makefile fragment tries to be general-purpose enough to be
# used by many projects via the gnulib maintainer-makefile module.
-## Copyright (C) 2001-2009 Free Software Foundation, Inc.
+## Copyright (C) 2001-2010 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
@@ -30,16 +30,38 @@ gzip_rsyncable := \
$(shell gzip --help 2>/dev/null|grep rsyncable >/dev/null && echo
--rsyncable)
GZIP_ENV = '--no-name --best $(gzip_rsyncable)'
-# cfg.mk must define the gpg_key_ID used by this package.
GIT = git
VC = $(GIT)
VC-tag = git tag -s -m '$(VERSION)' -u '$(gpg_key_ID)'
VC_LIST = $(build_aux)/vc-list-files -C $(srcdir)
+# You can override this variable in cfg.mk to set your own regexp
+# matching files to ignore.
+VC_LIST_ALWAYS_EXCLUDE_REGEX ?= ^$$
+
+# This is to preprocess robustly the output of $(VC_LIST), so that even
+# when $(srcdir) is a pathological name like "....", the leading sed command
+# removes only the intended prefix.
+_dot_escaped_srcdir = $(subst .,\.,$(srcdir))
+
+# Post-process $(VC_LIST) output, prepending $(srcdir)/, but only
+# when $(srcdir) is not ".".
+ifeq ($(srcdir),.)
+_prepend_srcdir_prefix =
+else
+_prepend_srcdir_prefix = | sed 's|^|$(srcdir)/|'
+endif
+
+# In order to be able to consistently filter "."-relative names,
+# (i.e., with no $(srcdir) prefix), this definition is careful to
+# remove any $(srcdir) prefix, and to restore what it removes.
VC_LIST_EXCEPT = \
- $(VC_LIST) | if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \
- else grep -Ev "$${VC_LIST_EXCEPT_DEFAULT-ChangeLog}"; fi
+ $(VC_LIST) | sed 's|^$(_dot_escaped_srcdir)/||' \
+ | if test -f $(srcdir)/.x-$@; then grep -vEf $(srcdir)/.x-$@; \
+ else grep -Ev -e "$${VC_LIST_EXCEPT_DEFAULT-ChangeLog}"; fi \
+ | grep -Ev -e '$(VC_LIST_ALWAYS_EXCLUDE_REGEX)' \
+ $(_prepend_srcdir_prefix)
ifeq ($(origin prev_version_file), undefined)
prev_version_file = $(srcdir)/.prev-version
@@ -103,7 +125,9 @@ local-checks-available = \
# Arrange to print the name of each syntax-checking rule just before running
it.
$(syntax-check-rules): %: %.m
-$(patsubst %, %.m, $(syntax-check-rules)):
+sc_m_rules_ = $(patsubst %, %.m, $(syntax-check-rules))
+.PHONY: $(sc_m_rules_)
+$(sc_m_rules_):
@echo $(patsubst sc_%.m, %, $@)
local-check := $(filter-out $(local-checks-to-skip), $(local-checks-available))
@@ -312,6 +336,11 @@ sc_prohibit_inttostr_without_use:
$(_header_without_use)
# Don't include this header unless you use one of its functions.
+sc_prohibit_ignore_value_without_use:
+ @h='"ignore-value.h"' re='\<ignore_(value|ptr) *\(' \
+ $(_header_without_use)
+
+# Don't include this header unless you use one of its functions.
sc_prohibit_error_without_use:
@h='"error.h"' \
re='\<error(_at_line|_print_progname|_one_per_line|_message_count)?
*\('\
@@ -325,15 +354,37 @@ sc_prohibit_error_without_use:
# | sort | perl -MRegexp::Assemble -le \
# 'print Regexp::Assemble->new(file => "/dev/stdin")->as_string'|sed
's/\?://g'
# Note this was produced by the above:
-# _xa1 = x(alloc_(oversized|die)|([cz]|2?re)alloc|m(alloc|emdup)|strdup)
-# But we can do better:
-_xa1 = x(alloc_(oversized|die)|([cmz]|2?re)alloc|(mem|str)dup)
+# _xa1 = \
+#x(((2n?)?re|c(har)?|n(re|m)|z)alloc|alloc_(oversized|die)|m(alloc|emdup)|strdup)
+# But we can do better, in at least two ways:
+# 1) take advantage of two "dup"-suffixed strings:
+# x(((2n?)?re|c(har)?|n(re|m)|[mz])alloc|alloc_(oversized|die)|(mem|str)dup)
+# 2) notice that "c(har)?|[mz]" is equivalent to the shorter and more readable
+# "char|[cmz]"
+# x(((2n?)?re|char|n(re|m)|[cmz])alloc|alloc_(oversized|die)|(mem|str)dup)
+_xa1 = x(((2n?)?re|char|n(re|m)|[cmz])alloc|alloc_(oversized|die)|(mem|str)dup)
_xa2 = X([CZ]|N?M)ALLOC
sc_prohibit_xalloc_without_use:
@h='"xalloc.h"' \
re='\<($(_xa1)|$(_xa2)) *\('\
$(_header_without_use)
+# Extract function names:
+# perl -lne '/^(?:extern )?(?:void|char) \*?(\w+) \(/ and print $1' lib/hash.h
+_hash_re = \
+clear|delete|free|get_(first|next)|insert|lookup|print_statistics|reset_tuning
+_hash_fn = \<($(_hash_re)) *\(
+_hash_struct = (struct )?\<[Hh]ash_(table|tuning)\>
+sc_prohibit_hash_without_use:
+ @h='"hash.h"' \
+ re='$(_hash_fn)|$(_hash_struct)'\
+ $(_header_without_use)
+
+sc_prohibit_hash_pjw_without_use:
+ @h='"hash-pjw.h"' \
+ re='\<hash_pjw *\(' \
+ $(_header_without_use)
+
sc_prohibit_safe_read_without_use:
@h='"safe-read.h"' re='(\<SAFE_READ_ERROR\>|\<safe_read *\()' \
$(_header_without_use)
@@ -490,6 +541,13 @@ sc_GPL_version:
@re='either ''version [^3]' msg='GPL vN, N!=3' \
$(_prohibit_regexp)
+# Require the latest GFDL. Two regexp, since some .texi files end up
+# line wrapping between 'Free Documentation License,' and 'Version'.
+_GFDL_regexp = (Free ''Documentation.*Version 1\.[^3]|Version 1\.[^3] or any)
+sc_GFDL_version:
+ @re='$(_GFDL_regexp)' msg='GFDL vN, N!=3' \
+ $(_prohibit_regexp)
+
cvs_keywords = \
Author|Date|Header|Id|Name|Locker|Log|RCSfile|Revision|Source|State
@@ -512,14 +570,20 @@ sc_prohibit_S_IS_definition:
msg='do not define S_IS* macros; include <sys/stat.h>' \
$(_prohibit_regexp)
-# Each program that uses proper_name_utf8 must link with
-# one of the ICONV libraries.
+# Each program that uses proper_name_utf8 must link with one of the
+# ICONV libraries. Otherwise, some ICONV library must appear in LDADD.
+# The perl -0777 invocation below extracts the possibly-multi-line
+# definition of LDADD from the appropriate Makefile.am and exits 0
+# when it contains "ICONV".
sc_proper_name_utf8_requires_ICONV:
@progs=$$(grep -l 'proper_name_utf8 ''("' $$($(VC_LIST_EXCEPT)));\
if test "x$$progs" != x; then \
fail=0; \
for p in $$progs; do \
dir=$$(dirname "$$p"); \
+ perl -0777 \
+ -ne 'exit !(/^LDADD =(.+?[^\\]\n)/ms && $$1 =~ /ICONV/)' \
+ $$dir/Makefile.am && continue; \
base=$$(basename "$$p" .c); \
grep "$${base}_LDADD.*ICONV)" $$dir/Makefile.am > /dev/null \
|| { fail=1; echo 1>&2 "$(ME): $$p uses proper_name_utf8"; }; \
@@ -545,7 +609,8 @@ sc_const_long_option:
NEWS_hash = \
$$(sed -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \
$(srcdir)/NEWS \
- | grep -v '^Copyright .*Free Software' \
+ | perl -0777 -pe \
+ 's/^Copyright.+?Free\sSoftware\sFoundation,\sInc\.\n//ms' \
| md5sum -
\
| sed 's/ .*//')
@@ -567,8 +632,12 @@ update-NEWS-hash: NEWS
# to emit a definition for each substituted variable.
# We use perl rather than "grep -nE ..." to exempt a single
# use of an @address@hidden variable name in src/Makefile.am.
-sc_makefile_check:
- @perl -ne '/address@hidden@/ && !/^cu_install_program =/' \
+# Allow the package to add exceptions via a hook in cfg.mk;
+# for example, @PRAGMA_SYSTEM_HEADER@ can be permitted by
+# setting this to ' && !/PRAGMA_SYSTEM_HEADER/'.
+_makefile_at_at_check_exceptions ?=
+sc_makefile_at_at_check:
+ @perl -ne '/address@hidden@/'$(_makefile_at_at_check_exceptions)
\
-e 'and (print "$$ARGV:$$.: $$_"), $$m=1; END {exit !$$m}' \
$$($(VC_LIST_EXCEPT) | grep -E '(^|/)Makefile\.am$$') \
&& { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || :
@@ -672,6 +741,27 @@ sc_copyright_check:
exit 1; }; \
fi
+# #if HAVE_... will evaluate to false for any non numeric string.
+# That would be flagged by using -Wundef, however gnulib currently
+# tests many undefined macros, and so we can't enable that option.
+# So at least preclude common boolean strings as macro values.
+sc_Wundef_boolean:
+ @grep -Ei '^#define.*(yes|no|true|false)$$' '$(CONFIG_INCLUDE)' && \
+ { echo 'Use 0 or 1 for macro values' 1>&2; exit 1; } || :
+
+sc_vulnerable_makefile_CVE-2009-4029:
+ @files=$$(find $(srcdir) -name Makefile.in); \
+ if test -n "$$files"; then \
+ grep -E \
+ 'perm -777 -exec chmod a\+rwx|chmod 777 \$$\(distdir\)' \
+ $$files && \
+ { echo '$(ME): the above files are vulnerable; beware of' \
+ 'running "make dist*" rules, and upgrade to fixed automake' \
+ 'see http://bugzilla.redhat.com/542609 for details' \
+ 1>&2; exit 1; } || :; \
+ else :; \
+ fi
+
vc-diff-check:
(unset CDPATH; cd $(srcdir) && $(VC) diff) > vc-diffs || :
if test -s vc-diffs; then \
@@ -688,6 +778,13 @@ gnulib_dir ?= $(srcdir)/gnulib
gnulib-version = $$(cd $(gnulib_dir) && git describe)
bootstrap-tools ?= autoconf,automake,gnulib
+# If it's not already specified, derive the GPG key ID from
+# the signed tag we've just applied to mark this release.
+gpg_key_ID ?= \
+ $$(git cat-file tag v$(VERSION) > .ann-sig \
+ && gpgv .ann-sig - < /dev/null 2>&1 \
+ | sed -n '/.*key ID \([0-9A-F]*\)/s//\1/p'; rm -f .ann-sig)
+
announcement: NEWS ChangeLog $(rel-files)
@$(build_aux)/announce-gen \
--release-type=$(RELEASE_TYPE) \
@@ -695,7 +792,7 @@ announcement: NEWS ChangeLog $(rel-files)
--prev=$(PREV_VERSION) \
--curr=$(VERSION) \
--gpg-key-id=$(gpg_key_ID) \
- --news=NEWS \
+ --news=$(srcdir)/NEWS \
--bootstrap-tools=$(bootstrap-tools) \
--gnulib-version=$(gnulib-version) \
--no-print-checksums \
@@ -708,13 +805,14 @@ announcement: NEWS ChangeLog $(rel-files)
ftp-gnu = ftp://ftp.gnu.org/gnu
www-gnu = http://www.gnu.org
+upload_dest_dir_ ?= $(PACKAGE)
emit_upload_commands:
@echo =====================================
@echo =====================================
@echo "$(build_aux)/gnupload $(GNUPLOADFLAGS) \\"
- @echo " --to $(gnu_rel_host):$(PACKAGE) \\"
+ @echo " --to $(gnu_rel_host):$(upload_dest_dir_) \\"
@echo " $(rel-files)"
- @echo '# send the /tmp/announcement e-mail'
+ @echo '# send the ~/announce-$(my_distdir) e-mail'
@echo =====================================
@echo =====================================
@@ -760,7 +858,7 @@ release-prep-hook ?= release-prep
release-prep:
case $$RELEASE_TYPE in alpha|beta|stable) ;; \
*) echo "invalid RELEASE_TYPE: $$RELEASE_TYPE" 1>&2; exit 1;; esac
- $(MAKE) -s announcement > /tmp/announce-$(my_distdir)
+ $(MAKE) -s announcement > ~/announce-$(my_distdir)
if test -d $(release_archive_dir); then \
ln $(rel-files) $(release_archive_dir); \
chmod a-w $(rel-files); \
@@ -770,6 +868,7 @@ release-prep:
perl -pi -e '$$. == 3 and print "$(noteworthy)\n\n\n"' NEWS
$(emit-commit-log) > .ci-msg
$(VC) commit -F .ci-msg -a
+ rm .ci-msg
.PHONY: web-manual
web-manual:
diff --git a/meta/Makefile.am b/meta/Makefile.am
index ad269ba..fe4aeb4 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -34,7 +34,7 @@ pkgconfig_DATA = guile-2.0.pc
aclocaldir = $(datadir)/aclocal
aclocal_DATA = guile.m4
-guile-config: $(srcdir)/guile-config.in
+guile-config: $(srcdir)/guile-config.in $(top_builddir)/config.status
guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ;
\
cat $(srcdir)/guile-config.in
\
| $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g ;
\
diff --git a/meta/guile-2.0-uninstalled.pc.in b/meta/guile-2.0-uninstalled.pc.in
index 6e687ea..4bf6058 100644
--- a/meta/guile-2.0-uninstalled.pc.in
+++ b/meta/guile-2.0-uninstalled.pc.in
@@ -4,5 +4,5 @@ address@hidden@
Name: GNU Guile (uninstalled)
Description: GNU's Ubiquitous Intelligent Language for Extension (uninstalled)
Version: @GUILE_VERSION@
-Libs: -L${builddir}/libguile -lguile @GUILE_LIBS@
+Libs: -L${builddir}/libguile address@hidden@ @GUILE_LIBS@
Cflags: -I${srcdir} -I${builddir} @GUILE_CFLAGS@ @BDW_GC_CFLAGS@
diff --git a/meta/guile-2.0.pc.in b/meta/guile-2.0.pc.in
index c73a171..c83d821 100644
--- a/meta/guile-2.0.pc.in
+++ b/meta/guile-2.0.pc.in
@@ -5,6 +5,7 @@ address@hidden@
address@hidden@
address@hidden@
address@hidden@/guile
address@hidden@/guile
address@hidden@
address@hidden@/guile/@GUILE_EFFECTIVE_VERSION@/extensions
@@ -13,5 +14,5 @@ address@hidden@
Name: GNU Guile
Description: GNU's Ubiquitous Intelligent Language for Extension
Version: @GUILE_VERSION@
-Libs: -L${libdir} -lguile @GUILE_LIBS@
-Cflags: -I${includedir} @GUILE_CFLAGS@ @BDW_GC_CFLAGS@
+Libs: -L${libdir} address@hidden@ @GUILE_LIBS@
+Cflags: -I${pkgincludedir}/@GUILE_EFFECTIVE_VERSION@ @GUILE_CFLAGS@
@BDW_GC_CFLAGS@
diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index 51d103f..74870ff 100755
--- a/meta/guile-tools.in
+++ b/meta/guile-tools.in
@@ -6,7 +6,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0"
"$@"
;;;; guile-tools --- running scripts bundled with Guile
;;;; Andy Wingo <address@hidden> --- April 2009
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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
@@ -109,6 +109,7 @@ PROGRAM is run with ARGS.
m)))
(define (main args)
+ (setlocale LC_ALL "")
(if (or (equal? (cdr args) '())
(equal? (cdr args) '("list")))
(list-scripts)
diff --git a/module/Makefile.am b/module/Makefile.am
index 21c3624..16013b0 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2009 Free Software Foundation, Inc.
+## Copyright (C) 2009, 2010 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -63,7 +63,8 @@ SOURCES = \
$(SCRIPTS_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(ELISP_LANG_SOURCES) \
- $(BRAINFUCK_LANG_SOURCES)
+ $(BRAINFUCK_LANG_SOURCES) \
+ $(LIB_SOURCES)
## test.scm is not currently installed.
EXTRA_DIST += \
@@ -116,7 +117,6 @@ VALUE_LANG_SOURCES = \
language/value/spec.scm
ECMASCRIPT_LANG_SOURCES = \
- language/ecmascript/parse-lalr.scm \
language/ecmascript/tokenize.scm \
language/ecmascript/parse.scm \
language/ecmascript/impl.scm \
@@ -164,11 +164,12 @@ SCRIPTS_SOURCES = \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm
-SYSTEM_BASE_SOURCES = \
+SYSTEM_BASE_SOURCES = \
system/base/pmatch.scm \
system/base/syntax.scm \
system/base/compile.scm \
system/base/language.scm \
+ system/base/lalr.scm \
system/base/message.scm
ICE_9_SOURCES = \
@@ -177,6 +178,8 @@ ICE_9_SOURCES = \
ice-9/and-let-star.scm \
ice-9/calling.scm \
ice-9/common-list.scm \
+ ice-9/control.scm \
+ ice-9/curried-definitions.scm \
ice-9/debug.scm \
ice-9/debugger.scm \
ice-9/documentation.scm \
@@ -223,7 +226,8 @@ ICE_9_SOURCES = \
ice-9/deprecated.scm \
ice-9/list.scm \
ice-9/serialize.scm \
- ice-9/gds-server.scm
+ ice-9/gds-server.scm \
+ ice-9/vlist.scm
SRFI_SOURCES = \
srfi/srfi-1.scm \
@@ -273,30 +277,60 @@ OOP_SOURCES = \
oop/goops/accessors.scm \
oop/goops/simple.scm
-SYSTEM_SOURCES = \
- system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
- system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
- system/vm/trace.scm system/vm/vm.scm \
- \
- system/xref.scm \
- \
- system/repl/repl.scm system/repl/common.scm \
+SYSTEM_SOURCES = \
+ system/vm/inspect.scm \
+ system/vm/debug.scm \
+ system/vm/frame.scm \
+ system/vm/instruction.scm \
+ system/vm/objcode.scm \
+ system/vm/profile.scm \
+ system/vm/program.scm \
+ system/vm/trace.scm \
+ system/vm/vm.scm \
+ system/foreign.scm \
+ system/xref.scm \
+ system/repl/repl.scm \
+ system/repl/common.scm \
system/repl/command.scm
+LIB_SOURCES = \
+ statprof.scm \
+ sxml/apply-templates.scm \
+ sxml/fold.scm \
+ sxml/simple.scm \
+ sxml/ssax/input-parse.scm \
+ sxml/ssax.scm \
+ sxml/transform.scm \
+ sxml/xpath.scm \
+ texinfo.scm \
+ texinfo/docbook.scm \
+ texinfo/html.scm \
+ texinfo/indexing.scm \
+ texinfo/string-utils.scm \
+ texinfo/plain-text.scm \
+ texinfo/reflection.scm \
+ texinfo/serialize.scm
+
EXTRA_DIST += oop/ChangeLog-2008
NOCOMP_SOURCES = \
- ice-9/gds-client.scm \
- ice-9/psyntax.scm \
- ice-9/quasisyntax.scm \
- system/repl/describe.scm \
- ice-9/debugger/command-loop.scm \
- ice-9/debugger/commands.scm \
- ice-9/debugger/state.scm \
- ice-9/debugger/trc.scm \
- ice-9/debugger/utils.scm \
- ice-9/debugging/example-fns.scm \
- ice-9/debugging/steps.scm \
- ice-9/debugging/trace.scm \
- ice-9/debugging/traps.scm \
- ice-9/debugging/trc.scm
+ ice-9/gds-client.scm \
+ ice-9/psyntax.scm \
+ ice-9/quasisyntax.scm \
+ system/base/lalr.upstream.scm \
+ system/repl/describe.scm \
+ ice-9/debugger/command-loop.scm \
+ ice-9/debugger/commands.scm \
+ ice-9/debugger/state.scm \
+ ice-9/debugger/trc.scm \
+ ice-9/debugger/utils.scm \
+ ice-9/debugging/example-fns.scm \
+ ice-9/debugging/steps.scm \
+ ice-9/debugging/trace.scm \
+ ice-9/debugging/traps.scm \
+ ice-9/debugging/trc.scm \
+ sxml/upstream/SSAX.scm \
+ sxml/upstream/SXML-tree-trans.scm \
+ sxml/upstream/SXPath-old.scm \
+ sxml/upstream/assert.scm \
+ sxml/upstream/input-parse.scm
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 20da580..ffd1f68 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+;;;; Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -40,6 +40,165 @@
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
+
+
+;;; {Error handling}
+;;;
+
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
+
+(define (make-prompt-tag . stem)
+ (gensym (if (pair? stem) (car stem) "prompt")))
+(define default-prompt-tag
+ ;; not sure if we should expose this to the user as a fluid
+ (let ((%default-prompt-tag (make-prompt-tag)))
+ (lambda ()
+ %default-prompt-tag)))
+
+(define (call-with-prompt tag thunk handler)
+ (@prompt tag (thunk) handler))
+(define (abort-to-prompt tag . args)
+ (@abort tag args))
+
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(let ()
+ ;; Ideally we'd like to be able to give these default values for all threads,
+ ;; even threads not created by Guile; but alack, that does not currently seem
+ ;; possible. So wrap the getters in thunks.
+ (define %running-exception-handlers (make-fluid))
+ (define %exception-handler (make-fluid))
+
+ (define (running-exception-handlers)
+ (or (fluid-ref %running-exception-handlers)
+ (begin
+ (fluid-set! %running-exception-handlers '())
+ '())))
+ (define (exception-handler)
+ (or (fluid-ref %exception-handler)
+ (begin
+ (fluid-set! %exception-handler default-exception-handler)
+ default-exception-handler)))
+
+ (define (default-exception-handler k . args)
+ (cond
+ ((eq? k 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (else
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
+ (primitive-exit 1))))
+
+ (define (default-throw-handler prompt-tag catch-k)
+ (let ((prev (exception-handler)))
+ (lambda (thrown-k . args)
+ (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+ (apply abort-to-prompt prompt-tag thrown-k args)
+ (apply prev thrown-k args)))))
+
+ (define (custom-throw-handler prompt-tag catch-k pre)
+ (let ((prev (exception-handler)))
+ (lambda (thrown-k . args)
+ (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+ (let ((running (running-exception-handlers)))
+ (with-fluids ((%running-exception-handlers (cons pre running)))
+ (if (not (memq pre running))
+ (apply pre thrown-k args))
+ ;; fall through
+ (if prompt-tag
+ (apply abort-to-prompt prompt-tag thrown-k args)
+ (apply prev thrown-k args))))
+ (apply prev thrown-k args)))))
+
+ (define! 'catch
+ ;; Until we get optargs support into Guile's C evaluator, we have to fake
it
+ ;; here.
+ (lambda (k thunk handler . pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
address@hidden, then @var{handler} is invoked this way:
address@hidden
+ (handler key args ...)
address@hidden lisp
+
address@hidden is a symbol or @code{#t}.
+
address@hidden takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
address@hidden before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "catch" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluids
+ ((%exception-handler
+ (if (null? pre-unwind-handler)
+ (default-throw-handler tag k)
+ (custom-throw-handler tag k
+ (car pre-unwind-handler)))))
+ (thunk)))
+ (lambda (cont k . args)
+ (apply handler k args))))))
+
+ (define! 'with-throw-handler
+ (lambda (k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
+for key @var{key}, then invoke @var{thunk}."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "with-throw-handler" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluids ((%exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)))
+ (thunk))))
+
+ (define! 'throw
+ (lambda (key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
address@hidden
+
address@hidden is a symbol. It will match catches of the same symbol or of
@code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+ (if (not (symbol? key))
+ ((exception-handler) 'wrong-type-arg "throw"
+ "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
+ (apply (exception-handler) key args)))))
+
+
+
+
;;; {R4RS compliance}
;;;
@@ -55,8 +214,8 @@
;; It is handy to wrap around an expression to look at
;; a value each time is evaluated, e.g.:
;;
-;; (+ 10 (troublesome-fn))
-;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
+;; (+ 10 (troublesome-fn))
+;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
;;
(define (peek . stuff)
@@ -110,11 +269,11 @@
;;
(define (and-map f lst)
(let loop ((result #t)
- (l lst))
+ (l lst))
(and result
- (or (and (null? l)
- result)
- (loop (f (car l)) (cdr l))))))
+ (or (and (null? l)
+ result)
+ (loop (f (car l)) (cdr l))))))
;; or-map f l
;;
@@ -123,10 +282,10 @@
;;
(define (or-map f lst)
(let loop ((result #f)
- (l lst))
+ (l lst))
(or result
- (and (not (null? l))
- (loop (f (car l)) (cdr l))))))
+ (and (not (null? l))
+ (loop (f (car l)) (cdr l))))))
@@ -138,29 +297,29 @@
;; per SRFI-13 spec
(define (string-any char_pred s . rest)
(let ((start (if (null? rest)
- 0 (car rest)))
- (end (if (or (null? rest) (null? (cdr rest)))
- (string-length s) (cadr rest))))
+ 0 (car rest)))
+ (end (if (or (null? rest) (null? (cdr rest)))
+ (string-length s) (cadr rest))))
(if (and (procedure? char_pred)
- (> end start)
- (<= end (string-length s))) ;; let c-code handle range error
- (or (string-any-c-code char_pred s start (1- end))
- (char_pred (string-ref s (1- end))))
- (string-any-c-code char_pred s start end))))
+ (> end start)
+ (<= end (string-length s))) ;; let c-code handle range error
+ (or (string-any-c-code char_pred s start (1- end))
+ (char_pred (string-ref s (1- end))))
+ (string-any-c-code char_pred s start end))))
;; this is scheme wrapping the C code so the final pred call is a tail call,
;; per SRFI-13 spec
(define (string-every char_pred s . rest)
(let ((start (if (null? rest)
- 0 (car rest)))
- (end (if (or (null? rest) (null? (cdr rest)))
- (string-length s) (cadr rest))))
+ 0 (car rest)))
+ (end (if (or (null? rest) (null? (cdr rest)))
+ (string-length s) (cadr rest))))
(if (and (procedure? char_pred)
- (> end start)
- (<= end (string-length s))) ;; let c-code handle range error
- (and (string-every-c-code char_pred s start (1- end))
- (char_pred (string-ref s (1- end))))
- (string-every-c-code char_pred s start end))))
+ (> end start)
+ (<= end (string-length s))) ;; let c-code handle range error
+ (and (string-every-c-code char_pred s start (1- end))
+ (char_pred (string-ref s (1- end))))
+ (string-every-c-code char_pred s start end))))
;; A variant of string-fill! that we keep for compatability
;;
@@ -198,9 +357,9 @@
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
-(define sc-expand #f)
+(define macroexpand #f)
-;; $sc-expand is an implementation detail of psyntax. It is used by
+;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
(define $sc-dispatch #f)
@@ -209,7 +368,7 @@
;; %pre-modules-transformer is the Scheme expander from now until the
;; module system has booted up.
-(define %pre-modules-transformer sc-expand)
+(define %pre-modules-transformer macroexpand)
(define-syntax and
(syntax-rules ()
@@ -353,31 +512,32 @@
"Define a defmacro."
(syntax-case x ()
((_ (macro . args) doc body1 body ...)
- (string? (syntax->datum (syntax doc)))
- (syntax (define-macro macro doc (lambda args body1 body ...))))
+ (string? (syntax->datum #'doc))
+ #'(define-macro macro doc (lambda args body1 body ...)))
((_ (macro . args) body ...)
- (syntax (define-macro macro #f (lambda args body ...))))
+ #'(define-macro macro #f (lambda args body ...)))
((_ macro doc transformer)
- (or (string? (syntax->datum (syntax doc)))
- (not (syntax->datum (syntax doc))))
- (syntax
- (define-syntax macro
- (lambda (y)
- doc
- (syntax-case y ()
- ((_ . args)
- (let ((v (syntax->datum (syntax args))))
- (datum->syntax y (apply transformer v))))))))))))
+ (or (string? (syntax->datum #'doc))
+ (not (syntax->datum #'doc)))
+ #'(define-syntax macro
+ (lambda (y)
+ doc
+ #((macro-type . defmacro)
+ (defmacro-args args))
+ (syntax-case y ()
+ ((_ . args)
+ (let ((v (syntax->datum #'args)))
+ (datum->syntax y (apply transformer v)))))))))))
(define-syntax defmacro
(lambda (x)
"Define a defmacro, with the old lispy defun syntax."
(syntax-case x ()
((_ macro args doc body1 body ...)
- (string? (syntax->datum (syntax doc)))
- (syntax (define-macro macro doc (lambda args body1 body ...))))
+ (string? (syntax->datum #'doc))
+ #'(define-macro macro doc (lambda args body1 body ...)))
((_ macro args body ...)
- (syntax (define-macro macro #f (lambda args body ...)))))))
+ #'(define-macro macro #f (lambda args body ...))))))
(provide 'defmacro)
@@ -409,9 +569,9 @@
;;; perform binding in many circumstances when the "let" family of
;;; of forms don't cut it. E.g.:
;;;
-;;; (apply-to-args (return-3d-mouse-coords)
-;;; (lambda (x y z)
-;;; ...))
+;;; (apply-to-args (return-3d-mouse-coords)
+;;; (lambda (x y z)
+;;; ...))
;;;
(define (apply-to-args args fn) (apply fn args))
@@ -420,8 +580,8 @@
`(catch #t
(lambda ()
;; avoid saving backtraces inside false-if-exception
- (with-fluid* the-last-stack (fluid-ref the-last-stack)
- (lambda () ,expr)))
+ (with-fluids ((the-last-stack (fluid-ref the-last-stack)))
+ ,expr))
(lambda args #f)))
@@ -450,13 +610,13 @@
(define (set-symbol-property! sym prop val)
(let ((pair (assoc prop (symbol-pref sym))))
(if pair
- (set-cdr! pair val)
- (symbol-pset! sym (acons prop val (symbol-pref sym))))))
+ (set-cdr! pair val)
+ (symbol-pset! sym (acons prop val (symbol-pref sym))))))
(define (symbol-property-remove! sym prop)
(let ((pair (assoc prop (symbol-pref sym))))
(if pair
- (symbol-pset! sym (delq! pair (symbol-pref sym))))))
+ (symbol-pset! sym (delq! pair (symbol-pref sym))))))
@@ -509,13 +669,13 @@
;; 0: type-name, 1: fields
(define record-type-vtable
(make-vtable-vtable "prpr" 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))))))
+ (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))))))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
@@ -523,30 +683,30 @@
(define (make-record-type type-name fields . opt)
(let ((printer-fn (and (pair? opt) (car opt))))
(let ((struct (make-struct record-type-vtable 0
- (make-struct-layout
- (apply string-append
- (map (lambda (f) "pw") fields)))
- (or printer-fn
- (lambda (s p)
- (display "#<" p)
- (display type-name p)
- (let loop ((fields fields)
- (off 0))
- (cond
- ((not (null? fields))
- (display " " p)
- (display (car fields) p)
- (display ": " p)
- (display (struct-ref s off) p)
- (loop (cdr fields) (+ 1 off)))))
- (display ">" p)))
- type-name
- (copy-tree fields))))
+ (make-struct-layout
+ (apply string-append
+ (map (lambda (f) "pw") fields)))
+ (or printer-fn
+ (lambda (s p)
+ (display "#<" p)
+ (display type-name p)
+ (let loop ((fields fields)
+ (off 0))
+ (cond
+ ((not (null? fields))
+ (display " " p)
+ (display (car fields) p)
+ (display ": " p)
+ (display (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p)))
+ type-name
+ (copy-tree fields))))
;; Temporary solution: Associate a name to the record type descriptor
;; so that the object system can create a wrapper class for it.
(set-struct-vtable-name! struct (if (symbol? type-name)
- type-name
- (string->symbol type-name)))
+ type-name
+ (string->symbol type-name)))
struct)))
(define (record-type-name obj)
@@ -575,14 +735,14 @@
(define (%record-type-error rtd obj) ;; private helper
(or (eq? rtd (record-type-descriptor obj))
(scm-error 'wrong-type-arg "%record-type-check"
- "Wrong type record (want `~S'): ~S"
- (list (record-type-name rtd) obj)
- #f)))
+ "Wrong type record (want `~S'): ~S"
+ (list (record-type-name rtd) obj)
+ #f)))
(define (record-accessor rtd field-name)
(let ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos)
- (error 'no-such-field field-name))
+ (error 'no-such-field field-name))
(lambda (obj)
(if (eq? (struct-vtable obj) rtd)
(struct-ref obj pos)
@@ -591,7 +751,7 @@
(define (record-modifier rtd field-name)
(let ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos)
- (error 'no-such-field field-name))
+ (error 'no-such-field field-name))
(lambda (obj val)
(if (eq? (struct-vtable obj) rtd)
(struct-set! obj pos val)
@@ -635,11 +795,11 @@
(define (list-index l k)
(let loop ((n 0)
- (l l))
+ (l l))
(and (not (null? l))
- (if (eq? (car l) k)
- n
- (loop (+ n 1) (cdr l))))))
+ (if (eq? (car l) k)
+ n
+ (loop (+ n 1) (cdr l))))))
@@ -653,24 +813,24 @@
(define file-exists?
(if (provided? 'posix)
(lambda (str)
- (->bool (stat str #f)))
+ (->bool (stat str #f)))
(lambda (str)
- (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
- (lambda args #f))))
- (if port (begin (close-port port) #t)
- #f)))))
+ (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
(define file-is-directory?
(if (provided? 'posix)
(lambda (str)
- (eq? (stat:type (stat str)) 'directory))
+ (eq? (stat:type (stat str)) 'directory))
(lambda (str)
- (let ((port (catch 'system-error
- (lambda () (open-file (string-append str "/.")
- OPEN_READ))
- (lambda args #f))))
- (if port (begin (close-port port) #t)
- #f)))))
+ (let ((port (catch 'system-error
+ (lambda () (open-file (string-append str "/.")
+ OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
(define (has-suffix? str suffix)
(string-suffix? suffix str))
@@ -690,11 +850,11 @@
(if (null? args)
(scm-error 'misc-error #f "?" #f #f)
(let loop ((msg "~A")
- (rest (cdr args)))
- (if (not (null? rest))
- (loop (string-append msg " ~S")
- (cdr rest))
- (scm-error 'misc-error #f msg args #f)))))
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " ~S")
+ (cdr rest))
+ (scm-error 'misc-error #f msg args #f)))))
;; bad-throw is the hook that is called upon a throw to a an unhandled
;; key (unless the throw has four arguments, in which case
@@ -705,7 +865,7 @@
(define (bad-throw key . args)
(let ((default (symbol-property key 'throw-handler-default)))
(or (and default (apply default key args))
- (apply error "unhandled-exception:" key args))))
+ (apply error "unhandled-exception:" key args))))
@@ -746,24 +906,24 @@
(define (move->fdes fd/port fd)
(cond ((integer? fd/port)
- (dup->fdes fd/port fd)
- (close fd/port)
- fd)
- (else
- (primitive-move->fdes fd/port fd)
- (set-port-revealed! fd/port 1)
- fd/port)))
+ (dup->fdes fd/port fd)
+ (close fd/port)
+ fd)
+ (else
+ (primitive-move->fdes fd/port fd)
+ (set-port-revealed! fd/port 1)
+ fd/port)))
(define (release-port-handle port)
(let ((revealed (port-revealed port)))
(if (> revealed 0)
- (set-port-revealed! port (- revealed 1)))))
+ (set-port-revealed! port (- revealed 1)))))
(define (dup->port port/fd mode . maybe-fd)
(let ((port (fdopen (apply dup->fdes port/fd maybe-fd)
- mode)))
+ mode)))
(if (pair? maybe-fd)
- (set-port-revealed! port 1))
+ (set-port-revealed! port 1))
port))
(define (dup->inport port/fd . maybe-fd)
@@ -783,28 +943,28 @@
(define (fdes->inport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
- (let ((result (fdopen fdes "r")))
- (set-port-revealed! result 1)
- result))
- ((input-port? (car rest-ports))
- (set-port-revealed! (car rest-ports)
- (+ (port-revealed (car rest-ports)) 1))
- (car rest-ports))
- (else
- (loop (cdr rest-ports))))))
+ (let ((result (fdopen fdes "r")))
+ (set-port-revealed! result 1)
+ result))
+ ((input-port? (car rest-ports))
+ (set-port-revealed! (car rest-ports)
+ (+ (port-revealed (car rest-ports)) 1))
+ (car rest-ports))
+ (else
+ (loop (cdr rest-ports))))))
(define (fdes->outport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
- (let ((result (fdopen fdes "w")))
- (set-port-revealed! result 1)
- result))
- ((output-port? (car rest-ports))
- (set-port-revealed! (car rest-ports)
- (+ (port-revealed (car rest-ports)) 1))
- (car rest-ports))
- (else
- (loop (cdr rest-ports))))))
+ (let ((result (fdopen fdes "w")))
+ (set-port-revealed! result 1)
+ result))
+ ((output-port? (car rest-ports))
+ (set-port-revealed! (car rest-ports)
+ (+ (port-revealed (car rest-ports)) 1))
+ (car rest-ports))
+ (else
+ (loop (cdr rest-ports))))))
(define (port->fdes port)
(set-port-revealed! port (+ (port-revealed port) 1))
@@ -830,15 +990,15 @@
(define (in-vicinity vicinity file)
(let ((tail (let ((len (string-length vicinity)))
- (if (zero? len)
- #f
- (string-ref vicinity (- len 1))))))
+ (if (zero? len)
+ #f
+ (string-ref vicinity (- len 1))))))
(string-append vicinity
- (if (or (not tail)
- (eq? tail #\/))
- ""
- "/")
- file)))
+ (if (or (not tail)
+ (eq? tail #\/))
+ ""
+ "/")
+ file)))
@@ -861,19 +1021,32 @@
(define (load-user-init)
(let* ((home (or (getenv "HOME")
- (false-if-exception (passwd:dir (getpwuid (getuid))))
- "/")) ;; fallback for cygwin etc.
- (init-file (in-vicinity home ".guile")))
+ (false-if-exception (passwd:dir (getpwuid (getuid))))
+ "/")) ;; fallback for cygwin etc.
+ (init-file (in-vicinity home ".guile")))
(if (file-exists? init-file)
- (primitive-load init-file))))
+ (primitive-load init-file))))
;;; {The interpreter stack}
;;;
-(defmacro start-stack (tag exp)
- `(%start-stack ,tag (lambda () ,exp)))
+;; %stacks defined in stacks.c
+(define (%start-stack tag thunk)
+ (let ((prompt-tag (make-prompt-tag "start-stack")))
+ (call-with-prompt
+ prompt-tag
+ (lambda ()
+ (with-fluids ((%stacks (acons tag prompt-tag
+ (or (fluid-ref %stacks) '()))))
+ (thunk)))
+ (lambda (k . args)
+ (%start-stack tag (lambda () (apply k args)))))))
+(define-syntax start-stack
+ (syntax-rules ()
+ ((_ tag exp)
+ (%start-stack tag (lambda () exp)))))
@@ -885,7 +1058,7 @@
;;; name extensions listed in %load-extensions.
(define (load-from-path name)
(start-stack 'load-stack
- (primitive-load-path name)))
+ (primitive-load-path name)))
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
@@ -893,12 +1066,12 @@
(define (%load-announce file)
(if %load-verbosely
(with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display "loading ")
- (display file)
- (newline)
- (force-output)))))
+ (lambda ()
+ (display ";;; ")
+ (display "loading ")
+ (display file)
+ (newline)
+ (force-output)))))
(set! %load-hook %load-announce)
@@ -908,19 +1081,34 @@
;; date, and autocompilation is enabled, will try autocompilation, just
;; as primitive-load-path does internally. primitive-load is
;; unaffected. Returns #f if autocompilation failed or was disabled.
- (define (autocompiled-file-name name)
+ ;;
+ ;; NB: Unless we need to compile the file, this function should not cause
+ ;; (system base compile) to be loaded up. For that reason compiled-file-name
+ ;; partially duplicates functionality from (system base compile).
+ (define (compiled-file-name canon-path)
+ (and %compile-fallback-path
+ (string-append
+ %compile-fallback-path
+ ;; no need for '/' separator here, canon-path is absolute
+ canon-path
+ (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions))))))
+ (define (fresh-compiled-file-name go-path)
(catch #t
(lambda ()
- (let* ((cfn ((@ (system base compile) compiled-file-name) name))
- (scmstat (stat name))
- (gostat (stat cfn #f)))
+ (let* ((scmstat (stat name))
+ (gostat (stat go-path #f)))
(if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
- cfn
+ go-path
(begin
(if gostat
(format (current-error-port)
";;; note: source file ~a\n;;; newer than
compiled ~a\n"
- name cfn))
+ name go-path))
(cond
(%load-should-autocompile
(%warn-autocompilation-enabled)
@@ -935,13 +1123,14 @@
";;; WARNING: compilation of ~a failed:\n;;; key ~a,
throw_args ~s\n"
name k args)
#f)))
- (with-fluid* current-reader (and (pair? reader) (car reader))
- (lambda ()
- (let ((cfn (autocompiled-file-name name)))
- (if cfn
- (load-compiled cfn)
- (start-stack 'load-stack
- (primitive-load name)))))))
+ (with-fluids ((current-reader (and (pair? reader) (car reader))))
+ (let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
+ compiled-file-name)
+ fresh-compiled-file-name)))
+ (if cfn
+ (load-compiled cfn)
+ (start-stack 'load-stack
+ (primitive-load name))))))
@@ -970,117 +1159,117 @@
(return #f #f argv))
((or (not (eq? #\- (string-ref (car argv) 0)))
- (eq? (string-length (car argv)) 1))
+ (eq? (string-length (car argv)) 1))
(return 'normal-arg (car argv) (cdr argv)))
((eq? #\- (string-ref (car argv) 1))
(let* ((kw-arg-pos (or (string-index (car argv) #\=)
- (string-length (car argv))))
- (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
- (kw-opt? (member kw kw-opts))
- (kw-arg? (member kw kw-args))
- (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
- (substring (car argv)
- (+ kw-arg-pos 1)
- (string-length (car argv))))
- (and kw-arg?
- (begin (set! argv (cdr argv)) (car argv))))))
+ (string-length (car argv))))
+ (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
+ (kw-opt? (member kw kw-opts))
+ (kw-arg? (member kw kw-args))
+ (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
+ (substring (car argv)
+ (+ kw-arg-pos 1)
+ (string-length (car argv))))
+ (and kw-arg?
+ (begin (set! argv (cdr argv)) (car argv))))))
(if (or kw-opt? kw-arg?)
- (return kw arg (cdr argv))
- (return 'usage-error kw (cdr argv)))))
+ (return kw arg (cdr argv))
+ (return 'usage-error kw (cdr argv)))))
(else
(let* ((char (substring (car argv) 1 2))
- (kw (symbol->keyword char)))
+ (kw (symbol->keyword char)))
(cond
((member kw kw-opts)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (new-argv (if (= 0 (string-length rest-car))
- (cdr argv)
- (cons (string-append "-" rest-car) (cdr argv)))))
- (return kw #f new-argv)))
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cdr argv)
+ (cons (string-append "-" rest-car) (cdr argv)))))
+ (return kw #f new-argv)))
((member kw kw-args)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (arg (if (= 0 (string-length rest-car))
- (cadr argv)
- rest-car))
- (new-argv (if (= 0 (string-length rest-car))
- (cddr argv)
- (cdr argv))))
- (return kw arg new-argv)))
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (arg (if (= 0 (string-length rest-car))
+ (cadr argv)
+ rest-car))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cddr argv)
+ (cdr argv))))
+ (return kw arg new-argv)))
(else (return 'usage-error kw argv)))))))
(define (for-next-option proc argv kw-opts kw-args)
(let loop ((argv argv))
(get-option argv kw-opts kw-args
- (lambda (opt opt-arg argv)
- (and opt (proc opt opt-arg argv loop))))))
+ (lambda (opt opt-arg argv)
+ (and opt (proc opt opt-arg argv loop))))))
(define (display-usage-report kw-desc)
(for-each
(lambda (kw)
(or (eq? (car kw) #t)
- (eq? (car kw) 'else)
- (let* ((opt-desc kw)
- (help (cadr opt-desc))
- (opts (car opt-desc))
- (opts-proper (if (string? (car opts)) (cdr opts) opts))
- (arg-name (if (string? (car opts))
- (string-append "<" (car opts) ">")
- ""))
- (left-part (string-append
- (with-output-to-string
- (lambda ()
- (map (lambda (x) (display (keyword->symbol x))
(display " "))
- opts-proper)))
- arg-name))
- (middle-part (if (and (< (string-length left-part) 30)
- (< (string-length help) 40))
- (make-string (- 30 (string-length left-part))
#\ )
- "\n\t")))
- (display left-part)
- (display middle-part)
- (display help)
- (newline))))
+ (eq? (car kw) 'else)
+ (let* ((opt-desc kw)
+ (help (cadr opt-desc))
+ (opts (car opt-desc))
+ (opts-proper (if (string? (car opts)) (cdr opts) opts))
+ (arg-name (if (string? (car opts))
+ (string-append "<" (car opts) ">")
+ ""))
+ (left-part (string-append
+ (with-output-to-string
+ (lambda ()
+ (map (lambda (x) (display (keyword->symbol x))
(display " "))
+ opts-proper)))
+ arg-name))
+ (middle-part (if (and (< (string-length left-part) 30)
+ (< (string-length help) 40))
+ (make-string (- 30 (string-length left-part))
#\ )
+ "\n\t")))
+ (display left-part)
+ (display middle-part)
+ (display help)
+ (newline))))
kw-desc))
(define (transform-usage-lambda cases)
(let* ((raw-usage (delq! 'else (map car cases)))
- (usage-sans-specials (map (lambda (x)
- (or (and (not (list? x)) x)
- (and (symbol? (car x)) #t)
- (and (boolean? (car x)) #t)
- x))
- raw-usage))
- (usage-desc (delq! #t usage-sans-specials))
- (kw-desc (map car usage-desc))
- (kw-opts (apply append (map (lambda (x) (and (not (string? (car x)))
x)) kw-desc)))
- (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr
x))) kw-desc)))
- (transmogrified-cases (map (lambda (case)
- (cons (let ((opts (car case)))
- (if (or (boolean? opts) (eq?
'else opts))
- opts
- (cond
- ((symbol? (car opts)) opts)
- ((boolean? (car opts)) opts)
- ((string? (caar opts)) (cdar
opts))
- (else (car opts)))))
- (cdr case)))
- cases)))
+ (usage-sans-specials (map (lambda (x)
+ (or (and (not (list? x)) x)
+ (and (symbol? (car x)) #t)
+ (and (boolean? (car x)) #t)
+ x))
+ raw-usage))
+ (usage-desc (delq! #t usage-sans-specials))
+ (kw-desc (map car usage-desc))
+ (kw-opts (apply append (map (lambda (x) (and (not (string? (car x)))
x)) kw-desc)))
+ (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr
x))) kw-desc)))
+ (transmogrified-cases (map (lambda (case)
+ (cons (let ((opts (car case)))
+ (if (or (boolean? opts) (eq?
'else opts))
+ opts
+ (cond
+ ((symbol? (car opts)) opts)
+ ((boolean? (car opts)) opts)
+ ((string? (caar opts))
(cdar opts))
+ (else (car opts)))))
+ (cdr case)))
+ cases)))
`(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
(lambda (%argv)
- (let %next-arg ((%argv %argv))
- (get-option %argv
- ',kw-opts
- ',kw-args
- (lambda (%opt %arg %new-argv)
- (case %opt
- ,@ transmogrified-cases))))))))
+ (let %next-arg ((%argv %argv))
+ (get-option %argv
+ ',kw-opts
+ ',kw-args
+ (lambda (%opt %arg %new-argv)
+ (case %opt
+ ,@ transmogrified-cases))))))))
@@ -1207,7 +1396,7 @@
;;; (module-local-variable module symbol) => [#<variable ...> | #f]
;;; (module-variable module symbol) => [#<variable ...> | #f]
;;; (module-symbol-binding module symbol opt-value)
-;;; => [ <obj> | opt-value | an error occurs ]
+;;; => [ <obj> | opt-value | an error occurs ]
;;; (module-make-local-var! module symbol) => #<variable...>
;;; (module-add! module symbol var) => unspecified
;;; (module-remove! module symbol) => unspecified
@@ -1251,10 +1440,10 @@
;;
(define module-type
(make-record-type 'module
- '(obarray uses binder eval-closure transformer name kind
- duplicates-handlers import-obarray
- observers weak-observers)
- %print-module))
+ '(obarray uses binder eval-closure transformer name kind
+ duplicates-handlers import-obarray
+ observers weak-observers version)
+ %print-module))
;; make-module &opt size uses binder
;;
@@ -1265,43 +1454,43 @@
(lambda args
(define (parse-arg index default)
- (if (> (length args) index)
- (list-ref args index)
- default))
+ (if (> (length args) index)
+ (list-ref args index)
+ default))
(define %default-import-size
;; Typical number of imported bindings actually used by a module.
600)
(if (> (length args) 3)
- (error "Too many args to make-module." args))
+ (error "Too many args to make-module." args))
(let ((size (parse-arg 0 31))
- (uses (parse-arg 1 '()))
- (binder (parse-arg 2 #f)))
-
- (if (not (integer? size))
- (error "Illegal size to make-module." size))
- (if (not (and (list? uses)
- (and-map module? uses)))
- (error "Incorrect use list." uses))
- (if (and binder (not (procedure? binder)))
- (error
- "Lazy-binder expected to be a procedure or #f." binder))
-
- (let ((module (module-constructor (make-hash-table size)
- uses binder #f
%pre-modules-transformer
+ (uses (parse-arg 1 '()))
+ (binder (parse-arg 2 #f)))
+
+ (if (not (integer? size))
+ (error "Illegal size to make-module." size))
+ (if (not (and (list? uses)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
+ (if (and binder (not (procedure? binder)))
+ (error
+ "Lazy-binder expected to be a procedure or #f." binder))
+
+ (let ((module (module-constructor (make-hash-table size)
+ uses binder #f
%pre-modules-transformer
#f #f #f
- (make-hash-table %default-import-size)
- '()
- (make-weak-key-hash-table 31))))
+ (make-hash-table
%default-import-size)
+ '()
+ (make-weak-key-hash-table 31) #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))
+ ;; 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))))
(define module-constructor (record-constructor module-type))
(define module-obarray (record-accessor module-type 'obarray))
@@ -1316,6 +1505,8 @@
;; (define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
+(define module-version (record-accessor module-type 'version))
+(define set-module-version! (record-modifier module-type 'version))
;; (define module-name (record-accessor module-type 'name)) wait until mods
are booted
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
@@ -1376,10 +1567,10 @@
(define (module-unobserve token)
(let ((module (car token))
- (id (cdr token)))
+ (id (cdr token)))
(if (integer? id)
- (hash-remove! (module-weak-observers module) id)
- (set-module-observers! module (delq1! id (module-observers module)))))
+ (hash-remove! (module-weak-observers module) id)
+ (set-module-observers! module (delq1! id (module-observers module)))))
*unspecified*)
(define module-defer-observers #f)
@@ -1397,16 +1588,16 @@
(define (call-with-deferred-observers thunk)
(dynamic-wind
(lambda ()
- (lock-mutex module-defer-observers-mutex)
- (set! module-defer-observers #t))
+ (lock-mutex module-defer-observers-mutex)
+ (set! module-defer-observers #t))
thunk
(lambda ()
- (set! module-defer-observers #f)
- (hash-for-each (lambda (m dummy)
- (module-call-observers m))
- module-defer-observers-table)
- (hash-clear! module-defer-observers-table)
- (unlock-mutex module-defer-observers-mutex))))
+ (set! module-defer-observers #f)
+ (hash-for-each (lambda (m dummy)
+ (module-call-observers m))
+ module-defer-observers-table)
+ (hash-clear! module-defer-observers-table)
+ (unlock-mutex module-defer-observers-mutex))))
(define (module-call-observers m)
(for-each (lambda (proc) (proc m)) (module-observers m))
@@ -1444,8 +1635,8 @@
(define (module-search fn m v)
(define (loop pos)
(and (pair? pos)
- (or (module-search fn (car pos) v)
- (loop (cdr pos)))))
+ (or (module-search fn (car pos) v)
+ (loop (cdr pos)))))
(or (fn m v)
(loop (module-uses m))))
@@ -1463,7 +1654,7 @@
(define (module-locally-bound? m v)
(let ((var (module-local-variable m v)))
(and var
- (variable-bound? var))))
+ (variable-bound? var))))
;; module-bound? module symbol
;;
@@ -1473,7 +1664,7 @@
(define (module-bound? m v)
(let ((var (module-variable m v)))
(and var
- (variable-bound? var))))
+ (variable-bound? var))))
;;; {Is a symbol interned in a module?}
;;;
@@ -1559,10 +1750,10 @@
(define (module-symbol-local-binding m v . opt-val)
(let ((var (module-local-variable m v)))
(if (and var (variable-bound? var))
- (variable-ref var)
- (if (not (null? opt-val))
- (car opt-val)
- (error "Locally unbound variable." v)))))
+ (variable-ref var)
+ (if (not (null? opt-val))
+ (car opt-val)
+ (error "Locally unbound variable." v)))))
;; module-symbol-binding module symbol opt-value
;;
@@ -1574,10 +1765,10 @@
(define (module-symbol-binding m v . opt-val)
(let ((var (module-variable m v)))
(if (and var (variable-bound? var))
- (variable-ref var)
- (if (not (null? opt-val))
- (car opt-val)
- (error "Unbound variable." v)))))
+ (variable-ref var)
+ (if (not (null? opt-val))
+ (car opt-val)
+ (error "Unbound variable." v)))))
@@ -1595,12 +1786,12 @@
;;
(define (module-make-local-var! m v)
(or (let ((b (module-obarray-ref (module-obarray m) v)))
- (and (variable? b)
- (begin
- ;; Mark as modified since this function is called when
- ;; the standard eval closure defines a binding
- (module-modified m)
- b)))
+ (and (variable? b)
+ (begin
+ ;; Mark as modified since this function is called when
+ ;; the standard eval closure defines a binding
+ (module-modified m)
+ b)))
;; Create a new local variable.
(let ((local-var (make-undefined-variable)))
@@ -1616,8 +1807,8 @@
(define (module-ensure-local-variable! module symbol)
(or (module-local-variable module symbol)
(let ((var (make-undefined-variable)))
- (module-add! module symbol var)
- var)))
+ (module-add! module symbol var)
+ var)))
;; module-add! module symbol var
;;
@@ -1689,16 +1880,16 @@
(define (save-module-excursion thunk)
(let ((inner-module (current-module))
- (outer-module #f))
+ (outer-module #f))
(dynamic-wind (lambda ()
- (set! outer-module (current-module))
- (set-current-module inner-module)
- (set! inner-module #f))
- thunk
- (lambda ()
- (set! inner-module (current-module))
- (set-current-module outer-module)
- (set! outer-module #f)))))
+ (set! outer-module (current-module))
+ (set-current-module inner-module)
+ (set! inner-module #f))
+ thunk
+ (lambda ()
+ (set! inner-module (current-module))
+ (set-current-module outer-module)
+ (set! outer-module #f)))))
(define basic-load load)
@@ -1706,15 +1897,15 @@
(save-module-excursion
(lambda ()
(let ((oldname (and (current-load-port)
- (port-filename (current-load-port)))))
+ (port-filename (current-load-port)))))
(apply basic-load
- (if (and oldname
- (> (string-length filename) 0)
- (not (char=? (string-ref filename 0) #\/))
- (not (string=? (dirname oldname) ".")))
- (string-append (dirname oldname) "/" filename)
- filename)
- reader)))))
+ (if (and oldname
+ (> (string-length filename) 0)
+ (not (char=? (string-ref filename 0) #\/))
+ (not (string=? (dirname oldname) ".")))
+ (string-append (dirname oldname) "/" filename)
+ filename)
+ reader)))))
@@ -1729,11 +1920,11 @@
(define (module-ref module name . rest)
(let ((variable (module-variable module name)))
(if (and variable (variable-bound? variable))
- (variable-ref variable)
- (if (null? rest)
- (error "No variable named" name 'in module)
- (car rest) ; default value
- ))))
+ (variable-ref variable)
+ (if (null? rest)
+ (error "No variable named" name 'in module)
+ (car rest) ; default value
+ ))))
;; MODULE-SET! -- exported
;;
@@ -1743,8 +1934,8 @@
(define (module-set! module name value)
(let ((variable (module-variable module name)))
(if variable
- (variable-set! variable value)
- (error "No variable named" name 'in module))))
+ (variable-set! variable value)
+ (error "No variable named" name 'in module))))
;; MODULE-DEFINE! -- exported
;;
@@ -1754,11 +1945,11 @@
(define (module-define! module name value)
(let ((variable (module-local-variable module name)))
(if variable
- (begin
- (variable-set! variable value)
- (module-modified module))
- (let ((variable (make-variable value)))
- (module-add! module name variable)))))
+ (begin
+ (variable-set! variable value)
+ (module-modified module))
+ (let ((variable (make-variable value)))
+ (module-add! module name variable)))))
;; MODULE-DEFINED? -- exported
;;
@@ -1787,7 +1978,7 @@
(module-name interface))))
(module-uses module))
(list interface)))
-
+ (hash-clear! (module-import-obarray module))
(module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces
@@ -1797,6 +1988,7 @@
(define (module-use-interfaces! module interfaces)
(set-module-uses! module
(append (module-uses module) interfaces))
+ (hash-clear! (module-import-obarray module))
(module-modified module))
@@ -1810,60 +2002,60 @@
;;; Each variable name is a list of elements, looked up in successively nested
;;; modules.
;;;
-;;; (nested-ref some-root-module '(foo bar baz))
-;;; => <value of a variable named baz in the module bound to bar in
-;;; the module bound to foo in some-root-module>
+;;; (nested-ref some-root-module '(foo bar baz))
+;;; => <value of a variable named baz in the module bound to bar in
+;;; the module bound to foo in some-root-module>
;;;
;;;
;;; There are:
;;;
-;;; ;; a-root is a module
-;;; ;; name is a list of symbols
+;;; ;; a-root is a module
+;;; ;; name is a list of symbols
;;;
-;;; nested-ref a-root name
-;;; nested-set! a-root name val
-;;; nested-define! a-root name val
-;;; nested-remove! a-root name
+;;; nested-ref a-root name
+;;; nested-set! a-root name val
+;;; nested-define! a-root name val
+;;; nested-remove! a-root name
;;;
;;;
;;; (current-module) is a natural choice for a-root so for convenience there
are
;;; also:
;;;
-;;; local-ref name == nested-ref (current-module) name
-;;; local-set! name val == nested-set! (current-module) name val
-;;; local-define! name val == nested-define! (current-module) name val
-;;; local-remove! name == nested-remove! (current-module) name
+;;; local-ref name == nested-ref (current-module) name
+;;; local-set! name val == nested-set! (current-module) name val
+;;; local-define! name val == nested-define! (current-module) name
val
+;;; local-remove! name == nested-remove! (current-module) name
;;;
(define (nested-ref root names)
(let loop ((cur root)
- (elts names))
+ (elts names))
(cond
- ((null? elts) cur)
- ((not (module? cur)) #f)
+ ((null? elts) cur)
+ ((not (module? cur)) #f)
(else (loop (module-ref cur (car elts) #f) (cdr elts))))))
(define (nested-set! root names val)
(let loop ((cur root)
- (elts names))
+ (elts names))
(if (null? (cdr elts))
- (module-set! cur (car elts) val)
- (loop (module-ref cur (car elts)) (cdr elts)))))
+ (module-set! cur (car elts) val)
+ (loop (module-ref cur (car elts)) (cdr elts)))))
(define (nested-define! root names val)
(let loop ((cur root)
- (elts names))
+ (elts names))
(if (null? (cdr elts))
- (module-define! cur (car elts) val)
- (loop (module-ref cur (car elts)) (cdr elts)))))
+ (module-define! cur (car elts) val)
+ (loop (module-ref cur (car elts)) (cdr elts)))))
(define (nested-remove! root names)
(let loop ((cur root)
- (elts names))
+ (elts names))
(if (null? (cdr elts))
- (module-remove! cur (car elts))
- (loop (module-ref cur (car elts)) (cdr elts)))))
+ (module-remove! cur (car elts))
+ (loop (module-ref cur (car elts)) (cdr elts)))))
(define (local-ref names) (nested-ref (current-module) names))
(define (local-set! names val) (nested-set! (current-module) names val))
@@ -1918,16 +2110,114 @@
(define (beautify-user-module! module)
(let ((interface (module-public-interface module)))
(if (or (not interface)
- (eq? interface module))
- (let ((interface (make-module 31)))
- (set-module-name! interface (module-name module))
- (set-module-kind! interface 'interface)
- (set-module-public-interface! module interface))))
+ (eq? interface module))
+ (let ((interface (make-module 31)))
+ (set-module-name! interface (module-name module))
+ (set-module-version! interface (module-version module))
+ (set-module-kind! interface 'interface)
+ (set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
- (not (eq? module the-root-module)))
+ (not (eq? module the-root-module)))
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
+(define (version-matches? version-ref target)
+ (define (any pred lst)
+ (and (not (null? lst)) (or (pred (car lst)) (any pred (cdr lst)))))
+ (define (every pred lst)
+ (or (null? lst) (and (pred (car lst)) (every pred (cdr lst)))))
+ (define (sub-versions-match? v-refs t)
+ (define (sub-version-matches? v-ref t)
+ (define (curried-sub-version-matches? v)
+ (sub-version-matches? v t))
+ (cond ((number? v-ref) (eqv? v-ref t))
+ ((list? v-ref)
+ (let ((cv (car v-ref)))
+ (cond ((eq? cv '>=) (>= t (cadr v-ref)))
+ ((eq? cv '<=) (<= t (cadr v-ref)))
+ ((eq? cv 'and)
+ (every curried-sub-version-matches? (cdr v-ref)))
+ ((eq? cv 'or)
+ (any curried-sub-version-matches? (cdr v-ref)))
+ ((eq? cv 'not) (not (sub-version-matches? (cadr v-ref)
t)))
+ (else (error "Incompatible sub-version reference" cv)))))
+ (else (error "Incompatible sub-version reference" v-ref))))
+ (or (null? v-refs)
+ (and (not (null? t))
+ (sub-version-matches? (car v-refs) (car t))
+ (sub-versions-match? (cdr v-refs) (cdr t)))))
+ (define (curried-version-matches? v)
+ (version-matches? v target))
+ (or (null? version-ref)
+ (let ((cv (car version-ref)))
+ (cond ((eq? cv 'and) (every curried-version-matches? (cdr
version-ref)))
+ ((eq? cv 'or) (any curried-version-matches? (cdr version-ref)))
+ ((eq? cv 'not) (not (version-matches? (cadr version-ref)
target)))
+ (else (sub-versions-match? version-ref target))))))
+
+(define (find-versioned-module dir-hint name version-ref roots)
+ (define (subdir-pair-less pair1 pair2)
+ (define (numlist-less lst1 lst2)
+ (or (null? lst2)
+ (and (not (null? lst1))
+ (cond ((> (car lst1) (car lst2)) #t)
+ ((< (car lst1) (car lst2)) #f)
+ (else (numlist-less (cdr lst1) (cdr lst2)))))))
+ (numlist-less (car pair1) (car pair2)))
+ (define (match-version-and-file pair)
+ (and (version-matches? version-ref (car pair))
+ (let ((filenames
+ (filter (lambda (file)
+ (let ((s (false-if-exception (stat file))))
+ (and s (eq? (stat:type s) 'regular))))
+ (map (lambda (ext)
+ (string-append (cdr pair) "/" name ext))
+ %load-extensions))))
+ (and (not (null? filenames))
+ (cons (car pair) (car filenames))))))
+
+ (define (match-version-recursive root-pairs leaf-pairs)
+ (define (filter-subdirs root-pairs ret)
+ (define (filter-subdir root-pair dstrm subdir-pairs)
+ (let ((entry (readdir dstrm)))
+ (if (eof-object? entry)
+ subdir-pairs
+ (let* ((subdir (string-append (cdr root-pair) "/" entry))
+ (num (string->number entry))
+ (num (and num (append (car root-pair) (list num)))))
+ (if (and num (eq? (stat:type (stat subdir)) 'directory))
+ (filter-subdir
+ root-pair dstrm (cons (cons num subdir) subdir-pairs))
+ (filter-subdir root-pair dstrm subdir-pairs))))))
+
+ (or (and (null? root-pairs) ret)
+ (let* ((rp (car root-pairs))
+ (dstrm (false-if-exception (opendir (cdr rp)))))
+ (if dstrm
+ (let ((subdir-pairs (filter-subdir rp dstrm '())))
+ (closedir dstrm)
+ (filter-subdirs (cdr root-pairs)
+ (or (and (null? subdir-pairs) ret)
+ (append ret subdir-pairs))))
+ (filter-subdirs (cdr root-pairs) ret)))))
+
+ (or (and (null? root-pairs) leaf-pairs)
+ (let ((matching-subdir-pairs (filter-subdirs root-pairs '())))
+ (match-version-recursive
+ matching-subdir-pairs
+ (append leaf-pairs (filter pair? (map match-version-and-file
+ matching-subdir-pairs)))))))
+ (define (make-root-pair root)
+ (cons '() (string-append root "/" dir-hint)))
+
+ (let* ((root-pairs (map make-root-pair roots))
+ (matches (if (null? version-ref)
+ (filter pair? (map match-version-and-file root-pairs))
+ '()))
+ (matches (append matches (match-version-recursive root-pairs '()))))
+ (and (null? matches) (error "No matching modules found."))
+ (cdar (sort matches subdir-pair-less))))
+
(define (make-fresh-user-module)
(let ((m (make-module)))
(beautify-user-module! m)
@@ -1937,20 +2227,25 @@
;;
(define resolve-module
(let ((the-root-module the-root-module))
- (lambda (name . maybe-autoload)
+ (lambda (name . args)
(if (equal? name '(guile))
the-root-module
(let ((full-name (append '(%app modules) name)))
- (let ((already (nested-ref the-root-module full-name))
- (autoload (or (null? maybe-autoload) (car maybe-autoload))))
+ (let* ((already (nested-ref the-root-module full-name))
+ (numargs (length args))
+ (autoload (or (= numargs 0) (car args)))
+ (version (and (> numargs 1) (cadr args))))
(cond
((and already (module? already)
(or (not autoload) (module-public-interface already)))
;; A hit, a palpable hit.
+ (if (and version
+ (not (version-matches? version (module-version
already))))
+ (error "incompatible module version already loaded" name))
already)
(autoload
;; Try to autoload the module, and recurse.
- (try-load-module name)
+ (try-load-module name version)
(resolve-module name #f))
(else
;; A module is not bound (but maybe something else is),
@@ -1996,15 +2291,15 @@
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
-(define (try-load-module name)
- (try-module-autoload name))
+(define (try-load-module name version)
+ (try-module-autoload name version))
(define (purify-module! module)
"Removes bindings in MODULE which are inherited from the (guile) module."
(let ((use-list (module-uses module)))
(if (and (pair? use-list)
- (eq? (car (last-pair use-list)) the-scm-module))
- (set-module-uses! module (reverse (cdr (reverse use-list)))))))
+ (eq? (car (last-pair use-list)) the-scm-module))
+ (set-module-uses! module (reverse (cdr (reverse use-list)))))))
;; Return a module that is an interface to the module designated by
;; NAME.
@@ -2044,57 +2339,58 @@
(define (get-keyword-arg args kw def)
(cond ((memq kw args)
- => (lambda (kw-arg)
- (if (null? (cdr kw-arg))
- (error "keyword without value: " kw))
- (cadr kw-arg)))
- (else
- def)))
+ => (lambda (kw-arg)
+ (if (null? (cdr kw-arg))
+ (error "keyword without value: " kw))
+ (cadr kw-arg)))
+ (else
+ def)))
(let* ((select (get-keyword-arg args #:select #f))
- (hide (get-keyword-arg args #:hide '()))
- (renamer (or (get-keyword-arg args #:renamer #f)
- (let ((prefix (get-keyword-arg args #:prefix #f)))
- (and prefix (symbol-prefix-proc prefix)))
- identity))
- (module (resolve-module name))
+ (hide (get-keyword-arg args #:hide '()))
+ (renamer (or (get-keyword-arg args #:renamer #f)
+ (let ((prefix (get-keyword-arg args #:prefix #f)))
+ (and prefix (symbol-prefix-proc prefix)))
+ identity))
+ (version (get-keyword-arg args #:version #f))
+ (module (resolve-module name #t version))
(public-i (and module (module-public-interface module))))
(and (or (not module) (not public-i))
(error "no code for module" name))
(if (and (not select) (null? hide) (eq? renamer identity))
public-i
(let ((selection (or select (module-map (lambda (sym var) sym)
- public-i)))
+ public-i)))
(custom-i (make-module 31)))
(set-module-kind! custom-i 'custom-interface)
- (set-module-name! custom-i name)
- ;; XXX - should use a lazy binder so that changes to the
- ;; used module are picked up automatically.
- (for-each (lambda (bspec)
- (let* ((direct? (symbol? bspec))
- (orig (if direct? bspec (car bspec)))
- (seen (if direct? bspec (cdr bspec)))
- (var (or (module-local-variable public-i orig)
- (module-local-variable module orig)
- (error
- ;; fixme: format manually for now
- (simple-format
- #f "no binding `~A' in module ~A"
- orig name)))))
- (if (memq orig hide)
- (set! hide (delq! orig hide))
- (module-add! custom-i
- (renamer seen)
- var))))
- selection)
- ;; Check that we are not hiding bindings which don't exist
- (for-each (lambda (binding)
- (if (not (module-local-variable public-i binding))
- (error
- (simple-format
- #f "no binding `~A' to hide in module ~A"
- binding name))))
- hide)
+ (set-module-name! custom-i name)
+ ;; XXX - should use a lazy binder so that changes to the
+ ;; used module are picked up automatically.
+ (for-each (lambda (bspec)
+ (let* ((direct? (symbol? bspec))
+ (orig (if direct? bspec (car bspec)))
+ (seen (if direct? bspec (cdr bspec)))
+ (var (or (module-local-variable public-i orig)
+ (module-local-variable module orig)
+ (error
+ ;; fixme: format manually for now
+ (simple-format
+ #f "no binding `~A' in module ~A"
+ orig name)))))
+ (if (memq orig hide)
+ (set! hide (delq! orig hide))
+ (module-add! custom-i
+ (renamer seen)
+ var))))
+ selection)
+ ;; Check that we are not hiding bindings which don't exist
+ (for-each (lambda (binding)
+ (if (not (module-local-variable public-i binding))
+ (error
+ (simple-format
+ #f "no binding `~A' to hide in module ~A"
+ binding name))))
+ hide)
custom-i))))
(define (symbol-prefix-proc prefix)
@@ -2178,6 +2474,14 @@
(purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
+ ((#:version)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (let ((version (cadr kws)))
+ (set-module-version! module version)
+ (set-module-version! (module-public-interface module) version))
+ (loop (cddr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
@@ -2230,18 +2534,18 @@
(define (make-autoload-interface module name bindings)
(let ((b (lambda (a sym definep)
- (and (memq sym bindings)
- (let ((i (module-public-interface (resolve-module name))))
- (if (not i)
- (error "missing interface for module" name))
- (let ((autoload (memq a (module-uses module))))
- ;; Replace autoload-interface with actual interface if
- ;; that has not happened yet.
- (if (pair? autoload)
- (set-car! autoload i)))
- (module-local-variable i sym))))))
+ (and (memq sym bindings)
+ (let ((i (module-public-interface (resolve-module name))))
+ (if (not i)
+ (error "missing interface for module" name))
+ (let ((autoload (memq a (module-uses module))))
+ ;; Replace autoload-interface with actual interface if
+ ;; that has not happened yet.
+ (if (pair? autoload)
+ (set-car! autoload i)))
+ (module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
- (make-hash-table 0) '() (make-weak-value-hash-table
31))))
+ (make-hash-table 0) '() (make-weak-value-hash-table
31) #f)))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
@@ -2271,28 +2575,31 @@ module '(ice-9 q) '(make-q q-length))}."
;; This function is called from "modules.c". If you change it, be
;; sure to update "modules.c" as well.
-(define (try-module-autoload module-name)
+(define (try-module-autoload module-name . args)
(let* ((reverse-name (reverse module-name))
- (name (symbol->string (car reverse-name)))
- (dir-hint-module-name (reverse (cdr reverse-name)))
- (dir-hint (apply string-append
- (map (lambda (elt)
- (string-append (symbol->string elt) "/"))
- dir-hint-module-name))))
+ (name (symbol->string (car reverse-name)))
+ (version (and (not (null? args)) (car args)))
+ (dir-hint-module-name (reverse (cdr reverse-name)))
+ (dir-hint (apply string-append
+ (map (lambda (elt)
+ (string-append (symbol->string elt) "/"))
+ dir-hint-module-name))))
(resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
- (let ((didit #f))
- (dynamic-wind
- (lambda () (autoload-in-progress! dir-hint name))
- (lambda ()
- (with-fluid* current-reader #f
- (lambda ()
- (save-module-excursion
- (lambda ()
- (primitive-load-path (in-vicinity dir-hint name) #f)
- (set! didit #t))))))
- (lambda () (set-autoloaded! dir-hint name didit)))
- didit))))
+ (let ((didit #f))
+ (dynamic-wind
+ (lambda () (autoload-in-progress! dir-hint name))
+ (lambda ()
+ (with-fluids ((current-reader #f))
+ (save-module-excursion
+ (lambda ()
+ (if version
+ (load (find-versioned-module
+ dir-hint name version %load-path))
+ (primitive-load-path (in-vicinity dir-hint name) #f))
+ (set! didit #t)))))
+ (lambda () (set-autoloaded! dir-hint name didit)))
+ didit))))
@@ -2304,27 +2611,27 @@ module '(ice-9 q) '(make-q q-length))}."
(define (autoload-done-or-in-progress? p m)
(let ((n (cons p m)))
(->bool (or (member n autoloads-done)
- (member n autoloads-in-progress)))))
+ (member n autoloads-in-progress)))))
(define (autoload-done! p m)
(let ((n (cons p m)))
(set! autoloads-in-progress
- (delete! n autoloads-in-progress))
+ (delete! n autoloads-in-progress))
(or (member n autoloads-done)
- (set! autoloads-done (cons n autoloads-done)))))
+ (set! autoloads-done (cons n autoloads-done)))))
(define (autoload-in-progress! p m)
(let ((n (cons p m)))
(set! autoloads-done
- (delete! n autoloads-done))
+ (delete! n autoloads-done))
(set! autoloads-in-progress (cons n autoloads-in-progress))))
(define (set-autoloaded! p m done?)
(if done?
(autoload-done! p m)
(let ((n (cons p m)))
- (set! autoloads-done (delete! n autoloads-done))
- (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
+ (set! autoloads-done (delete! n autoloads-done))
+ (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
@@ -2333,17 +2640,17 @@ module '(ice-9 q) '(make-q q-length))}."
(defmacro define-option-interface (option-group)
(let* ((option-name 'car)
- (option-value 'cadr)
- (option-documentation 'caddr)
+ (option-value 'cadr)
+ (option-documentation 'caddr)
- ;; Below follow the macros defining the run-time option interfaces.
+ ;; Below follow the macros defining the run-time option interfaces.
- (make-options (lambda (interface)
- `(lambda args
- (cond ((null? args) (,interface))
- ((list? (car args))
- (,interface (car args)) (,interface))
- (else (for-each
+ (make-options (lambda (interface)
+ `(lambda args
+ (cond ((null? args) (,interface))
+ ((list? (car args))
+ (,interface (car args)) (,interface))
+ (else (for-each
(lambda (option)
(display (,option-name option))
(if (< (string-length
@@ -2357,19 +2664,19 @@ module '(ice-9 q) '(make-q q-length))}."
(newline))
(,interface #t)))))))
- (make-enable (lambda (interface)
- `(lambda flags
- (,interface (append flags (,interface)))
- (,interface))))
-
- (make-disable (lambda (interface)
- `(lambda flags
- (let ((options (,interface)))
- (for-each (lambda (flag)
- (set! options (delq! flag options)))
- flags)
- (,interface options)
- (,interface))))))
+ (make-enable (lambda (interface)
+ `(lambda flags
+ (,interface (append flags (,interface)))
+ (,interface))))
+
+ (make-disable (lambda (interface)
+ `(lambda flags
+ (let ((options (,interface)))
+ (for-each (lambda (flag)
+ (set! options (delq! flag options)))
+ flags)
+ (,interface options)
+ (,interface))))))
(let* ((interface (car option-group))
(options/enable/disable (cadr option-group)))
`(begin
@@ -2438,7 +2745,8 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack 1)
+ ;; Narrow by two more frames: this one, and the throw handler.
+ (save-stack 2)
(apply throw key args))
(begin-deprecated
@@ -2454,109 +2762,106 @@ module '(ice-9 q) '(make-q q-length))}."
(define (error-catching-loop thunk)
(let ((status #f)
- (interactive #t))
+ (interactive #t))
(define (loop first)
(let ((next
- (catch #t
-
- (lambda ()
- (call-with-unblocked-asyncs
- (lambda ()
- (with-traps
- (lambda ()
- (first)
-
- ;; This line is needed because mark
- ;; doesn't do closures quite right.
- ;; Unreferenced locals should be
- ;; collected.
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)))))
-
- (lambda (key . args)
- (case key
- ((quit)
- (set! status args)
- #f)
-
- ((switch-repl)
- (apply throw 'switch-repl args))
-
- ((abort)
- ;; This is one of the closures that require
- ;; (set! first #f) above
- ;;
- (lambda ()
- (run-hook abort-hook)
- (force-output (current-output-port))
- (display "ABORT: " (current-error-port))
- (write args (current-error-port))
- (newline (current-error-port))
- (if interactive
- (begin
- (if (and
- (not has-shown-debugger-hint?)
- (not (memq 'backtrace
- (debug-options-interface)))
- (stack? (fluid-ref the-last-stack)))
- (begin
- (newline (current-error-port))
- (display
- "Type \"(backtrace)\" to get more
information or \"(debug)\" to enter the debugger.\n"
- (current-error-port))
- (set! has-shown-debugger-hint? #t)))
- (force-output (current-error-port)))
- (begin
- (primitive-exit 1)))
- (set! stack-saved? #f)))
-
- (else
- ;; This is the other cons-leak closure...
- (lambda ()
- (cond ((= (length args) 4)
- (apply handle-system-error key args))
- (else
- (apply bad-throw key args)))))))
+ (catch #t
+
+ (lambda ()
+ (call-with-unblocked-asyncs
+ (lambda ()
+ (with-traps
+ (lambda ()
+ (first)
+
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)))))
+
+ (lambda (key . args)
+ (case key
+ ((quit)
+ (set! status args)
+ #f)
+
+ ((switch-repl)
+ (apply throw 'switch-repl args))
+
+ ((abort)
+ ;; This is one of the closures that require
+ ;; (set! first #f) above
+ ;;
+ (lambda ()
+ (run-hook abort-hook)
+ (force-output (current-output-port))
+ (display "ABORT: " (current-error-port))
+ (write args (current-error-port))
+ (newline (current-error-port))
+ (if interactive
+ (begin
+ (if (and
+ (not has-shown-debugger-hint?)
+ (not (memq 'backtrace
+ (debug-options-interface)))
+ (stack? (fluid-ref the-last-stack)))
+ (begin
+ (newline (current-error-port))
+ (display
+ "Type \"(backtrace)\" to get more
information or \"(debug)\" to enter the debugger.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (force-output (current-error-port)))
+ (begin
+ (primitive-exit 1)))
+ (set! stack-saved? #f)))
+
+ (else
+ ;; This is the other cons-leak closure...
+ (lambda ()
+ (cond ((= (length args) 4)
+ (apply handle-system-error key args))
+ (else
+ (apply bad-throw key args)))))))
default-pre-unwind-handler)))
- (if next (loop next) status)))
+ (if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
- (cond (arg
- (set! interactive #f)
- (restore-signals))
- (#t
- (error "sorry, not implemented")))))
+ (cond (arg
+ (set! interactive #f)
+ (restore-signals))
+ (#t
+ (error "sorry, not implemented")))))
(set! batch-mode? (lambda () (not interactive)))
(call-with-blocked-asyncs
(lambda () (loop (lambda () #t))))))
;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
(define before-signal-stack (make-fluid))
+;; FIXME: stack-saved? is broken in the presence of threads.
(define stack-saved? #f)
(define (save-stack . narrowing)
- (or stack-saved?
- (cond ((not (memq 'debug (debug-options-interface)))
- (fluid-set! the-last-stack #f)
- (set! stack-saved? #t))
- (else
- (fluid-set!
- the-last-stack
- (case (stack-id #t)
- ((repl-stack)
- (apply make-stack #t save-stack primitive-eval #t 0 narrowing))
- ((load-stack)
- (apply make-stack #t save-stack 0 #t 0 narrowing))
- ((#t)
- (apply make-stack #t save-stack 0 1 narrowing))
- (else
- (let ((id (stack-id #t)))
- (and (procedure? id)
- (apply make-stack #t save-stack id #t 0 narrowing))))))
- (set! stack-saved? #t)))))
+ (if (not stack-saved?)
+ (begin
+ (let ((stacks (fluid-ref %stacks)))
+ (fluid-set! the-last-stack
+ ;; (make-stack obj inner outer inner outer ...)
+ ;;
+ ;; In this case, cut away the make-stack frame, the
+ ;; save-stack frame, and then narrow as specified by the
+ ;; user, delimited by the nearest start-stack invocation,
+ ;; if any.
+ (apply make-stack #t
+ 2
+ (if (pair? stacks) (cdar stacks) 0)
+ narrowing)))
+ (set! stack-saved? #t))))
(define before-error-hook (make-hook))
(define after-error-hook (make-hook))
@@ -2568,18 +2873,18 @@ module '(ice-9 q) '(make-q q-length))}."
(define (handle-system-error key . args)
(let ((cep (current-error-port)))
(cond ((not (stack? (fluid-ref the-last-stack))))
- ((memq 'backtrace (debug-options-interface))
- (let ((highlights (if (or (eq? key 'wrong-type-arg)
- (eq? key 'out-of-range))
- (list-ref args 3)
- '())))
- (run-hook before-backtrace-hook)
- (newline cep)
- (display "Backtrace:\n")
- (display-backtrace (fluid-ref the-last-stack) cep
- #f #f highlights)
- (newline cep)
- (run-hook after-backtrace-hook))))
+ ((memq 'backtrace (debug-options-interface))
+ (let ((highlights (if (or (eq? key 'wrong-type-arg)
+ (eq? key 'out-of-range))
+ (list-ref args 3)
+ '())))
+ (run-hook before-backtrace-hook)
+ (newline cep)
+ (display "Backtrace:\n")
+ (display-backtrace (fluid-ref the-last-stack) cep
+ #f #f highlights)
+ (newline cep)
+ (run-hook after-backtrace-hook))))
(run-hook before-error-hook)
(apply display-error (fluid-ref the-last-stack) cep args)
(run-hook after-error-hook)
@@ -2597,16 +2902,16 @@ module '(ice-9 q) '(make-q q-length))}."
;;(define (backtrace)
;; (if (fluid-ref the-last-stack)
;; (begin
-;; (newline)
-;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
-;; (newline)
-;; (if (and (not has-shown-backtrace-hint?)
-;; (not (memq 'backtrace (debug-options-interface))))
-;; (begin
-;; (display
+;; (newline)
+;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
+;; (newline)
+;; (if (and (not has-shown-backtrace-hint?)
+;; (not (memq 'backtrace (debug-options-interface))))
+;; (begin
+;; (display
;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
;;automatically if an error occurs in the future.\n")
-;; (set! has-shown-backtrace-hint? #t))))
+;; (set! has-shown-backtrace-hint? #t))))
;; (display "No backtrace available.\n")))
(define (error-catching-repl r e p)
@@ -2629,7 +2934,8 @@ module '(ice-9 q) '(make-q q-length))}."
;;; the readline library.
(define repl-reader
(lambda (prompt . reader)
- (display (if (string? prompt) prompt (prompt)))
+ (if (not (char-ready?))
+ (display (if (string? prompt) prompt (prompt))))
(force-output)
(run-hook before-read-hook)
((or (and (pair? reader) (car reader))
@@ -2640,108 +2946,108 @@ module '(ice-9 q) '(make-q q-length))}."
(define (scm-style-repl)
(letrec (
- (start-gc-rt #f)
- (start-rt #f)
- (repl-report-start-timing (lambda ()
- (set! start-gc-rt (gc-run-time))
- (set! start-rt (get-internal-run-time))))
- (repl-report (lambda ()
- (display ";;; ")
- (display (inexact->exact
- (* 1000 (/ (- (get-internal-run-time)
start-rt)
-
internal-time-units-per-second))))
- (display " msec (")
- (display (inexact->exact
- (* 1000 (/ (- (gc-run-time) start-gc-rt)
-
internal-time-units-per-second))))
- (display " msec in gc)\n")))
-
- (consume-trailing-whitespace
- (lambda ()
- (let ((ch (peek-char)))
- (cond
- ((eof-object? ch))
- ((or (char=? ch #\space) (char=? ch #\tab))
- (read-char)
- (consume-trailing-whitespace))
- ((char=? ch #\newline)
- (read-char))))))
- (-read (lambda ()
- (let ((val
- (let ((prompt (cond ((string? scm-repl-prompt)
- scm-repl-prompt)
- ((thunk? scm-repl-prompt)
- (scm-repl-prompt))
- (scm-repl-prompt "> ")
- (else ""))))
- (repl-reader prompt))))
-
- ;; As described in R4RS, the READ procedure updates the
- ;; port to point to the first character past the end of
- ;; the external representation of the object. This
- ;; means that it doesn't consume the newline typically
- ;; found after an expression. This means that, when
- ;; debugging Guile with GDB, GDB gets the newline, which
- ;; it often interprets as a "continue" command, making
- ;; breakpoints kind of useless. So, consume any
- ;; trailing newline here, as well as any whitespace
- ;; before it.
- ;; But not if EOF, for control-D.
- (if (not (eof-object? val))
- (consume-trailing-whitespace))
- (run-hook after-read-hook)
- (if (eof-object? val)
- (begin
- (repl-report-start-timing)
- (if scm-repl-verbose
- (begin
- (newline)
- (display ";;; EOF -- quitting")
- (newline)))
- (quit 0)))
- val)))
-
- (-eval (lambda (sourc)
- (repl-report-start-timing)
- (run-hook before-eval-hook sourc)
- (let ((val (start-stack 'repl-stack
- ;; If you change this procedure
- ;; (primitive-eval), please also
- ;; modify the repl-stack case in
- ;; save-stack so that stack cutting
- ;; continues to work.
- (primitive-eval sourc))))
- (run-hook after-eval-hook sourc)
- val)))
-
-
- (-print (let ((maybe-print (lambda (result)
- (if (or scm-repl-print-unspecified
- (not (unspecified? result)))
- (begin
- (write result)
- (newline))))))
- (lambda (result)
- (if (not scm-repl-silent)
- (begin
- (run-hook before-print-hook result)
- (maybe-print result)
- (run-hook after-print-hook result)
- (if scm-repl-verbose
- (repl-report))
- (force-output))))))
-
- (-quit (lambda (args)
- (if scm-repl-verbose
- (begin
- (display ";;; QUIT executed, repl exitting")
- (newline)
- (repl-report)))
- args)))
+ (start-gc-rt #f)
+ (start-rt #f)
+ (repl-report-start-timing (lambda ()
+ (set! start-gc-rt (gc-run-time))
+ (set! start-rt
(get-internal-run-time))))
+ (repl-report (lambda ()
+ (display ";;; ")
+ (display (inexact->exact
+ (* 1000 (/ (- (get-internal-run-time)
start-rt)
+
internal-time-units-per-second))))
+ (display " msec (")
+ (display (inexact->exact
+ (* 1000 (/ (- (gc-run-time) start-gc-rt)
+
internal-time-units-per-second))))
+ (display " msec in gc)\n")))
+
+ (consume-trailing-whitespace
+ (lambda ()
+ (let ((ch (peek-char)))
+ (cond
+ ((eof-object? ch))
+ ((or (char=? ch #\space) (char=? ch #\tab))
+ (read-char)
+ (consume-trailing-whitespace))
+ ((char=? ch #\newline)
+ (read-char))))))
+ (-read (lambda ()
+ (let ((val
+ (let ((prompt (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (scm-repl-prompt "> ")
+ (else ""))))
+ (repl-reader prompt))))
+
+ ;; As described in R4RS, the READ procedure updates the
+ ;; port to point to the first character past the end of
+ ;; the external representation of the object. This
+ ;; means that it doesn't consume the newline typically
+ ;; found after an expression. This means that, when
+ ;; debugging Guile with GDB, GDB gets the newline, which
+ ;; it often interprets as a "continue" command, making
+ ;; breakpoints kind of useless. So, consume any
+ ;; trailing newline here, as well as any whitespace
+ ;; before it.
+ ;; But not if EOF, for control-D.
+ (if (not (eof-object? val))
+ (consume-trailing-whitespace))
+ (run-hook after-read-hook)
+ (if (eof-object? val)
+ (begin
+ (repl-report-start-timing)
+ (if scm-repl-verbose
+ (begin
+ (newline)
+ (display ";;; EOF -- quitting")
+ (newline)))
+ (quit 0)))
+ val)))
+
+ (-eval (lambda (sourc)
+ (repl-report-start-timing)
+ (run-hook before-eval-hook sourc)
+ (let ((val (start-stack 'repl-stack
+ ;; If you change this procedure
+ ;; (primitive-eval), please also
+ ;; modify the repl-stack case in
+ ;; save-stack so that stack cutting
+ ;; continues to work.
+ (primitive-eval sourc))))
+ (run-hook after-eval-hook sourc)
+ val)))
+
+
+ (-print (let ((maybe-print (lambda (result)
+ (if (or scm-repl-print-unspecified
+ (not (unspecified? result)))
+ (begin
+ (write result)
+ (newline))))))
+ (lambda (result)
+ (if (not scm-repl-silent)
+ (begin
+ (run-hook before-print-hook result)
+ (maybe-print result)
+ (run-hook after-print-hook result)
+ (if scm-repl-verbose
+ (repl-report))
+ (force-output))))))
+
+ (-quit (lambda (args)
+ (if scm-repl-verbose
+ (begin
+ (display ";;; QUIT executed, repl exitting")
+ (newline)
+ (repl-report)))
+ args)))
(let ((status (error-catching-repl -read
- -eval
- -print)))
+ -eval
+ -print)))
(-quit status))))
@@ -2770,24 +3076,6 @@ module '(ice-9 q) '(make-q q-length))}."
-;;; {with-fluids}
-;;;
-
-;; with-fluids is a convenience wrapper for the builtin procedure
-;; `with-fluids*'. The syntax is just like `let':
-;;
-;; (with-fluids ((fluid val)
-;; ...)
-;; body)
-
-(defmacro with-fluids (bindings . body)
- (let ((fluids (map car bindings))
- (values (map cadr bindings)))
- (if (and (= (length fluids) 1) (= (length values) 1))
- `(with-fluid* ,(car fluids) ,(car values) (lambda () ,@body))
- `(with-fluids* (list ,@fluids) (list ,@values)
- (lambda () ,@body)))))
-
;;; {While}
;;;
;;; with `continue' and `break'.
@@ -2833,25 +3121,26 @@ module '(ice-9 q) '(make-q q-length))}."
(define (compile-interface-spec spec)
(define (make-keyarg sym key quote?)
(cond ((or (memq sym spec)
- (memq key spec))
- => (lambda (rest)
- (if quote?
- (list key (list 'quote (cadr rest)))
- (list key (cadr rest)))))
- (else
- '())))
+ (memq key spec))
+ => (lambda (rest)
+ (if quote?
+ (list key (list 'quote (cadr rest)))
+ (list key (cadr rest)))))
+ (else
+ '())))
(define (map-apply func list)
(map (lambda (args) (apply func args)) list))
(define keys
;; sym key quote?
'((:select #:select #t)
- (:hide #:hide #t)
+ (:hide #:hide #t)
(:prefix #:prefix #t)
- (:renamer #:renamer #f)))
+ (:renamer #:renamer #f)
+ (:version #:version #t)))
(if (not (pair? (car spec)))
`(',spec)
`(',(car spec)
- ,@(apply append (map-apply make-keyarg keys)))))
+ ,@(apply append (map-apply make-keyarg keys)))))
(define (keyword-like-symbol->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
@@ -2863,34 +3152,34 @@ module '(ice-9 q) '(make-q q-length))}."
;; keyword args in a define-module form are not regular
;; (i.e. no-backtrace doesn't take a value).
(let loop ((compiled-args `((quote ,(car args))))
- (args (cdr args)))
+ (args (cdr args)))
(cond ((null? args)
- (reverse! compiled-args))
- ;; symbol in keyword position
- ((symbol? (car args))
- (loop compiled-args
- (cons (keyword-like-symbol->keyword (car args)) (cdr args))))
- ((memq (car args) '(#:no-backtrace #:pure))
- (loop (cons (car args) compiled-args)
- (cdr args)))
- ((null? (cdr args))
- (error "keyword without value:" (car args)))
- ((memq (car args) '(#:use-module #:use-syntax))
- (loop (cons* `(list ,@(compile-interface-spec (cadr args)))
- (car args)
- compiled-args)
- (cddr args)))
- ((eq? (car args) #:autoload)
- (loop (cons* `(quote ,(caddr args))
- `(quote ,(cadr args))
- (car args)
- compiled-args)
- (cdddr args)))
- (else
- (loop (cons* `(quote ,(cadr args))
- (car args)
- compiled-args)
- (cddr args))))))
+ (reverse! compiled-args))
+ ;; symbol in keyword position
+ ((symbol? (car args))
+ (loop compiled-args
+ (cons (keyword-like-symbol->keyword (car args)) (cdr args))))
+ ((memq (car args) '(#:no-backtrace #:pure))
+ (loop (cons (car args) compiled-args)
+ (cdr args)))
+ ((null? (cdr args))
+ (error "keyword without value:" (car args)))
+ ((memq (car args) '(#:use-module #:use-syntax))
+ (loop (cons* `(list ,@(compile-interface-spec (cadr args)))
+ (car args)
+ compiled-args)
+ (cddr args)))
+ ((eq? (car args) #:autoload)
+ (loop (cons* `(quote ,(caddr args))
+ `(quote ,(cadr args))
+ (car args)
+ compiled-args)
+ (cdddr args)))
+ (else
+ (loop (cons* `(quote ,(cadr args))
+ (car args)
+ compiled-args)
+ (cddr args))))))
(defmacro define-module args
`(eval-when
@@ -2908,9 +3197,9 @@ module '(ice-9 q) '(make-q q-length))}."
(define (process-use-modules module-interface-args)
(let ((interfaces (map (lambda (mif-args)
- (or (apply resolve-interface mif-args)
- (error "no such module" mif-args)))
- module-interface-args)))
+ (or (apply resolve-interface mif-args)
+ (error "no such module" mif-args)))
+ module-interface-args)))
(call-with-deferred-observers
(lambda ()
(module-use-interfaces! (current-module) interfaces)))))
@@ -2968,41 +3257,49 @@ module '(ice-9 q) '(make-q q-length))}."
(define (module-export! m names)
(let ((public-i (module-public-interface m)))
(for-each (lambda (name)
- (let ((var (module-ensure-local-variable! m name)))
- (module-add! public-i name var)))
- names)))
+ (let* ((internal-name (if (pair? name) (car name) name))
+ (external-name (if (pair? name) (cdr name) name))
+ (var (module-ensure-local-variable! m internal-name)))
+ (module-add! public-i external-name var)))
+ names)))
(define (module-replace! m names)
(let ((public-i (module-public-interface m)))
(for-each (lambda (name)
- (let ((var (module-ensure-local-variable! m name)))
- (set-object-property! var 'replace #t)
- (module-add! public-i name var)))
- names)))
+ (let* ((internal-name (if (pair? name) (car name) name))
+ (external-name (if (pair? name) (cdr name) name))
+ (var (module-ensure-local-variable! m internal-name)))
+ (set-object-property! var 'replace #t)
+ (module-add! public-i external-name var)))
+ names)))
;; Re-export a imported variable
;;
(define (module-re-export! m names)
(let ((public-i (module-public-interface m)))
(for-each (lambda (name)
- (let ((var (module-variable m name)))
- (cond ((not var)
- (error "Undefined variable:" name))
- ((eq? var (module-local-variable m name))
- (error "re-exporting local variable:" name))
- (else
- (module-add! public-i name var)))))
- names)))
+ (let* ((internal-name (if (pair? name) (car name) name))
+ (external-name (if (pair? name) (cdr name) name))
+ (var (module-variable m internal-name)))
+ (cond ((not var)
+ (error "Undefined variable:" internal-name))
+ ((eq? var (module-local-variable m internal-name))
+ (error "re-exporting local variable:" internal-name))
+ (else
+ (module-add! public-i external-name var)))))
+ names)))
(defmacro export names
- `(call-with-deferred-observers
- (lambda ()
- (module-export! (current-module) ',names))))
+ `(eval-when (eval load compile)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-export! (current-module) ',names)))))
(defmacro re-export names
- `(call-with-deferred-observers
- (lambda ()
- (module-re-export! (current-module) ',names))))
+ `(eval-when (eval load compile)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-re-export! (current-module) ',names)))))
(defmacro export-syntax names
`(export ,@names))
@@ -3019,17 +3316,17 @@ module '(ice-9 q) '(make-q q-length))}."
(define make-mutable-parameter
(let ((make (lambda (fluid converter)
- (lambda args
- (if (null? args)
- (fluid-ref fluid)
- (fluid-set! fluid (converter (car args))))))))
+ (lambda args
+ (if (null? args)
+ (fluid-ref fluid)
+ (fluid-set! fluid (converter (car args))))))))
(lambda (init . converter)
(let ((fluid (make-fluid))
- (converter (if (null? converter)
- identity
- (car converter))))
- (fluid-set! fluid (converter init))
- (make fluid converter)))))
+ (converter (if (null? converter)
+ identity
+ (car converter))))
+ (fluid-set! fluid (converter init))
+ (make fluid converter)))))
@@ -3039,13 +3336,13 @@ module '(ice-9 q) '(make-q q-length))}."
;; Duplicate handlers take the following arguments:
;;
;; module importing module
-;; name conflicting name
-;; int1 old interface where name occurs
-;; val1 value of binding in old interface
-;; int2 new interface where name occurs
-;; val2 value of binding in new interface
-;; var previous resolution or #f
-;; val value of previous resolution
+;; name conflicting name
+;; int1 old interface where name occurs
+;; val1 value of binding in old interface
+;; int2 new interface where name occurs
+;; val2 value of binding in new interface
+;; var previous resolution or #f
+;; val value of previous resolution
;;
;; A duplicate handler can take three alternative actions:
;;
@@ -3059,43 +3356,43 @@ module '(ice-9 q) '(make-q q-length))}."
(define (check module name int1 val1 int2 val2 var val)
(scm-error 'misc-error
- #f
- "~A: `~A' imported from both ~A and ~A"
- (list (module-name module)
- name
- (module-name int1)
- (module-name int2))
- #f))
+ #f
+ "~A: `~A' imported from both ~A and ~A"
+ (list (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #f))
(define (warn module name int1 val1 int2 val2 var val)
(format (current-error-port)
- "WARNING: ~A: `~A' imported from both ~A and ~A\n"
- (module-name module)
- name
- (module-name int1)
- (module-name int2))
+ "WARNING: ~A: `~A' imported from both ~A and ~A\n"
+ (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
#f)
(define (replace module name int1 val1 int2 val2 var val)
(let ((old (or (and var (object-property var 'replace) var)
- (module-variable int1 name)))
- (new (module-variable int2 name)))
- (if (object-property old 'replace)
- (and (or (eq? old new)
- (not (object-property new 'replace)))
- old)
- (and (object-property new 'replace)
- new))))
+ (module-variable int1 name)))
+ (new (module-variable int2 name)))
+ (if (object-property old 'replace)
+ (and (or (eq? old new)
+ (not (object-property new 'replace)))
+ old)
+ (and (object-property new 'replace)
+ new))))
(define (warn-override-core module name int1 val1 int2 val2 var val)
(and (eq? int1 the-scm-module)
- (begin
- (format (current-error-port)
- "WARNING: ~A: imported module ~A overrides core binding
`~A'\n"
- (module-name module)
- (module-name int2)
- name)
- (module-local-variable int2 name))))
+ (begin
+ (format (current-error-port)
+ "WARNING: ~A: imported module ~A overrides core binding
`~A'\n"
+ (module-name module)
+ (module-name int2)
+ name)
+ (module-local-variable int2 name))))
(define (first module name int1 val1 int2 val2 var val)
(or var (module-local-variable int1 name)))
@@ -3121,23 +3418,23 @@ module '(ice-9 q) '(make-q q-length))}."
(define (lookup-duplicates-handlers handler-names)
(and handler-names
(map (lambda (handler-name)
- (or (module-symbol-local-binding
- duplicate-handlers handler-name #f)
- (error "invalid duplicate handler name:"
- handler-name)))
- (if (list? handler-names)
- handler-names
- (list handler-names)))))
+ (or (module-symbol-local-binding
+ duplicate-handlers handler-name #f)
+ (error "invalid duplicate handler name:"
+ handler-name)))
+ (if (list? handler-names)
+ handler-names
+ (list handler-names)))))
(define default-duplicate-binding-procedures
(make-mutable-parameter #f))
(define default-duplicate-binding-handler
(make-mutable-parameter '(replace warn-override-core warn last)
- (lambda (handler-names)
- (default-duplicate-binding-procedures
- (lookup-duplicates-handlers handler-names))
- handler-names)))
+ (lambda (handler-names)
+ (default-duplicate-binding-procedures
+ (lookup-duplicates-handlers handler-names))
+ handler-names)))
@@ -3197,9 +3494,9 @@ module '(ice-9 q) '(make-q q-length))}."
(define (cond-expand-provide module features)
(let ((mod (module-public-interface module)))
(and mod
- (hashq-set! %cond-expand-table mod
- (append (hashq-ref %cond-expand-table mod '())
- features)))))
+ (hashq-set! %cond-expand-table mod
+ (append (hashq-ref %cond-expand-table mod '())
+ features)))))
(define-macro (cond-expand . clauses)
(let ((syntax-error (lambda (cl)
@@ -3268,9 +3565,9 @@ module '(ice-9 q) '(make-q q-length))}."
(define (use-srfis srfis)
(process-use-modules
(map (lambda (num)
- (list (list 'srfi (string->symbol
- (string-append "srfi-" (number->string num))))))
- srfis)))
+ (list (list 'srfi (string->symbol
+ (string-append "srfi-" (number->string num))))))
+ srfis)))
@@ -3333,8 +3630,8 @@ module '(ice-9 q) '(make-q q-length))}."
;; Load emacs interface support if emacs option is given.
(if (and (module-defined? guile-user-module 'use-emacs-interface)
- (module-ref guile-user-module 'use-emacs-interface))
- (load-emacs-interface))
+ (module-ref guile-user-module 'use-emacs-interface))
+ (load-emacs-interface))
;; Use some convenient modules (in reverse order)
@@ -3342,16 +3639,16 @@ module '(ice-9 q) '(make-q q-length))}."
(process-use-modules
(append
'(((ice-9 r5rs))
- ((ice-9 session))
- ((ice-9 debug)))
+ ((ice-9 session))
+ ((ice-9 debug)))
(if (provided? 'regex)
- '(((ice-9 regex)))
- '())
+ '(((ice-9 regex)))
+ '())
(if (provided? 'threads)
- '(((ice-9 threads)))
- '())))
+ '(((ice-9 threads)))
+ '())))
;; load debugger on demand
- (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
+ (module-autoload! guile-user-module '(system vm debug) '(debug))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
@@ -3359,55 +3656,55 @@ module '(ice-9 q) '(make-q q-length))}."
(let ((old-handlers #f)
(start-repl (module-ref (resolve-interface '(system repl repl))
'start-repl))
- (signals (if (provided? 'posix)
- `((,SIGINT . "User interrupt")
- (,SIGFPE . "Arithmetic error")
- (,SIGSEGV
- . "Bad memory access (Segmentation violation)"))
- '())))
+ (signals (if (provided? 'posix)
+ `((,SIGINT . "User interrupt")
+ (,SIGFPE . "Arithmetic error")
+ (,SIGSEGV
+ . "Bad memory access (Segmentation violation)"))
+ '())))
;; no SIGBUS on mingw
(if (defined? 'SIGBUS)
- (set! signals (acons SIGBUS "Bad memory access (bus error)"
- signals)))
+ (set! signals (acons SIGBUS "Bad memory access (bus error)"
+ signals)))
(dynamic-wind
- ;; call at entry
- (lambda ()
- (let ((make-handler (lambda (msg)
- (lambda (sig)
- ;; Make a backup copy of the stack
- (fluid-set! before-signal-stack
- (fluid-ref the-last-stack))
- (save-stack 2)
- (scm-error 'signal
- #f
- msg
- #f
- (list sig))))))
- (set! old-handlers
- (map (lambda (sig-msg)
- (sigaction (car sig-msg)
- (make-handler (cdr sig-msg))))
- signals))))
-
- ;; the protected thunk.
- (lambda ()
+ ;; call at entry
+ (lambda ()
+ (let ((make-handler (lambda (msg)
+ (lambda (sig)
+ ;; Make a backup copy of the stack
+ (fluid-set! before-signal-stack
+ (fluid-ref the-last-stack))
+ (save-stack 2)
+ (scm-error 'signal
+ #f
+ msg
+ #f
+ (list sig))))))
+ (set! old-handlers
+ (map (lambda (sig-msg)
+ (sigaction (car sig-msg)
+ (make-handler (cdr sig-msg))))
+ signals))))
+
+ ;; the protected thunk.
+ (lambda ()
(let ((status (start-repl 'scheme)))
- (run-hook exit-hook)
- status))
-
- ;; call at exit.
- (lambda ()
- (map (lambda (sig-msg old-handler)
- (if (not (car old-handler))
- ;; restore original C handler.
- (sigaction (car sig-msg) #f)
- ;; restore Scheme handler, SIG_IGN or SIG_DFL.
- (sigaction (car sig-msg)
- (car old-handler)
- (cdr old-handler))))
- signals old-handlers))))))
+ (run-hook exit-hook)
+ status))
+
+ ;; call at exit.
+ (lambda ()
+ (map (lambda (sig-msg old-handler)
+ (if (not (car old-handler))
+ ;; restore original C handler.
+ (sigaction (car sig-msg) #f)
+ ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+ (sigaction (car sig-msg)
+ (car old-handler)
+ (cdr old-handler))))
+ signals old-handlers))))))
;;; This hook is run at the very end of an interactive session.
;;;
@@ -3419,13 +3716,7 @@ module '(ice-9 q) '(make-q q-length))}."
;;;
(begin-deprecated
- (define (feature? sym)
- (issue-deprecation-warning
- "`feature?' is deprecated. Use `provided?' instead.")
- (provided? sym)))
-
-(begin-deprecated
- (primitive-load-path "ice-9/deprecated"))
+ (module-use! the-scm-module (resolve-interface '(ice-9 deprecated))))
@@ -3435,10 +3726,17 @@ module '(ice-9 q) '(make-q q-length))}."
;;; FIXME: annotate ?
;; (define (syncase exp)
;; (with-fluids ((expansion-eval-closure
-;; (module-eval-closure (current-module))))
-;; (deannotate/source-properties (sc-expand (annotate exp)))))
+;; (module-eval-closure (current-module))))
+;; (deannotate/source-properties (macroexpand (annotate exp)))))
+
+;; FIXME:
+(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
(define-module (guile-user)
#:autoload (system base compile) (compile))
+;; Remain in the `(guile)' module at compilation-time so that the
+;; `-Wunused-toplevel' warning works as expected.
+(eval-when (compile) (set-current-module the-root-module))
+
;;; boot-9.scm ends here
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 8b53267..5529e69 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -13,7 +13,7 @@
(close-port in))
(begin
(pretty-print (tree-il->scheme
- (sc-expand x 'c '(compile load eval)))
+ (macroexpand x 'c '(compile load eval)))
out)
(newline out)
(loop (read in))))))
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
new file mode 100644
index 0000000..dbee61e
--- /dev/null
+++ b/module/ice-9/control.scm
@@ -0,0 +1,56 @@
+;;; Beyond call/cc
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Code:
+
+(define-module (ice-9 control)
+ #:re-export (call-with-prompt abort-to-prompt
+ default-prompt-tag make-prompt-tag)
+ #:export (% abort))
+
+(define (abort . args)
+ (apply abort-to-prompt (default-prompt-tag) args))
+
+(define-syntax %
+ (syntax-rules ()
+ ((_ expr)
+ (call-with-prompt (default-prompt-tag)
+ (lambda () expr)
+ default-prompt-handler))
+ ((_ expr handler)
+ (call-with-prompt (default-prompt-tag)
+ (lambda () expr)
+ handler))
+ ((_ tag expr handler)
+ (call-with-prompt tag
+ (lambda () expr)
+ handler))))
+
+;; Each prompt tag has a type -- an expected set of arguments, and an unwritten
+;; contract of what its handler will do on an abort. In the case of the default
+;; prompt tag, we could choose to return values, exit nonlocally, or punt to
the
+;; user.
+;;
+;; We choose the latter, by requiring that the user return one value, a
+;; procedure, to an abort to the prompt tag. That argument is then invoked with
+;; the continuation as an argument, within a reinstated default prompt. In this
+;; way the return value(s) from a default prompt are under the user's control.
+(define (default-prompt-handler k proc)
+ (% (default-prompt-tag)
+ (proc k)
+ default-prompt-handler))
diff --git a/module/ice-9/curried-definitions.scm
b/module/ice-9/curried-definitions.scm
new file mode 100644
index 0000000..d55f1fb
--- /dev/null
+++ b/module/ice-9/curried-definitions.scm
@@ -0,0 +1,41 @@
+;;; Copyright (C) 2010 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 (ice-9 curried-definitions)
+ #:replace ((cdefine . define)
+ (cdefine* . define*)))
+
+(define-syntax cdefine
+ (syntax-rules ()
+ ((_ ((head . tail) . rest) body body* ...)
+ (cdefine (head . tail)
+ (lambda rest body body* ...)))
+ ((_ (head . rest) body body* ...)
+ (define head
+ (lambda rest body body* ...)))
+ ((_ . rest)
+ (define . rest))))
+
+(define-syntax cdefine*
+ (syntax-rules ()
+ ((_ ((head . tail) . rest) body body* ...)
+ (cdefine* (head . tail)
+ (lambda* rest body body* ...)))
+ ((_ (head . rest) body body* ...)
+ (define* head
+ (lambda* rest body body* ...)))
+ ((_ . rest)
+ (define* . rest))))
diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm
index 132e2d4..1d509f4 100755
--- a/module/ice-9/debugging/traps.scm
+++ b/module/ice-9/debugging/traps.scm
@@ -1,6 +1,6 @@
;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
-;;; Copyright (C) 2002, 2004, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2002, 2004, 2009, 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
;;;; This library is free software; you can redistribute it and/or
@@ -81,7 +81,9 @@
without-traps
guile-trap-features)
#:re-export (make)
- #:export-syntax (trap-here))
+ ;; FIXME: see below
+ ;; #:export-syntax (trap-here)
+ )
;; How to debug the debugging infrastructure, when needed. Grep for
;; "(trc " to find other symbols that can be passed to trc-add.
@@ -888,6 +890,7 @@ it twice."
;; (trap-here EXPRESSION . OPTIONS)
;; FIXME: no longer working due to no mmacros, no local-eval
+#;
(define trap-here
(procedure->memoizing-macro
(lambda (expr env)
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 0d632b2..081f3f8 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2003, 2005, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010 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,11 +15,35 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
;;;;
+(define-module (ice-9 deprecated)
+ #:export (substring-move-left! substring-move-right!
+ dynamic-maybe-call dynamic-maybe-link
+ try-module-linked try-module-dynamic-link
+ list* feature? eval-case unmemoize-expr
+ $asinh
+ $acosh
+ $atanh
+ $sqrt
+ $abs
+ $exp
+ $log
+ $sin
+ $cos
+ $tan
+ $asin
+ $acos
+ $atan
+ $sinh
+ $cosh
+ $tanh
+ closure?))
+
;;;; Deprecated definitions.
(define substring-move-left! substring-move!)
(define substring-move-right! substring-move!)
+
;; This method of dynamically linking Guile Extensions is deprecated.
;; Use `load-extension' explicitly from Scheme code instead.
@@ -162,12 +186,15 @@
(and (find-and-link-dynamic-module module-name)
(init-dynamic-module module-name)))
+
(define (list* . args)
(issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.")
(apply cons* args))
-;; The strange prototype system for uniform arrays has been
-;; deprecated.
+(define (feature? sym)
+ (issue-deprecation-warning
+ "`feature?' is deprecated. Use `provided?' instead.")
+ (provided? sym))
(define-macro (eval-case . clauses)
(issue-deprecation-warning
@@ -186,6 +213,8 @@
(else
`(begin))))
+;; The strange prototype system for uniform arrays has been
+;; deprecated.
(read-hash-extend
#\y
(lambda (c port)
@@ -224,7 +253,10 @@
(define ($sinh z) (sinh z))
(define ($cosh z) (cosh z))
(define ($tanh z) (tanh z))
+
(define (closure? x)
(issue-deprecation-warning
"`closure?' is deprecated. Use `procedure?' instead.")
(procedure? x))
+
+(define %nil #nil)
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index b3721e4..e38f2df 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009
+;;;; Copyright (C) 2009, 2010
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -188,24 +188,66 @@
(mx-match mx data tag c ...)))))))
+;;;
+;;; On 18 Feb 2010, I did a profile of how often the various memoized
expression
+;;; types occur when getting to a prompt on a fresh build. Here are the numbers
+;;; I got:
+;;;
+;;; lexical-ref: 32933054
+;;; call: 20281547
+;;; toplevel-ref: 13228724
+;;; if: 9156156
+;;; quote: 6610137
+;;; let: 2619707
+;;; lambda: 1010921
+;;; begin: 948945
+;;; lexical-set: 509862
+;;; call-with-values: 139668
+;;; apply: 49402
+;;; module-ref: 14468
+;;; define: 1259
+;;; toplevel-set: 328
+;;; dynwind: 162
+;;; with-fluids: 0
+;;; call/cc: 0
+;;; module-set: 0
+;;;
+;;; So until we compile `case' into a computed goto, we'll order the clauses in
+;;; `eval' in this order, to put the most frequent cases first.
+;;;
+
(define primitive-eval
(let ()
;; The "engine". EXP is a memoized expression.
(define (eval exp env)
(memoized-expression-case exp
- (('begin (first . rest))
- (let lp ((first first) (rest rest))
- (if (null? rest)
- (eval first env)
- (begin
- (eval first env)
- (lp (car rest) (cdr rest))))))
+ (('lexical-ref n)
+ (let lp ((n n) (env env))
+ (if (zero? n)
+ (car env)
+ (lp (1- n) (cdr env)))))
+ (('call (f nargs . args))
+ (let ((proc (eval f env)))
+ (call eval proc nargs args env)))
+
+ (('toplevel-ref var-or-sym)
+ (variable-ref
+ (if (variable? var-or-sym)
+ var-or-sym
+ (let lp ((env env))
+ (if (pair? env)
+ (lp (cdr env))
+ (memoize-variable-access! exp (capture-env env)))))))
+
(('if (test consequent . alternate))
(if (eval test env)
(eval consequent env)
(eval alternate env)))
+ (('quote x)
+ x)
+
(('let (inits . body))
(let lp ((inits inits) (new-env (capture-env env)))
(if (null? inits)
@@ -216,31 +258,13 @@
(('lambda (nreq rest? . body))
(make-closure eval nreq rest? body (capture-env env)))
- (('quote x)
- x)
-
- (('define (name . x))
- (define! name (eval x env)))
-
- (('apply (f args))
- (apply (eval f env) (eval args env)))
-
- (('call (f nargs . args))
- (let ((proc (eval f env)))
- (call eval proc nargs args env)))
-
- (('call/cc proc)
- (call/cc (eval proc env)))
-
- (('call-with-values (producer . consumer))
- (call-with-values (eval producer env)
- (eval consumer env)))
-
- (('lexical-ref n)
- (let lp ((n n) (env env))
- (if (zero? n)
- (car env)
- (lp (1- n) (cdr env)))))
+ (('begin (first . rest))
+ (let lp ((first first) (rest rest))
+ (if (null? rest)
+ (eval first env)
+ (begin
+ (eval first env)
+ (lp (car rest) (cdr rest))))))
(('lexical-set! (n . x))
(let ((val (eval x env)))
@@ -249,15 +273,22 @@
(set-car! env val)
(lp (1- n) (cdr env))))))
- (('toplevel-ref var-or-sym)
+ (('call-with-values (producer . consumer))
+ (call-with-values (eval producer env)
+ (eval consumer env)))
+
+ (('apply (f args))
+ (apply (eval f env) (eval args env)))
+
+ (('module-ref var-or-spec)
(variable-ref
- (if (variable? var-or-sym)
- var-or-sym
- (let lp ((env env))
- (if (pair? env)
- (lp (cdr env))
- (memoize-variable-access! exp (capture-env env)))))))
+ (if (variable? var-or-spec)
+ var-or-spec
+ (memoize-variable-access! exp #f))))
+ (('define (name . x))
+ (define! name (eval x env)))
+
(('toplevel-set! (var-or-sym . x))
(variable-set!
(if (variable? var-or-sym)
@@ -268,11 +299,27 @@
(memoize-variable-access! exp (capture-env env)))))
(eval x env)))
- (('module-ref var-or-spec)
- (variable-ref
- (if (variable? var-or-spec)
- var-or-spec
- (memoize-variable-access! exp #f))))
+ (('dynwind (in exp . out))
+ (dynamic-wind (eval in env)
+ (lambda () (eval exp env))
+ (eval out env)))
+
+ (('with-fluids (fluids vals . exp))
+ (let* ((fluids (map (lambda (x) (eval x env)) fluids))
+ (vals (map (lambda (x) (eval x env)) vals)))
+ (let lp ((fluids fluids) (vals vals))
+ (if (null? fluids)
+ (eval exp env)
+ (with-fluids (((car fluids) (car vals)))
+ (lp (cdr fluids) (cdr vals)))))))
+
+ (('prompt (tag exp . handler))
+ (@prompt (eval tag env)
+ (eval exp env)
+ (eval handler env)))
+
+ (('call/cc proc)
+ (call/cc (eval proc env)))
(('module-set! (x . var-or-spec))
(variable-set!
diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index 4bf6237..133f8e4 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -13,7 +13,7 @@
(define-module (ice-9 format)
:use-module (ice-9 and-let-star)
- :autoload (ice-9 pretty-print) (pretty-print)
+ :autoload (ice-9 pretty-print) (pretty-print truncated-print)
:replace (format)
:export (format:symbol-case-conv
format:iobj-case-conv
@@ -482,10 +482,33 @@
((#\T) ; Tabulate
(format:tabulate modifier params)
(anychar-dispatch))
- ((#\Y) ; Pretty-print
- (pretty-print (next-arg) format:port)
- (set! format:output-col 0)
- (anychar-dispatch))
+ ((#\Y) ; Structured print
+ (let ((width (if (one-positive-integer? params)
+ (car params)
+ 79)))
+ (case modifier
+ ((at)
+ (format:out-str
+ (with-output-to-string
+ (lambda ()
+ (truncated-print (next-arg)
+ #:width width)))))
+ ((colon-at)
+ (format:out-str
+ (with-output-to-string
+ (lambda ()
+ (truncated-print (next-arg)
+ #:width
+ (max (- width
+ format:output-col)
+ 1))))))
+ ((colon)
+ (format:error "illegal modifier in ~~?"))
+ (else
+ (pretty-print (next-arg) format:port
+ #:width width)
+ (set! format:output-col 0))))
+ (anychar-dispatch))
((#\? #\K) ; Indirection (is "~K" in
T-Scheme)
(cond
((memq modifier '(colon colon-at))
diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm
index e63ec74..ce04aa3 100644
--- a/module/ice-9/i18n.scm
+++ b/module/ice-9/i18n.scm
@@ -1,6 +1,6 @@
-;;;; i18n.scm --- internationalization support
+;;;; i18n.scm --- internationalization support -*- coding: utf-8 -*-
-;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010 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
@@ -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
-;;; Author: Ludovic Courtès <address@hidden>
+;;; Author: Ludovic Courtès <address@hidden>
;;; Commentary:
;;;
@@ -42,8 +42,8 @@
char-locale-ci<? char-locale-ci>? char-locale-ci=?
;; character mapping
- char-locale-downcase char-locale-upcase
- string-locale-downcase string-locale-upcase
+ char-locale-downcase char-locale-upcase char-locale-titlecase
+ string-locale-downcase string-locale-upcase string-locale-titlecase
;; reading numbers
locale-string->integer locale-string->inexact
@@ -84,7 +84,8 @@
(eval-when (eval load compile)
- (load-extension "libguile" "scm_init_i18n"))
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_i18n"))
;;;
@@ -414,9 +415,4 @@ number of fractional digits to be displayed."
;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
-
;;; i18n.scm ends here
diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm
index 7e84f09..f9ff394 100644
--- a/module/ice-9/networking.scm
+++ b/module/ice-9/networking.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1999, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2005, 2006, 2010 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
@@ -85,3 +85,10 @@
(define (sockaddr:port obj) (vector-ref obj 2))
(define (sockaddr:flowinfo obj) (vector-ref obj 3))
(define (sockaddr:scopeid obj) (vector-ref obj 4))
+
+(define (addrinfo:flags obj) (vector-ref obj 0))
+(define (addrinfo:fam obj) (vector-ref obj 1))
+(define (addrinfo:socktype obj) (vector-ref obj 2))
+(define (addrinfo:protocol obj) (vector-ref obj 3))
+(define (addrinfo:addr obj) (vector-ref obj 4))
+(define (addrinfo:canonname obj) (vector-ref obj 5))
diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm
index 5ad9e81..4e3267d 100644
--- a/module/ice-9/optargs.scm
+++ b/module/ice-9/optargs.scm
@@ -1,6 +1,6 @@
;;;; optargs.scm -- support for optional arguments
;;;;
-;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010 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
@@ -253,9 +253,12 @@
;; in the same way as lambda*.
(define-syntax define*-public
- (syntax-rules ()
- ((_ (id . args) b0 b1 ...)
- (define-public id (lambda* args b0 b1 ...)))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (id . args) b0 b1 ...)
+ #'(define-public id (lambda* args b0 b1 ...)))
+ ((_ id val) (identifier? #'id)
+ #'(define-public id val)))))
;; defmacro* name args . body
@@ -269,14 +272,17 @@
;; (defmacro* transmorgify (a #:optional b)
(define-syntax defmacro*
- (syntax-rules ()
- ((_ (id . args) b0 b1 ...)
- (defmacro id (lambda* args b0 b1 ...)))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ id args doc b0 b1 ...) (string? (syntax->datum #'doc))
+ #'(define-macro id doc (lambda* args b0 b1 ...)))
+ ((_ id args b0 b1 ...)
+ #'(define-macro id #f (lambda* args b0 b1 ...))))))
(define-syntax defmacro*-public
(syntax-rules ()
- ((_ (id . args) b0 b1 ...)
+ ((_ id args b0 b1 ...)
(begin
- (defmacro id (lambda* args b0 b1 ...))
+ (defmacro* id args b0 b1 ...)
(export-syntax id)))))
;;; Support for optional & keyword args with the interpreter.
@@ -343,7 +349,8 @@
(pair? (cdr args-tail))
allow-other-keys?)
(permissive-keys slots slots-tail (cddr args-tail) inits))
- (else (error "unrecognized keyword" args-tail))))
+ (else (scm-error 'keyword-argument-error #f "Unrecognized keyword"
+ '() args-tail))))
(define (key slots slots-tail args-tail inits)
(cond
((null? args-tail)
@@ -357,7 +364,8 @@
(if rest-idx
;; no error checking, everything goes to the rest..
(key slots slots-tail '() inits)
- (error "bad keyword argument list" args-tail)))
+ (scm-error 'keyword-argument-error #f "Invalid keyword"
+ '() args-tail)))
((and (keyword? (car args-tail))
(pair? (cdr args-tail))
(assq-ref kw-indices (car args-tail)))
@@ -368,7 +376,8 @@
(pair? (cdr args-tail))
allow-other-keys?)
(key slots slots-tail (cddr args-tail) inits))
- (else (error "unrecognized keyword" args-tail))))
+ (else (scm-error 'keyword-argument-error #f "Unrecognized keyword"
+ '() args-tail))))
(let ((args (list-copy args)))
(req args #f args nreq)))
(else (error "unexpected spec" spec))))
diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm
index a1be33c..b002676 100644
--- a/module/ice-9/posix.scm
+++ b/module/ice-9/posix.scm
@@ -33,6 +33,9 @@
(define (stat:ctime f) (vector-ref f 10))
(define (stat:blksize f) (vector-ref f 11))
(define (stat:blocks f) (vector-ref f 12))
+(define (stat:atimensec f) (vector-ref f 15))
+(define (stat:mtimensec f) (vector-ref f 16))
+(define (stat:ctimensec f) (vector-ref f 17))
;; derived from stat mode.
(define (stat:type f) (vector-ref f 13))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 0ce6a80..d3e3eca 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -1,6 +1,6 @@
-;;;; -*-scheme-*-
+;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010 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,8 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
;;;;
(define-module (ice-9 pretty-print)
- :use-module (ice-9 optargs)
- :export (pretty-print))
+ #:export (pretty-print
+ truncated-print))
+
;; From SLIB.
@@ -250,7 +251,12 @@
(rev-string-append l 0))
-(define (pretty-print obj . opts)
+(define* (pretty-print obj #:optional port*
+ #:key
+ (port (or port* (current-output-port)))
+ (width 79)
+ (display? #f)
+ (per-line-prefix ""))
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
the current output port. Formatting can be controlled by a number of
keyword arguments: Each line in the output is preceded by the string
@@ -260,19 +266,166 @@ true, display rather than write representation will be
used.
Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
- (if (pair? opts)
- (if (keyword? (car opts))
- (apply pretty-print-with-keys obj opts)
- (apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
- (pretty-print-with-keys obj)))
-
-(define* (pretty-print-with-keys obj
- #:key
- (port (current-output-port))
- (width 79)
- (display? #f)
- (per-line-prefix ""))
(generic-write obj display?
(- width (string-length per-line-prefix))
per-line-prefix
(lambda (s) (display s port) #t)))
+
+
+;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
+;; genwrite.scm.
+(define* (truncated-print x #:optional port*
+ #:key
+ (port (or port* (current-output-port)))
+ (width 79)
+ (display? #f)
+ (breadth-first? #f))
+ "Print @var{obj}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
address@hidden, though that behavior can be overriden via the
address@hidden keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expression of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+\"ration\" the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument."
+
+ ;; Make sure string ports are created with the right encoding.
+ (with-fluids ((%default-port-encoding (port-encoding port)))
+
+ (define ellipsis
+ ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots,
depending
+ ;; on the encoding of PORT.
+ (let ((e "â¦"))
+ (catch 'encoding-error
+ (lambda ()
+ (with-output-to-string
+ (lambda ()
+ (display e))))
+ (lambda (key . args)
+ "..."))))
+
+ (let ((ellipsis-width (string-length ellipsis)))
+
+ (define (print-sequence x width len ref next)
+ (let lp ((x x)
+ (width width)
+ (i 0))
+ (if (> i 0)
+ (display #\space))
+ (cond
+ ((= i len)) ; catches 0-length case
+ ((= i (1- len))
+ (print (ref x i) (if (zero? i) width (1- width))))
+ ((<= width (+ 1 ellipsis-width))
+ (display "..."))
+ (else
+ (let ((str
+ (with-fluids ((%default-port-encoding (port-encoding port)))
+ (with-output-to-string
+ (lambda ()
+ (print (ref x i)
+ (if breadth-first?
+ (max 1
+ (1- (floor (/ width (- len i)))))
+ (- width (+ 1 ellipsis-width)))))))))
+ (display str)
+ (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+ (define (print-tree x width)
+ ;; width is >= the width of # . #, which is 5
+ (let lp ((x x)
+ (width width))
+ (cond
+ ((or (not (pair? x)) (<= width 4))
+ (display ". ")
+ (print x (- width 2)))
+ (else
+ ;; width >= 5
+ (let ((str (with-output-to-string
+ (lambda ()
+ (print (car x)
+ (if breadth-first?
+ (floor (/ (- width 3) 2))
+ (- width 4)))))))
+ (display str)
+ (display " ")
+ (lp (cdr x) (- width 1 (string-length str))))))))
+
+ (define (truncate-string str width)
+ ;; width is < (string-length str)
+ (let lp ((fixes '(("#<" . ">")
+ ("#(" . ")")
+ ("(" . ")")
+ ("\"" . "\""))))
+ (cond
+ ((null? fixes)
+ "#")
+ ((and (string-prefix? (caar fixes) str)
+ (string-suffix? (cdar fixes) str)
+ (>= (string-length str)
+ width
+ (+ (string-length (caar fixes))
+ (string-length (cdar fixes))
+ ellipsis-width)))
+ (format #f "~a~a~a~a"
+ (caar fixes)
+ (substring str (string-length (caar fixes))
+ (- width (string-length (cdar fixes))
+ ellipsis-width))
+ ellipsis
+ (cdar fixes)))
+ (else
+ (lp (cdr fixes))))))
+
+ (define (print x width)
+ (cond
+ ((<= width 0)
+ (error "expected a positive width" width))
+ ((list? x)
+ (cond
+ ((>= width (+ 2 ellipsis-width))
+ (display "(")
+ (print-sequence x (- width 2) (length x)
+ (lambda (x i) (car x)) cdr)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((vector? x)
+ (cond
+ ((>= width (+ 3 ellipsis-width))
+ (display "#(")
+ (print-sequence x (- width 3) (vector-length x)
+ vector-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((uniform-vector? x)
+ (cond
+ ((>= width 9)
+ (format #t "#~a(" (uniform-vector-element-type x))
+ (print-sequence x (- width 6) (uniform-vector-length x)
+ uniform-vector-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((pair? x)
+ (cond
+ ((>= width (+ 4 ellipsis-width))
+ (display "(")
+ (print-tree x (- width 2))
+ (display ")"))
+ (else
+ (display "#"))))
+ (else
+ (let* ((str (with-output-to-string
+ (lambda () (if display? (display x) (write x)))))
+ (len (string-length str)))
+ (display (if (<= (string-length str) width)
+ str
+ (truncate-string str width)))))))
+
+ (with-output-to-port port
+ (lambda ()
+ (print x width))))))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index bc14711..f84119d 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,610 +1,644 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(letrec ((#{and-map*\ 31}#
- (lambda (#{f\ 69}# #{first\ 70}# . #{rest\ 71}#)
- (let ((#{t\ 72}# (null? #{first\ 70}#)))
- (if #{t\ 72}#
- #{t\ 72}#
- (if (null? #{rest\ 71}#)
- (letrec ((#{andmap\ 73}#
- (lambda (#{first\ 74}#)
- (let ((#{x\ 75}# (car #{first\ 74}#))
- (#{first\ 76}# (cdr #{first\ 74}#)))
- (if (null? #{first\ 76}#)
- (#{f\ 69}# #{x\ 75}#)
- (if (#{f\ 69}# #{x\ 75}#)
- (#{andmap\ 73}# #{first\ 76}#)
+(letrec ((#{and-map*\ 8874}#
+ (lambda (#{f\ 8936}# #{first\ 8937}# . #{rest\ 8938}#)
+ (let ((#{t\ 8944}# (null? #{first\ 8937}#)))
+ (if #{t\ 8944}#
+ #{t\ 8944}#
+ (if (null? #{rest\ 8938}#)
+ (letrec ((#{andmap\ 8948}#
+ (lambda (#{first\ 8949}#)
+ (let ((#{x\ 8952}# (car #{first\ 8949}#))
+ (#{first\ 8953}# (cdr #{first\ 8949}#)))
+ (if (null? #{first\ 8953}#)
+ (#{f\ 8936}# #{x\ 8952}#)
+ (if (#{f\ 8936}# #{x\ 8952}#)
+ (#{andmap\ 8948}# #{first\ 8953}#)
#f))))))
- (#{andmap\ 73}# #{first\ 70}#))
- (letrec ((#{andmap\ 77}#
- (lambda (#{first\ 78}# #{rest\ 79}#)
- (let ((#{x\ 80}# (car #{first\ 78}#))
- (#{xr\ 81}# (map car #{rest\ 79}#))
- (#{first\ 82}# (cdr #{first\ 78}#))
- (#{rest\ 83}# (map cdr #{rest\ 79}#)))
- (if (null? #{first\ 82}#)
- (apply #{f\ 69}#
- (cons #{x\ 80}# #{xr\ 81}#))
- (if (apply #{f\ 69}#
- (cons #{x\ 80}# #{xr\ 81}#))
- (#{andmap\ 77}#
- #{first\ 82}#
- #{rest\ 83}#)
+ (#{andmap\ 8948}# #{first\ 8937}#))
+ (letrec ((#{andmap\ 8959}#
+ (lambda (#{first\ 8960}# #{rest\ 8961}#)
+ (let ((#{x\ 8966}# (car #{first\ 8960}#))
+ (#{xr\ 8967}# (map car #{rest\ 8961}#))
+ (#{first\ 8968}# (cdr #{first\ 8960}#))
+ (#{rest\ 8969}#
+ (map cdr #{rest\ 8961}#)))
+ (if (null? #{first\ 8968}#)
+ (apply #{f\ 8936}#
+ (cons #{x\ 8966}# #{xr\ 8967}#))
+ (if (apply #{f\ 8936}#
+ (cons #{x\ 8966}# #{xr\ 8967}#))
+ (#{andmap\ 8959}#
+ #{first\ 8968}#
+ #{rest\ 8969}#)
#f))))))
- (#{andmap\ 77}# #{first\ 70}# #{rest\ 71}#))))))))
- (letrec ((#{lambda-var-list\ 182}#
- (lambda (#{vars\ 306}#)
- (letrec ((#{lvl\ 307}#
- (lambda (#{vars\ 308}# #{ls\ 309}# #{w\ 310}#)
- (if (pair? #{vars\ 308}#)
- (#{lvl\ 307}#
- (cdr #{vars\ 308}#)
- (cons (#{wrap\ 159}#
- (car #{vars\ 308}#)
- #{w\ 310}#
+ (#{andmap\ 8959}# #{first\ 8937}# #{rest\ 8938}#))))))))
+ (letrec ((#{lambda-var-list\ 9191}#
+ (lambda (#{vars\ 9406}#)
+ (letrec ((#{lvl\ 9412}#
+ (lambda (#{vars\ 9413}# #{ls\ 9414}# #{w\ 9415}#)
+ (if (pair? #{vars\ 9413}#)
+ (#{lvl\ 9412}#
+ (cdr #{vars\ 9413}#)
+ (cons (#{wrap\ 9145}#
+ (car #{vars\ 9413}#)
+ #{w\ 9415}#
#f)
- #{ls\ 309}#)
- #{w\ 310}#)
- (if (#{id?\ 131}# #{vars\ 308}#)
- (cons (#{wrap\ 159}#
- #{vars\ 308}#
- #{w\ 310}#
+ #{ls\ 9414}#)
+ #{w\ 9415}#)
+ (if (#{id?\ 9076}# #{vars\ 9413}#)
+ (cons (#{wrap\ 9145}#
+ #{vars\ 9413}#
+ #{w\ 9415}#
#f)
- #{ls\ 309}#)
- (if (null? #{vars\ 308}#)
- #{ls\ 309}#
- (if (#{syntax-object?\ 115}# #{vars\ 308}#)
- (#{lvl\ 307}#
- (#{syntax-object-expression\ 116}#
- #{vars\ 308}#)
- #{ls\ 309}#
- (#{join-wraps\ 150}#
- #{w\ 310}#
- (#{syntax-object-wrap\ 117}#
- #{vars\ 308}#)))
- (cons #{vars\ 308}# #{ls\ 309}#))))))))
- (#{lvl\ 307}#
- #{vars\ 306}#
+ #{ls\ 9414}#)
+ (if (null? #{vars\ 9413}#)
+ #{ls\ 9414}#
+ (if (#{syntax-object?\ 9040}# #{vars\ 9413}#)
+ (#{lvl\ 9412}#
+ (#{syntax-object-expression\ 9042}#
+ #{vars\ 9413}#)
+ #{ls\ 9414}#
+ (#{join-wraps\ 9127}#
+ #{w\ 9415}#
+ (#{syntax-object-wrap\ 9044}#
+ #{vars\ 9413}#)))
+ (cons #{vars\ 9413}# #{ls\ 9414}#))))))))
+ (#{lvl\ 9412}#
+ #{vars\ 9406}#
'()
'(())))))
- (#{gen-var\ 181}#
- (lambda (#{id\ 311}#)
- (let ((#{id\ 312}#
- (if (#{syntax-object?\ 115}# #{id\ 311}#)
- (#{syntax-object-expression\ 116}# #{id\ 311}#)
- #{id\ 311}#)))
+ (#{gen-var\ 9189}#
+ (lambda (#{id\ 9426}#)
+ (let ((#{id\ 9429}#
+ (if (#{syntax-object?\ 9040}# #{id\ 9426}#)
+ (#{syntax-object-expression\ 9042}# #{id\ 9426}#)
+ #{id\ 9426}#)))
(gensym
- (string-append (symbol->string #{id\ 312}#) " ")))))
- (#{strip\ 180}#
- (lambda (#{x\ 313}# #{w\ 314}#)
+ (string-append (symbol->string #{id\ 9429}#) " ")))))
+ (#{strip\ 9187}#
+ (lambda (#{x\ 9431}# #{w\ 9432}#)
(if (memq 'top
- (#{wrap-marks\ 134}# #{w\ 314}#))
- #{x\ 313}#
- (letrec ((#{f\ 315}# (lambda (#{x\ 316}#)
- (if (#{syntax-object?\ 115}#
- #{x\ 316}#)
- (#{strip\ 180}#
- (#{syntax-object-expression\ 116}#
- #{x\ 316}#)
- (#{syntax-object-wrap\ 117}#
- #{x\ 316}#))
- (if (pair? #{x\ 316}#)
- (let ((#{a\ 317}# (#{f\ 315}# (car
#{x\ 316}#)))
- (#{d\ 318}# (#{f\ 315}# (cdr
#{x\ 316}#))))
- (if (if (eq? #{a\ 317}#
- (car #{x\ 316}#))
- (eq? #{d\ 318}#
- (cdr #{x\ 316}#))
- #f)
- #{x\ 316}#
- (cons #{a\ 317}# #{d\ 318}#)))
- (if (vector? #{x\ 316}#)
- (let ((#{old\ 319}#
- (vector->list
- #{x\ 316}#)))
- (let ((#{new\ 320}#
- (map #{f\ 315}#
- #{old\ 319}#)))
- (if (#{and-map*\ 31}#
- eq?
- #{old\ 319}#
- #{new\ 320}#)
- #{x\ 316}#
- (list->vector
- #{new\ 320}#))))
- #{x\ 316}#))))))
- (#{f\ 315}# #{x\ 313}#)))))
- (#{chi-lambda-case\ 179}#
- (lambda (#{e\ 321}#
- #{r\ 322}#
- #{w\ 323}#
- #{s\ 324}#
- #{mod\ 325}#
- #{get-formals\ 326}#
- #{clauses\ 327}#)
- (letrec ((#{expand-body\ 331}#
- (lambda (#{req\ 332}#
- #{opt\ 333}#
- #{rest\ 334}#
- #{kw\ 335}#
- #{body\ 336}#
- #{vars\ 337}#
- #{r*\ 338}#
- #{w*\ 339}#
- #{inits\ 340}#)
- ((lambda (#{tmp\ 341}#)
- ((lambda (#{tmp\ 342}#)
- (if (if #{tmp\ 342}#
- (apply (lambda (#{docstring\ 343}#
- #{e1\ 344}#
- #{e2\ 345}#)
+ (#{wrap-marks\ 9083}# #{w\ 9432}#))
+ #{x\ 9431}#
+ (letrec ((#{f\ 9438}#
+ (lambda (#{x\ 9439}#)
+ (if (#{syntax-object?\ 9040}# #{x\ 9439}#)
+ (#{strip\ 9187}#
+ (#{syntax-object-expression\ 9042}#
+ #{x\ 9439}#)
+ (#{syntax-object-wrap\ 9044}# #{x\ 9439}#))
+ (if (pair? #{x\ 9439}#)
+ (let ((#{a\ 9446}#
+ (#{f\ 9438}# (car #{x\ 9439}#)))
+ (#{d\ 9447}#
+ (#{f\ 9438}# (cdr #{x\ 9439}#))))
+ (if (if (eq? #{a\ 9446}# (car #{x\ 9439}#))
+ (eq? #{d\ 9447}# (cdr #{x\ 9439}#))
+ #f)
+ #{x\ 9439}#
+ (cons #{a\ 9446}# #{d\ 9447}#)))
+ (if (vector? #{x\ 9439}#)
+ (let ((#{old\ 9453}#
+ (vector->list #{x\ 9439}#)))
+ (let ((#{new\ 9455}#
+ (map #{f\ 9438}# #{old\ 9453}#)))
+ (if (#{and-map*\ 8874}#
+ eq?
+ #{old\ 9453}#
+ #{new\ 9455}#)
+ #{x\ 9439}#
+ (list->vector #{new\ 9455}#))))
+ #{x\ 9439}#))))))
+ (#{f\ 9438}# #{x\ 9431}#)))))
+ (#{chi-lambda-case\ 9185}#
+ (lambda (#{e\ 9457}#
+ #{r\ 9458}#
+ #{w\ 9459}#
+ #{s\ 9460}#
+ #{mod\ 9461}#
+ #{get-formals\ 9462}#
+ #{clauses\ 9463}#)
+ (letrec ((#{expand-body\ 9478}#
+ (lambda (#{req\ 9479}#
+ #{opt\ 9480}#
+ #{rest\ 9481}#
+ #{kw\ 9482}#
+ #{body\ 9483}#
+ #{vars\ 9484}#
+ #{r*\ 9485}#
+ #{w*\ 9486}#
+ #{inits\ 9487}#
+ #{meta\ 9488}#)
+ ((lambda (#{tmp\ 9499}#)
+ ((lambda (#{tmp\ 9500}#)
+ (if (if #{tmp\ 9500}#
+ (apply (lambda (#{docstring\ 9504}#
+ #{e1\ 9505}#
+ #{e2\ 9506}#)
(string?
(syntax->datum
- #{docstring\ 343}#)))
- #{tmp\ 342}#)
+ #{docstring\ 9504}#)))
+ #{tmp\ 9500}#)
#f)
- (apply (lambda (#{docstring\ 346}#
- #{e1\ 347}#
- #{e2\ 348}#)
- (values
- (syntax->datum
- #{docstring\ 346}#)
- #{req\ 332}#
- #{opt\ 333}#
- #{rest\ 334}#
- #{kw\ 335}#
- #{inits\ 340}#
- #{vars\ 337}#
- (#{chi-body\ 171}#
- (cons #{e1\ 347}# #{e2\ 348}#)
- (#{source-wrap\ 160}#
- #{e\ 321}#
- #{w\ 323}#
- #{s\ 324}#
- #{mod\ 325}#)
- #{r*\ 338}#
- #{w*\ 339}#
- #{mod\ 325}#)))
- #{tmp\ 342}#)
- ((lambda (#{tmp\ 350}#)
- (if #{tmp\ 350}#
- (apply (lambda (#{e1\ 351}#
- #{e2\ 352}#)
- (values
- #f
- #{req\ 332}#
- #{opt\ 333}#
- #{rest\ 334}#
- #{kw\ 335}#
- #{inits\ 340}#
- #{vars\ 337}#
- (#{chi-body\ 171}#
- (cons #{e1\ 351}#
- #{e2\ 352}#)
- (#{source-wrap\ 160}#
- #{e\ 321}#
- #{w\ 323}#
- #{s\ 324}#
- #{mod\ 325}#)
- #{r*\ 338}#
- #{w*\ 339}#
- #{mod\ 325}#)))
- #{tmp\ 350}#)
- (syntax-violation
- #f
- "source expression failed to match
any pattern"
- #{tmp\ 341}#)))
+ (apply (lambda (#{docstring\ 9510}#
+ #{e1\ 9511}#
+ #{e2\ 9512}#)
+ (#{expand-body\ 9478}#
+ #{req\ 9479}#
+ #{opt\ 9480}#
+ #{rest\ 9481}#
+ #{kw\ 9482}#
+ (cons #{e1\ 9511}# #{e2\ 9512}#)
+ #{vars\ 9484}#
+ #{r*\ 9485}#
+ #{w*\ 9486}#
+ #{inits\ 9487}#
+ (append
+ #{meta\ 9488}#
+ (list (cons 'documentation
+ (syntax->datum
+ #{docstring\
9510}#))))))
+ #{tmp\ 9500}#)
+ ((lambda (#{tmp\ 9515}#)
+ (if #{tmp\ 9515}#
+ (apply (lambda (#{k\ 9520}#
+ #{v\ 9521}#
+ #{e1\ 9522}#
+ #{e2\ 9523}#)
+ (#{expand-body\ 9478}#
+ #{req\ 9479}#
+ #{opt\ 9480}#
+ #{rest\ 9481}#
+ #{kw\ 9482}#
+ (cons #{e1\ 9522}#
+ #{e2\ 9523}#)
+ #{vars\ 9484}#
+ #{r*\ 9485}#
+ #{w*\ 9486}#
+ #{inits\ 9487}#
+ (append
+ #{meta\ 9488}#
+ (syntax->datum
+ (map cons
+ #{k\ 9520}#
+ #{v\ 9521}#)))))
+ #{tmp\ 9515}#)
+ ((lambda (#{tmp\ 9527}#)
+ (if #{tmp\ 9527}#
+ (apply (lambda (#{e1\ 9530}#
+ #{e2\ 9531}#)
+ (values
+ #{meta\ 9488}#
+ #{req\ 9479}#
+ #{opt\ 9480}#
+ #{rest\ 9481}#
+ #{kw\ 9482}#
+ #{inits\ 9487}#
+ #{vars\ 9484}#
+ (#{chi-body\ 9169}#
+ (cons #{e1\ 9530}#
+ #{e2\ 9531}#)
+ (#{source-wrap\
9147}#
+ #{e\ 9457}#
+ #{w\ 9459}#
+ #{s\ 9460}#
+ #{mod\ 9461}#)
+ #{r*\ 9485}#
+ #{w*\ 9486}#
+ #{mod\ 9461}#)))
+ #{tmp\ 9527}#)
+ (syntax-violation
+ #f
+ "source expression failed to
match any pattern"
+ #{tmp\ 9499}#)))
+ ($sc-dispatch
+ #{tmp\ 9499}#
+ '(any . each-any)))))
($sc-dispatch
- #{tmp\ 341}#
- '(any . each-any)))))
+ #{tmp\ 9499}#
+ '(#(vector #(each (any . any)))
+ any
+ .
+ each-any)))))
($sc-dispatch
- #{tmp\ 341}#
+ #{tmp\ 9499}#
'(any any . each-any))))
- #{body\ 336}#)))
- (#{expand-kw\ 330}#
- (lambda (#{req\ 354}#
- #{opt\ 355}#
- #{rest\ 356}#
- #{kw\ 357}#
- #{body\ 358}#
- #{vars\ 359}#
- #{r*\ 360}#
- #{w*\ 361}#
- #{aok\ 362}#
- #{out\ 363}#
- #{inits\ 364}#)
- (if (pair? #{kw\ 357}#)
- ((lambda (#{tmp\ 365}#)
- ((lambda (#{tmp\ 366}#)
- (if #{tmp\ 366}#
- (apply (lambda (#{k\ 367}#
- #{id\ 368}#
- #{i\ 369}#)
- (let ((#{v\ 370}# (#{gen-var\
181}#
- #{id\
368}#)))
- (let ((#{l\ 371}#
(#{gen-labels\ 137}#
- (list
#{v\ 370}#))))
- (let ((#{r**\ 372}#
- (#{extend-var-env\
126}#
- #{l\ 371}#
- (list #{v\ 370}#)
- #{r*\ 360}#)))
- (let ((#{w**\ 373}#
-
(#{make-binding-wrap\ 148}#
- (list #{id\
368}#)
- #{l\ 371}#
- #{w*\ 361}#)))
- (#{expand-kw\ 330}#
- #{req\ 354}#
- #{opt\ 355}#
- #{rest\ 356}#
- (cdr #{kw\ 357}#)
- #{body\ 358}#
- (cons #{v\ 370}#
- #{vars\ 359}#)
- #{r**\ 372}#
- #{w**\ 373}#
- #{aok\ 362}#
+ #{body\ 9483}#)))
+ (#{expand-kw\ 9476}#
+ (lambda (#{req\ 9533}#
+ #{opt\ 9534}#
+ #{rest\ 9535}#
+ #{kw\ 9536}#
+ #{body\ 9537}#
+ #{vars\ 9538}#
+ #{r*\ 9539}#
+ #{w*\ 9540}#
+ #{aok\ 9541}#
+ #{out\ 9542}#
+ #{inits\ 9543}#)
+ (if (pair? #{kw\ 9536}#)
+ ((lambda (#{tmp\ 9557}#)
+ ((lambda (#{tmp\ 9558}#)
+ (if #{tmp\ 9558}#
+ (apply (lambda (#{k\ 9562}#
+ #{id\ 9563}#
+ #{i\ 9564}#)
+ (let ((#{v\ 9567}#
+ (#{gen-var\ 9189}#
+ #{id\ 9563}#)))
+ (let ((#{l\ 9569}#
+ (#{gen-labels\ 9094}#
+ (list #{v\
9567}#))))
+ (let ((#{r**\ 9571}#
+ (#{extend-var-env\
9066}#
+ #{l\ 9569}#
+ (list #{v\ 9567}#)
+ #{r*\ 9539}#)))
+ (let ((#{w**\ 9573}#
+
(#{make-binding-wrap\ 9123}#
+ (list #{id\
9563}#)
+ #{l\ 9569}#
+ #{w*\ 9540}#)))
+ (#{expand-kw\ 9476}#
+ #{req\ 9533}#
+ #{opt\ 9534}#
+ #{rest\ 9535}#
+ (cdr #{kw\ 9536}#)
+ #{body\ 9537}#
+ (cons #{v\ 9567}#
+ #{vars\ 9538}#)
+ #{r**\ 9571}#
+ #{w**\ 9573}#
+ #{aok\ 9541}#
(cons (list
(syntax->datum
- #{k\
367}#)
+ #{k\
9562}#)
(syntax->datum
- #{id\
368}#)
- #{v\
370}#)
- #{out\ 363}#)
- (cons (#{chi\ 167}#
- #{i\ 369}#
- #{r*\ 360}#
- #{w*\ 361}#
- #{mod\ 325}#)
- #{inits\
364}#)))))))
- #{tmp\ 366}#)
+ #{id\
9563}#)
+ #{v\
9567}#)
+ #{out\ 9542}#)
+ (cons (#{chi\ 9161}#
+ #{i\ 9564}#
+ #{r*\ 9539}#
+ #{w*\ 9540}#
+ #{mod\ 9461}#)
+ #{inits\
9543}#)))))))
+ #{tmp\ 9558}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 365}#)))
+ #{tmp\ 9557}#)))
($sc-dispatch
- #{tmp\ 365}#
+ #{tmp\ 9557}#
'(any any any))))
- (car #{kw\ 357}#))
- (#{expand-body\ 331}#
- #{req\ 354}#
- #{opt\ 355}#
- #{rest\ 356}#
- (if (let ((#{t\ 374}# #{aok\ 362}#))
- (if #{t\ 374}#
- #{t\ 374}#
- (pair? #{out\ 363}#)))
- (cons #{aok\ 362}# (reverse #{out\ 363}#))
+ (car #{kw\ 9536}#))
+ (#{expand-body\ 9478}#
+ #{req\ 9533}#
+ #{opt\ 9534}#
+ #{rest\ 9535}#
+ (if (let ((#{t\ 9577}# #{aok\ 9541}#))
+ (if #{t\ 9577}#
+ #{t\ 9577}#
+ (pair? #{out\ 9542}#)))
+ (cons #{aok\ 9541}# (reverse #{out\ 9542}#))
#f)
- #{body\ 358}#
- (reverse #{vars\ 359}#)
- #{r*\ 360}#
- #{w*\ 361}#
- (reverse #{inits\ 364}#)))))
- (#{expand-opt\ 329}#
- (lambda (#{req\ 375}#
- #{opt\ 376}#
- #{rest\ 377}#
- #{kw\ 378}#
- #{body\ 379}#
- #{vars\ 380}#
- #{r*\ 381}#
- #{w*\ 382}#
- #{out\ 383}#
- #{inits\ 384}#)
- (if (pair? #{opt\ 376}#)
- ((lambda (#{tmp\ 385}#)
- ((lambda (#{tmp\ 386}#)
- (if #{tmp\ 386}#
- (apply (lambda (#{id\ 387}# #{i\ 388}#)
- (let ((#{v\ 389}# (#{gen-var\
181}#
- #{id\
387}#)))
- (let ((#{l\ 390}#
(#{gen-labels\ 137}#
- (list
#{v\ 389}#))))
- (let ((#{r**\ 391}#
- (#{extend-var-env\
126}#
- #{l\ 390}#
- (list #{v\ 389}#)
- #{r*\ 381}#)))
- (let ((#{w**\ 392}#
-
(#{make-binding-wrap\ 148}#
- (list #{id\
387}#)
- #{l\ 390}#
- #{w*\ 382}#)))
- (#{expand-opt\ 329}#
- #{req\ 375}#
- (cdr #{opt\ 376}#)
- #{rest\ 377}#
- #{kw\ 378}#
- #{body\ 379}#
- (cons #{v\ 389}#
- #{vars\ 380}#)
- #{r**\ 391}#
- #{w**\ 392}#
+ #{body\ 9537}#
+ (reverse #{vars\ 9538}#)
+ #{r*\ 9539}#
+ #{w*\ 9540}#
+ (reverse #{inits\ 9543}#)
+ '()))))
+ (#{expand-opt\ 9474}#
+ (lambda (#{req\ 9579}#
+ #{opt\ 9580}#
+ #{rest\ 9581}#
+ #{kw\ 9582}#
+ #{body\ 9583}#
+ #{vars\ 9584}#
+ #{r*\ 9585}#
+ #{w*\ 9586}#
+ #{out\ 9587}#
+ #{inits\ 9588}#)
+ (if (pair? #{opt\ 9580}#)
+ ((lambda (#{tmp\ 9601}#)
+ ((lambda (#{tmp\ 9602}#)
+ (if #{tmp\ 9602}#
+ (apply (lambda (#{id\ 9605}# #{i\ 9606}#)
+ (let ((#{v\ 9609}#
+ (#{gen-var\ 9189}#
+ #{id\ 9605}#)))
+ (let ((#{l\ 9611}#
+ (#{gen-labels\ 9094}#
+ (list #{v\
9609}#))))
+ (let ((#{r**\ 9613}#
+ (#{extend-var-env\
9066}#
+ #{l\ 9611}#
+ (list #{v\ 9609}#)
+ #{r*\ 9585}#)))
+ (let ((#{w**\ 9615}#
+
(#{make-binding-wrap\ 9123}#
+ (list #{id\
9605}#)
+ #{l\ 9611}#
+ #{w*\ 9586}#)))
+ (#{expand-opt\ 9474}#
+ #{req\ 9579}#
+ (cdr #{opt\ 9580}#)
+ #{rest\ 9581}#
+ #{kw\ 9582}#
+ #{body\ 9583}#
+ (cons #{v\ 9609}#
+ #{vars\ 9584}#)
+ #{r**\ 9613}#
+ #{w**\ 9615}#
(cons (syntax->datum
- #{id\ 387}#)
- #{out\ 383}#)
- (cons (#{chi\ 167}#
- #{i\ 388}#
- #{r*\ 381}#
- #{w*\ 382}#
- #{mod\ 325}#)
- #{inits\
384}#)))))))
- #{tmp\ 386}#)
+ #{id\ 9605}#)
+ #{out\ 9587}#)
+ (cons (#{chi\ 9161}#
+ #{i\ 9606}#
+ #{r*\ 9585}#
+ #{w*\ 9586}#
+ #{mod\ 9461}#)
+ #{inits\
9588}#)))))))
+ #{tmp\ 9602}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 385}#)))
+ #{tmp\ 9601}#)))
($sc-dispatch
- #{tmp\ 385}#
+ #{tmp\ 9601}#
'(any any))))
- (car #{opt\ 376}#))
- (if #{rest\ 377}#
- (let ((#{v\ 393}# (#{gen-var\ 181}#
- #{rest\ 377}#)))
- (let ((#{l\ 394}# (#{gen-labels\ 137}#
- (list #{v\ 393}#))))
- (let ((#{r*\ 395}#
- (#{extend-var-env\ 126}#
- #{l\ 394}#
- (list #{v\ 393}#)
- #{r*\ 381}#)))
- (let ((#{w*\ 396}#
- (#{make-binding-wrap\ 148}#
- (list #{rest\ 377}#)
- #{l\ 394}#
- #{w*\ 382}#)))
- (#{expand-kw\ 330}#
- #{req\ 375}#
- (if (pair? #{out\ 383}#)
- (reverse #{out\ 383}#)
+ (car #{opt\ 9580}#))
+ (if #{rest\ 9581}#
+ (let ((#{v\ 9620}#
+ (#{gen-var\ 9189}# #{rest\ 9581}#)))
+ (let ((#{l\ 9622}#
+ (#{gen-labels\ 9094}#
+ (list #{v\ 9620}#))))
+ (let ((#{r*\ 9624}#
+ (#{extend-var-env\ 9066}#
+ #{l\ 9622}#
+ (list #{v\ 9620}#)
+ #{r*\ 9585}#)))
+ (let ((#{w*\ 9626}#
+ (#{make-binding-wrap\ 9123}#
+ (list #{rest\ 9581}#)
+ #{l\ 9622}#
+ #{w*\ 9586}#)))
+ (#{expand-kw\ 9476}#
+ #{req\ 9579}#
+ (if (pair? #{out\ 9587}#)
+ (reverse #{out\ 9587}#)
#f)
- (syntax->datum #{rest\ 377}#)
- (if (pair? #{kw\ 378}#)
- (cdr #{kw\ 378}#)
- #{kw\ 378}#)
- #{body\ 379}#
- (cons #{v\ 393}# #{vars\ 380}#)
- #{r*\ 395}#
- #{w*\ 396}#
- (if (pair? #{kw\ 378}#)
- (car #{kw\ 378}#)
+ (syntax->datum #{rest\ 9581}#)
+ (if (pair? #{kw\ 9582}#)
+ (cdr #{kw\ 9582}#)
+ #{kw\ 9582}#)
+ #{body\ 9583}#
+ (cons #{v\ 9620}# #{vars\ 9584}#)
+ #{r*\ 9624}#
+ #{w*\ 9626}#
+ (if (pair? #{kw\ 9582}#)
+ (car #{kw\ 9582}#)
#f)
'()
- #{inits\ 384}#)))))
- (#{expand-kw\ 330}#
- #{req\ 375}#
- (if (pair? #{out\ 383}#)
- (reverse #{out\ 383}#)
+ #{inits\ 9588}#)))))
+ (#{expand-kw\ 9476}#
+ #{req\ 9579}#
+ (if (pair? #{out\ 9587}#)
+ (reverse #{out\ 9587}#)
#f)
#f
- (if (pair? #{kw\ 378}#)
- (cdr #{kw\ 378}#)
- #{kw\ 378}#)
- #{body\ 379}#
- #{vars\ 380}#
- #{r*\ 381}#
- #{w*\ 382}#
- (if (pair? #{kw\ 378}#) (car #{kw\ 378}#) #f)
+ (if (pair? #{kw\ 9582}#)
+ (cdr #{kw\ 9582}#)
+ #{kw\ 9582}#)
+ #{body\ 9583}#
+ #{vars\ 9584}#
+ #{r*\ 9585}#
+ #{w*\ 9586}#
+ (if (pair? #{kw\ 9582}#)
+ (car #{kw\ 9582}#)
+ #f)
'()
- #{inits\ 384}#)))))
- (#{expand-req\ 328}#
- (lambda (#{req\ 397}#
- #{opt\ 398}#
- #{rest\ 399}#
- #{kw\ 400}#
- #{body\ 401}#)
- (let ((#{vars\ 402}#
- (map #{gen-var\ 181}# #{req\ 397}#))
- (#{labels\ 403}#
- (#{gen-labels\ 137}# #{req\ 397}#)))
- (let ((#{r*\ 404}#
- (#{extend-var-env\ 126}#
- #{labels\ 403}#
- #{vars\ 402}#
- #{r\ 322}#))
- (#{w*\ 405}#
- (#{make-binding-wrap\ 148}#
- #{req\ 397}#
- #{labels\ 403}#
- #{w\ 323}#)))
- (#{expand-opt\ 329}#
- (map syntax->datum #{req\ 397}#)
- #{opt\ 398}#
- #{rest\ 399}#
- #{kw\ 400}#
- #{body\ 401}#
- (reverse #{vars\ 402}#)
- #{r*\ 404}#
- #{w*\ 405}#
+ #{inits\ 9588}#)))))
+ (#{expand-req\ 9472}#
+ (lambda (#{req\ 9628}#
+ #{opt\ 9629}#
+ #{rest\ 9630}#
+ #{kw\ 9631}#
+ #{body\ 9632}#)
+ (let ((#{vars\ 9640}#
+ (map #{gen-var\ 9189}# #{req\ 9628}#))
+ (#{labels\ 9641}#
+ (#{gen-labels\ 9094}# #{req\ 9628}#)))
+ (let ((#{r*\ 9644}#
+ (#{extend-var-env\ 9066}#
+ #{labels\ 9641}#
+ #{vars\ 9640}#
+ #{r\ 9458}#))
+ (#{w*\ 9645}#
+ (#{make-binding-wrap\ 9123}#
+ #{req\ 9628}#
+ #{labels\ 9641}#
+ #{w\ 9459}#)))
+ (#{expand-opt\ 9474}#
+ (map syntax->datum #{req\ 9628}#)
+ #{opt\ 9629}#
+ #{rest\ 9630}#
+ #{kw\ 9631}#
+ #{body\ 9632}#
+ (reverse #{vars\ 9640}#)
+ #{r*\ 9644}#
+ #{w*\ 9645}#
'()
'()))))))
- ((lambda (#{tmp\ 406}#)
- ((lambda (#{tmp\ 407}#)
- (if #{tmp\ 407}#
- (apply (lambda () (values #f #f)) #{tmp\ 407}#)
- ((lambda (#{tmp\ 408}#)
- (if #{tmp\ 408}#
- (apply (lambda (#{args\ 409}#
- #{e1\ 410}#
- #{e2\ 411}#
- #{args*\ 412}#
- #{e1*\ 413}#
- #{e2*\ 414}#)
+ ((lambda (#{tmp\ 9646}#)
+ ((lambda (#{tmp\ 9647}#)
+ (if #{tmp\ 9647}#
+ (apply (lambda () (values (quote ()) #f))
+ #{tmp\ 9647}#)
+ ((lambda (#{tmp\ 9648}#)
+ (if #{tmp\ 9648}#
+ (apply (lambda (#{args\ 9655}#
+ #{e1\ 9656}#
+ #{e2\ 9657}#
+ #{args*\ 9658}#
+ #{e1*\ 9659}#
+ #{e2*\ 9660}#)
(call-with-values
(lambda ()
- (#{get-formals\ 326}#
- #{args\ 409}#))
- (lambda (#{req\ 415}#
- #{opt\ 416}#
- #{rest\ 417}#
- #{kw\ 418}#)
+ (#{get-formals\ 9462}#
+ #{args\ 9655}#))
+ (lambda (#{req\ 9661}#
+ #{opt\ 9662}#
+ #{rest\ 9663}#
+ #{kw\ 9664}#)
(call-with-values
(lambda ()
- (#{expand-req\ 328}#
- #{req\ 415}#
- #{opt\ 416}#
- #{rest\ 417}#
- #{kw\ 418}#
- (cons #{e1\ 410}#
- #{e2\ 411}#)))
- (lambda (#{docstring\ 420}#
- #{req\ 421}#
- #{opt\ 422}#
- #{rest\ 423}#
- #{kw\ 424}#
- #{inits\ 425}#
- #{vars\ 426}#
- #{body\ 427}#)
+ (#{expand-req\ 9472}#
+ #{req\ 9661}#
+ #{opt\ 9662}#
+ #{rest\ 9663}#
+ #{kw\ 9664}#
+ (cons #{e1\ 9656}#
+ #{e2\ 9657}#)))
+ (lambda (#{meta\ 9670}#
+ #{req\ 9671}#
+ #{opt\ 9672}#
+ #{rest\ 9673}#
+ #{kw\ 9674}#
+ #{inits\ 9675}#
+ #{vars\ 9676}#
+ #{body\ 9677}#)
(call-with-values
(lambda ()
- (#{chi-lambda-case\ 179}#
- #{e\ 321}#
- #{r\ 322}#
- #{w\ 323}#
- #{s\ 324}#
- #{mod\ 325}#
- #{get-formals\ 326}#
- (map (lambda (#{tmp\ 430}#
- #{tmp\ 429}#
- #{tmp\
428}#)
- (cons #{tmp\ 428}#
- (cons #{tmp\
429}#
- #{tmp\
430}#)))
- #{e2*\ 414}#
- #{e1*\ 413}#
- #{args*\ 412}#)))
- (lambda (#{docstring*\ 432}#
- #{else*\ 433}#)
+ (#{chi-lambda-case\ 9185}#
+ #{e\ 9457}#
+ #{r\ 9458}#
+ #{w\ 9459}#
+ #{s\ 9460}#
+ #{mod\ 9461}#
+ #{get-formals\ 9462}#
+ (map (lambda (#{tmp\
9688}#
+ #{tmp\
9687}#
+ #{tmp\
9686}#)
+ (cons #{tmp\ 9686}#
+ (cons #{tmp\
9687}#
+ #{tmp\
9688}#)))
+ #{e2*\ 9660}#
+ #{e1*\ 9659}#
+ #{args*\ 9658}#)))
+ (lambda (#{meta*\ 9690}#
+ #{else*\ 9691}#)
(values
- (let ((#{t\ 434}#
#{docstring\ 420}#))
- (if #{t\ 434}#
- #{t\ 434}#
- #{docstring*\ 432}#))
- (#{build-lambda-case\
107}#
- #{s\ 324}#
- #{req\ 421}#
- #{opt\ 422}#
- #{rest\ 423}#
- #{kw\ 424}#
- #{inits\ 425}#
- #{vars\ 426}#
- #{body\ 427}#
- #{else*\ 433}#)))))))))
- #{tmp\ 408}#)
+ (append
+ #{meta\ 9670}#
+ #{meta*\ 9690}#)
+ (#{build-lambda-case\
9022}#
+ #{s\ 9460}#
+ #{req\ 9671}#
+ #{opt\ 9672}#
+ #{rest\ 9673}#
+ #{kw\ 9674}#
+ #{inits\ 9675}#
+ #{vars\ 9676}#
+ #{body\ 9677}#
+ #{else*\ 9691}#)))))))))
+ #{tmp\ 9648}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 406}#)))
+ #{tmp\ 9646}#)))
($sc-dispatch
- #{tmp\ 406}#
+ #{tmp\ 9646}#
'((any any . each-any)
.
#(each (any any . each-any)))))))
- ($sc-dispatch #{tmp\ 406}# (quote ()))))
- #{clauses\ 327}#))))
- (#{lambda*-formals\ 178}#
- (lambda (#{orig-args\ 435}#)
- (letrec ((#{check\ 440}#
- (lambda (#{req\ 441}#
- #{opt\ 442}#
- #{rest\ 443}#
- #{kw\ 444}#)
- (if (#{distinct-bound-ids?\ 157}#
+ ($sc-dispatch #{tmp\ 9646}# (quote ()))))
+ #{clauses\ 9463}#))))
+ (#{lambda*-formals\ 9183}#
+ (lambda (#{orig-args\ 9694}#)
+ (letrec ((#{check\ 9705}#
+ (lambda (#{req\ 9706}#
+ #{opt\ 9707}#
+ #{rest\ 9708}#
+ #{kw\ 9709}#)
+ (if (#{distinct-bound-ids?\ 9141}#
(append
- #{req\ 441}#
- (map car #{opt\ 442}#)
- (if #{rest\ 443}#
- (list #{rest\ 443}#)
+ #{req\ 9706}#
+ (map car #{opt\ 9707}#)
+ (if #{rest\ 9708}#
+ (list #{rest\ 9708}#)
'())
- (if (pair? #{kw\ 444}#)
- (map cadr (cdr #{kw\ 444}#))
+ (if (pair? #{kw\ 9709}#)
+ (map cadr (cdr #{kw\ 9709}#))
'())))
(values
- #{req\ 441}#
- #{opt\ 442}#
- #{rest\ 443}#
- #{kw\ 444}#)
+ #{req\ 9706}#
+ #{opt\ 9707}#
+ #{rest\ 9708}#
+ #{kw\ 9709}#)
(syntax-violation
'lambda*
"duplicate identifier in argument list"
- #{orig-args\ 435}#))))
- (#{rest\ 439}#
- (lambda (#{args\ 445}#
- #{req\ 446}#
- #{opt\ 447}#
- #{kw\ 448}#)
- ((lambda (#{tmp\ 449}#)
- ((lambda (#{tmp\ 450}#)
- (if (if #{tmp\ 450}#
- (apply (lambda (#{r\ 451}#)
- (#{id?\ 131}# #{r\ 451}#))
- #{tmp\ 450}#)
+ #{orig-args\ 9694}#))))
+ (#{rest\ 9703}#
+ (lambda (#{args\ 9717}#
+ #{req\ 9718}#
+ #{opt\ 9719}#
+ #{kw\ 9720}#)
+ ((lambda (#{tmp\ 9725}#)
+ ((lambda (#{tmp\ 9726}#)
+ (if (if #{tmp\ 9726}#
+ (apply (lambda (#{r\ 9728}#)
+ (#{id?\ 9076}# #{r\ 9728}#))
+ #{tmp\ 9726}#)
#f)
- (apply (lambda (#{r\ 452}#)
- (#{check\ 440}#
- #{req\ 446}#
- #{opt\ 447}#
- #{r\ 452}#
- #{kw\ 448}#))
- #{tmp\ 450}#)
- ((lambda (#{else\ 453}#)
+ (apply (lambda (#{r\ 9730}#)
+ (#{check\ 9705}#
+ #{req\ 9718}#
+ #{opt\ 9719}#
+ #{r\ 9730}#
+ #{kw\ 9720}#))
+ #{tmp\ 9726}#)
+ ((lambda (#{else\ 9732}#)
(syntax-violation
'lambda*
"invalid rest argument"
- #{orig-args\ 435}#
- #{args\ 445}#))
- #{tmp\ 449}#)))
- (list #{tmp\ 449}#)))
- #{args\ 445}#)))
- (#{key\ 438}#
- (lambda (#{args\ 454}#
- #{req\ 455}#
- #{opt\ 456}#
- #{rkey\ 457}#)
- ((lambda (#{tmp\ 458}#)
- ((lambda (#{tmp\ 459}#)
- (if #{tmp\ 459}#
+ #{orig-args\ 9694}#
+ #{args\ 9717}#))
+ #{tmp\ 9725}#)))
+ (list #{tmp\ 9725}#)))
+ #{args\ 9717}#)))
+ (#{key\ 9701}#
+ (lambda (#{args\ 9733}#
+ #{req\ 9734}#
+ #{opt\ 9735}#
+ #{rkey\ 9736}#)
+ ((lambda (#{tmp\ 9741}#)
+ ((lambda (#{tmp\ 9742}#)
+ (if #{tmp\ 9742}#
(apply (lambda ()
- (#{check\ 440}#
- #{req\ 455}#
- #{opt\ 456}#
+ (#{check\ 9705}#
+ #{req\ 9734}#
+ #{opt\ 9735}#
#f
(cons #f
- (reverse #{rkey\ 457}#))))
- #{tmp\ 459}#)
- ((lambda (#{tmp\ 460}#)
- (if (if #{tmp\ 460}#
- (apply (lambda (#{a\ 461}#
- #{b\ 462}#)
- (#{id?\ 131}#
- #{a\ 461}#))
- #{tmp\ 460}#)
+ (reverse
+ #{rkey\ 9736}#))))
+ #{tmp\ 9742}#)
+ ((lambda (#{tmp\ 9743}#)
+ (if (if #{tmp\ 9743}#
+ (apply (lambda (#{a\ 9746}#
+ #{b\ 9747}#)
+ (#{id?\ 9076}#
+ #{a\ 9746}#))
+ #{tmp\ 9743}#)
#f)
- (apply (lambda (#{a\ 463}# #{b\ 464}#)
- ((lambda (#{tmp\ 465}#)
- ((lambda (#{k\ 466}#)
- (#{key\ 438}#
- #{b\ 464}#
- #{req\ 455}#
- #{opt\ 456}#
- (cons (cons #{k\
466}#
- (cons
#{a\ 463}#
+ (apply (lambda (#{a\ 9750}#
+ #{b\ 9751}#)
+ ((lambda (#{tmp\ 9753}#)
+ ((lambda (#{k\ 9755}#)
+ (#{key\ 9701}#
+ #{b\ 9751}#
+ #{req\ 9734}#
+ #{opt\ 9735}#
+ (cons (cons #{k\
9755}#
+ (cons
#{a\ 9750}#
'(#(syntax-object
#f
((top)
#(ribcage
#(k)
#((top))
-
#("i"))
+
#("i9754"))
#(ribcage
#(a
b)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i9748"
+
"i9749"))
#(ribcage
()
()
@@ -618,10 +652,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i9737"
+
"i9738"
+
"i9739"
+
"i9740"))
#(ribcage
(check rest
key
@@ -632,15 +666,15 @@
(top)
(top)
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
("i9704"
+
"i9702"
+
"i9700"
+
"i9698"
+
"i9696"))
#(ribcage
#(orig-args)
#((top))
-
#("i"))
+
#("i9695"))
#(ribcage
(lambda-var-list
gen-var
@@ -744,6 +778,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+
build-dynlet
build-conditional
build-application
build-void
@@ -875,349 +910,352 @@
(top)
(top)
(top)
+
(top)
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
("i9190"
+
"i9188"
+
"i9186"
+
"i9184"
+
"i9182"
+
"i9180"
+
"i9178"
+
"i9176"
+
"i9174"
+
"i9172"
+
"i9170"
+
"i9168"
+
"i9166"
+
"i9164"
+
"i9162"
+
"i9160"
+
"i9158"
+
"i9156"
+
"i9154"
+
"i9152"
+
"i9150"
+
"i9148"
+
"i9146"
+
"i9144"
+
"i9142"
+
"i9140"
+
"i9138"
+
"i9136"
+
"i9134"
+
"i9132"
+
"i9130"
+
"i9128"
+
"i9126"
+
"i9124"
+
"i9122"
+
"i9120"
+
"i9119"
+
"i9118"
+
"i9116"
+
"i9115"
+
"i9114"
+
"i9113"
+
"i9112"
+
"i9110"
+
"i9108"
+
"i9106"
+
"i9104"
+
"i9102"
+
"i9100"
+
"i9098"
+
"i9096"
+
"i9093"
+
"i9091"
+
"i9090"
+
"i9089"
+
"i9088"
+
"i9087"
+
"i9086"
+
"i9084"
+
"i9082"
+
"i9080"
+
"i9078"
+
"i9077"
+
"i9075"
+
"i9073"
+
"i9071"
+
"i9069"
+
"i9067"
+
"i9065"
+
"i9063"
+
"i9062"
+
"i9060"
+
"i9058"
+
"i9057"
+
"i9056"
+
"i9054"
+
"i9053"
+
"i9051"
+
"i9049"
+
"i9047"
+
"i9045"
+
"i9043"
+
"i9041"
+
"i9039"
+
"i9037"
+
"i9035"
+
"i9033"
+
"i9031"
+
"i9029"
+
"i9027"
+
"i9025"
+
"i9023"
+
"i9021"
+
"i9019"
+
"i9017"
+
"i9015"
+
"i9013"
+
"i9011"
+
"i9009"
+
"i9007"
+
"i9005"
+
"i9003"
+
"i9001"
+
"i8999"
+
"i8997"
+
"i8995"
+
"i8993"
+
"i8991"
+
"i8989"
+
"i8988"
+
"i8986"
+
"i8984"
+
"i8982"
+
"i8980"
+
"i8978"
+
"i8976"
+
"i8974"
+
"i8972"))
#(ribcage
(define-structure
and-map*)
((top)
(top))
-
("i"
-
"i")))
+
("i8875"
+
"i8873")))
(hygiene
guile)))))
- #{rkey\
457}#)))
- #{tmp\ 465}#))
+ #{rkey\
9736}#)))
+ #{tmp\ 9753}#))
(symbol->keyword
(syntax->datum
- #{a\ 463}#))))
- #{tmp\ 460}#)
- ((lambda (#{tmp\ 467}#)
- (if (if #{tmp\ 467}#
- (apply (lambda (#{a\ 468}#
- #{init\ 469}#
- #{b\ 470}#)
- (#{id?\ 131}#
- #{a\ 468}#))
- #{tmp\ 467}#)
+ #{a\ 9750}#))))
+ #{tmp\ 9743}#)
+ ((lambda (#{tmp\ 9756}#)
+ (if (if #{tmp\ 9756}#
+ (apply (lambda (#{a\ 9760}#
+ #{init\
9761}#
+ #{b\ 9762}#)
+ (#{id?\ 9076}#
+ #{a\ 9760}#))
+ #{tmp\ 9756}#)
#f)
- (apply (lambda (#{a\ 471}#
- #{init\ 472}#
- #{b\ 473}#)
- ((lambda (#{tmp\ 474}#)
- ((lambda (#{k\ 475}#)
- (#{key\ 438}#
- #{b\ 473}#
- #{req\ 455}#
- #{opt\ 456}#
- (cons (list
#{k\ 475}#
-
#{a\ 471}#
-
#{init\ 472}#)
- #{rkey\
457}#)))
- #{tmp\ 474}#))
+ (apply (lambda (#{a\ 9766}#
+ #{init\ 9767}#
+ #{b\ 9768}#)
+ ((lambda (#{tmp\ 9770}#)
+ ((lambda (#{k\
9772}#)
+ (#{key\ 9701}#
+ #{b\ 9768}#
+ #{req\ 9734}#
+ #{opt\ 9735}#
+ (cons (list
#{k\ 9772}#
+
#{a\ 9766}#
+
#{init\ 9767}#)
+ #{rkey\
9736}#)))
+ #{tmp\ 9770}#))
(symbol->keyword
(syntax->datum
- #{a\ 471}#))))
- #{tmp\ 467}#)
- ((lambda (#{tmp\ 476}#)
- (if (if #{tmp\ 476}#
- (apply (lambda (#{a\
477}#
- #{init\
478}#
- #{k\
479}#
- #{b\
480}#)
- (if (#{id?\
131}#
- #{a\
477}#)
+ #{a\ 9766}#))))
+ #{tmp\ 9756}#)
+ ((lambda (#{tmp\ 9773}#)
+ (if (if #{tmp\ 9773}#
+ (apply (lambda (#{a\
9778}#
+ #{init\
9779}#
+ #{k\
9780}#
+ #{b\
9781}#)
+ (if (#{id?\
9076}#
+ #{a\
9778}#)
(keyword?
(syntax->datum
- #{k\
479}#))
+ #{k\
9780}#))
#f))
- #{tmp\ 476}#)
+ #{tmp\ 9773}#)
#f)
- (apply (lambda (#{a\ 481}#
- #{init\
482}#
- #{k\ 483}#
- #{b\ 484}#)
- (#{key\ 438}#
- #{b\ 484}#
- #{req\ 455}#
- #{opt\ 456}#
- (cons (list #{k\
483}#
- #{a\
481}#
-
#{init\ 482}#)
- #{rkey\
457}#)))
- #{tmp\ 476}#)
- ((lambda (#{tmp\ 485}#)
- (if (if #{tmp\ 485}#
- (apply (lambda
(#{aok\ 486}#)
+ (apply (lambda (#{a\ 9788}#
+ #{init\
9789}#
+ #{k\ 9790}#
+ #{b\ 9791}#)
+ (#{key\ 9701}#
+ #{b\ 9791}#
+ #{req\ 9734}#
+ #{opt\ 9735}#
+ (cons (list #{k\
9790}#
+ #{a\
9788}#
+
#{init\ 9789}#)
+ #{rkey\
9736}#)))
+ #{tmp\ 9773}#)
+ ((lambda (#{tmp\ 9792}#)
+ (if (if #{tmp\ 9792}#
+ (apply (lambda
(#{aok\ 9794}#)
(eq?
(syntax->datum
-
#{aok\ 486}#)
+
#{aok\ 9794}#)
#:allow-other-keys))
- #{tmp\
485}#)
+ #{tmp\
9792}#)
#f)
- (apply (lambda (#{aok\
487}#)
- (#{check\
440}#
- #{req\ 455}#
- #{opt\ 456}#
+ (apply (lambda (#{aok\
9796}#)
+ (#{check\
9705}#
+ #{req\
9734}#
+ #{opt\
9735}#
#f
(cons #t
(reverse
-
#{rkey\ 457}#))))
- #{tmp\ 485}#)
- ((lambda (#{tmp\ 488}#)
- (if (if #{tmp\ 488}#
- (apply
(lambda (#{aok\ 489}#
-
#{a\ 490}#
-
#{b\ 491}#)
+
#{rkey\ 9736}#))))
+ #{tmp\ 9792}#)
+ ((lambda (#{tmp\
9797}#)
+ (if (if #{tmp\
9797}#
+ (apply
(lambda (#{aok\ 9801}#
+
#{a\ 9802}#
+
#{b\ 9803}#)
(if
(eq? (syntax->datum
-
#{aok\ 489}#)
+
#{aok\ 9801}#)
#:allow-other-keys)
(eq? (syntax->datum
-
#{a\ 490}#)
+
#{a\ 9802}#)
#:rest)
#f))
- #{tmp\
488}#)
+ #{tmp\
9797}#)
#f)
- (apply (lambda
(#{aok\ 492}#
-
#{a\ 493}#
-
#{b\ 494}#)
- (#{rest\
439}#
- #{b\
494}#
- #{req\
455}#
- #{opt\
456}#
+ (apply (lambda
(#{aok\ 9809}#
+
#{a\ 9810}#
+
#{b\ 9811}#)
+ (#{rest\
9703}#
+ #{b\
9811}#
+ #{req\
9734}#
+ #{opt\
9735}#
(cons
#t
(reverse
-
#{rkey\ 457}#))))
- #{tmp\
488}#)
- ((lambda (#{tmp\
495}#)
- (if (if #{tmp\
495}#
- (apply
(lambda (#{aok\ 496}#
-
#{r\ 497}#)
+
#{rkey\ 9736}#))))
+ #{tmp\
9797}#)
+ ((lambda (#{tmp\
9812}#)
+ (if (if #{tmp\
9812}#
+ (apply
(lambda (#{aok\ 9815}#
+
#{r\ 9816}#)
(if (eq? (syntax->datum
-
#{aok\ 496}#)
+
#{aok\ 9815}#)
#:allow-other-keys)
-
(#{id?\ 131}#
-
#{r\ 497}#)
+
(#{id?\ 9076}#
+
#{r\ 9816}#)
#f))
-
#{tmp\ 495}#)
+
#{tmp\ 9812}#)
#f)
- (apply
(lambda (#{aok\ 498}#
-
#{r\ 499}#)
-
(#{rest\ 439}#
-
#{r\ 499}#
-
#{req\ 455}#
-
#{opt\ 456}#
+ (apply
(lambda (#{aok\ 9821}#
+
#{r\ 9822}#)
+
(#{rest\ 9703}#
+
#{r\ 9822}#
+
#{req\ 9734}#
+
#{opt\ 9735}#
(cons #t
(reverse
-
#{rkey\ 457}#))))
-
#{tmp\ 495}#)
- ((lambda
(#{tmp\ 500}#)
- (if (if
#{tmp\ 500}#
-
(apply (lambda (#{a\ 501}#
-
#{b\ 502}#)
+
#{rkey\ 9736}#))))
+
#{tmp\ 9812}#)
+ ((lambda
(#{tmp\ 9823}#)
+ (if (if
#{tmp\ 9823}#
+
(apply (lambda (#{a\ 9826}#
+
#{b\ 9827}#)
(eq? (syntax->datum
-
#{a\ 501}#)
+
#{a\ 9826}#)
#:rest))
-
#{tmp\ 500}#)
+
#{tmp\ 9823}#)
#f)
- (apply
(lambda (#{a\ 503}#
-
#{b\ 504}#)
-
(#{rest\ 439}#
-
#{b\ 504}#
-
#{req\ 455}#
-
#{opt\ 456}#
+ (apply
(lambda (#{a\ 9830}#
+
#{b\ 9831}#)
+
(#{rest\ 9703}#
+
#{b\ 9831}#
+
#{req\ 9734}#
+
#{opt\ 9735}#
(cons #f
(reverse
-
#{rkey\ 457}#))))
-
#{tmp\ 500}#)
-
((lambda (#{tmp\ 505}#)
- (if
(if #{tmp\ 505}#
-
(apply (lambda (#{r\ 506}#)
-
(#{id?\ 131}#
-
#{r\ 506}#))
-
#{tmp\ 505}#)
+
#{rkey\ 9736}#))))
+
#{tmp\ 9823}#)
+
((lambda (#{tmp\ 9832}#)
+ (if
(if #{tmp\ 9832}#
+
(apply (lambda (#{r\ 9834}#)
+
(#{id?\ 9076}#
+
#{r\ 9834}#))
+
#{tmp\ 9832}#)
#f)
-
(apply (lambda (#{r\ 507}#)
-
(#{rest\ 439}#
-
#{r\ 507}#
-
#{req\ 455}#
-
#{opt\ 456}#
+
(apply (lambda (#{r\ 9836}#)
+
(#{rest\ 9703}#
+
#{r\ 9836}#
+
#{req\ 9734}#
+
#{opt\ 9735}#
(cons #f
(reverse
-
#{rkey\ 457}#))))
-
#{tmp\ 505}#)
-
((lambda (#{else\ 508}#)
+
#{rkey\ 9736}#))))
+
#{tmp\ 9832}#)
+
((lambda (#{else\ 9838}#)
(syntax-violation
'lambda*
"invalid keyword argument list"
-
#{orig-args\ 435}#
-
#{args\ 454}#))
-
#{tmp\ 458}#)))
- (list
#{tmp\ 458}#))))
+
#{orig-args\ 9694}#
+
#{args\ 9733}#))
+
#{tmp\ 9741}#)))
+ (list
#{tmp\ 9741}#))))
($sc-dispatch
- #{tmp\
458}#
+ #{tmp\
9741}#
'(any
any)))))
($sc-dispatch
- #{tmp\ 458}#
+ #{tmp\ 9741}#
'(any .
any)))))
($sc-dispatch
- #{tmp\ 458}#
+ #{tmp\ 9741}#
'(any any any)))))
($sc-dispatch
- #{tmp\ 458}#
+ #{tmp\ 9741}#
'(any)))))
($sc-dispatch
- #{tmp\ 458}#
+ #{tmp\ 9741}#
'((any any any) . any)))))
($sc-dispatch
- #{tmp\ 458}#
+ #{tmp\ 9741}#
'((any any) . any)))))
($sc-dispatch
- #{tmp\ 458}#
+ #{tmp\ 9741}#
'(any . any)))))
- ($sc-dispatch #{tmp\ 458}# (quote ()))))
- #{args\ 454}#)))
- (#{opt\ 437}#
- (lambda (#{args\ 509}# #{req\ 510}# #{ropt\ 511}#)
- ((lambda (#{tmp\ 512}#)
- ((lambda (#{tmp\ 513}#)
- (if #{tmp\ 513}#
+ ($sc-dispatch #{tmp\ 9741}# (quote ()))))
+ #{args\ 9733}#)))
+ (#{opt\ 9699}#
+ (lambda (#{args\ 9839}# #{req\ 9840}# #{ropt\ 9841}#)
+ ((lambda (#{tmp\ 9845}#)
+ ((lambda (#{tmp\ 9846}#)
+ (if #{tmp\ 9846}#
(apply (lambda ()
- (#{check\ 440}#
- #{req\ 510}#
- (reverse #{ropt\ 511}#)
+ (#{check\ 9705}#
+ #{req\ 9840}#
+ (reverse #{ropt\ 9841}#)
#f
'()))
- #{tmp\ 513}#)
- ((lambda (#{tmp\ 514}#)
- (if (if #{tmp\ 514}#
- (apply (lambda (#{a\ 515}#
- #{b\ 516}#)
- (#{id?\ 131}#
- #{a\ 515}#))
- #{tmp\ 514}#)
+ #{tmp\ 9846}#)
+ ((lambda (#{tmp\ 9847}#)
+ (if (if #{tmp\ 9847}#
+ (apply (lambda (#{a\ 9850}#
+ #{b\ 9851}#)
+ (#{id?\ 9076}#
+ #{a\ 9850}#))
+ #{tmp\ 9847}#)
#f)
- (apply (lambda (#{a\ 517}# #{b\ 518}#)
- (#{opt\ 437}#
- #{b\ 518}#
- #{req\ 510}#
- (cons (cons #{a\ 517}#
+ (apply (lambda (#{a\ 9854}#
+ #{b\ 9855}#)
+ (#{opt\ 9699}#
+ #{b\ 9855}#
+ #{req\ 9840}#
+ (cons (cons #{a\ 9854}#
'(#(syntax-object
#f
((top)
@@ -1225,8 +1263,8 @@
#(a b)
#((top)
(top))
- #("i"
- "i"))
+
#("i9852"
+
"i9853"))
#(ribcage
()
()
@@ -1238,9 +1276,9 @@
#((top)
(top)
(top))
- #("i"
- "i"
- "i"))
+
#("i9842"
+
"i9843"
+
"i9844"))
#(ribcage
(check
rest
key
@@ -1251,15 +1289,15 @@
(top)
(top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9704"
+ "i9702"
+ "i9700"
+ "i9698"
+
"i9696"))
#(ribcage
#(orig-args)
#((top))
- #("i"))
+
#("i9695"))
#(ribcage
(lambda-var-list
gen-var
@@ -1363,6 +1401,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+
build-dynlet
build-conditional
build-application
build-void
@@ -1494,461 +1533,465 @@
(top)
(top)
(top)
+ (top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+
"i8972"))
#(ribcage
(define-structure
and-map*)
((top)
(top))
- ("i"
- "i")))
+ ("i8875"
+
"i8873")))
(hygiene
guile))))
- #{ropt\ 511}#)))
- #{tmp\ 514}#)
- ((lambda (#{tmp\ 519}#)
- (if (if #{tmp\ 519}#
- (apply (lambda (#{a\ 520}#
- #{init\ 521}#
- #{b\ 522}#)
- (#{id?\ 131}#
- #{a\ 520}#))
- #{tmp\ 519}#)
+ #{ropt\ 9841}#)))
+ #{tmp\ 9847}#)
+ ((lambda (#{tmp\ 9856}#)
+ (if (if #{tmp\ 9856}#
+ (apply (lambda (#{a\ 9860}#
+ #{init\
9861}#
+ #{b\ 9862}#)
+ (#{id?\ 9076}#
+ #{a\ 9860}#))
+ #{tmp\ 9856}#)
#f)
- (apply (lambda (#{a\ 523}#
- #{init\ 524}#
- #{b\ 525}#)
- (#{opt\ 437}#
- #{b\ 525}#
- #{req\ 510}#
- (cons (list #{a\ 523}#
- #{init\
524}#)
- #{ropt\ 511}#)))
- #{tmp\ 519}#)
- ((lambda (#{tmp\ 526}#)
- (if (if #{tmp\ 526}#
- (apply (lambda (#{a\
527}#
- #{b\
528}#)
+ (apply (lambda (#{a\ 9866}#
+ #{init\ 9867}#
+ #{b\ 9868}#)
+ (#{opt\ 9699}#
+ #{b\ 9868}#
+ #{req\ 9840}#
+ (cons (list #{a\
9866}#
+ #{init\
9867}#)
+ #{ropt\
9841}#)))
+ #{tmp\ 9856}#)
+ ((lambda (#{tmp\ 9869}#)
+ (if (if #{tmp\ 9869}#
+ (apply (lambda (#{a\
9872}#
+ #{b\
9873}#)
(eq?
(syntax->datum
- #{a\
527}#)
+ #{a\
9872}#)
#:key))
- #{tmp\ 526}#)
+ #{tmp\ 9869}#)
#f)
- (apply (lambda (#{a\ 529}#
- #{b\ 530}#)
- (#{key\ 438}#
- #{b\ 530}#
- #{req\ 510}#
+ (apply (lambda (#{a\ 9876}#
+ #{b\ 9877}#)
+ (#{key\ 9701}#
+ #{b\ 9877}#
+ #{req\ 9840}#
(reverse
- #{ropt\ 511}#)
+ #{ropt\ 9841}#)
'()))
- #{tmp\ 526}#)
- ((lambda (#{tmp\ 531}#)
- (if (if #{tmp\ 531}#
- (apply (lambda
(#{a\ 532}#
-
#{b\ 533}#)
+ #{tmp\ 9869}#)
+ ((lambda (#{tmp\ 9878}#)
+ (if (if #{tmp\ 9878}#
+ (apply (lambda
(#{a\ 9881}#
+
#{b\ 9882}#)
(eq?
(syntax->datum
-
#{a\ 532}#)
+
#{a\ 9881}#)
#:rest))
- #{tmp\
531}#)
+ #{tmp\
9878}#)
#f)
- (apply (lambda (#{a\
534}#
- #{b\
535}#)
- (#{rest\ 439}#
- #{b\ 535}#
- #{req\ 510}#
+ (apply (lambda (#{a\
9885}#
+ #{b\
9886}#)
+ (#{rest\
9703}#
+ #{b\ 9886}#
+ #{req\
9840}#
(reverse
- #{ropt\
511}#)
+ #{ropt\
9841}#)
'()))
- #{tmp\ 531}#)
- ((lambda (#{tmp\ 536}#)
- (if (if #{tmp\ 536}#
- (apply
(lambda (#{r\ 537}#)
-
(#{id?\ 131}#
-
#{r\ 537}#))
- #{tmp\
536}#)
+ #{tmp\ 9878}#)
+ ((lambda (#{tmp\
9887}#)
+ (if (if #{tmp\
9887}#
+ (apply
(lambda (#{r\ 9889}#)
+
(#{id?\ 9076}#
+
#{r\ 9889}#))
+ #{tmp\
9887}#)
#f)
- (apply (lambda
(#{r\ 538}#)
- (#{rest\
439}#
- #{r\
538}#
- #{req\
510}#
+ (apply (lambda
(#{r\ 9891}#)
+ (#{rest\
9703}#
+ #{r\
9891}#
+ #{req\
9840}#
(reverse
-
#{ropt\ 511}#)
+
#{ropt\ 9841}#)
'()))
- #{tmp\
536}#)
- ((lambda (#{else\
539}#)
+ #{tmp\
9887}#)
+ ((lambda (#{else\
9893}#)
(syntax-violation
'lambda*
"invalid
optional argument list"
- #{orig-args\
435}#
- #{args\
509}#))
- #{tmp\ 512}#)))
- (list #{tmp\ 512}#))))
+ #{orig-args\
9694}#
+ #{args\
9839}#))
+ #{tmp\ 9845}#)))
+ (list #{tmp\
9845}#))))
($sc-dispatch
- #{tmp\ 512}#
+ #{tmp\ 9845}#
'(any any)))))
($sc-dispatch
- #{tmp\ 512}#
+ #{tmp\ 9845}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 512}#
+ #{tmp\ 9845}#
'((any any) . any)))))
($sc-dispatch
- #{tmp\ 512}#
+ #{tmp\ 9845}#
'(any . any)))))
- ($sc-dispatch #{tmp\ 512}# (quote ()))))
- #{args\ 509}#)))
- (#{req\ 436}#
- (lambda (#{args\ 540}# #{rreq\ 541}#)
- ((lambda (#{tmp\ 542}#)
- ((lambda (#{tmp\ 543}#)
- (if #{tmp\ 543}#
+ ($sc-dispatch #{tmp\ 9845}# (quote ()))))
+ #{args\ 9839}#)))
+ (#{req\ 9697}#
+ (lambda (#{args\ 9894}# #{rreq\ 9895}#)
+ ((lambda (#{tmp\ 9898}#)
+ ((lambda (#{tmp\ 9899}#)
+ (if #{tmp\ 9899}#
(apply (lambda ()
- (#{check\ 440}#
- (reverse #{rreq\ 541}#)
+ (#{check\ 9705}#
+ (reverse #{rreq\ 9895}#)
'()
#f
'()))
- #{tmp\ 543}#)
- ((lambda (#{tmp\ 544}#)
- (if (if #{tmp\ 544}#
- (apply (lambda (#{a\ 545}#
- #{b\ 546}#)
- (#{id?\ 131}#
- #{a\ 545}#))
- #{tmp\ 544}#)
+ #{tmp\ 9899}#)
+ ((lambda (#{tmp\ 9900}#)
+ (if (if #{tmp\ 9900}#
+ (apply (lambda (#{a\ 9903}#
+ #{b\ 9904}#)
+ (#{id?\ 9076}#
+ #{a\ 9903}#))
+ #{tmp\ 9900}#)
#f)
- (apply (lambda (#{a\ 547}# #{b\ 548}#)
- (#{req\ 436}#
- #{b\ 548}#
- (cons #{a\ 547}#
- #{rreq\ 541}#)))
- #{tmp\ 544}#)
- ((lambda (#{tmp\ 549}#)
- (if (if #{tmp\ 549}#
- (apply (lambda (#{a\ 550}#
- #{b\ 551}#)
+ (apply (lambda (#{a\ 9907}#
+ #{b\ 9908}#)
+ (#{req\ 9697}#
+ #{b\ 9908}#
+ (cons #{a\ 9907}#
+ #{rreq\ 9895}#)))
+ #{tmp\ 9900}#)
+ ((lambda (#{tmp\ 9909}#)
+ (if (if #{tmp\ 9909}#
+ (apply (lambda (#{a\ 9912}#
+ #{b\ 9913}#)
(eq? (syntax->datum
- #{a\ 550}#)
+ #{a\ 9912}#)
#:optional))
- #{tmp\ 549}#)
+ #{tmp\ 9909}#)
#f)
- (apply (lambda (#{a\ 552}#
- #{b\ 553}#)
- (#{opt\ 437}#
- #{b\ 553}#
+ (apply (lambda (#{a\ 9916}#
+ #{b\ 9917}#)
+ (#{opt\ 9699}#
+ #{b\ 9917}#
(reverse
- #{rreq\ 541}#)
+ #{rreq\ 9895}#)
'()))
- #{tmp\ 549}#)
- ((lambda (#{tmp\ 554}#)
- (if (if #{tmp\ 554}#
- (apply (lambda (#{a\
555}#
- #{b\
556}#)
+ #{tmp\ 9909}#)
+ ((lambda (#{tmp\ 9918}#)
+ (if (if #{tmp\ 9918}#
+ (apply (lambda (#{a\
9921}#
+ #{b\
9922}#)
(eq?
(syntax->datum
- #{a\
555}#)
+ #{a\
9921}#)
#:key))
- #{tmp\ 554}#)
+ #{tmp\ 9918}#)
#f)
- (apply (lambda (#{a\ 557}#
- #{b\ 558}#)
- (#{key\ 438}#
- #{b\ 558}#
+ (apply (lambda (#{a\ 9925}#
+ #{b\ 9926}#)
+ (#{key\ 9701}#
+ #{b\ 9926}#
(reverse
- #{rreq\ 541}#)
+ #{rreq\ 9895}#)
'()
'()))
- #{tmp\ 554}#)
- ((lambda (#{tmp\ 559}#)
- (if (if #{tmp\ 559}#
- (apply (lambda
(#{a\ 560}#
-
#{b\ 561}#)
+ #{tmp\ 9918}#)
+ ((lambda (#{tmp\ 9927}#)
+ (if (if #{tmp\ 9927}#
+ (apply (lambda
(#{a\ 9930}#
+
#{b\ 9931}#)
(eq?
(syntax->datum
-
#{a\ 560}#)
+
#{a\ 9930}#)
#:rest))
- #{tmp\
559}#)
+ #{tmp\
9927}#)
#f)
- (apply (lambda (#{a\
562}#
- #{b\
563}#)
- (#{rest\ 439}#
- #{b\ 563}#
+ (apply (lambda (#{a\
9934}#
+ #{b\
9935}#)
+ (#{rest\
9703}#
+ #{b\ 9935}#
(reverse
- #{rreq\
541}#)
+ #{rreq\
9895}#)
'()
'()))
- #{tmp\ 559}#)
- ((lambda (#{tmp\ 564}#)
- (if (if #{tmp\ 564}#
- (apply
(lambda (#{r\ 565}#)
-
(#{id?\ 131}#
-
#{r\ 565}#))
- #{tmp\
564}#)
+ #{tmp\ 9927}#)
+ ((lambda (#{tmp\
9936}#)
+ (if (if #{tmp\
9936}#
+ (apply
(lambda (#{r\ 9938}#)
+
(#{id?\ 9076}#
+
#{r\ 9938}#))
+ #{tmp\
9936}#)
#f)
- (apply (lambda
(#{r\ 566}#)
- (#{rest\
439}#
- #{r\
566}#
+ (apply (lambda
(#{r\ 9940}#)
+ (#{rest\
9703}#
+ #{r\
9940}#
(reverse
-
#{rreq\ 541}#)
+
#{rreq\ 9895}#)
'()
'()))
- #{tmp\
564}#)
- ((lambda (#{else\
567}#)
+ #{tmp\
9936}#)
+ ((lambda (#{else\
9942}#)
(syntax-violation
'lambda*
"invalid
argument list"
- #{orig-args\
435}#
- #{args\
540}#))
- #{tmp\ 542}#)))
- (list #{tmp\ 542}#))))
+ #{orig-args\
9694}#
+ #{args\
9894}#))
+ #{tmp\ 9898}#)))
+ (list #{tmp\
9898}#))))
($sc-dispatch
- #{tmp\ 542}#
+ #{tmp\ 9898}#
'(any any)))))
($sc-dispatch
- #{tmp\ 542}#
+ #{tmp\ 9898}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 542}#
+ #{tmp\ 9898}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 542}#
+ #{tmp\ 9898}#
'(any . any)))))
- ($sc-dispatch #{tmp\ 542}# (quote ()))))
- #{args\ 540}#))))
- (#{req\ 436}# #{orig-args\ 435}# (quote ())))))
- (#{chi-simple-lambda\ 177}#
- (lambda (#{e\ 568}#
- #{r\ 569}#
- #{w\ 570}#
- #{s\ 571}#
- #{mod\ 572}#
- #{req\ 573}#
- #{rest\ 574}#
- #{docstring\ 575}#
- #{body\ 576}#)
- (let ((#{ids\ 577}#
- (if #{rest\ 574}#
- (append #{req\ 573}# (list #{rest\ 574}#))
- #{req\ 573}#)))
- (let ((#{vars\ 578}#
- (map #{gen-var\ 181}# #{ids\ 577}#)))
- (let ((#{labels\ 579}#
- (#{gen-labels\ 137}# #{ids\ 577}#)))
- (#{build-simple-lambda\ 105}#
- #{s\ 571}#
- (map syntax->datum #{req\ 573}#)
- (if #{rest\ 574}#
- (syntax->datum #{rest\ 574}#)
+ ($sc-dispatch #{tmp\ 9898}# (quote ()))))
+ #{args\ 9894}#))))
+ (#{req\ 9697}# #{orig-args\ 9694}# (quote ())))))
+ (#{chi-simple-lambda\ 9181}#
+ (lambda (#{e\ 9943}#
+ #{r\ 9944}#
+ #{w\ 9945}#
+ #{s\ 9946}#
+ #{mod\ 9947}#
+ #{req\ 9948}#
+ #{rest\ 9949}#
+ #{meta\ 9950}#
+ #{body\ 9951}#)
+ (let ((#{ids\ 9963}#
+ (if #{rest\ 9949}#
+ (append #{req\ 9948}# (list #{rest\ 9949}#))
+ #{req\ 9948}#)))
+ (let ((#{vars\ 9965}#
+ (map #{gen-var\ 9189}# #{ids\ 9963}#)))
+ (let ((#{labels\ 9967}#
+ (#{gen-labels\ 9094}# #{ids\ 9963}#)))
+ (#{build-simple-lambda\ 9018}#
+ #{s\ 9946}#
+ (map syntax->datum #{req\ 9948}#)
+ (if #{rest\ 9949}#
+ (syntax->datum #{rest\ 9949}#)
#f)
- #{vars\ 578}#
- #{docstring\ 575}#
- (#{chi-body\ 171}#
- #{body\ 576}#
- (#{source-wrap\ 160}#
- #{e\ 568}#
- #{w\ 570}#
- #{s\ 571}#
- #{mod\ 572}#)
- (#{extend-var-env\ 126}#
- #{labels\ 579}#
- #{vars\ 578}#
- #{r\ 569}#)
- (#{make-binding-wrap\ 148}#
- #{ids\ 577}#
- #{labels\ 579}#
- #{w\ 570}#)
- #{mod\ 572}#)))))))
- (#{lambda-formals\ 176}#
- (lambda (#{orig-args\ 580}#)
- (letrec ((#{check\ 582}#
- (lambda (#{req\ 583}# #{rest\ 584}#)
- (if (#{distinct-bound-ids?\ 157}#
- (if #{rest\ 584}#
- (cons #{rest\ 584}# #{req\ 583}#)
- #{req\ 583}#))
- (values #{req\ 583}# #f #{rest\ 584}# #f)
+ #{vars\ 9965}#
+ #{meta\ 9950}#
+ (#{chi-body\ 9169}#
+ #{body\ 9951}#
+ (#{source-wrap\ 9147}#
+ #{e\ 9943}#
+ #{w\ 9945}#
+ #{s\ 9946}#
+ #{mod\ 9947}#)
+ (#{extend-var-env\ 9066}#
+ #{labels\ 9967}#
+ #{vars\ 9965}#
+ #{r\ 9944}#)
+ (#{make-binding-wrap\ 9123}#
+ #{ids\ 9963}#
+ #{labels\ 9967}#
+ #{w\ 9945}#)
+ #{mod\ 9947}#)))))))
+ (#{lambda-formals\ 9179}#
+ (lambda (#{orig-args\ 9970}#)
+ (letrec ((#{check\ 9975}#
+ (lambda (#{req\ 9976}# #{rest\ 9977}#)
+ (if (#{distinct-bound-ids?\ 9141}#
+ (if #{rest\ 9977}#
+ (cons #{rest\ 9977}# #{req\ 9976}#)
+ #{req\ 9976}#))
+ (values #{req\ 9976}# #f #{rest\ 9977}# #f)
(syntax-violation
'lambda
"duplicate identifier in argument list"
- #{orig-args\ 580}#))))
- (#{req\ 581}#
- (lambda (#{args\ 585}# #{rreq\ 586}#)
- ((lambda (#{tmp\ 587}#)
- ((lambda (#{tmp\ 588}#)
- (if #{tmp\ 588}#
+ #{orig-args\ 9970}#))))
+ (#{req\ 9973}#
+ (lambda (#{args\ 9983}# #{rreq\ 9984}#)
+ ((lambda (#{tmp\ 9987}#)
+ ((lambda (#{tmp\ 9988}#)
+ (if #{tmp\ 9988}#
(apply (lambda ()
- (#{check\ 582}#
- (reverse #{rreq\ 586}#)
+ (#{check\ 9975}#
+ (reverse #{rreq\ 9984}#)
#f))
- #{tmp\ 588}#)
- ((lambda (#{tmp\ 589}#)
- (if (if #{tmp\ 589}#
- (apply (lambda (#{a\ 590}#
- #{b\ 591}#)
- (#{id?\ 131}#
- #{a\ 590}#))
- #{tmp\ 589}#)
+ #{tmp\ 9988}#)
+ ((lambda (#{tmp\ 9989}#)
+ (if (if #{tmp\ 9989}#
+ (apply (lambda (#{a\ 9992}#
+ #{b\ 9993}#)
+ (#{id?\ 9076}#
+ #{a\ 9992}#))
+ #{tmp\ 9989}#)
#f)
- (apply (lambda (#{a\ 592}# #{b\ 593}#)
- (#{req\ 581}#
- #{b\ 593}#
- (cons #{a\ 592}#
- #{rreq\ 586}#)))
- #{tmp\ 589}#)
- ((lambda (#{tmp\ 594}#)
- (if (if #{tmp\ 594}#
- (apply (lambda (#{r\ 595}#)
- (#{id?\ 131}#
- #{r\ 595}#))
- #{tmp\ 594}#)
+ (apply (lambda (#{a\ 9996}#
+ #{b\ 9997}#)
+ (#{req\ 9973}#
+ #{b\ 9997}#
+ (cons #{a\ 9996}#
+ #{rreq\ 9984}#)))
+ #{tmp\ 9989}#)
+ ((lambda (#{tmp\ 9998}#)
+ (if (if #{tmp\ 9998}#
+ (apply (lambda (#{r\ 10000}#)
+ (#{id?\ 9076}#
+ #{r\ 10000}#))
+ #{tmp\ 9998}#)
#f)
- (apply (lambda (#{r\ 596}#)
- (#{check\ 582}#
+ (apply (lambda (#{r\ 10002}#)
+ (#{check\ 9975}#
(reverse
- #{rreq\ 586}#)
- #{r\ 596}#))
- #{tmp\ 594}#)
- ((lambda (#{else\ 597}#)
+ #{rreq\ 9984}#)
+ #{r\ 10002}#))
+ #{tmp\ 9998}#)
+ ((lambda (#{else\ 10004}#)
(syntax-violation
'lambda
"invalid argument list"
- #{orig-args\ 580}#
- #{args\ 585}#))
- #{tmp\ 587}#)))
- (list #{tmp\ 587}#))))
+ #{orig-args\ 9970}#
+ #{args\ 9983}#))
+ #{tmp\ 9987}#)))
+ (list #{tmp\ 9987}#))))
($sc-dispatch
- #{tmp\ 587}#
+ #{tmp\ 9987}#
'(any . any)))))
- ($sc-dispatch #{tmp\ 587}# (quote ()))))
- #{args\ 585}#))))
- (#{req\ 581}# #{orig-args\ 580}# (quote ())))))
- (#{ellipsis?\ 175}#
- (lambda (#{x\ 598}#)
- (if (#{nonsymbol-id?\ 130}# #{x\ 598}#)
- (#{free-id=?\ 154}#
- #{x\ 598}#
+ ($sc-dispatch #{tmp\ 9987}# (quote ()))))
+ #{args\ 9983}#))))
+ (#{req\ 9973}# #{orig-args\ 9970}# (quote ())))))
+ (#{ellipsis?\ 9177}#
+ (lambda (#{x\ 10005}#)
+ (if (#{nonsymbol-id?\ 9074}# #{x\ 10005}#)
+ (#{free-id=?\ 9135}#
+ #{x\ 10005}#
'#(syntax-object
...
((top)
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
+ #(ribcage #(x) #((top)) #("i10006"))
#(ribcage
(lambda-var-list
gen-var
@@ -2052,6 +2095,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+ build-dynlet
build-conditional
build-application
build-void
@@ -2183,1344 +2227,1375 @@
(top)
(top)
(top)
+ (top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
#(ribcage
(define-structure and-map*)
((top) (top))
- ("i" "i")))
+ ("i8875" "i8873")))
(hygiene guile)))
#f)))
- (#{chi-void\ 174}#
- (lambda () (#{build-void\ 95}# #f)))
- (#{eval-local-transformer\ 173}#
- (lambda (#{expanded\ 599}# #{mod\ 600}#)
- (let ((#{p\ 601}# (#{local-eval-hook\ 91}#
- #{expanded\ 599}#
- #{mod\ 600}#)))
- (if (procedure? #{p\ 601}#)
- (cons #{p\ 601}# (module-name (current-module)))
+ (#{chi-void\ 9175}#
+ (lambda () (#{build-void\ 8996}# #f)))
+ (#{eval-local-transformer\ 9173}#
+ (lambda (#{expanded\ 10010}# #{mod\ 10011}#)
+ (let ((#{p\ 10015}#
+ (#{local-eval-hook\ 8987}#
+ #{expanded\ 10010}#
+ #{mod\ 10011}#)))
+ (if (procedure? #{p\ 10015}#)
+ (cons #{p\ 10015}#
+ (module-name (current-module)))
(syntax-violation
#f
"nonprocedure transformer"
- #{p\ 601}#)))))
- (#{chi-local-syntax\ 172}#
- (lambda (#{rec?\ 602}#
- #{e\ 603}#
- #{r\ 604}#
- #{w\ 605}#
- #{s\ 606}#
- #{mod\ 607}#
- #{k\ 608}#)
- ((lambda (#{tmp\ 609}#)
- ((lambda (#{tmp\ 610}#)
- (if #{tmp\ 610}#
- (apply (lambda (#{_\ 611}#
- #{id\ 612}#
- #{val\ 613}#
- #{e1\ 614}#
- #{e2\ 615}#)
- (let ((#{ids\ 616}# #{id\ 612}#))
- (if (not (#{valid-bound-ids?\ 156}#
- #{ids\ 616}#))
+ #{p\ 10015}#)))))
+ (#{chi-local-syntax\ 9171}#
+ (lambda (#{rec?\ 10016}#
+ #{e\ 10017}#
+ #{r\ 10018}#
+ #{w\ 10019}#
+ #{s\ 10020}#
+ #{mod\ 10021}#
+ #{k\ 10022}#)
+ ((lambda (#{tmp\ 10030}#)
+ ((lambda (#{tmp\ 10031}#)
+ (if #{tmp\ 10031}#
+ (apply (lambda (#{_\ 10037}#
+ #{id\ 10038}#
+ #{val\ 10039}#
+ #{e1\ 10040}#
+ #{e2\ 10041}#)
+ (let ((#{ids\ 10043}# #{id\ 10038}#))
+ (if (not (#{valid-bound-ids?\ 9139}#
+ #{ids\ 10043}#))
(syntax-violation
#f
"duplicate bound keyword"
- #{e\ 603}#)
- (let ((#{labels\ 618}#
- (#{gen-labels\ 137}#
- #{ids\ 616}#)))
- (let ((#{new-w\ 619}#
- (#{make-binding-wrap\ 148}#
- #{ids\ 616}#
- #{labels\ 618}#
- #{w\ 605}#)))
- (#{k\ 608}# (cons #{e1\ 614}#
- #{e2\ 615}#)
- (#{extend-env\ 125}#
- #{labels\ 618}#
- (let ((#{w\ 621}# (if
#{rec?\ 602}#
-
#{new-w\ 619}#
- #{w\
605}#))
- (#{trans-r\ 622}#
-
(#{macros-only-env\ 127}#
- #{r\ 604}#)))
- (map (lambda (#{x\
623}#)
- (cons 'macro
-
(#{eval-local-transformer\ 173}#
- (#{chi\
167}#
- #{x\
623}#
-
#{trans-r\ 622}#
- #{w\
621}#
-
#{mod\ 607}#)
- #{mod\
607}#)))
- #{val\ 613}#))
- #{r\ 604}#)
- #{new-w\ 619}#
- #{s\ 606}#
- #{mod\ 607}#))))))
- #{tmp\ 610}#)
- ((lambda (#{_\ 625}#)
+ #{e\ 10017}#)
+ (let ((#{labels\ 10046}#
+ (#{gen-labels\ 9094}#
+ #{ids\ 10043}#)))
+ (let ((#{new-w\ 10048}#
+ (#{make-binding-wrap\ 9123}#
+ #{ids\ 10043}#
+ #{labels\ 10046}#
+ #{w\ 10019}#)))
+ (#{k\ 10022}#
+ (cons #{e1\ 10040}# #{e2\ 10041}#)
+ (#{extend-env\ 9064}#
+ #{labels\ 10046}#
+ (let ((#{w\ 10052}#
+ (if #{rec?\ 10016}#
+ #{new-w\ 10048}#
+ #{w\ 10019}#))
+ (#{trans-r\ 10053}#
+ (#{macros-only-env\ 9068}#
+ #{r\ 10018}#)))
+ (map (lambda (#{x\ 10054}#)
+ (cons 'macro
+
(#{eval-local-transformer\ 9173}#
+ (#{chi\ 9161}#
+ #{x\ 10054}#
+ #{trans-r\
10053}#
+ #{w\ 10052}#
+ #{mod\ 10021}#)
+ #{mod\ 10021}#)))
+ #{val\ 10039}#))
+ #{r\ 10018}#)
+ #{new-w\ 10048}#
+ #{s\ 10020}#
+ #{mod\ 10021}#))))))
+ #{tmp\ 10031}#)
+ ((lambda (#{_\ 10059}#)
(syntax-violation
#f
"bad local syntax definition"
- (#{source-wrap\ 160}#
- #{e\ 603}#
- #{w\ 605}#
- #{s\ 606}#
- #{mod\ 607}#)))
- #{tmp\ 609}#)))
+ (#{source-wrap\ 9147}#
+ #{e\ 10017}#
+ #{w\ 10019}#
+ #{s\ 10020}#
+ #{mod\ 10021}#)))
+ #{tmp\ 10030}#)))
($sc-dispatch
- #{tmp\ 609}#
+ #{tmp\ 10030}#
'(any #(each (any any)) any . each-any))))
- #{e\ 603}#)))
- (#{chi-body\ 171}#
- (lambda (#{body\ 626}#
- #{outer-form\ 627}#
- #{r\ 628}#
- #{w\ 629}#
- #{mod\ 630}#)
- (let ((#{r\ 631}# (cons '("placeholder" placeholder)
- #{r\ 628}#)))
- (let ((#{ribcage\ 632}#
- (#{make-ribcage\ 138}#
+ #{e\ 10017}#)))
+ (#{chi-body\ 9169}#
+ (lambda (#{body\ 10060}#
+ #{outer-form\ 10061}#
+ #{r\ 10062}#
+ #{w\ 10063}#
+ #{mod\ 10064}#)
+ (let ((#{r\ 10072}#
+ (cons '("placeholder" placeholder)
+ #{r\ 10062}#)))
+ (let ((#{ribcage\ 10074}#
+ (#{make-ribcage\ 9097}#
'()
'()
'())))
- (let ((#{w\ 633}# (#{make-wrap\ 133}#
- (#{wrap-marks\ 134}# #{w\ 629}#)
- (cons #{ribcage\ 632}#
- (#{wrap-subst\ 135}#
- #{w\ 629}#)))))
- (letrec ((#{parse\ 634}#
- (lambda (#{body\ 635}#
- #{ids\ 636}#
- #{labels\ 637}#
- #{var-ids\ 638}#
- #{vars\ 639}#
- #{vals\ 640}#
- #{bindings\ 641}#)
- (if (null? #{body\ 635}#)
+ (let ((#{w\ 10077}#
+ (#{make-wrap\ 9081}#
+ (#{wrap-marks\ 9083}# #{w\ 10063}#)
+ (cons #{ribcage\ 10074}#
+ (#{wrap-subst\ 9085}# #{w\ 10063}#)))))
+ (letrec ((#{parse\ 10086}#
+ (lambda (#{body\ 10087}#
+ #{ids\ 10088}#
+ #{labels\ 10089}#
+ #{var-ids\ 10090}#
+ #{vars\ 10091}#
+ #{vals\ 10092}#
+ #{bindings\ 10093}#)
+ (if (null? #{body\ 10087}#)
(syntax-violation
#f
"no expressions in body"
- #{outer-form\ 627}#)
- (let ((#{e\ 643}# (cdar #{body\ 635}#))
- (#{er\ 644}# (caar #{body\ 635}#)))
+ #{outer-form\ 10061}#)
+ (let ((#{e\ 10098}# (cdar #{body\ 10087}#))
+ (#{er\ 10099}#
+ (caar #{body\ 10087}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 165}#
- #{e\ 643}#
- #{er\ 644}#
+ (#{syntax-type\ 9157}#
+ #{e\ 10098}#
+ #{er\ 10099}#
'(())
- (#{source-annotation\ 122}#
- #{er\ 644}#)
- #{ribcage\ 632}#
- #{mod\ 630}#
+ (#{source-annotation\ 9055}#
+ #{er\ 10099}#)
+ #{ribcage\ 10074}#
+ #{mod\ 10064}#
#f))
- (lambda (#{type\ 645}#
- #{value\ 646}#
- #{e\ 647}#
- #{w\ 648}#
- #{s\ 649}#
- #{mod\ 650}#)
- (if (memv #{type\ 645}#
+ (lambda (#{type\ 10101}#
+ #{value\ 10102}#
+ #{e\ 10103}#
+ #{w\ 10104}#
+ #{s\ 10105}#
+ #{mod\ 10106}#)
+ (if (memv #{type\ 10101}#
'(define-form))
- (let ((#{id\ 651}#
- (#{wrap\ 159}#
- #{value\ 646}#
- #{w\ 648}#
- #{mod\ 650}#))
- (#{label\ 652}#
- (#{gen-label\ 136}#)))
- (let ((#{var\ 653}#
- (#{gen-var\ 181}#
- #{id\ 651}#)))
+ (let ((#{id\ 10116}#
+ (#{wrap\ 9145}#
+ #{value\ 10102}#
+ #{w\ 10104}#
+ #{mod\ 10106}#))
+ (#{label\ 10117}#
+ (#{gen-label\ 9092}#)))
+ (let ((#{var\ 10119}#
+ (#{gen-var\ 9189}#
+ #{id\ 10116}#)))
(begin
- (#{extend-ribcage!\ 147}#
- #{ribcage\ 632}#
- #{id\ 651}#
- #{label\ 652}#)
- (#{parse\ 634}#
- (cdr #{body\ 635}#)
- (cons #{id\ 651}#
- #{ids\ 636}#)
- (cons #{label\ 652}#
- #{labels\ 637}#)
- (cons #{id\ 651}#
- #{var-ids\ 638}#)
- (cons #{var\ 653}#
- #{vars\ 639}#)
- (cons (cons #{er\ 644}#
- (#{wrap\ 159}#
- #{e\ 647}#
- #{w\ 648}#
- #{mod\
650}#))
- #{vals\ 640}#)
+ (#{extend-ribcage!\ 9121}#
+ #{ribcage\ 10074}#
+ #{id\ 10116}#
+ #{label\ 10117}#)
+ (#{parse\ 10086}#
+ (cdr #{body\ 10087}#)
+ (cons #{id\ 10116}#
+ #{ids\ 10088}#)
+ (cons #{label\ 10117}#
+ #{labels\ 10089}#)
+ (cons #{id\ 10116}#
+ #{var-ids\ 10090}#)
+ (cons #{var\ 10119}#
+ #{vars\ 10091}#)
+ (cons (cons #{er\ 10099}#
+ (#{wrap\ 9145}#
+ #{e\ 10103}#
+ #{w\ 10104}#
+ #{mod\
10106}#))
+ #{vals\ 10092}#)
(cons (cons 'lexical
- #{var\ 653}#)
- #{bindings\
641}#)))))
- (if (memv #{type\ 645}#
+ #{var\ 10119}#)
+ #{bindings\
10093}#)))))
+ (if (memv #{type\ 10101}#
'(define-syntax-form))
- (let ((#{id\ 654}#
- (#{wrap\ 159}#
- #{value\ 646}#
- #{w\ 648}#
- #{mod\ 650}#))
- (#{label\ 655}#
- (#{gen-label\ 136}#)))
+ (let ((#{id\ 10124}#
+ (#{wrap\ 9145}#
+ #{value\ 10102}#
+ #{w\ 10104}#
+ #{mod\ 10106}#))
+ (#{label\ 10125}#
+ (#{gen-label\ 9092}#)))
(begin
- (#{extend-ribcage!\ 147}#
- #{ribcage\ 632}#
- #{id\ 654}#
- #{label\ 655}#)
- (#{parse\ 634}#
- (cdr #{body\ 635}#)
- (cons #{id\ 654}#
- #{ids\ 636}#)
- (cons #{label\ 655}#
- #{labels\ 637}#)
- #{var-ids\ 638}#
- #{vars\ 639}#
- #{vals\ 640}#
+ (#{extend-ribcage!\ 9121}#
+ #{ribcage\ 10074}#
+ #{id\ 10124}#
+ #{label\ 10125}#)
+ (#{parse\ 10086}#
+ (cdr #{body\ 10087}#)
+ (cons #{id\ 10124}#
+ #{ids\ 10088}#)
+ (cons #{label\ 10125}#
+ #{labels\ 10089}#)
+ #{var-ids\ 10090}#
+ #{vars\ 10091}#
+ #{vals\ 10092}#
(cons (cons 'macro
- (cons #{er\
644}#
- (#{wrap\
159}#
- #{e\
647}#
- #{w\
648}#
- #{mod\
650}#)))
- #{bindings\ 641}#))))
- (if (memv #{type\ 645}#
+ (cons #{er\
10099}#
+ (#{wrap\
9145}#
+ #{e\
10103}#
+ #{w\
10104}#
+ #{mod\
10106}#)))
+ #{bindings\
10093}#))))
+ (if (memv #{type\ 10101}#
'(begin-form))
- ((lambda (#{tmp\ 656}#)
- ((lambda (#{tmp\ 657}#)
- (if #{tmp\ 657}#
- (apply (lambda (#{_\
658}#
- #{e1\
659}#)
- (#{parse\
634}#
- (letrec
((#{f\ 660}# (lambda (#{forms\ 661}#)
-
(if (null? #{forms\ 661}#)
-
(cdr #{body\ 635}#)
-
(cons (cons #{er\ 644}#
-
(#{wrap\ 159}#
-
(car #{forms\ 661}#)
-
#{w\ 648}#
-
#{mod\ 650}#))
-
(#{f\ 660}# (cdr #{forms\ 661}#)))))))
- (#{f\
660}# #{e1\ 659}#))
- #{ids\ 636}#
- #{labels\
637}#
- #{var-ids\
638}#
- #{vars\
639}#
- #{vals\
640}#
- #{bindings\
641}#))
- #{tmp\ 657}#)
+ ((lambda (#{tmp\ 10128}#)
+ ((lambda (#{tmp\ 10129}#)
+ (if #{tmp\ 10129}#
+ (apply (lambda (#{_\
10132}#
+ #{e1\
10133}#)
+ (#{parse\
10086}#
+ (letrec
((#{f\ 10136}#
+
(lambda (#{forms\ 10137}#)
+
(if (null? #{forms\ 10137}#)
+
(cdr #{body\ 10087}#)
+
(cons (cons #{er\ 10099}#
+
(#{wrap\ 9145}#
+
(car #{forms\ 10137}#)
+
#{w\ 10104}#
+
#{mod\ 10106}#))
+
(#{f\ 10136}#
+
(cdr #{forms\ 10137}#)))))))
+ (#{f\
10136}#
+ #{e1\
10133}#))
+ #{ids\
10088}#
+ #{labels\
10089}#
+ #{var-ids\
10090}#
+ #{vars\
10091}#
+ #{vals\
10092}#
+ #{bindings\
10093}#))
+ #{tmp\ 10129}#)
(syntax-violation
#f
"source expression
failed to match any pattern"
- #{tmp\ 656}#)))
+ #{tmp\ 10128}#)))
($sc-dispatch
- #{tmp\ 656}#
+ #{tmp\ 10128}#
'(any . each-any))))
- #{e\ 647}#)
- (if (memv #{type\ 645}#
+ #{e\ 10103}#)
+ (if (memv #{type\ 10101}#
'(local-syntax-form))
- (#{chi-local-syntax\ 172}#
- #{value\ 646}#
- #{e\ 647}#
- #{er\ 644}#
- #{w\ 648}#
- #{s\ 649}#
- #{mod\ 650}#
- (lambda (#{forms\ 663}#
- #{er\ 664}#
- #{w\ 665}#
- #{s\ 666}#
- #{mod\ 667}#)
- (#{parse\ 634}#
- (letrec ((#{f\ 668}#
(lambda (#{forms\ 669}#)
-
(if (null? #{forms\ 669}#)
-
(cdr #{body\ 635}#)
-
(cons (cons #{er\ 664}#
-
(#{wrap\ 159}#
-
(car #{forms\ 669}#)
-
#{w\ 665}#
-
#{mod\ 667}#))
-
(#{f\ 668}# (cdr #{forms\ 669}#)))))))
- (#{f\ 668}# #{forms\
663}#))
- #{ids\ 636}#
- #{labels\ 637}#
- #{var-ids\ 638}#
- #{vars\ 639}#
- #{vals\ 640}#
- #{bindings\ 641}#)))
- (if (null? #{ids\ 636}#)
- (#{build-sequence\ 110}#
+ (#{chi-local-syntax\ 9171}#
+ #{value\ 10102}#
+ #{e\ 10103}#
+ #{er\ 10099}#
+ #{w\ 10104}#
+ #{s\ 10105}#
+ #{mod\ 10106}#
+ (lambda (#{forms\ 10140}#
+ #{er\ 10141}#
+ #{w\ 10142}#
+ #{s\ 10143}#
+ #{mod\ 10144}#)
+ (#{parse\ 10086}#
+ (letrec ((#{f\ 10152}#
+ (lambda
(#{forms\ 10153}#)
+ (if
(null? #{forms\ 10153}#)
+ (cdr
#{body\ 10087}#)
+ (cons
(cons #{er\ 10141}#
+
(#{wrap\ 9145}#
+
(car #{forms\ 10153}#)
+
#{w\ 10142}#
+
#{mod\ 10144}#))
+
(#{f\ 10152}#
+
(cdr #{forms\ 10153}#)))))))
+ (#{f\ 10152}#
+ #{forms\ 10140}#))
+ #{ids\ 10088}#
+ #{labels\ 10089}#
+ #{var-ids\ 10090}#
+ #{vars\ 10091}#
+ #{vals\ 10092}#
+ #{bindings\ 10093}#)))
+ (if (null? #{ids\ 10088}#)
+ (#{build-sequence\ 9028}#
#f
- (map (lambda (#{x\ 670}#)
- (#{chi\ 167}#
- (cdr #{x\ 670}#)
- (car #{x\ 670}#)
+ (map (lambda (#{x\
10156}#)
+ (#{chi\ 9161}#
+ (cdr #{x\
10156}#)
+ (car #{x\
10156}#)
'(())
- #{mod\ 650}#))
- (cons (cons #{er\
644}#
-
(#{source-wrap\ 160}#
- #{e\
647}#
- #{w\
648}#
- #{s\
649}#
-
#{mod\ 650}#))
- (cdr #{body\
635}#))))
+ #{mod\ 10106}#))
+ (cons (cons #{er\
10099}#
+
(#{source-wrap\ 9147}#
+ #{e\
10103}#
+ #{w\
10104}#
+ #{s\
10105}#
+
#{mod\ 10106}#))
+ (cdr #{body\
10087}#))))
(begin
- (if (not
(#{valid-bound-ids?\ 156}#
- #{ids\ 636}#))
+ (if (not
(#{valid-bound-ids?\ 9139}#
+ #{ids\
10088}#))
(syntax-violation
#f
"invalid or
duplicate identifier in definition"
- #{outer-form\ 627}#))
- (letrec ((#{loop\ 671}#
- (lambda
(#{bs\ 672}#
-
#{er-cache\ 673}#
-
#{r-cache\ 674}#)
- (if (not
(null? #{bs\ 672}#))
- (let
((#{b\ 675}# (car #{bs\ 672}#)))
- (if
(eq? (car #{b\ 675}#)
+ #{outer-form\
10061}#))
+ (letrec ((#{loop\ 10163}#
+ (lambda
(#{bs\ 10164}#
+
#{er-cache\ 10165}#
+
#{r-cache\ 10166}#)
+ (if (not
(null? #{bs\ 10164}#))
+ (let
((#{b\ 10169}#
+
(car #{bs\ 10164}#)))
+ (if
(eq? (car #{b\ 10169}#)
'macro)
- (let
((#{er\ 676}#
-
(cadr #{b\ 675}#)))
-
(let ((#{r-cache\ 677}#
-
(if (eq? #{er\ 676}#
-
#{er-cache\ 673}#)
-
#{r-cache\ 674}#
-
(#{macros-only-env\ 127}#
-
#{er\ 676}#))))
+ (let
((#{er\ 10172}#
+
(cadr #{b\ 10169}#)))
+
(let ((#{r-cache\ 10174}#
+
(if (eq? #{er\ 10172}#
+
#{er-cache\ 10165}#)
+
#{r-cache\ 10166}#
+
(#{macros-only-env\ 9068}#
+
#{er\ 10172}#))))
(begin
(set-cdr!
-
#{b\ 675}#
-
(#{eval-local-transformer\ 173}#
-
(#{chi\ 167}#
-
(cddr #{b\ 675}#)
-
#{r-cache\ 677}#
+
#{b\ 10169}#
+
(#{eval-local-transformer\ 9173}#
+
(#{chi\ 9161}#
+
(cddr #{b\ 10169}#)
+
#{r-cache\ 10174}#
'(())
-
#{mod\ 650}#)
-
#{mod\ 650}#))
-
(#{loop\ 671}#
-
(cdr #{bs\ 672}#)
-
#{er\ 676}#
-
#{r-cache\ 677}#))))
-
(#{loop\ 671}#
-
(cdr #{bs\ 672}#)
-
#{er-cache\ 673}#
-
#{r-cache\ 674}#)))))))
- (#{loop\ 671}#
- #{bindings\ 641}#
+
#{mod\ 10106}#)
+
#{mod\ 10106}#))
+
(#{loop\ 10163}#
+
(cdr #{bs\ 10164}#)
+
#{er\ 10172}#
+
#{r-cache\ 10174}#))))
+
(#{loop\ 10163}#
+
(cdr #{bs\ 10164}#)
+
#{er-cache\ 10165}#
+
#{r-cache\ 10166}#)))))))
+ (#{loop\ 10163}#
+ #{bindings\ 10093}#
#f
#f))
(set-cdr!
- #{r\ 631}#
- (#{extend-env\ 125}#
- #{labels\ 637}#
- #{bindings\ 641}#
- (cdr #{r\ 631}#)))
- (#{build-letrec\ 113}#
+ #{r\ 10072}#
+ (#{extend-env\ 9064}#
+ #{labels\ 10089}#
+ #{bindings\ 10093}#
+ (cdr #{r\ 10072}#)))
+ (#{build-letrec\ 9034}#
#f
(map syntax->datum
- #{var-ids\ 638}#)
- #{vars\ 639}#
- (map (lambda (#{x\
678}#)
- (#{chi\ 167}#
- (cdr #{x\
678}#)
- (car #{x\
678}#)
+ #{var-ids\
10090}#)
+ #{vars\ 10091}#
+ (map (lambda (#{x\
10177}#)
+ (#{chi\ 9161}#
+ (cdr #{x\
10177}#)
+ (car #{x\
10177}#)
'(())
- #{mod\ 650}#))
- #{vals\ 640}#)
- (#{build-sequence\
110}#
+ #{mod\
10106}#))
+ #{vals\ 10092}#)
+ (#{build-sequence\
9028}#
#f
- (map (lambda (#{x\
679}#)
- (#{chi\ 167}#
- (cdr #{x\
679}#)
- (car #{x\
679}#)
+ (map (lambda (#{x\
10181}#)
+ (#{chi\ 9161}#
+ (cdr #{x\
10181}#)
+ (car #{x\
10181}#)
'(())
- #{mod\
650}#))
- (cons (cons
#{er\ 644}#
-
(#{source-wrap\ 160}#
-
#{e\ 647}#
-
#{w\ 648}#
-
#{s\ 649}#
-
#{mod\ 650}#))
- (cdr
#{body\ 635}#))))))))))))))))))
- (#{parse\ 634}#
- (map (lambda (#{x\ 642}#)
- (cons #{r\ 631}#
- (#{wrap\ 159}#
- #{x\ 642}#
- #{w\ 633}#
- #{mod\ 630}#)))
- #{body\ 626}#)
+ #{mod\
10106}#))
+ (cons (cons
#{er\ 10099}#
+
(#{source-wrap\ 9147}#
+
#{e\ 10103}#
+
#{w\ 10104}#
+
#{s\ 10105}#
+
#{mod\ 10106}#))
+ (cdr
#{body\ 10087}#))))))))))))))))))
+ (#{parse\ 10086}#
+ (map (lambda (#{x\ 10094}#)
+ (cons #{r\ 10072}#
+ (#{wrap\ 9145}#
+ #{x\ 10094}#
+ #{w\ 10077}#
+ #{mod\ 10064}#)))
+ #{body\ 10060}#)
'()
'()
'()
'()
'()
'())))))))
- (#{chi-macro\ 170}#
- (lambda (#{p\ 680}#
- #{e\ 681}#
- #{r\ 682}#
- #{w\ 683}#
- #{rib\ 684}#
- #{mod\ 685}#)
- (letrec ((#{rebuild-macro-output\ 686}#
- (lambda (#{x\ 687}# #{m\ 688}#)
- (if (pair? #{x\ 687}#)
- (cons (#{rebuild-macro-output\ 686}#
- (car #{x\ 687}#)
- #{m\ 688}#)
- (#{rebuild-macro-output\ 686}#
- (cdr #{x\ 687}#)
- #{m\ 688}#))
- (if (#{syntax-object?\ 115}# #{x\ 687}#)
- (let ((#{w\ 689}# (#{syntax-object-wrap\ 117}#
- #{x\ 687}#)))
- (let ((#{ms\ 690}#
- (#{wrap-marks\ 134}# #{w\ 689}#))
- (#{s\ 691}# (#{wrap-subst\ 135}#
- #{w\ 689}#)))
- (if (if (pair? #{ms\ 690}#)
- (eq? (car #{ms\ 690}#) #f)
+ (#{chi-macro\ 9167}#
+ (lambda (#{p\ 10184}#
+ #{e\ 10185}#
+ #{r\ 10186}#
+ #{w\ 10187}#
+ #{rib\ 10188}#
+ #{mod\ 10189}#)
+ (letrec ((#{rebuild-macro-output\ 10197}#
+ (lambda (#{x\ 10198}# #{m\ 10199}#)
+ (if (pair? #{x\ 10198}#)
+ (cons (#{rebuild-macro-output\ 10197}#
+ (car #{x\ 10198}#)
+ #{m\ 10199}#)
+ (#{rebuild-macro-output\ 10197}#
+ (cdr #{x\ 10198}#)
+ #{m\ 10199}#))
+ (if (#{syntax-object?\ 9040}# #{x\ 10198}#)
+ (let ((#{w\ 10207}#
+ (#{syntax-object-wrap\ 9044}#
+ #{x\ 10198}#)))
+ (let ((#{ms\ 10210}#
+ (#{wrap-marks\ 9083}# #{w\ 10207}#))
+ (#{s\ 10211}#
+ (#{wrap-subst\ 9085}# #{w\ 10207}#)))
+ (if (if (pair? #{ms\ 10210}#)
+ (eq? (car #{ms\ 10210}#) #f)
#f)
- (#{make-syntax-object\ 114}#
- (#{syntax-object-expression\ 116}#
- #{x\ 687}#)
- (#{make-wrap\ 133}#
- (cdr #{ms\ 690}#)
- (if #{rib\ 684}#
- (cons #{rib\ 684}#
- (cdr #{s\ 691}#))
- (cdr #{s\ 691}#)))
- (#{syntax-object-module\ 118}#
- #{x\ 687}#))
- (#{make-syntax-object\ 114}#
- (#{syntax-object-expression\ 116}#
- #{x\ 687}#)
- (#{make-wrap\ 133}#
- (cons #{m\ 688}# #{ms\ 690}#)
- (if #{rib\ 684}#
- (cons #{rib\ 684}#
+ (#{make-syntax-object\ 9038}#
+ (#{syntax-object-expression\ 9042}#
+ #{x\ 10198}#)
+ (#{make-wrap\ 9081}#
+ (cdr #{ms\ 10210}#)
+ (if #{rib\ 10188}#
+ (cons #{rib\ 10188}#
+ (cdr #{s\ 10211}#))
+ (cdr #{s\ 10211}#)))
+ (#{syntax-object-module\ 9046}#
+ #{x\ 10198}#))
+ (#{make-syntax-object\ 9038}#
+ (#{syntax-object-expression\ 9042}#
+ #{x\ 10198}#)
+ (#{make-wrap\ 9081}#
+ (cons #{m\ 10199}# #{ms\ 10210}#)
+ (if #{rib\ 10188}#
+ (cons #{rib\ 10188}#
(cons 'shift
- #{s\ 691}#))
- (cons (quote shift) #{s\ 691}#)))
+ #{s\ 10211}#))
+ (cons (quote shift) #{s\ 10211}#)))
(cons 'hygiene
- (cdr #{p\ 680}#))))))
- (if (vector? #{x\ 687}#)
- (let ((#{n\ 692}# (vector-length
- #{x\ 687}#)))
- (let ((#{v\ 693}# (make-vector
- #{n\ 692}#)))
- (letrec ((#{loop\ 694}#
- (lambda (#{i\ 695}#)
- (if (#{fx=\ 88}#
- #{i\ 695}#
- #{n\ 692}#)
+ (cdr #{p\ 10184}#))))))
+ (if (vector? #{x\ 10198}#)
+ (let ((#{n\ 10219}#
+ (vector-length #{x\ 10198}#)))
+ (let ((#{v\ 10221}#
+ (make-vector #{n\ 10219}#)))
+ (letrec ((#{loop\ 10224}#
+ (lambda (#{i\ 10225}#)
+ (if (#{fx=\ 8981}#
+ #{i\ 10225}#
+ #{n\ 10219}#)
(begin
(if #f #f)
- #{v\ 693}#)
+ #{v\ 10221}#)
(begin
(vector-set!
- #{v\ 693}#
- #{i\ 695}#
-
(#{rebuild-macro-output\ 686}#
+ #{v\ 10221}#
+ #{i\ 10225}#
+
(#{rebuild-macro-output\ 10197}#
(vector-ref
- #{x\ 687}#
- #{i\ 695}#)
- #{m\ 688}#))
- (#{loop\ 694}#
- (#{fx+\ 86}#
- #{i\ 695}#
+ #{x\ 10198}#
+ #{i\ 10225}#)
+ #{m\ 10199}#))
+ (#{loop\ 10224}#
+ (#{fx+\ 8977}#
+ #{i\ 10225}#
1)))))))
- (#{loop\ 694}# 0))))
- (if (symbol? #{x\ 687}#)
+ (#{loop\ 10224}# 0))))
+ (if (symbol? #{x\ 10198}#)
(syntax-violation
#f
"encountered raw symbol in macro output"
- (#{source-wrap\ 160}#
- #{e\ 681}#
- #{w\ 683}#
- (#{wrap-subst\ 135}# #{w\ 683}#)
- #{mod\ 685}#)
- #{x\ 687}#)
- #{x\ 687}#)))))))
- (#{rebuild-macro-output\ 686}#
- ((car #{p\ 680}#)
- (#{wrap\ 159}#
- #{e\ 681}#
- (#{anti-mark\ 146}# #{w\ 683}#)
- #{mod\ 685}#))
- (string #\m)))))
- (#{chi-application\ 169}#
- (lambda (#{x\ 696}#
- #{e\ 697}#
- #{r\ 698}#
- #{w\ 699}#
- #{s\ 700}#
- #{mod\ 701}#)
- ((lambda (#{tmp\ 702}#)
- ((lambda (#{tmp\ 703}#)
- (if #{tmp\ 703}#
- (apply (lambda (#{e0\ 704}# #{e1\ 705}#)
- (#{build-application\ 96}#
- #{s\ 700}#
- #{x\ 696}#
- (map (lambda (#{e\ 706}#)
- (#{chi\ 167}#
- #{e\ 706}#
- #{r\ 698}#
- #{w\ 699}#
- #{mod\ 701}#))
- #{e1\ 705}#)))
- #{tmp\ 703}#)
+ (#{source-wrap\ 9147}#
+ #{e\ 10185}#
+ #{w\ 10187}#
+ (#{wrap-subst\ 9085}# #{w\ 10187}#)
+ #{mod\ 10189}#)
+ #{x\ 10198}#)
+ #{x\ 10198}#)))))))
+ (#{rebuild-macro-output\ 10197}#
+ ((car #{p\ 10184}#)
+ (#{wrap\ 9145}#
+ #{e\ 10185}#
+ (#{anti-mark\ 9117}# #{w\ 10187}#)
+ #{mod\ 10189}#))
+ (gensym "m")))))
+ (#{chi-application\ 9165}#
+ (lambda (#{x\ 10232}#
+ #{e\ 10233}#
+ #{r\ 10234}#
+ #{w\ 10235}#
+ #{s\ 10236}#
+ #{mod\ 10237}#)
+ ((lambda (#{tmp\ 10244}#)
+ ((lambda (#{tmp\ 10245}#)
+ (if #{tmp\ 10245}#
+ (apply (lambda (#{e0\ 10248}# #{e1\ 10249}#)
+ (#{build-application\ 8998}#
+ #{s\ 10236}#
+ #{x\ 10232}#
+ (map (lambda (#{e\ 10250}#)
+ (#{chi\ 9161}#
+ #{e\ 10250}#
+ #{r\ 10234}#
+ #{w\ 10235}#
+ #{mod\ 10237}#))
+ #{e1\ 10249}#)))
+ #{tmp\ 10245}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 702}#)))
+ #{tmp\ 10244}#)))
($sc-dispatch
- #{tmp\ 702}#
+ #{tmp\ 10244}#
'(any . each-any))))
- #{e\ 697}#)))
- (#{chi-expr\ 168}#
- (lambda (#{type\ 708}#
- #{value\ 709}#
- #{e\ 710}#
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
- (if (memv #{type\ 708}# (quote (lexical)))
- (#{build-lexical-reference\ 98}#
+ #{e\ 10233}#)))
+ (#{chi-expr\ 9163}#
+ (lambda (#{type\ 10253}#
+ #{value\ 10254}#
+ #{e\ 10255}#
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
+ (if (memv #{type\ 10253}# (quote (lexical)))
+ (#{build-lexical-reference\ 9004}#
'value
- #{s\ 713}#
- #{e\ 710}#
- #{value\ 709}#)
- (if (memv #{type\ 708}# (quote (core core-form)))
- (#{value\ 709}#
- #{e\ 710}#
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
- (if (memv #{type\ 708}# (quote (module-ref)))
+ #{s\ 10258}#
+ #{e\ 10255}#
+ #{value\ 10254}#)
+ (if (memv #{type\ 10253}# (quote (core core-form)))
+ (#{value\ 10254}#
+ #{e\ 10255}#
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
+ (if (memv #{type\ 10253}# (quote (module-ref)))
(call-with-values
- (lambda () (#{value\ 709}# #{e\ 710}#))
- (lambda (#{id\ 715}# #{mod\ 716}#)
- (#{build-global-reference\ 101}#
- #{s\ 713}#
- #{id\ 715}#
- #{mod\ 716}#)))
- (if (memv #{type\ 708}# (quote (lexical-call)))
- (#{chi-application\ 169}#
- (#{build-lexical-reference\ 98}#
+ (lambda () (#{value\ 10254}# #{e\ 10255}#))
+ (lambda (#{id\ 10270}# #{mod\ 10271}#)
+ (#{build-global-reference\ 9010}#
+ #{s\ 10258}#
+ #{id\ 10270}#
+ #{mod\ 10271}#)))
+ (if (memv #{type\ 10253}# (quote (lexical-call)))
+ (#{chi-application\ 9165}#
+ (#{build-lexical-reference\ 9004}#
'fun
- (#{source-annotation\ 122}# (car #{e\ 710}#))
- (car #{e\ 710}#)
- #{value\ 709}#)
- #{e\ 710}#
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
- (if (memv #{type\ 708}# (quote (global-call)))
- (#{chi-application\ 169}#
- (#{build-global-reference\ 101}#
- (#{source-annotation\ 122}# (car #{e\ 710}#))
- (if (#{syntax-object?\ 115}# #{value\ 709}#)
- (#{syntax-object-expression\ 116}#
- #{value\ 709}#)
- #{value\ 709}#)
- (if (#{syntax-object?\ 115}# #{value\ 709}#)
- (#{syntax-object-module\ 118}# #{value\ 709}#)
- #{mod\ 714}#))
- #{e\ 710}#
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
- (if (memv #{type\ 708}# (quote (constant)))
- (#{build-data\ 109}#
- #{s\ 713}#
- (#{strip\ 180}#
- (#{source-wrap\ 160}#
- #{e\ 710}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
+ (#{source-annotation\ 9055}# (car #{e\ 10255}#))
+ (car #{e\ 10255}#)
+ #{value\ 10254}#)
+ #{e\ 10255}#
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
+ (if (memv #{type\ 10253}# (quote (global-call)))
+ (#{chi-application\ 9165}#
+ (#{build-global-reference\ 9010}#
+ (#{source-annotation\ 9055}# (car #{e\ 10255}#))
+ (if (#{syntax-object?\ 9040}# #{value\ 10254}#)
+ (#{syntax-object-expression\ 9042}#
+ #{value\ 10254}#)
+ #{value\ 10254}#)
+ (if (#{syntax-object?\ 9040}# #{value\ 10254}#)
+ (#{syntax-object-module\ 9046}#
+ #{value\ 10254}#)
+ #{mod\ 10259}#))
+ #{e\ 10255}#
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
+ (if (memv #{type\ 10253}# (quote (constant)))
+ (#{build-data\ 9026}#
+ #{s\ 10258}#
+ (#{strip\ 9187}#
+ (#{source-wrap\ 9147}#
+ #{e\ 10255}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
'(())))
- (if (memv #{type\ 708}# (quote (global)))
- (#{build-global-reference\ 101}#
- #{s\ 713}#
- #{value\ 709}#
- #{mod\ 714}#)
- (if (memv #{type\ 708}# (quote (call)))
- (#{chi-application\ 169}#
- (#{chi\ 167}#
- (car #{e\ 710}#)
- #{r\ 711}#
- #{w\ 712}#
- #{mod\ 714}#)
- #{e\ 710}#
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
- (if (memv #{type\ 708}# (quote (begin-form)))
- ((lambda (#{tmp\ 717}#)
- ((lambda (#{tmp\ 718}#)
- (if #{tmp\ 718}#
- (apply (lambda (#{_\ 719}#
- #{e1\ 720}#
- #{e2\ 721}#)
- (#{chi-sequence\ 161}#
- (cons #{e1\ 720}#
- #{e2\ 721}#)
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#))
- #{tmp\ 718}#)
+ (if (memv #{type\ 10253}# (quote (global)))
+ (#{build-global-reference\ 9010}#
+ #{s\ 10258}#
+ #{value\ 10254}#
+ #{mod\ 10259}#)
+ (if (memv #{type\ 10253}# (quote (call)))
+ (#{chi-application\ 9165}#
+ (#{chi\ 9161}#
+ (car #{e\ 10255}#)
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{mod\ 10259}#)
+ #{e\ 10255}#
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
+ (if (memv #{type\ 10253}# (quote (begin-form)))
+ ((lambda (#{tmp\ 10281}#)
+ ((lambda (#{tmp\ 10282}#)
+ (if #{tmp\ 10282}#
+ (apply (lambda (#{_\ 10286}#
+ #{e1\ 10287}#
+ #{e2\ 10288}#)
+ (#{chi-sequence\ 9149}#
+ (cons #{e1\ 10287}#
+ #{e2\ 10288}#)
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#))
+ #{tmp\ 10282}#)
(syntax-violation
#f
"source expression failed to match
any pattern"
- #{tmp\ 717}#)))
+ #{tmp\ 10281}#)))
($sc-dispatch
- #{tmp\ 717}#
+ #{tmp\ 10281}#
'(any any . each-any))))
- #{e\ 710}#)
- (if (memv #{type\ 708}#
+ #{e\ 10255}#)
+ (if (memv #{type\ 10253}#
'(local-syntax-form))
- (#{chi-local-syntax\ 172}#
- #{value\ 709}#
- #{e\ 710}#
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#
- #{chi-sequence\ 161}#)
- (if (memv #{type\ 708}#
+ (#{chi-local-syntax\ 9171}#
+ #{value\ 10254}#
+ #{e\ 10255}#
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#
+ #{chi-sequence\ 9149}#)
+ (if (memv #{type\ 10253}#
'(eval-when-form))
- ((lambda (#{tmp\ 723}#)
- ((lambda (#{tmp\ 724}#)
- (if #{tmp\ 724}#
- (apply (lambda (#{_\ 725}#
- #{x\ 726}#
- #{e1\ 727}#
- #{e2\ 728}#)
- (let ((#{when-list\ 729}#
-
(#{chi-when-list\ 164}#
- #{e\ 710}#
- #{x\ 726}#
- #{w\ 712}#)))
+ ((lambda (#{tmp\ 10292}#)
+ ((lambda (#{tmp\ 10293}#)
+ (if #{tmp\ 10293}#
+ (apply (lambda (#{_\ 10298}#
+ #{x\ 10299}#
+ #{e1\ 10300}#
+ #{e2\ 10301}#)
+ (let ((#{when-list\
10303}#
+
(#{chi-when-list\ 9155}#
+ #{e\ 10255}#
+ #{x\ 10299}#
+ #{w\ 10257}#)))
(if (memq 'eval
- #{when-list\
729}#)
- (#{chi-sequence\
161}#
- (cons #{e1\ 727}#
- #{e2\ 728}#)
- #{r\ 711}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#)
- (#{chi-void\
174}#))))
- #{tmp\ 724}#)
+ #{when-list\
10303}#)
+ (#{chi-sequence\
9149}#
+ (cons #{e1\ 10300}#
+ #{e2\
10301}#)
+ #{r\ 10256}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#)
+ (#{chi-void\
9175}#))))
+ #{tmp\ 10293}#)
(syntax-violation
#f
"source expression failed to
match any pattern"
- #{tmp\ 723}#)))
+ #{tmp\ 10292}#)))
($sc-dispatch
- #{tmp\ 723}#
+ #{tmp\ 10292}#
'(any each-any any . each-any))))
- #{e\ 710}#)
- (if (memv #{type\ 708}#
+ #{e\ 10255}#)
+ (if (memv #{type\ 10253}#
'(define-form
define-syntax-form))
(syntax-violation
#f
"definition in expression context"
- #{e\ 710}#
- (#{wrap\ 159}#
- #{value\ 709}#
- #{w\ 712}#
- #{mod\ 714}#))
- (if (memv #{type\ 708}#
+ #{e\ 10255}#
+ (#{wrap\ 9145}#
+ #{value\ 10254}#
+ #{w\ 10257}#
+ #{mod\ 10259}#))
+ (if (memv #{type\ 10253}#
'(syntax))
(syntax-violation
#f
"reference to pattern variable
outside syntax form"
- (#{source-wrap\ 160}#
- #{e\ 710}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#))
- (if (memv #{type\ 708}#
+ (#{source-wrap\ 9147}#
+ #{e\ 10255}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#))
+ (if (memv #{type\ 10253}#
'(displaced-lexical))
(syntax-violation
#f
"reference to identifier outside
its scope"
- (#{source-wrap\ 160}#
- #{e\ 710}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#))
+ (#{source-wrap\ 9147}#
+ #{e\ 10255}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#))
(syntax-violation
#f
"unexpected syntax"
- (#{source-wrap\ 160}#
- #{e\ 710}#
- #{w\ 712}#
- #{s\ 713}#
- #{mod\ 714}#))))))))))))))))))
- (#{chi\ 167}#
- (lambda (#{e\ 732}# #{r\ 733}# #{w\ 734}# #{mod\ 735}#)
+ (#{source-wrap\ 9147}#
+ #{e\ 10255}#
+ #{w\ 10257}#
+ #{s\ 10258}#
+ #{mod\ 10259}#))))))))))))))))))
+ (#{chi\ 9161}#
+ (lambda (#{e\ 10310}#
+ #{r\ 10311}#
+ #{w\ 10312}#
+ #{mod\ 10313}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 165}#
- #{e\ 732}#
- #{r\ 733}#
- #{w\ 734}#
- (#{source-annotation\ 122}# #{e\ 732}#)
+ (#{syntax-type\ 9157}#
+ #{e\ 10310}#
+ #{r\ 10311}#
+ #{w\ 10312}#
+ (#{source-annotation\ 9055}# #{e\ 10310}#)
#f
- #{mod\ 735}#
+ #{mod\ 10313}#
#f))
- (lambda (#{type\ 736}#
- #{value\ 737}#
- #{e\ 738}#
- #{w\ 739}#
- #{s\ 740}#
- #{mod\ 741}#)
- (#{chi-expr\ 168}#
- #{type\ 736}#
- #{value\ 737}#
- #{e\ 738}#
- #{r\ 733}#
- #{w\ 739}#
- #{s\ 740}#
- #{mod\ 741}#)))))
- (#{chi-top\ 166}#
- (lambda (#{e\ 742}#
- #{r\ 743}#
- #{w\ 744}#
- #{m\ 745}#
- #{esew\ 746}#
- #{mod\ 747}#)
+ (lambda (#{type\ 10318}#
+ #{value\ 10319}#
+ #{e\ 10320}#
+ #{w\ 10321}#
+ #{s\ 10322}#
+ #{mod\ 10323}#)
+ (#{chi-expr\ 9163}#
+ #{type\ 10318}#
+ #{value\ 10319}#
+ #{e\ 10320}#
+ #{r\ 10311}#
+ #{w\ 10321}#
+ #{s\ 10322}#
+ #{mod\ 10323}#)))))
+ (#{chi-top\ 9159}#
+ (lambda (#{e\ 10330}#
+ #{r\ 10331}#
+ #{w\ 10332}#
+ #{m\ 10333}#
+ #{esew\ 10334}#
+ #{mod\ 10335}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 165}#
- #{e\ 742}#
- #{r\ 743}#
- #{w\ 744}#
- (#{source-annotation\ 122}# #{e\ 742}#)
+ (#{syntax-type\ 9157}#
+ #{e\ 10330}#
+ #{r\ 10331}#
+ #{w\ 10332}#
+ (#{source-annotation\ 9055}# #{e\ 10330}#)
#f
- #{mod\ 747}#
+ #{mod\ 10335}#
#f))
- (lambda (#{type\ 755}#
- #{value\ 756}#
- #{e\ 757}#
- #{w\ 758}#
- #{s\ 759}#
- #{mod\ 760}#)
- (if (memv #{type\ 755}# (quote (begin-form)))
- ((lambda (#{tmp\ 761}#)
- ((lambda (#{tmp\ 762}#)
- (if #{tmp\ 762}#
- (apply (lambda (#{_\ 763}#) (#{chi-void\ 174}#))
- #{tmp\ 762}#)
- ((lambda (#{tmp\ 764}#)
- (if #{tmp\ 764}#
- (apply (lambda (#{_\ 765}#
- #{e1\ 766}#
- #{e2\ 767}#)
- (#{chi-top-sequence\ 162}#
- (cons #{e1\ 766}# #{e2\ 767}#)
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
- #{m\ 745}#
- #{esew\ 746}#
- #{mod\ 760}#))
- #{tmp\ 764}#)
+ (lambda (#{type\ 10356}#
+ #{value\ 10357}#
+ #{e\ 10358}#
+ #{w\ 10359}#
+ #{s\ 10360}#
+ #{mod\ 10361}#)
+ (if (memv #{type\ 10356}# (quote (begin-form)))
+ ((lambda (#{tmp\ 10369}#)
+ ((lambda (#{tmp\ 10370}#)
+ (if #{tmp\ 10370}#
+ (apply (lambda (#{_\ 10372}#)
+ (#{chi-void\ 9175}#))
+ #{tmp\ 10370}#)
+ ((lambda (#{tmp\ 10373}#)
+ (if #{tmp\ 10373}#
+ (apply (lambda (#{_\ 10377}#
+ #{e1\ 10378}#
+ #{e2\ 10379}#)
+ (#{chi-top-sequence\ 9151}#
+ (cons #{e1\ 10378}# #{e2\ 10379}#)
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
+ #{m\ 10333}#
+ #{esew\ 10334}#
+ #{mod\ 10361}#))
+ #{tmp\ 10373}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 761}#)))
+ #{tmp\ 10369}#)))
($sc-dispatch
- #{tmp\ 761}#
+ #{tmp\ 10369}#
'(any any . each-any)))))
- ($sc-dispatch #{tmp\ 761}# (quote (any)))))
- #{e\ 757}#)
- (if (memv #{type\ 755}# (quote (local-syntax-form)))
- (#{chi-local-syntax\ 172}#
- #{value\ 756}#
- #{e\ 757}#
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
- #{mod\ 760}#
- (lambda (#{body\ 769}#
- #{r\ 770}#
- #{w\ 771}#
- #{s\ 772}#
- #{mod\ 773}#)
- (#{chi-top-sequence\ 162}#
- #{body\ 769}#
- #{r\ 770}#
- #{w\ 771}#
- #{s\ 772}#
- #{m\ 745}#
- #{esew\ 746}#
- #{mod\ 773}#)))
- (if (memv #{type\ 755}# (quote (eval-when-form)))
- ((lambda (#{tmp\ 774}#)
- ((lambda (#{tmp\ 775}#)
- (if #{tmp\ 775}#
- (apply (lambda (#{_\ 776}#
- #{x\ 777}#
- #{e1\ 778}#
- #{e2\ 779}#)
- (let ((#{when-list\ 780}#
- (#{chi-when-list\ 164}#
- #{e\ 757}#
- #{x\ 777}#
- #{w\ 758}#))
- (#{body\ 781}#
- (cons #{e1\ 778}#
- #{e2\ 779}#)))
- (if (eq? #{m\ 745}# (quote e))
+ ($sc-dispatch #{tmp\ 10369}# (quote (any)))))
+ #{e\ 10358}#)
+ (if (memv #{type\ 10356}#
+ '(local-syntax-form))
+ (#{chi-local-syntax\ 9171}#
+ #{value\ 10357}#
+ #{e\ 10358}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
+ #{mod\ 10361}#
+ (lambda (#{body\ 10382}#
+ #{r\ 10383}#
+ #{w\ 10384}#
+ #{s\ 10385}#
+ #{mod\ 10386}#)
+ (#{chi-top-sequence\ 9151}#
+ #{body\ 10382}#
+ #{r\ 10383}#
+ #{w\ 10384}#
+ #{s\ 10385}#
+ #{m\ 10333}#
+ #{esew\ 10334}#
+ #{mod\ 10386}#)))
+ (if (memv #{type\ 10356}# (quote (eval-when-form)))
+ ((lambda (#{tmp\ 10393}#)
+ ((lambda (#{tmp\ 10394}#)
+ (if #{tmp\ 10394}#
+ (apply (lambda (#{_\ 10399}#
+ #{x\ 10400}#
+ #{e1\ 10401}#
+ #{e2\ 10402}#)
+ (let ((#{when-list\ 10405}#
+ (#{chi-when-list\ 9155}#
+ #{e\ 10358}#
+ #{x\ 10400}#
+ #{w\ 10359}#))
+ (#{body\ 10406}#
+ (cons #{e1\ 10401}#
+ #{e2\ 10402}#)))
+ (if (eq? #{m\ 10333}# (quote e))
(if (memq 'eval
- #{when-list\ 780}#)
- (#{chi-top-sequence\ 162}#
- #{body\ 781}#
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
+ #{when-list\ 10405}#)
+ (#{chi-top-sequence\ 9151}#
+ #{body\ 10406}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
'e
'(eval)
- #{mod\ 760}#)
- (#{chi-void\ 174}#))
+ #{mod\ 10361}#)
+ (#{chi-void\ 9175}#))
(if (memq 'load
- #{when-list\ 780}#)
- (if (let ((#{t\ 784}# (memq
'compile
-
#{when-list\ 780}#)))
- (if #{t\ 784}#
- #{t\ 784}#
- (if (eq? #{m\ 745}#
+ #{when-list\ 10405}#)
+ (if (let ((#{t\ 10415}#
+ (memq 'compile
+ #{when-list\
10405}#)))
+ (if #{t\ 10415}#
+ #{t\ 10415}#
+ (if (eq? #{m\ 10333}#
'c&e)
(memq 'eval
- #{when-list\
780}#)
+ #{when-list\
10405}#)
#f)))
- (#{chi-top-sequence\ 162}#
- #{body\ 781}#
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
+ (#{chi-top-sequence\ 9151}#
+ #{body\ 10406}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
'c&e
'(compile load)
- #{mod\ 760}#)
- (if (memq #{m\ 745}#
+ #{mod\ 10361}#)
+ (if (memq #{m\ 10333}#
'(c c&e))
- (#{chi-top-sequence\ 162}#
- #{body\ 781}#
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
+ (#{chi-top-sequence\ 9151}#
+ #{body\ 10406}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
'c
'(load)
- #{mod\ 760}#)
- (#{chi-void\ 174}#)))
- (if (let ((#{t\ 785}# (memq
'compile
-
#{when-list\ 780}#)))
- (if #{t\ 785}#
- #{t\ 785}#
- (if (eq? #{m\ 745}#
+ #{mod\ 10361}#)
+ (#{chi-void\ 9175}#)))
+ (if (let ((#{t\ 10423}#
+ (memq 'compile
+ #{when-list\
10405}#)))
+ (if #{t\ 10423}#
+ #{t\ 10423}#
+ (if (eq? #{m\ 10333}#
'c&e)
(memq 'eval
- #{when-list\
780}#)
+ #{when-list\
10405}#)
#f)))
(begin
- (#{top-level-eval-hook\
90}#
- (#{chi-top-sequence\
162}#
- #{body\ 781}#
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
+ (#{top-level-eval-hook\
8985}#
+ (#{chi-top-sequence\
9151}#
+ #{body\ 10406}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
'e
'(eval)
- #{mod\ 760}#)
- #{mod\ 760}#)
- (#{chi-void\ 174}#))
- (#{chi-void\ 174}#))))))
- #{tmp\ 775}#)
+ #{mod\ 10361}#)
+ #{mod\ 10361}#)
+ (#{chi-void\ 9175}#))
+ (#{chi-void\ 9175}#))))))
+ #{tmp\ 10394}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 774}#)))
+ #{tmp\ 10393}#)))
($sc-dispatch
- #{tmp\ 774}#
+ #{tmp\ 10393}#
'(any each-any any . each-any))))
- #{e\ 757}#)
- (if (memv #{type\ 755}# (quote (define-syntax-form)))
- (let ((#{n\ 786}# (#{id-var-name\ 153}#
- #{value\ 756}#
- #{w\ 758}#))
- (#{r\ 787}# (#{macros-only-env\ 127}#
- #{r\ 743}#)))
- (if (memv #{m\ 745}# (quote (c)))
- (if (memq (quote compile) #{esew\ 746}#)
- (let ((#{e\ 788}# (#{chi-install-global\ 163}#
- #{n\ 786}#
- (#{chi\ 167}#
- #{e\ 757}#
- #{r\ 787}#
- #{w\ 758}#
- #{mod\ 760}#))))
+ #{e\ 10358}#)
+ (if (memv #{type\ 10356}#
+ '(define-syntax-form))
+ (let ((#{n\ 10431}#
+ (#{id-var-name\ 9133}#
+ #{value\ 10357}#
+ #{w\ 10359}#))
+ (#{r\ 10432}#
+ (#{macros-only-env\ 9068}# #{r\ 10331}#)))
+ (if (memv #{m\ 10333}# (quote (c)))
+ (if (memq (quote compile) #{esew\ 10334}#)
+ (let ((#{e\ 10435}#
+ (#{chi-install-global\ 9153}#
+ #{n\ 10431}#
+ (#{chi\ 9161}#
+ #{e\ 10358}#
+ #{r\ 10432}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))))
(begin
- (#{top-level-eval-hook\ 90}#
- #{e\ 788}#
- #{mod\ 760}#)
- (if (memq (quote load) #{esew\ 746}#)
- #{e\ 788}#
- (#{chi-void\ 174}#))))
- (if (memq (quote load) #{esew\ 746}#)
- (#{chi-install-global\ 163}#
- #{n\ 786}#
- (#{chi\ 167}#
- #{e\ 757}#
- #{r\ 787}#
- #{w\ 758}#
- #{mod\ 760}#))
- (#{chi-void\ 174}#)))
- (if (memv #{m\ 745}# (quote (c&e)))
- (let ((#{e\ 789}# (#{chi-install-global\ 163}#
- #{n\ 786}#
- (#{chi\ 167}#
- #{e\ 757}#
- #{r\ 787}#
- #{w\ 758}#
- #{mod\ 760}#))))
+ (#{top-level-eval-hook\ 8985}#
+ #{e\ 10435}#
+ #{mod\ 10361}#)
+ (if (memq (quote load) #{esew\ 10334}#)
+ #{e\ 10435}#
+ (#{chi-void\ 9175}#))))
+ (if (memq (quote load) #{esew\ 10334}#)
+ (#{chi-install-global\ 9153}#
+ #{n\ 10431}#
+ (#{chi\ 9161}#
+ #{e\ 10358}#
+ #{r\ 10432}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))
+ (#{chi-void\ 9175}#)))
+ (if (memv #{m\ 10333}# (quote (c&e)))
+ (let ((#{e\ 10438}#
+ (#{chi-install-global\ 9153}#
+ #{n\ 10431}#
+ (#{chi\ 9161}#
+ #{e\ 10358}#
+ #{r\ 10432}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))))
(begin
- (#{top-level-eval-hook\ 90}#
- #{e\ 789}#
- #{mod\ 760}#)
- #{e\ 789}#))
+ (#{top-level-eval-hook\ 8985}#
+ #{e\ 10438}#
+ #{mod\ 10361}#)
+ #{e\ 10438}#))
(begin
- (if (memq (quote eval) #{esew\ 746}#)
- (#{top-level-eval-hook\ 90}#
- (#{chi-install-global\ 163}#
- #{n\ 786}#
- (#{chi\ 167}#
- #{e\ 757}#
- #{r\ 787}#
- #{w\ 758}#
- #{mod\ 760}#))
- #{mod\ 760}#))
- (#{chi-void\ 174}#)))))
- (if (memv #{type\ 755}# (quote (define-form)))
- (let ((#{n\ 790}# (#{id-var-name\ 153}#
- #{value\ 756}#
- #{w\ 758}#)))
- (let ((#{type\ 791}#
- (#{binding-type\ 123}#
- (#{lookup\ 128}#
- #{n\ 790}#
- #{r\ 743}#
- #{mod\ 760}#))))
- (if (memv #{type\ 791}#
+ (if (memq (quote eval) #{esew\ 10334}#)
+ (#{top-level-eval-hook\ 8985}#
+ (#{chi-install-global\ 9153}#
+ #{n\ 10431}#
+ (#{chi\ 9161}#
+ #{e\ 10358}#
+ #{r\ 10432}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))
+ #{mod\ 10361}#))
+ (#{chi-void\ 9175}#)))))
+ (if (memv #{type\ 10356}# (quote (define-form)))
+ (let ((#{n\ 10443}#
+ (#{id-var-name\ 9133}#
+ #{value\ 10357}#
+ #{w\ 10359}#)))
+ (let ((#{type\ 10445}#
+ (#{binding-type\ 9059}#
+ (#{lookup\ 9070}#
+ #{n\ 10443}#
+ #{r\ 10331}#
+ #{mod\ 10361}#))))
+ (if (memv #{type\ 10445}#
'(global core macro module-ref))
(begin
(if (if (not (module-local-variable
(current-module)
- #{n\ 790}#))
+ #{n\ 10443}#))
(current-module)
#f)
- (let ((#{old\ 792}#
+ (let ((#{old\ 10450}#
(module-variable
(current-module)
- #{n\ 790}#)))
+ #{n\ 10443}#)))
(module-define!
(current-module)
- #{n\ 790}#
- (if (variable? #{old\ 792}#)
- (variable-ref #{old\ 792}#)
+ #{n\ 10443}#
+ (if (variable? #{old\ 10450}#)
+ (variable-ref #{old\ 10450}#)
#f))))
- (let ((#{x\ 793}#
(#{build-global-definition\ 104}#
- #{s\ 759}#
- #{n\ 790}#
- (#{chi\ 167}#
- #{e\ 757}#
- #{r\ 743}#
- #{w\ 758}#
- #{mod\ 760}#))))
+ (let ((#{x\ 10453}#
+ (#{build-global-definition\ 9016}#
+ #{s\ 10360}#
+ #{n\ 10443}#
+ (#{chi\ 9161}#
+ #{e\ 10358}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))))
(begin
- (if (eq? #{m\ 745}# (quote c&e))
- (#{top-level-eval-hook\ 90}#
- #{x\ 793}#
- #{mod\ 760}#))
- #{x\ 793}#)))
- (if (memv #{type\ 791}#
+ (if (eq? #{m\ 10333}# (quote c&e))
+ (#{top-level-eval-hook\ 8985}#
+ #{x\ 10453}#
+ #{mod\ 10361}#))
+ #{x\ 10453}#)))
+ (if (memv #{type\ 10445}#
'(displaced-lexical))
(syntax-violation
#f
"identifier out of context"
- #{e\ 757}#
- (#{wrap\ 159}#
- #{value\ 756}#
- #{w\ 758}#
- #{mod\ 760}#))
+ #{e\ 10358}#
+ (#{wrap\ 9145}#
+ #{value\ 10357}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))
(syntax-violation
#f
"cannot define keyword at top level"
- #{e\ 757}#
- (#{wrap\ 159}#
- #{value\ 756}#
- #{w\ 758}#
- #{mod\ 760}#))))))
- (let ((#{x\ 794}# (#{chi-expr\ 168}#
- #{type\ 755}#
- #{value\ 756}#
- #{e\ 757}#
- #{r\ 743}#
- #{w\ 758}#
- #{s\ 759}#
- #{mod\ 760}#)))
+ #{e\ 10358}#
+ (#{wrap\ 9145}#
+ #{value\ 10357}#
+ #{w\ 10359}#
+ #{mod\ 10361}#))))))
+ (let ((#{x\ 10459}#
+ (#{chi-expr\ 9163}#
+ #{type\ 10356}#
+ #{value\ 10357}#
+ #{e\ 10358}#
+ #{r\ 10331}#
+ #{w\ 10359}#
+ #{s\ 10360}#
+ #{mod\ 10361}#)))
(begin
- (if (eq? #{m\ 745}# (quote c&e))
- (#{top-level-eval-hook\ 90}#
- #{x\ 794}#
- #{mod\ 760}#))
- #{x\ 794}#)))))))))))
- (#{syntax-type\ 165}#
- (lambda (#{e\ 795}#
- #{r\ 796}#
- #{w\ 797}#
- #{s\ 798}#
- #{rib\ 799}#
- #{mod\ 800}#
- #{for-car?\ 801}#)
- (if (symbol? #{e\ 795}#)
- (let ((#{n\ 802}# (#{id-var-name\ 153}#
- #{e\ 795}#
- #{w\ 797}#)))
- (let ((#{b\ 803}# (#{lookup\ 128}#
- #{n\ 802}#
- #{r\ 796}#
- #{mod\ 800}#)))
- (let ((#{type\ 804}#
- (#{binding-type\ 123}# #{b\ 803}#)))
- (if (memv #{type\ 804}# (quote (lexical)))
+ (if (eq? #{m\ 10333}# (quote c&e))
+ (#{top-level-eval-hook\ 8985}#
+ #{x\ 10459}#
+ #{mod\ 10361}#))
+ #{x\ 10459}#)))))))))))
+ (#{syntax-type\ 9157}#
+ (lambda (#{e\ 10460}#
+ #{r\ 10461}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{rib\ 10464}#
+ #{mod\ 10465}#
+ #{for-car?\ 10466}#)
+ (if (symbol? #{e\ 10460}#)
+ (let ((#{n\ 10478}#
+ (#{id-var-name\ 9133}# #{e\ 10460}# #{w\ 10462}#)))
+ (let ((#{b\ 10480}#
+ (#{lookup\ 9070}#
+ #{n\ 10478}#
+ #{r\ 10461}#
+ #{mod\ 10465}#)))
+ (let ((#{type\ 10482}#
+ (#{binding-type\ 9059}# #{b\ 10480}#)))
+ (if (memv #{type\ 10482}# (quote (lexical)))
(values
- #{type\ 804}#
- (#{binding-value\ 124}# #{b\ 803}#)
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{type\ 804}# (quote (global)))
+ #{type\ 10482}#
+ (#{binding-value\ 9061}# #{b\ 10480}#)
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{type\ 10482}# (quote (global)))
(values
- #{type\ 804}#
- #{n\ 802}#
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{type\ 804}# (quote (macro)))
- (if #{for-car?\ 801}#
+ #{type\ 10482}#
+ #{n\ 10478}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{type\ 10482}# (quote (macro)))
+ (if #{for-car?\ 10466}#
(values
- #{type\ 804}#
- (#{binding-value\ 124}# #{b\ 803}#)
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (#{syntax-type\ 165}#
- (#{chi-macro\ 170}#
- (#{binding-value\ 124}# #{b\ 803}#)
- #{e\ 795}#
- #{r\ 796}#
- #{w\ 797}#
- #{rib\ 799}#
- #{mod\ 800}#)
- #{r\ 796}#
+ #{type\ 10482}#
+ (#{binding-value\ 9061}# #{b\ 10480}#)
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (#{syntax-type\ 9157}#
+ (#{chi-macro\ 9167}#
+ (#{binding-value\ 9061}# #{b\ 10480}#)
+ #{e\ 10460}#
+ #{r\ 10461}#
+ #{w\ 10462}#
+ #{rib\ 10464}#
+ #{mod\ 10465}#)
+ #{r\ 10461}#
'(())
- #{s\ 798}#
- #{rib\ 799}#
- #{mod\ 800}#
+ #{s\ 10463}#
+ #{rib\ 10464}#
+ #{mod\ 10465}#
#f))
(values
- #{type\ 804}#
- (#{binding-value\ 124}# #{b\ 803}#)
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)))))))
- (if (pair? #{e\ 795}#)
- (let ((#{first\ 805}# (car #{e\ 795}#)))
+ #{type\ 10482}#
+ (#{binding-value\ 9061}# #{b\ 10480}#)
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)))))))
+ (if (pair? #{e\ 10460}#)
+ (let ((#{first\ 10491}# (car #{e\ 10460}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 165}#
- #{first\ 805}#
- #{r\ 796}#
- #{w\ 797}#
- #{s\ 798}#
- #{rib\ 799}#
- #{mod\ 800}#
+ (#{syntax-type\ 9157}#
+ #{first\ 10491}#
+ #{r\ 10461}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{rib\ 10464}#
+ #{mod\ 10465}#
#t))
- (lambda (#{ftype\ 806}#
- #{fval\ 807}#
- #{fe\ 808}#
- #{fw\ 809}#
- #{fs\ 810}#
- #{fmod\ 811}#)
- (if (memv #{ftype\ 806}# (quote (lexical)))
+ (lambda (#{ftype\ 10492}#
+ #{fval\ 10493}#
+ #{fe\ 10494}#
+ #{fw\ 10495}#
+ #{fs\ 10496}#
+ #{fmod\ 10497}#)
+ (if (memv #{ftype\ 10492}# (quote (lexical)))
(values
'lexical-call
- #{fval\ 807}#
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{ftype\ 806}# (quote (global)))
+ #{fval\ 10493}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{ftype\ 10492}# (quote (global)))
(values
'global-call
- (#{make-syntax-object\ 114}#
- #{fval\ 807}#
- #{w\ 797}#
- #{fmod\ 811}#)
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{ftype\ 806}# (quote (macro)))
- (#{syntax-type\ 165}#
- (#{chi-macro\ 170}#
- #{fval\ 807}#
- #{e\ 795}#
- #{r\ 796}#
- #{w\ 797}#
- #{rib\ 799}#
- #{mod\ 800}#)
- #{r\ 796}#
+ (#{make-syntax-object\ 9038}#
+ #{fval\ 10493}#
+ #{w\ 10462}#
+ #{fmod\ 10497}#)
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{ftype\ 10492}# (quote (macro)))
+ (#{syntax-type\ 9157}#
+ (#{chi-macro\ 9167}#
+ #{fval\ 10493}#
+ #{e\ 10460}#
+ #{r\ 10461}#
+ #{w\ 10462}#
+ #{rib\ 10464}#
+ #{mod\ 10465}#)
+ #{r\ 10461}#
'(())
- #{s\ 798}#
- #{rib\ 799}#
- #{mod\ 800}#
- #{for-car?\ 801}#)
- (if (memv #{ftype\ 806}# (quote (module-ref)))
+ #{s\ 10463}#
+ #{rib\ 10464}#
+ #{mod\ 10465}#
+ #{for-car?\ 10466}#)
+ (if (memv #{ftype\ 10492}# (quote (module-ref)))
(call-with-values
- (lambda () (#{fval\ 807}# #{e\ 795}#))
- (lambda (#{sym\ 812}# #{mod\ 813}#)
- (#{syntax-type\ 165}#
- #{sym\ 812}#
- #{r\ 796}#
- #{w\ 797}#
- #{s\ 798}#
- #{rib\ 799}#
- #{mod\ 813}#
- #{for-car?\ 801}#)))
- (if (memv #{ftype\ 806}# (quote (core)))
+ (lambda () (#{fval\ 10493}# #{e\ 10460}#))
+ (lambda (#{sym\ 10509}# #{mod\ 10510}#)
+ (#{syntax-type\ 9157}#
+ #{sym\ 10509}#
+ #{r\ 10461}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{rib\ 10464}#
+ #{mod\ 10510}#
+ #{for-car?\ 10466}#)))
+ (if (memv #{ftype\ 10492}# (quote (core)))
(values
'core-form
- #{fval\ 807}#
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{ftype\ 806}#
+ #{fval\ 10493}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{ftype\ 10492}#
'(local-syntax))
(values
'local-syntax-form
- #{fval\ 807}#
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{ftype\ 806}# (quote (begin)))
+ #{fval\ 10493}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{ftype\ 10492}#
+ '(begin))
(values
'begin-form
#f
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{ftype\ 806}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{ftype\ 10492}#
'(eval-when))
(values
'eval-when-form
#f
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
- (if (memv #{ftype\ 806}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
+ (if (memv #{ftype\ 10492}#
'(define))
- ((lambda (#{tmp\ 814}#)
- ((lambda (#{tmp\ 815}#)
- (if (if #{tmp\ 815}#
- (apply (lambda (#{_\
816}#
- #{name\
817}#
- #{val\
818}#)
- (#{id?\ 131}#
- #{name\
817}#))
- #{tmp\ 815}#)
+ ((lambda (#{tmp\ 10518}#)
+ ((lambda (#{tmp\ 10519}#)
+ (if (if #{tmp\ 10519}#
+ (apply (lambda (#{_\
10523}#
+ #{name\
10524}#
+ #{val\
10525}#)
+ (#{id?\ 9076}#
+ #{name\
10524}#))
+ #{tmp\ 10519}#)
#f)
- (apply (lambda (#{_\ 819}#
- #{name\
820}#
- #{val\
821}#)
+ (apply (lambda (#{_\ 10529}#
+ #{name\
10530}#
+ #{val\
10531}#)
(values
'define-form
- #{name\ 820}#
- #{val\ 821}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#))
- #{tmp\ 815}#)
- ((lambda (#{tmp\ 822}#)
- (if (if #{tmp\ 822}#
- (apply (lambda
(#{_\ 823}#
-
#{name\ 824}#
-
#{args\ 825}#
-
#{e1\ 826}#
-
#{e2\ 827}#)
- (if
(#{id?\ 131}#
-
#{name\ 824}#)
-
(#{valid-bound-ids?\ 156}#
-
(#{lambda-var-list\ 182}#
-
#{args\ 825}#))
+ #{name\ 10530}#
+ #{val\ 10531}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#))
+ #{tmp\ 10519}#)
+ ((lambda (#{tmp\ 10532}#)
+ (if (if #{tmp\ 10532}#
+ (apply (lambda
(#{_\ 10538}#
+
#{name\ 10539}#
+
#{args\ 10540}#
+
#{e1\ 10541}#
+
#{e2\ 10542}#)
+ (if
(#{id?\ 9076}#
+
#{name\ 10539}#)
+
(#{valid-bound-ids?\ 9139}#
+
(#{lambda-var-list\ 9191}#
+
#{args\ 10540}#))
#f))
- #{tmp\
822}#)
+ #{tmp\
10532}#)
#f)
- (apply (lambda (#{_\
828}#
-
#{name\ 829}#
-
#{args\ 830}#
- #{e1\
831}#
- #{e2\
832}#)
+ (apply (lambda (#{_\
10550}#
+
#{name\ 10551}#
+
#{args\ 10552}#
+ #{e1\
10553}#
+ #{e2\
10554}#)
(values
'define-form
- (#{wrap\
159}#
- #{name\
829}#
- #{w\ 797}#
- #{mod\
800}#)
-
(#{decorate-source\ 94}#
+ (#{wrap\
9145}#
+ #{name\
10551}#
+ #{w\
10462}#
+ #{mod\
10465}#)
+
(#{decorate-source\ 8994}#
(cons
'#(syntax-object
lambda
((top)
@@ -3535,11 +3610,11 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10545"
+
"i10546"
+
"i10547"
+
"i10548"
+
"i10549"))
#(ribcage
()
()
@@ -3561,12 +3636,12 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10498"
+
"i10499"
+
"i10500"
+
"i10501"
+
"i10502"
+
"i10503"))
#(ribcage
()
()
@@ -3574,7 +3649,7 @@
#(ribcage
#(first)
#((top))
-
#("i"))
+
#("i10490"))
#(ribcage
()
()
@@ -3602,13 +3677,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10467"
+
"i10468"
+
"i10469"
+
"i10470"
+
"i10471"
+
"i10472"
+
"i10473"))
#(ribcage
(lambda-var-list
gen-var
@@ -3712,6 +3787,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+
build-dynlet
build-conditional
build-application
build-void
@@ -3843,160 +3919,162 @@
(top)
(top)
(top)
+
(top)
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
("i9190"
+
"i9188"
+
"i9186"
+
"i9184"
+
"i9182"
+
"i9180"
+
"i9178"
+
"i9176"
+
"i9174"
+
"i9172"
+
"i9170"
+
"i9168"
+
"i9166"
+
"i9164"
+
"i9162"
+
"i9160"
+
"i9158"
+
"i9156"
+
"i9154"
+
"i9152"
+
"i9150"
+
"i9148"
+
"i9146"
+
"i9144"
+
"i9142"
+
"i9140"
+
"i9138"
+
"i9136"
+
"i9134"
+
"i9132"
+
"i9130"
+
"i9128"
+
"i9126"
+
"i9124"
+
"i9122"
+
"i9120"
+
"i9119"
+
"i9118"
+
"i9116"
+
"i9115"
+
"i9114"
+
"i9113"
+
"i9112"
+
"i9110"
+
"i9108"
+
"i9106"
+
"i9104"
+
"i9102"
+
"i9100"
+
"i9098"
+
"i9096"
+
"i9093"
+
"i9091"
+
"i9090"
+
"i9089"
+
"i9088"
+
"i9087"
+
"i9086"
+
"i9084"
+
"i9082"
+
"i9080"
+
"i9078"
+
"i9077"
+
"i9075"
+
"i9073"
+
"i9071"
+
"i9069"
+
"i9067"
+
"i9065"
+
"i9063"
+
"i9062"
+
"i9060"
+
"i9058"
+
"i9057"
+
"i9056"
+
"i9054"
+
"i9053"
+
"i9051"
+
"i9049"
+
"i9047"
+
"i9045"
+
"i9043"
+
"i9041"
+
"i9039"
+
"i9037"
+
"i9035"
+
"i9033"
+
"i9031"
+
"i9029"
+
"i9027"
+
"i9025"
+
"i9023"
+
"i9021"
+
"i9019"
+
"i9017"
+
"i9015"
+
"i9013"
+
"i9011"
+
"i9009"
+
"i9007"
+
"i9005"
+
"i9003"
+
"i9001"
+
"i8999"
+
"i8997"
+
"i8995"
+
"i8993"
+
"i8991"
+
"i8989"
+
"i8988"
+
"i8986"
+
"i8984"
+
"i8982"
+
"i8980"
+
"i8978"
+
"i8976"
+
"i8974"
+
"i8972"))
#(ribcage
(define-structure
and-map*)
((top)
(top))
-
("i"
-
"i")))
+
("i8875"
+
"i8873")))
(hygiene
guile))
-
(#{wrap\ 159}#
-
(cons #{args\ 830}#
-
(cons #{e1\ 831}#
-
#{e2\ 832}#))
-
#{w\ 797}#
-
#{mod\ 800}#))
- #{s\
798}#)
+
(#{wrap\ 9145}#
+
(cons #{args\ 10552}#
+
(cons #{e1\ 10553}#
+
#{e2\ 10554}#))
+
#{w\ 10462}#
+
#{mod\ 10465}#))
+ #{s\
10463}#)
'(())
- #{s\ 798}#
- #{mod\
800}#))
- #{tmp\ 822}#)
- ((lambda (#{tmp\ 834}#)
- (if (if #{tmp\ 834}#
- (apply
(lambda (#{_\ 835}#
-
#{name\ 836}#)
-
(#{id?\ 131}#
-
#{name\ 836}#))
- #{tmp\
834}#)
+ #{s\ 10463}#
+ #{mod\
10465}#))
+ #{tmp\ 10532}#)
+ ((lambda (#{tmp\
10557}#)
+ (if (if #{tmp\
10557}#
+ (apply
(lambda (#{_\ 10560}#
+
#{name\ 10561}#)
+
(#{id?\ 9076}#
+
#{name\ 10561}#))
+ #{tmp\
10557}#)
#f)
- (apply (lambda
(#{_\ 837}#
-
#{name\ 838}#)
+ (apply (lambda
(#{_\ 10564}#
+
#{name\ 10565}#)
(values
'define-form
-
(#{wrap\ 159}#
-
#{name\ 838}#
- #{w\
797}#
-
#{mod\ 800}#)
+
(#{wrap\ 9145}#
+
#{name\ 10565}#
+ #{w\
10462}#
+
#{mod\ 10465}#)
'(#(syntax-object
if
((top)
@@ -4005,8 +4083,8 @@
name)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i10562"
+
"i10563"))
#(ribcage
()
()
@@ -4028,12 +4106,12 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10498"
+
"i10499"
+
"i10500"
+
"i10501"
+
"i10502"
+
"i10503"))
#(ribcage
()
()
@@ -4041,7 +4119,7 @@
#(ribcage
#(first)
#((top))
-
#("i"))
+
#("i10490"))
#(ribcage
()
()
@@ -4069,13 +4147,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10467"
+
"i10468"
+
"i10469"
+
"i10470"
+
"i10471"
+
"i10472"
+
"i10473"))
#(ribcage
(lambda-var-list
gen-var
@@ -4179,6 +4257,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+
build-dynlet
build-conditional
build-application
build-void
@@ -4310,131 +4389,133 @@
(top)
(top)
(top)
+
(top)
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
("i9190"
+
"i9188"
+
"i9186"
+
"i9184"
+
"i9182"
+
"i9180"
+
"i9178"
+
"i9176"
+
"i9174"
+
"i9172"
+
"i9170"
+
"i9168"
+
"i9166"
+
"i9164"
+
"i9162"
+
"i9160"
+
"i9158"
+
"i9156"
+
"i9154"
+
"i9152"
+
"i9150"
+
"i9148"
+
"i9146"
+
"i9144"
+
"i9142"
+
"i9140"
+
"i9138"
+
"i9136"
+
"i9134"
+
"i9132"
+
"i9130"
+
"i9128"
+
"i9126"
+
"i9124"
+
"i9122"
+
"i9120"
+
"i9119"
+
"i9118"
+
"i9116"
+
"i9115"
+
"i9114"
+
"i9113"
+
"i9112"
+
"i9110"
+
"i9108"
+
"i9106"
+
"i9104"
+
"i9102"
+
"i9100"
+
"i9098"
+
"i9096"
+
"i9093"
+
"i9091"
+
"i9090"
+
"i9089"
+
"i9088"
+
"i9087"
+
"i9086"
+
"i9084"
+
"i9082"
+
"i9080"
+
"i9078"
+
"i9077"
+
"i9075"
+
"i9073"
+
"i9071"
+
"i9069"
+
"i9067"
+
"i9065"
+
"i9063"
+
"i9062"
+
"i9060"
+
"i9058"
+
"i9057"
+
"i9056"
+
"i9054"
+
"i9053"
+
"i9051"
+
"i9049"
+
"i9047"
+
"i9045"
+
"i9043"
+
"i9041"
+
"i9039"
+
"i9037"
+
"i9035"
+
"i9033"
+
"i9031"
+
"i9029"
+
"i9027"
+
"i9025"
+
"i9023"
+
"i9021"
+
"i9019"
+
"i9017"
+
"i9015"
+
"i9013"
+
"i9011"
+
"i9009"
+
"i9007"
+
"i9005"
+
"i9003"
+
"i9001"
+
"i8999"
+
"i8997"
+
"i8995"
+
"i8993"
+
"i8991"
+
"i8989"
+
"i8988"
+
"i8986"
+
"i8984"
+
"i8982"
+
"i8980"
+
"i8978"
+
"i8976"
+
"i8974"
+
"i8972"))
#(ribcage
(define-structure
and-map*)
((top)
(top))
-
("i"
-
"i")))
+
("i8875"
+
"i8873")))
(hygiene
guile))
#(syntax-object
@@ -4445,8 +4526,8 @@
name)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i10562"
+
"i10563"))
#(ribcage
()
()
@@ -4468,12 +4549,12 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10498"
+
"i10499"
+
"i10500"
+
"i10501"
+
"i10502"
+
"i10503"))
#(ribcage
()
()
@@ -4481,7 +4562,7 @@
#(ribcage
#(first)
#((top))
-
#("i"))
+
#("i10490"))
#(ribcage
()
()
@@ -4509,13 +4590,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10467"
+
"i10468"
+
"i10469"
+
"i10470"
+
"i10471"
+
"i10472"
+
"i10473"))
#(ribcage
(lambda-var-list
gen-var
@@ -4619,6 +4700,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+
build-dynlet
build-conditional
build-application
build-void
@@ -4750,131 +4832,133 @@
(top)
(top)
(top)
+
(top)
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
("i9190"
+
"i9188"
+
"i9186"
+
"i9184"
+
"i9182"
+
"i9180"
+
"i9178"
+
"i9176"
+
"i9174"
+
"i9172"
+
"i9170"
+
"i9168"
+
"i9166"
+
"i9164"
+
"i9162"
+
"i9160"
+
"i9158"
+
"i9156"
+
"i9154"
+
"i9152"
+
"i9150"
+
"i9148"
+
"i9146"
+
"i9144"
+
"i9142"
+
"i9140"
+
"i9138"
+
"i9136"
+
"i9134"
+
"i9132"
+
"i9130"
+
"i9128"
+
"i9126"
+
"i9124"
+
"i9122"
+
"i9120"
+
"i9119"
+
"i9118"
+
"i9116"
+
"i9115"
+
"i9114"
+
"i9113"
+
"i9112"
+
"i9110"
+
"i9108"
+
"i9106"
+
"i9104"
+
"i9102"
+
"i9100"
+
"i9098"
+
"i9096"
+
"i9093"
+
"i9091"
+
"i9090"
+
"i9089"
+
"i9088"
+
"i9087"
+
"i9086"
+
"i9084"
+
"i9082"
+
"i9080"
+
"i9078"
+
"i9077"
+
"i9075"
+
"i9073"
+
"i9071"
+
"i9069"
+
"i9067"
+
"i9065"
+
"i9063"
+
"i9062"
+
"i9060"
+
"i9058"
+
"i9057"
+
"i9056"
+
"i9054"
+
"i9053"
+
"i9051"
+
"i9049"
+
"i9047"
+
"i9045"
+
"i9043"
+
"i9041"
+
"i9039"
+
"i9037"
+
"i9035"
+
"i9033"
+
"i9031"
+
"i9029"
+
"i9027"
+
"i9025"
+
"i9023"
+
"i9021"
+
"i9019"
+
"i9017"
+
"i9015"
+
"i9013"
+
"i9011"
+
"i9009"
+
"i9007"
+
"i9005"
+
"i9003"
+
"i9001"
+
"i8999"
+
"i8997"
+
"i8995"
+
"i8993"
+
"i8991"
+
"i8989"
+
"i8988"
+
"i8986"
+
"i8984"
+
"i8982"
+
"i8980"
+
"i8978"
+
"i8976"
+
"i8974"
+
"i8972"))
#(ribcage
(define-structure
and-map*)
((top)
(top))
-
("i"
-
"i")))
+
("i8875"
+
"i8873")))
(hygiene
guile))
#(syntax-object
@@ -4885,8 +4969,8 @@
name)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i10562"
+
"i10563"))
#(ribcage
()
()
@@ -4908,12 +4992,12 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10498"
+
"i10499"
+
"i10500"
+
"i10501"
+
"i10502"
+
"i10503"))
#(ribcage
()
()
@@ -4921,7 +5005,7 @@
#(ribcage
#(first)
#((top))
-
#("i"))
+
#("i10490"))
#(ribcage
()
()
@@ -4949,13 +5033,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i10467"
+
"i10468"
+
"i10469"
+
"i10470"
+
"i10471"
+
"i10472"
+
"i10473"))
#(ribcage
(lambda-var-list
gen-var
@@ -5059,6 +5143,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+
build-dynlet
build-conditional
build-application
build-void
@@ -5190,3782 +5275,3780 @@
(top)
(top)
(top)
+
(top)
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
("i9190"
+
"i9188"
+
"i9186"
+
"i9184"
+
"i9182"
+
"i9180"
+
"i9178"
+
"i9176"
+
"i9174"
+
"i9172"
+
"i9170"
+
"i9168"
+
"i9166"
+
"i9164"
+
"i9162"
+
"i9160"
+
"i9158"
+
"i9156"
+
"i9154"
+
"i9152"
+
"i9150"
+
"i9148"
+
"i9146"
+
"i9144"
+
"i9142"
+
"i9140"
+
"i9138"
+
"i9136"
+
"i9134"
+
"i9132"
+
"i9130"
+
"i9128"
+
"i9126"
+
"i9124"
+
"i9122"
+
"i9120"
+
"i9119"
+
"i9118"
+
"i9116"
+
"i9115"
+
"i9114"
+
"i9113"
+
"i9112"
+
"i9110"
+
"i9108"
+
"i9106"
+
"i9104"
+
"i9102"
+
"i9100"
+
"i9098"
+
"i9096"
+
"i9093"
+
"i9091"
+
"i9090"
+
"i9089"
+
"i9088"
+
"i9087"
+
"i9086"
+
"i9084"
+
"i9082"
+
"i9080"
+
"i9078"
+
"i9077"
+
"i9075"
+
"i9073"
+
"i9071"
+
"i9069"
+
"i9067"
+
"i9065"
+
"i9063"
+
"i9062"
+
"i9060"
+
"i9058"
+
"i9057"
+
"i9056"
+
"i9054"
+
"i9053"
+
"i9051"
+
"i9049"
+
"i9047"
+
"i9045"
+
"i9043"
+
"i9041"
+
"i9039"
+
"i9037"
+
"i9035"
+
"i9033"
+
"i9031"
+
"i9029"
+
"i9027"
+
"i9025"
+
"i9023"
+
"i9021"
+
"i9019"
+
"i9017"
+
"i9015"
+
"i9013"
+
"i9011"
+
"i9009"
+
"i9007"
+
"i9005"
+
"i9003"
+
"i9001"
+
"i8999"
+
"i8997"
+
"i8995"
+
"i8993"
+
"i8991"
+
"i8989"
+
"i8988"
+
"i8986"
+
"i8984"
+
"i8982"
+
"i8980"
+
"i8978"
+
"i8976"
+
"i8974"
+
"i8972"))
#(ribcage
(define-structure
and-map*)
((top)
(top))
-
("i"
-
"i")))
+
("i8875"
+
"i8873")))
(hygiene
guile)))
'(())
- #{s\
798}#
- #{mod\
800}#))
- #{tmp\
834}#)
+ #{s\
10463}#
+ #{mod\
10465}#))
+ #{tmp\
10557}#)
(syntax-violation
#f
"source
expression failed to match any pattern"
- #{tmp\ 814}#)))
+ #{tmp\
10518}#)))
($sc-dispatch
- #{tmp\ 814}#
+ #{tmp\ 10518}#
'(any any)))))
($sc-dispatch
- #{tmp\ 814}#
+ #{tmp\ 10518}#
'(any (any . any)
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 814}#
+ #{tmp\ 10518}#
'(any any any))))
- #{e\ 795}#)
- (if (memv #{ftype\ 806}#
+ #{e\ 10460}#)
+ (if (memv #{ftype\ 10492}#
'(define-syntax))
- ((lambda (#{tmp\ 839}#)
- ((lambda (#{tmp\ 840}#)
- (if (if #{tmp\ 840}#
- (apply (lambda (#{_\
841}#
-
#{name\ 842}#
-
#{val\ 843}#)
- (#{id?\ 131}#
- #{name\
842}#))
- #{tmp\ 840}#)
+ ((lambda (#{tmp\ 10568}#)
+ ((lambda (#{tmp\ 10569}#)
+ (if (if #{tmp\ 10569}#
+ (apply (lambda (#{_\
10573}#
+
#{name\ 10574}#
+
#{val\ 10575}#)
+ (#{id?\
9076}#
+ #{name\
10574}#))
+ #{tmp\ 10569}#)
#f)
- (apply (lambda (#{_\ 844}#
- #{name\
845}#
- #{val\
846}#)
+ (apply (lambda (#{_\
10579}#
+ #{name\
10580}#
+ #{val\
10581}#)
(values
'define-syntax-form
- #{name\ 845}#
- #{val\ 846}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#))
- #{tmp\ 840}#)
+ #{name\ 10580}#
+ #{val\ 10581}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\
10465}#))
+ #{tmp\ 10569}#)
(syntax-violation
#f
"source expression
failed to match any pattern"
- #{tmp\ 839}#)))
+ #{tmp\ 10568}#)))
($sc-dispatch
- #{tmp\ 839}#
+ #{tmp\ 10568}#
'(any any any))))
- #{e\ 795}#)
+ #{e\ 10460}#)
(values
'call
#f
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#))))))))))))))
- (if (#{syntax-object?\ 115}# #{e\ 795}#)
- (#{syntax-type\ 165}#
- (#{syntax-object-expression\ 116}# #{e\ 795}#)
- #{r\ 796}#
- (#{join-wraps\ 150}#
- #{w\ 797}#
- (#{syntax-object-wrap\ 117}# #{e\ 795}#))
- #{s\ 798}#
- #{rib\ 799}#
- (let ((#{t\ 847}# (#{syntax-object-module\ 118}#
- #{e\ 795}#)))
- (if #{t\ 847}# #{t\ 847}# #{mod\ 800}#))
- #{for-car?\ 801}#)
- (if (self-evaluating? #{e\ 795}#)
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#))))))))))))))
+ (if (#{syntax-object?\ 9040}# #{e\ 10460}#)
+ (#{syntax-type\ 9157}#
+ (#{syntax-object-expression\ 9042}# #{e\ 10460}#)
+ #{r\ 10461}#
+ (#{join-wraps\ 9127}#
+ #{w\ 10462}#
+ (#{syntax-object-wrap\ 9044}# #{e\ 10460}#))
+ #{s\ 10463}#
+ #{rib\ 10464}#
+ (let ((#{t\ 10587}#
+ (#{syntax-object-module\ 9046}# #{e\ 10460}#)))
+ (if #{t\ 10587}# #{t\ 10587}# #{mod\ 10465}#))
+ #{for-car?\ 10466}#)
+ (if (self-evaluating? #{e\ 10460}#)
(values
'constant
#f
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)
(values
'other
#f
- #{e\ 795}#
- #{w\ 797}#
- #{s\ 798}#
- #{mod\ 800}#)))))))
- (#{chi-when-list\ 164}#
- (lambda (#{e\ 848}# #{when-list\ 849}# #{w\ 850}#)
- (letrec ((#{f\ 851}# (lambda (#{when-list\ 852}#
- #{situations\ 853}#)
- (if (null? #{when-list\ 852}#)
- #{situations\ 853}#
- (#{f\ 851}# (cdr #{when-list\ 852}#)
- (cons (let ((#{x\ 854}#
(car #{when-list\ 852}#)))
- (if (#{free-id=?\
154}#
- #{x\ 854}#
-
'#(syntax-object
- compile
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
-
#((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
-
when-list
-
situations)
- #((top)
- (top)
-
(top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
-
when-list
- w)
- #((top)
- (top)
-
(top))
- #("i"
- "i"
- "i"))
- #(ribcage
-
(lambda-var-list
-
gen-var
- strip
-
chi-lambda-case
-
lambda*-formals
-
chi-simple-lambda
-
lambda-formals
-
ellipsis?
-
chi-void
-
eval-local-transformer
-
chi-local-syntax
-
chi-body
-
chi-macro
-
chi-application
-
chi-expr
- chi
-
chi-top
-
syntax-type
-
chi-when-list
-
chi-install-global
-
chi-top-sequence
-
chi-sequence
-
source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
-
bound-id=?
-
free-id=?
-
id-var-name
-
same-marks?
-
join-marks
-
join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
-
new-mark
-
anti-mark
-
the-anti-mark
-
top-marked?
-
top-wrap
-
empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
-
ribcage?
-
make-ribcage
-
gen-labels
-
gen-label
-
make-rename
-
rename-marks
-
rename-new
-
rename-old
-
subst-rename?
-
wrap-subst
-
wrap-marks
-
make-wrap
-
id-sym-name&marks
-
id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
-
lookup
-
macros-only-env
-
extend-var-env
-
extend-env
-
null-env
-
binding-value
-
binding-type
-
make-binding
-
arg-check
-
source-annotation
-
no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
-
build-let
-
build-sequence
-
build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
maybe-name-value!
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-conditional
-
build-application
-
build-void
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
-
gensym-hook
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
*mode*
-
noexpand)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
-
(define-structure
-
and-map*)
- ((top)
- (top))
- ("i"
- "i")))
- (hygiene
- guile)))
- 'compile
- (if
(#{free-id=?\ 154}#
- #{x\ 854}#
-
'#(syntax-object
- load
- ((top)
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(x)
-
#((top))
-
#("i"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(f
-
when-list
-
situations)
-
#((top)
-
(top)
-
(top))
- #("i"
- "i"
-
"i"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(e
-
when-list
- w)
-
#((top)
-
(top)
-
(top))
- #("i"
- "i"
-
"i"))
-
#(ribcage
-
(lambda-var-list
-
gen-var
-
strip
-
chi-lambda-case
-
lambda*-formals
-
chi-simple-lambda
-
lambda-formals
-
ellipsis?
-
chi-void
-
eval-local-transformer
-
chi-local-syntax
-
chi-body
-
chi-macro
-
chi-application
-
chi-expr
- chi
-
chi-top
-
syntax-type
-
chi-when-list
-
chi-install-global
-
chi-top-sequence
-
chi-sequence
-
source-wrap
-
wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
-
bound-id=?
-
free-id=?
-
id-var-name
-
same-marks?
-
join-marks
-
join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
-
new-mark
-
anti-mark
-
the-anti-mark
-
top-marked?
-
top-wrap
-
empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
-
ribcage?
-
make-ribcage
-
gen-labels
-
gen-label
-
make-rename
-
rename-marks
-
rename-new
-
rename-old
-
subst-rename?
-
wrap-subst
-
wrap-marks
-
make-wrap
-
id-sym-name&marks
-
id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
-
lookup
-
macros-only-env
-
extend-var-env
-
extend-env
-
null-env
-
binding-value
-
binding-type
-
make-binding
-
arg-check
-
source-annotation
-
no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
-
build-let
-
build-sequence
-
build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
maybe-name-value!
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-conditional
-
build-application
-
build-void
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
-
gensym-hook
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
*mode*
-
noexpand)
-
((top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
-
"i"))
-
#(ribcage
-
(define-structure
-
and-map*)
-
((top)
-
(top))
- ("i"
-
"i")))
- (hygiene
-
guile)))
- 'load
- (if
(#{free-id=?\ 154}#
- #{x\
854}#
-
'#(syntax-object
- eval
- ((top)
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
-
#(x)
-
#((top))
-
#("i"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(f
-
when-list
-
situations)
-
#((top)
-
(top)
-
(top))
-
#("i"
-
"i"
-
"i"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(e
-
when-list
-
w)
-
#((top)
-
(top)
-
(top))
-
#("i"
-
"i"
-
"i"))
-
#(ribcage
-
(lambda-var-list
-
gen-var
-
strip
-
chi-lambda-case
-
lambda*-formals
-
chi-simple-lambda
-
lambda-formals
-
ellipsis?
-
chi-void
-
eval-local-transformer
-
chi-local-syntax
-
chi-body
-
chi-macro
-
chi-application
-
chi-expr
-
chi
-
chi-top
-
syntax-type
-
chi-when-list
-
chi-install-global
-
chi-top-sequence
-
chi-sequence
-
source-wrap
-
wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
-
bound-id=?
-
free-id=?
-
id-var-name
-
same-marks?
-
join-marks
-
join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
-
new-mark
-
anti-mark
-
the-anti-mark
-
top-marked?
-
top-wrap
-
empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
-
ribcage?
-
make-ribcage
-
gen-labels
-
gen-label
-
make-rename
-
rename-marks
-
rename-new
-
rename-old
-
subst-rename?
-
wrap-subst
-
wrap-marks
-
make-wrap
-
id-sym-name&marks
-
id-sym-name
-
id?
-
nonsymbol-id?
-
global-extend
-
lookup
-
macros-only-env
-
extend-var-env
-
extend-env
-
null-env
-
binding-value
-
binding-type
-
make-binding
-
arg-check
-
source-annotation
-
no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
-
build-let
-
build-sequence
-
build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
maybe-name-value!
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-conditional
-
build-application
-
build-void
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
-
gensym-hook
-
local-eval-hook
-
top-level-eval-hook
-
fx<
-
fx=
-
fx-
-
fx+
-
*mode*
-
noexpand)
-
((top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top))
-
("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
-
#(ribcage
-
(define-structure
-
and-map*)
-
((top)
-
(top))
-
("i"
-
"i")))
-
(hygiene
-
guile)))
- 'eval
-
(syntax-violation
- 'eval-when
- "invalid
situation"
- #{e\ 848}#
- (#{wrap\
159}#
- #{x\
854}#
- #{w\
850}#
- #f))))))
- #{situations\
853}#))))))
- (#{f\ 851}# #{when-list\ 849}# (quote ())))))
- (#{chi-install-global\ 163}#
- (lambda (#{name\ 855}# #{e\ 856}#)
- (#{build-global-definition\ 104}#
+ #{e\ 10460}#
+ #{w\ 10462}#
+ #{s\ 10463}#
+ #{mod\ 10465}#)))))))
+ (#{chi-when-list\ 9155}#
+ (lambda (#{e\ 10592}# #{when-list\ 10593}# #{w\ 10594}#)
+ (letrec ((#{f\ 10601}#
+ (lambda (#{when-list\ 10602}# #{situations\ 10603}#)
+ (if (null? #{when-list\ 10602}#)
+ #{situations\ 10603}#
+ (#{f\ 10601}#
+ (cdr #{when-list\ 10602}#)
+ (cons (let ((#{x\ 10605}#
+ (car #{when-list\ 10602}#)))
+ (if (#{free-id=?\ 9135}#
+ #{x\ 10605}#
+ '#(syntax-object
+ compile
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i10604"))
+ #(ribcage () () ())
+ #(ribcage
+ #(f when-list situations)
+ #((top) (top) (top))
+ #("i10598"
+ "i10599"
+ "i10600"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e when-list w)
+ #((top) (top) (top))
+ #("i10595"
+ "i10596"
+ "i10597"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+
set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
+ #(ribcage
+ (define-structure and-map*)
+ ((top) (top))
+ ("i8875" "i8873")))
+ (hygiene guile)))
+ 'compile
+ (if (#{free-id=?\ 9135}#
+ #{x\ 10605}#
+ '#(syntax-object
+ load
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i10604"))
+ #(ribcage () () ())
+ #(ribcage
+ #(f when-list situations)
+ #((top) (top) (top))
+ #("i10598"
+ "i10599"
+ "i10600"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e when-list w)
+ #((top) (top) (top))
+ #("i10595"
+ "i10596"
+ "i10597"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+
set-syntax-object-module!
+ set-syntax-object-wrap!
+
set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+
syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+
build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top) (top))
+ ("i8875" "i8873")))
+ (hygiene guile)))
+ 'load
+ (if (#{free-id=?\ 9135}#
+ #{x\ 10605}#
+ '#(syntax-object
+ eval
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i10604"))
+ #(ribcage () () ())
+ #(ribcage
+ #(f
+ when-list
+ situations)
+ #((top) (top) (top))
+ #("i10598"
+ "i10599"
+ "i10600"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e when-list w)
+ #((top) (top) (top))
+ #("i10595"
+ "i10596"
+ "i10597"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+
eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+
set-syntax-object-module!
+
set-syntax-object-wrap!
+
set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+
syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+
build-global-definition
+ maybe-name-value!
+
build-global-assignment
+
build-global-reference
+ analyze-variable
+
build-lexical-assignment
+
build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top) (top))
+ ("i8875" "i8873")))
+ (hygiene guile)))
+ 'eval
+ (syntax-violation
+ 'eval-when
+ "invalid situation"
+ #{e\ 10592}#
+ (#{wrap\ 9145}#
+ #{x\ 10605}#
+ #{w\ 10594}#
+ #f))))))
+ #{situations\ 10603}#))))))
+ (#{f\ 10601}# #{when-list\ 10593}# (quote ())))))
+ (#{chi-install-global\ 9153}#
+ (lambda (#{name\ 10613}# #{e\ 10614}#)
+ (#{build-global-definition\ 9016}#
#f
- #{name\ 855}#
- (if (let ((#{v\ 857}# (module-variable
- (current-module)
- #{name\ 855}#)))
- (if #{v\ 857}#
- (if (variable-bound? #{v\ 857}#)
- (if (macro? (variable-ref #{v\ 857}#))
- (not (eq? (macro-type (variable-ref #{v\ 857}#))
- 'syncase-macro))
- #f)
- #f)
- #f))
- (#{build-application\ 96}#
+ #{name\ 10613}#
+ (#{build-application\ 8998}#
+ #f
+ (#{build-primref\ 9024}#
#f
- (#{build-primref\ 108}#
- #f
- 'make-extended-syncase-macro)
- (list (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}# #f (quote module-ref))
- (list (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}#
- #f
- 'current-module)
- '())
- (#{build-data\ 109}# #f #{name\ 855}#)))
- (#{build-data\ 109}# #f (quote macro))
- (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}# #f (quote cons))
- (list #{e\ 856}#
- (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}#
- #f
- 'module-name)
- (list (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}#
- #f
- 'current-module)
- '())))))))
- (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}#
- #f
- 'make-syncase-macro)
- (list (#{build-data\ 109}# #f (quote macro))
- (#{build-application\ 96}#
- #f
- (#{build-primref\ 108}# #f (quote cons))
- (list #{e\ 856}#
- (#{build-application\ 96}#
+ 'make-syntax-transformer)
+ (list (#{build-data\ 9026}# #f #{name\ 10613}#)
+ (#{build-data\ 9026}# #f (quote macro))
+ (#{build-application\ 8998}#
+ #f
+ (#{build-primref\ 9024}# #f (quote cons))
+ (list #{e\ 10614}#
+ (#{build-application\ 8998}#
+ #f
+ (#{build-primref\ 9024}#
#f
- (#{build-primref\ 108}#
- #f
- 'module-name)
- (list (#{build-application\ 96}#
+ 'module-name)
+ (list (#{build-application\ 8998}#
+ #f
+ (#{build-primref\ 9024}#
#f
- (#{build-primref\ 108}#
- #f
- 'current-module)
- '())))))))))))
- (#{chi-top-sequence\ 162}#
- (lambda (#{body\ 858}#
- #{r\ 859}#
- #{w\ 860}#
- #{s\ 861}#
- #{m\ 862}#
- #{esew\ 863}#
- #{mod\ 864}#)
- (#{build-sequence\ 110}#
- #{s\ 861}#
- (letrec ((#{dobody\ 865}#
- (lambda (#{body\ 866}#
- #{r\ 867}#
- #{w\ 868}#
- #{m\ 869}#
- #{esew\ 870}#
- #{mod\ 871}#)
- (if (null? #{body\ 866}#)
- '()
- (let ((#{first\ 872}#
- (#{chi-top\ 166}#
- (car #{body\ 866}#)
- #{r\ 867}#
- #{w\ 868}#
- #{m\ 869}#
- #{esew\ 870}#
- #{mod\ 871}#)))
- (cons #{first\ 872}#
- (#{dobody\ 865}#
- (cdr #{body\ 866}#)
- #{r\ 867}#
- #{w\ 868}#
- #{m\ 869}#
- #{esew\ 870}#
- #{mod\ 871}#)))))))
- (#{dobody\ 865}#
- #{body\ 858}#
- #{r\ 859}#
- #{w\ 860}#
- #{m\ 862}#
- #{esew\ 863}#
- #{mod\ 864}#)))))
- (#{chi-sequence\ 161}#
- (lambda (#{body\ 873}#
- #{r\ 874}#
- #{w\ 875}#
- #{s\ 876}#
- #{mod\ 877}#)
- (#{build-sequence\ 110}#
- #{s\ 876}#
- (letrec ((#{dobody\ 878}#
- (lambda (#{body\ 879}#
- #{r\ 880}#
- #{w\ 881}#
- #{mod\ 882}#)
- (if (null? #{body\ 879}#)
+ 'current-module)
+ '()))))))))))
+ (#{chi-top-sequence\ 9151}#
+ (lambda (#{body\ 10628}#
+ #{r\ 10629}#
+ #{w\ 10630}#
+ #{s\ 10631}#
+ #{m\ 10632}#
+ #{esew\ 10633}#
+ #{mod\ 10634}#)
+ (#{build-sequence\ 9028}#
+ #{s\ 10631}#
+ (letrec ((#{dobody\ 10651}#
+ (lambda (#{body\ 10652}#
+ #{r\ 10653}#
+ #{w\ 10654}#
+ #{m\ 10655}#
+ #{esew\ 10656}#
+ #{mod\ 10657}#
+ #{module\ 10658}#
+ #{out\ 10659}#)
+ (if (null? #{body\ 10652}#)
+ (reverse #{out\ 10659}#)
+ (let ((#{first\ 10662}#
+ (#{chi-top\ 9159}#
+ (car #{body\ 10652}#)
+ #{r\ 10653}#
+ #{w\ 10654}#
+ #{m\ 10655}#
+ #{esew\ 10656}#
+ #{mod\ 10657}#)))
+ (let ((#{new-module\ 10664}#
+ (current-module)))
+ (#{dobody\ 10651}#
+ (cdr #{body\ 10652}#)
+ #{r\ 10653}#
+ #{w\ 10654}#
+ #{m\ 10655}#
+ #{esew\ 10656}#
+ (if (eq? #{module\ 10658}#
+ #{new-module\ 10664}#)
+ #{mod\ 10657}#
+ (cons 'hygiene
+ (module-name
+ #{new-module\ 10664}#)))
+ #{new-module\ 10664}#
+ (cons #{first\ 10662}#
+ #{out\ 10659}#))))))))
+ (#{dobody\ 10651}#
+ #{body\ 10628}#
+ #{r\ 10629}#
+ #{w\ 10630}#
+ #{m\ 10632}#
+ #{esew\ 10633}#
+ #{mod\ 10634}#
+ (current-module)
+ '())))))
+ (#{chi-sequence\ 9149}#
+ (lambda (#{body\ 10665}#
+ #{r\ 10666}#
+ #{w\ 10667}#
+ #{s\ 10668}#
+ #{mod\ 10669}#)
+ (#{build-sequence\ 9028}#
+ #{s\ 10668}#
+ (letrec ((#{dobody\ 10680}#
+ (lambda (#{body\ 10681}#
+ #{r\ 10682}#
+ #{w\ 10683}#
+ #{mod\ 10684}#)
+ (if (null? #{body\ 10681}#)
'()
- (let ((#{first\ 883}#
- (#{chi\ 167}#
- (car #{body\ 879}#)
- #{r\ 880}#
- #{w\ 881}#
- #{mod\ 882}#)))
- (cons #{first\ 883}#
- (#{dobody\ 878}#
- (cdr #{body\ 879}#)
- #{r\ 880}#
- #{w\ 881}#
- #{mod\ 882}#)))))))
- (#{dobody\ 878}#
- #{body\ 873}#
- #{r\ 874}#
- #{w\ 875}#
- #{mod\ 877}#)))))
- (#{source-wrap\ 160}#
- (lambda (#{x\ 884}#
- #{w\ 885}#
- #{s\ 886}#
- #{defmod\ 887}#)
- (#{wrap\ 159}#
- (#{decorate-source\ 94}# #{x\ 884}# #{s\ 886}#)
- #{w\ 885}#
- #{defmod\ 887}#)))
- (#{wrap\ 159}#
- (lambda (#{x\ 888}# #{w\ 889}# #{defmod\ 890}#)
- (if (if (null? (#{wrap-marks\ 134}# #{w\ 889}#))
- (null? (#{wrap-subst\ 135}# #{w\ 889}#))
+ (let ((#{first\ 10686}#
+ (#{chi\ 9161}#
+ (car #{body\ 10681}#)
+ #{r\ 10682}#
+ #{w\ 10683}#
+ #{mod\ 10684}#)))
+ (cons #{first\ 10686}#
+ (#{dobody\ 10680}#
+ (cdr #{body\ 10681}#)
+ #{r\ 10682}#
+ #{w\ 10683}#
+ #{mod\ 10684}#)))))))
+ (#{dobody\ 10680}#
+ #{body\ 10665}#
+ #{r\ 10666}#
+ #{w\ 10667}#
+ #{mod\ 10669}#)))))
+ (#{source-wrap\ 9147}#
+ (lambda (#{x\ 10687}#
+ #{w\ 10688}#
+ #{s\ 10689}#
+ #{defmod\ 10690}#)
+ (#{wrap\ 9145}#
+ (#{decorate-source\ 8994}#
+ #{x\ 10687}#
+ #{s\ 10689}#)
+ #{w\ 10688}#
+ #{defmod\ 10690}#)))
+ (#{wrap\ 9145}#
+ (lambda (#{x\ 10695}# #{w\ 10696}# #{defmod\ 10697}#)
+ (if (if (null? (#{wrap-marks\ 9083}# #{w\ 10696}#))
+ (null? (#{wrap-subst\ 9085}# #{w\ 10696}#))
#f)
- #{x\ 888}#
- (if (#{syntax-object?\ 115}# #{x\ 888}#)
- (#{make-syntax-object\ 114}#
- (#{syntax-object-expression\ 116}# #{x\ 888}#)
- (#{join-wraps\ 150}#
- #{w\ 889}#
- (#{syntax-object-wrap\ 117}# #{x\ 888}#))
- (#{syntax-object-module\ 118}# #{x\ 888}#))
- (if (null? #{x\ 888}#)
- #{x\ 888}#
- (#{make-syntax-object\ 114}#
- #{x\ 888}#
- #{w\ 889}#
- #{defmod\ 890}#))))))
- (#{bound-id-member?\ 158}#
- (lambda (#{x\ 891}# #{list\ 892}#)
- (if (not (null? #{list\ 892}#))
- (let ((#{t\ 893}# (#{bound-id=?\ 155}#
- #{x\ 891}#
- (car #{list\ 892}#))))
- (if #{t\ 893}#
- #{t\ 893}#
- (#{bound-id-member?\ 158}#
- #{x\ 891}#
- (cdr #{list\ 892}#))))
+ #{x\ 10695}#
+ (if (#{syntax-object?\ 9040}# #{x\ 10695}#)
+ (#{make-syntax-object\ 9038}#
+ (#{syntax-object-expression\ 9042}# #{x\ 10695}#)
+ (#{join-wraps\ 9127}#
+ #{w\ 10696}#
+ (#{syntax-object-wrap\ 9044}# #{x\ 10695}#))
+ (#{syntax-object-module\ 9046}# #{x\ 10695}#))
+ (if (null? #{x\ 10695}#)
+ #{x\ 10695}#
+ (#{make-syntax-object\ 9038}#
+ #{x\ 10695}#
+ #{w\ 10696}#
+ #{defmod\ 10697}#))))))
+ (#{bound-id-member?\ 9143}#
+ (lambda (#{x\ 10710}# #{list\ 10711}#)
+ (if (not (null? #{list\ 10711}#))
+ (let ((#{t\ 10718}#
+ (#{bound-id=?\ 9137}#
+ #{x\ 10710}#
+ (car #{list\ 10711}#))))
+ (if #{t\ 10718}#
+ #{t\ 10718}#
+ (#{bound-id-member?\ 9143}#
+ #{x\ 10710}#
+ (cdr #{list\ 10711}#))))
#f)))
- (#{distinct-bound-ids?\ 157}#
- (lambda (#{ids\ 894}#)
- (letrec ((#{distinct?\ 895}#
- (lambda (#{ids\ 896}#)
- (let ((#{t\ 897}# (null? #{ids\ 896}#)))
- (if #{t\ 897}#
- #{t\ 897}#
- (if (not (#{bound-id-member?\ 158}#
- (car #{ids\ 896}#)
- (cdr #{ids\ 896}#)))
- (#{distinct?\ 895}# (cdr #{ids\ 896}#))
+ (#{distinct-bound-ids?\ 9141}#
+ (lambda (#{ids\ 10720}#)
+ (letrec ((#{distinct?\ 10724}#
+ (lambda (#{ids\ 10725}#)
+ (let ((#{t\ 10728}# (null? #{ids\ 10725}#)))
+ (if #{t\ 10728}#
+ #{t\ 10728}#
+ (if (not (#{bound-id-member?\ 9143}#
+ (car #{ids\ 10725}#)
+ (cdr #{ids\ 10725}#)))
+ (#{distinct?\ 10724}# (cdr #{ids\ 10725}#))
#f))))))
- (#{distinct?\ 895}# #{ids\ 894}#))))
- (#{valid-bound-ids?\ 156}#
- (lambda (#{ids\ 898}#)
- (if (letrec ((#{all-ids?\ 899}#
- (lambda (#{ids\ 900}#)
- (let ((#{t\ 901}# (null? #{ids\ 900}#)))
- (if #{t\ 901}#
- #{t\ 901}#
- (if (#{id?\ 131}# (car #{ids\ 900}#))
- (#{all-ids?\ 899}# (cdr #{ids\ 900}#))
+ (#{distinct?\ 10724}# #{ids\ 10720}#))))
+ (#{valid-bound-ids?\ 9139}#
+ (lambda (#{ids\ 10732}#)
+ (if (letrec ((#{all-ids?\ 10737}#
+ (lambda (#{ids\ 10738}#)
+ (let ((#{t\ 10741}# (null? #{ids\ 10738}#)))
+ (if #{t\ 10741}#
+ #{t\ 10741}#
+ (if (#{id?\ 9076}# (car #{ids\ 10738}#))
+ (#{all-ids?\ 10737}#
+ (cdr #{ids\ 10738}#))
#f))))))
- (#{all-ids?\ 899}# #{ids\ 898}#))
- (#{distinct-bound-ids?\ 157}# #{ids\ 898}#)
+ (#{all-ids?\ 10737}# #{ids\ 10732}#))
+ (#{distinct-bound-ids?\ 9141}# #{ids\ 10732}#)
#f)))
- (#{bound-id=?\ 155}#
- (lambda (#{i\ 902}# #{j\ 903}#)
- (if (if (#{syntax-object?\ 115}# #{i\ 902}#)
- (#{syntax-object?\ 115}# #{j\ 903}#)
+ (#{bound-id=?\ 9137}#
+ (lambda (#{i\ 10746}# #{j\ 10747}#)
+ (if (if (#{syntax-object?\ 9040}# #{i\ 10746}#)
+ (#{syntax-object?\ 9040}# #{j\ 10747}#)
#f)
- (if (eq? (#{syntax-object-expression\ 116}# #{i\ 902}#)
- (#{syntax-object-expression\ 116}# #{j\ 903}#))
- (#{same-marks?\ 152}#
- (#{wrap-marks\ 134}#
- (#{syntax-object-wrap\ 117}# #{i\ 902}#))
- (#{wrap-marks\ 134}#
- (#{syntax-object-wrap\ 117}# #{j\ 903}#)))
+ (if (eq? (#{syntax-object-expression\ 9042}# #{i\ 10746}#)
+ (#{syntax-object-expression\ 9042}# #{j\ 10747}#))
+ (#{same-marks?\ 9131}#
+ (#{wrap-marks\ 9083}#
+ (#{syntax-object-wrap\ 9044}# #{i\ 10746}#))
+ (#{wrap-marks\ 9083}#
+ (#{syntax-object-wrap\ 9044}# #{j\ 10747}#)))
#f)
- (eq? #{i\ 902}# #{j\ 903}#))))
- (#{free-id=?\ 154}#
- (lambda (#{i\ 904}# #{j\ 905}#)
- (if (eq? (let ((#{x\ 906}# #{i\ 904}#))
- (if (#{syntax-object?\ 115}# #{x\ 906}#)
- (#{syntax-object-expression\ 116}# #{x\ 906}#)
- #{x\ 906}#))
- (let ((#{x\ 907}# #{j\ 905}#))
- (if (#{syntax-object?\ 115}# #{x\ 907}#)
- (#{syntax-object-expression\ 116}# #{x\ 907}#)
- #{x\ 907}#)))
- (eq? (#{id-var-name\ 153}# #{i\ 904}# (quote (())))
- (#{id-var-name\ 153}# #{j\ 905}# (quote (()))))
+ (eq? #{i\ 10746}# #{j\ 10747}#))))
+ (#{free-id=?\ 9135}#
+ (lambda (#{i\ 10754}# #{j\ 10755}#)
+ (if (eq? (let ((#{x\ 10761}# #{i\ 10754}#))
+ (if (#{syntax-object?\ 9040}# #{x\ 10761}#)
+ (#{syntax-object-expression\ 9042}# #{x\ 10761}#)
+ #{x\ 10761}#))
+ (let ((#{x\ 10764}# #{j\ 10755}#))
+ (if (#{syntax-object?\ 9040}# #{x\ 10764}#)
+ (#{syntax-object-expression\ 9042}# #{x\ 10764}#)
+ #{x\ 10764}#)))
+ (eq? (#{id-var-name\ 9133}# #{i\ 10754}# (quote (())))
+ (#{id-var-name\ 9133}# #{j\ 10755}# (quote (()))))
#f)))
- (#{id-var-name\ 153}#
- (lambda (#{id\ 908}# #{w\ 909}#)
- (letrec ((#{search-vector-rib\ 912}#
- (lambda (#{sym\ 918}#
- #{subst\ 919}#
- #{marks\ 920}#
- #{symnames\ 921}#
- #{ribcage\ 922}#)
- (let ((#{n\ 923}# (vector-length
- #{symnames\ 921}#)))
- (letrec ((#{f\ 924}# (lambda (#{i\ 925}#)
- (if (#{fx=\ 88}#
- #{i\ 925}#
- #{n\ 923}#)
- (#{search\ 910}#
- #{sym\ 918}#
- (cdr #{subst\ 919}#)
- #{marks\ 920}#)
- (if (if (eq? (vector-ref
-
#{symnames\ 921}#
- #{i\
925}#)
- #{sym\
918}#)
- (#{same-marks?\
152}#
- #{marks\ 920}#
- (vector-ref
-
(#{ribcage-marks\ 141}#
- #{ribcage\
922}#)
- #{i\ 925}#))
- #f)
- (values
- (vector-ref
-
(#{ribcage-labels\ 142}#
- #{ribcage\
922}#)
- #{i\ 925}#)
- #{marks\ 920}#)
- (#{f\ 924}# (#{fx+\
86}#
- #{i\
925}#
- 1)))))))
- (#{f\ 924}# 0)))))
- (#{search-list-rib\ 911}#
- (lambda (#{sym\ 926}#
- #{subst\ 927}#
- #{marks\ 928}#
- #{symnames\ 929}#
- #{ribcage\ 930}#)
- (letrec ((#{f\ 931}# (lambda (#{symnames\ 932}#
- #{i\ 933}#)
- (if (null? #{symnames\
932}#)
- (#{search\ 910}#
- #{sym\ 926}#
- (cdr #{subst\ 927}#)
- #{marks\ 928}#)
- (if (if (eq? (car
#{symnames\ 932}#)
- #{sym\ 926}#)
- (#{same-marks?\
152}#
- #{marks\ 928}#
- (list-ref
-
(#{ribcage-marks\ 141}#
- #{ribcage\
930}#)
- #{i\ 933}#))
- #f)
- (values
- (list-ref
- (#{ribcage-labels\
142}#
- #{ribcage\ 930}#)
- #{i\ 933}#)
- #{marks\ 928}#)
- (#{f\ 931}# (cdr
#{symnames\ 932}#)
- (#{fx+\ 86}#
- #{i\ 933}#
- 1)))))))
- (#{f\ 931}# #{symnames\ 929}# 0))))
- (#{search\ 910}#
- (lambda (#{sym\ 934}# #{subst\ 935}# #{marks\ 936}#)
- (if (null? #{subst\ 935}#)
- (values #f #{marks\ 936}#)
- (let ((#{fst\ 937}# (car #{subst\ 935}#)))
- (if (eq? #{fst\ 937}# (quote shift))
- (#{search\ 910}#
- #{sym\ 934}#
- (cdr #{subst\ 935}#)
- (cdr #{marks\ 936}#))
- (let ((#{symnames\ 938}#
- (#{ribcage-symnames\ 140}#
- #{fst\ 937}#)))
- (if (vector? #{symnames\ 938}#)
- (#{search-vector-rib\ 912}#
- #{sym\ 934}#
- #{subst\ 935}#
- #{marks\ 936}#
- #{symnames\ 938}#
- #{fst\ 937}#)
- (#{search-list-rib\ 911}#
- #{sym\ 934}#
- #{subst\ 935}#
- #{marks\ 936}#
- #{symnames\ 938}#
- #{fst\ 937}#)))))))))
- (if (symbol? #{id\ 908}#)
- (let ((#{t\ 939}# (call-with-values
- (lambda ()
- (#{search\ 910}#
- #{id\ 908}#
- (#{wrap-subst\ 135}# #{w\ 909}#)
- (#{wrap-marks\ 134}# #{w\ 909}#)))
- (lambda (#{x\ 940}# . #{ignore\ 941}#)
- #{x\ 940}#))))
- (if #{t\ 939}# #{t\ 939}# #{id\ 908}#))
- (if (#{syntax-object?\ 115}# #{id\ 908}#)
- (let ((#{id\ 942}#
- (#{syntax-object-expression\ 116}# #{id\ 908}#))
- (#{w1\ 943}#
- (#{syntax-object-wrap\ 117}# #{id\ 908}#)))
- (let ((#{marks\ 944}#
- (#{join-marks\ 151}#
- (#{wrap-marks\ 134}# #{w\ 909}#)
- (#{wrap-marks\ 134}# #{w1\ 943}#))))
+ (#{id-var-name\ 9133}#
+ (lambda (#{id\ 10768}# #{w\ 10769}#)
+ (letrec ((#{search-vector-rib\ 10778}#
+ (lambda (#{sym\ 10790}#
+ #{subst\ 10791}#
+ #{marks\ 10792}#
+ #{symnames\ 10793}#
+ #{ribcage\ 10794}#)
+ (let ((#{n\ 10801}#
+ (vector-length #{symnames\ 10793}#)))
+ (letrec ((#{f\ 10804}#
+ (lambda (#{i\ 10805}#)
+ (if (#{fx=\ 8981}#
+ #{i\ 10805}#
+ #{n\ 10801}#)
+ (#{search\ 10774}#
+ #{sym\ 10790}#
+ (cdr #{subst\ 10791}#)
+ #{marks\ 10792}#)
+ (if (if (eq? (vector-ref
+ #{symnames\ 10793}#
+ #{i\ 10805}#)
+ #{sym\ 10790}#)
+ (#{same-marks?\ 9131}#
+ #{marks\ 10792}#
+ (vector-ref
+ (#{ribcage-marks\ 9103}#
+ #{ribcage\ 10794}#)
+ #{i\ 10805}#))
+ #f)
+ (values
+ (vector-ref
+ (#{ribcage-labels\ 9105}#
+ #{ribcage\ 10794}#)
+ #{i\ 10805}#)
+ #{marks\ 10792}#)
+ (#{f\ 10804}#
+ (#{fx+\ 8977}#
+ #{i\ 10805}#
+ 1)))))))
+ (#{f\ 10804}# 0)))))
+ (#{search-list-rib\ 10776}#
+ (lambda (#{sym\ 10813}#
+ #{subst\ 10814}#
+ #{marks\ 10815}#
+ #{symnames\ 10816}#
+ #{ribcage\ 10817}#)
+ (letrec ((#{f\ 10826}#
+ (lambda (#{symnames\ 10827}#
+ #{i\ 10828}#)
+ (if (null? #{symnames\ 10827}#)
+ (#{search\ 10774}#
+ #{sym\ 10813}#
+ (cdr #{subst\ 10814}#)
+ #{marks\ 10815}#)
+ (if (if (eq? (car #{symnames\
10827}#)
+ #{sym\ 10813}#)
+ (#{same-marks?\ 9131}#
+ #{marks\ 10815}#
+ (list-ref
+ (#{ribcage-marks\ 9103}#
+ #{ribcage\ 10817}#)
+ #{i\ 10828}#))
+ #f)
+ (values
+ (list-ref
+ (#{ribcage-labels\ 9105}#
+ #{ribcage\ 10817}#)
+ #{i\ 10828}#)
+ #{marks\ 10815}#)
+ (#{f\ 10826}#
+ (cdr #{symnames\ 10827}#)
+ (#{fx+\ 8977}#
+ #{i\ 10828}#
+ 1)))))))
+ (#{f\ 10826}# #{symnames\ 10816}# 0))))
+ (#{search\ 10774}#
+ (lambda (#{sym\ 10836}#
+ #{subst\ 10837}#
+ #{marks\ 10838}#)
+ (if (null? #{subst\ 10837}#)
+ (values #f #{marks\ 10838}#)
+ (let ((#{fst\ 10843}# (car #{subst\ 10837}#)))
+ (if (eq? #{fst\ 10843}# (quote shift))
+ (#{search\ 10774}#
+ #{sym\ 10836}#
+ (cdr #{subst\ 10837}#)
+ (cdr #{marks\ 10838}#))
+ (let ((#{symnames\ 10845}#
+ (#{ribcage-symnames\ 9101}#
+ #{fst\ 10843}#)))
+ (if (vector? #{symnames\ 10845}#)
+ (#{search-vector-rib\ 10778}#
+ #{sym\ 10836}#
+ #{subst\ 10837}#
+ #{marks\ 10838}#
+ #{symnames\ 10845}#
+ #{fst\ 10843}#)
+ (#{search-list-rib\ 10776}#
+ #{sym\ 10836}#
+ #{subst\ 10837}#
+ #{marks\ 10838}#
+ #{symnames\ 10845}#
+ #{fst\ 10843}#)))))))))
+ (if (symbol? #{id\ 10768}#)
+ (let ((#{t\ 10848}#
+ (call-with-values
+ (lambda ()
+ (#{search\ 10774}#
+ #{id\ 10768}#
+ (#{wrap-subst\ 9085}# #{w\ 10769}#)
+ (#{wrap-marks\ 9083}# #{w\ 10769}#)))
+ (lambda (#{x\ 10850}# . #{ignore\ 10851}#)
+ #{x\ 10850}#))))
+ (if #{t\ 10848}# #{t\ 10848}# #{id\ 10768}#))
+ (if (#{syntax-object?\ 9040}# #{id\ 10768}#)
+ (let ((#{id\ 10859}#
+ (#{syntax-object-expression\ 9042}#
+ #{id\ 10768}#))
+ (#{w1\ 10860}#
+ (#{syntax-object-wrap\ 9044}# #{id\ 10768}#)))
+ (let ((#{marks\ 10862}#
+ (#{join-marks\ 9129}#
+ (#{wrap-marks\ 9083}# #{w\ 10769}#)
+ (#{wrap-marks\ 9083}# #{w1\ 10860}#))))
(call-with-values
(lambda ()
- (#{search\ 910}#
- #{id\ 942}#
- (#{wrap-subst\ 135}# #{w\ 909}#)
- #{marks\ 944}#))
- (lambda (#{new-id\ 945}# #{marks\ 946}#)
- (let ((#{t\ 947}# #{new-id\ 945}#))
- (if #{t\ 947}#
- #{t\ 947}#
- (let ((#{t\ 948}# (call-with-values
- (lambda ()
- (#{search\ 910}#
- #{id\ 942}#
- (#{wrap-subst\ 135}#
- #{w1\ 943}#)
- #{marks\ 946}#))
- (lambda (#{x\ 949}#
- .
- #{ignore\ 950}#)
- #{x\ 949}#))))
- (if #{t\ 948}#
- #{t\ 948}#
- #{id\ 942}#))))))))
+ (#{search\ 10774}#
+ #{id\ 10859}#
+ (#{wrap-subst\ 9085}# #{w\ 10769}#)
+ #{marks\ 10862}#))
+ (lambda (#{new-id\ 10863}# #{marks\ 10864}#)
+ (let ((#{t\ 10869}# #{new-id\ 10863}#))
+ (if #{t\ 10869}#
+ #{t\ 10869}#
+ (let ((#{t\ 10872}#
+ (call-with-values
+ (lambda ()
+ (#{search\ 10774}#
+ #{id\ 10859}#
+ (#{wrap-subst\ 9085}#
+ #{w1\ 10860}#)
+ #{marks\ 10864}#))
+ (lambda (#{x\ 10874}#
+ .
+ #{ignore\ 10875}#)
+ #{x\ 10874}#))))
+ (if #{t\ 10872}#
+ #{t\ 10872}#
+ #{id\ 10859}#))))))))
(syntax-violation
'id-var-name
"invalid id"
- #{id\ 908}#))))))
- (#{same-marks?\ 152}#
- (lambda (#{x\ 951}# #{y\ 952}#)
- (let ((#{t\ 953}# (eq? #{x\ 951}# #{y\ 952}#)))
- (if #{t\ 953}#
- #{t\ 953}#
- (if (not (null? #{x\ 951}#))
- (if (not (null? #{y\ 952}#))
- (if (eq? (car #{x\ 951}#) (car #{y\ 952}#))
- (#{same-marks?\ 152}#
- (cdr #{x\ 951}#)
- (cdr #{y\ 952}#))
+ #{id\ 10768}#))))))
+ (#{same-marks?\ 9131}#
+ (lambda (#{x\ 10880}# #{y\ 10881}#)
+ (let ((#{t\ 10886}# (eq? #{x\ 10880}# #{y\ 10881}#)))
+ (if #{t\ 10886}#
+ #{t\ 10886}#
+ (if (not (null? #{x\ 10880}#))
+ (if (not (null? #{y\ 10881}#))
+ (if (eq? (car #{x\ 10880}#) (car #{y\ 10881}#))
+ (#{same-marks?\ 9131}#
+ (cdr #{x\ 10880}#)
+ (cdr #{y\ 10881}#))
#f)
#f)
#f)))))
- (#{join-marks\ 151}#
- (lambda (#{m1\ 954}# #{m2\ 955}#)
- (#{smart-append\ 149}# #{m1\ 954}# #{m2\ 955}#)))
- (#{join-wraps\ 150}#
- (lambda (#{w1\ 956}# #{w2\ 957}#)
- (let ((#{m1\ 958}# (#{wrap-marks\ 134}# #{w1\ 956}#))
- (#{s1\ 959}# (#{wrap-subst\ 135}# #{w1\ 956}#)))
- (if (null? #{m1\ 958}#)
- (if (null? #{s1\ 959}#)
- #{w2\ 957}#
- (#{make-wrap\ 133}#
- (#{wrap-marks\ 134}# #{w2\ 957}#)
- (#{smart-append\ 149}#
- #{s1\ 959}#
- (#{wrap-subst\ 135}# #{w2\ 957}#))))
- (#{make-wrap\ 133}#
- (#{smart-append\ 149}#
- #{m1\ 958}#
- (#{wrap-marks\ 134}# #{w2\ 957}#))
- (#{smart-append\ 149}#
- #{s1\ 959}#
- (#{wrap-subst\ 135}# #{w2\ 957}#)))))))
- (#{smart-append\ 149}#
- (lambda (#{m1\ 960}# #{m2\ 961}#)
- (if (null? #{m2\ 961}#)
- #{m1\ 960}#
- (append #{m1\ 960}# #{m2\ 961}#))))
- (#{make-binding-wrap\ 148}#
- (lambda (#{ids\ 962}# #{labels\ 963}# #{w\ 964}#)
- (if (null? #{ids\ 962}#)
- #{w\ 964}#
- (#{make-wrap\ 133}#
- (#{wrap-marks\ 134}# #{w\ 964}#)
- (cons (let ((#{labelvec\ 965}#
- (list->vector #{labels\ 963}#)))
- (let ((#{n\ 966}# (vector-length
- #{labelvec\ 965}#)))
- (let ((#{symnamevec\ 967}#
- (make-vector #{n\ 966}#))
- (#{marksvec\ 968}#
- (make-vector #{n\ 966}#)))
+ (#{join-marks\ 9129}#
+ (lambda (#{m1\ 10892}# #{m2\ 10893}#)
+ (#{smart-append\ 9125}#
+ #{m1\ 10892}#
+ #{m2\ 10893}#)))
+ (#{join-wraps\ 9127}#
+ (lambda (#{w1\ 10896}# #{w2\ 10897}#)
+ (let ((#{m1\ 10902}#
+ (#{wrap-marks\ 9083}# #{w1\ 10896}#))
+ (#{s1\ 10903}#
+ (#{wrap-subst\ 9085}# #{w1\ 10896}#)))
+ (if (null? #{m1\ 10902}#)
+ (if (null? #{s1\ 10903}#)
+ #{w2\ 10897}#
+ (#{make-wrap\ 9081}#
+ (#{wrap-marks\ 9083}# #{w2\ 10897}#)
+ (#{smart-append\ 9125}#
+ #{s1\ 10903}#
+ (#{wrap-subst\ 9085}# #{w2\ 10897}#))))
+ (#{make-wrap\ 9081}#
+ (#{smart-append\ 9125}#
+ #{m1\ 10902}#
+ (#{wrap-marks\ 9083}# #{w2\ 10897}#))
+ (#{smart-append\ 9125}#
+ #{s1\ 10903}#
+ (#{wrap-subst\ 9085}# #{w2\ 10897}#)))))))
+ (#{smart-append\ 9125}#
+ (lambda (#{m1\ 10904}# #{m2\ 10905}#)
+ (if (null? #{m2\ 10905}#)
+ #{m1\ 10904}#
+ (append #{m1\ 10904}# #{m2\ 10905}#))))
+ (#{make-binding-wrap\ 9123}#
+ (lambda (#{ids\ 10908}# #{labels\ 10909}# #{w\ 10910}#)
+ (if (null? #{ids\ 10908}#)
+ #{w\ 10910}#
+ (#{make-wrap\ 9081}#
+ (#{wrap-marks\ 9083}# #{w\ 10910}#)
+ (cons (let ((#{labelvec\ 10915}#
+ (list->vector #{labels\ 10909}#)))
+ (let ((#{n\ 10917}#
+ (vector-length #{labelvec\ 10915}#)))
+ (let ((#{symnamevec\ 10920}#
+ (make-vector #{n\ 10917}#))
+ (#{marksvec\ 10921}#
+ (make-vector #{n\ 10917}#)))
(begin
- (letrec ((#{f\ 969}# (lambda (#{ids\ 970}#
- #{i\ 971}#)
- (if (not (null? #{ids\
970}#))
- (call-with-values
- (lambda ()
-
(#{id-sym-name&marks\ 132}#
- (car #{ids\
970}#)
- #{w\ 964}#))
- (lambda
(#{symname\ 972}#
- #{marks\
973}#)
- (begin
- (vector-set!
-
#{symnamevec\ 967}#
- #{i\ 971}#
- #{symname\
972}#)
- (vector-set!
- #{marksvec\
968}#
- #{i\ 971}#
- #{marks\
973}#)
- (#{f\ 969}#
(cdr #{ids\ 970}#)
-
(#{fx+\ 86}#
-
#{i\ 971}#
-
1)))))))))
- (#{f\ 969}# #{ids\ 962}# 0))
- (#{make-ribcage\ 138}#
- #{symnamevec\ 967}#
- #{marksvec\ 968}#
- #{labelvec\ 965}#)))))
- (#{wrap-subst\ 135}# #{w\ 964}#))))))
- (#{extend-ribcage!\ 147}#
- (lambda (#{ribcage\ 974}# #{id\ 975}# #{label\ 976}#)
+ (letrec ((#{f\ 10925}#
+ (lambda (#{ids\ 10926}#
+ #{i\ 10927}#)
+ (if (not (null? #{ids\ 10926}#))
+ (call-with-values
+ (lambda ()
+ (#{id-sym-name&marks\
9079}#
+ (car #{ids\ 10926}#)
+ #{w\ 10910}#))
+ (lambda (#{symname\ 10928}#
+ #{marks\ 10929}#)
+ (begin
+ (vector-set!
+ #{symnamevec\ 10920}#
+ #{i\ 10927}#
+ #{symname\ 10928}#)
+ (vector-set!
+ #{marksvec\ 10921}#
+ #{i\ 10927}#
+ #{marks\ 10929}#)
+ (#{f\ 10925}#
+ (cdr #{ids\ 10926}#)
+ (#{fx+\ 8977}#
+ #{i\ 10927}#
+ 1)))))))))
+ (#{f\ 10925}# #{ids\ 10908}# 0))
+ (#{make-ribcage\ 9097}#
+ #{symnamevec\ 10920}#
+ #{marksvec\ 10921}#
+ #{labelvec\ 10915}#)))))
+ (#{wrap-subst\ 9085}# #{w\ 10910}#))))))
+ (#{extend-ribcage!\ 9121}#
+ (lambda (#{ribcage\ 10932}#
+ #{id\ 10933}#
+ #{label\ 10934}#)
(begin
- (#{set-ribcage-symnames!\ 143}#
- #{ribcage\ 974}#
- (cons (#{syntax-object-expression\ 116}# #{id\ 975}#)
- (#{ribcage-symnames\ 140}# #{ribcage\ 974}#)))
- (#{set-ribcage-marks!\ 144}#
- #{ribcage\ 974}#
- (cons (#{wrap-marks\ 134}#
- (#{syntax-object-wrap\ 117}# #{id\ 975}#))
- (#{ribcage-marks\ 141}# #{ribcage\ 974}#)))
- (#{set-ribcage-labels!\ 145}#
- #{ribcage\ 974}#
- (cons #{label\ 976}#
- (#{ribcage-labels\ 142}# #{ribcage\ 974}#))))))
- (#{anti-mark\ 146}#
- (lambda (#{w\ 977}#)
- (#{make-wrap\ 133}#
- (cons #f (#{wrap-marks\ 134}# #{w\ 977}#))
+ (#{set-ribcage-symnames!\ 9107}#
+ #{ribcage\ 10932}#
+ (cons (#{syntax-object-expression\ 9042}#
+ #{id\ 10933}#)
+ (#{ribcage-symnames\ 9101}# #{ribcage\ 10932}#)))
+ (#{set-ribcage-marks!\ 9109}#
+ #{ribcage\ 10932}#
+ (cons (#{wrap-marks\ 9083}#
+ (#{syntax-object-wrap\ 9044}# #{id\ 10933}#))
+ (#{ribcage-marks\ 9103}# #{ribcage\ 10932}#)))
+ (#{set-ribcage-labels!\ 9111}#
+ #{ribcage\ 10932}#
+ (cons #{label\ 10934}#
+ (#{ribcage-labels\ 9105}# #{ribcage\ 10932}#))))))
+ (#{anti-mark\ 9117}#
+ (lambda (#{w\ 10938}#)
+ (#{make-wrap\ 9081}#
+ (cons #f (#{wrap-marks\ 9083}# #{w\ 10938}#))
(cons 'shift
- (#{wrap-subst\ 135}# #{w\ 977}#)))))
- (#{set-ribcage-labels!\ 145}#
- (lambda (#{x\ 978}# #{update\ 979}#)
- (vector-set! #{x\ 978}# 3 #{update\ 979}#)))
- (#{set-ribcage-marks!\ 144}#
- (lambda (#{x\ 980}# #{update\ 981}#)
- (vector-set! #{x\ 980}# 2 #{update\ 981}#)))
- (#{set-ribcage-symnames!\ 143}#
- (lambda (#{x\ 982}# #{update\ 983}#)
- (vector-set! #{x\ 982}# 1 #{update\ 983}#)))
- (#{ribcage-labels\ 142}#
- (lambda (#{x\ 984}#) (vector-ref #{x\ 984}# 3)))
- (#{ribcage-marks\ 141}#
- (lambda (#{x\ 985}#) (vector-ref #{x\ 985}# 2)))
- (#{ribcage-symnames\ 140}#
- (lambda (#{x\ 986}#) (vector-ref #{x\ 986}# 1)))
- (#{ribcage?\ 139}#
- (lambda (#{x\ 987}#)
- (if (vector? #{x\ 987}#)
- (if (= (vector-length #{x\ 987}#) 4)
- (eq? (vector-ref #{x\ 987}# 0) (quote ribcage))
+ (#{wrap-subst\ 9085}# #{w\ 10938}#)))))
+ (#{set-ribcage-labels!\ 9111}#
+ (lambda (#{x\ 10941}# #{update\ 10942}#)
+ (vector-set! #{x\ 10941}# 3 #{update\ 10942}#)))
+ (#{set-ribcage-marks!\ 9109}#
+ (lambda (#{x\ 10945}# #{update\ 10946}#)
+ (vector-set! #{x\ 10945}# 2 #{update\ 10946}#)))
+ (#{set-ribcage-symnames!\ 9107}#
+ (lambda (#{x\ 10949}# #{update\ 10950}#)
+ (vector-set! #{x\ 10949}# 1 #{update\ 10950}#)))
+ (#{ribcage-labels\ 9105}#
+ (lambda (#{x\ 10953}#)
+ (vector-ref #{x\ 10953}# 3)))
+ (#{ribcage-marks\ 9103}#
+ (lambda (#{x\ 10955}#)
+ (vector-ref #{x\ 10955}# 2)))
+ (#{ribcage-symnames\ 9101}#
+ (lambda (#{x\ 10957}#)
+ (vector-ref #{x\ 10957}# 1)))
+ (#{ribcage?\ 9099}#
+ (lambda (#{x\ 10959}#)
+ (if (vector? #{x\ 10959}#)
+ (if (= (vector-length #{x\ 10959}#) 4)
+ (eq? (vector-ref #{x\ 10959}# 0) (quote ribcage))
#f)
#f)))
- (#{make-ribcage\ 138}#
- (lambda (#{symnames\ 988}#
- #{marks\ 989}#
- #{labels\ 990}#)
+ (#{make-ribcage\ 9097}#
+ (lambda (#{symnames\ 10964}#
+ #{marks\ 10965}#
+ #{labels\ 10966}#)
(vector
'ribcage
- #{symnames\ 988}#
- #{marks\ 989}#
- #{labels\ 990}#)))
- (#{gen-labels\ 137}#
- (lambda (#{ls\ 991}#)
- (if (null? #{ls\ 991}#)
+ #{symnames\ 10964}#
+ #{marks\ 10965}#
+ #{labels\ 10966}#)))
+ (#{gen-labels\ 9094}#
+ (lambda (#{ls\ 10970}#)
+ (if (null? #{ls\ 10970}#)
'()
- (cons (#{gen-label\ 136}#)
- (#{gen-labels\ 137}# (cdr #{ls\ 991}#))))))
- (#{gen-label\ 136}# (lambda () (string #\i)))
- (#{wrap-subst\ 135}# cdr)
- (#{wrap-marks\ 134}# car)
- (#{make-wrap\ 133}# cons)
- (#{id-sym-name&marks\ 132}#
- (lambda (#{x\ 992}# #{w\ 993}#)
- (if (#{syntax-object?\ 115}# #{x\ 992}#)
+ (cons (#{gen-label\ 9092}#)
+ (#{gen-labels\ 9094}# (cdr #{ls\ 10970}#))))))
+ (#{gen-label\ 9092}#
+ (lambda () (symbol->string (gensym "i"))))
+ (#{wrap-subst\ 9085}# cdr)
+ (#{wrap-marks\ 9083}# car)
+ (#{make-wrap\ 9081}# cons)
+ (#{id-sym-name&marks\ 9079}#
+ (lambda (#{x\ 10972}# #{w\ 10973}#)
+ (if (#{syntax-object?\ 9040}# #{x\ 10972}#)
(values
- (#{syntax-object-expression\ 116}# #{x\ 992}#)
- (#{join-marks\ 151}#
- (#{wrap-marks\ 134}# #{w\ 993}#)
- (#{wrap-marks\ 134}#
- (#{syntax-object-wrap\ 117}# #{x\ 992}#))))
+ (#{syntax-object-expression\ 9042}# #{x\ 10972}#)
+ (#{join-marks\ 9129}#
+ (#{wrap-marks\ 9083}# #{w\ 10973}#)
+ (#{wrap-marks\ 9083}#
+ (#{syntax-object-wrap\ 9044}# #{x\ 10972}#))))
(values
- #{x\ 992}#
- (#{wrap-marks\ 134}# #{w\ 993}#)))))
- (#{id?\ 131}#
- (lambda (#{x\ 994}#)
- (if (symbol? #{x\ 994}#)
+ #{x\ 10972}#
+ (#{wrap-marks\ 9083}# #{w\ 10973}#)))))
+ (#{id?\ 9076}#
+ (lambda (#{x\ 10976}#)
+ (if (symbol? #{x\ 10976}#)
#t
- (if (#{syntax-object?\ 115}# #{x\ 994}#)
+ (if (#{syntax-object?\ 9040}# #{x\ 10976}#)
(symbol?
- (#{syntax-object-expression\ 116}# #{x\ 994}#))
+ (#{syntax-object-expression\ 9042}# #{x\ 10976}#))
#f))))
- (#{nonsymbol-id?\ 130}#
- (lambda (#{x\ 995}#)
- (if (#{syntax-object?\ 115}# #{x\ 995}#)
+ (#{nonsymbol-id?\ 9074}#
+ (lambda (#{x\ 10983}#)
+ (if (#{syntax-object?\ 9040}# #{x\ 10983}#)
(symbol?
- (#{syntax-object-expression\ 116}# #{x\ 995}#))
+ (#{syntax-object-expression\ 9042}# #{x\ 10983}#))
#f)))
- (#{global-extend\ 129}#
- (lambda (#{type\ 996}# #{sym\ 997}# #{val\ 998}#)
- (#{put-global-definition-hook\ 92}#
- #{sym\ 997}#
- #{type\ 996}#
- #{val\ 998}#)))
- (#{lookup\ 128}#
- (lambda (#{x\ 999}# #{r\ 1000}# #{mod\ 1001}#)
- (let ((#{t\ 1002}# (assq #{x\ 999}# #{r\ 1000}#)))
- (if #{t\ 1002}#
- (cdr #{t\ 1002}#)
- (if (symbol? #{x\ 999}#)
- (let ((#{t\ 1003}#
- (#{get-global-definition-hook\ 93}#
- #{x\ 999}#
- #{mod\ 1001}#)))
- (if #{t\ 1003}# #{t\ 1003}# (quote (global))))
+ (#{global-extend\ 9072}#
+ (lambda (#{type\ 10987}# #{sym\ 10988}# #{val\ 10989}#)
+ (#{put-global-definition-hook\ 8990}#
+ #{sym\ 10988}#
+ #{type\ 10987}#
+ #{val\ 10989}#)))
+ (#{lookup\ 9070}#
+ (lambda (#{x\ 10993}# #{r\ 10994}# #{mod\ 10995}#)
+ (let ((#{t\ 11001}# (assq #{x\ 10993}# #{r\ 10994}#)))
+ (if #{t\ 11001}#
+ (cdr #{t\ 11001}#)
+ (if (symbol? #{x\ 10993}#)
+ (let ((#{t\ 11007}#
+ (#{get-global-definition-hook\ 8992}#
+ #{x\ 10993}#
+ #{mod\ 10995}#)))
+ (if #{t\ 11007}# #{t\ 11007}# (quote (global))))
'(displaced-lexical))))))
- (#{macros-only-env\ 127}#
- (lambda (#{r\ 1004}#)
- (if (null? #{r\ 1004}#)
+ (#{macros-only-env\ 9068}#
+ (lambda (#{r\ 11012}#)
+ (if (null? #{r\ 11012}#)
'()
- (let ((#{a\ 1005}# (car #{r\ 1004}#)))
- (if (eq? (cadr #{a\ 1005}#) (quote macro))
- (cons #{a\ 1005}#
- (#{macros-only-env\ 127}# (cdr #{r\ 1004}#)))
- (#{macros-only-env\ 127}# (cdr #{r\ 1004}#)))))))
- (#{extend-var-env\ 126}#
- (lambda (#{labels\ 1006}# #{vars\ 1007}# #{r\ 1008}#)
- (if (null? #{labels\ 1006}#)
- #{r\ 1008}#
- (#{extend-var-env\ 126}#
- (cdr #{labels\ 1006}#)
- (cdr #{vars\ 1007}#)
- (cons (cons (car #{labels\ 1006}#)
- (cons (quote lexical) (car #{vars\ 1007}#)))
- #{r\ 1008}#)))))
- (#{extend-env\ 125}#
- (lambda (#{labels\ 1009}# #{bindings\ 1010}# #{r\ 1011}#)
- (if (null? #{labels\ 1009}#)
- #{r\ 1011}#
- (#{extend-env\ 125}#
- (cdr #{labels\ 1009}#)
- (cdr #{bindings\ 1010}#)
- (cons (cons (car #{labels\ 1009}#)
- (car #{bindings\ 1010}#))
- #{r\ 1011}#)))))
- (#{binding-value\ 124}# cdr)
- (#{binding-type\ 123}# car)
- (#{source-annotation\ 122}#
- (lambda (#{x\ 1012}#)
- (if (#{syntax-object?\ 115}# #{x\ 1012}#)
- (#{source-annotation\ 122}#
- (#{syntax-object-expression\ 116}# #{x\ 1012}#))
- (if (pair? #{x\ 1012}#)
- (let ((#{props\ 1013}# (source-properties #{x\ 1012}#)))
- (if (pair? #{props\ 1013}#) #{props\ 1013}# #f))
+ (let ((#{a\ 11015}# (car #{r\ 11012}#)))
+ (if (eq? (cadr #{a\ 11015}#) (quote macro))
+ (cons #{a\ 11015}#
+ (#{macros-only-env\ 9068}# (cdr #{r\ 11012}#)))
+ (#{macros-only-env\ 9068}# (cdr #{r\ 11012}#)))))))
+ (#{extend-var-env\ 9066}#
+ (lambda (#{labels\ 11016}# #{vars\ 11017}# #{r\ 11018}#)
+ (if (null? #{labels\ 11016}#)
+ #{r\ 11018}#
+ (#{extend-var-env\ 9066}#
+ (cdr #{labels\ 11016}#)
+ (cdr #{vars\ 11017}#)
+ (cons (cons (car #{labels\ 11016}#)
+ (cons (quote lexical) (car #{vars\ 11017}#)))
+ #{r\ 11018}#)))))
+ (#{extend-env\ 9064}#
+ (lambda (#{labels\ 11023}#
+ #{bindings\ 11024}#
+ #{r\ 11025}#)
+ (if (null? #{labels\ 11023}#)
+ #{r\ 11025}#
+ (#{extend-env\ 9064}#
+ (cdr #{labels\ 11023}#)
+ (cdr #{bindings\ 11024}#)
+ (cons (cons (car #{labels\ 11023}#)
+ (car #{bindings\ 11024}#))
+ #{r\ 11025}#)))))
+ (#{binding-value\ 9061}# cdr)
+ (#{binding-type\ 9059}# car)
+ (#{source-annotation\ 9055}#
+ (lambda (#{x\ 11029}#)
+ (if (#{syntax-object?\ 9040}# #{x\ 11029}#)
+ (#{source-annotation\ 9055}#
+ (#{syntax-object-expression\ 9042}# #{x\ 11029}#))
+ (if (pair? #{x\ 11029}#)
+ (let ((#{props\ 11036}#
+ (source-properties #{x\ 11029}#)))
+ (if (pair? #{props\ 11036}#) #{props\ 11036}# #f))
#f))))
- (#{set-syntax-object-module!\ 121}#
- (lambda (#{x\ 1014}# #{update\ 1015}#)
- (vector-set! #{x\ 1014}# 3 #{update\ 1015}#)))
- (#{set-syntax-object-wrap!\ 120}#
- (lambda (#{x\ 1016}# #{update\ 1017}#)
- (vector-set! #{x\ 1016}# 2 #{update\ 1017}#)))
- (#{set-syntax-object-expression!\ 119}#
- (lambda (#{x\ 1018}# #{update\ 1019}#)
- (vector-set! #{x\ 1018}# 1 #{update\ 1019}#)))
- (#{syntax-object-module\ 118}#
- (lambda (#{x\ 1020}#) (vector-ref #{x\ 1020}# 3)))
- (#{syntax-object-wrap\ 117}#
- (lambda (#{x\ 1021}#) (vector-ref #{x\ 1021}# 2)))
- (#{syntax-object-expression\ 116}#
- (lambda (#{x\ 1022}#) (vector-ref #{x\ 1022}# 1)))
- (#{syntax-object?\ 115}#
- (lambda (#{x\ 1023}#)
- (if (vector? #{x\ 1023}#)
- (if (= (vector-length #{x\ 1023}#) 4)
- (eq? (vector-ref #{x\ 1023}# 0)
+ (#{set-syntax-object-module!\ 9052}#
+ (lambda (#{x\ 11038}# #{update\ 11039}#)
+ (vector-set! #{x\ 11038}# 3 #{update\ 11039}#)))
+ (#{set-syntax-object-wrap!\ 9050}#
+ (lambda (#{x\ 11042}# #{update\ 11043}#)
+ (vector-set! #{x\ 11042}# 2 #{update\ 11043}#)))
+ (#{set-syntax-object-expression!\ 9048}#
+ (lambda (#{x\ 11046}# #{update\ 11047}#)
+ (vector-set! #{x\ 11046}# 1 #{update\ 11047}#)))
+ (#{syntax-object-module\ 9046}#
+ (lambda (#{x\ 11050}#)
+ (vector-ref #{x\ 11050}# 3)))
+ (#{syntax-object-wrap\ 9044}#
+ (lambda (#{x\ 11052}#)
+ (vector-ref #{x\ 11052}# 2)))
+ (#{syntax-object-expression\ 9042}#
+ (lambda (#{x\ 11054}#)
+ (vector-ref #{x\ 11054}# 1)))
+ (#{syntax-object?\ 9040}#
+ (lambda (#{x\ 11056}#)
+ (if (vector? #{x\ 11056}#)
+ (if (= (vector-length #{x\ 11056}#) 4)
+ (eq? (vector-ref #{x\ 11056}# 0)
'syntax-object)
#f)
#f)))
- (#{make-syntax-object\ 114}#
- (lambda (#{expression\ 1024}#
- #{wrap\ 1025}#
- #{module\ 1026}#)
+ (#{make-syntax-object\ 9038}#
+ (lambda (#{expression\ 11061}#
+ #{wrap\ 11062}#
+ #{module\ 11063}#)
(vector
'syntax-object
- #{expression\ 1024}#
- #{wrap\ 1025}#
- #{module\ 1026}#)))
- (#{build-letrec\ 113}#
- (lambda (#{src\ 1027}#
- #{ids\ 1028}#
- #{vars\ 1029}#
- #{val-exps\ 1030}#
- #{body-exp\ 1031}#)
- (if (null? #{vars\ 1029}#)
- #{body-exp\ 1031}#
- (let ((#{atom-key\ 1032}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1032}# (quote (c)))
+ #{expression\ 11061}#
+ #{wrap\ 11062}#
+ #{module\ 11063}#)))
+ (#{build-letrec\ 9034}#
+ (lambda (#{src\ 11067}#
+ #{ids\ 11068}#
+ #{vars\ 11069}#
+ #{val-exps\ 11070}#
+ #{body-exp\ 11071}#)
+ (if (null? #{vars\ 11069}#)
+ #{body-exp\ 11071}#
+ (let ((#{atom-key\ 11079}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11079}# (quote (c)))
(begin
(for-each
- #{maybe-name-value!\ 103}#
- #{ids\ 1028}#
- #{val-exps\ 1030}#)
+ #{maybe-name-value!\ 9014}#
+ #{ids\ 11068}#
+ #{val-exps\ 11070}#)
((@ (language tree-il) make-letrec)
- #{src\ 1027}#
- #{ids\ 1028}#
- #{vars\ 1029}#
- #{val-exps\ 1030}#
- #{body-exp\ 1031}#))
- (#{decorate-source\ 94}#
+ #{src\ 11067}#
+ #{ids\ 11068}#
+ #{vars\ 11069}#
+ #{val-exps\ 11070}#
+ #{body-exp\ 11071}#))
+ (#{decorate-source\ 8994}#
(list 'letrec
- (map list #{vars\ 1029}# #{val-exps\ 1030}#)
- #{body-exp\ 1031}#)
- #{src\ 1027}#))))))
- (#{build-named-let\ 112}#
- (lambda (#{src\ 1033}#
- #{ids\ 1034}#
- #{vars\ 1035}#
- #{val-exps\ 1036}#
- #{body-exp\ 1037}#)
- (let ((#{f\ 1038}# (car #{vars\ 1035}#))
- (#{f-name\ 1039}# (car #{ids\ 1034}#))
- (#{vars\ 1040}# (cdr #{vars\ 1035}#))
- (#{ids\ 1041}# (cdr #{ids\ 1034}#)))
- (let ((#{atom-key\ 1042}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1042}# (quote (c)))
- (let ((#{proc\ 1043}#
- (#{build-simple-lambda\ 105}#
- #{src\ 1033}#
- #{ids\ 1041}#
+ (map list #{vars\ 11069}# #{val-exps\ 11070}#)
+ #{body-exp\ 11071}#)
+ #{src\ 11067}#))))))
+ (#{build-named-let\ 9032}#
+ (lambda (#{src\ 11083}#
+ #{ids\ 11084}#
+ #{vars\ 11085}#
+ #{val-exps\ 11086}#
+ #{body-exp\ 11087}#)
+ (let ((#{f\ 11097}# (car #{vars\ 11085}#))
+ (#{f-name\ 11098}# (car #{ids\ 11084}#))
+ (#{vars\ 11099}# (cdr #{vars\ 11085}#))
+ (#{ids\ 11100}# (cdr #{ids\ 11084}#)))
+ (let ((#{atom-key\ 11103}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11103}# (quote (c)))
+ (let ((#{proc\ 11106}#
+ (#{build-simple-lambda\ 9018}#
+ #{src\ 11083}#
+ #{ids\ 11100}#
#f
- #{vars\ 1040}#
- #f
- #{body-exp\ 1037}#)))
+ #{vars\ 11099}#
+ '()
+ #{body-exp\ 11087}#)))
(begin
- (#{maybe-name-value!\ 103}#
- #{f-name\ 1039}#
- #{proc\ 1043}#)
+ (#{maybe-name-value!\ 9014}#
+ #{f-name\ 11098}#
+ #{proc\ 11106}#)
(for-each
- #{maybe-name-value!\ 103}#
- #{ids\ 1041}#
- #{val-exps\ 1036}#)
+ #{maybe-name-value!\ 9014}#
+ #{ids\ 11100}#
+ #{val-exps\ 11086}#)
((@ (language tree-il) make-letrec)
- #{src\ 1033}#
- (list #{f-name\ 1039}#)
- (list #{f\ 1038}#)
- (list #{proc\ 1043}#)
- (#{build-application\ 96}#
- #{src\ 1033}#
- (#{build-lexical-reference\ 98}#
+ #{src\ 11083}#
+ (list #{f-name\ 11098}#)
+ (list #{f\ 11097}#)
+ (list #{proc\ 11106}#)
+ (#{build-application\ 8998}#
+ #{src\ 11083}#
+ (#{build-lexical-reference\ 9004}#
'fun
- #{src\ 1033}#
- #{f-name\ 1039}#
- #{f\ 1038}#)
- #{val-exps\ 1036}#))))
- (#{decorate-source\ 94}#
+ #{src\ 11083}#
+ #{f-name\ 11098}#
+ #{f\ 11097}#)
+ #{val-exps\ 11086}#))))
+ (#{decorate-source\ 8994}#
(list 'letrec
- (list (list #{f\ 1038}#
+ (list (list #{f\ 11097}#
(list 'lambda
- #{vars\ 1040}#
- #{body-exp\ 1037}#)))
- (cons #{f\ 1038}# #{val-exps\ 1036}#))
- #{src\ 1033}#))))))
- (#{build-let\ 111}#
- (lambda (#{src\ 1044}#
- #{ids\ 1045}#
- #{vars\ 1046}#
- #{val-exps\ 1047}#
- #{body-exp\ 1048}#)
- (if (null? #{vars\ 1046}#)
- #{body-exp\ 1048}#
- (let ((#{atom-key\ 1049}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1049}# (quote (c)))
+ #{vars\ 11099}#
+ #{body-exp\ 11087}#)))
+ (cons #{f\ 11097}# #{val-exps\ 11086}#))
+ #{src\ 11083}#))))))
+ (#{build-let\ 9030}#
+ (lambda (#{src\ 11109}#
+ #{ids\ 11110}#
+ #{vars\ 11111}#
+ #{val-exps\ 11112}#
+ #{body-exp\ 11113}#)
+ (if (null? #{vars\ 11111}#)
+ #{body-exp\ 11113}#
+ (let ((#{atom-key\ 11121}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11121}# (quote (c)))
(begin
(for-each
- #{maybe-name-value!\ 103}#
- #{ids\ 1045}#
- #{val-exps\ 1047}#)
+ #{maybe-name-value!\ 9014}#
+ #{ids\ 11110}#
+ #{val-exps\ 11112}#)
((@ (language tree-il) make-let)
- #{src\ 1044}#
- #{ids\ 1045}#
- #{vars\ 1046}#
- #{val-exps\ 1047}#
- #{body-exp\ 1048}#))
- (#{decorate-source\ 94}#
+ #{src\ 11109}#
+ #{ids\ 11110}#
+ #{vars\ 11111}#
+ #{val-exps\ 11112}#
+ #{body-exp\ 11113}#))
+ (#{decorate-source\ 8994}#
(list 'let
- (map list #{vars\ 1046}# #{val-exps\ 1047}#)
- #{body-exp\ 1048}#)
- #{src\ 1044}#))))))
- (#{build-sequence\ 110}#
- (lambda (#{src\ 1050}# #{exps\ 1051}#)
- (if (null? (cdr #{exps\ 1051}#))
- (car #{exps\ 1051}#)
- (let ((#{atom-key\ 1052}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1052}# (quote (c)))
+ (map list #{vars\ 11111}# #{val-exps\ 11112}#)
+ #{body-exp\ 11113}#)
+ #{src\ 11109}#))))))
+ (#{build-sequence\ 9028}#
+ (lambda (#{src\ 11125}# #{exps\ 11126}#)
+ (if (null? (cdr #{exps\ 11126}#))
+ (car #{exps\ 11126}#)
+ (let ((#{atom-key\ 11131}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11131}# (quote (c)))
((@ (language tree-il) make-sequence)
- #{src\ 1050}#
- #{exps\ 1051}#)
- (#{decorate-source\ 94}#
- (cons (quote begin) #{exps\ 1051}#)
- #{src\ 1050}#))))))
- (#{build-data\ 109}#
- (lambda (#{src\ 1053}# #{exp\ 1054}#)
- (let ((#{atom-key\ 1055}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1055}# (quote (c)))
+ #{src\ 11125}#
+ #{exps\ 11126}#)
+ (#{decorate-source\ 8994}#
+ (cons (quote begin) #{exps\ 11126}#)
+ #{src\ 11125}#))))))
+ (#{build-data\ 9026}#
+ (lambda (#{src\ 11135}# #{exp\ 11136}#)
+ (let ((#{atom-key\ 11141}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11141}# (quote (c)))
((@ (language tree-il) make-const)
- #{src\ 1053}#
- #{exp\ 1054}#)
- (#{decorate-source\ 94}#
- (if (if (self-evaluating? #{exp\ 1054}#)
- (not (vector? #{exp\ 1054}#))
+ #{src\ 11135}#
+ #{exp\ 11136}#)
+ (#{decorate-source\ 8994}#
+ (if (if (self-evaluating? #{exp\ 11136}#)
+ (not (vector? #{exp\ 11136}#))
#f)
- #{exp\ 1054}#
- (list (quote quote) #{exp\ 1054}#))
- #{src\ 1053}#)))))
- (#{build-primref\ 108}#
- (lambda (#{src\ 1056}# #{name\ 1057}#)
+ #{exp\ 11136}#
+ (list (quote quote) #{exp\ 11136}#))
+ #{src\ 11135}#)))))
+ (#{build-primref\ 9024}#
+ (lambda (#{src\ 11146}# #{name\ 11147}#)
(if (equal?
(module-name (current-module))
'(guile))
- (let ((#{atom-key\ 1058}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1058}# (quote (c)))
+ (let ((#{atom-key\ 11152}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11152}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- #{src\ 1056}#
- #{name\ 1057}#)
- (#{decorate-source\ 94}#
- #{name\ 1057}#
- #{src\ 1056}#)))
- (let ((#{atom-key\ 1059}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1059}# (quote (c)))
+ #{src\ 11146}#
+ #{name\ 11147}#)
+ (#{decorate-source\ 8994}#
+ #{name\ 11147}#
+ #{src\ 11146}#)))
+ (let ((#{atom-key\ 11157}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11157}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{src\ 1056}#
+ #{src\ 11146}#
'(guile)
- #{name\ 1057}#
+ #{name\ 11147}#
#f)
- (#{decorate-source\ 94}#
- (list (quote @@) (quote (guile)) #{name\ 1057}#)
- #{src\ 1056}#))))))
- (#{build-lambda-case\ 107}#
- (lambda (#{src\ 1060}#
- #{req\ 1061}#
- #{opt\ 1062}#
- #{rest\ 1063}#
- #{kw\ 1064}#
- #{inits\ 1065}#
- #{vars\ 1066}#
- #{body\ 1067}#
- #{else-case\ 1068}#)
- (let ((#{atom-key\ 1069}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1069}# (quote (c)))
+ (#{decorate-source\ 8994}#
+ (list (quote @@) (quote (guile)) #{name\ 11147}#)
+ #{src\ 11146}#))))))
+ (#{build-lambda-case\ 9022}#
+ (lambda (#{src\ 11161}#
+ #{req\ 11162}#
+ #{opt\ 11163}#
+ #{rest\ 11164}#
+ #{kw\ 11165}#
+ #{inits\ 11166}#
+ #{vars\ 11167}#
+ #{body\ 11168}#
+ #{else-case\ 11169}#)
+ (let ((#{atom-key\ 11181}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11181}# (quote (c)))
((@ (language tree-il) make-lambda-case)
- #{src\ 1060}#
- #{req\ 1061}#
- #{opt\ 1062}#
- #{rest\ 1063}#
- #{kw\ 1064}#
- #{inits\ 1065}#
- #{vars\ 1066}#
- #{body\ 1067}#
- #{else-case\ 1068}#)
- (let ((#{nreq\ 1070}# (length #{req\ 1061}#)))
- (let ((#{nopt\ 1071}#
- (if #{opt\ 1062}# (length #{opt\ 1062}#) 0)))
- (let ((#{rest-idx\ 1072}#
- (if #{rest\ 1063}#
- (+ #{nreq\ 1070}# #{nopt\ 1071}#)
+ #{src\ 11161}#
+ #{req\ 11162}#
+ #{opt\ 11163}#
+ #{rest\ 11164}#
+ #{kw\ 11165}#
+ #{inits\ 11166}#
+ #{vars\ 11167}#
+ #{body\ 11168}#
+ #{else-case\ 11169}#)
+ (let ((#{nreq\ 11186}# (length #{req\ 11162}#)))
+ (let ((#{nopt\ 11188}#
+ (if #{opt\ 11163}# (length #{opt\ 11163}#) 0)))
+ (let ((#{rest-idx\ 11190}#
+ (if #{rest\ 11164}#
+ (+ #{nreq\ 11186}# #{nopt\ 11188}#)
#f)))
- (let ((#{allow-other-keys?\ 1073}#
- (if #{kw\ 1064}# (car #{kw\ 1064}#) #f)))
- (let ((#{kw-indices\ 1074}#
- (map (lambda (#{x\ 1075}#)
- (cons (car #{x\ 1075}#)
+ (let ((#{allow-other-keys?\ 11194}#
+ (if #{kw\ 11165}# (car #{kw\ 11165}#) #f)))
+ (let ((#{kw-indices\ 11196}#
+ (map (lambda (#{x\ 11197}#)
+ (cons (car #{x\ 11197}#)
(list-index
- #{vars\ 1066}#
- (caddr #{x\ 1075}#))))
- (if #{kw\ 1064}#
- (cdr #{kw\ 1064}#)
+ #{vars\ 11167}#
+ (caddr #{x\ 11197}#))))
+ (if #{kw\ 11165}#
+ (cdr #{kw\ 11165}#)
'()))))
- (let ((#{nargs\ 1076}#
+ (let ((#{nargs\ 11200}#
(apply max
- (+ #{nreq\ 1070}#
- #{nopt\ 1071}#
- (if #{rest\ 1063}# 1 0))
+ (+ #{nreq\ 11186}#
+ #{nopt\ 11188}#
+ (if #{rest\ 11164}# 1 0))
(map 1+
(map cdr
- #{kw-indices\ 1074}#)))))
+ #{kw-indices\
11196}#)))))
(begin
- (let ((#{t\ 1077}#
- (= #{nargs\ 1076}#
- (length #{vars\ 1066}#)
- (+ #{nreq\ 1070}#
- (length #{inits\ 1065}#)
- (if #{rest\ 1063}# 1 0)))))
- (if #{t\ 1077}#
- #{t\ 1077}#
+ (let ((#{t\ 11203}#
+ (= #{nargs\ 11200}#
+ (length #{vars\ 11167}#)
+ (+ #{nreq\ 11186}#
+ (length #{inits\ 11166}#)
+ (if #{rest\ 11164}# 1 0)))))
+ (if #{t\ 11203}#
+ #{t\ 11203}#
(error "something went wrong"
- #{req\ 1061}#
- #{opt\ 1062}#
- #{rest\ 1063}#
- #{kw\ 1064}#
- #{inits\ 1065}#
- #{vars\ 1066}#
- #{nreq\ 1070}#
- #{nopt\ 1071}#
- #{kw-indices\ 1074}#
- #{nargs\ 1076}#)))
- (#{decorate-source\ 94}#
+ #{req\ 11162}#
+ #{opt\ 11163}#
+ #{rest\ 11164}#
+ #{kw\ 11165}#
+ #{inits\ 11166}#
+ #{vars\ 11167}#
+ #{nreq\ 11186}#
+ #{nopt\ 11188}#
+ #{kw-indices\ 11196}#
+ #{nargs\ 11200}#)))
+ (#{decorate-source\ 8994}#
(cons (list (cons '(@@ (ice-9 optargs)
parse-lambda-case)
(cons (list 'quote
- (list #{nreq\
1070}#
- #{nopt\
1071}#
-
#{rest-idx\ 1072}#
-
#{nargs\ 1076}#
-
#{allow-other-keys?\ 1073}#
-
#{kw-indices\ 1074}#))
+ (list #{nreq\
11186}#
+ #{nopt\
11188}#
+
#{rest-idx\ 11190}#
+
#{nargs\ 11200}#
+
#{allow-other-keys?\ 11194}#
+
#{kw-indices\ 11196}#))
(cons (cons 'list
- (map
(lambda (#{i\ 1078}#)
+ (map
(lambda (#{i\ 11206}#)
(list 'lambda
-
#{vars\ 1066}#
-
#{i\ 1078}#))
-
#{inits\ 1065}#))
+
#{vars\ 11167}#
+
#{i\ 11206}#))
+
#{inits\ 11166}#))
'(%%args))))
'=>
(list 'lambda
- '(%%%args . _)
+ '(%%args)
(cons 'apply
(cons (list 'lambda
- #{vars\
1066}#
- #{body\
1067}#)
- '(%%%args)))))
- (let ((#{t\ 1079}#
- #{else-case\ 1068}#))
- (if #{t\ 1079}#
- #{t\ 1079}#
+ #{vars\
11167}#
+ #{body\
11168}#)
+ '(%%args)))))
+ (let ((#{t\ 11211}#
+ #{else-case\ 11169}#))
+ (if #{t\ 11211}#
+ #{t\ 11211}#
'((%%args
- (error "wrong number of
arguments"
- %%args))))))
- #{src\ 1060}#))))))))))))
- (#{build-case-lambda\ 106}#
- (lambda (#{src\ 1080}#
- #{docstring\ 1081}#
- #{body\ 1082}#)
- (let ((#{atom-key\ 1083}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1083}# (quote (c)))
+ (scm-error
+ 'wrong-number-of-args
+ #f
+ "Wrong number of arguments"
+ '()
+ %%args))))))
+ #{src\ 11161}#))))))))))))
+ (#{build-case-lambda\ 9020}#
+ (lambda (#{src\ 11214}# #{meta\ 11215}# #{body\ 11216}#)
+ (let ((#{atom-key\ 11222}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11222}# (quote (c)))
((@ (language tree-il) make-lambda)
- #{src\ 1080}#
- (if #{docstring\ 1081}#
- (list (cons (quote documentation) #{docstring\ 1081}#))
- '())
- #{body\ 1082}#)
- (#{decorate-source\ 94}#
- (cons 'lambda
- (cons '%%args
- (append
- (if #{docstring\ 1081}#
- (list #{docstring\ 1081}#)
- '())
- (list (cons (quote cond) #{body\ 1082}#)))))
- #{src\ 1080}#)))))
- (#{build-simple-lambda\ 105}#
- (lambda (#{src\ 1084}#
- #{req\ 1085}#
- #{rest\ 1086}#
- #{vars\ 1087}#
- #{docstring\ 1088}#
- #{exp\ 1089}#)
- (let ((#{atom-key\ 1090}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1090}# (quote (c)))
+ #{src\ 11214}#
+ #{meta\ 11215}#
+ #{body\ 11216}#)
+ (#{decorate-source\ 8994}#
+ (list 'lambda
+ '%%args
+ (cons (quote cond) #{body\ 11216}#))
+ #{src\ 11214}#)))))
+ (#{build-simple-lambda\ 9018}#
+ (lambda (#{src\ 11226}#
+ #{req\ 11227}#
+ #{rest\ 11228}#
+ #{vars\ 11229}#
+ #{meta\ 11230}#
+ #{exp\ 11231}#)
+ (let ((#{atom-key\ 11240}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11240}# (quote (c)))
((@ (language tree-il) make-lambda)
- #{src\ 1084}#
- (if #{docstring\ 1088}#
- (list (cons (quote documentation) #{docstring\ 1088}#))
- '())
+ #{src\ 11226}#
+ #{meta\ 11230}#
((@ (language tree-il) make-lambda-case)
- #{src\ 1084}#
- #{req\ 1085}#
+ #{src\ 11226}#
+ #{req\ 11227}#
#f
- #{rest\ 1086}#
+ #{rest\ 11228}#
#f
'()
- #{vars\ 1087}#
- #{exp\ 1089}#
+ #{vars\ 11229}#
+ #{exp\ 11231}#
#f))
- (#{decorate-source\ 94}#
- (cons 'lambda
- (cons (if #{rest\ 1086}#
- (apply cons* #{vars\ 1087}#)
- #{vars\ 1087}#)
- (append
- (if #{docstring\ 1088}#
- (list #{docstring\ 1088}#)
- '())
- (list #{exp\ 1089}#))))
- #{src\ 1084}#)))))
- (#{build-global-definition\ 104}#
- (lambda (#{source\ 1091}# #{var\ 1092}# #{exp\ 1093}#)
- (let ((#{atom-key\ 1094}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1094}# (quote (c)))
+ (#{decorate-source\ 8994}#
+ (list 'lambda
+ (if #{rest\ 11228}#
+ (apply cons* #{vars\ 11229}#)
+ #{vars\ 11229}#)
+ #{exp\ 11231}#)
+ #{src\ 11226}#)))))
+ (#{build-global-definition\ 9016}#
+ (lambda (#{source\ 11244}# #{var\ 11245}# #{exp\ 11246}#)
+ (let ((#{atom-key\ 11252}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11252}# (quote (c)))
(begin
- (#{maybe-name-value!\ 103}#
- #{var\ 1092}#
- #{exp\ 1093}#)
+ (#{maybe-name-value!\ 9014}#
+ #{var\ 11245}#
+ #{exp\ 11246}#)
((@ (language tree-il) make-toplevel-define)
- #{source\ 1091}#
- #{var\ 1092}#
- #{exp\ 1093}#))
- (#{decorate-source\ 94}#
- (list (quote define) #{var\ 1092}# #{exp\ 1093}#)
- #{source\ 1091}#)))))
- (#{maybe-name-value!\ 103}#
- (lambda (#{name\ 1095}# #{val\ 1096}#)
- (if ((@ (language tree-il) lambda?) #{val\ 1096}#)
- (let ((#{meta\ 1097}#
+ #{source\ 11244}#
+ #{var\ 11245}#
+ #{exp\ 11246}#))
+ (#{decorate-source\ 8994}#
+ (list 'define
+ #{var\ 11245}#
+ #{exp\ 11246}#)
+ #{source\ 11244}#)))))
+ (#{maybe-name-value!\ 9014}#
+ (lambda (#{name\ 11256}# #{val\ 11257}#)
+ (if ((@ (language tree-il) lambda?) #{val\ 11257}#)
+ (let ((#{meta\ 11263}#
((@ (language tree-il) lambda-meta)
- #{val\ 1096}#)))
- (if (not (assq (quote name) #{meta\ 1097}#))
+ #{val\ 11257}#)))
+ (if (not (assq (quote name) #{meta\ 11263}#))
((setter (@ (language tree-il) lambda-meta))
- #{val\ 1096}#
+ #{val\ 11257}#
(acons 'name
- #{name\ 1095}#
- #{meta\ 1097}#)))))))
- (#{build-global-assignment\ 102}#
- (lambda (#{source\ 1098}#
- #{var\ 1099}#
- #{exp\ 1100}#
- #{mod\ 1101}#)
- (#{analyze-variable\ 100}#
- #{mod\ 1101}#
- #{var\ 1099}#
- (lambda (#{mod\ 1102}# #{var\ 1103}# #{public?\ 1104}#)
- (let ((#{atom-key\ 1105}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1105}# (quote (c)))
+ #{name\ 11256}#
+ #{meta\ 11263}#)))))))
+ (#{build-global-assignment\ 9012}#
+ (lambda (#{source\ 11264}#
+ #{var\ 11265}#
+ #{exp\ 11266}#
+ #{mod\ 11267}#)
+ (#{analyze-variable\ 9008}#
+ #{mod\ 11267}#
+ #{var\ 11265}#
+ (lambda (#{mod\ 11272}#
+ #{var\ 11273}#
+ #{public?\ 11274}#)
+ (let ((#{atom-key\ 11280}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11280}# (quote (c)))
((@ (language tree-il) make-module-set)
- #{source\ 1098}#
- #{mod\ 1102}#
- #{var\ 1103}#
- #{public?\ 1104}#
- #{exp\ 1100}#)
- (#{decorate-source\ 94}#
+ #{source\ 11264}#
+ #{mod\ 11272}#
+ #{var\ 11273}#
+ #{public?\ 11274}#
+ #{exp\ 11266}#)
+ (#{decorate-source\ 8994}#
(list 'set!
- (list (if #{public?\ 1104}#
+ (list (if #{public?\ 11274}#
'@
'@@)
- #{mod\ 1102}#
- #{var\ 1103}#)
- #{exp\ 1100}#)
- #{source\ 1098}#))))
- (lambda (#{var\ 1106}#)
- (let ((#{atom-key\ 1107}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1107}# (quote (c)))
+ #{mod\ 11272}#
+ #{var\ 11273}#)
+ #{exp\ 11266}#)
+ #{source\ 11264}#))))
+ (lambda (#{var\ 11284}#)
+ (let ((#{atom-key\ 11288}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11288}# (quote (c)))
((@ (language tree-il) make-toplevel-set)
- #{source\ 1098}#
- #{var\ 1106}#
- #{exp\ 1100}#)
- (#{decorate-source\ 94}#
- (list (quote set!) #{var\ 1106}# #{exp\ 1100}#)
- #{source\ 1098}#)))))))
- (#{build-global-reference\ 101}#
- (lambda (#{source\ 1108}# #{var\ 1109}# #{mod\ 1110}#)
- (#{analyze-variable\ 100}#
- #{mod\ 1110}#
- #{var\ 1109}#
- (lambda (#{mod\ 1111}# #{var\ 1112}# #{public?\ 1113}#)
- (let ((#{atom-key\ 1114}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1114}# (quote (c)))
+ #{source\ 11264}#
+ #{var\ 11284}#
+ #{exp\ 11266}#)
+ (#{decorate-source\ 8994}#
+ (list (quote set!) #{var\ 11284}# #{exp\ 11266}#)
+ #{source\ 11264}#)))))))
+ (#{build-global-reference\ 9010}#
+ (lambda (#{source\ 11292}# #{var\ 11293}# #{mod\ 11294}#)
+ (#{analyze-variable\ 9008}#
+ #{mod\ 11294}#
+ #{var\ 11293}#
+ (lambda (#{mod\ 11298}#
+ #{var\ 11299}#
+ #{public?\ 11300}#)
+ (let ((#{atom-key\ 11306}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11306}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{source\ 1108}#
- #{mod\ 1111}#
- #{var\ 1112}#
- #{public?\ 1113}#)
- (#{decorate-source\ 94}#
- (list (if #{public?\ 1113}# (quote @) (quote @@))
- #{mod\ 1111}#
- #{var\ 1112}#)
- #{source\ 1108}#))))
- (lambda (#{var\ 1115}#)
- (let ((#{atom-key\ 1116}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1116}# (quote (c)))
+ #{source\ 11292}#
+ #{mod\ 11298}#
+ #{var\ 11299}#
+ #{public?\ 11300}#)
+ (#{decorate-source\ 8994}#
+ (list (if #{public?\ 11300}# (quote @) (quote @@))
+ #{mod\ 11298}#
+ #{var\ 11299}#)
+ #{source\ 11292}#))))
+ (lambda (#{var\ 11309}#)
+ (let ((#{atom-key\ 11313}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11313}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- #{source\ 1108}#
- #{var\ 1115}#)
- (#{decorate-source\ 94}#
- #{var\ 1115}#
- #{source\ 1108}#)))))))
- (#{analyze-variable\ 100}#
- (lambda (#{mod\ 1117}#
- #{var\ 1118}#
- #{modref-cont\ 1119}#
- #{bare-cont\ 1120}#)
- (if (not #{mod\ 1117}#)
- (#{bare-cont\ 1120}# #{var\ 1118}#)
- (let ((#{kind\ 1121}# (car #{mod\ 1117}#))
- (#{mod\ 1122}# (cdr #{mod\ 1117}#)))
- (if (memv #{kind\ 1121}# (quote (public)))
- (#{modref-cont\ 1119}#
- #{mod\ 1122}#
- #{var\ 1118}#
+ #{source\ 11292}#
+ #{var\ 11309}#)
+ (#{decorate-source\ 8994}#
+ #{var\ 11309}#
+ #{source\ 11292}#)))))))
+ (#{analyze-variable\ 9008}#
+ (lambda (#{mod\ 11316}#
+ #{var\ 11317}#
+ #{modref-cont\ 11318}#
+ #{bare-cont\ 11319}#)
+ (if (not #{mod\ 11316}#)
+ (#{bare-cont\ 11319}# #{var\ 11317}#)
+ (let ((#{kind\ 11326}# (car #{mod\ 11316}#))
+ (#{mod\ 11327}# (cdr #{mod\ 11316}#)))
+ (if (memv #{kind\ 11326}# (quote (public)))
+ (#{modref-cont\ 11318}#
+ #{mod\ 11327}#
+ #{var\ 11317}#
#t)
- (if (memv #{kind\ 1121}# (quote (private)))
+ (if (memv #{kind\ 11326}# (quote (private)))
(if (not (equal?
- #{mod\ 1122}#
+ #{mod\ 11327}#
(module-name (current-module))))
- (#{modref-cont\ 1119}#
- #{mod\ 1122}#
- #{var\ 1118}#
+ (#{modref-cont\ 11318}#
+ #{mod\ 11327}#
+ #{var\ 11317}#
#f)
- (#{bare-cont\ 1120}# #{var\ 1118}#))
- (if (memv #{kind\ 1121}# (quote (bare)))
- (#{bare-cont\ 1120}# #{var\ 1118}#)
- (if (memv #{kind\ 1121}# (quote (hygiene)))
+ (#{bare-cont\ 11319}# #{var\ 11317}#))
+ (if (memv #{kind\ 11326}# (quote (bare)))
+ (#{bare-cont\ 11319}# #{var\ 11317}#)
+ (if (memv #{kind\ 11326}# (quote (hygiene)))
(if (if (not (equal?
- #{mod\ 1122}#
+ #{mod\ 11327}#
(module-name (current-module))))
(module-variable
- (resolve-module #{mod\ 1122}#)
- #{var\ 1118}#)
+ (resolve-module #{mod\ 11327}#)
+ #{var\ 11317}#)
#f)
- (#{modref-cont\ 1119}#
- #{mod\ 1122}#
- #{var\ 1118}#
+ (#{modref-cont\ 11318}#
+ #{mod\ 11327}#
+ #{var\ 11317}#
#f)
- (#{bare-cont\ 1120}# #{var\ 1118}#))
+ (#{bare-cont\ 11319}# #{var\ 11317}#))
(syntax-violation
#f
"bad module kind"
- #{var\ 1118}#
- #{mod\ 1122}#)))))))))
- (#{build-lexical-assignment\ 99}#
- (lambda (#{source\ 1123}#
- #{name\ 1124}#
- #{var\ 1125}#
- #{exp\ 1126}#)
- (let ((#{atom-key\ 1127}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1127}# (quote (c)))
+ #{var\ 11317}#
+ #{mod\ 11327}#)))))))))
+ (#{build-lexical-assignment\ 9006}#
+ (lambda (#{source\ 11335}#
+ #{name\ 11336}#
+ #{var\ 11337}#
+ #{exp\ 11338}#)
+ (let ((#{atom-key\ 11345}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11345}# (quote (c)))
((@ (language tree-il) make-lexical-set)
- #{source\ 1123}#
- #{name\ 1124}#
- #{var\ 1125}#
- #{exp\ 1126}#)
- (#{decorate-source\ 94}#
- (list (quote set!) #{var\ 1125}# #{exp\ 1126}#)
- #{source\ 1123}#)))))
- (#{build-lexical-reference\ 98}#
- (lambda (#{type\ 1128}#
- #{source\ 1129}#
- #{name\ 1130}#
- #{var\ 1131}#)
- (let ((#{atom-key\ 1132}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1132}# (quote (c)))
+ #{source\ 11335}#
+ #{name\ 11336}#
+ #{var\ 11337}#
+ #{exp\ 11338}#)
+ (#{decorate-source\ 8994}#
+ (list (quote set!) #{var\ 11337}# #{exp\ 11338}#)
+ #{source\ 11335}#)))))
+ (#{build-lexical-reference\ 9004}#
+ (lambda (#{type\ 11349}#
+ #{source\ 11350}#
+ #{name\ 11351}#
+ #{var\ 11352}#)
+ (let ((#{atom-key\ 11359}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11359}# (quote (c)))
((@ (language tree-il) make-lexical-ref)
- #{source\ 1129}#
- #{name\ 1130}#
- #{var\ 1131}#)
- (#{decorate-source\ 94}#
- #{var\ 1131}#
- #{source\ 1129}#)))))
- (#{build-conditional\ 97}#
- (lambda (#{source\ 1133}#
- #{test-exp\ 1134}#
- #{then-exp\ 1135}#
- #{else-exp\ 1136}#)
- (let ((#{atom-key\ 1137}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1137}# (quote (c)))
+ #{source\ 11350}#
+ #{name\ 11351}#
+ #{var\ 11352}#)
+ (#{decorate-source\ 8994}#
+ #{var\ 11352}#
+ #{source\ 11350}#)))))
+ (#{build-dynlet\ 9002}#
+ (lambda (#{source\ 11362}#
+ #{fluids\ 11363}#
+ #{vals\ 11364}#
+ #{body\ 11365}#)
+ (let ((#{atom-key\ 11372}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11372}# (quote (c)))
+ ((@ (language tree-il) make-dynlet)
+ #{source\ 11362}#
+ #{fluids\ 11363}#
+ #{vals\ 11364}#
+ #{body\ 11365}#)
+ (#{decorate-source\ 8994}#
+ (list 'with-fluids
+ (map list #{fluids\ 11363}# #{vals\ 11364}#)
+ #{body\ 11365}#)
+ #{source\ 11362}#)))))
+ (#{build-conditional\ 9000}#
+ (lambda (#{source\ 11376}#
+ #{test-exp\ 11377}#
+ #{then-exp\ 11378}#
+ #{else-exp\ 11379}#)
+ (let ((#{atom-key\ 11386}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11386}# (quote (c)))
((@ (language tree-il) make-conditional)
- #{source\ 1133}#
- #{test-exp\ 1134}#
- #{then-exp\ 1135}#
- #{else-exp\ 1136}#)
- (#{decorate-source\ 94}#
- (if (equal? #{else-exp\ 1136}# (quote (if #f #f)))
+ #{source\ 11376}#
+ #{test-exp\ 11377}#
+ #{then-exp\ 11378}#
+ #{else-exp\ 11379}#)
+ (#{decorate-source\ 8994}#
+ (if (equal? #{else-exp\ 11379}# (quote (if #f #f)))
(list 'if
- #{test-exp\ 1134}#
- #{then-exp\ 1135}#)
+ #{test-exp\ 11377}#
+ #{then-exp\ 11378}#)
(list 'if
- #{test-exp\ 1134}#
- #{then-exp\ 1135}#
- #{else-exp\ 1136}#))
- #{source\ 1133}#)))))
- (#{build-application\ 96}#
- (lambda (#{source\ 1138}#
- #{fun-exp\ 1139}#
- #{arg-exps\ 1140}#)
- (let ((#{atom-key\ 1141}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1141}# (quote (c)))
+ #{test-exp\ 11377}#
+ #{then-exp\ 11378}#
+ #{else-exp\ 11379}#))
+ #{source\ 11376}#)))))
+ (#{build-application\ 8998}#
+ (lambda (#{source\ 11391}#
+ #{fun-exp\ 11392}#
+ #{arg-exps\ 11393}#)
+ (let ((#{atom-key\ 11399}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11399}# (quote (c)))
((@ (language tree-il) make-application)
- #{source\ 1138}#
- #{fun-exp\ 1139}#
- #{arg-exps\ 1140}#)
- (#{decorate-source\ 94}#
- (cons #{fun-exp\ 1139}# #{arg-exps\ 1140}#)
- #{source\ 1138}#)))))
- (#{build-void\ 95}#
- (lambda (#{source\ 1142}#)
- (let ((#{atom-key\ 1143}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1143}# (quote (c)))
+ #{source\ 11391}#
+ #{fun-exp\ 11392}#
+ #{arg-exps\ 11393}#)
+ (#{decorate-source\ 8994}#
+ (cons #{fun-exp\ 11392}# #{arg-exps\ 11393}#)
+ #{source\ 11391}#)))))
+ (#{build-void\ 8996}#
+ (lambda (#{source\ 11403}#)
+ (let ((#{atom-key\ 11407}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11407}# (quote (c)))
((@ (language tree-il) make-void)
- #{source\ 1142}#)
- (#{decorate-source\ 94}#
+ #{source\ 11403}#)
+ (#{decorate-source\ 8994}#
'(if #f #f)
- #{source\ 1142}#)))))
- (#{decorate-source\ 94}#
- (lambda (#{e\ 1144}# #{s\ 1145}#)
+ #{source\ 11403}#)))))
+ (#{decorate-source\ 8994}#
+ (lambda (#{e\ 11410}# #{s\ 11411}#)
(begin
- (if (if (pair? #{e\ 1144}#) #{s\ 1145}# #f)
- (set-source-properties! #{e\ 1144}# #{s\ 1145}#))
- #{e\ 1144}#)))
- (#{get-global-definition-hook\ 93}#
- (lambda (#{symbol\ 1146}# #{module\ 1147}#)
+ (if (if (pair? #{e\ 11410}#) #{s\ 11411}# #f)
+ (set-source-properties!
+ #{e\ 11410}#
+ #{s\ 11411}#))
+ #{e\ 11410}#)))
+ (#{get-global-definition-hook\ 8992}#
+ (lambda (#{symbol\ 11416}# #{module\ 11417}#)
(begin
- (if (if (not #{module\ 1147}#) (current-module) #f)
+ (if (if (not #{module\ 11417}#) (current-module) #f)
(warn "module system is booted, we should have a module"
- #{symbol\ 1146}#))
- (let ((#{v\ 1148}#
+ #{symbol\ 11416}#))
+ (let ((#{v\ 11423}#
(module-variable
- (if #{module\ 1147}#
- (resolve-module (cdr #{module\ 1147}#))
+ (if #{module\ 11417}#
+ (resolve-module (cdr #{module\ 11417}#))
(current-module))
- #{symbol\ 1146}#)))
- (if #{v\ 1148}#
- (if (variable-bound? #{v\ 1148}#)
- (let ((#{val\ 1149}# (variable-ref #{v\ 1148}#)))
- (if (macro? #{val\ 1149}#)
- (if (syncase-macro-type #{val\ 1149}#)
- (cons (syncase-macro-type #{val\ 1149}#)
- (syncase-macro-binding #{val\ 1149}#))
+ #{symbol\ 11416}#)))
+ (if #{v\ 11423}#
+ (if (variable-bound? #{v\ 11423}#)
+ (let ((#{val\ 11428}# (variable-ref #{v\ 11423}#)))
+ (if (macro? #{val\ 11428}#)
+ (if (macro-type #{val\ 11428}#)
+ (cons (macro-type #{val\ 11428}#)
+ (macro-binding #{val\ 11428}#))
#f)
#f))
#f)
#f)))))
- (#{put-global-definition-hook\ 92}#
- (lambda (#{symbol\ 1150}# #{type\ 1151}# #{val\ 1152}#)
- (let ((#{existing\ 1153}#
- (let ((#{v\ 1154}#
- (module-variable
- (current-module)
- #{symbol\ 1150}#)))
- (if #{v\ 1154}#
- (if (variable-bound? #{v\ 1154}#)
- (let ((#{val\ 1155}# (variable-ref #{v\ 1154}#)))
- (if (macro? #{val\ 1155}#)
- (if (not (syncase-macro-type #{val\ 1155}#))
- #{val\ 1155}#
- #f)
- #f))
- #f)
- #f))))
- (module-define!
- (current-module)
- #{symbol\ 1150}#
- (if #{existing\ 1153}#
- (make-extended-syncase-macro
- #{existing\ 1153}#
- #{type\ 1151}#
- #{val\ 1152}#)
- (make-syncase-macro #{type\ 1151}# #{val\ 1152}#))))))
- (#{local-eval-hook\ 91}#
- (lambda (#{x\ 1156}# #{mod\ 1157}#)
+ (#{put-global-definition-hook\ 8990}#
+ (lambda (#{symbol\ 11432}#
+ #{type\ 11433}#
+ #{val\ 11434}#)
+ (module-define!
+ (current-module)
+ #{symbol\ 11432}#
+ (make-syntax-transformer
+ #{symbol\ 11432}#
+ #{type\ 11433}#
+ #{val\ 11434}#))))
+ (#{local-eval-hook\ 8987}#
+ (lambda (#{x\ 11438}# #{mod\ 11439}#)
(primitive-eval
- (list #{noexpand\ 84}#
- (let ((#{atom-key\ 1158}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1158}# (quote (c)))
+ (list #{noexpand\ 8973}#
+ (let ((#{atom-key\ 11445}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11445}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 1156}#)
- #{x\ 1156}#))))))
- (#{top-level-eval-hook\ 90}#
- (lambda (#{x\ 1159}# #{mod\ 1160}#)
+ #{x\ 11438}#)
+ #{x\ 11438}#))))))
+ (#{top-level-eval-hook\ 8985}#
+ (lambda (#{x\ 11448}# #{mod\ 11449}#)
(primitive-eval
- (list #{noexpand\ 84}#
- (let ((#{atom-key\ 1161}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 1161}# (quote (c)))
+ (list #{noexpand\ 8973}#
+ (let ((#{atom-key\ 11455}#
+ (fluid-ref #{*mode*\ 8975}#)))
+ (if (memv #{atom-key\ 11455}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 1159}#)
- #{x\ 1159}#))))))
- (#{fx<\ 89}# <)
- (#{fx=\ 88}# =)
- (#{fx-\ 87}# -)
- (#{fx+\ 86}# +)
- (#{*mode*\ 85}# (make-fluid))
- (#{noexpand\ 84}# "noexpand"))
+ #{x\ 11448}#)
+ #{x\ 11448}#))))))
+ (#{fx<\ 8983}# <)
+ (#{fx=\ 8981}# =)
+ (#{fx-\ 8979}# -)
+ (#{fx+\ 8977}# +)
+ (#{*mode*\ 8975}# (make-fluid))
+ (#{noexpand\ 8973}# "noexpand"))
(begin
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'local-syntax
'letrec-syntax
#t)
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'local-syntax
'let-syntax
#f)
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'core
'fluid-let-syntax
- (lambda (#{e\ 1162}#
- #{r\ 1163}#
- #{w\ 1164}#
- #{s\ 1165}#
- #{mod\ 1166}#)
- ((lambda (#{tmp\ 1167}#)
- ((lambda (#{tmp\ 1168}#)
- (if (if #{tmp\ 1168}#
- (apply (lambda (#{_\ 1169}#
- #{var\ 1170}#
- #{val\ 1171}#
- #{e1\ 1172}#
- #{e2\ 1173}#)
- (#{valid-bound-ids?\ 156}# #{var\ 1170}#))
- #{tmp\ 1168}#)
+ (lambda (#{e\ 11458}#
+ #{r\ 11459}#
+ #{w\ 11460}#
+ #{s\ 11461}#
+ #{mod\ 11462}#)
+ ((lambda (#{tmp\ 11468}#)
+ ((lambda (#{tmp\ 11469}#)
+ (if (if #{tmp\ 11469}#
+ (apply (lambda (#{_\ 11475}#
+ #{var\ 11476}#
+ #{val\ 11477}#
+ #{e1\ 11478}#
+ #{e2\ 11479}#)
+ (#{valid-bound-ids?\ 9139}# #{var\ 11476}#))
+ #{tmp\ 11469}#)
#f)
- (apply (lambda (#{_\ 1175}#
- #{var\ 1176}#
- #{val\ 1177}#
- #{e1\ 1178}#
- #{e2\ 1179}#)
- (let ((#{names\ 1180}#
- (map (lambda (#{x\ 1181}#)
- (#{id-var-name\ 153}#
- #{x\ 1181}#
- #{w\ 1164}#))
- #{var\ 1176}#)))
+ (apply (lambda (#{_\ 11486}#
+ #{var\ 11487}#
+ #{val\ 11488}#
+ #{e1\ 11489}#
+ #{e2\ 11490}#)
+ (let ((#{names\ 11492}#
+ (map (lambda (#{x\ 11493}#)
+ (#{id-var-name\ 9133}#
+ #{x\ 11493}#
+ #{w\ 11460}#))
+ #{var\ 11487}#)))
(begin
(for-each
- (lambda (#{id\ 1183}# #{n\ 1184}#)
- (let ((#{atom-key\ 1185}#
- (#{binding-type\ 123}#
- (#{lookup\ 128}#
- #{n\ 1184}#
- #{r\ 1163}#
- #{mod\ 1166}#))))
- (if (memv #{atom-key\ 1185}#
+ (lambda (#{id\ 11496}# #{n\ 11497}#)
+ (let ((#{atom-key\ 11502}#
+ (#{binding-type\ 9059}#
+ (#{lookup\ 9070}#
+ #{n\ 11497}#
+ #{r\ 11459}#
+ #{mod\ 11462}#))))
+ (if (memv #{atom-key\ 11502}#
'(displaced-lexical))
(syntax-violation
'fluid-let-syntax
"identifier out of context"
- #{e\ 1162}#
- (#{source-wrap\ 160}#
- #{id\ 1183}#
- #{w\ 1164}#
- #{s\ 1165}#
- #{mod\ 1166}#)))))
- #{var\ 1176}#
- #{names\ 1180}#)
- (#{chi-body\ 171}#
- (cons #{e1\ 1178}# #{e2\ 1179}#)
- (#{source-wrap\ 160}#
- #{e\ 1162}#
- #{w\ 1164}#
- #{s\ 1165}#
- #{mod\ 1166}#)
- (#{extend-env\ 125}#
- #{names\ 1180}#
- (let ((#{trans-r\ 1188}#
- (#{macros-only-env\ 127}#
- #{r\ 1163}#)))
- (map (lambda (#{x\ 1189}#)
+ #{e\ 11458}#
+ (#{source-wrap\ 9147}#
+ #{id\ 11496}#
+ #{w\ 11460}#
+ #{s\ 11461}#
+ #{mod\ 11462}#)))))
+ #{var\ 11487}#
+ #{names\ 11492}#)
+ (#{chi-body\ 9169}#
+ (cons #{e1\ 11489}# #{e2\ 11490}#)
+ (#{source-wrap\ 9147}#
+ #{e\ 11458}#
+ #{w\ 11460}#
+ #{s\ 11461}#
+ #{mod\ 11462}#)
+ (#{extend-env\ 9064}#
+ #{names\ 11492}#
+ (let ((#{trans-r\ 11507}#
+ (#{macros-only-env\ 9068}#
+ #{r\ 11459}#)))
+ (map (lambda (#{x\ 11508}#)
(cons 'macro
- (#{eval-local-transformer\
173}#
- (#{chi\ 167}#
- #{x\ 1189}#
- #{trans-r\ 1188}#
- #{w\ 1164}#
- #{mod\ 1166}#)
- #{mod\ 1166}#)))
- #{val\ 1177}#))
- #{r\ 1163}#)
- #{w\ 1164}#
- #{mod\ 1166}#))))
- #{tmp\ 1168}#)
- ((lambda (#{_\ 1191}#)
+ (#{eval-local-transformer\
9173}#
+ (#{chi\ 9161}#
+ #{x\ 11508}#
+ #{trans-r\ 11507}#
+ #{w\ 11460}#
+ #{mod\ 11462}#)
+ #{mod\ 11462}#)))
+ #{val\ 11488}#))
+ #{r\ 11459}#)
+ #{w\ 11460}#
+ #{mod\ 11462}#))))
+ #{tmp\ 11469}#)
+ ((lambda (#{_\ 11513}#)
(syntax-violation
'fluid-let-syntax
"bad syntax"
- (#{source-wrap\ 160}#
- #{e\ 1162}#
- #{w\ 1164}#
- #{s\ 1165}#
- #{mod\ 1166}#)))
- #{tmp\ 1167}#)))
+ (#{source-wrap\ 9147}#
+ #{e\ 11458}#
+ #{w\ 11460}#
+ #{s\ 11461}#
+ #{mod\ 11462}#)))
+ #{tmp\ 11468}#)))
($sc-dispatch
- #{tmp\ 1167}#
+ #{tmp\ 11468}#
'(any #(each (any any)) any . each-any))))
- #{e\ 1162}#)))
- (#{global-extend\ 129}#
+ #{e\ 11458}#)))
+ (#{global-extend\ 9072}#
'core
'quote
- (lambda (#{e\ 1192}#
- #{r\ 1193}#
- #{w\ 1194}#
- #{s\ 1195}#
- #{mod\ 1196}#)
- ((lambda (#{tmp\ 1197}#)
- ((lambda (#{tmp\ 1198}#)
- (if #{tmp\ 1198}#
- (apply (lambda (#{_\ 1199}# #{e\ 1200}#)
- (#{build-data\ 109}#
- #{s\ 1195}#
- (#{strip\ 180}# #{e\ 1200}# #{w\ 1194}#)))
- #{tmp\ 1198}#)
- ((lambda (#{_\ 1201}#)
+ (lambda (#{e\ 11514}#
+ #{r\ 11515}#
+ #{w\ 11516}#
+ #{s\ 11517}#
+ #{mod\ 11518}#)
+ ((lambda (#{tmp\ 11524}#)
+ ((lambda (#{tmp\ 11525}#)
+ (if #{tmp\ 11525}#
+ (apply (lambda (#{_\ 11528}# #{e\ 11529}#)
+ (#{build-data\ 9026}#
+ #{s\ 11517}#
+ (#{strip\ 9187}# #{e\ 11529}# #{w\ 11516}#)))
+ #{tmp\ 11525}#)
+ ((lambda (#{_\ 11531}#)
(syntax-violation
'quote
"bad syntax"
- (#{source-wrap\ 160}#
- #{e\ 1192}#
- #{w\ 1194}#
- #{s\ 1195}#
- #{mod\ 1196}#)))
- #{tmp\ 1197}#)))
- ($sc-dispatch #{tmp\ 1197}# (quote (any any)))))
- #{e\ 1192}#)))
- (#{global-extend\ 129}#
+ (#{source-wrap\ 9147}#
+ #{e\ 11514}#
+ #{w\ 11516}#
+ #{s\ 11517}#
+ #{mod\ 11518}#)))
+ #{tmp\ 11524}#)))
+ ($sc-dispatch #{tmp\ 11524}# (quote (any any)))))
+ #{e\ 11514}#)))
+ (#{global-extend\ 9072}#
'core
'syntax
- (letrec ((#{regen\ 1209}#
- (lambda (#{x\ 1210}#)
- (let ((#{atom-key\ 1211}# (car #{x\ 1210}#)))
- (if (memv #{atom-key\ 1211}# (quote (ref)))
- (#{build-lexical-reference\ 98}#
+ (letrec ((#{regen\ 11547}#
+ (lambda (#{x\ 11548}#)
+ (let ((#{atom-key\ 11552}# (car #{x\ 11548}#)))
+ (if (memv #{atom-key\ 11552}# (quote (ref)))
+ (#{build-lexical-reference\ 9004}#
'value
#f
- (cadr #{x\ 1210}#)
- (cadr #{x\ 1210}#))
- (if (memv #{atom-key\ 1211}# (quote (primitive)))
- (#{build-primref\ 108}# #f (cadr #{x\ 1210}#))
- (if (memv #{atom-key\ 1211}# (quote (quote)))
- (#{build-data\ 109}# #f (cadr #{x\ 1210}#))
- (if (memv #{atom-key\ 1211}# (quote (lambda)))
- (if (list? (cadr #{x\ 1210}#))
- (#{build-simple-lambda\ 105}#
- #f
- (cadr #{x\ 1210}#)
+ (cadr #{x\ 11548}#)
+ (cadr #{x\ 11548}#))
+ (if (memv #{atom-key\ 11552}# (quote (primitive)))
+ (#{build-primref\ 9024}# #f (cadr #{x\ 11548}#))
+ (if (memv #{atom-key\ 11552}# (quote (quote)))
+ (#{build-data\ 9026}# #f (cadr #{x\ 11548}#))
+ (if (memv #{atom-key\ 11552}# (quote (lambda)))
+ (if (list? (cadr #{x\ 11548}#))
+ (#{build-simple-lambda\ 9018}#
#f
- (cadr #{x\ 1210}#)
+ (cadr #{x\ 11548}#)
#f
- (#{regen\ 1209}# (caddr #{x\ 1210}#)))
- (error "how did we get here" #{x\ 1210}#))
- (#{build-application\ 96}#
+ (cadr #{x\ 11548}#)
+ '()
+ (#{regen\ 11547}# (caddr #{x\ 11548}#)))
+ (error "how did we get here" #{x\ 11548}#))
+ (#{build-application\ 8998}#
#f
- (#{build-primref\ 108}# #f (car #{x\ 1210}#))
- (map #{regen\ 1209}#
- (cdr #{x\ 1210}#))))))))))
- (#{gen-vector\ 1208}#
- (lambda (#{x\ 1212}#)
- (if (eq? (car #{x\ 1212}#) (quote list))
- (cons (quote vector) (cdr #{x\ 1212}#))
- (if (eq? (car #{x\ 1212}#) (quote quote))
+ (#{build-primref\ 9024}#
+ #f
+ (car #{x\ 11548}#))
+ (map #{regen\ 11547}#
+ (cdr #{x\ 11548}#))))))))))
+ (#{gen-vector\ 11545}#
+ (lambda (#{x\ 11564}#)
+ (if (eq? (car #{x\ 11564}#) (quote list))
+ (cons (quote vector) (cdr #{x\ 11564}#))
+ (if (eq? (car #{x\ 11564}#) (quote quote))
(list 'quote
- (list->vector (cadr #{x\ 1212}#)))
- (list (quote list->vector) #{x\ 1212}#)))))
- (#{gen-append\ 1207}#
- (lambda (#{x\ 1213}# #{y\ 1214}#)
- (if (equal? #{y\ 1214}# (quote (quote ())))
- #{x\ 1213}#
- (list (quote append) #{x\ 1213}# #{y\ 1214}#))))
- (#{gen-cons\ 1206}#
- (lambda (#{x\ 1215}# #{y\ 1216}#)
- (let ((#{atom-key\ 1217}# (car #{y\ 1216}#)))
- (if (memv #{atom-key\ 1217}# (quote (quote)))
- (if (eq? (car #{x\ 1215}#) (quote quote))
+ (list->vector (cadr #{x\ 11564}#)))
+ (list (quote list->vector) #{x\ 11564}#)))))
+ (#{gen-append\ 11543}#
+ (lambda (#{x\ 11574}# #{y\ 11575}#)
+ (if (equal? #{y\ 11575}# (quote (quote ())))
+ #{x\ 11574}#
+ (list (quote append) #{x\ 11574}# #{y\ 11575}#))))
+ (#{gen-cons\ 11541}#
+ (lambda (#{x\ 11579}# #{y\ 11580}#)
+ (let ((#{atom-key\ 11585}# (car #{y\ 11580}#)))
+ (if (memv #{atom-key\ 11585}# (quote (quote)))
+ (if (eq? (car #{x\ 11579}#) (quote quote))
(list 'quote
- (cons (cadr #{x\ 1215}#) (cadr #{y\ 1216}#)))
- (if (eq? (cadr #{y\ 1216}#) (quote ()))
- (list (quote list) #{x\ 1215}#)
- (list (quote cons) #{x\ 1215}# #{y\ 1216}#)))
- (if (memv #{atom-key\ 1217}# (quote (list)))
+ (cons (cadr #{x\ 11579}#)
+ (cadr #{y\ 11580}#)))
+ (if (eq? (cadr #{y\ 11580}#) (quote ()))
+ (list (quote list) #{x\ 11579}#)
+ (list (quote cons) #{x\ 11579}# #{y\ 11580}#)))
+ (if (memv #{atom-key\ 11585}# (quote (list)))
(cons 'list
- (cons #{x\ 1215}# (cdr #{y\ 1216}#)))
- (list (quote cons) #{x\ 1215}# #{y\ 1216}#))))))
- (#{gen-map\ 1205}#
- (lambda (#{e\ 1218}# #{map-env\ 1219}#)
- (let ((#{formals\ 1220}# (map cdr #{map-env\ 1219}#))
- (#{actuals\ 1221}#
- (map (lambda (#{x\ 1222}#)
- (list (quote ref) (car #{x\ 1222}#)))
- #{map-env\ 1219}#)))
- (if (eq? (car #{e\ 1218}#) (quote ref))
- (car #{actuals\ 1221}#)
+ (cons #{x\ 11579}# (cdr #{y\ 11580}#)))
+ (list (quote cons) #{x\ 11579}# #{y\ 11580}#))))))
+ (#{gen-map\ 11539}#
+ (lambda (#{e\ 11594}# #{map-env\ 11595}#)
+ (let ((#{formals\ 11600}# (map cdr #{map-env\ 11595}#))
+ (#{actuals\ 11601}#
+ (map (lambda (#{x\ 11602}#)
+ (list (quote ref) (car #{x\ 11602}#)))
+ #{map-env\ 11595}#)))
+ (if (eq? (car #{e\ 11594}#) (quote ref))
+ (car #{actuals\ 11601}#)
(if (and-map
- (lambda (#{x\ 1223}#)
- (if (eq? (car #{x\ 1223}#) (quote ref))
- (memq (cadr #{x\ 1223}#) #{formals\ 1220}#)
+ (lambda (#{x\ 11609}#)
+ (if (eq? (car #{x\ 11609}#) (quote ref))
+ (memq (cadr #{x\ 11609}#)
+ #{formals\ 11600}#)
#f))
- (cdr #{e\ 1218}#))
+ (cdr #{e\ 11594}#))
(cons 'map
(cons (list 'primitive
- (car #{e\ 1218}#))
- (map (let ((#{r\ 1224}#
+ (car #{e\ 11594}#))
+ (map (let ((#{r\ 11615}#
(map cons
- #{formals\ 1220}#
- #{actuals\ 1221}#)))
- (lambda (#{x\ 1225}#)
- (cdr (assq (cadr #{x\ 1225}#)
- #{r\ 1224}#))))
- (cdr #{e\ 1218}#))))
+ #{formals\ 11600}#
+ #{actuals\ 11601}#)))
+ (lambda (#{x\ 11616}#)
+ (cdr (assq (cadr #{x\ 11616}#)
+ #{r\ 11615}#))))
+ (cdr #{e\ 11594}#))))
(cons 'map
(cons (list 'lambda
- #{formals\ 1220}#
- #{e\ 1218}#)
- #{actuals\ 1221}#)))))))
- (#{gen-mappend\ 1204}#
- (lambda (#{e\ 1226}# #{map-env\ 1227}#)
+ #{formals\ 11600}#
+ #{e\ 11594}#)
+ #{actuals\ 11601}#)))))))
+ (#{gen-mappend\ 11537}#
+ (lambda (#{e\ 11620}# #{map-env\ 11621}#)
(list 'apply
'(primitive append)
- (#{gen-map\ 1205}# #{e\ 1226}# #{map-env\ 1227}#))))
- (#{gen-ref\ 1203}#
- (lambda (#{src\ 1228}#
- #{var\ 1229}#
- #{level\ 1230}#
- #{maps\ 1231}#)
- (if (#{fx=\ 88}# #{level\ 1230}# 0)
- (values #{var\ 1229}# #{maps\ 1231}#)
- (if (null? #{maps\ 1231}#)
+ (#{gen-map\ 11539}#
+ #{e\ 11620}#
+ #{map-env\ 11621}#))))
+ (#{gen-ref\ 11535}#
+ (lambda (#{src\ 11625}#
+ #{var\ 11626}#
+ #{level\ 11627}#
+ #{maps\ 11628}#)
+ (if (#{fx=\ 8981}# #{level\ 11627}# 0)
+ (values #{var\ 11626}# #{maps\ 11628}#)
+ (if (null? #{maps\ 11628}#)
(syntax-violation
'syntax
"missing ellipsis"
- #{src\ 1228}#)
+ #{src\ 11625}#)
(call-with-values
(lambda ()
- (#{gen-ref\ 1203}#
- #{src\ 1228}#
- #{var\ 1229}#
- (#{fx-\ 87}# #{level\ 1230}# 1)
- (cdr #{maps\ 1231}#)))
- (lambda (#{outer-var\ 1232}# #{outer-maps\ 1233}#)
- (let ((#{b\ 1234}#
- (assq #{outer-var\ 1232}#
- (car #{maps\ 1231}#))))
- (if #{b\ 1234}#
- (values (cdr #{b\ 1234}#) #{maps\ 1231}#)
- (let ((#{inner-var\ 1235}#
- (#{gen-var\ 181}# (quote tmp))))
+ (#{gen-ref\ 11535}#
+ #{src\ 11625}#
+ #{var\ 11626}#
+ (#{fx-\ 8979}# #{level\ 11627}# 1)
+ (cdr #{maps\ 11628}#)))
+ (lambda (#{outer-var\ 11633}# #{outer-maps\ 11634}#)
+ (let ((#{b\ 11638}#
+ (assq #{outer-var\ 11633}#
+ (car #{maps\ 11628}#))))
+ (if #{b\ 11638}#
+ (values (cdr #{b\ 11638}#) #{maps\ 11628}#)
+ (let ((#{inner-var\ 11640}#
+ (#{gen-var\ 9189}# (quote tmp))))
(values
- #{inner-var\ 1235}#
- (cons (cons (cons #{outer-var\ 1232}#
- #{inner-var\ 1235}#)
- (car #{maps\ 1231}#))
- #{outer-maps\ 1233}#)))))))))))
- (#{gen-syntax\ 1202}#
- (lambda (#{src\ 1236}#
- #{e\ 1237}#
- #{r\ 1238}#
- #{maps\ 1239}#
- #{ellipsis?\ 1240}#
- #{mod\ 1241}#)
- (if (#{id?\ 131}# #{e\ 1237}#)
- (let ((#{label\ 1242}#
- (#{id-var-name\ 153}#
- #{e\ 1237}#
+ #{inner-var\ 11640}#
+ (cons (cons (cons #{outer-var\ 11633}#
+ #{inner-var\ 11640}#)
+ (car #{maps\ 11628}#))
+ #{outer-maps\ 11634}#)))))))))))
+ (#{gen-syntax\ 11533}#
+ (lambda (#{src\ 11641}#
+ #{e\ 11642}#
+ #{r\ 11643}#
+ #{maps\ 11644}#
+ #{ellipsis?\ 11645}#
+ #{mod\ 11646}#)
+ (if (#{id?\ 9076}# #{e\ 11642}#)
+ (let ((#{label\ 11654}#
+ (#{id-var-name\ 9133}#
+ #{e\ 11642}#
'(()))))
- (let ((#{b\ 1243}#
- (#{lookup\ 128}#
- #{label\ 1242}#
- #{r\ 1238}#
- #{mod\ 1241}#)))
- (if (eq? (#{binding-type\ 123}# #{b\ 1243}#)
+ (let ((#{b\ 11657}#
+ (#{lookup\ 9070}#
+ #{label\ 11654}#
+ #{r\ 11643}#
+ #{mod\ 11646}#)))
+ (if (eq? (#{binding-type\ 9059}# #{b\ 11657}#)
'syntax)
(call-with-values
(lambda ()
- (let ((#{var.lev\ 1244}#
- (#{binding-value\ 124}# #{b\ 1243}#)))
- (#{gen-ref\ 1203}#
- #{src\ 1236}#
- (car #{var.lev\ 1244}#)
- (cdr #{var.lev\ 1244}#)
- #{maps\ 1239}#)))
- (lambda (#{var\ 1245}# #{maps\ 1246}#)
+ (let ((#{var.lev\ 11659}#
+ (#{binding-value\ 9061}#
+ #{b\ 11657}#)))
+ (#{gen-ref\ 11535}#
+ #{src\ 11641}#
+ (car #{var.lev\ 11659}#)
+ (cdr #{var.lev\ 11659}#)
+ #{maps\ 11644}#)))
+ (lambda (#{var\ 11660}# #{maps\ 11661}#)
(values
- (list (quote ref) #{var\ 1245}#)
- #{maps\ 1246}#)))
- (if (#{ellipsis?\ 1240}# #{e\ 1237}#)
+ (list (quote ref) #{var\ 11660}#)
+ #{maps\ 11661}#)))
+ (if (#{ellipsis?\ 11645}# #{e\ 11642}#)
(syntax-violation
'syntax
"misplaced ellipsis"
- #{src\ 1236}#)
+ #{src\ 11641}#)
(values
- (list (quote quote) #{e\ 1237}#)
- #{maps\ 1239}#)))))
- ((lambda (#{tmp\ 1247}#)
- ((lambda (#{tmp\ 1248}#)
- (if (if #{tmp\ 1248}#
- (apply (lambda (#{dots\ 1249}# #{e\ 1250}#)
- (#{ellipsis?\ 1240}#
- #{dots\ 1249}#))
- #{tmp\ 1248}#)
+ (list (quote quote) #{e\ 11642}#)
+ #{maps\ 11644}#)))))
+ ((lambda (#{tmp\ 11666}#)
+ ((lambda (#{tmp\ 11667}#)
+ (if (if #{tmp\ 11667}#
+ (apply (lambda (#{dots\ 11670}#
+ #{e\ 11671}#)
+ (#{ellipsis?\ 11645}#
+ #{dots\ 11670}#))
+ #{tmp\ 11667}#)
#f)
- (apply (lambda (#{dots\ 1251}# #{e\ 1252}#)
- (#{gen-syntax\ 1202}#
- #{src\ 1236}#
- #{e\ 1252}#
- #{r\ 1238}#
- #{maps\ 1239}#
- (lambda (#{x\ 1253}#) #f)
- #{mod\ 1241}#))
- #{tmp\ 1248}#)
- ((lambda (#{tmp\ 1254}#)
- (if (if #{tmp\ 1254}#
- (apply (lambda (#{x\ 1255}#
- #{dots\ 1256}#
- #{y\ 1257}#)
- (#{ellipsis?\ 1240}#
- #{dots\ 1256}#))
- #{tmp\ 1254}#)
+ (apply (lambda (#{dots\ 11674}# #{e\ 11675}#)
+ (#{gen-syntax\ 11533}#
+ #{src\ 11641}#
+ #{e\ 11675}#
+ #{r\ 11643}#
+ #{maps\ 11644}#
+ (lambda (#{x\ 11676}#) #f)
+ #{mod\ 11646}#))
+ #{tmp\ 11667}#)
+ ((lambda (#{tmp\ 11678}#)
+ (if (if #{tmp\ 11678}#
+ (apply (lambda (#{x\ 11682}#
+ #{dots\ 11683}#
+ #{y\ 11684}#)
+ (#{ellipsis?\ 11645}#
+ #{dots\ 11683}#))
+ #{tmp\ 11678}#)
#f)
- (apply (lambda (#{x\ 1258}#
- #{dots\ 1259}#
- #{y\ 1260}#)
- (letrec ((#{f\ 1261}#
- (lambda (#{y\ 1262}#
- #{k\ 1263}#)
- ((lambda (#{tmp\
1267}#)
- ((lambda (#{tmp\
1268}#)
- (if (if #{tmp\
1268}#
- (apply
(lambda (#{dots\ 1269}#
-
#{y\ 1270}#)
-
(#{ellipsis?\ 1240}#
-
#{dots\ 1269}#))
-
#{tmp\ 1268}#)
+ (apply (lambda (#{x\ 11688}#
+ #{dots\ 11689}#
+ #{y\ 11690}#)
+ (letrec ((#{f\ 11694}#
+ (lambda (#{y\ 11695}#
+ #{k\ 11696}#)
+ ((lambda (#{tmp\
11703}#)
+ ((lambda (#{tmp\
11704}#)
+ (if (if #{tmp\
11704}#
+ (apply
(lambda (#{dots\ 11707}#
+
#{y\ 11708}#)
+
(#{ellipsis?\ 11645}#
+
#{dots\ 11707}#))
+
#{tmp\ 11704}#)
#f)
- (apply
(lambda (#{dots\ 1271}#
-
#{y\ 1272}#)
-
(#{f\ 1261}#
-
#{y\ 1272}#
-
(lambda (#{maps\ 1273}#)
+ (apply
(lambda (#{dots\ 11711}#
+
#{y\ 11712}#)
+
(#{f\ 11694}#
+
#{y\ 11712}#
+
(lambda (#{maps\ 11713}#)
(call-with-values
(lambda ()
-
(#{k\ 1263}#
+
(#{k\ 11696}#
(cons '()
-
#{maps\ 1273}#)))
-
(lambda (#{x\ 1274}#
-
#{maps\ 1275}#)
-
(if (null? (car #{maps\ 1275}#))
+
#{maps\ 11713}#)))
+
(lambda (#{x\ 11715}#
+
#{maps\ 11716}#)
+
(if (null? (car #{maps\ 11716}#))
(syntax-violation
'syntax
"extra ellipsis"
-
#{src\ 1236}#)
+
#{src\ 11641}#)
(values
-
(#{gen-mappend\ 1204}#
-
#{x\ 1274}#
-
(car #{maps\ 1275}#))
-
(cdr #{maps\ 1275}#))))))))
-
#{tmp\ 1268}#)
- ((lambda
(#{_\ 1276}#)
+
(#{gen-mappend\ 11537}#
+
#{x\ 11715}#
+
(car #{maps\ 11716}#))
+
(cdr #{maps\ 11716}#))))))))
+
#{tmp\ 11704}#)
+ ((lambda
(#{_\ 11720}#)
(call-with-values
(lambda
()
-
(#{gen-syntax\ 1202}#
-
#{src\ 1236}#
-
#{y\ 1262}#
-
#{r\ 1238}#
-
#{maps\ 1239}#
-
#{ellipsis?\ 1240}#
-
#{mod\ 1241}#))
- (lambda
(#{y\ 1277}#
-
#{maps\ 1278}#)
+
(#{gen-syntax\ 11533}#
+
#{src\ 11641}#
+
#{y\ 11695}#
+
#{r\ 11643}#
+
#{maps\ 11644}#
+
#{ellipsis?\ 11645}#
+
#{mod\ 11646}#))
+ (lambda
(#{y\ 11721}#
+
#{maps\ 11722}#)
(call-with-values
(lambda ()
-
(#{k\ 1263}#
-
#{maps\ 1278}#))
-
(lambda (#{x\ 1279}#
-
#{maps\ 1280}#)
+
(#{k\ 11696}#
+
#{maps\ 11722}#))
+
(lambda (#{x\ 11725}#
+
#{maps\ 11726}#)
(values
-
(#{gen-append\ 1207}#
-
#{x\ 1279}#
-
#{y\ 1277}#)
-
#{maps\ 1280}#))))))
- #{tmp\
1267}#)))
+
(#{gen-append\ 11543}#
+
#{x\ 11725}#
+
#{y\ 11721}#)
+
#{maps\ 11726}#))))))
+ #{tmp\
11703}#)))
($sc-dispatch
- #{tmp\ 1267}#
+ #{tmp\ 11703}#
'(any . any))))
- #{y\ 1262}#))))
- (#{f\ 1261}#
- #{y\ 1260}#
- (lambda (#{maps\ 1264}#)
+ #{y\ 11695}#))))
+ (#{f\ 11694}#
+ #{y\ 11690}#
+ (lambda (#{maps\ 11697}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 1202}#
- #{src\ 1236}#
- #{x\ 1258}#
- #{r\ 1238}#
+ (#{gen-syntax\ 11533}#
+ #{src\ 11641}#
+ #{x\ 11688}#
+ #{r\ 11643}#
(cons '()
- #{maps\ 1264}#)
- #{ellipsis?\ 1240}#
- #{mod\ 1241}#))
- (lambda (#{x\ 1265}#
- #{maps\ 1266}#)
- (if (null? (car #{maps\
1266}#))
+ #{maps\ 11697}#)
+ #{ellipsis?\ 11645}#
+ #{mod\ 11646}#))
+ (lambda (#{x\ 11699}#
+ #{maps\ 11700}#)
+ (if (null? (car #{maps\
11700}#))
(syntax-violation
'syntax
"extra ellipsis"
- #{src\ 1236}#)
+ #{src\ 11641}#)
(values
- (#{gen-map\ 1205}#
- #{x\ 1265}#
- (car #{maps\
1266}#))
- (cdr #{maps\
1266}#)))))))))
- #{tmp\ 1254}#)
- ((lambda (#{tmp\ 1281}#)
- (if #{tmp\ 1281}#
- (apply (lambda (#{x\ 1282}#
- #{y\ 1283}#)
+ (#{gen-map\ 11539}#
+ #{x\ 11699}#
+ (car #{maps\
11700}#))
+ (cdr #{maps\
11700}#)))))))))
+ #{tmp\ 11678}#)
+ ((lambda (#{tmp\ 11729}#)
+ (if #{tmp\ 11729}#
+ (apply (lambda (#{x\ 11732}#
+ #{y\ 11733}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 1202}#
- #{src\ 1236}#
- #{x\ 1282}#
- #{r\ 1238}#
- #{maps\ 1239}#
- #{ellipsis?\ 1240}#
- #{mod\ 1241}#))
- (lambda (#{x\ 1284}#
- #{maps\ 1285}#)
+ (#{gen-syntax\ 11533}#
+ #{src\ 11641}#
+ #{x\ 11732}#
+ #{r\ 11643}#
+ #{maps\ 11644}#
+ #{ellipsis?\ 11645}#
+ #{mod\ 11646}#))
+ (lambda (#{x\ 11734}#
+ #{maps\ 11735}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 1202}#
- #{src\ 1236}#
- #{y\ 1283}#
- #{r\ 1238}#
- #{maps\ 1285}#
- #{ellipsis?\ 1240}#
- #{mod\ 1241}#))
- (lambda (#{y\ 1286}#
- #{maps\
1287}#)
+ (#{gen-syntax\
11533}#
+ #{src\ 11641}#
+ #{y\ 11733}#
+ #{r\ 11643}#
+ #{maps\ 11735}#
+ #{ellipsis?\
11645}#
+ #{mod\ 11646}#))
+ (lambda (#{y\ 11738}#
+ #{maps\
11739}#)
(values
- (#{gen-cons\ 1206}#
- #{x\ 1284}#
- #{y\ 1286}#)
- #{maps\
1287}#))))))
- #{tmp\ 1281}#)
- ((lambda (#{tmp\ 1288}#)
- (if #{tmp\ 1288}#
- (apply (lambda (#{e1\ 1289}#
- #{e2\ 1290}#)
+ (#{gen-cons\
11541}#
+ #{x\ 11734}#
+ #{y\ 11738}#)
+ #{maps\
11739}#))))))
+ #{tmp\ 11729}#)
+ ((lambda (#{tmp\ 11742}#)
+ (if #{tmp\ 11742}#
+ (apply (lambda (#{e1\ 11745}#
+ #{e2\ 11746}#)
(call-with-values
(lambda ()
- (#{gen-syntax\
1202}#
- #{src\ 1236}#
- (cons #{e1\ 1289}#
- #{e2\
1290}#)
- #{r\ 1238}#
- #{maps\ 1239}#
- #{ellipsis?\
1240}#
- #{mod\ 1241}#))
- (lambda (#{e\ 1292}#
- #{maps\
1293}#)
+ (#{gen-syntax\
11533}#
+ #{src\ 11641}#
+ (cons #{e1\
11745}#
+ #{e2\
11746}#)
+ #{r\ 11643}#
+ #{maps\ 11644}#
+ #{ellipsis?\
11645}#
+ #{mod\ 11646}#))
+ (lambda (#{e\ 11748}#
+ #{maps\
11749}#)
(values
- (#{gen-vector\
1208}#
- #{e\ 1292}#)
- #{maps\ 1293}#))))
- #{tmp\ 1288}#)
- ((lambda (#{_\ 1294}#)
+ (#{gen-vector\
11545}#
+ #{e\ 11748}#)
+ #{maps\
11749}#))))
+ #{tmp\ 11742}#)
+ ((lambda (#{_\ 11753}#)
(values
(list 'quote
- #{e\ 1237}#)
- #{maps\ 1239}#))
- #{tmp\ 1247}#)))
+ #{e\ 11642}#)
+ #{maps\ 11644}#))
+ #{tmp\ 11666}#)))
($sc-dispatch
- #{tmp\ 1247}#
+ #{tmp\ 11666}#
'#(vector (any . each-any))))))
($sc-dispatch
- #{tmp\ 1247}#
+ #{tmp\ 11666}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 1247}#
+ #{tmp\ 11666}#
'(any any . any)))))
- ($sc-dispatch #{tmp\ 1247}# (quote (any any)))))
- #{e\ 1237}#)))))
- (lambda (#{e\ 1295}#
- #{r\ 1296}#
- #{w\ 1297}#
- #{s\ 1298}#
- #{mod\ 1299}#)
- (let ((#{e\ 1300}#
- (#{source-wrap\ 160}#
- #{e\ 1295}#
- #{w\ 1297}#
- #{s\ 1298}#
- #{mod\ 1299}#)))
- ((lambda (#{tmp\ 1301}#)
- ((lambda (#{tmp\ 1302}#)
- (if #{tmp\ 1302}#
- (apply (lambda (#{_\ 1303}# #{x\ 1304}#)
+ ($sc-dispatch #{tmp\ 11666}# (quote (any any)))))
+ #{e\ 11642}#)))))
+ (lambda (#{e\ 11755}#
+ #{r\ 11756}#
+ #{w\ 11757}#
+ #{s\ 11758}#
+ #{mod\ 11759}#)
+ (let ((#{e\ 11766}#
+ (#{source-wrap\ 9147}#
+ #{e\ 11755}#
+ #{w\ 11757}#
+ #{s\ 11758}#
+ #{mod\ 11759}#)))
+ ((lambda (#{tmp\ 11767}#)
+ ((lambda (#{tmp\ 11768}#)
+ (if #{tmp\ 11768}#
+ (apply (lambda (#{_\ 11771}# #{x\ 11772}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 1202}#
- #{e\ 1300}#
- #{x\ 1304}#
- #{r\ 1296}#
+ (#{gen-syntax\ 11533}#
+ #{e\ 11766}#
+ #{x\ 11772}#
+ #{r\ 11756}#
'()
- #{ellipsis?\ 175}#
- #{mod\ 1299}#))
- (lambda (#{e\ 1305}# #{maps\ 1306}#)
- (#{regen\ 1209}# #{e\ 1305}#))))
- #{tmp\ 1302}#)
- ((lambda (#{_\ 1307}#)
+ #{ellipsis?\ 9177}#
+ #{mod\ 11759}#))
+ (lambda (#{e\ 11773}# #{maps\ 11774}#)
+ (#{regen\ 11547}# #{e\ 11773}#))))
+ #{tmp\ 11768}#)
+ ((lambda (#{_\ 11778}#)
(syntax-violation
'syntax
"bad `syntax' form"
- #{e\ 1300}#))
- #{tmp\ 1301}#)))
- ($sc-dispatch #{tmp\ 1301}# (quote (any any)))))
- #{e\ 1300}#)))))
- (#{global-extend\ 129}#
+ #{e\ 11766}#))
+ #{tmp\ 11767}#)))
+ ($sc-dispatch #{tmp\ 11767}# (quote (any any)))))
+ #{e\ 11766}#)))))
+ (#{global-extend\ 9072}#
'core
'lambda
- (lambda (#{e\ 1308}#
- #{r\ 1309}#
- #{w\ 1310}#
- #{s\ 1311}#
- #{mod\ 1312}#)
- ((lambda (#{tmp\ 1313}#)
- ((lambda (#{tmp\ 1314}#)
- (if (if #{tmp\ 1314}#
- (apply (lambda (#{_\ 1315}#
- #{args\ 1316}#
- #{docstring\ 1317}#
- #{e1\ 1318}#
- #{e2\ 1319}#)
- (string? (syntax->datum #{docstring\ 1317}#)))
- #{tmp\ 1314}#)
- #f)
- (apply (lambda (#{_\ 1320}#
- #{args\ 1321}#
- #{docstring\ 1322}#
- #{e1\ 1323}#
- #{e2\ 1324}#)
+ (lambda (#{e\ 11779}#
+ #{r\ 11780}#
+ #{w\ 11781}#
+ #{s\ 11782}#
+ #{mod\ 11783}#)
+ ((lambda (#{tmp\ 11789}#)
+ ((lambda (#{tmp\ 11790}#)
+ (if #{tmp\ 11790}#
+ (apply (lambda (#{_\ 11795}#
+ #{args\ 11796}#
+ #{e1\ 11797}#
+ #{e2\ 11798}#)
(call-with-values
(lambda ()
- (#{lambda-formals\ 176}# #{args\ 1321}#))
- (lambda (#{req\ 1325}#
- #{opt\ 1326}#
- #{rest\ 1327}#
- #{kw\ 1328}#)
- (#{chi-simple-lambda\ 177}#
- #{e\ 1308}#
- #{r\ 1309}#
- #{w\ 1310}#
- #{s\ 1311}#
- #{mod\ 1312}#
- #{req\ 1325}#
- #{rest\ 1327}#
- (syntax->datum #{docstring\ 1322}#)
- (cons #{e1\ 1323}# #{e2\ 1324}#)))))
- #{tmp\ 1314}#)
- ((lambda (#{tmp\ 1330}#)
- (if #{tmp\ 1330}#
- (apply (lambda (#{_\ 1331}#
- #{args\ 1332}#
- #{e1\ 1333}#
- #{e2\ 1334}#)
- (call-with-values
- (lambda ()
- (#{lambda-formals\ 176}# #{args\ 1332}#))
- (lambda (#{req\ 1335}#
- #{opt\ 1336}#
- #{rest\ 1337}#
- #{kw\ 1338}#)
- (#{chi-simple-lambda\ 177}#
- #{e\ 1308}#
- #{r\ 1309}#
- #{w\ 1310}#
- #{s\ 1311}#
- #{mod\ 1312}#
- #{req\ 1335}#
- #{rest\ 1337}#
- #f
- (cons #{e1\ 1333}# #{e2\ 1334}#)))))
- #{tmp\ 1330}#)
- ((lambda (#{_\ 1340}#)
- (syntax-violation
- 'lambda
- "bad lambda"
- #{e\ 1308}#))
- #{tmp\ 1313}#)))
- ($sc-dispatch
- #{tmp\ 1313}#
- '(any any any . each-any)))))
+ (#{lambda-formals\ 9179}# #{args\ 11796}#))
+ (lambda (#{req\ 11799}#
+ #{opt\ 11800}#
+ #{rest\ 11801}#
+ #{kw\ 11802}#)
+ (letrec ((#{lp\ 11810}#
+ (lambda (#{body\ 11811}#
+ #{meta\ 11812}#)
+ ((lambda (#{tmp\ 11814}#)
+ ((lambda (#{tmp\ 11815}#)
+ (if (if #{tmp\ 11815}#
+ (apply (lambda
(#{docstring\ 11819}#
+ #{e1\
11820}#
+ #{e2\
11821}#)
+ (string?
+
(syntax->datum
+
#{docstring\ 11819}#)))
+ #{tmp\ 11815}#)
+ #f)
+ (apply (lambda
(#{docstring\ 11825}#
+ #{e1\
11826}#
+ #{e2\
11827}#)
+ (#{lp\ 11810}#
+ (cons #{e1\
11826}#
+ #{e2\
11827}#)
+ (append
+ #{meta\
11812}#
+ (list (cons
'documentation
+
(syntax->datum
+
#{docstring\ 11825}#))))))
+ #{tmp\ 11815}#)
+ ((lambda (#{tmp\ 11830}#)
+ (if #{tmp\ 11830}#
+ (apply (lambda (#{k\
11835}#
+ #{v\
11836}#
+ #{e1\
11837}#
+ #{e2\
11838}#)
+ (#{lp\
11810}#
+ (cons
#{e1\ 11837}#
+
#{e2\ 11838}#)
+ (append
+ #{meta\
11812}#
+
(syntax->datum
+ (map
cons
+
#{k\ 11835}#
+
#{v\ 11836}#)))))
+ #{tmp\ 11830}#)
+ ((lambda (#{_\
11843}#)
+
(#{chi-simple-lambda\ 9181}#
+ #{e\ 11779}#
+ #{r\ 11780}#
+ #{w\ 11781}#
+ #{s\ 11782}#
+ #{mod\ 11783}#
+ #{req\ 11799}#
+ #{rest\ 11801}#
+ #{meta\ 11812}#
+ #{body\ 11811}#))
+ #{tmp\ 11814}#)))
+ ($sc-dispatch
+ #{tmp\ 11814}#
+ '(#(vector
+ #(each (any . any)))
+ any
+ .
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 11814}#
+ '(any any . each-any))))
+ #{body\ 11811}#))))
+ (#{lp\ 11810}#
+ (cons #{e1\ 11797}# #{e2\ 11798}#)
+ '())))))
+ #{tmp\ 11790}#)
+ ((lambda (#{_\ 11845}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda"
+ #{e\ 11779}#))
+ #{tmp\ 11789}#)))
($sc-dispatch
- #{tmp\ 1313}#
- '(any any any any . each-any))))
- #{e\ 1308}#)))
- (#{global-extend\ 129}#
+ #{tmp\ 11789}#
+ '(any any any . each-any))))
+ #{e\ 11779}#)))
+ (#{global-extend\ 9072}#
'core
'lambda*
- (lambda (#{e\ 1341}#
- #{r\ 1342}#
- #{w\ 1343}#
- #{s\ 1344}#
- #{mod\ 1345}#)
- ((lambda (#{tmp\ 1346}#)
- ((lambda (#{tmp\ 1347}#)
- (if #{tmp\ 1347}#
- (apply (lambda (#{_\ 1348}#
- #{args\ 1349}#
- #{e1\ 1350}#
- #{e2\ 1351}#)
+ (lambda (#{e\ 11846}#
+ #{r\ 11847}#
+ #{w\ 11848}#
+ #{s\ 11849}#
+ #{mod\ 11850}#)
+ ((lambda (#{tmp\ 11856}#)
+ ((lambda (#{tmp\ 11857}#)
+ (if #{tmp\ 11857}#
+ (apply (lambda (#{_\ 11862}#
+ #{args\ 11863}#
+ #{e1\ 11864}#
+ #{e2\ 11865}#)
(call-with-values
(lambda ()
- (#{chi-lambda-case\ 179}#
- #{e\ 1341}#
- #{r\ 1342}#
- #{w\ 1343}#
- #{s\ 1344}#
- #{mod\ 1345}#
- #{lambda*-formals\ 178}#
- (list (cons #{args\ 1349}#
- (cons #{e1\ 1350}#
- #{e2\ 1351}#)))))
- (lambda (#{docstring\ 1353}# #{lcase\ 1354}#)
- (#{build-case-lambda\ 106}#
- #{s\ 1344}#
- #{docstring\ 1353}#
- #{lcase\ 1354}#))))
- #{tmp\ 1347}#)
- ((lambda (#{_\ 1355}#)
+ (#{chi-lambda-case\ 9185}#
+ #{e\ 11846}#
+ #{r\ 11847}#
+ #{w\ 11848}#
+ #{s\ 11849}#
+ #{mod\ 11850}#
+ #{lambda*-formals\ 9183}#
+ (list (cons #{args\ 11863}#
+ (cons #{e1\ 11864}#
+ #{e2\ 11865}#)))))
+ (lambda (#{meta\ 11867}# #{lcase\ 11868}#)
+ (#{build-case-lambda\ 9020}#
+ #{s\ 11849}#
+ #{meta\ 11867}#
+ #{lcase\ 11868}#))))
+ #{tmp\ 11857}#)
+ ((lambda (#{_\ 11872}#)
(syntax-violation
'lambda
"bad lambda*"
- #{e\ 1341}#))
- #{tmp\ 1346}#)))
+ #{e\ 11846}#))
+ #{tmp\ 11856}#)))
($sc-dispatch
- #{tmp\ 1346}#
+ #{tmp\ 11856}#
'(any any any . each-any))))
- #{e\ 1341}#)))
- (#{global-extend\ 129}#
+ #{e\ 11846}#)))
+ (#{global-extend\ 9072}#
'core
'case-lambda
- (lambda (#{e\ 1356}#
- #{r\ 1357}#
- #{w\ 1358}#
- #{s\ 1359}#
- #{mod\ 1360}#)
- ((lambda (#{tmp\ 1361}#)
- ((lambda (#{tmp\ 1362}#)
- (if #{tmp\ 1362}#
- (apply (lambda (#{_\ 1363}#
- #{args\ 1364}#
- #{e1\ 1365}#
- #{e2\ 1366}#
- #{args*\ 1367}#
- #{e1*\ 1368}#
- #{e2*\ 1369}#)
+ (lambda (#{e\ 11873}#
+ #{r\ 11874}#
+ #{w\ 11875}#
+ #{s\ 11876}#
+ #{mod\ 11877}#)
+ ((lambda (#{tmp\ 11883}#)
+ ((lambda (#{tmp\ 11884}#)
+ (if #{tmp\ 11884}#
+ (apply (lambda (#{_\ 11892}#
+ #{args\ 11893}#
+ #{e1\ 11894}#
+ #{e2\ 11895}#
+ #{args*\ 11896}#
+ #{e1*\ 11897}#
+ #{e2*\ 11898}#)
(call-with-values
(lambda ()
- (#{chi-lambda-case\ 179}#
- #{e\ 1356}#
- #{r\ 1357}#
- #{w\ 1358}#
- #{s\ 1359}#
- #{mod\ 1360}#
- #{lambda-formals\ 176}#
- (cons (cons #{args\ 1364}#
- (cons #{e1\ 1365}# #{e2\ 1366}#))
- (map (lambda (#{tmp\ 1373}#
- #{tmp\ 1372}#
- #{tmp\ 1371}#)
- (cons #{tmp\ 1371}#
- (cons #{tmp\ 1372}#
- #{tmp\ 1373}#)))
- #{e2*\ 1369}#
- #{e1*\ 1368}#
- #{args*\ 1367}#))))
- (lambda (#{docstring\ 1375}# #{lcase\ 1376}#)
- (#{build-case-lambda\ 106}#
- #{s\ 1359}#
- #{docstring\ 1375}#
- #{lcase\ 1376}#))))
- #{tmp\ 1362}#)
- ((lambda (#{_\ 1377}#)
+ (#{chi-lambda-case\ 9185}#
+ #{e\ 11873}#
+ #{r\ 11874}#
+ #{w\ 11875}#
+ #{s\ 11876}#
+ #{mod\ 11877}#
+ #{lambda-formals\ 9179}#
+ (cons (cons #{args\ 11893}#
+ (cons #{e1\ 11894}#
+ #{e2\ 11895}#))
+ (map (lambda (#{tmp\ 11902}#
+ #{tmp\ 11901}#
+ #{tmp\ 11900}#)
+ (cons #{tmp\ 11900}#
+ (cons #{tmp\ 11901}#
+ #{tmp\ 11902}#)))
+ #{e2*\ 11898}#
+ #{e1*\ 11897}#
+ #{args*\ 11896}#))))
+ (lambda (#{meta\ 11904}# #{lcase\ 11905}#)
+ (#{build-case-lambda\ 9020}#
+ #{s\ 11876}#
+ #{meta\ 11904}#
+ #{lcase\ 11905}#))))
+ #{tmp\ 11884}#)
+ ((lambda (#{_\ 11909}#)
(syntax-violation
'case-lambda
"bad case-lambda"
- #{e\ 1356}#))
- #{tmp\ 1361}#)))
+ #{e\ 11873}#))
+ #{tmp\ 11883}#)))
($sc-dispatch
- #{tmp\ 1361}#
+ #{tmp\ 11883}#
'(any (any any . each-any)
.
#(each (any any . each-any))))))
- #{e\ 1356}#)))
- (#{global-extend\ 129}#
+ #{e\ 11873}#)))
+ (#{global-extend\ 9072}#
'core
'case-lambda*
- (lambda (#{e\ 1378}#
- #{r\ 1379}#
- #{w\ 1380}#
- #{s\ 1381}#
- #{mod\ 1382}#)
- ((lambda (#{tmp\ 1383}#)
- ((lambda (#{tmp\ 1384}#)
- (if #{tmp\ 1384}#
- (apply (lambda (#{_\ 1385}#
- #{args\ 1386}#
- #{e1\ 1387}#
- #{e2\ 1388}#
- #{args*\ 1389}#
- #{e1*\ 1390}#
- #{e2*\ 1391}#)
+ (lambda (#{e\ 11910}#
+ #{r\ 11911}#
+ #{w\ 11912}#
+ #{s\ 11913}#
+ #{mod\ 11914}#)
+ ((lambda (#{tmp\ 11920}#)
+ ((lambda (#{tmp\ 11921}#)
+ (if #{tmp\ 11921}#
+ (apply (lambda (#{_\ 11929}#
+ #{args\ 11930}#
+ #{e1\ 11931}#
+ #{e2\ 11932}#
+ #{args*\ 11933}#
+ #{e1*\ 11934}#
+ #{e2*\ 11935}#)
(call-with-values
(lambda ()
- (#{chi-lambda-case\ 179}#
- #{e\ 1378}#
- #{r\ 1379}#
- #{w\ 1380}#
- #{s\ 1381}#
- #{mod\ 1382}#
- #{lambda*-formals\ 178}#
- (cons (cons #{args\ 1386}#
- (cons #{e1\ 1387}# #{e2\ 1388}#))
- (map (lambda (#{tmp\ 1395}#
- #{tmp\ 1394}#
- #{tmp\ 1393}#)
- (cons #{tmp\ 1393}#
- (cons #{tmp\ 1394}#
- #{tmp\ 1395}#)))
- #{e2*\ 1391}#
- #{e1*\ 1390}#
- #{args*\ 1389}#))))
- (lambda (#{docstring\ 1397}# #{lcase\ 1398}#)
- (#{build-case-lambda\ 106}#
- #{s\ 1381}#
- #{docstring\ 1397}#
- #{lcase\ 1398}#))))
- #{tmp\ 1384}#)
- ((lambda (#{_\ 1399}#)
+ (#{chi-lambda-case\ 9185}#
+ #{e\ 11910}#
+ #{r\ 11911}#
+ #{w\ 11912}#
+ #{s\ 11913}#
+ #{mod\ 11914}#
+ #{lambda*-formals\ 9183}#
+ (cons (cons #{args\ 11930}#
+ (cons #{e1\ 11931}#
+ #{e2\ 11932}#))
+ (map (lambda (#{tmp\ 11939}#
+ #{tmp\ 11938}#
+ #{tmp\ 11937}#)
+ (cons #{tmp\ 11937}#
+ (cons #{tmp\ 11938}#
+ #{tmp\ 11939}#)))
+ #{e2*\ 11935}#
+ #{e1*\ 11934}#
+ #{args*\ 11933}#))))
+ (lambda (#{meta\ 11941}# #{lcase\ 11942}#)
+ (#{build-case-lambda\ 9020}#
+ #{s\ 11913}#
+ #{meta\ 11941}#
+ #{lcase\ 11942}#))))
+ #{tmp\ 11921}#)
+ ((lambda (#{_\ 11946}#)
(syntax-violation
'case-lambda
"bad case-lambda*"
- #{e\ 1378}#))
- #{tmp\ 1383}#)))
+ #{e\ 11910}#))
+ #{tmp\ 11920}#)))
($sc-dispatch
- #{tmp\ 1383}#
+ #{tmp\ 11920}#
'(any (any any . each-any)
.
#(each (any any . each-any))))))
- #{e\ 1378}#)))
- (#{global-extend\ 129}#
+ #{e\ 11910}#)))
+ (#{global-extend\ 9072}#
'core
'let
- (letrec ((#{chi-let\ 1400}#
- (lambda (#{e\ 1401}#
- #{r\ 1402}#
- #{w\ 1403}#
- #{s\ 1404}#
- #{mod\ 1405}#
- #{constructor\ 1406}#
- #{ids\ 1407}#
- #{vals\ 1408}#
- #{exps\ 1409}#)
- (if (not (#{valid-bound-ids?\ 156}# #{ids\ 1407}#))
+ (letrec ((#{chi-let\ 11948}#
+ (lambda (#{e\ 11949}#
+ #{r\ 11950}#
+ #{w\ 11951}#
+ #{s\ 11952}#
+ #{mod\ 11953}#
+ #{constructor\ 11954}#
+ #{ids\ 11955}#
+ #{vals\ 11956}#
+ #{exps\ 11957}#)
+ (if (not (#{valid-bound-ids?\ 9139}# #{ids\ 11955}#))
(syntax-violation
'let
"duplicate bound variable"
- #{e\ 1401}#)
- (let ((#{labels\ 1410}#
- (#{gen-labels\ 137}# #{ids\ 1407}#))
- (#{new-vars\ 1411}#
- (map #{gen-var\ 181}# #{ids\ 1407}#)))
- (let ((#{nw\ 1412}#
- (#{make-binding-wrap\ 148}#
- #{ids\ 1407}#
- #{labels\ 1410}#
- #{w\ 1403}#))
- (#{nr\ 1413}#
- (#{extend-var-env\ 126}#
- #{labels\ 1410}#
- #{new-vars\ 1411}#
- #{r\ 1402}#)))
- (#{constructor\ 1406}#
- #{s\ 1404}#
- (map syntax->datum #{ids\ 1407}#)
- #{new-vars\ 1411}#
- (map (lambda (#{x\ 1414}#)
- (#{chi\ 167}#
- #{x\ 1414}#
- #{r\ 1402}#
- #{w\ 1403}#
- #{mod\ 1405}#))
- #{vals\ 1408}#)
- (#{chi-body\ 171}#
- #{exps\ 1409}#
- (#{source-wrap\ 160}#
- #{e\ 1401}#
- #{nw\ 1412}#
- #{s\ 1404}#
- #{mod\ 1405}#)
- #{nr\ 1413}#
- #{nw\ 1412}#
- #{mod\ 1405}#))))))))
- (lambda (#{e\ 1415}#
- #{r\ 1416}#
- #{w\ 1417}#
- #{s\ 1418}#
- #{mod\ 1419}#)
- ((lambda (#{tmp\ 1420}#)
- ((lambda (#{tmp\ 1421}#)
- (if (if #{tmp\ 1421}#
- (apply (lambda (#{_\ 1422}#
- #{id\ 1423}#
- #{val\ 1424}#
- #{e1\ 1425}#
- #{e2\ 1426}#)
- (and-map #{id?\ 131}# #{id\ 1423}#))
- #{tmp\ 1421}#)
+ #{e\ 11949}#)
+ (let ((#{labels\ 11969}#
+ (#{gen-labels\ 9094}# #{ids\ 11955}#))
+ (#{new-vars\ 11970}#
+ (map #{gen-var\ 9189}# #{ids\ 11955}#)))
+ (let ((#{nw\ 11973}#
+ (#{make-binding-wrap\ 9123}#
+ #{ids\ 11955}#
+ #{labels\ 11969}#
+ #{w\ 11951}#))
+ (#{nr\ 11974}#
+ (#{extend-var-env\ 9066}#
+ #{labels\ 11969}#
+ #{new-vars\ 11970}#
+ #{r\ 11950}#)))
+ (#{constructor\ 11954}#
+ #{s\ 11952}#
+ (map syntax->datum #{ids\ 11955}#)
+ #{new-vars\ 11970}#
+ (map (lambda (#{x\ 11975}#)
+ (#{chi\ 9161}#
+ #{x\ 11975}#
+ #{r\ 11950}#
+ #{w\ 11951}#
+ #{mod\ 11953}#))
+ #{vals\ 11956}#)
+ (#{chi-body\ 9169}#
+ #{exps\ 11957}#
+ (#{source-wrap\ 9147}#
+ #{e\ 11949}#
+ #{nw\ 11973}#
+ #{s\ 11952}#
+ #{mod\ 11953}#)
+ #{nr\ 11974}#
+ #{nw\ 11973}#
+ #{mod\ 11953}#))))))))
+ (lambda (#{e\ 11977}#
+ #{r\ 11978}#
+ #{w\ 11979}#
+ #{s\ 11980}#
+ #{mod\ 11981}#)
+ ((lambda (#{tmp\ 11987}#)
+ ((lambda (#{tmp\ 11988}#)
+ (if (if #{tmp\ 11988}#
+ (apply (lambda (#{_\ 11994}#
+ #{id\ 11995}#
+ #{val\ 11996}#
+ #{e1\ 11997}#
+ #{e2\ 11998}#)
+ (and-map #{id?\ 9076}# #{id\ 11995}#))
+ #{tmp\ 11988}#)
#f)
- (apply (lambda (#{_\ 1428}#
- #{id\ 1429}#
- #{val\ 1430}#
- #{e1\ 1431}#
- #{e2\ 1432}#)
- (#{chi-let\ 1400}#
- #{e\ 1415}#
- #{r\ 1416}#
- #{w\ 1417}#
- #{s\ 1418}#
- #{mod\ 1419}#
- #{build-let\ 111}#
- #{id\ 1429}#
- #{val\ 1430}#
- (cons #{e1\ 1431}# #{e2\ 1432}#)))
- #{tmp\ 1421}#)
- ((lambda (#{tmp\ 1436}#)
- (if (if #{tmp\ 1436}#
- (apply (lambda (#{_\ 1437}#
- #{f\ 1438}#
- #{id\ 1439}#
- #{val\ 1440}#
- #{e1\ 1441}#
- #{e2\ 1442}#)
- (if (#{id?\ 131}# #{f\ 1438}#)
- (and-map #{id?\ 131}# #{id\ 1439}#)
+ (apply (lambda (#{_\ 12005}#
+ #{id\ 12006}#
+ #{val\ 12007}#
+ #{e1\ 12008}#
+ #{e2\ 12009}#)
+ (#{chi-let\ 11948}#
+ #{e\ 11977}#
+ #{r\ 11978}#
+ #{w\ 11979}#
+ #{s\ 11980}#
+ #{mod\ 11981}#
+ #{build-let\ 9030}#
+ #{id\ 12006}#
+ #{val\ 12007}#
+ (cons #{e1\ 12008}# #{e2\ 12009}#)))
+ #{tmp\ 11988}#)
+ ((lambda (#{tmp\ 12013}#)
+ (if (if #{tmp\ 12013}#
+ (apply (lambda (#{_\ 12020}#
+ #{f\ 12021}#
+ #{id\ 12022}#
+ #{val\ 12023}#
+ #{e1\ 12024}#
+ #{e2\ 12025}#)
+ (if (#{id?\ 9076}# #{f\ 12021}#)
+ (and-map #{id?\ 9076}# #{id\ 12022}#)
#f))
- #{tmp\ 1436}#)
+ #{tmp\ 12013}#)
#f)
- (apply (lambda (#{_\ 1444}#
- #{f\ 1445}#
- #{id\ 1446}#
- #{val\ 1447}#
- #{e1\ 1448}#
- #{e2\ 1449}#)
- (#{chi-let\ 1400}#
- #{e\ 1415}#
- #{r\ 1416}#
- #{w\ 1417}#
- #{s\ 1418}#
- #{mod\ 1419}#
- #{build-named-let\ 112}#
- (cons #{f\ 1445}# #{id\ 1446}#)
- #{val\ 1447}#
- (cons #{e1\ 1448}# #{e2\ 1449}#)))
- #{tmp\ 1436}#)
- ((lambda (#{_\ 1453}#)
+ (apply (lambda (#{_\ 12035}#
+ #{f\ 12036}#
+ #{id\ 12037}#
+ #{val\ 12038}#
+ #{e1\ 12039}#
+ #{e2\ 12040}#)
+ (#{chi-let\ 11948}#
+ #{e\ 11977}#
+ #{r\ 11978}#
+ #{w\ 11979}#
+ #{s\ 11980}#
+ #{mod\ 11981}#
+ #{build-named-let\ 9032}#
+ (cons #{f\ 12036}# #{id\ 12037}#)
+ #{val\ 12038}#
+ (cons #{e1\ 12039}# #{e2\ 12040}#)))
+ #{tmp\ 12013}#)
+ ((lambda (#{_\ 12045}#)
(syntax-violation
'let
"bad let"
- (#{source-wrap\ 160}#
- #{e\ 1415}#
- #{w\ 1417}#
- #{s\ 1418}#
- #{mod\ 1419}#)))
- #{tmp\ 1420}#)))
+ (#{source-wrap\ 9147}#
+ #{e\ 11977}#
+ #{w\ 11979}#
+ #{s\ 11980}#
+ #{mod\ 11981}#)))
+ #{tmp\ 11987}#)))
($sc-dispatch
- #{tmp\ 1420}#
+ #{tmp\ 11987}#
'(any any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 1420}#
+ #{tmp\ 11987}#
'(any #(each (any any)) any . each-any))))
- #{e\ 1415}#))))
- (#{global-extend\ 129}#
+ #{e\ 11977}#))))
+ (#{global-extend\ 9072}#
'core
'letrec
- (lambda (#{e\ 1454}#
- #{r\ 1455}#
- #{w\ 1456}#
- #{s\ 1457}#
- #{mod\ 1458}#)
- ((lambda (#{tmp\ 1459}#)
- ((lambda (#{tmp\ 1460}#)
- (if (if #{tmp\ 1460}#
- (apply (lambda (#{_\ 1461}#
- #{id\ 1462}#
- #{val\ 1463}#
- #{e1\ 1464}#
- #{e2\ 1465}#)
- (and-map #{id?\ 131}# #{id\ 1462}#))
- #{tmp\ 1460}#)
+ (lambda (#{e\ 12046}#
+ #{r\ 12047}#
+ #{w\ 12048}#
+ #{s\ 12049}#
+ #{mod\ 12050}#)
+ ((lambda (#{tmp\ 12056}#)
+ ((lambda (#{tmp\ 12057}#)
+ (if (if #{tmp\ 12057}#
+ (apply (lambda (#{_\ 12063}#
+ #{id\ 12064}#
+ #{val\ 12065}#
+ #{e1\ 12066}#
+ #{e2\ 12067}#)
+ (and-map #{id?\ 9076}# #{id\ 12064}#))
+ #{tmp\ 12057}#)
#f)
- (apply (lambda (#{_\ 1467}#
- #{id\ 1468}#
- #{val\ 1469}#
- #{e1\ 1470}#
- #{e2\ 1471}#)
- (let ((#{ids\ 1472}# #{id\ 1468}#))
- (if (not (#{valid-bound-ids?\ 156}#
- #{ids\ 1472}#))
+ (apply (lambda (#{_\ 12074}#
+ #{id\ 12075}#
+ #{val\ 12076}#
+ #{e1\ 12077}#
+ #{e2\ 12078}#)
+ (let ((#{ids\ 12080}# #{id\ 12075}#))
+ (if (not (#{valid-bound-ids?\ 9139}#
+ #{ids\ 12080}#))
(syntax-violation
'letrec
"duplicate bound variable"
- #{e\ 1454}#)
- (let ((#{labels\ 1474}#
- (#{gen-labels\ 137}# #{ids\ 1472}#))
- (#{new-vars\ 1475}#
- (map #{gen-var\ 181}# #{ids\ 1472}#)))
- (let ((#{w\ 1476}#
- (#{make-binding-wrap\ 148}#
- #{ids\ 1472}#
- #{labels\ 1474}#
- #{w\ 1456}#))
- (#{r\ 1477}#
- (#{extend-var-env\ 126}#
- #{labels\ 1474}#
- #{new-vars\ 1475}#
- #{r\ 1455}#)))
- (#{build-letrec\ 113}#
- #{s\ 1457}#
- (map syntax->datum #{ids\ 1472}#)
- #{new-vars\ 1475}#
- (map (lambda (#{x\ 1478}#)
- (#{chi\ 167}#
- #{x\ 1478}#
- #{r\ 1477}#
- #{w\ 1476}#
- #{mod\ 1458}#))
- #{val\ 1469}#)
- (#{chi-body\ 171}#
- (cons #{e1\ 1470}# #{e2\ 1471}#)
- (#{source-wrap\ 160}#
- #{e\ 1454}#
- #{w\ 1476}#
- #{s\ 1457}#
- #{mod\ 1458}#)
- #{r\ 1477}#
- #{w\ 1476}#
- #{mod\ 1458}#)))))))
- #{tmp\ 1460}#)
- ((lambda (#{_\ 1481}#)
+ #{e\ 12046}#)
+ (let ((#{labels\ 12084}#
+ (#{gen-labels\ 9094}# #{ids\ 12080}#))
+ (#{new-vars\ 12085}#
+ (map #{gen-var\ 9189}# #{ids\ 12080}#)))
+ (let ((#{w\ 12088}#
+ (#{make-binding-wrap\ 9123}#
+ #{ids\ 12080}#
+ #{labels\ 12084}#
+ #{w\ 12048}#))
+ (#{r\ 12089}#
+ (#{extend-var-env\ 9066}#
+ #{labels\ 12084}#
+ #{new-vars\ 12085}#
+ #{r\ 12047}#)))
+ (#{build-letrec\ 9034}#
+ #{s\ 12049}#
+ (map syntax->datum #{ids\ 12080}#)
+ #{new-vars\ 12085}#
+ (map (lambda (#{x\ 12090}#)
+ (#{chi\ 9161}#
+ #{x\ 12090}#
+ #{r\ 12089}#
+ #{w\ 12088}#
+ #{mod\ 12050}#))
+ #{val\ 12076}#)
+ (#{chi-body\ 9169}#
+ (cons #{e1\ 12077}# #{e2\ 12078}#)
+ (#{source-wrap\ 9147}#
+ #{e\ 12046}#
+ #{w\ 12088}#
+ #{s\ 12049}#
+ #{mod\ 12050}#)
+ #{r\ 12089}#
+ #{w\ 12088}#
+ #{mod\ 12050}#)))))))
+ #{tmp\ 12057}#)
+ ((lambda (#{_\ 12095}#)
(syntax-violation
'letrec
"bad letrec"
- (#{source-wrap\ 160}#
- #{e\ 1454}#
- #{w\ 1456}#
- #{s\ 1457}#
- #{mod\ 1458}#)))
- #{tmp\ 1459}#)))
+ (#{source-wrap\ 9147}#
+ #{e\ 12046}#
+ #{w\ 12048}#
+ #{s\ 12049}#
+ #{mod\ 12050}#)))
+ #{tmp\ 12056}#)))
($sc-dispatch
- #{tmp\ 1459}#
+ #{tmp\ 12056}#
'(any #(each (any any)) any . each-any))))
- #{e\ 1454}#)))
- (#{global-extend\ 129}#
+ #{e\ 12046}#)))
+ (#{global-extend\ 9072}#
'core
'set!
- (lambda (#{e\ 1482}#
- #{r\ 1483}#
- #{w\ 1484}#
- #{s\ 1485}#
- #{mod\ 1486}#)
- ((lambda (#{tmp\ 1487}#)
- ((lambda (#{tmp\ 1488}#)
- (if (if #{tmp\ 1488}#
- (apply (lambda (#{_\ 1489}# #{id\ 1490}# #{val\ 1491}#)
- (#{id?\ 131}# #{id\ 1490}#))
- #{tmp\ 1488}#)
+ (lambda (#{e\ 12096}#
+ #{r\ 12097}#
+ #{w\ 12098}#
+ #{s\ 12099}#
+ #{mod\ 12100}#)
+ ((lambda (#{tmp\ 12106}#)
+ ((lambda (#{tmp\ 12107}#)
+ (if (if #{tmp\ 12107}#
+ (apply (lambda (#{_\ 12111}#
+ #{id\ 12112}#
+ #{val\ 12113}#)
+ (#{id?\ 9076}# #{id\ 12112}#))
+ #{tmp\ 12107}#)
#f)
- (apply (lambda (#{_\ 1492}# #{id\ 1493}# #{val\ 1494}#)
- (let ((#{val\ 1495}#
- (#{chi\ 167}#
- #{val\ 1494}#
- #{r\ 1483}#
- #{w\ 1484}#
- #{mod\ 1486}#))
- (#{n\ 1496}#
- (#{id-var-name\ 153}#
- #{id\ 1493}#
- #{w\ 1484}#)))
- (let ((#{b\ 1497}#
- (#{lookup\ 128}#
- #{n\ 1496}#
- #{r\ 1483}#
- #{mod\ 1486}#)))
- (let ((#{atom-key\ 1498}#
- (#{binding-type\ 123}# #{b\ 1497}#)))
- (if (memv #{atom-key\ 1498}#
+ (apply (lambda (#{_\ 12117}# #{id\ 12118}# #{val\ 12119}#)
+ (let ((#{val\ 12122}#
+ (#{chi\ 9161}#
+ #{val\ 12119}#
+ #{r\ 12097}#
+ #{w\ 12098}#
+ #{mod\ 12100}#))
+ (#{n\ 12123}#
+ (#{id-var-name\ 9133}#
+ #{id\ 12118}#
+ #{w\ 12098}#)))
+ (let ((#{b\ 12125}#
+ (#{lookup\ 9070}#
+ #{n\ 12123}#
+ #{r\ 12097}#
+ #{mod\ 12100}#)))
+ (let ((#{atom-key\ 12128}#
+ (#{binding-type\ 9059}# #{b\ 12125}#)))
+ (if (memv #{atom-key\ 12128}#
'(lexical))
- (#{build-lexical-assignment\ 99}#
- #{s\ 1485}#
- (syntax->datum #{id\ 1493}#)
- (#{binding-value\ 124}# #{b\ 1497}#)
- #{val\ 1495}#)
- (if (memv #{atom-key\ 1498}#
+ (#{build-lexical-assignment\ 9006}#
+ #{s\ 12099}#
+ (syntax->datum #{id\ 12118}#)
+ (#{binding-value\ 9061}# #{b\ 12125}#)
+ #{val\ 12122}#)
+ (if (memv #{atom-key\ 12128}#
'(global))
- (#{build-global-assignment\ 102}#
- #{s\ 1485}#
- #{n\ 1496}#
- #{val\ 1495}#
- #{mod\ 1486}#)
- (if (memv #{atom-key\ 1498}#
+ (#{build-global-assignment\ 9012}#
+ #{s\ 12099}#
+ #{n\ 12123}#
+ #{val\ 12122}#
+ #{mod\ 12100}#)
+ (if (memv #{atom-key\ 12128}#
'(displaced-lexical))
(syntax-violation
'set!
"identifier out of context"
- (#{wrap\ 159}#
- #{id\ 1493}#
- #{w\ 1484}#
- #{mod\ 1486}#))
+ (#{wrap\ 9145}#
+ #{id\ 12118}#
+ #{w\ 12098}#
+ #{mod\ 12100}#))
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 160}#
- #{e\ 1482}#
- #{w\ 1484}#
- #{s\ 1485}#
- #{mod\ 1486}#)))))))))
- #{tmp\ 1488}#)
- ((lambda (#{tmp\ 1499}#)
- (if #{tmp\ 1499}#
- (apply (lambda (#{_\ 1500}#
- #{head\ 1501}#
- #{tail\ 1502}#
- #{val\ 1503}#)
+ (#{source-wrap\ 9147}#
+ #{e\ 12096}#
+ #{w\ 12098}#
+ #{s\ 12099}#
+ #{mod\ 12100}#)))))))))
+ #{tmp\ 12107}#)
+ ((lambda (#{tmp\ 12133}#)
+ (if #{tmp\ 12133}#
+ (apply (lambda (#{_\ 12138}#
+ #{head\ 12139}#
+ #{tail\ 12140}#
+ #{val\ 12141}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 165}#
- #{head\ 1501}#
- #{r\ 1483}#
+ (#{syntax-type\ 9157}#
+ #{head\ 12139}#
+ #{r\ 12097}#
'(())
#f
#f
- #{mod\ 1486}#
+ #{mod\ 12100}#
#t))
- (lambda (#{type\ 1504}#
- #{value\ 1505}#
- #{ee\ 1506}#
- #{ww\ 1507}#
- #{ss\ 1508}#
- #{modmod\ 1509}#)
- (if (memv #{type\ 1504}#
+ (lambda (#{type\ 12144}#
+ #{value\ 12145}#
+ #{ee\ 12146}#
+ #{ww\ 12147}#
+ #{ss\ 12148}#
+ #{modmod\ 12149}#)
+ (if (memv #{type\ 12144}#
'(module-ref))
- (let ((#{val\ 1510}#
- (#{chi\ 167}#
- #{val\ 1503}#
- #{r\ 1483}#
- #{w\ 1484}#
- #{mod\ 1486}#)))
+ (let ((#{val\ 12158}#
+ (#{chi\ 9161}#
+ #{val\ 12141}#
+ #{r\ 12097}#
+ #{w\ 12098}#
+ #{mod\ 12100}#)))
(call-with-values
(lambda ()
- (#{value\ 1505}#
- (cons #{head\ 1501}#
- #{tail\ 1502}#)))
- (lambda (#{id\ 1512}# #{mod\ 1513}#)
- (#{build-global-assignment\ 102}#
- #{s\ 1485}#
- #{id\ 1512}#
- #{val\ 1510}#
- #{mod\ 1513}#))))
- (#{build-application\ 96}#
- #{s\ 1485}#
- (#{chi\ 167}#
+ (#{value\ 12145}#
+ (cons #{head\ 12139}#
+ #{tail\ 12140}#)))
+ (lambda (#{id\ 12160}#
+ #{mod\ 12161}#)
+ (#{build-global-assignment\ 9012}#
+ #{s\ 12099}#
+ #{id\ 12160}#
+ #{val\ 12158}#
+ #{mod\ 12161}#))))
+ (#{build-application\ 8998}#
+ #{s\ 12099}#
+ (#{chi\ 9161}#
(list '#(syntax-object
setter
((top)
@@ -8984,19 +9067,22 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ #("i12150"
+ "i12151"
+ "i12152"
+ "i12153"
+ "i12154"
+ "i12155"))
#(ribcage
#(_ head tail val)
#((top)
(top)
(top)
(top))
- #("i" "i" "i" "i"))
+ #("i12134"
+ "i12135"
+ "i12136"
+ "i12137"))
#(ribcage () () ())
#(ribcage
#(e r w s mod)
@@ -9005,7 +9091,11 @@
(top)
(top)
(top))
- #("i" "i" "i" "i" "i"))
+ #("i12101"
+ "i12102"
+ "i12103"
+ "i12104"
+ "i12105"))
#(ribcage
(lambda-var-list
gen-var
@@ -9109,6 +9199,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+ build-dynlet
build-conditional
build-application
build-void
@@ -9240,177 +9331,181 @@
(top)
(top)
(top)
+ (top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
#(ribcage
(define-structure
and-map*)
((top) (top))
- ("i" "i")))
+ ("i8875" "i8873")))
(hygiene guile))
- #{head\ 1501}#)
- #{r\ 1483}#
- #{w\ 1484}#
- #{mod\ 1486}#)
- (map (lambda (#{e\ 1514}#)
- (#{chi\ 167}#
- #{e\ 1514}#
- #{r\ 1483}#
- #{w\ 1484}#
- #{mod\ 1486}#))
+ #{head\ 12139}#)
+ #{r\ 12097}#
+ #{w\ 12098}#
+ #{mod\ 12100}#)
+ (map (lambda (#{e\ 12165}#)
+ (#{chi\ 9161}#
+ #{e\ 12165}#
+ #{r\ 12097}#
+ #{w\ 12098}#
+ #{mod\ 12100}#))
(append
- #{tail\ 1502}#
- (list #{val\ 1503}#))))))))
- #{tmp\ 1499}#)
- ((lambda (#{_\ 1516}#)
+ #{tail\ 12140}#
+ (list #{val\ 12141}#))))))))
+ #{tmp\ 12133}#)
+ ((lambda (#{_\ 12169}#)
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 160}#
- #{e\ 1482}#
- #{w\ 1484}#
- #{s\ 1485}#
- #{mod\ 1486}#)))
- #{tmp\ 1487}#)))
+ (#{source-wrap\ 9147}#
+ #{e\ 12096}#
+ #{w\ 12098}#
+ #{s\ 12099}#
+ #{mod\ 12100}#)))
+ #{tmp\ 12106}#)))
($sc-dispatch
- #{tmp\ 1487}#
+ #{tmp\ 12106}#
'(any (any . each-any) any)))))
($sc-dispatch
- #{tmp\ 1487}#
+ #{tmp\ 12106}#
'(any any any))))
- #{e\ 1482}#)))
- (#{global-extend\ 129}#
+ #{e\ 12096}#)))
+ (#{global-extend\ 9072}#
'module-ref
'@
- (lambda (#{e\ 1517}#)
- ((lambda (#{tmp\ 1518}#)
- ((lambda (#{tmp\ 1519}#)
- (if (if #{tmp\ 1519}#
- (apply (lambda (#{_\ 1520}# #{mod\ 1521}# #{id\ 1522}#)
- (if (and-map #{id?\ 131}# #{mod\ 1521}#)
- (#{id?\ 131}# #{id\ 1522}#)
+ (lambda (#{e\ 12170}#)
+ ((lambda (#{tmp\ 12172}#)
+ ((lambda (#{tmp\ 12173}#)
+ (if (if #{tmp\ 12173}#
+ (apply (lambda (#{_\ 12177}#
+ #{mod\ 12178}#
+ #{id\ 12179}#)
+ (if (and-map #{id?\ 9076}# #{mod\ 12178}#)
+ (#{id?\ 9076}# #{id\ 12179}#)
#f))
- #{tmp\ 1519}#)
+ #{tmp\ 12173}#)
#f)
- (apply (lambda (#{_\ 1524}# #{mod\ 1525}# #{id\ 1526}#)
+ (apply (lambda (#{_\ 12186}# #{mod\ 12187}# #{id\ 12188}#)
(values
- (syntax->datum #{id\ 1526}#)
+ (syntax->datum #{id\ 12188}#)
(syntax->datum
(cons '#(syntax-object
public
@@ -9418,9 +9513,9 @@
#(ribcage
#(_ mod id)
#((top) (top) (top))
- #("i" "i" "i"))
+ #("i12183" "i12184" "i12185"))
#(ribcage () () ())
- #(ribcage #(e) #((top)) #("i"))
+ #(ribcage #(e) #((top)) #("i12171"))
#(ribcage
(lambda-var-list
gen-var
@@ -9524,6 +9619,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+ build-dynlet
build-conditional
build-application
build-void
@@ -9655,155 +9751,159 @@
(top)
(top)
(top)
+ (top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
#(ribcage
(define-structure and-map*)
((top) (top))
- ("i" "i")))
+ ("i8875" "i8873")))
(hygiene guile))
- #{mod\ 1525}#))))
- #{tmp\ 1519}#)
+ #{mod\ 12187}#))))
+ #{tmp\ 12173}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1518}#)))
+ #{tmp\ 12172}#)))
($sc-dispatch
- #{tmp\ 1518}#
+ #{tmp\ 12172}#
'(any each-any any))))
- #{e\ 1517}#)))
- (#{global-extend\ 129}#
+ #{e\ 12170}#)))
+ (#{global-extend\ 9072}#
'module-ref
'@@
- (lambda (#{e\ 1528}#)
- ((lambda (#{tmp\ 1529}#)
- ((lambda (#{tmp\ 1530}#)
- (if (if #{tmp\ 1530}#
- (apply (lambda (#{_\ 1531}# #{mod\ 1532}# #{id\ 1533}#)
- (if (and-map #{id?\ 131}# #{mod\ 1532}#)
- (#{id?\ 131}# #{id\ 1533}#)
+ (lambda (#{e\ 12190}#)
+ ((lambda (#{tmp\ 12192}#)
+ ((lambda (#{tmp\ 12193}#)
+ (if (if #{tmp\ 12193}#
+ (apply (lambda (#{_\ 12197}#
+ #{mod\ 12198}#
+ #{id\ 12199}#)
+ (if (and-map #{id?\ 9076}# #{mod\ 12198}#)
+ (#{id?\ 9076}# #{id\ 12199}#)
#f))
- #{tmp\ 1530}#)
+ #{tmp\ 12193}#)
#f)
- (apply (lambda (#{_\ 1535}# #{mod\ 1536}# #{id\ 1537}#)
+ (apply (lambda (#{_\ 12206}# #{mod\ 12207}# #{id\ 12208}#)
(values
- (syntax->datum #{id\ 1537}#)
+ (syntax->datum #{id\ 12208}#)
(syntax->datum
(cons '#(syntax-object
private
@@ -9811,9 +9911,9 @@
#(ribcage
#(_ mod id)
#((top) (top) (top))
- #("i" "i" "i"))
+ #("i12203" "i12204" "i12205"))
#(ribcage () () ())
- #(ribcage #(e) #((top)) #("i"))
+ #(ribcage #(e) #((top)) #("i12191"))
#(ribcage
(lambda-var-list
gen-var
@@ -9917,6 +10017,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+ build-dynlet
build-conditional
build-application
build-void
@@ -10048,253 +10149,307 @@
(top)
(top)
(top)
+ (top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
#(ribcage
(define-structure and-map*)
((top) (top))
- ("i" "i")))
+ ("i8875" "i8873")))
(hygiene guile))
- #{mod\ 1536}#))))
- #{tmp\ 1530}#)
+ #{mod\ 12207}#))))
+ #{tmp\ 12193}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1529}#)))
+ #{tmp\ 12192}#)))
($sc-dispatch
- #{tmp\ 1529}#
+ #{tmp\ 12192}#
'(any each-any any))))
- #{e\ 1528}#)))
- (#{global-extend\ 129}#
+ #{e\ 12190}#)))
+ (#{global-extend\ 9072}#
'core
'if
- (lambda (#{e\ 1539}#
- #{r\ 1540}#
- #{w\ 1541}#
- #{s\ 1542}#
- #{mod\ 1543}#)
- ((lambda (#{tmp\ 1544}#)
- ((lambda (#{tmp\ 1545}#)
- (if #{tmp\ 1545}#
- (apply (lambda (#{_\ 1546}# #{test\ 1547}# #{then\ 1548}#)
- (#{build-conditional\ 97}#
- #{s\ 1542}#
- (#{chi\ 167}#
- #{test\ 1547}#
- #{r\ 1540}#
- #{w\ 1541}#
- #{mod\ 1543}#)
- (#{chi\ 167}#
- #{then\ 1548}#
- #{r\ 1540}#
- #{w\ 1541}#
- #{mod\ 1543}#)
- (#{build-void\ 95}# #f)))
- #{tmp\ 1545}#)
- ((lambda (#{tmp\ 1549}#)
- (if #{tmp\ 1549}#
- (apply (lambda (#{_\ 1550}#
- #{test\ 1551}#
- #{then\ 1552}#
- #{else\ 1553}#)
- (#{build-conditional\ 97}#
- #{s\ 1542}#
- (#{chi\ 167}#
- #{test\ 1551}#
- #{r\ 1540}#
- #{w\ 1541}#
- #{mod\ 1543}#)
- (#{chi\ 167}#
- #{then\ 1552}#
- #{r\ 1540}#
- #{w\ 1541}#
- #{mod\ 1543}#)
- (#{chi\ 167}#
- #{else\ 1553}#
- #{r\ 1540}#
- #{w\ 1541}#
- #{mod\ 1543}#)))
- #{tmp\ 1549}#)
+ (lambda (#{e\ 12210}#
+ #{r\ 12211}#
+ #{w\ 12212}#
+ #{s\ 12213}#
+ #{mod\ 12214}#)
+ ((lambda (#{tmp\ 12220}#)
+ ((lambda (#{tmp\ 12221}#)
+ (if #{tmp\ 12221}#
+ (apply (lambda (#{_\ 12225}# #{test\ 12226}# #{then\ 12227}#)
+ (#{build-conditional\ 9000}#
+ #{s\ 12213}#
+ (#{chi\ 9161}#
+ #{test\ 12226}#
+ #{r\ 12211}#
+ #{w\ 12212}#
+ #{mod\ 12214}#)
+ (#{chi\ 9161}#
+ #{then\ 12227}#
+ #{r\ 12211}#
+ #{w\ 12212}#
+ #{mod\ 12214}#)
+ (#{build-void\ 8996}# #f)))
+ #{tmp\ 12221}#)
+ ((lambda (#{tmp\ 12229}#)
+ (if #{tmp\ 12229}#
+ (apply (lambda (#{_\ 12234}#
+ #{test\ 12235}#
+ #{then\ 12236}#
+ #{else\ 12237}#)
+ (#{build-conditional\ 9000}#
+ #{s\ 12213}#
+ (#{chi\ 9161}#
+ #{test\ 12235}#
+ #{r\ 12211}#
+ #{w\ 12212}#
+ #{mod\ 12214}#)
+ (#{chi\ 9161}#
+ #{then\ 12236}#
+ #{r\ 12211}#
+ #{w\ 12212}#
+ #{mod\ 12214}#)
+ (#{chi\ 9161}#
+ #{else\ 12237}#
+ #{r\ 12211}#
+ #{w\ 12212}#
+ #{mod\ 12214}#)))
+ #{tmp\ 12229}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1544}#)))
+ #{tmp\ 12220}#)))
($sc-dispatch
- #{tmp\ 1544}#
+ #{tmp\ 12220}#
'(any any any any)))))
($sc-dispatch
- #{tmp\ 1544}#
+ #{tmp\ 12220}#
'(any any any))))
- #{e\ 1539}#)))
- (#{global-extend\ 129}#
+ #{e\ 12210}#)))
+ (#{global-extend\ 9072}#
+ 'core
+ 'with-fluids
+ (lambda (#{e\ 12238}#
+ #{r\ 12239}#
+ #{w\ 12240}#
+ #{s\ 12241}#
+ #{mod\ 12242}#)
+ ((lambda (#{tmp\ 12248}#)
+ ((lambda (#{tmp\ 12249}#)
+ (if #{tmp\ 12249}#
+ (apply (lambda (#{_\ 12255}#
+ #{fluid\ 12256}#
+ #{val\ 12257}#
+ #{b\ 12258}#
+ #{b*\ 12259}#)
+ (#{build-dynlet\ 9002}#
+ #{s\ 12241}#
+ (map (lambda (#{x\ 12260}#)
+ (#{chi\ 9161}#
+ #{x\ 12260}#
+ #{r\ 12239}#
+ #{w\ 12240}#
+ #{mod\ 12242}#))
+ #{fluid\ 12256}#)
+ (map (lambda (#{x\ 12263}#)
+ (#{chi\ 9161}#
+ #{x\ 12263}#
+ #{r\ 12239}#
+ #{w\ 12240}#
+ #{mod\ 12242}#))
+ #{val\ 12257}#)
+ (#{chi-body\ 9169}#
+ (cons #{b\ 12258}# #{b*\ 12259}#)
+ (#{source-wrap\ 9147}#
+ #{e\ 12238}#
+ #{w\ 12240}#
+ #{s\ 12241}#
+ #{mod\ 12242}#)
+ #{r\ 12239}#
+ #{w\ 12240}#
+ #{mod\ 12242}#)))
+ #{tmp\ 12249}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 12248}#)))
+ ($sc-dispatch
+ #{tmp\ 12248}#
+ '(any #(each (any any)) any . each-any))))
+ #{e\ 12238}#)))
+ (#{global-extend\ 9072}#
'begin
'begin
'())
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'define
'define
'())
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'define-syntax
'define-syntax
'())
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'eval-when
'eval-when
'())
- (#{global-extend\ 129}#
+ (#{global-extend\ 9072}#
'core
'syntax-case
- (letrec ((#{gen-syntax-case\ 1557}#
- (lambda (#{x\ 1558}#
- #{keys\ 1559}#
- #{clauses\ 1560}#
- #{r\ 1561}#
- #{mod\ 1562}#)
- (if (null? #{clauses\ 1560}#)
- (#{build-application\ 96}#
+ (letrec ((#{gen-syntax-case\ 12274}#
+ (lambda (#{x\ 12275}#
+ #{keys\ 12276}#
+ #{clauses\ 12277}#
+ #{r\ 12278}#
+ #{mod\ 12279}#)
+ (if (null? #{clauses\ 12277}#)
+ (#{build-application\ 8998}#
#f
- (#{build-primref\ 108}#
+ (#{build-primref\ 9024}#
#f
'syntax-violation)
- (list (#{build-data\ 109}# #f #f)
- (#{build-data\ 109}#
+ (list (#{build-data\ 9026}# #f #f)
+ (#{build-data\ 9026}#
#f
"source expression failed to match any
pattern")
- #{x\ 1558}#))
- ((lambda (#{tmp\ 1563}#)
- ((lambda (#{tmp\ 1564}#)
- (if #{tmp\ 1564}#
- (apply (lambda (#{pat\ 1565}# #{exp\ 1566}#)
- (if (if (#{id?\ 131}# #{pat\ 1565}#)
+ #{x\ 12275}#))
+ ((lambda (#{tmp\ 12289}#)
+ ((lambda (#{tmp\ 12290}#)
+ (if #{tmp\ 12290}#
+ (apply (lambda (#{pat\ 12293}# #{exp\ 12294}#)
+ (if (if (#{id?\ 9076}# #{pat\ 12293}#)
(and-map
- (lambda (#{x\ 1567}#)
- (not (#{free-id=?\ 154}#
- #{pat\ 1565}#
- #{x\ 1567}#)))
+ (lambda (#{x\ 12297}#)
+ (not (#{free-id=?\ 9135}#
+ #{pat\ 12293}#
+ #{x\ 12297}#)))
(cons '#(syntax-object
...
((top)
#(ribcage
#(pat exp)
#((top) (top))
- #("i" "i"))
+ #("i12291"
+ "i12292"))
#(ribcage () () ())
#(ribcage
#(x
@@ -10307,11 +10462,11 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
+ #("i12280"
+ "i12281"
+ "i12282"
+ "i12283"
+ "i12284"))
#(ribcage
(gen-syntax-case
gen-clause
@@ -10321,7 +10476,10 @@
(top)
(top)
(top))
- ("i" "i" "i" "i"))
+ ("i12273"
+ "i12271"
+ "i12269"
+ "i12267"))
#(ribcage
(lambda-var-list
gen-var
@@ -10425,6 +10583,7 @@
analyze-variable
build-lexical-assignment
build-lexical-reference
+ build-dynlet
build-conditional
build-application
build-void
@@ -10556,1071 +10715,1083 @@
(top)
(top)
(top)
+ (top)
(top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
+ ("i9190"
+ "i9188"
+ "i9186"
+ "i9184"
+ "i9182"
+ "i9180"
+ "i9178"
+ "i9176"
+ "i9174"
+ "i9172"
+ "i9170"
+ "i9168"
+ "i9166"
+ "i9164"
+ "i9162"
+ "i9160"
+ "i9158"
+ "i9156"
+ "i9154"
+ "i9152"
+ "i9150"
+ "i9148"
+ "i9146"
+ "i9144"
+ "i9142"
+ "i9140"
+ "i9138"
+ "i9136"
+ "i9134"
+ "i9132"
+ "i9130"
+ "i9128"
+ "i9126"
+ "i9124"
+ "i9122"
+ "i9120"
+ "i9119"
+ "i9118"
+ "i9116"
+ "i9115"
+ "i9114"
+ "i9113"
+ "i9112"
+ "i9110"
+ "i9108"
+ "i9106"
+ "i9104"
+ "i9102"
+ "i9100"
+ "i9098"
+ "i9096"
+ "i9093"
+ "i9091"
+ "i9090"
+ "i9089"
+ "i9088"
+ "i9087"
+ "i9086"
+ "i9084"
+ "i9082"
+ "i9080"
+ "i9078"
+ "i9077"
+ "i9075"
+ "i9073"
+ "i9071"
+ "i9069"
+ "i9067"
+ "i9065"
+ "i9063"
+ "i9062"
+ "i9060"
+ "i9058"
+ "i9057"
+ "i9056"
+ "i9054"
+ "i9053"
+ "i9051"
+ "i9049"
+ "i9047"
+ "i9045"
+ "i9043"
+ "i9041"
+ "i9039"
+ "i9037"
+ "i9035"
+ "i9033"
+ "i9031"
+ "i9029"
+ "i9027"
+ "i9025"
+ "i9023"
+ "i9021"
+ "i9019"
+ "i9017"
+ "i9015"
+ "i9013"
+ "i9011"
+ "i9009"
+ "i9007"
+ "i9005"
+ "i9003"
+ "i9001"
+ "i8999"
+ "i8997"
+ "i8995"
+ "i8993"
+ "i8991"
+ "i8989"
+ "i8988"
+ "i8986"
+ "i8984"
+ "i8982"
+ "i8980"
+ "i8978"
+ "i8976"
+ "i8974"
+ "i8972"))
#(ribcage
(define-structure
and-map*)
((top) (top))
- ("i" "i")))
+ ("i8875" "i8873")))
(hygiene guile))
- #{keys\ 1559}#))
+ #{keys\ 12276}#))
#f)
- (let ((#{labels\ 1568}#
- (list (#{gen-label\ 136}#)))
- (#{var\ 1569}#
- (#{gen-var\ 181}#
- #{pat\ 1565}#)))
- (#{build-application\ 96}#
+ (let ((#{labels\ 12301}#
+ (list (#{gen-label\ 9092}#)))
+ (#{var\ 12302}#
+ (#{gen-var\ 9189}#
+ #{pat\ 12293}#)))
+ (#{build-application\ 8998}#
#f
- (#{build-simple-lambda\ 105}#
+ (#{build-simple-lambda\ 9018}#
#f
(list (syntax->datum
- #{pat\ 1565}#))
+ #{pat\ 12293}#))
#f
- (list #{var\ 1569}#)
- #f
- (#{chi\ 167}#
- #{exp\ 1566}#
- (#{extend-env\ 125}#
- #{labels\ 1568}#
+ (list #{var\ 12302}#)
+ '()
+ (#{chi\ 9161}#
+ #{exp\ 12294}#
+ (#{extend-env\ 9064}#
+ #{labels\ 12301}#
(list (cons 'syntax
- (cons #{var\
1569}#
+ (cons #{var\
12302}#
0)))
- #{r\ 1561}#)
- (#{make-binding-wrap\ 148}#
- (list #{pat\ 1565}#)
- #{labels\ 1568}#
+ #{r\ 12278}#)
+ (#{make-binding-wrap\ 9123}#
+ (list #{pat\ 12293}#)
+ #{labels\ 12301}#
'(()))
- #{mod\ 1562}#))
- (list #{x\ 1558}#)))
- (#{gen-clause\ 1556}#
- #{x\ 1558}#
- #{keys\ 1559}#
- (cdr #{clauses\ 1560}#)
- #{r\ 1561}#
- #{pat\ 1565}#
+ #{mod\ 12279}#))
+ (list #{x\ 12275}#)))
+ (#{gen-clause\ 12272}#
+ #{x\ 12275}#
+ #{keys\ 12276}#
+ (cdr #{clauses\ 12277}#)
+ #{r\ 12278}#
+ #{pat\ 12293}#
#t
- #{exp\ 1566}#
- #{mod\ 1562}#)))
- #{tmp\ 1564}#)
- ((lambda (#{tmp\ 1570}#)
- (if #{tmp\ 1570}#
- (apply (lambda (#{pat\ 1571}#
- #{fender\ 1572}#
- #{exp\ 1573}#)
- (#{gen-clause\ 1556}#
- #{x\ 1558}#
- #{keys\ 1559}#
- (cdr #{clauses\ 1560}#)
- #{r\ 1561}#
- #{pat\ 1571}#
- #{fender\ 1572}#
- #{exp\ 1573}#
- #{mod\ 1562}#))
- #{tmp\ 1570}#)
- ((lambda (#{_\ 1574}#)
+ #{exp\ 12294}#
+ #{mod\ 12279}#)))
+ #{tmp\ 12290}#)
+ ((lambda (#{tmp\ 12308}#)
+ (if #{tmp\ 12308}#
+ (apply (lambda (#{pat\ 12312}#
+ #{fender\ 12313}#
+ #{exp\ 12314}#)
+ (#{gen-clause\ 12272}#
+ #{x\ 12275}#
+ #{keys\ 12276}#
+ (cdr #{clauses\ 12277}#)
+ #{r\ 12278}#
+ #{pat\ 12312}#
+ #{fender\ 12313}#
+ #{exp\ 12314}#
+ #{mod\ 12279}#))
+ #{tmp\ 12308}#)
+ ((lambda (#{_\ 12316}#)
(syntax-violation
'syntax-case
"invalid clause"
- (car #{clauses\ 1560}#)))
- #{tmp\ 1563}#)))
+ (car #{clauses\ 12277}#)))
+ #{tmp\ 12289}#)))
($sc-dispatch
- #{tmp\ 1563}#
+ #{tmp\ 12289}#
'(any any any)))))
- ($sc-dispatch #{tmp\ 1563}# (quote (any any)))))
- (car #{clauses\ 1560}#)))))
- (#{gen-clause\ 1556}#
- (lambda (#{x\ 1575}#
- #{keys\ 1576}#
- #{clauses\ 1577}#
- #{r\ 1578}#
- #{pat\ 1579}#
- #{fender\ 1580}#
- #{exp\ 1581}#
- #{mod\ 1582}#)
+ ($sc-dispatch #{tmp\ 12289}# (quote (any any)))))
+ (car #{clauses\ 12277}#)))))
+ (#{gen-clause\ 12272}#
+ (lambda (#{x\ 12317}#
+ #{keys\ 12318}#
+ #{clauses\ 12319}#
+ #{r\ 12320}#
+ #{pat\ 12321}#
+ #{fender\ 12322}#
+ #{exp\ 12323}#
+ #{mod\ 12324}#)
(call-with-values
(lambda ()
- (#{convert-pattern\ 1554}#
- #{pat\ 1579}#
- #{keys\ 1576}#))
- (lambda (#{p\ 1583}# #{pvars\ 1584}#)
- (if (not (#{distinct-bound-ids?\ 157}#
- (map car #{pvars\ 1584}#)))
+ (#{convert-pattern\ 12268}#
+ #{pat\ 12321}#
+ #{keys\ 12318}#))
+ (lambda (#{p\ 12333}# #{pvars\ 12334}#)
+ (if (not (#{distinct-bound-ids?\ 9141}#
+ (map car #{pvars\ 12334}#)))
(syntax-violation
'syntax-case
"duplicate pattern variable"
- #{pat\ 1579}#)
+ #{pat\ 12321}#)
(if (not (and-map
- (lambda (#{x\ 1585}#)
- (not (#{ellipsis?\ 175}#
- (car #{x\ 1585}#))))
- #{pvars\ 1584}#))
+ (lambda (#{x\ 12341}#)
+ (not (#{ellipsis?\ 9177}#
+ (car #{x\ 12341}#))))
+ #{pvars\ 12334}#))
(syntax-violation
'syntax-case
"misplaced ellipsis"
- #{pat\ 1579}#)
- (let ((#{y\ 1586}#
- (#{gen-var\ 181}# (quote tmp))))
- (#{build-application\ 96}#
+ #{pat\ 12321}#)
+ (let ((#{y\ 12345}#
+ (#{gen-var\ 9189}# (quote tmp))))
+ (#{build-application\ 8998}#
#f
- (#{build-simple-lambda\ 105}#
+ (#{build-simple-lambda\ 9018}#
#f
(list (quote tmp))
#f
- (list #{y\ 1586}#)
- #f
- (let ((#{y\ 1587}#
- (#{build-lexical-reference\ 98}#
+ (list #{y\ 12345}#)
+ '()
+ (let ((#{y\ 12349}#
+ (#{build-lexical-reference\ 9004}#
'value
#f
'tmp
- #{y\ 1586}#)))
- (#{build-conditional\ 97}#
+ #{y\ 12345}#)))
+ (#{build-conditional\ 9000}#
#f
- ((lambda (#{tmp\ 1588}#)
- ((lambda (#{tmp\ 1589}#)
- (if #{tmp\ 1589}#
- (apply (lambda () #{y\ 1587}#)
- #{tmp\ 1589}#)
- ((lambda (#{_\ 1590}#)
- (#{build-conditional\ 97}#
+ ((lambda (#{tmp\ 12352}#)
+ ((lambda (#{tmp\ 12353}#)
+ (if #{tmp\ 12353}#
+ (apply (lambda () #{y\ 12349}#)
+ #{tmp\ 12353}#)
+ ((lambda (#{_\ 12355}#)
+ (#{build-conditional\ 9000}#
#f
- #{y\ 1587}#
- (#{build-dispatch-call\
1555}#
- #{pvars\ 1584}#
- #{fender\ 1580}#
- #{y\ 1587}#
- #{r\ 1578}#
- #{mod\ 1582}#)
- (#{build-data\ 109}#
+ #{y\ 12349}#
+ (#{build-dispatch-call\
12270}#
+ #{pvars\ 12334}#
+ #{fender\ 12322}#
+ #{y\ 12349}#
+ #{r\ 12320}#
+ #{mod\ 12324}#)
+ (#{build-data\ 9026}#
#f
#f)))
- #{tmp\ 1588}#)))
+ #{tmp\ 12352}#)))
($sc-dispatch
- #{tmp\ 1588}#
+ #{tmp\ 12352}#
'#(atom #t))))
- #{fender\ 1580}#)
- (#{build-dispatch-call\ 1555}#
- #{pvars\ 1584}#
- #{exp\ 1581}#
- #{y\ 1587}#
- #{r\ 1578}#
- #{mod\ 1582}#)
- (#{gen-syntax-case\ 1557}#
- #{x\ 1575}#
- #{keys\ 1576}#
- #{clauses\ 1577}#
- #{r\ 1578}#
- #{mod\ 1582}#))))
- (list (if (eq? #{p\ 1583}# (quote any))
- (#{build-application\ 96}#
+ #{fender\ 12322}#)
+ (#{build-dispatch-call\ 12270}#
+ #{pvars\ 12334}#
+ #{exp\ 12323}#
+ #{y\ 12349}#
+ #{r\ 12320}#
+ #{mod\ 12324}#)
+ (#{gen-syntax-case\ 12274}#
+ #{x\ 12317}#
+ #{keys\ 12318}#
+ #{clauses\ 12319}#
+ #{r\ 12320}#
+ #{mod\ 12324}#))))
+ (list (if (eq? #{p\ 12333}# (quote any))
+ (#{build-application\ 8998}#
#f
- (#{build-primref\ 108}#
+ (#{build-primref\ 9024}#
#f
'list)
- (list #{x\ 1575}#))
- (#{build-application\ 96}#
+ (list #{x\ 12317}#))
+ (#{build-application\ 8998}#
#f
- (#{build-primref\ 108}#
+ (#{build-primref\ 9024}#
#f
'$sc-dispatch)
- (list #{x\ 1575}#
- (#{build-data\ 109}#
+ (list #{x\ 12317}#
+ (#{build-data\ 9026}#
#f
- #{p\ 1583}#)))))))))))))
- (#{build-dispatch-call\ 1555}#
- (lambda (#{pvars\ 1591}#
- #{exp\ 1592}#
- #{y\ 1593}#
- #{r\ 1594}#
- #{mod\ 1595}#)
- (let ((#{ids\ 1596}# (map car #{pvars\ 1591}#))
- (#{levels\ 1597}# (map cdr #{pvars\ 1591}#)))
- (let ((#{labels\ 1598}#
- (#{gen-labels\ 137}# #{ids\ 1596}#))
- (#{new-vars\ 1599}#
- (map #{gen-var\ 181}# #{ids\ 1596}#)))
- (#{build-application\ 96}#
+ #{p\ 12333}#)))))))))))))
+ (#{build-dispatch-call\ 12270}#
+ (lambda (#{pvars\ 12363}#
+ #{exp\ 12364}#
+ #{y\ 12365}#
+ #{r\ 12366}#
+ #{mod\ 12367}#)
+ (let ((#{ids\ 12375}# (map car #{pvars\ 12363}#))
+ (#{levels\ 12376}# (map cdr #{pvars\ 12363}#)))
+ (let ((#{labels\ 12379}#
+ (#{gen-labels\ 9094}# #{ids\ 12375}#))
+ (#{new-vars\ 12380}#
+ (map #{gen-var\ 9189}# #{ids\ 12375}#)))
+ (#{build-application\ 8998}#
#f
- (#{build-primref\ 108}# #f (quote apply))
- (list (#{build-simple-lambda\ 105}#
+ (#{build-primref\ 9024}# #f (quote apply))
+ (list (#{build-simple-lambda\ 9018}#
#f
- (map syntax->datum #{ids\ 1596}#)
+ (map syntax->datum #{ids\ 12375}#)
#f
- #{new-vars\ 1599}#
- #f
- (#{chi\ 167}#
- #{exp\ 1592}#
- (#{extend-env\ 125}#
- #{labels\ 1598}#
- (map (lambda (#{var\ 1600}#
- #{level\ 1601}#)
+ #{new-vars\ 12380}#
+ '()
+ (#{chi\ 9161}#
+ #{exp\ 12364}#
+ (#{extend-env\ 9064}#
+ #{labels\ 12379}#
+ (map (lambda (#{var\ 12384}#
+ #{level\ 12385}#)
(cons 'syntax
- (cons #{var\ 1600}#
- #{level\ 1601}#)))
- #{new-vars\ 1599}#
- (map cdr #{pvars\ 1591}#))
- #{r\ 1594}#)
- (#{make-binding-wrap\ 148}#
- #{ids\ 1596}#
- #{labels\ 1598}#
+ (cons #{var\ 12384}#
+ #{level\ 12385}#)))
+ #{new-vars\ 12380}#
+ (map cdr #{pvars\ 12363}#))
+ #{r\ 12366}#)
+ (#{make-binding-wrap\ 9123}#
+ #{ids\ 12375}#
+ #{labels\ 12379}#
'(()))
- #{mod\ 1595}#))
- #{y\ 1593}#))))))
- (#{convert-pattern\ 1554}#
- (lambda (#{pattern\ 1602}# #{keys\ 1603}#)
- (letrec ((#{cvt\ 1605}#
- (lambda (#{p\ 1606}# #{n\ 1607}# #{ids\ 1608}#)
- (if (#{id?\ 131}# #{p\ 1606}#)
- (if (#{bound-id-member?\ 158}#
- #{p\ 1606}#
- #{keys\ 1603}#)
+ #{mod\ 12367}#))
+ #{y\ 12365}#))))))
+ (#{convert-pattern\ 12268}#
+ (lambda (#{pattern\ 12391}# #{keys\ 12392}#)
+ (letrec ((#{cvt\ 12398}#
+ (lambda (#{p\ 12399}#
+ #{n\ 12400}#
+ #{ids\ 12401}#)
+ (if (#{id?\ 9076}# #{p\ 12399}#)
+ (if (#{bound-id-member?\ 9143}#
+ #{p\ 12399}#
+ #{keys\ 12392}#)
(values
- (vector (quote free-id) #{p\ 1606}#)
- #{ids\ 1608}#)
+ (vector (quote free-id) #{p\ 12399}#)
+ #{ids\ 12401}#)
(values
'any
- (cons (cons #{p\ 1606}# #{n\ 1607}#)
- #{ids\ 1608}#)))
- ((lambda (#{tmp\ 1609}#)
- ((lambda (#{tmp\ 1610}#)
- (if (if #{tmp\ 1610}#
- (apply (lambda (#{x\ 1611}#
- #{dots\ 1612}#)
- (#{ellipsis?\ 175}#
- #{dots\ 1612}#))
- #{tmp\ 1610}#)
+ (cons (cons #{p\ 12399}# #{n\ 12400}#)
+ #{ids\ 12401}#)))
+ ((lambda (#{tmp\ 12405}#)
+ ((lambda (#{tmp\ 12406}#)
+ (if (if #{tmp\ 12406}#
+ (apply (lambda (#{x\ 12409}#
+ #{dots\
12410}#)
+ (#{ellipsis?\ 9177}#
+ #{dots\ 12410}#))
+ #{tmp\ 12406}#)
#f)
- (apply (lambda (#{x\ 1613}#
- #{dots\ 1614}#)
+ (apply (lambda (#{x\ 12413}#
+ #{dots\ 12414}#)
(call-with-values
(lambda ()
- (#{cvt\ 1605}#
- #{x\ 1613}#
- (#{fx+\ 86}#
- #{n\ 1607}#
+ (#{cvt\ 12398}#
+ #{x\ 12413}#
+ (#{fx+\ 8977}#
+ #{n\ 12400}#
1)
- #{ids\ 1608}#))
- (lambda (#{p\ 1615}#
- #{ids\ 1616}#)
+ #{ids\ 12401}#))
+ (lambda (#{p\ 12415}#
+ #{ids\ 12416}#)
(values
- (if (eq? #{p\ 1615}#
+ (if (eq? #{p\
12415}#
'any)
'each-any
(vector
'each
- #{p\ 1615}#))
- #{ids\ 1616}#))))
- #{tmp\ 1610}#)
- ((lambda (#{tmp\ 1617}#)
- (if (if #{tmp\ 1617}#
- (apply (lambda (#{x\
1618}#
- #{dots\
1619}#
- #{ys\
1620}#)
- (#{ellipsis?\
175}#
- #{dots\
1619}#))
- #{tmp\ 1617}#)
+ #{p\ 12415}#))
+ #{ids\ 12416}#))))
+ #{tmp\ 12406}#)
+ ((lambda (#{tmp\ 12419}#)
+ (if (if #{tmp\ 12419}#
+ (apply (lambda (#{x\
12423}#
+ #{dots\
12424}#
+ #{ys\
12425}#)
+ (#{ellipsis?\
9177}#
+ #{dots\
12424}#))
+ #{tmp\ 12419}#)
#f)
- (apply (lambda (#{x\ 1621}#
- #{dots\ 1622}#
- #{ys\ 1623}#)
+ (apply (lambda (#{x\ 12429}#
+ #{dots\
12430}#
+ #{ys\ 12431}#)
(call-with-values
(lambda ()
- (#{cvt*\ 1604}#
- #{ys\ 1623}#
- #{n\ 1607}#
- #{ids\ 1608}#))
- (lambda (#{ys\
1625}#
- #{ids\
1626}#)
+ (#{cvt*\ 12396}#
+ #{ys\ 12431}#
+ #{n\ 12400}#
+ #{ids\
12401}#))
+ (lambda (#{ys\
12433}#
+ #{ids\
12434}#)
(call-with-values
(lambda ()
- (#{cvt\
1605}#
- #{x\ 1621}#
- (+ #{n\
1607}#
+ (#{cvt\
12398}#
+ #{x\
12429}#
+ (+ #{n\
12400}#
1)
- #{ids\
1626}#))
- (lambda (#{x\
1627}#
-
#{ids\ 1628}#)
+ #{ids\
12434}#))
+ (lambda (#{x\
12437}#
+
#{ids\ 12438}#)
(values
(list->vector
(cons
'each+
-
(cons #{x\ 1627}#
+
(cons #{x\ 12437}#
(cons (reverse
-
#{ys\ 1625}#)
+
#{ys\ 12433}#)
'(())))))
- #{ids\
1628}#))))))
- #{tmp\ 1617}#)
- ((lambda (#{tmp\ 1629}#)
- (if #{tmp\ 1629}#
- (apply (lambda (#{x\
1630}#
- #{y\
1631}#)
+ #{ids\
12438}#))))))
+ #{tmp\ 12419}#)
+ ((lambda (#{tmp\ 12442}#)
+ (if #{tmp\ 12442}#
+ (apply (lambda (#{x\
12445}#
+ #{y\
12446}#)
(call-with-values
(lambda ()
- (#{cvt\
1605}#
- #{y\
1631}#
- #{n\
1607}#
- #{ids\
1608}#))
- (lambda (#{y\
1632}#
-
#{ids\ 1633}#)
+ (#{cvt\
12398}#
+ #{y\
12446}#
+ #{n\
12400}#
+ #{ids\
12401}#))
+ (lambda (#{y\
12447}#
+
#{ids\ 12448}#)
(call-with-values
(lambda ()
- (#{cvt\
1605}#
- #{x\
1630}#
- #{n\
1607}#
-
#{ids\ 1633}#))
- (lambda
(#{x\ 1634}#
-
#{ids\ 1635}#)
+ (#{cvt\
12398}#
+ #{x\
12445}#
+ #{n\
12400}#
+
#{ids\ 12448}#))
+ (lambda
(#{x\ 12451}#
+
#{ids\ 12452}#)
(values
- (cons
#{x\ 1634}#
-
#{y\ 1632}#)
-
#{ids\ 1635}#))))))
- #{tmp\ 1629}#)
- ((lambda (#{tmp\ 1636}#)
- (if #{tmp\ 1636}#
+ (cons
#{x\ 12451}#
+
#{y\ 12447}#)
+
#{ids\ 12452}#))))))
+ #{tmp\ 12442}#)
+ ((lambda (#{tmp\ 12455}#)
+ (if #{tmp\ 12455}#
(apply (lambda ()
(values
'()
- #{ids\
1608}#))
- #{tmp\
1636}#)
- ((lambda (#{tmp\
1637}#)
- (if #{tmp\ 1637}#
- (apply (lambda
(#{x\ 1638}#)
+ #{ids\
12401}#))
+ #{tmp\
12455}#)
+ ((lambda (#{tmp\
12456}#)
+ (if #{tmp\
12456}#
+ (apply (lambda
(#{x\ 12458}#)
(call-with-values
(lambda ()
-
(#{cvt\ 1605}#
-
#{x\ 1638}#
-
#{n\ 1607}#
-
#{ids\ 1608}#))
-
(lambda (#{p\ 1640}#
-
#{ids\ 1641}#)
+
(#{cvt\ 12398}#
+
#{x\ 12458}#
+
#{n\ 12400}#
+
#{ids\ 12401}#))
+
(lambda (#{p\ 12460}#
+
#{ids\ 12461}#)
(values
(vector
'vector
-
#{p\ 1640}#)
-
#{ids\ 1641}#))))
- #{tmp\
1637}#)
- ((lambda (#{x\
1642}#)
+
#{p\ 12460}#)
+
#{ids\ 12461}#))))
+ #{tmp\
12456}#)
+ ((lambda (#{x\
12465}#)
(values
(vector
'atom
-
(#{strip\ 180}#
- #{p\
1606}#
+
(#{strip\ 9187}#
+ #{p\
12399}#
'(())))
- #{ids\
1608}#))
- #{tmp\
1609}#)))
+ #{ids\
12401}#))
+ #{tmp\
12405}#)))
($sc-dispatch
- #{tmp\ 1609}#
+ #{tmp\ 12405}#
'#(vector
each-any)))))
($sc-dispatch
- #{tmp\ 1609}#
+ #{tmp\ 12405}#
'()))))
($sc-dispatch
- #{tmp\ 1609}#
+ #{tmp\ 12405}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 1609}#
+ #{tmp\ 12405}#
'(any any . each-any)))))
($sc-dispatch
- #{tmp\ 1609}#
+ #{tmp\ 12405}#
'(any any))))
- #{p\ 1606}#))))
- (#{cvt*\ 1604}#
- (lambda (#{p*\ 1643}#
- #{n\ 1644}#
- #{ids\ 1645}#)
- (if (null? #{p*\ 1643}#)
- (values (quote ()) #{ids\ 1645}#)
+ #{p\ 12399}#))))
+ (#{cvt*\ 12396}#
+ (lambda (#{p*\ 12467}#
+ #{n\ 12468}#
+ #{ids\ 12469}#)
+ (if (null? #{p*\ 12467}#)
+ (values (quote ()) #{ids\ 12469}#)
(call-with-values
(lambda ()
- (#{cvt*\ 1604}#
- (cdr #{p*\ 1643}#)
- #{n\ 1644}#
- #{ids\ 1645}#))
- (lambda (#{y\ 1646}# #{ids\ 1647}#)
+ (#{cvt*\ 12396}#
+ (cdr #{p*\ 12467}#)
+ #{n\ 12468}#
+ #{ids\ 12469}#))
+ (lambda (#{y\ 12473}# #{ids\ 12474}#)
(call-with-values
(lambda ()
- (#{cvt\ 1605}#
- (car #{p*\ 1643}#)
- #{n\ 1644}#
- #{ids\ 1647}#))
- (lambda (#{x\ 1648}# #{ids\ 1649}#)
+ (#{cvt\ 12398}#
+ (car #{p*\ 12467}#)
+ #{n\ 12468}#
+ #{ids\ 12474}#))
+ (lambda (#{x\ 12477}# #{ids\ 12478}#)
(values
- (cons #{x\ 1648}# #{y\ 1646}#)
- #{ids\ 1649}#)))))))))
- (#{cvt\ 1605}# #{pattern\ 1602}# 0 (quote ()))))))
- (lambda (#{e\ 1650}#
- #{r\ 1651}#
- #{w\ 1652}#
- #{s\ 1653}#
- #{mod\ 1654}#)
- (let ((#{e\ 1655}#
- (#{source-wrap\ 160}#
- #{e\ 1650}#
- #{w\ 1652}#
- #{s\ 1653}#
- #{mod\ 1654}#)))
- ((lambda (#{tmp\ 1656}#)
- ((lambda (#{tmp\ 1657}#)
- (if #{tmp\ 1657}#
- (apply (lambda (#{_\ 1658}#
- #{val\ 1659}#
- #{key\ 1660}#
- #{m\ 1661}#)
+ (cons #{x\ 12477}# #{y\ 12473}#)
+ #{ids\ 12478}#)))))))))
+ (#{cvt\ 12398}# #{pattern\ 12391}# 0 (quote ()))))))
+ (lambda (#{e\ 12481}#
+ #{r\ 12482}#
+ #{w\ 12483}#
+ #{s\ 12484}#
+ #{mod\ 12485}#)
+ (let ((#{e\ 12492}#
+ (#{source-wrap\ 9147}#
+ #{e\ 12481}#
+ #{w\ 12483}#
+ #{s\ 12484}#
+ #{mod\ 12485}#)))
+ ((lambda (#{tmp\ 12493}#)
+ ((lambda (#{tmp\ 12494}#)
+ (if #{tmp\ 12494}#
+ (apply (lambda (#{_\ 12499}#
+ #{val\ 12500}#
+ #{key\ 12501}#
+ #{m\ 12502}#)
(if (and-map
- (lambda (#{x\ 1662}#)
- (if (#{id?\ 131}# #{x\ 1662}#)
- (not (#{ellipsis?\ 175}# #{x\ 1662}#))
+ (lambda (#{x\ 12503}#)
+ (if (#{id?\ 9076}# #{x\ 12503}#)
+ (not (#{ellipsis?\ 9177}#
+ #{x\ 12503}#))
#f))
- #{key\ 1660}#)
- (let ((#{x\ 1664}#
- (#{gen-var\ 181}# (quote tmp))))
- (#{build-application\ 96}#
- #{s\ 1653}#
- (#{build-simple-lambda\ 105}#
+ #{key\ 12501}#)
+ (let ((#{x\ 12509}#
+ (#{gen-var\ 9189}# (quote tmp))))
+ (#{build-application\ 8998}#
+ #{s\ 12484}#
+ (#{build-simple-lambda\ 9018}#
#f
(list (quote tmp))
#f
- (list #{x\ 1664}#)
- #f
- (#{gen-syntax-case\ 1557}#
- (#{build-lexical-reference\ 98}#
+ (list #{x\ 12509}#)
+ '()
+ (#{gen-syntax-case\ 12274}#
+ (#{build-lexical-reference\ 9004}#
'value
#f
'tmp
- #{x\ 1664}#)
- #{key\ 1660}#
- #{m\ 1661}#
- #{r\ 1651}#
- #{mod\ 1654}#))
- (list (#{chi\ 167}#
- #{val\ 1659}#
- #{r\ 1651}#
+ #{x\ 12509}#)
+ #{key\ 12501}#
+ #{m\ 12502}#
+ #{r\ 12482}#
+ #{mod\ 12485}#))
+ (list (#{chi\ 9161}#
+ #{val\ 12500}#
+ #{r\ 12482}#
'(())
- #{mod\ 1654}#))))
+ #{mod\ 12485}#))))
(syntax-violation
'syntax-case
"invalid literals list"
- #{e\ 1655}#)))
- #{tmp\ 1657}#)
+ #{e\ 12492}#)))
+ #{tmp\ 12494}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1656}#)))
+ #{tmp\ 12493}#)))
($sc-dispatch
- #{tmp\ 1656}#
+ #{tmp\ 12493}#
'(any any each-any . each-any))))
- #{e\ 1655}#)))))
- (set! sc-expand
- (lambda (#{x\ 1667}# . #{rest\ 1668}#)
- (if (if (pair? #{x\ 1667}#)
- (equal? (car #{x\ 1667}#) #{noexpand\ 84}#)
+ #{e\ 12492}#)))))
+ (set! macroexpand
+ (lambda (#{x\ 12515}# . #{rest\ 12516}#)
+ (if (if (pair? #{x\ 12515}#)
+ (equal? (car #{x\ 12515}#) #{noexpand\ 8973}#)
#f)
- (cadr #{x\ 1667}#)
- (let ((#{m\ 1669}#
- (if (null? #{rest\ 1668}#)
+ (cadr #{x\ 12515}#)
+ (let ((#{m\ 12523}#
+ (if (null? #{rest\ 12516}#)
'e
- (car #{rest\ 1668}#)))
- (#{esew\ 1670}#
- (if (let ((#{t\ 1671}# (null? #{rest\ 1668}#)))
- (if #{t\ 1671}#
- #{t\ 1671}#
- (null? (cdr #{rest\ 1668}#))))
+ (car #{rest\ 12516}#)))
+ (#{esew\ 12524}#
+ (if (let ((#{t\ 12527}# (null? #{rest\ 12516}#)))
+ (if #{t\ 12527}#
+ #{t\ 12527}#
+ (null? (cdr #{rest\ 12516}#))))
'(eval)
- (cadr #{rest\ 1668}#))))
- (with-fluid*
- #{*mode*\ 85}#
- #{m\ 1669}#
- (lambda ()
- (#{chi-top\ 166}#
- #{x\ 1667}#
- '()
- '((top))
- #{m\ 1669}#
- #{esew\ 1670}#
- (cons 'hygiene
- (module-name (current-module))))))))))
+ (cadr #{rest\ 12516}#))))
+ (with-fluids
+ ((#{*mode*\ 8975}# #{m\ 12523}#))
+ (#{chi-top\ 9159}#
+ #{x\ 12515}#
+ '()
+ '((top))
+ #{m\ 12523}#
+ #{esew\ 12524}#
+ (cons 'hygiene
+ (module-name (current-module)))))))))
(set! identifier?
- (lambda (#{x\ 1672}#)
- (#{nonsymbol-id?\ 130}# #{x\ 1672}#)))
+ (lambda (#{x\ 12531}#)
+ (#{nonsymbol-id?\ 9074}# #{x\ 12531}#)))
(set! datum->syntax
- (lambda (#{id\ 1673}# #{datum\ 1674}#)
- (#{make-syntax-object\ 114}#
- #{datum\ 1674}#
- (#{syntax-object-wrap\ 117}# #{id\ 1673}#)
+ (lambda (#{id\ 12533}# #{datum\ 12534}#)
+ (#{make-syntax-object\ 9038}#
+ #{datum\ 12534}#
+ (#{syntax-object-wrap\ 9044}# #{id\ 12533}#)
#f)))
(set! syntax->datum
- (lambda (#{x\ 1675}#)
- (#{strip\ 180}# #{x\ 1675}# (quote (())))))
+ (lambda (#{x\ 12537}#)
+ (#{strip\ 9187}# #{x\ 12537}# (quote (())))))
(set! generate-temporaries
- (lambda (#{ls\ 1676}#)
+ (lambda (#{ls\ 12540}#)
(begin
- (let ((#{x\ 1677}# #{ls\ 1676}#))
- (if (not (list? #{x\ 1677}#))
+ (let ((#{x\ 12544}# #{ls\ 12540}#))
+ (if (not (list? #{x\ 12544}#))
(syntax-violation
'generate-temporaries
"invalid argument"
- #{x\ 1677}#)))
- (map (lambda (#{x\ 1678}#)
- (#{wrap\ 159}# (gensym) (quote ((top))) #f))
- #{ls\ 1676}#))))
+ #{x\ 12544}#)))
+ (map (lambda (#{x\ 12545}#)
+ (#{wrap\ 9145}# (gensym) (quote ((top))) #f))
+ #{ls\ 12540}#))))
(set! free-identifier=?
- (lambda (#{x\ 1679}# #{y\ 1680}#)
+ (lambda (#{x\ 12549}# #{y\ 12550}#)
(begin
- (let ((#{x\ 1681}# #{x\ 1679}#))
- (if (not (#{nonsymbol-id?\ 130}# #{x\ 1681}#))
+ (let ((#{x\ 12555}# #{x\ 12549}#))
+ (if (not (#{nonsymbol-id?\ 9074}# #{x\ 12555}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 1681}#)))
- (let ((#{x\ 1682}# #{y\ 1680}#))
- (if (not (#{nonsymbol-id?\ 130}# #{x\ 1682}#))
+ #{x\ 12555}#)))
+ (let ((#{x\ 12558}# #{y\ 12550}#))
+ (if (not (#{nonsymbol-id?\ 9074}# #{x\ 12558}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 1682}#)))
- (#{free-id=?\ 154}# #{x\ 1679}# #{y\ 1680}#))))
+ #{x\ 12558}#)))
+ (#{free-id=?\ 9135}# #{x\ 12549}# #{y\ 12550}#))))
(set! bound-identifier=?
- (lambda (#{x\ 1683}# #{y\ 1684}#)
+ (lambda (#{x\ 12559}# #{y\ 12560}#)
(begin
- (let ((#{x\ 1685}# #{x\ 1683}#))
- (if (not (#{nonsymbol-id?\ 130}# #{x\ 1685}#))
+ (let ((#{x\ 12565}# #{x\ 12559}#))
+ (if (not (#{nonsymbol-id?\ 9074}# #{x\ 12565}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 1685}#)))
- (let ((#{x\ 1686}# #{y\ 1684}#))
- (if (not (#{nonsymbol-id?\ 130}# #{x\ 1686}#))
+ #{x\ 12565}#)))
+ (let ((#{x\ 12568}# #{y\ 12560}#))
+ (if (not (#{nonsymbol-id?\ 9074}# #{x\ 12568}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 1686}#)))
- (#{bound-id=?\ 155}# #{x\ 1683}# #{y\ 1684}#))))
+ #{x\ 12568}#)))
+ (#{bound-id=?\ 9137}# #{x\ 12559}# #{y\ 12560}#))))
(set! syntax-violation
- (lambda (#{who\ 1687}#
- #{message\ 1688}#
- #{form\ 1689}#
+ (lambda (#{who\ 12569}#
+ #{message\ 12570}#
+ #{form\ 12571}#
.
- #{subform\ 1690}#)
+ #{subform\ 12572}#)
(begin
- (let ((#{x\ 1691}# #{who\ 1687}#))
- (if (not ((lambda (#{x\ 1692}#)
- (let ((#{t\ 1693}# (not #{x\ 1692}#)))
- (if #{t\ 1693}#
- #{t\ 1693}#
- (let ((#{t\ 1694}# (string? #{x\ 1692}#)))
- (if #{t\ 1694}#
- #{t\ 1694}#
- (symbol? #{x\ 1692}#))))))
- #{x\ 1691}#))
+ (let ((#{x\ 12579}# #{who\ 12569}#))
+ (if (not ((lambda (#{x\ 12580}#)
+ (let ((#{t\ 12584}# (not #{x\ 12580}#)))
+ (if #{t\ 12584}#
+ #{t\ 12584}#
+ (let ((#{t\ 12587}# (string? #{x\ 12580}#)))
+ (if #{t\ 12587}#
+ #{t\ 12587}#
+ (symbol? #{x\ 12580}#))))))
+ #{x\ 12579}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 1691}#)))
- (let ((#{x\ 1695}# #{message\ 1688}#))
- (if (not (string? #{x\ 1695}#))
+ #{x\ 12579}#)))
+ (let ((#{x\ 12591}# #{message\ 12570}#))
+ (if (not (string? #{x\ 12591}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 1695}#)))
+ #{x\ 12591}#)))
(scm-error
'syntax-error
- 'sc-expand
+ 'macroexpand
(string-append
- (if #{who\ 1687}# "~a: " "")
+ (if #{who\ 12569}# "~a: " "")
"~a "
- (if (null? #{subform\ 1690}#)
+ (if (null? #{subform\ 12572}#)
"in ~a"
"in subform `~s' of `~s'"))
- (let ((#{tail\ 1696}#
- (cons #{message\ 1688}#
- (map (lambda (#{x\ 1697}#)
- (#{strip\ 180}# #{x\ 1697}# (quote (()))))
+ (let ((#{tail\ 12593}#
+ (cons #{message\ 12570}#
+ (map (lambda (#{x\ 12594}#)
+ (#{strip\ 9187}# #{x\ 12594}# (quote (()))))
(append
- #{subform\ 1690}#
- (list #{form\ 1689}#))))))
- (if #{who\ 1687}#
- (cons #{who\ 1687}# #{tail\ 1696}#)
- #{tail\ 1696}#))
+ #{subform\ 12572}#
+ (list #{form\ 12571}#))))))
+ (if #{who\ 12569}#
+ (cons #{who\ 12569}# #{tail\ 12593}#)
+ #{tail\ 12593}#))
#f))))
- (letrec ((#{match\ 1704}#
- (lambda (#{e\ 1705}#
- #{p\ 1706}#
- #{w\ 1707}#
- #{r\ 1708}#
- #{mod\ 1709}#)
- (if (not #{r\ 1708}#)
+ (letrec ((#{match\ 12610}#
+ (lambda (#{e\ 12611}#
+ #{p\ 12612}#
+ #{w\ 12613}#
+ #{r\ 12614}#
+ #{mod\ 12615}#)
+ (if (not #{r\ 12614}#)
#f
- (if (eq? #{p\ 1706}# (quote any))
- (cons (#{wrap\ 159}#
- #{e\ 1705}#
- #{w\ 1707}#
- #{mod\ 1709}#)
- #{r\ 1708}#)
- (if (#{syntax-object?\ 115}# #{e\ 1705}#)
- (#{match*\ 1703}#
- (#{syntax-object-expression\ 116}# #{e\ 1705}#)
- #{p\ 1706}#
- (#{join-wraps\ 150}#
- #{w\ 1707}#
- (#{syntax-object-wrap\ 117}# #{e\ 1705}#))
- #{r\ 1708}#
- (#{syntax-object-module\ 118}# #{e\ 1705}#))
- (#{match*\ 1703}#
- #{e\ 1705}#
- #{p\ 1706}#
- #{w\ 1707}#
- #{r\ 1708}#
- #{mod\ 1709}#))))))
- (#{match*\ 1703}#
- (lambda (#{e\ 1710}#
- #{p\ 1711}#
- #{w\ 1712}#
- #{r\ 1713}#
- #{mod\ 1714}#)
- (if (null? #{p\ 1711}#)
- (if (null? #{e\ 1710}#) #{r\ 1713}# #f)
- (if (pair? #{p\ 1711}#)
- (if (pair? #{e\ 1710}#)
- (#{match\ 1704}#
- (car #{e\ 1710}#)
- (car #{p\ 1711}#)
- #{w\ 1712}#
- (#{match\ 1704}#
- (cdr #{e\ 1710}#)
- (cdr #{p\ 1711}#)
- #{w\ 1712}#
- #{r\ 1713}#
- #{mod\ 1714}#)
- #{mod\ 1714}#)
+ (if (eq? #{p\ 12612}# (quote any))
+ (cons (#{wrap\ 9145}#
+ #{e\ 12611}#
+ #{w\ 12613}#
+ #{mod\ 12615}#)
+ #{r\ 12614}#)
+ (if (#{syntax-object?\ 9040}# #{e\ 12611}#)
+ (#{match*\ 12608}#
+ (#{syntax-object-expression\ 9042}# #{e\ 12611}#)
+ #{p\ 12612}#
+ (#{join-wraps\ 9127}#
+ #{w\ 12613}#
+ (#{syntax-object-wrap\ 9044}# #{e\ 12611}#))
+ #{r\ 12614}#
+ (#{syntax-object-module\ 9046}# #{e\ 12611}#))
+ (#{match*\ 12608}#
+ #{e\ 12611}#
+ #{p\ 12612}#
+ #{w\ 12613}#
+ #{r\ 12614}#
+ #{mod\ 12615}#))))))
+ (#{match*\ 12608}#
+ (lambda (#{e\ 12628}#
+ #{p\ 12629}#
+ #{w\ 12630}#
+ #{r\ 12631}#
+ #{mod\ 12632}#)
+ (if (null? #{p\ 12629}#)
+ (if (null? #{e\ 12628}#) #{r\ 12631}# #f)
+ (if (pair? #{p\ 12629}#)
+ (if (pair? #{e\ 12628}#)
+ (#{match\ 12610}#
+ (car #{e\ 12628}#)
+ (car #{p\ 12629}#)
+ #{w\ 12630}#
+ (#{match\ 12610}#
+ (cdr #{e\ 12628}#)
+ (cdr #{p\ 12629}#)
+ #{w\ 12630}#
+ #{r\ 12631}#
+ #{mod\ 12632}#)
+ #{mod\ 12632}#)
#f)
- (if (eq? #{p\ 1711}# (quote each-any))
- (let ((#{l\ 1715}#
- (#{match-each-any\ 1700}#
- #{e\ 1710}#
- #{w\ 1712}#
- #{mod\ 1714}#)))
- (if #{l\ 1715}#
- (cons #{l\ 1715}# #{r\ 1713}#)
+ (if (eq? #{p\ 12629}# (quote each-any))
+ (let ((#{l\ 12649}#
+ (#{match-each-any\ 12602}#
+ #{e\ 12628}#
+ #{w\ 12630}#
+ #{mod\ 12632}#)))
+ (if #{l\ 12649}#
+ (cons #{l\ 12649}# #{r\ 12631}#)
#f))
- (let ((#{atom-key\ 1716}# (vector-ref #{p\ 1711}# 0)))
- (if (memv #{atom-key\ 1716}# (quote (each)))
- (if (null? #{e\ 1710}#)
- (#{match-empty\ 1701}#
- (vector-ref #{p\ 1711}# 1)
- #{r\ 1713}#)
- (let ((#{l\ 1717}#
- (#{match-each\ 1698}#
- #{e\ 1710}#
- (vector-ref #{p\ 1711}# 1)
- #{w\ 1712}#
- #{mod\ 1714}#)))
- (if #{l\ 1717}#
- (letrec ((#{collect\ 1718}#
- (lambda (#{l\ 1719}#)
- (if (null? (car #{l\ 1719}#))
- #{r\ 1713}#
- (cons (map car #{l\ 1719}#)
- (#{collect\ 1718}#
+ (let ((#{atom-key\ 12655}#
+ (vector-ref #{p\ 12629}# 0)))
+ (if (memv #{atom-key\ 12655}# (quote (each)))
+ (if (null? #{e\ 12628}#)
+ (#{match-empty\ 12604}#
+ (vector-ref #{p\ 12629}# 1)
+ #{r\ 12631}#)
+ (let ((#{l\ 12658}#
+ (#{match-each\ 12598}#
+ #{e\ 12628}#
+ (vector-ref #{p\ 12629}# 1)
+ #{w\ 12630}#
+ #{mod\ 12632}#)))
+ (if #{l\ 12658}#
+ (letrec ((#{collect\ 12663}#
+ (lambda (#{l\ 12664}#)
+ (if (null? (car #{l\ 12664}#))
+ #{r\ 12631}#
+ (cons (map car #{l\ 12664}#)
+ (#{collect\ 12663}#
(map cdr
- #{l\
1719}#)))))))
- (#{collect\ 1718}# #{l\ 1717}#))
+ #{l\
12664}#)))))))
+ (#{collect\ 12663}# #{l\ 12658}#))
#f)))
- (if (memv #{atom-key\ 1716}# (quote (each+)))
+ (if (memv #{atom-key\ 12655}# (quote (each+)))
(call-with-values
(lambda ()
- (#{match-each+\ 1699}#
- #{e\ 1710}#
- (vector-ref #{p\ 1711}# 1)
- (vector-ref #{p\ 1711}# 2)
- (vector-ref #{p\ 1711}# 3)
- #{w\ 1712}#
- #{r\ 1713}#
- #{mod\ 1714}#))
- (lambda (#{xr*\ 1720}#
- #{y-pat\ 1721}#
- #{r\ 1722}#)
- (if #{r\ 1722}#
- (if (null? #{y-pat\ 1721}#)
- (if (null? #{xr*\ 1720}#)
- (#{match-empty\ 1701}#
- (vector-ref #{p\ 1711}# 1)
- #{r\ 1722}#)
- (#{combine\ 1702}#
- #{xr*\ 1720}#
- #{r\ 1722}#))
+ (#{match-each+\ 12600}#
+ #{e\ 12628}#
+ (vector-ref #{p\ 12629}# 1)
+ (vector-ref #{p\ 12629}# 2)
+ (vector-ref #{p\ 12629}# 3)
+ #{w\ 12630}#
+ #{r\ 12631}#
+ #{mod\ 12632}#))
+ (lambda (#{xr*\ 12666}#
+ #{y-pat\ 12667}#
+ #{r\ 12668}#)
+ (if #{r\ 12668}#
+ (if (null? #{y-pat\ 12667}#)
+ (if (null? #{xr*\ 12666}#)
+ (#{match-empty\ 12604}#
+ (vector-ref #{p\ 12629}# 1)
+ #{r\ 12668}#)
+ (#{combine\ 12606}#
+ #{xr*\ 12666}#
+ #{r\ 12668}#))
#f)
#f)))
- (if (memv #{atom-key\ 1716}# (quote (free-id)))
- (if (#{id?\ 131}# #{e\ 1710}#)
- (if (#{free-id=?\ 154}#
- (#{wrap\ 159}#
- #{e\ 1710}#
- #{w\ 1712}#
- #{mod\ 1714}#)
- (vector-ref #{p\ 1711}# 1))
- #{r\ 1713}#
+ (if (memv #{atom-key\ 12655}# (quote (free-id)))
+ (if (#{id?\ 9076}# #{e\ 12628}#)
+ (if (#{free-id=?\ 9135}#
+ (#{wrap\ 9145}#
+ #{e\ 12628}#
+ #{w\ 12630}#
+ #{mod\ 12632}#)
+ (vector-ref #{p\ 12629}# 1))
+ #{r\ 12631}#
#f)
#f)
- (if (memv #{atom-key\ 1716}# (quote (atom)))
+ (if (memv #{atom-key\ 12655}# (quote (atom)))
(if (equal?
- (vector-ref #{p\ 1711}# 1)
- (#{strip\ 180}#
- #{e\ 1710}#
- #{w\ 1712}#))
- #{r\ 1713}#
+ (vector-ref #{p\ 12629}# 1)
+ (#{strip\ 9187}#
+ #{e\ 12628}#
+ #{w\ 12630}#))
+ #{r\ 12631}#
#f)
- (if (memv #{atom-key\ 1716}#
+ (if (memv #{atom-key\ 12655}#
'(vector))
- (if (vector? #{e\ 1710}#)
- (#{match\ 1704}#
- (vector->list #{e\ 1710}#)
- (vector-ref #{p\ 1711}# 1)
- #{w\ 1712}#
- #{r\ 1713}#
- #{mod\ 1714}#)
+ (if (vector? #{e\ 12628}#)
+ (#{match\ 12610}#
+ (vector->list #{e\ 12628}#)
+ (vector-ref #{p\ 12629}# 1)
+ #{w\ 12630}#
+ #{r\ 12631}#
+ #{mod\ 12632}#)
#f))))))))))))
- (#{combine\ 1702}#
- (lambda (#{r*\ 1723}# #{r\ 1724}#)
- (if (null? (car #{r*\ 1723}#))
- #{r\ 1724}#
- (cons (map car #{r*\ 1723}#)
- (#{combine\ 1702}#
- (map cdr #{r*\ 1723}#)
- #{r\ 1724}#)))))
- (#{match-empty\ 1701}#
- (lambda (#{p\ 1725}# #{r\ 1726}#)
- (if (null? #{p\ 1725}#)
- #{r\ 1726}#
- (if (eq? #{p\ 1725}# (quote any))
- (cons (quote ()) #{r\ 1726}#)
- (if (pair? #{p\ 1725}#)
- (#{match-empty\ 1701}#
- (car #{p\ 1725}#)
- (#{match-empty\ 1701}#
- (cdr #{p\ 1725}#)
- #{r\ 1726}#))
- (if (eq? #{p\ 1725}# (quote each-any))
- (cons (quote ()) #{r\ 1726}#)
- (let ((#{atom-key\ 1727}#
- (vector-ref #{p\ 1725}# 0)))
- (if (memv #{atom-key\ 1727}# (quote (each)))
- (#{match-empty\ 1701}#
- (vector-ref #{p\ 1725}# 1)
- #{r\ 1726}#)
- (if (memv #{atom-key\ 1727}# (quote (each+)))
- (#{match-empty\ 1701}#
- (vector-ref #{p\ 1725}# 1)
- (#{match-empty\ 1701}#
- (reverse (vector-ref #{p\ 1725}# 2))
- (#{match-empty\ 1701}#
- (vector-ref #{p\ 1725}# 3)
- #{r\ 1726}#)))
- (if (memv #{atom-key\ 1727}#
+ (#{combine\ 12606}#
+ (lambda (#{r*\ 12685}# #{r\ 12686}#)
+ (if (null? (car #{r*\ 12685}#))
+ #{r\ 12686}#
+ (cons (map car #{r*\ 12685}#)
+ (#{combine\ 12606}#
+ (map cdr #{r*\ 12685}#)
+ #{r\ 12686}#)))))
+ (#{match-empty\ 12604}#
+ (lambda (#{p\ 12689}# #{r\ 12690}#)
+ (if (null? #{p\ 12689}#)
+ #{r\ 12690}#
+ (if (eq? #{p\ 12689}# (quote any))
+ (cons (quote ()) #{r\ 12690}#)
+ (if (pair? #{p\ 12689}#)
+ (#{match-empty\ 12604}#
+ (car #{p\ 12689}#)
+ (#{match-empty\ 12604}#
+ (cdr #{p\ 12689}#)
+ #{r\ 12690}#))
+ (if (eq? #{p\ 12689}# (quote each-any))
+ (cons (quote ()) #{r\ 12690}#)
+ (let ((#{atom-key\ 12704}#
+ (vector-ref #{p\ 12689}# 0)))
+ (if (memv #{atom-key\ 12704}# (quote (each)))
+ (#{match-empty\ 12604}#
+ (vector-ref #{p\ 12689}# 1)
+ #{r\ 12690}#)
+ (if (memv #{atom-key\ 12704}# (quote (each+)))
+ (#{match-empty\ 12604}#
+ (vector-ref #{p\ 12689}# 1)
+ (#{match-empty\ 12604}#
+ (reverse (vector-ref #{p\ 12689}# 2))
+ (#{match-empty\ 12604}#
+ (vector-ref #{p\ 12689}# 3)
+ #{r\ 12690}#)))
+ (if (memv #{atom-key\ 12704}#
'(free-id atom))
- #{r\ 1726}#
- (if (memv #{atom-key\ 1727}#
+ #{r\ 12690}#
+ (if (memv #{atom-key\ 12704}#
'(vector))
- (#{match-empty\ 1701}#
- (vector-ref #{p\ 1725}# 1)
- #{r\ 1726}#))))))))))))
- (#{match-each-any\ 1700}#
- (lambda (#{e\ 1728}# #{w\ 1729}# #{mod\ 1730}#)
- (if (pair? #{e\ 1728}#)
- (let ((#{l\ 1731}#
- (#{match-each-any\ 1700}#
- (cdr #{e\ 1728}#)
- #{w\ 1729}#
- #{mod\ 1730}#)))
- (if #{l\ 1731}#
- (cons (#{wrap\ 159}#
- (car #{e\ 1728}#)
- #{w\ 1729}#
- #{mod\ 1730}#)
- #{l\ 1731}#)
+ (#{match-empty\ 12604}#
+ (vector-ref #{p\ 12689}# 1)
+ #{r\ 12690}#))))))))))))
+ (#{match-each-any\ 12602}#
+ (lambda (#{e\ 12709}# #{w\ 12710}# #{mod\ 12711}#)
+ (if (pair? #{e\ 12709}#)
+ (let ((#{l\ 12718}#
+ (#{match-each-any\ 12602}#
+ (cdr #{e\ 12709}#)
+ #{w\ 12710}#
+ #{mod\ 12711}#)))
+ (if #{l\ 12718}#
+ (cons (#{wrap\ 9145}#
+ (car #{e\ 12709}#)
+ #{w\ 12710}#
+ #{mod\ 12711}#)
+ #{l\ 12718}#)
#f))
- (if (null? #{e\ 1728}#)
+ (if (null? #{e\ 12709}#)
'()
- (if (#{syntax-object?\ 115}# #{e\ 1728}#)
- (#{match-each-any\ 1700}#
- (#{syntax-object-expression\ 116}# #{e\ 1728}#)
- (#{join-wraps\ 150}#
- #{w\ 1729}#
- (#{syntax-object-wrap\ 117}# #{e\ 1728}#))
- #{mod\ 1730}#)
+ (if (#{syntax-object?\ 9040}# #{e\ 12709}#)
+ (#{match-each-any\ 12602}#
+ (#{syntax-object-expression\ 9042}# #{e\ 12709}#)
+ (#{join-wraps\ 9127}#
+ #{w\ 12710}#
+ (#{syntax-object-wrap\ 9044}# #{e\ 12709}#))
+ #{mod\ 12711}#)
#f)))))
- (#{match-each+\ 1699}#
- (lambda (#{e\ 1732}#
- #{x-pat\ 1733}#
- #{y-pat\ 1734}#
- #{z-pat\ 1735}#
- #{w\ 1736}#
- #{r\ 1737}#
- #{mod\ 1738}#)
- (letrec ((#{f\ 1739}#
- (lambda (#{e\ 1740}# #{w\ 1741}#)
- (if (pair? #{e\ 1740}#)
+ (#{match-each+\ 12600}#
+ (lambda (#{e\ 12726}#
+ #{x-pat\ 12727}#
+ #{y-pat\ 12728}#
+ #{z-pat\ 12729}#
+ #{w\ 12730}#
+ #{r\ 12731}#
+ #{mod\ 12732}#)
+ (letrec ((#{f\ 12743}#
+ (lambda (#{e\ 12744}# #{w\ 12745}#)
+ (if (pair? #{e\ 12744}#)
(call-with-values
(lambda ()
- (#{f\ 1739}#
- (cdr #{e\ 1740}#)
- #{w\ 1741}#))
- (lambda (#{xr*\ 1742}#
- #{y-pat\ 1743}#
- #{r\ 1744}#)
- (if #{r\ 1744}#
- (if (null? #{y-pat\ 1743}#)
- (let ((#{xr\ 1745}#
- (#{match\ 1704}#
- (car #{e\ 1740}#)
- #{x-pat\ 1733}#
- #{w\ 1741}#
+ (#{f\ 12743}#
+ (cdr #{e\ 12744}#)
+ #{w\ 12745}#))
+ (lambda (#{xr*\ 12748}#
+ #{y-pat\ 12749}#
+ #{r\ 12750}#)
+ (if #{r\ 12750}#
+ (if (null? #{y-pat\ 12749}#)
+ (let ((#{xr\ 12755}#
+ (#{match\ 12610}#
+ (car #{e\ 12744}#)
+ #{x-pat\ 12727}#
+ #{w\ 12745}#
'()
- #{mod\ 1738}#)))
- (if #{xr\ 1745}#
+ #{mod\ 12732}#)))
+ (if #{xr\ 12755}#
(values
- (cons #{xr\ 1745}#
- #{xr*\ 1742}#)
- #{y-pat\ 1743}#
- #{r\ 1744}#)
+ (cons #{xr\ 12755}#
+ #{xr*\ 12748}#)
+ #{y-pat\ 12749}#
+ #{r\ 12750}#)
(values #f #f #f)))
(values
'()
- (cdr #{y-pat\ 1743}#)
- (#{match\ 1704}#
- (car #{e\ 1740}#)
- (car #{y-pat\ 1743}#)
- #{w\ 1741}#
- #{r\ 1744}#
- #{mod\ 1738}#)))
+ (cdr #{y-pat\ 12749}#)
+ (#{match\ 12610}#
+ (car #{e\ 12744}#)
+ (car #{y-pat\ 12749}#)
+ #{w\ 12745}#
+ #{r\ 12750}#
+ #{mod\ 12732}#)))
(values #f #f #f))))
- (if (#{syntax-object?\ 115}# #{e\ 1740}#)
- (#{f\ 1739}#
- (#{syntax-object-expression\ 116}#
- #{e\ 1740}#)
- (#{join-wraps\ 150}#
- #{w\ 1741}#
- #{e\ 1740}#))
+ (if (#{syntax-object?\ 9040}# #{e\ 12744}#)
+ (#{f\ 12743}#
+ (#{syntax-object-expression\ 9042}#
+ #{e\ 12744}#)
+ (#{join-wraps\ 9127}#
+ #{w\ 12745}#
+ #{e\ 12744}#))
(values
'()
- #{y-pat\ 1734}#
- (#{match\ 1704}#
- #{e\ 1740}#
- #{z-pat\ 1735}#
- #{w\ 1741}#
- #{r\ 1737}#
- #{mod\ 1738}#)))))))
- (#{f\ 1739}# #{e\ 1732}# #{w\ 1736}#))))
- (#{match-each\ 1698}#
- (lambda (#{e\ 1746}#
- #{p\ 1747}#
- #{w\ 1748}#
- #{mod\ 1749}#)
- (if (pair? #{e\ 1746}#)
- (let ((#{first\ 1750}#
- (#{match\ 1704}#
- (car #{e\ 1746}#)
- #{p\ 1747}#
- #{w\ 1748}#
+ #{y-pat\ 12728}#
+ (#{match\ 12610}#
+ #{e\ 12744}#
+ #{z-pat\ 12729}#
+ #{w\ 12745}#
+ #{r\ 12731}#
+ #{mod\ 12732}#)))))))
+ (#{f\ 12743}# #{e\ 12726}# #{w\ 12730}#))))
+ (#{match-each\ 12598}#
+ (lambda (#{e\ 12759}#
+ #{p\ 12760}#
+ #{w\ 12761}#
+ #{mod\ 12762}#)
+ (if (pair? #{e\ 12759}#)
+ (let ((#{first\ 12770}#
+ (#{match\ 12610}#
+ (car #{e\ 12759}#)
+ #{p\ 12760}#
+ #{w\ 12761}#
'()
- #{mod\ 1749}#)))
- (if #{first\ 1750}#
- (let ((#{rest\ 1751}#
- (#{match-each\ 1698}#
- (cdr #{e\ 1746}#)
- #{p\ 1747}#
- #{w\ 1748}#
- #{mod\ 1749}#)))
- (if #{rest\ 1751}#
- (cons #{first\ 1750}# #{rest\ 1751}#)
+ #{mod\ 12762}#)))
+ (if #{first\ 12770}#
+ (let ((#{rest\ 12774}#
+ (#{match-each\ 12598}#
+ (cdr #{e\ 12759}#)
+ #{p\ 12760}#
+ #{w\ 12761}#
+ #{mod\ 12762}#)))
+ (if #{rest\ 12774}#
+ (cons #{first\ 12770}# #{rest\ 12774}#)
#f))
#f))
- (if (null? #{e\ 1746}#)
+ (if (null? #{e\ 12759}#)
'()
- (if (#{syntax-object?\ 115}# #{e\ 1746}#)
- (#{match-each\ 1698}#
- (#{syntax-object-expression\ 116}# #{e\ 1746}#)
- #{p\ 1747}#
- (#{join-wraps\ 150}#
- #{w\ 1748}#
- (#{syntax-object-wrap\ 117}# #{e\ 1746}#))
- (#{syntax-object-module\ 118}# #{e\ 1746}#))
+ (if (#{syntax-object?\ 9040}# #{e\ 12759}#)
+ (#{match-each\ 12598}#
+ (#{syntax-object-expression\ 9042}# #{e\ 12759}#)
+ #{p\ 12760}#
+ (#{join-wraps\ 9127}#
+ #{w\ 12761}#
+ (#{syntax-object-wrap\ 9044}# #{e\ 12759}#))
+ (#{syntax-object-module\ 9046}# #{e\ 12759}#))
#f))))))
(set! $sc-dispatch
- (lambda (#{e\ 1752}# #{p\ 1753}#)
- (if (eq? #{p\ 1753}# (quote any))
- (list #{e\ 1752}#)
- (if (#{syntax-object?\ 115}# #{e\ 1752}#)
- (#{match*\ 1703}#
- (#{syntax-object-expression\ 116}# #{e\ 1752}#)
- #{p\ 1753}#
- (#{syntax-object-wrap\ 117}# #{e\ 1752}#)
+ (lambda (#{e\ 12782}# #{p\ 12783}#)
+ (if (eq? #{p\ 12783}# (quote any))
+ (list #{e\ 12782}#)
+ (if (#{syntax-object?\ 9040}# #{e\ 12782}#)
+ (#{match*\ 12608}#
+ (#{syntax-object-expression\ 9042}# #{e\ 12782}#)
+ #{p\ 12783}#
+ (#{syntax-object-wrap\ 9044}# #{e\ 12782}#)
'()
- (#{syntax-object-module\ 118}# #{e\ 1752}#))
- (#{match*\ 1703}#
- #{e\ 1752}#
- #{p\ 1753}#
+ (#{syntax-object-module\ 9046}# #{e\ 12782}#))
+ (#{match*\ 12608}#
+ #{e\ 12782}#
+ #{p\ 12783}#
'(())
'()
#f)))))))))
(define with-syntax
- (make-syncase-macro
+ (make-syntax-transformer
+ 'with-syntax
'macro
- (cons (lambda (#{x\ 1754}#)
- ((lambda (#{tmp\ 1755}#)
- ((lambda (#{tmp\ 1756}#)
- (if #{tmp\ 1756}#
- (apply (lambda (#{_\ 1757}# #{e1\ 1758}# #{e2\ 1759}#)
+ (cons (lambda (#{x\ 12792}#)
+ ((lambda (#{tmp\ 12794}#)
+ ((lambda (#{tmp\ 12795}#)
+ (if #{tmp\ 12795}#
+ (apply (lambda (#{_\ 12799}# #{e1\ 12800}# #{e2\ 12801}#)
(cons '#(syntax-object
begin
((top)
#(ribcage
#(_ e1 e2)
#((top) (top) (top))
- #("i" "i" "i"))
+ #("i12796" "i12797" "i12798"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage #(x) #((top)) #("i12793")))
(hygiene guile))
- (cons #{e1\ 1758}# #{e2\ 1759}#)))
- #{tmp\ 1756}#)
- ((lambda (#{tmp\ 1761}#)
- (if #{tmp\ 1761}#
- (apply (lambda (#{_\ 1762}#
- #{out\ 1763}#
- #{in\ 1764}#
- #{e1\ 1765}#
- #{e2\ 1766}#)
+ (cons #{e1\ 12800}# #{e2\ 12801}#)))
+ #{tmp\ 12795}#)
+ ((lambda (#{tmp\ 12803}#)
+ (if #{tmp\ 12803}#
+ (apply (lambda (#{_\ 12809}#
+ #{out\ 12810}#
+ #{in\ 12811}#
+ #{e1\ 12812}#
+ #{e2\ 12813}#)
(list '#(syntax-object
syntax-case
((top)
#(ribcage
#(_ out in e1 e2)
#((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
+ #("i12804"
+ "i12805"
+ "i12806"
+ "i12807"
+ "i12808"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i12793")))
(hygiene guile))
- #{in\ 1764}#
+ #{in\ 12811}#
'()
- (list #{out\ 1763}#
+ (list #{out\ 12810}#
(cons '#(syntax-object
begin
((top)
@@ -11631,27 +11802,27 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
+ #("i12804"
+ "i12805"
+ "i12806"
+ "i12807"
+ "i12808"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i12793")))
(hygiene guile))
- (cons #{e1\ 1765}#
- #{e2\ 1766}#)))))
- #{tmp\ 1761}#)
- ((lambda (#{tmp\ 1768}#)
- (if #{tmp\ 1768}#
- (apply (lambda (#{_\ 1769}#
- #{out\ 1770}#
- #{in\ 1771}#
- #{e1\ 1772}#
- #{e2\ 1773}#)
+ (cons #{e1\ 12812}#
+ #{e2\ 12813}#)))))
+ #{tmp\ 12803}#)
+ ((lambda (#{tmp\ 12815}#)
+ (if #{tmp\ 12815}#
+ (apply (lambda (#{_\ 12821}#
+ #{out\ 12822}#
+ #{in\ 12823}#
+ #{e1\ 12824}#
+ #{e2\ 12825}#)
(list '#(syntax-object
syntax-case
((top)
@@ -11662,12 +11833,16 @@
(top)
(top)
(top))
- #("i" "i" "i" "i" "i"))
+ #("i12816"
+ "i12817"
+ "i12818"
+ "i12819"
+ "i12820"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i12793")))
(hygiene guile))
(cons '#(syntax-object
list
@@ -11679,20 +11854,20 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
+ #("i12816"
+ "i12817"
+ "i12818"
+ "i12819"
+ "i12820"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i12793")))
(hygiene guile))
- #{in\ 1771}#)
+ #{in\ 12823}#)
'()
- (list #{out\ 1770}#
+ (list #{out\ 12822}#
(cons '#(syntax-object
begin
((top)
@@ -11707,11 +11882,11 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
+ #("i12816"
+ "i12817"
+ "i12818"
+ "i12819"
+ "i12820"))
#(ribcage
()
()
@@ -11719,48 +11894,53 @@
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i12793")))
(hygiene guile))
- (cons #{e1\ 1772}#
- #{e2\
1773}#)))))
- #{tmp\ 1768}#)
+ (cons #{e1\ 12824}#
+ #{e2\
12825}#)))))
+ #{tmp\ 12815}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1755}#)))
+ #{tmp\ 12794}#)))
($sc-dispatch
- #{tmp\ 1755}#
+ #{tmp\ 12794}#
'(any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 1755}#
+ #{tmp\ 12794}#
'(any ((any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 1755}#
+ #{tmp\ 12794}#
'(any () any . each-any))))
- #{x\ 1754}#))
+ #{x\ 12792}#))
(module-name (current-module)))))
(define syntax-rules
- (make-syncase-macro
+ (make-syntax-transformer
+ 'syntax-rules
'macro
- (cons (lambda (#{x\ 1777}#)
- ((lambda (#{tmp\ 1778}#)
- ((lambda (#{tmp\ 1779}#)
- (if #{tmp\ 1779}#
- (apply (lambda (#{_\ 1780}#
- #{k\ 1781}#
- #{keyword\ 1782}#
- #{pattern\ 1783}#
- #{template\ 1784}#)
+ (cons (lambda (#{x\ 12829}#)
+ ((lambda (#{tmp\ 12831}#)
+ ((lambda (#{tmp\ 12832}#)
+ (if #{tmp\ 12832}#
+ (apply (lambda (#{_\ 12838}#
+ #{k\ 12839}#
+ #{keyword\ 12840}#
+ #{pattern\ 12841}#
+ #{template\ 12842}#)
(list '#(syntax-object
lambda
((top)
#(ribcage
#(_ k keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage #(x) #((top)) #("i12830")))
(hygiene guile))
'(#(syntax-object
x
@@ -11768,19 +11948,86 @@
#(ribcage
#(_ k keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage #(x) #((top)) #("i12830")))
(hygiene guile)))
+ (vector
+ '(#(syntax-object
+ macro-type
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i12830")))
+ (hygiene guile))
+ .
+ #(syntax-object
+ syntax-rules
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i12830")))
+ (hygiene guile)))
+ (cons '#(syntax-object
+ patterns
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i12830")))
+ (hygiene guile))
+ #{pattern\ 12841}#))
(cons '#(syntax-object
syntax-case
((top)
#(ribcage
#(_ k keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i12830")))
(hygiene guile))
(cons '#(syntax-object
x
@@ -11796,16 +12043,20 @@
(top)
(top)
(top))
- #("i" "i" "i" "i" "i"))
+ #("i12833"
+ "i12834"
+ "i12835"
+ "i12836"
+ "i12837"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i12830")))
(hygiene guile))
- (cons #{k\ 1781}#
- (map (lambda (#{tmp\
1787}#
- #{tmp\
1786}#)
+ (cons #{k\ 12839}#
+ (map (lambda (#{tmp\
12846}#
+ #{tmp\
12845}#)
(list (cons
'#(syntax-object
dummy
((top)
@@ -11820,11 +12071,11 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12833"
+
"i12834"
+
"i12835"
+
"i12836"
+
"i12837"))
#(ribcage
()
()
@@ -11832,10 +12083,10 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i12830")))
(hygiene
guile))
- #{tmp\
1786}#)
+ #{tmp\
12845}#)
(list
'#(syntax-object
syntax
((top)
@@ -11850,11 +12101,11 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12833"
+
"i12834"
+
"i12835"
+
"i12836"
+
"i12837"))
#(ribcage
()
()
@@ -11862,47 +12113,47 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i12830")))
(hygiene
guile))
- #{tmp\
1787}#)))
- #{template\ 1784}#
- #{pattern\
1783}#))))))
- #{tmp\ 1779}#)
+ #{tmp\
12846}#)))
+ #{template\ 12842}#
+ #{pattern\
12841}#))))))
+ #{tmp\ 12832}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1778}#)))
+ #{tmp\ 12831}#)))
($sc-dispatch
- #{tmp\ 1778}#
+ #{tmp\ 12831}#
'(any each-any . #(each ((any . any) any))))))
- #{x\ 1777}#))
+ #{x\ 12829}#))
(module-name (current-module)))))
(define let*
- (make-extended-syncase-macro
- (module-ref (current-module) (quote let*))
+ (make-syntax-transformer
+ 'let*
'macro
- (cons (lambda (#{x\ 1788}#)
- ((lambda (#{tmp\ 1789}#)
- ((lambda (#{tmp\ 1790}#)
- (if (if #{tmp\ 1790}#
- (apply (lambda (#{let*\ 1791}#
- #{x\ 1792}#
- #{v\ 1793}#
- #{e1\ 1794}#
- #{e2\ 1795}#)
- (and-map identifier? #{x\ 1792}#))
- #{tmp\ 1790}#)
+ (cons (lambda (#{x\ 12847}#)
+ ((lambda (#{tmp\ 12849}#)
+ ((lambda (#{tmp\ 12850}#)
+ (if (if #{tmp\ 12850}#
+ (apply (lambda (#{let*\ 12856}#
+ #{x\ 12857}#
+ #{v\ 12858}#
+ #{e1\ 12859}#
+ #{e2\ 12860}#)
+ (and-map identifier? #{x\ 12857}#))
+ #{tmp\ 12850}#)
#f)
- (apply (lambda (#{let*\ 1797}#
- #{x\ 1798}#
- #{v\ 1799}#
- #{e1\ 1800}#
- #{e2\ 1801}#)
- (letrec ((#{f\ 1802}#
- (lambda (#{bindings\ 1803}#)
- (if (null? #{bindings\ 1803}#)
+ (apply (lambda (#{let*\ 12867}#
+ #{x\ 12868}#
+ #{v\ 12869}#
+ #{e1\ 12870}#
+ #{e2\ 12871}#)
+ (letrec ((#{f\ 12874}#
+ (lambda (#{bindings\ 12875}#)
+ (if (null? #{bindings\ 12875}#)
(cons '#(syntax-object
let
((top)
@@ -11910,7 +12161,7 @@
#(ribcage
#(f bindings)
#((top) (top))
- #("i" "i"))
+ #("i12872" "i12873"))
#(ribcage
#(let* x v e1 e2)
#((top)
@@ -11918,21 +12169,25 @@
(top)
(top)
(top))
- #("i" "i" "i" "i" "i"))
+ #("i12862"
+ "i12863"
+ "i12864"
+ "i12865"
+ "i12866"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i12848")))
(hygiene guile))
(cons '()
- (cons #{e1\ 1800}#
- #{e2\ 1801}#)))
- ((lambda (#{tmp\ 1807}#)
- ((lambda (#{tmp\ 1808}#)
- (if #{tmp\ 1808}#
- (apply (lambda (#{body\
1809}#
- #{binding\
1810}#)
+ (cons #{e1\ 12870}#
+ #{e2\ 12871}#)))
+ ((lambda (#{tmp\ 12880}#)
+ ((lambda (#{tmp\ 12881}#)
+ (if #{tmp\ 12881}#
+ (apply (lambda (#{body\
12884}#
+ #{binding\
12885}#)
(list
'#(syntax-object
let
((top)
@@ -11941,8 +12196,8 @@
binding)
#((top)
(top))
- #("i"
-
"i"))
+
#("i12882"
+
"i12883"))
#(ribcage
()
()
@@ -11952,8 +12207,8 @@
bindings)
#((top)
(top))
- #("i"
-
"i"))
+
#("i12872"
+
"i12873"))
#(ribcage
#(let*
x
@@ -11965,11 +12220,11 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i"
-
"i"))
+
#("i12862"
+
"i12863"
+
"i12864"
+
"i12865"
+
"i12866"))
#(ribcage
()
()
@@ -11977,56 +12232,57 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i12848")))
(hygiene
guile))
- (list
#{binding\ 1810}#)
- #{body\
1809}#))
- #{tmp\ 1808}#)
+ (list
#{binding\ 12885}#)
+ #{body\
12884}#))
+ #{tmp\ 12881}#)
(syntax-violation
#f
"source expression
failed to match any pattern"
- #{tmp\ 1807}#)))
+ #{tmp\ 12880}#)))
($sc-dispatch
- #{tmp\ 1807}#
+ #{tmp\ 12880}#
'(any any))))
- (list (#{f\ 1802}#
- (cdr #{bindings\ 1803}#))
- (car #{bindings\
1803}#)))))))
- (#{f\ 1802}#
- (map list #{x\ 1798}# #{v\ 1799}#))))
- #{tmp\ 1790}#)
+ (list (#{f\ 12874}#
+ (cdr #{bindings\ 12875}#))
+ (car #{bindings\
12875}#)))))))
+ (#{f\ 12874}#
+ (map list #{x\ 12868}# #{v\ 12869}#))))
+ #{tmp\ 12850}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1789}#)))
+ #{tmp\ 12849}#)))
($sc-dispatch
- #{tmp\ 1789}#
+ #{tmp\ 12849}#
'(any #(each (any any)) any . each-any))))
- #{x\ 1788}#))
+ #{x\ 12847}#))
(module-name (current-module)))))
(define do
- (make-syncase-macro
+ (make-syntax-transformer
+ 'do
'macro
- (cons (lambda (#{orig-x\ 1811}#)
- ((lambda (#{tmp\ 1812}#)
- ((lambda (#{tmp\ 1813}#)
- (if #{tmp\ 1813}#
- (apply (lambda (#{_\ 1814}#
- #{var\ 1815}#
- #{init\ 1816}#
- #{step\ 1817}#
- #{e0\ 1818}#
- #{e1\ 1819}#
- #{c\ 1820}#)
- ((lambda (#{tmp\ 1821}#)
- ((lambda (#{tmp\ 1822}#)
- (if #{tmp\ 1822}#
- (apply (lambda (#{step\ 1823}#)
- ((lambda (#{tmp\ 1824}#)
- ((lambda (#{tmp\ 1825}#)
- (if #{tmp\ 1825}#
+ (cons (lambda (#{orig-x\ 12886}#)
+ ((lambda (#{tmp\ 12888}#)
+ ((lambda (#{tmp\ 12889}#)
+ (if #{tmp\ 12889}#
+ (apply (lambda (#{_\ 12897}#
+ #{var\ 12898}#
+ #{init\ 12899}#
+ #{step\ 12900}#
+ #{e0\ 12901}#
+ #{e1\ 12902}#
+ #{c\ 12903}#)
+ ((lambda (#{tmp\ 12905}#)
+ ((lambda (#{tmp\ 12906}#)
+ (if #{tmp\ 12906}#
+ (apply (lambda (#{step\ 12908}#)
+ ((lambda (#{tmp\ 12909}#)
+ ((lambda (#{tmp\ 12910}#)
+ (if #{tmp\ 12910}#
(apply (lambda ()
(list
'#(syntax-object
let
@@ -12034,7 +12290,7 @@
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12050,13 +12306,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12064,7 +12320,7 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
'#(syntax-object
@@ -12073,7 +12329,7 @@
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12089,13 +12345,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12103,19 +12359,19 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
(map list
-
#{var\ 1815}#
-
#{init\ 1816}#)
+
#{var\ 12898}#
+
#{init\ 12899}#)
(list
'#(syntax-object
if
((top)
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12131,13 +12387,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12145,7 +12401,7 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
(list '#(syntax-object
@@ -12154,7 +12410,7 @@
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12170,13 +12426,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12184,17 +12440,17 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
-
#{e0\ 1818}#)
+
#{e0\ 12901}#)
(cons '#(syntax-object
begin
((top)
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12210,13 +12466,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12224,18 +12480,18 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
(append
-
#{c\ 1820}#
+
#{c\ 12903}#
(list (cons '#(syntax-object
doloop
((top)
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12251,13 +12507,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12265,15 +12521,15 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
-
#{step\ 1823}#)))))))
- #{tmp\ 1825}#)
- ((lambda (#{tmp\ 1830}#)
- (if #{tmp\ 1830}#
- (apply (lambda
(#{e1\ 1831}#
-
#{e2\ 1832}#)
+
#{step\ 12908}#)))))))
+ #{tmp\ 12910}#)
+ ((lambda (#{tmp\ 12915}#)
+ (if #{tmp\ 12915}#
+ (apply (lambda
(#{e1\ 12918}#
+
#{e2\ 12919}#)
(list
'#(syntax-object
let
((top)
@@ -12282,12 +12538,12 @@
e2)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12916"
+
"i12917"))
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12303,13 +12559,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12317,7 +12573,7 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
'#(syntax-object
@@ -12328,12 +12584,12 @@
e2)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12916"
+
"i12917"))
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12349,13 +12605,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12363,12 +12619,12 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
(map
list
-
#{var\ 1815}#
-
#{init\ 1816}#)
+
#{var\ 12898}#
+
#{init\ 12899}#)
(list '#(syntax-object
if
((top)
@@ -12377,12 +12633,12 @@
e2)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12916"
+
"i12917"))
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12398,13 +12654,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12412,10 +12668,10 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
-
#{e0\ 1818}#
+
#{e0\ 12901}#
(cons '#(syntax-object
begin
((top)
@@ -12424,12 +12680,12 @@
e2)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12916"
+
"i12917"))
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12445,13 +12701,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12459,11 +12715,11 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
-
(cons #{e1\ 1831}#
-
#{e2\ 1832}#))
+
(cons #{e1\ 12918}#
+
#{e2\ 12919}#))
(cons '#(syntax-object
begin
((top)
@@ -12472,12 +12728,12 @@
e2)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12916"
+
"i12917"))
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12493,13 +12749,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12507,11 +12763,11 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
(append
-
#{c\ 1820}#
+
#{c\ 12903}#
(list (cons '#(syntax-object
doloop
((top)
@@ -12520,12 +12776,12 @@
e2)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12916"
+
"i12917"))
#(ribcage
#(step)
#((top))
-
#("i"))
+
#("i12907"))
#(ribcage
#(_
var
@@ -12541,13 +12797,13 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"
-
"i"))
+
#("i12890"
+
"i12891"
+
"i12892"
+
"i12893"
+
"i12894"
+
"i12895"
+
"i12896"))
#(ribcage
()
()
@@ -12555,106 +12811,107 @@
#(ribcage
#(orig-x)
#((top))
-
#("i")))
+
#("i12887")))
(hygiene
guile))
-
#{step\ 1823}#)))))))
- #{tmp\
1830}#)
+
#{step\ 12908}#)))))))
+ #{tmp\
12915}#)
(syntax-violation
#f
"source
expression failed to match any pattern"
- #{tmp\ 1824}#)))
+ #{tmp\ 12909}#)))
($sc-dispatch
- #{tmp\ 1824}#
+ #{tmp\ 12909}#
'(any . each-any)))))
($sc-dispatch
- #{tmp\ 1824}#
+ #{tmp\ 12909}#
'())))
- #{e1\ 1819}#))
- #{tmp\ 1822}#)
+ #{e1\ 12902}#))
+ #{tmp\ 12906}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 1821}#)))
+ #{tmp\ 12905}#)))
($sc-dispatch
- #{tmp\ 1821}#
+ #{tmp\ 12905}#
'each-any)))
- (map (lambda (#{v\ 1839}# #{s\ 1840}#)
- ((lambda (#{tmp\ 1841}#)
- ((lambda (#{tmp\ 1842}#)
- (if #{tmp\ 1842}#
- (apply (lambda () #{v\ 1839}#)
- #{tmp\ 1842}#)
- ((lambda (#{tmp\ 1843}#)
- (if #{tmp\ 1843}#
- (apply (lambda (#{e\ 1844}#)
- #{e\ 1844}#)
- #{tmp\ 1843}#)
- ((lambda (#{_\ 1845}#)
+ (map (lambda (#{v\ 12926}# #{s\ 12927}#)
+ ((lambda (#{tmp\ 12930}#)
+ ((lambda (#{tmp\ 12931}#)
+ (if #{tmp\ 12931}#
+ (apply (lambda () #{v\ 12926}#)
+ #{tmp\ 12931}#)
+ ((lambda (#{tmp\ 12932}#)
+ (if #{tmp\ 12932}#
+ (apply (lambda (#{e\ 12934}#)
+ #{e\ 12934}#)
+ #{tmp\ 12932}#)
+ ((lambda (#{_\ 12936}#)
(syntax-violation
'do
"bad step expression"
- #{orig-x\ 1811}#
- #{s\ 1840}#))
- #{tmp\ 1841}#)))
+ #{orig-x\ 12886}#
+ #{s\ 12927}#))
+ #{tmp\ 12930}#)))
($sc-dispatch
- #{tmp\ 1841}#
+ #{tmp\ 12930}#
'(any)))))
($sc-dispatch
- #{tmp\ 1841}#
+ #{tmp\ 12930}#
'())))
- #{s\ 1840}#))
- #{var\ 1815}#
- #{step\ 1817}#)))
- #{tmp\ 1813}#)
+ #{s\ 12927}#))
+ #{var\ 12898}#
+ #{step\ 12900}#)))
+ #{tmp\ 12889}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1812}#)))
+ #{tmp\ 12888}#)))
($sc-dispatch
- #{tmp\ 1812}#
+ #{tmp\ 12888}#
'(any #(each (any any . any))
(any . each-any)
.
each-any))))
- #{orig-x\ 1811}#))
+ #{orig-x\ 12886}#))
(module-name (current-module)))))
(define quasiquote
- (make-syncase-macro
+ (make-syntax-transformer
+ 'quasiquote
'macro
- (cons (letrec ((#{quasicons\ 1848}#
- (lambda (#{x\ 1852}# #{y\ 1853}#)
- ((lambda (#{tmp\ 1854}#)
- ((lambda (#{tmp\ 1855}#)
- (if #{tmp\ 1855}#
- (apply (lambda (#{x\ 1856}# #{y\ 1857}#)
- ((lambda (#{tmp\ 1858}#)
- ((lambda (#{tmp\ 1859}#)
- (if #{tmp\ 1859}#
- (apply (lambda (#{dy\ 1860}#)
- ((lambda (#{tmp\
1861}#)
- ((lambda (#{tmp\
1862}#)
- (if #{tmp\
1862}#
- (apply
(lambda (#{dx\ 1863}#)
+ (cons (letrec ((#{quasicons\ 12943}#
+ (lambda (#{x\ 12947}# #{y\ 12948}#)
+ ((lambda (#{tmp\ 12952}#)
+ ((lambda (#{tmp\ 12953}#)
+ (if #{tmp\ 12953}#
+ (apply (lambda (#{x\ 12956}# #{y\ 12957}#)
+ ((lambda (#{tmp\ 12958}#)
+ ((lambda (#{tmp\ 12959}#)
+ (if #{tmp\ 12959}#
+ (apply (lambda (#{dy\ 12961}#)
+ ((lambda (#{tmp\
12962}#)
+ ((lambda (#{tmp\
12963}#)
+ (if #{tmp\
12963}#
+ (apply
(lambda (#{dx\ 12965}#)
(list '#(syntax-object
quote
((top)
#(ribcage
#(dx)
#((top))
-
#("i"))
+
#("i12964"))
#(ribcage
#(dy)
#((top))
-
#("i"))
+
#("i12960"))
#(ribcage
#(x
y)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12954"
+
"i12955"))
#(ribcage
()
()
@@ -12668,8 +12925,8 @@
y)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12949"
+
"i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12679,35 +12936,35 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i")))
+
#("i12939"
+
"i12940"
+
"i12941"
+
"i12942")))
(hygiene
guile))
-
(cons #{dx\ 1863}#
-
#{dy\ 1860}#)))
- #{tmp\
1862}#)
- ((lambda
(#{_\ 1864}#)
- (if (null?
#{dy\ 1860}#)
+
(cons #{dx\ 12965}#
+
#{dy\ 12961}#)))
+ #{tmp\
12963}#)
+ ((lambda
(#{_\ 12967}#)
+ (if (null?
#{dy\ 12961}#)
(list
'#(syntax-object
list
((top)
#(ribcage
#(_)
#((top))
-
#("i"))
+
#("i12966"))
#(ribcage
#(dy)
#((top))
-
#("i"))
+
#("i12960"))
#(ribcage
#(x
y)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12954"
+
"i12955"))
#(ribcage
()
()
@@ -12721,8 +12978,8 @@
y)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12949"
+
"i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12732,31 +12989,31 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i")))
+
#("i12939"
+
"i12940"
+
"i12941"
+
"i12942")))
(hygiene
guile))
-
#{x\ 1856}#)
+
#{x\ 12956}#)
(list
'#(syntax-object
cons
((top)
#(ribcage
#(_)
#((top))
-
#("i"))
+
#("i12966"))
#(ribcage
#(dy)
#((top))
-
#("i"))
+
#("i12960"))
#(ribcage
#(x
y)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12954"
+
"i12955"))
#(ribcage
()
()
@@ -12770,8 +13027,8 @@
y)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i12949"
+
"i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12781,17 +13038,17 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i")))
+
#("i12939"
+
"i12940"
+
"i12941"
+
"i12942")))
(hygiene
guile))
-
#{x\ 1856}#
-
#{y\ 1857}#)))
- #{tmp\
1861}#)))
+
#{x\ 12956}#
+
#{y\ 12957}#)))
+ #{tmp\
12962}#)))
($sc-dispatch
- #{tmp\ 1861}#
+ #{tmp\ 12962}#
'(#(free-id
#(syntax-object
quote
@@ -12799,13 +13056,13 @@
#(ribcage
#(dy)
#((top))
- #("i"))
+
#("i12960"))
#(ribcage
#(x y)
#((top)
(top))
- #("i"
- "i"))
+
#("i12954"
+
"i12955"))
#(ribcage
()
()
@@ -12818,8 +13075,8 @@
#(x y)
#((top)
(top))
- #("i"
- "i"))
+
#("i12949"
+
"i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12829,32 +13086,32 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
-
"i")))
+
#("i12939"
+
"i12940"
+
"i12941"
+
"i12942")))
(hygiene
guile)))
any))))
- #{x\ 1856}#))
- #{tmp\ 1859}#)
- ((lambda (#{tmp\ 1865}#)
- (if #{tmp\ 1865}#
- (apply (lambda (#{stuff\
1866}#)
+ #{x\ 12956}#))
+ #{tmp\ 12959}#)
+ ((lambda (#{tmp\ 12968}#)
+ (if #{tmp\ 12968}#
+ (apply (lambda (#{stuff\
12970}#)
(cons
'#(syntax-object
list
((top)
#(ribcage
#(stuff)
#((top))
-
#("i"))
+
#("i12969"))
#(ribcage
#(x
y)
#((top)
(top))
- #("i"
-
"i"))
+
#("i12954"
+
"i12955"))
#(ribcage
()
()
@@ -12868,8 +13125,8 @@
y)
#((top)
(top))
- #("i"
-
"i"))
+
#("i12949"
+
"i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12879,28 +13136,29 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
-
"i")))
+
#("i12939"
+
"i12940"
+
"i12941"
+
"i12942")))
(hygiene
guile))
- (cons #{x\
1856}#
-
#{stuff\ 1866}#)))
- #{tmp\ 1865}#)
- ((lambda (#{else\ 1867}#)
+ (cons #{x\
12956}#
+
#{stuff\ 12970}#)))
+ #{tmp\ 12968}#)
+ ((lambda (#{else\ 12972}#)
(list '#(syntax-object
cons
((top)
#(ribcage
#(else)
#((top))
- #("i"))
+
#("i12971"))
#(ribcage
#(x y)
#((top)
(top))
- #("i" "i"))
+ #("i12954"
+
"i12955"))
#(ribcage
()
()
@@ -12913,7 +13171,8 @@
#(x y)
#((top)
(top))
- #("i" "i"))
+ #("i12949"
+
"i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12923,17 +13182,17 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+
"i12942")))
(hygiene
guile))
- #{x\ 1856}#
- #{y\ 1857}#))
- #{tmp\ 1858}#)))
+ #{x\ 12956}#
+ #{y\ 12957}#))
+ #{tmp\ 12958}#)))
($sc-dispatch
- #{tmp\ 1858}#
+ #{tmp\ 12958}#
'(#(free-id
#(syntax-object
list
@@ -12941,13 +13200,15 @@
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12954"
+ "i12955"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12949"
+ "i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12957,15 +13218,15 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
.
any)))))
($sc-dispatch
- #{tmp\ 1858}#
+ #{tmp\ 12958}#
'(#(free-id
#(syntax-object
quote
@@ -12973,13 +13234,13 @@
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12954" "i12955"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12949" "i12950"))
#(ribcage
#(quasicons
quasiappend
@@ -12989,40 +13250,44 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
any))))
- #{y\ 1857}#))
- #{tmp\ 1855}#)
+ #{y\ 12957}#))
+ #{tmp\ 12953}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 1854}#)))
- ($sc-dispatch #{tmp\ 1854}# (quote (any any)))))
- (list #{x\ 1852}# #{y\ 1853}#))))
- (#{quasiappend\ 1849}#
- (lambda (#{x\ 1868}# #{y\ 1869}#)
- ((lambda (#{tmp\ 1870}#)
- ((lambda (#{tmp\ 1871}#)
- (if #{tmp\ 1871}#
- (apply (lambda (#{x\ 1872}# #{y\ 1873}#)
- ((lambda (#{tmp\ 1874}#)
- ((lambda (#{tmp\ 1875}#)
- (if #{tmp\ 1875}#
- (apply (lambda () #{x\ 1872}#)
- #{tmp\ 1875}#)
- ((lambda (#{_\ 1876}#)
+ #{tmp\ 12952}#)))
+ ($sc-dispatch #{tmp\ 12952}# (quote (any any)))))
+ (list #{x\ 12947}# #{y\ 12948}#))))
+ (#{quasiappend\ 12944}#
+ (lambda (#{x\ 12973}# #{y\ 12974}#)
+ ((lambda (#{tmp\ 12978}#)
+ ((lambda (#{tmp\ 12979}#)
+ (if #{tmp\ 12979}#
+ (apply (lambda (#{x\ 12982}# #{y\ 12983}#)
+ ((lambda (#{tmp\ 12984}#)
+ ((lambda (#{tmp\ 12985}#)
+ (if #{tmp\ 12985}#
+ (apply (lambda () #{x\ 12982}#)
+ #{tmp\ 12985}#)
+ ((lambda (#{_\ 12987}#)
(list '#(syntax-object
append
((top)
#(ribcage
#(_)
#((top))
- #("i"))
+ #("i12986"))
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12980"
+ "i12981"))
#(ribcage
()
()
@@ -13034,7 +13299,8 @@
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12975"
+ "i12976"))
#(ribcage
#(quasicons
quasiappend
@@ -13044,16 +13310,16 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
- #{x\ 1872}#
- #{y\ 1873}#))
- #{tmp\ 1874}#)))
+ #{x\ 12982}#
+ #{y\ 12983}#))
+ #{tmp\ 12984}#)))
($sc-dispatch
- #{tmp\ 1874}#
+ #{tmp\ 12984}#
'(#(free-id
#(syntax-object
quote
@@ -13061,13 +13327,13 @@
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12980" "i12981"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i" "i"))
+ #("i12975" "i12976"))
#(ribcage
#(quasicons
quasiappend
@@ -13077,42 +13343,45 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
()))))
- #{y\ 1873}#))
- #{tmp\ 1871}#)
+ #{y\ 12983}#))
+ #{tmp\ 12979}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 1870}#)))
- ($sc-dispatch #{tmp\ 1870}# (quote (any any)))))
- (list #{x\ 1868}# #{y\ 1869}#))))
- (#{quasivector\ 1850}#
- (lambda (#{x\ 1877}#)
- ((lambda (#{tmp\ 1878}#)
- ((lambda (#{x\ 1879}#)
- ((lambda (#{tmp\ 1880}#)
- ((lambda (#{tmp\ 1881}#)
- (if #{tmp\ 1881}#
- (apply (lambda (#{x\ 1882}#)
+ #{tmp\ 12978}#)))
+ ($sc-dispatch #{tmp\ 12978}# (quote (any any)))))
+ (list #{x\ 12973}# #{y\ 12974}#))))
+ (#{quasivector\ 12945}#
+ (lambda (#{x\ 12988}#)
+ ((lambda (#{tmp\ 12991}#)
+ ((lambda (#{x\ 12993}#)
+ ((lambda (#{tmp\ 12994}#)
+ ((lambda (#{tmp\ 12995}#)
+ (if #{tmp\ 12995}#
+ (apply (lambda (#{x\ 12997}#)
(list '#(syntax-object
quote
((top)
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12996"))
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12992"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12989"))
#(ribcage
#(quasicons
quasiappend
@@ -13122,25 +13391,28 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
(list->vector
- #{x\ 1882}#)))
- #{tmp\ 1881}#)
- ((lambda (#{tmp\ 1884}#)
- (if #{tmp\ 1884}#
- (apply (lambda (#{x\ 1885}#)
+ #{x\ 12997}#)))
+ #{tmp\ 12995}#)
+ ((lambda (#{tmp\ 12999}#)
+ (if #{tmp\ 12999}#
+ (apply (lambda (#{x\ 13001}#)
(cons '#(syntax-object
vector
((top)
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i13000"))
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12992"))
#(ribcage
()
()
@@ -13152,7 +13424,7 @@
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12989"))
#(ribcage
#(quasicons
quasiappend
@@ -13162,31 +13434,31 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
- #{x\ 1885}#))
- #{tmp\ 1884}#)
- ((lambda (#{_\ 1887}#)
+ #{x\ 13001}#))
+ #{tmp\ 12999}#)
+ ((lambda (#{_\ 13004}#)
(list '#(syntax-object
list->vector
((top)
#(ribcage
#(_)
#((top))
- #("i"))
+ #("i13003"))
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12992"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i"))
+ #("i12989"))
#(ribcage
#(quasicons
quasiappend
@@ -13196,80 +13468,98 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
- #{x\ 1879}#))
- #{tmp\ 1880}#)))
+ #{x\ 12993}#))
+ #{tmp\ 12994}#)))
($sc-dispatch
- #{tmp\ 1880}#
+ #{tmp\ 12994}#
'(#(free-id
#(syntax-object
list
((top)
- #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i12992"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i12989"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
.
each-any)))))
($sc-dispatch
- #{tmp\ 1880}#
+ #{tmp\ 12994}#
'(#(free-id
#(syntax-object
quote
((top)
- #(ribcage #(x) #((top)) #("i"))
+ #(ribcage #(x) #((top)) #("i12992"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
+ #(ribcage #(x) #((top)) #("i12989"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
each-any))))
- #{x\ 1879}#))
- #{tmp\ 1878}#))
- #{x\ 1877}#)))
- (#{quasi\ 1851}#
- (lambda (#{p\ 1888}# #{lev\ 1889}#)
- ((lambda (#{tmp\ 1890}#)
- ((lambda (#{tmp\ 1891}#)
- (if #{tmp\ 1891}#
- (apply (lambda (#{p\ 1892}#)
- (if (= #{lev\ 1889}# 0)
- #{p\ 1892}#
- (#{quasicons\ 1848}#
+ #{x\ 12993}#))
+ #{tmp\ 12991}#))
+ #{x\ 12988}#)))
+ (#{quasi\ 12946}#
+ (lambda (#{p\ 13005}# #{lev\ 13006}#)
+ ((lambda (#{tmp\ 13009}#)
+ ((lambda (#{tmp\ 13010}#)
+ (if #{tmp\ 13010}#
+ (apply (lambda (#{p\ 13012}#)
+ (if (= #{lev\ 13006}# 0)
+ #{p\ 13012}#
+ (#{quasicons\ 12943}#
'(#(syntax-object
quote
((top)
#(ribcage
#(p)
#((top))
- #("i"))
+ #("i13011"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
#(syntax-object
unquote
@@ -13277,47 +13567,51 @@
#(ribcage
#(p)
#((top))
- #("i"))
+ #("i13011"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
- (#{quasi\ 1851}#
- (list #{p\ 1892}#)
- (- #{lev\ 1889}# 1)))))
- #{tmp\ 1891}#)
- ((lambda (#{tmp\ 1893}#)
- (if (if #{tmp\ 1893}#
- (apply (lambda (#{args\ 1894}#)
- (= #{lev\ 1889}# 0))
- #{tmp\ 1893}#)
+ (#{quasi\ 12946}#
+ (list #{p\ 13012}#)
+ (- #{lev\ 13006}# 1)))))
+ #{tmp\ 13010}#)
+ ((lambda (#{tmp\ 13013}#)
+ (if (if #{tmp\ 13013}#
+ (apply (lambda (#{args\ 13015}#)
+ (= #{lev\ 13006}# 0))
+ #{tmp\ 13013}#)
#f)
- (apply (lambda (#{args\ 1895}#)
+ (apply (lambda (#{args\ 13017}#)
(syntax-violation
'unquote
"unquote takes exactly one
argument"
- #{p\ 1888}#
+ #{p\ 13005}#
(cons '#(syntax-object
unquote
((top)
#(ribcage
#(args)
#((top))
- #("i"))
+ #("i13016"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007"
+ "i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13327,29 +13621,33 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
- #{args\ 1895}#)))
- #{tmp\ 1893}#)
- ((lambda (#{tmp\ 1896}#)
- (if #{tmp\ 1896}#
- (apply (lambda (#{p\ 1897}#
- #{q\ 1898}#)
- (if (= #{lev\ 1889}# 0)
- (#{quasiappend\ 1849}#
- #{p\ 1897}#
- (#{quasi\ 1851}#
- #{q\ 1898}#
- #{lev\ 1889}#))
- (#{quasicons\ 1848}#
- (#{quasicons\ 1848}#
+ #{args\ 13017}#)))
+ #{tmp\ 13013}#)
+ ((lambda (#{tmp\ 13018}#)
+ (if #{tmp\ 13018}#
+ (apply (lambda (#{p\ 13021}#
+ #{q\ 13022}#)
+ (if (= #{lev\ 13006}# 0)
+ (#{quasiappend\ 12944}#
+ #{p\ 13021}#
+ (#{quasi\ 12946}#
+ #{q\ 13022}#
+ #{lev\ 13006}#))
+ (#{quasicons\ 12943}#
+ (#{quasicons\ 12943}#
'(#(syntax-object
quote
((top)
#(ribcage
#(p q)
#((top) (top))
- #("i" "i"))
+ #("i13019"
+ "i13020"))
#(ribcage
()
()
@@ -13357,7 +13655,8 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007"
+ "i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13367,10 +13666,10 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile))
#(syntax-object
unquote-splicing
@@ -13378,7 +13677,8 @@
#(ribcage
#(p q)
#((top) (top))
- #("i" "i"))
+ #("i13019"
+ "i13020"))
#(ribcage
()
()
@@ -13386,7 +13686,8 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007"
+ "i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13396,31 +13697,33 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
- (#{quasi\ 1851}#
- (list #{p\ 1897}#)
- (- #{lev\ 1889}# 1)))
- (#{quasi\ 1851}#
- #{q\ 1898}#
- #{lev\ 1889}#))))
- #{tmp\ 1896}#)
- ((lambda (#{tmp\ 1899}#)
- (if (if #{tmp\ 1899}#
- (apply (lambda (#{args\
1900}#
- #{q\ 1901}#)
- (= #{lev\ 1889}# 0))
- #{tmp\ 1899}#)
+ (#{quasi\ 12946}#
+ (list #{p\ 13021}#)
+ (- #{lev\ 13006}#
+ 1)))
+ (#{quasi\ 12946}#
+ #{q\ 13022}#
+ #{lev\ 13006}#))))
+ #{tmp\ 13018}#)
+ ((lambda (#{tmp\ 13023}#)
+ (if (if #{tmp\ 13023}#
+ (apply (lambda (#{args\
13026}#
+ #{q\ 13027}#)
+ (= #{lev\ 13006}#
+ 0))
+ #{tmp\ 13023}#)
#f)
- (apply (lambda (#{args\ 1902}#
- #{q\ 1903}#)
+ (apply (lambda (#{args\ 13030}#
+ #{q\ 13031}#)
(syntax-violation
'unquote-splicing
"unquote-splicing
takes exactly one argument"
- #{p\ 1888}#
+ #{p\ 13005}#
(cons '#(syntax-object
unquote-splicing
((top)
@@ -13428,8 +13731,8 @@
#(args q)
#((top)
(top))
- #("i"
- "i"))
+ #("i13028"
+
"i13029"))
#(ribcage
()
()
@@ -13438,8 +13741,8 @@
#(p lev)
#((top)
(top))
- #("i"
- "i"))
+ #("i13007"
+
"i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13449,25 +13752,25 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+
"i12942")))
(hygiene
guile))
- #{args\
1902}#)))
- #{tmp\ 1899}#)
- ((lambda (#{tmp\ 1904}#)
- (if #{tmp\ 1904}#
- (apply (lambda (#{p\ 1905}#)
- (#{quasicons\
1848}#
+ #{args\
13030}#)))
+ #{tmp\ 13023}#)
+ ((lambda (#{tmp\ 13032}#)
+ (if #{tmp\ 13032}#
+ (apply (lambda (#{p\
13034}#)
+ (#{quasicons\
12943}#
'(#(syntax-object
quote
((top)
#(ribcage
#(p)
#((top))
- #("i"))
+
#("i13033"))
#(ribcage
()
()
@@ -13476,8 +13779,8 @@
#(p lev)
#((top)
(top))
- #("i"
- "i"))
+ #("i13007"
+
"i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13487,10 +13790,10 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+
"i12942")))
(hygiene
guile))
#(syntax-object
@@ -13499,7 +13802,7 @@
#(ribcage
#(p)
#((top))
- #("i"))
+
#("i13033"))
#(ribcage
()
()
@@ -13508,8 +13811,8 @@
#(p lev)
#((top)
(top))
- #("i"
- "i"))
+ #("i13007"
+
"i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13519,45 +13822,45 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
- "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+
"i12942")))
(hygiene
guile)))
- (#{quasi\ 1851}#
- (list #{p\
1905}#)
- (+ #{lev\
1889}#
+ (#{quasi\ 12946}#
+ (list #{p\
13034}#)
+ (+ #{lev\
13006}#
1))))
- #{tmp\ 1904}#)
- ((lambda (#{tmp\ 1906}#)
- (if #{tmp\ 1906}#
- (apply (lambda (#{p\
1907}#
- #{q\
1908}#)
- (#{quasicons\
1848}#
- (#{quasi\
1851}#
- #{p\
1907}#
- #{lev\
1889}#)
- (#{quasi\
1851}#
- #{q\
1908}#
- #{lev\
1889}#)))
- #{tmp\ 1906}#)
- ((lambda (#{tmp\
1909}#)
- (if #{tmp\ 1909}#
- (apply (lambda
(#{x\ 1910}#)
-
(#{quasivector\ 1850}#
-
(#{quasi\ 1851}#
- #{x\
1910}#
-
#{lev\ 1889}#)))
- #{tmp\
1909}#)
- ((lambda (#{p\
1912}#)
+ #{tmp\ 13032}#)
+ ((lambda (#{tmp\ 13035}#)
+ (if #{tmp\ 13035}#
+ (apply (lambda (#{p\
13038}#
+ #{q\
13039}#)
+ (#{quasicons\
12943}#
+ (#{quasi\
12946}#
+ #{p\
13038}#
+ #{lev\
13006}#)
+ (#{quasi\
12946}#
+ #{q\
13039}#
+ #{lev\
13006}#)))
+ #{tmp\ 13035}#)
+ ((lambda (#{tmp\
13040}#)
+ (if #{tmp\ 13040}#
+ (apply (lambda
(#{x\ 13042}#)
+
(#{quasivector\ 12945}#
+
(#{quasi\ 12946}#
+ #{x\
13042}#
+
#{lev\ 13006}#)))
+ #{tmp\
13040}#)
+ ((lambda (#{p\
13045}#)
(list
'#(syntax-object
quote
((top)
#(ribcage
#(p)
#((top))
-
#("i"))
+
#("i13044"))
#(ribcage
()
()
@@ -13567,8 +13870,8 @@
lev)
#((top)
(top))
-
#("i"
-
"i"))
+
#("i13007"
+
"i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13578,23 +13881,23 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i")))
+
#("i12939"
+
"i12940"
+
"i12941"
+
"i12942")))
(hygiene
guile))
- #{p\
1912}#))
- #{tmp\ 1890}#)))
+ #{p\
13045}#))
+ #{tmp\ 13009}#)))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'#(vector
each-any)))))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'(#(free-id
#(syntax-object
quasiquote
@@ -13603,7 +13906,7 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13613,11 +13916,14 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
any)))))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -13626,7 +13932,7 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
@@ -13636,14 +13942,17 @@
(top)
(top)
(top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
.
any)
.
any)))))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -13652,20 +13961,23 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
any)
.
any)))))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'(#(free-id
#(syntax-object
unquote
@@ -13674,19 +13986,22 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939"
+ "i12940"
+ "i12941"
+ "i12942")))
(hygiene guile)))
.
any)))))
($sc-dispatch
- #{tmp\ 1890}#
+ #{tmp\ 13009}#
'(#(free-id
#(syntax-object
unquote
@@ -13695,219 +14010,244 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i" "i"))
+ #("i13007" "i13008"))
#(ribcage
#(quasicons
quasiappend
quasivector
quasi)
#((top) (top) (top) (top))
- #("i" "i" "i" "i")))
+ #("i12939" "i12940" "i12941" "i12942")))
(hygiene guile)))
any))))
- #{p\ 1888}#))))
- (lambda (#{x\ 1913}#)
- ((lambda (#{tmp\ 1914}#)
- ((lambda (#{tmp\ 1915}#)
- (if #{tmp\ 1915}#
- (apply (lambda (#{_\ 1916}# #{e\ 1917}#)
- (#{quasi\ 1851}# #{e\ 1917}# 0))
- #{tmp\ 1915}#)
+ #{p\ 13005}#))))
+ (lambda (#{x\ 13046}#)
+ ((lambda (#{tmp\ 13048}#)
+ ((lambda (#{tmp\ 13049}#)
+ (if #{tmp\ 13049}#
+ (apply (lambda (#{_\ 13052}# #{e\ 13053}#)
+ (#{quasi\ 12946}# #{e\ 13053}# 0))
+ #{tmp\ 13049}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1914}#)))
- ($sc-dispatch #{tmp\ 1914}# (quote (any any)))))
- #{x\ 1913}#)))
+ #{tmp\ 13048}#)))
+ ($sc-dispatch #{tmp\ 13048}# (quote (any any)))))
+ #{x\ 13046}#)))
(module-name (current-module)))))
(define include
- (make-syncase-macro
+ (make-syntax-transformer
+ 'include
'macro
- (cons (lambda (#{x\ 1918}#)
- (letrec ((#{read-file\ 1919}#
- (lambda (#{fn\ 1920}# #{k\ 1921}#)
- (let ((#{p\ 1922}# (open-input-file #{fn\ 1920}#)))
- (letrec ((#{f\ 1923}#
- (lambda (#{x\ 1924}#)
- (if (eof-object? #{x\ 1924}#)
+ (cons (lambda (#{x\ 13054}#)
+ (letrec ((#{read-file\ 13057}#
+ (lambda (#{fn\ 13058}# #{k\ 13059}#)
+ (let ((#{p\ 13063}# (open-input-file #{fn\ 13058}#)))
+ (letrec ((#{f\ 13067}#
+ (lambda (#{x\ 13068}# #{result\ 13069}#)
+ (if (eof-object? #{x\ 13068}#)
(begin
- (close-input-port #{p\ 1922}#)
- '())
- (cons (datum->syntax
- #{k\ 1921}#
- #{x\ 1924}#)
- (#{f\ 1923}#
- (read #{p\ 1922}#)))))))
- (#{f\ 1923}# (read #{p\ 1922}#)))))))
- ((lambda (#{tmp\ 1925}#)
- ((lambda (#{tmp\ 1926}#)
- (if #{tmp\ 1926}#
- (apply (lambda (#{k\ 1927}# #{filename\ 1928}#)
- (let ((#{fn\ 1929}#
- (syntax->datum #{filename\ 1928}#)))
- ((lambda (#{tmp\ 1930}#)
- ((lambda (#{tmp\ 1931}#)
- (if #{tmp\ 1931}#
- (apply (lambda (#{exp\ 1932}#)
+ (close-input-port #{p\ 13063}#)
+ (reverse #{result\ 13069}#))
+ (#{f\ 13067}#
+ (read #{p\ 13063}#)
+ (cons (datum->syntax
+ #{k\ 13059}#
+ #{x\ 13068}#)
+ #{result\ 13069}#))))))
+ (#{f\ 13067}# (read #{p\ 13063}#) (quote ())))))))
+ ((lambda (#{tmp\ 13070}#)
+ ((lambda (#{tmp\ 13071}#)
+ (if #{tmp\ 13071}#
+ (apply (lambda (#{k\ 13074}# #{filename\ 13075}#)
+ (let ((#{fn\ 13077}#
+ (syntax->datum #{filename\ 13075}#)))
+ ((lambda (#{tmp\ 13079}#)
+ ((lambda (#{tmp\ 13080}#)
+ (if #{tmp\ 13080}#
+ (apply (lambda (#{exp\ 13082}#)
(cons '#(syntax-object
begin
((top)
#(ribcage
#(exp)
#((top))
- #("i"))
+ #("i13081"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(fn)
#((top))
- #("i"))
+ #("i13076"))
#(ribcage
#(k filename)
#((top) (top))
- #("i" "i"))
+ #("i13072"
+ "i13073"))
#(ribcage
(read-file)
((top))
- ("i"))
+ ("i13056"))
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13055")))
(hygiene guile))
- #{exp\ 1932}#))
- #{tmp\ 1931}#)
+ #{exp\ 13082}#))
+ #{tmp\ 13080}#)
(syntax-violation
#f
"source expression failed to match
any pattern"
- #{tmp\ 1930}#)))
+ #{tmp\ 13079}#)))
($sc-dispatch
- #{tmp\ 1930}#
+ #{tmp\ 13079}#
'each-any)))
- (#{read-file\ 1919}#
- #{fn\ 1929}#
- #{k\ 1927}#))))
- #{tmp\ 1926}#)
+ (#{read-file\ 13057}#
+ #{fn\ 13077}#
+ #{k\ 13074}#))))
+ #{tmp\ 13071}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1925}#)))
- ($sc-dispatch #{tmp\ 1925}# (quote (any any)))))
- #{x\ 1918}#)))
+ #{tmp\ 13070}#)))
+ ($sc-dispatch #{tmp\ 13070}# (quote (any any)))))
+ #{x\ 13054}#)))
(module-name (current-module)))))
(define include-from-path
- (make-syncase-macro
+ (make-syntax-transformer
+ 'include-from-path
'macro
- (cons (lambda (#{x\ 1934}#)
- ((lambda (#{tmp\ 1935}#)
- ((lambda (#{tmp\ 1936}#)
- (if #{tmp\ 1936}#
- (apply (lambda (#{k\ 1937}# #{filename\ 1938}#)
- (let ((#{fn\ 1939}#
- (syntax->datum #{filename\ 1938}#)))
- ((lambda (#{tmp\ 1940}#)
- ((lambda (#{fn\ 1941}#)
+ (cons (lambda (#{x\ 13084}#)
+ ((lambda (#{tmp\ 13086}#)
+ ((lambda (#{tmp\ 13087}#)
+ (if #{tmp\ 13087}#
+ (apply (lambda (#{k\ 13090}# #{filename\ 13091}#)
+ (let ((#{fn\ 13093}#
+ (syntax->datum #{filename\ 13091}#)))
+ ((lambda (#{tmp\ 13095}#)
+ ((lambda (#{fn\ 13097}#)
(list '#(syntax-object
include
((top)
- #(ribcage #(fn) #((top)) #("i"))
+ #(ribcage
+ #(fn)
+ #((top))
+ #("i13096"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("i"))
+ #(ribcage
+ #(fn)
+ #((top))
+ #("i13092"))
#(ribcage
#(k filename)
#((top) (top))
- #("i" "i"))
+ #("i13088" "i13089"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i13085")))
(hygiene guile))
- #{fn\ 1941}#))
- #{tmp\ 1940}#))
- (let ((#{t\ 1942}#
- (%search-load-path #{fn\ 1939}#)))
- (if #{t\ 1942}#
- #{t\ 1942}#
+ #{fn\ 13097}#))
+ #{tmp\ 13095}#))
+ (let ((#{t\ 13100}#
+ (%search-load-path #{fn\ 13093}#)))
+ (if #{t\ 13100}#
+ #{t\ 13100}#
(syntax-violation
'include-from-path
"file not found in path"
- #{x\ 1934}#
- #{filename\ 1938}#))))))
- #{tmp\ 1936}#)
+ #{x\ 13084}#
+ #{filename\ 13091}#))))))
+ #{tmp\ 13087}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1935}#)))
- ($sc-dispatch #{tmp\ 1935}# (quote (any any)))))
- #{x\ 1934}#))
+ #{tmp\ 13086}#)))
+ ($sc-dispatch #{tmp\ 13086}# (quote (any any)))))
+ #{x\ 13084}#))
(module-name (current-module)))))
(define unquote
- (make-syncase-macro
+ (make-syntax-transformer
+ 'unquote
'macro
- (cons (lambda (#{x\ 1943}#)
- ((lambda (#{tmp\ 1944}#)
- ((lambda (#{tmp\ 1945}#)
- (if #{tmp\ 1945}#
- (apply (lambda (#{_\ 1946}# #{e\ 1947}#)
+ (cons (lambda (#{x\ 13102}#)
+ ((lambda (#{tmp\ 13104}#)
+ ((lambda (#{tmp\ 13105}#)
+ (if #{tmp\ 13105}#
+ (apply (lambda (#{_\ 13108}# #{e\ 13109}#)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- #{x\ 1943}#))
- #{tmp\ 1945}#)
+ #{x\ 13102}#))
+ #{tmp\ 13105}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1944}#)))
- ($sc-dispatch #{tmp\ 1944}# (quote (any any)))))
- #{x\ 1943}#))
+ #{tmp\ 13104}#)))
+ ($sc-dispatch #{tmp\ 13104}# (quote (any any)))))
+ #{x\ 13102}#))
(module-name (current-module)))))
(define unquote-splicing
- (make-syncase-macro
+ (make-syntax-transformer
+ 'unquote-splicing
'macro
- (cons (lambda (#{x\ 1948}#)
- ((lambda (#{tmp\ 1949}#)
- ((lambda (#{tmp\ 1950}#)
- (if #{tmp\ 1950}#
- (apply (lambda (#{_\ 1951}# #{e\ 1952}#)
+ (cons (lambda (#{x\ 13110}#)
+ ((lambda (#{tmp\ 13112}#)
+ ((lambda (#{tmp\ 13113}#)
+ (if #{tmp\ 13113}#
+ (apply (lambda (#{_\ 13116}# #{e\ 13117}#)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- #{x\ 1948}#))
- #{tmp\ 1950}#)
+ #{x\ 13110}#))
+ #{tmp\ 13113}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1949}#)))
- ($sc-dispatch #{tmp\ 1949}# (quote (any any)))))
- #{x\ 1948}#))
+ #{tmp\ 13112}#)))
+ ($sc-dispatch #{tmp\ 13112}# (quote (any any)))))
+ #{x\ 13110}#))
(module-name (current-module)))))
(define case
- (make-syncase-macro
+ (make-syntax-transformer
+ 'case
'macro
- (cons (lambda (#{x\ 1953}#)
- ((lambda (#{tmp\ 1954}#)
- ((lambda (#{tmp\ 1955}#)
- (if #{tmp\ 1955}#
- (apply (lambda (#{_\ 1956}#
- #{e\ 1957}#
- #{m1\ 1958}#
- #{m2\ 1959}#)
- ((lambda (#{tmp\ 1960}#)
- ((lambda (#{body\ 1961}#)
+ (cons (lambda (#{x\ 13118}#)
+ ((lambda (#{tmp\ 13120}#)
+ ((lambda (#{tmp\ 13121}#)
+ (if #{tmp\ 13121}#
+ (apply (lambda (#{_\ 13126}#
+ #{e\ 13127}#
+ #{m1\ 13128}#
+ #{m2\ 13129}#)
+ ((lambda (#{tmp\ 13131}#)
+ ((lambda (#{body\ 13133}#)
(list '#(syntax-object
let
((top)
- #(ribcage #(body) #((top)) #("i"))
+ #(ribcage
+ #(body)
+ #((top))
+ #("i13132"))
#(ribcage
#(_ e m1 m2)
#((top) (top) (top) (top))
- #("i" "i" "i" "i"))
+ #("i13122"
+ "i13123"
+ "i13124"
+ "i13125"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i13119")))
(hygiene guile))
(list (list '#(syntax-object
t
@@ -13915,32 +14255,35 @@
#(ribcage
#(body)
#((top))
- #("i"))
+ #("i13132"))
#(ribcage
#(_ e m1 m2)
#((top)
(top)
(top)
(top))
- #("i" "i" "i" "i"))
+ #("i13122"
+ "i13123"
+ "i13124"
+ "i13125"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13119")))
(hygiene guile))
- #{e\ 1957}#))
- #{body\ 1961}#))
- #{tmp\ 1960}#))
- (letrec ((#{f\ 1962}#
- (lambda (#{clause\ 1963}#
- #{clauses\ 1964}#)
- (if (null? #{clauses\ 1964}#)
- ((lambda (#{tmp\ 1966}#)
- ((lambda (#{tmp\ 1967}#)
- (if #{tmp\ 1967}#
- (apply (lambda (#{e1\
1968}#
- #{e2\
1969}#)
+ #{e\ 13127}#))
+ #{body\ 13133}#))
+ #{tmp\ 13131}#))
+ (letrec ((#{f\ 13137}#
+ (lambda (#{clause\ 13138}#
+ #{clauses\ 13139}#)
+ (if (null? #{clauses\ 13139}#)
+ ((lambda (#{tmp\ 13141}#)
+ ((lambda (#{tmp\ 13142}#)
+ (if #{tmp\ 13142}#
+ (apply (lambda (#{e1\
13145}#
+ #{e2\
13146}#)
(cons
'#(syntax-object
begin
((top)
@@ -13949,8 +14292,8 @@
e2)
#((top)
(top))
- #("i"
-
"i"))
+
#("i13143"
+
"i13144"))
#(ribcage
()
()
@@ -13962,9 +14305,9 @@
#((top)
(top)
(top))
- #("i"
- "i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -13974,10 +14317,10 @@
(top)
(top)
(top))
- #("i"
- "i"
- "i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -13985,17 +14328,17 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
- (cons
#{e1\ 1968}#
-
#{e2\ 1969}#)))
- #{tmp\ 1967}#)
- ((lambda (#{tmp\ 1971}#)
- (if #{tmp\ 1971}#
- (apply (lambda (#{k\
1972}#
-
#{e1\ 1973}#
-
#{e2\ 1974}#)
+ (cons
#{e1\ 13145}#
+
#{e2\ 13146}#)))
+ #{tmp\ 13142}#)
+ ((lambda (#{tmp\ 13148}#)
+ (if #{tmp\ 13148}#
+ (apply (lambda (#{k\
13152}#
+
#{e1\ 13153}#
+
#{e2\ 13154}#)
(list
'#(syntax-object
if
((top)
@@ -14006,9 +14349,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13149"
+
"i13150"
+
"i13151"))
#(ribcage
()
()
@@ -14020,9 +14363,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14032,10 +14375,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14043,7 +14386,7 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
(list
'#(syntax-object
@@ -14056,9 +14399,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13149"
+
"i13150"
+
"i13151"))
#(ribcage
()
()
@@ -14070,9 +14413,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14082,10 +14425,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14093,7 +14436,7 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
'#(syntax-object
@@ -14106,9 +14449,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13149"
+
"i13150"
+
"i13151"))
#(ribcage
()
()
@@ -14120,9 +14463,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14132,10 +14475,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14143,7 +14486,7 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
(list '#(syntax-object
@@ -14156,9 +14499,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13149"
+
"i13150"
+
"i13151"))
#(ribcage
()
()
@@ -14170,9 +14513,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14182,10 +14525,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14193,10 +14536,10 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
-
#{k\ 1972}#))
+
#{k\ 13152}#))
(cons
'#(syntax-object
begin
((top)
@@ -14207,9 +14550,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13149"
+
"i13150"
+
"i13151"))
#(ribcage
()
()
@@ -14221,9 +14564,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14233,10 +14576,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14244,27 +14587,27 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
-
(cons #{e1\ 1973}#
-
#{e2\ 1974}#))))
- #{tmp\ 1971}#)
- ((lambda (#{_\
1977}#)
+
(cons #{e1\ 13153}#
+
#{e2\ 13154}#))))
+ #{tmp\
13148}#)
+ ((lambda (#{_\
13158}#)
(syntax-violation
'case
"bad clause"
- #{x\ 1953}#
- #{clause\
1963}#))
- #{tmp\ 1966}#)))
+ #{x\ 13118}#
+ #{clause\
13138}#))
+ #{tmp\ 13141}#)))
($sc-dispatch
- #{tmp\ 1966}#
+ #{tmp\ 13141}#
'(each-any
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 1966}#
+ #{tmp\ 13141}#
'(#(free-id
#(syntax-object
else
@@ -14275,32 +14618,37 @@
#((top)
(top)
(top))
- #("i" "i" "i"))
+ #("i13134"
+ "i13135"
+ "i13136"))
#(ribcage
#(_ e m1 m2)
#((top)
(top)
(top)
(top))
- #("i" "i" "i" "i"))
+ #("i13122"
+ "i13123"
+ "i13124"
+ "i13125"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13119")))
(hygiene guile)))
any
.
each-any))))
- #{clause\ 1963}#)
- ((lambda (#{tmp\ 1978}#)
- ((lambda (#{rest\ 1979}#)
- ((lambda (#{tmp\ 1980}#)
- ((lambda (#{tmp\ 1981}#)
- (if #{tmp\ 1981}#
- (apply (lambda
(#{k\ 1982}#
-
#{e1\ 1983}#
-
#{e2\ 1984}#)
+ #{clause\ 13138}#)
+ ((lambda (#{tmp\ 13160}#)
+ ((lambda (#{rest\ 13162}#)
+ ((lambda (#{tmp\ 13163}#)
+ ((lambda (#{tmp\ 13164}#)
+ (if #{tmp\ 13164}#
+ (apply (lambda
(#{k\ 13168}#
+
#{e1\ 13169}#
+
#{e2\ 13170}#)
(list
'#(syntax-object
if
((top)
@@ -14311,13 +14659,13 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13165"
+
"i13166"
+
"i13167"))
#(ribcage
#(rest)
#((top))
-
#("i"))
+
#("i13161"))
#(ribcage
()
()
@@ -14329,9 +14677,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14341,10 +14689,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14352,7 +14700,7 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
(list '#(syntax-object
@@ -14365,13 +14713,13 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13165"
+
"i13166"
+
"i13167"))
#(ribcage
#(rest)
#((top))
-
#("i"))
+
#("i13161"))
#(ribcage
()
()
@@ -14383,9 +14731,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14395,10 +14743,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14406,7 +14754,7 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
'#(syntax-object
@@ -14419,13 +14767,13 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13165"
+
"i13166"
+
"i13167"))
#(ribcage
#(rest)
#((top))
-
#("i"))
+
#("i13161"))
#(ribcage
()
()
@@ -14437,9 +14785,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14449,10 +14797,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14460,7 +14808,7 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
(list '#(syntax-object
@@ -14473,13 +14821,13 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13165"
+
"i13166"
+
"i13167"))
#(ribcage
#(rest)
#((top))
-
#("i"))
+
#("i13161"))
#(ribcage
()
()
@@ -14491,9 +14839,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14503,10 +14851,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14514,10 +14862,10 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
-
#{k\ 1982}#))
+
#{k\ 13168}#))
(cons '#(syntax-object
begin
((top)
@@ -14528,13 +14876,13 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13165"
+
"i13166"
+
"i13167"))
#(ribcage
#(rest)
#((top))
-
#("i"))
+
#("i13161"))
#(ribcage
()
()
@@ -14546,9 +14894,9 @@
#((top)
(top)
(top))
-
#("i"
-
"i"
-
"i"))
+
#("i13134"
+
"i13135"
+
"i13136"))
#(ribcage
#(_
e
@@ -14558,10 +14906,10 @@
(top)
(top)
(top))
-
#("i"
-
"i"
-
"i"
-
"i"))
+
#("i13122"
+
"i13123"
+
"i13124"
+
"i13125"))
#(ribcage
()
()
@@ -14569,60 +14917,61 @@
#(ribcage
#(x)
#((top))
-
#("i")))
+
#("i13119")))
(hygiene
guile))
-
(cons #{e1\ 1983}#
-
#{e2\ 1984}#))
-
#{rest\ 1979}#))
- #{tmp\
1981}#)
- ((lambda (#{_\
1987}#)
+
(cons #{e1\ 13169}#
+
#{e2\ 13170}#))
+
#{rest\ 13162}#))
+ #{tmp\
13164}#)
+ ((lambda (#{_\
13174}#)
(syntax-violation
'case
"bad clause"
- #{x\ 1953}#
- #{clause\
1963}#))
- #{tmp\ 1980}#)))
+ #{x\ 13118}#
+ #{clause\
13138}#))
+ #{tmp\ 13163}#)))
($sc-dispatch
- #{tmp\ 1980}#
+ #{tmp\ 13163}#
'(each-any
any
.
each-any))))
- #{clause\ 1963}#))
- #{tmp\ 1978}#))
- (#{f\ 1962}#
- (car #{clauses\ 1964}#)
- (cdr #{clauses\ 1964}#)))))))
- (#{f\ 1962}# #{m1\ 1958}# #{m2\ 1959}#))))
- #{tmp\ 1955}#)
+ #{clause\ 13138}#))
+ #{tmp\ 13160}#))
+ (#{f\ 13137}#
+ (car #{clauses\ 13139}#)
+ (cdr #{clauses\ 13139}#)))))))
+ (#{f\ 13137}# #{m1\ 13128}# #{m2\ 13129}#))))
+ #{tmp\ 13121}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1954}#)))
+ #{tmp\ 13120}#)))
($sc-dispatch
- #{tmp\ 1954}#
+ #{tmp\ 13120}#
'(any any any . each-any))))
- #{x\ 1953}#))
+ #{x\ 13118}#))
(module-name (current-module)))))
(define identifier-syntax
- (make-syncase-macro
+ (make-syntax-transformer
+ 'identifier-syntax
'macro
- (cons (lambda (#{x\ 1988}#)
- ((lambda (#{tmp\ 1989}#)
- ((lambda (#{tmp\ 1990}#)
- (if #{tmp\ 1990}#
- (apply (lambda (#{_\ 1991}# #{e\ 1992}#)
+ (cons (lambda (#{x\ 13175}#)
+ ((lambda (#{tmp\ 13177}#)
+ ((lambda (#{tmp\ 13178}#)
+ (if #{tmp\ 13178}#
+ (apply (lambda (#{_\ 13181}# #{e\ 13182}#)
(list '#(syntax-object
lambda
((top)
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage #(x) #((top)) #("i13176")))
(hygiene guile))
'(#(syntax-object
x
@@ -14630,19 +14979,43 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage #(x) #((top)) #("i13176")))
(hygiene guile)))
+ '#((#(syntax-object
+ macro-type
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i13179" "i13180"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i13176")))
+ (hygiene guile))
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i13179" "i13180"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i13176")))
+ (hygiene guile))))
(list '#(syntax-object
syntax-case
((top)
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i13176")))
(hygiene guile))
'#(syntax-object
x
@@ -14650,9 +15023,12 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i")))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i13176")))
(hygiene guile))
'()
(list '#(syntax-object
@@ -14661,12 +15037,12 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
'(#(syntax-object
identifier?
@@ -14674,12 +15050,12 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
(#(syntax-object
syntax
@@ -14687,12 +15063,12 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
#(syntax-object
id
@@ -14700,12 +15076,12 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179" "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))))
(list '#(syntax-object
syntax
@@ -14713,27 +15089,29 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179"
+ "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
- #{e\ 1992}#))
- (list (cons #{_\ 1991}#
+ #{e\ 13182}#))
+ (list (cons #{_\ 13181}#
'(#(syntax-object
x
((top)
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179"
+ "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
#(syntax-object
...
@@ -14741,12 +15119,13 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179"
+ "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))))
(list '#(syntax-object
syntax
@@ -14754,14 +15133,15 @@
#(ribcage
#(_ e)
#((top) (top))
- #("i" "i"))
+ #("i13179"
+ "i13180"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
- (cons #{e\ 1992}#
+ (cons #{e\ 13182}#
'(#(syntax-object
x
((top)
@@ -14769,7 +15149,8 @@
#(_ e)
#((top)
(top))
- #("i" "i"))
+ #("i13179"
+ "i13180"))
#(ribcage
()
()
@@ -14777,7 +15158,7 @@
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene guile))
#(syntax-object
...
@@ -14786,7 +15167,8 @@
#(_ e)
#((top)
(top))
- #("i" "i"))
+ #("i13179"
+ "i13180"))
#(ribcage
()
()
@@ -14794,69 +15176,117 @@
#(ribcage
#(x)
#((top))
- #("i")))
+ #("i13176")))
(hygiene
guile)))))))))
- #{tmp\ 1990}#)
+ #{tmp\ 13178}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1989}#)))
- ($sc-dispatch #{tmp\ 1989}# (quote (any any)))))
- #{x\ 1988}#))
+ #{tmp\ 13177}#)))
+ ($sc-dispatch #{tmp\ 13177}# (quote (any any)))))
+ #{x\ 13175}#))
(module-name (current-module)))))
(define define*
- (make-syncase-macro
+ (make-syntax-transformer
+ 'define*
'macro
- (cons (lambda (#{x\ 1993}#)
- ((lambda (#{tmp\ 1994}#)
- ((lambda (#{tmp\ 1995}#)
- (if #{tmp\ 1995}#
- (apply (lambda (#{dummy\ 1996}#
- #{id\ 1997}#
- #{args\ 1998}#
- #{b0\ 1999}#
- #{b1\ 2000}#)
+ (cons (lambda (#{x\ 13183}#)
+ ((lambda (#{tmp\ 13185}#)
+ ((lambda (#{tmp\ 13186}#)
+ (if #{tmp\ 13186}#
+ (apply (lambda (#{_\ 13192}#
+ #{id\ 13193}#
+ #{args\ 13194}#
+ #{b0\ 13195}#
+ #{b1\ 13196}#)
(list '#(syntax-object
define
((top)
#(ribcage
- #(dummy id args b0 b1)
- #(("m" top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
+ #(_ id args b0 b1)
+ #((top) (top) (top) (top) (top))
+ #("i13187"
+ "i13188"
+ "i13189"
+ "i13190"
+ "i13191"))
#(ribcage () () ())
- #(ribcage #(x) #(("m" top)) #("i")))
+ #(ribcage #(x) #((top)) #("i13184")))
(hygiene guile))
- #{id\ 1997}#
+ #{id\ 13193}#
(cons '#(syntax-object
lambda*
((top)
#(ribcage
- #(dummy id args b0 b1)
- #(("m" top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
+ #(_ id args b0 b1)
+ #((top) (top) (top) (top) (top))
+ #("i13187"
+ "i13188"
+ "i13189"
+ "i13190"
+ "i13191"))
#(ribcage () () ())
#(ribcage
#(x)
- #(("m" top))
- #("i")))
+ #((top))
+ #("i13184")))
(hygiene guile))
- (cons #{args\ 1998}#
- (cons #{b0\ 1999}#
- #{b1\ 2000}#)))))
- #{tmp\ 1995}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 1994}#)))
+ (cons #{args\ 13194}#
+ (cons #{b0\ 13195}#
+ #{b1\ 13196}#)))))
+ #{tmp\ 13186}#)
+ ((lambda (#{tmp\ 13198}#)
+ (if (if #{tmp\ 13198}#
+ (apply (lambda (#{_\ 13202}#
+ #{id\ 13203}#
+ #{val\ 13204}#)
+ (identifier?
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ id val)
+ #((top) (top) (top))
+ #("i13199" "i13200" "i13201"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i13184")))
+ (hygiene guile))))
+ #{tmp\ 13198}#)
+ #f)
+ (apply (lambda (#{_\ 13208}#
+ #{id\ 13209}#
+ #{val\ 13210}#)
+ (list '#(syntax-object
+ define
+ ((top)
+ #(ribcage
+ #(_ id val)
+ #((top) (top) (top))
+ #("i13205" "i13206" "i13207"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i13184")))
+ (hygiene guile))
+ #{id\ 13209}#
+ #{val\ 13210}#))
+ #{tmp\ 13198}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 13185}#)))
+ ($sc-dispatch
+ #{tmp\ 13185}#
+ '(any any any)))))
($sc-dispatch
- #{tmp\ 1994}#
+ #{tmp\ 13185}#
'(any (any . any) any . each-any))))
- #{x\ 1993}#))
+ #{x\ 13183}#))
(module-name (current-module)))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 623b82a..48e506e 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,6 +1,6 @@
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010 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
@@ -45,7 +45,7 @@
;;; Scheme, please read the notes below carefully.
-;;; This file defines the syntax-case expander, sc-expand, and a set
+;;; This file defines the syntax-case expander, macroexpand, and a set
;;; of associated syntactic forms and procedures. Of these, the
;;; following are documented in The Scheme Programming Language,
;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are
@@ -73,8 +73,8 @@
;;; The remaining exports are listed below:
;;;
-;;; (sc-expand datum)
-;;; if datum represents a valid expression, sc-expand returns an
+;;; (macroexpand datum)
+;;; if datum represents a valid expression, macroexpand returns an
;;; expanded version of datum in a core language that includes no
;;; syntactic abstractions. The core language includes begin,
;;; define, if, lambda, letrec, quote, and set!.
@@ -101,9 +101,9 @@
;;; eval will not be invoked during the loading of psyntax.pp. After
;;; psyntax.pp has been loaded, the expansion of any macro definition,
;;; whether local or global, will result in a call to eval. If, however,
-;;; sc-expand has already been registered as the expander to be used
+;;; macroexpand has already been registered as the expander to be used
;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
+;;; to support the "noexpand" flag, since it is handled by macroexpand.
;;;
;;; (gensym)
;;; returns a unique symbol each time it's called
@@ -111,7 +111,7 @@
;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
+;;; psyntax.ss), and register macroexpand as the current expander (how
;;; you do this depends upon your implementation of Scheme). You may
;;; change the hooks and constructors defined toward the beginning of
;;; the code below, but to avoid bootstrapping problems, do so only
@@ -308,18 +308,10 @@
(define put-global-definition-hook
(lambda (symbol type val)
- (let ((existing (let ((v (module-variable (current-module) symbol)))
- (and v (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val)
- (not (syncase-macro-type val))
- val))))))
- (module-define! (current-module)
- symbol
- (if existing
- (make-extended-syncase-macro existing type val)
- (make-syncase-macro type val))))))
-
+ (module-define! (current-module)
+ symbol
+ (make-syntax-transformer symbol type val))))
+
(define get-global-definition-hook
(lambda (symbol module)
(if (and (not module) (current-module))
@@ -330,9 +322,9 @@
symbol)))
(and v (variable-bound? v)
(let ((val (variable-ref v)))
- (and (macro? val) (syncase-macro-type val)
- (cons (syncase-macro-type val)
- (syncase-macro-binding val))))))))
+ (and (macro? val) (macro-type val)
+ (cons (macro-type val)
+ (macro-binding val))))))))
)
@@ -366,6 +358,13 @@
`(if ,test-exp ,then-exp ,else-exp))
source)))))
+ (define build-dynlet
+ (lambda (source fluids vals body)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-dynlet) source fluids vals body))
+ (else (decorate-source `(with-fluids ,(map list fluids vals) ,body)
+ source)))))
+
(define build-lexical-reference
(lambda (type source name var)
(case (fluid-ref *mode*)
@@ -454,29 +453,27 @@
;; This will come with the new interpreter, but for now we separate
;; the cases.
(define build-simple-lambda
- (lambda (src req rest vars docstring exp)
+ (lambda (src req rest vars meta exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lambda) src
- (if docstring `((documentation . ,docstring)) '())
+ meta
;; hah, a case in which kwargs would be nice.
((@ (language tree-il) make-lambda-case)
;; src req opt rest kw inits vars body else
src req #f rest #f '() vars exp #f)))
(else (decorate-source
`(lambda ,(if rest (apply cons* vars) vars)
- ,@(if docstring (list docstring) '())
,exp)
src)))))
(define build-case-lambda
- (lambda (src docstring body)
+ (lambda (src meta body)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lambda) src
- (if docstring `((documentation . ,docstring)) '())
+ meta
body))
(else (decorate-source
;; really gross hack
`(lambda %%args
- ,@(if docstring (list docstring) '())
(cond ,@body))
src)))))
@@ -518,14 +515,11 @@
'(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
(list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
%%args)
- ;; FIXME: This _ is here to work around a bug in the
- ;; memoizer. The %%% makes it different from %%, also a
- ;; memoizer workaround. See the "interesting bug" mail from
- ;; 23 oct 2009. As soon as we change the evaluator, this
- ;; can be removed.
- => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args)))
+ => (lambda (%%args) (apply (lambda ,vars ,body) %%args)))
,@(or else-case
- `((%%args (error "wrong number of arguments" %%args)))))
+ `((%%args (scm-error 'wrong-number-of-args #f
+ "Wrong number of arguments" '()
+ %%args)))))
src))))))
(define build-primref
@@ -575,7 +569,7 @@
(ids (cdr ids)))
(case (fluid-ref *mode*)
((c)
- (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
+ (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)
((@ (language tree-il) make-letrec) src
@@ -787,9 +781,10 @@
(syntax-rules ()
((_ old new marks) (vector old new marks))))
-;;; labels must be comparable with "eq?" and distinct from symbols.
+;;; labels must be comparable with "eq?", have read-write invariance,
+;;; and distinct from symbols.
(define gen-label
- (lambda () (string #\i)))
+ (lambda () (symbol->string (gensym "i"))))
(define gen-labels
(lambda (ls)
@@ -820,7 +815,7 @@
(define-syntax new-mark
(syntax-rules ()
- ((_) (string #\m))))
+ ((_) (gensym "m"))))
;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;;; internal definitions, in which the ribcages are built incrementally
@@ -1026,61 +1021,56 @@
(define chi-top-sequence
(lambda (body r w s m esew mod)
+ ;; Expanding a sequence of toplevel expressions can affect the
+ ;; expansion-time environment in several ways -- by adding or changing
+ ;; top-level syntactic bindings, by defining new modules, and by changing
+ ;; the current module -- among other ways.
+ ;;
+ ;; Of all of these, changes to the current module need to be treated
+ ;; specially, as modules have specific support in the expander, for
+ ;; purposes of maintaining hygiene. (In contrast, changes to parts of the
+ ;; global state that are not specifically treated by the expander are
+ ;; visible by default, without special support.)
+ ;;
+ ;; So, the deal. In the expression, (begin (define-module (foo)) (bar)),
+ ;; we need to expand (bar) within the (foo) module. More generally, in a
+ ;; top-level sequence, if the module after expanding a form is not the
+ ;; same as the module before expanding the form, we expand subsequent
+ ;; forms in the new module.
(build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew)
(mod mod))
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew)
(mod mod)
+ (module (current-module)) (out '()))
(if (null? body)
- '()
- (let ((first (chi-top (car body) r w m esew mod)))
- (cons first (dobody (cdr body) r w m esew
mod))))))))
+ (reverse out)
+ (let* ((first (chi-top (car body) r w m esew mod))
+ (new-module (current-module)))
+ (dobody (cdr body) r w m esew
+ (if (eq? module new-module)
+ mod
+ (cons 'hygiene (module-name
new-module)))
+ new-module (cons first out))))))))
(define chi-install-global
(lambda (name e)
(build-global-definition
no-source
name
- ;; FIXME: seems nasty to call current-module here
- (if (let ((v (module-variable (current-module) name)))
- ;; FIXME use primitive-macro?
- (and v (variable-bound? v) (macro? (variable-ref v))
- (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
- (build-application
- no-source
- (build-primref no-source 'make-extended-syncase-macro)
- (list (build-application
- no-source
- (build-primref no-source 'module-ref)
- (list (build-application
- no-source
- (build-primref no-source 'current-module)
- '())
- (build-data no-source name)))
- (build-data no-source 'macro)
- (build-application
- no-source
- (build-primref no-source 'cons)
- (list e
- (build-application
- no-source
- (build-primref no-source 'module-name)
- (list (build-application
- no-source
- (build-primref no-source 'current-module)
- '())))))))
- (build-application
- no-source
- (build-primref no-source 'make-syncase-macro)
- (list (build-data no-source 'macro)
- (build-application
- no-source
- (build-primref no-source 'cons)
- (list e
- (build-application
- no-source
- (build-primref no-source 'module-name)
- (list (build-application
- no-source
- (build-primref no-source 'current-module)
- '())))))))))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-syntax-transformer)
+ (list (build-data no-source name)
+ (build-data no-source 'macro)
+ (build-application
+ no-source
+ (build-primref no-source 'cons)
+ (list e
+ (build-application
+ no-source
+ (build-primref no-source 'module-name)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '()))))))))))
(define chi-when-list
(lambda (e when-list w)
@@ -1607,14 +1597,14 @@
(req orig-args '())))
(define chi-simple-lambda
- (lambda (e r w s mod req rest docstring body)
+ (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
- docstring
+ meta
(chi-body body (source-wrap e w s mod)
(extend-var-env labels vars r)
(make-binding-wrap ids labels w)
@@ -1758,33 +1748,37 @@
(else
(expand-body req opt rest
(if (or aok (pair? out)) (cons aok (reverse out)) #f)
- body (reverse vars) r* w* (reverse inits)))))
- (define (expand-body req opt rest kw body vars r* w* inits)
+ body (reverse vars) r* w* (reverse inits) '()))))
+ (define (expand-body req opt rest kw body vars r* w* inits meta)
(syntax-case body ()
((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
- (values (syntax->datum #'docstring) req opt rest kw inits vars
- (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
- r* w* mod)))
+ (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+ (append meta
+ `((documentation
+ . ,(syntax->datum #'docstring))))))
+ ((#((k . v) ...) e1 e2 ...)
+ (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+ (append meta (syntax->datum #'((k . v) ...)))))
((e1 e2 ...)
- (values #f req opt rest kw inits vars
+ (values meta req opt rest kw inits vars
(chi-body #'(e1 e2 ...) (source-wrap e w s mod)
r* w* mod)))))
(syntax-case clauses ()
- (() (values #f #f))
+ (() (values '() #f))
(((args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values (lambda () (get-formals #'args))
(lambda (req opt rest kw)
(call-with-values (lambda ()
(expand-req req opt rest kw #'(e1 e2 ...)))
- (lambda (docstring req opt rest kw inits vars body)
+ (lambda (meta req opt rest kw inits vars body)
(call-with-values
(lambda ()
(chi-lambda-case e r w s mod get-formals
#'((args* e1* e2* ...) ...)))
- (lambda (docstring* else*)
+ (lambda (meta* else*)
(values
- (or docstring docstring*)
+ (append meta meta*)
(build-lambda-case s req opt rest kw inits vars
body else*))))))))))))
@@ -2028,7 +2022,7 @@
((quote) (build-data no-source (cadr x)))
((lambda)
(if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr
x) #f (regen (caddr x)))
+ (build-simple-lambda no-source (cadr x) #f (cadr
x) '() (regen (caddr x)))
(error "how did we get here" x)))
(else (build-application no-source
(build-primref no-source
(car x))
@@ -2046,17 +2040,22 @@
(global-extend 'core 'lambda
(lambda (e r w s mod)
(syntax-case e ()
- ((_ args docstring e1 e2 ...) (string? (syntax->datum
#'docstring))
- (call-with-values (lambda () (lambda-formals #'args))
- (lambda (req opt rest kw)
- (chi-simple-lambda e r w s mod req rest
(syntax->datum #'docstring)
- #'(e1 e2 ...)))))
((_ args e1 e2 ...)
(call-with-values (lambda () (lambda-formals #'args))
(lambda (req opt rest kw)
- (chi-simple-lambda e r w s mod req rest #f #'(e1 e2
...)))))
+ (let lp ((body #'(e1 e2 ...)) (meta '()))
+ (syntax-case body ()
+ ((docstring e1 e2 ...) (string? (syntax->datum
#'docstring))
+ (lp #'(e1 e2 ...)
+ (append meta
+ `((documentation
+ . ,(syntax->datum
#'docstring))))))
+ ((#((k . v) ...) e1 e2 ...)
+ (lp #'(e1 e2 ...)
+ (append meta (syntax->datum #'((k . v)
...)))))
+ (_ (chi-simple-lambda e r w s mod req rest meta
body)))))))
(_ (syntax-violation 'lambda "bad lambda" e)))))
-
+
(global-extend 'core 'lambda*
(lambda (e r w s mod)
(syntax-case e ()
@@ -2065,8 +2064,8 @@
(lambda ()
(chi-lambda-case e r w s mod
lambda*-formals #'((args e1 e2
...))))
- (lambda (docstring lcase)
- (build-case-lambda s docstring lcase))))
+ (lambda (meta lcase)
+ (build-case-lambda s meta lcase))))
(_ (syntax-violation 'lambda "bad lambda*" e)))))
(global-extend 'core 'case-lambda
@@ -2078,8 +2077,8 @@
(chi-lambda-case e r w s mod
lambda-formals
#'((args e1 e2 ...) (args* e1*
e2* ...) ...)))
- (lambda (docstring lcase)
- (build-case-lambda s docstring lcase))))
+ (lambda (meta lcase)
+ (build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
(global-extend 'core 'case-lambda*
@@ -2091,8 +2090,8 @@
(chi-lambda-case e r w s mod
lambda*-formals
#'((args e1 e2 ...) (args* e1*
e2* ...) ...)))
- (lambda (docstring lcase)
- (build-case-lambda s docstring lcase))))
+ (lambda (meta lcase)
+ (build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda*"
e)))))
(global-extend 'core 'let
@@ -2221,6 +2220,17 @@
(chi #'then r w mod)
(chi #'else r w mod))))))
+ (global-extend 'core 'with-fluids
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((fluid val) ...) b b* ...)
+ (build-dynlet
+ s
+ (map (lambda (x) (chi x r w mod)) #'(fluid ...))
+ (map (lambda (x) (chi x r w mod)) #'(val ...))
+ (chi-body #'(b b* ...)
+ (source-wrap e w s mod) r w mod))))))
+
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
@@ -2291,7 +2301,7 @@
(let ((labels (gen-labels ids)) (new-vars (map
gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-simple-lambda
no-source (map syntax->datum ids) #f new-vars #f
+ (list (build-simple-lambda
no-source (map syntax->datum ids) #f new-vars '()
(chi
exp
(extend-env
labels
@@ -2318,7 +2328,7 @@
(let ((y (gen-var 'tmp)))
; fat finger binding and references to
temp variable y
(build-application no-source
- (build-simple-lambda
no-source (list 'tmp) #f (list y) #f
+ (build-simple-lambda
no-source (list 'tmp) #f (list y) '()
(let
((y (build-lexical-reference 'value no-source
'tmp y)))
(build-conditional no-source
@@ -2357,7 +2367,7 @@
(build-application no-source
(build-simple-lambda
no-source (list
(syntax->datum #'pat)) #f (list var)
- #f
+ '()
(chi #'exp
(extend-env labels
(list
(make-binding 'syntax `(,var . 0)))
@@ -2383,7 +2393,7 @@
(let ((x (gen-var 'tmp)))
; fat finger binding and references to
temp variable x
(build-application s
- (build-simple-lambda
no-source (list 'tmp) #f (list x) #f
+ (build-simple-lambda
no-source (list 'tmp) #f (list x) '()
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)
#'(key ...) #'(m ...)
@@ -2392,7 +2402,7 @@
(list (chi #'val r
empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals
list" e))))))))
-;;; The portable sc-expand seeds chi-top's mode m with 'e (for
+;;; The portable macroexpand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
;;; if we are compiling a file, and esew is set to
@@ -2401,7 +2411,7 @@
;;; syntactic definitions are evaluated immediately after they are
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
- (set! sc-expand
+ (set! macroexpand
(lambda (x . rest)
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
@@ -2409,10 +2419,9 @@
(esew (if (or (null? rest) (null? (cdr rest)))
'(eval)
(cadr rest))))
- (with-fluid* *mode* m
- (lambda ()
- (chi-top x null-env top-wrap m esew
- (cons 'hygiene (module-name
(current-module))))))))))
+ (with-fluids ((*mode* m))
+ (chi-top x null-env top-wrap m esew
+ (cons 'hygiene (module-name (current-module)))))))))
(set! identifier?
(lambda (x)
@@ -2450,7 +2459,7 @@
(arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
who 'syntax-violation)
(arg-check string? message 'syntax-violation)
- (scm-error 'syntax-error 'sc-expand
+ (scm-error 'syntax-error 'macroexpand
(string-append
(if who "~a: " "")
"~a "
@@ -2640,6 +2649,9 @@
(syntax-case x ()
((_ (k ...) ((keyword . pattern) template) ...)
#'(lambda (x)
+ ;; embed patterns as procedure metadata
+ #((macro-type . syntax-rules)
+ (patterns pattern ...))
(syntax-case x (k ...)
((dummy . pattern) #'template)
...))))))
@@ -2747,11 +2759,14 @@
(define read-file
(lambda (fn k)
(let ((p (open-input-file fn)))
- (let f ((x (read p)))
+ (let f ((x (read p))
+ (result '()))
(if (eof-object? x)
- (begin (close-input-port p) '())
- (cons (datum->syntax k x)
- (f (read p))))))))
+ (begin
+ (close-input-port p)
+ (reverse result))
+ (f (read p)
+ (cons (datum->syntax k x) result)))))))
(syntax-case x ()
((k filename)
(let ((fn (syntax->datum #'filename)))
@@ -2812,6 +2827,7 @@
(syntax-case x ()
((_ e)
#'(lambda (x)
+ #((macro-type . identifier-syntax))
(syntax-case x ()
(id
(identifier? #'id)
@@ -2820,6 +2836,9 @@
#'(e x (... ...)))))))))
(define-syntax define*
- (syntax-rules ()
- ((_ (id . args) b0 b1 ...)
- (define id (lambda* args b0 b1 ...)))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (id . args) b0 b1 ...)
+ #'(define id (lambda* args b0 b1 ...)))
+ ((_ id val) (identifier? #'x)
+ #'(define id val)))))
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
index c23f31a..4d3feba 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 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010 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,15 +23,71 @@
;;;; apply and call-with-current-continuation
-;;; We want these to be tail-recursive, so instead of using primitive
-;;; procedures, we define them as closures in terms of the primitive
-;;; macros @apply and @call-with-current-continuation.
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(set-procedure-property! apply 'name 'apply)
+;;; The deal with these is that they are the procedural wrappers around the
+;;; primitives of Guile's language. There are about 20 different kinds of
+;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
+;;; to preserve tail recursion.)
+;;;
+;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in
the
+;;; case that apply is passed to apply, or we're bootstrapping, we need a
+;;; trampoline -- and here they are.
+(define (apply fun . args)
+ (@apply fun (apply:nconc2last args)))
(define (call-with-current-continuation proc)
(@call-with-current-continuation proc))
(define (call-with-values producer consumer)
(@call-with-values producer consumer))
+(define (dynamic-wind in thunk out)
+ "All three arguments must be 0-argument procedures.
address@hidden is called, then @var{thunk}, then
address@hidden
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out_guard} is called. If the continuation of
+the dynamic-wind is re-entered, @var{in_guard} is called. Thus
address@hidden and @var{out_guard} may be called any number of
+times.
address@hidden
+ (define x 'normal-binding)
address@hidden x
+ (define a-cont
+ (call-with-current-continuation
+ (lambda (escape)
+ (let ((old-x x))
+ (dynamic-wind
+ ;; in-guard:
+ ;;
+ (lambda () (set! x 'special-binding))
+
+ ;; thunk
+ ;;
+ (lambda () (display x) (newline)
+ (call-with-current-continuation escape)
+ (display x) (newline)
+ x)
+
+ ;; out-guard:
+ ;;
+ (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
address@hidden a-cont
+x
address@hidden normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
address@hidden a-cont ;; the value of the (define a-cont...)
+x
address@hidden normal-binding
+a-cont
address@hidden special-binding
address@hidden lisp"
+ (@dynamic-wind in (thunk) out))
;;;; Basic Port Code
diff --git a/module/ice-9/runq.scm b/module/ice-9/runq.scm
index c14eb89..78a4203 100644
--- a/module/ice-9/runq.scm
+++ b/module/ice-9/runq.scm
@@ -1,6 +1,6 @@
;;;; runq.scm --- the runq data structure
;;;;
-;;;; Copyright (C) 1996, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 2001, 2006, 2010 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
@@ -208,7 +208,6 @@
;;; runq, strips of the parallel subtasks will run
;;; round-robin style.
;;;
-(define fork-strips (lambda args args))
;;;;
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index f6cad46..e168d3e 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010 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
@@ -516,7 +516,7 @@ The alist keys that are currently defined are `required',
`optional',
((procedure-source proc)
=> cadr)
(((@ (system vm program) program?) proc)
- ((@ (system vm program) program-arguments) proc))
+ ((@ (system vm program) program-arguments-alist) proc))
(else #f)))
diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm
index 210a232..219803e 100644
--- a/module/ice-9/syncase.scm
+++ b/module/ice-9/syncase.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006, 2010 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,11 +17,17 @@
(define-module (ice-9 syncase)
- )
+ ;; FIXME re-export other procs
+ #:export (datum->syntax-object syntax-object->datum
+ sc-expand))
(issue-deprecation-warning
"Syntax-case macros are now a part of Guile core; importing (ice-9 syncase)
is no longer necessary.")
+(define datum->syntax-object datum->syntax)
+(define syntax-object->datum syntax->datum)
+(define sc-expand macroexpand)
+
;;; Hack to make syncase macros work in the slib module
;; FIXME wingo is this still necessary?
;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
new file mode 100644
index 0000000..0c92976
--- /dev/null
+++ b/module/ice-9/vlist.scm
@@ -0,0 +1,489 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2009, 2010 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 (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+
+ #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
+ vlist-null list->vlist vlist-ref vlist-drop vlist-take
+ vlist-length vlist-fold vlist-fold-right vlist-map
+ vlist-unfold vlist-unfold-right vlist-append
+ vlist-reverse vlist-filter vlist-delete vlist->list
+ vlist-for-each
+ block-growth-factor
+
+ vhash? vhash-cons vhash-consq vhash-consv
+ vhash-assoc vhash-assq vhash-assv
+ vhash-delete vhash-fold alist->vhash))
+
+;;; Author: Ludovic Courtès <address@hidden>
+;;;
+;;; Commentary:
+;;;
+;;; This module provides an implementations of vlists, a functional list-like
+;;; data structure described by Phil Bagwell in "Fast Functional Lists,
+;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report,
+;;; 2002.
+;;;
+;;; The idea is to store vlist elements in increasingly large contiguous blocks
+;;; (implemented as vectors here). These blocks are linked to one another
using
+;;; a pointer to the next block (called `block-base' here) and an offset within
+;;; that block (`block-offset' here). The size of these blocks form a
geometric
+;;; series with ratio `block-growth-factor'.
+;;;
+;;; In the best case (e.g., using a vlist returned by `list->vlist'),
+;;; elements from the first half of an N-element vlist are accessed in O(1)
+;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only
+;;; O(ln(N)). Furthermore, the data structure improves data locality since
+;;; vlist elements are adjacent, which plays well with caches.
+;;;
+;;; Code:
+
+
+;;;
+;;; VList Blocks and Block Descriptors.
+;;;
+
+(define block-growth-factor
+ (let ((f (make-fluid)))
+ (fluid-set! f 2)
+ f))
+
+(define-syntax define-inline
+ ;; Work around the lack of an inliner.
+ (syntax-rules ()
+ ((_ (name formals ...) body ...)
+ (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-syntax define-block-accessor
+ (syntax-rules ()
+ ((_ name index)
+ (define-inline (name block)
+ (vector-ref block index)))))
+
+(define-block-accessor block-content 0)
+(define-block-accessor block-base 1)
+(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-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-inline (block-hash-table-set! block offset value)
+ (vector-set! (block-hash-table block) offset value))
+
+(define block-null
+ ;; The null block.
+ (make-block #f 0 0 #f))
+
+
+;;;
+;;; VLists.
+;;;
+
+(define-record-type <vlist>
+ ;; A vlist is just a base+offset pair pointing to a block.
+
+ ;; XXX: Allocating a <vlist> record in addition to the block at each
+ ;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it
+ ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
+ ;; performance hit for everyone.
+ (make-vlist base offset)
+ vlist?
+ (base vlist-base)
+ (offset vlist-offset))
+
+
+(define vlist-null
+ ;; 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)))))
+
+(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.
+ (block-cons item vlist #f))
+
+(define (vlist-head vlist)
+ "Return the head of @var{vlist}."
+ (let ((base (vlist-base vlist))
+ (offset (vlist-offset vlist)))
+ (block-ref* base offset)))
+
+(define (vlist-tail vlist)
+ "Return the tail of @var{vlist}."
+ (let ((base (vlist-base vlist))
+ (offset (vlist-offset vlist)))
+ (if (> offset 0)
+ (make-vlist base (- offset 1))
+ (make-vlist (block-base base)
+ (block-offset base)))))
+
+(define (vlist-null? vlist)
+ "Return true if @var{vlist} is empty."
+ (let ((base (vlist-base vlist)))
+ (and (not (block-base base))
+ (= 0 (block-size base)))))
+
+
+;;;
+;;; VList Utilities.
+;;;
+
+(define (list->vlist lst)
+ "Return a new vlist whose contents correspond to @var{lst}."
+ (vlist-reverse (fold vlist-cons vlist-null lst)))
+
+(define (vlist-fold proc init vlist)
+ "Fold over @var{vlist}, calling @var{proc} for each element."
+ ;; FIXME: Handle multiple lists.
+ (let loop ((base (vlist-base vlist))
+ (offset (vlist-offset vlist))
+ (result init))
+ (if (eq? base block-null)
+ result
+ (let* ((next (- offset 1))
+ (done? (< next 0)))
+ (loop (if done? (block-base base) base)
+ (if done? (block-offset base) next)
+ (proc (block-ref* 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."
+ (vlist-fold proc init (vlist-reverse vlist)))
+
+(define (vlist-reverse vlist)
+ "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
+order."
+ (vlist-fold vlist-cons vlist-null vlist))
+
+(define (vlist-map proc vlist)
+ "Map @var{proc} over the elements of @var{vlist} and return a new vlist."
+ (vlist-fold (lambda (item result)
+ (vlist-cons (proc item) result))
+ vlist-null
+ (vlist-reverse vlist)))
+
+(define (vlist->list vlist)
+ "Return a new list whose contents match those of @var{vlist}."
+ (vlist-fold-right cons '() vlist))
+
+(define (vlist-ref vlist index)
+ "Return the element at index @var{index} in @var{vlist}."
+ (let loop ((index index)
+ (base (vlist-base vlist))
+ (offset (vlist-offset vlist)))
+ (if (<= index offset)
+ (block-ref* base (- offset index))
+ (loop (- index offset 1)
+ (block-base base)
+ (block-offset base)))))
+
+(define (vlist-drop vlist count)
+ "Return a new vlist that does not contain the @var{count} first elements of
address@hidden"
+ (let loop ((count count)
+ (base (vlist-base vlist))
+ (offset (vlist-offset vlist)))
+ (if (<= count offset)
+ (make-vlist base (- offset count))
+ (loop (- count offset 1)
+ (block-base base)
+ (block-offset base)))))
+
+(define (vlist-take vlist count)
+ "Return a new vlist that contains only the @var{count} first elements of
address@hidden"
+ (let loop ((count count)
+ (vlist vlist)
+ (result vlist-null))
+ (if (= 0 count)
+ (vlist-reverse result)
+ (loop (- count 1)
+ (vlist-tail vlist)
+ (vlist-cons (vlist-head vlist) result)))))
+
+(define (vlist-filter pred vlist)
+ "Return a new vlist containing all the elements from @var{vlist} that
+satisfy @var{pred}."
+ (vlist-fold-right (lambda (e v)
+ (if (pred e)
+ (vlist-cons e v)
+ v))
+ vlist-null
+ vlist))
+
+(define* (vlist-delete x vlist #:optional (equal? equal?))
+ "Return a new vlist corresponding to @var{vlist} without the elements
address@hidden to @var{x}."
+ (vlist-filter (lambda (e)
+ (not (equal? e x)))
+ vlist))
+
+(define (vlist-length vlist)
+ "Return the length of @var{vlist}."
+ (let loop ((base (vlist-base vlist))
+ (len (vlist-offset vlist)))
+ (if (eq? base block-null)
+ len
+ (loop (block-base base)
+ (+ len 1 (block-offset base))))))
+
+(define* (vlist-unfold p f g seed
+ #:optional (tail-gen (lambda (x) vlist-null)))
+ "Return a new vlist. See the description of SRFI-1 `unfold' for details."
+ (let uf ((seed seed))
+ (if (p seed)
+ (tail-gen seed)
+ (vlist-cons (f seed)
+ (uf (g seed))))))
+
+(define* (vlist-unfold-right p f g seed #:optional (tail vlist-null))
+ "Return a new vlist. See the description of SRFI-1 `unfold-right' for
+details."
+ (let uf ((seed seed) (lis tail))
+ (if (p seed)
+ lis
+ (uf (g seed) (vlist-cons (f seed) lis)))))
+
+(define (vlist-append . vlists)
+ "Append the given lists."
+ (if (null? vlists)
+ vlist-null
+ (fold-right (lambda (vlist result)
+ (vlist-fold-right (lambda (e v)
+ (vlist-cons e v))
+ result
+ vlist))
+ vlist-null
+ vlists)))
+
+(define (vlist-for-each proc vlist)
+ "Call @var{proc} on each element of @var{vlist}. The result is unspecified."
+ (vlist-fold (lambda (item x)
+ (proc item))
+ (if #f #f)
+ vlist))
+
+
+;;;
+;;; Hash Lists, aka. `VHash'.
+;;;
+
+;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2
+;; associated with K1 and K2, respectively. The resulting layout is a
+;; follows:
+;;
+;; ,--------------------.
+;; | ,-> (K1 . V1) ---. |
+;; | | | |
+;; | | (K2 . V2) <--' |
+;; | | |
+;; +-|------------------+
+;; | | |
+;; | | |
+;; | `-- O <---------------H
+;; | |
+;; `--------------------'
+;;
+;; 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:
+;;
+;; - 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.
+
+(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))))))
+
+(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))
+
+(define vhash-consq (cut vhash-cons <> <> <> hashq))
+(define vhash-consv (cut vhash-cons <> <> <> hashv))
+
+;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction
instead
+;; of calling the `eq?' subr.
+(define-inline (%vhash-assoc key vhash equal? hash)
+ (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* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
+ "Return the first key/value pair from @var{vhash} whose key is equal to
address@hidden according to the @var{equal?} equality predicate."
+ (%vhash-assoc key vhash equal? hash))
+
+(define (vhash-assq key vhash)
+ "Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
address@hidden"
+ (%vhash-assoc key vhash eq? hashq))
+
+(define (vhash-assv key vhash)
+ "Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
address@hidden"
+ (%vhash-assoc key vhash eqv? hashv))
+
+(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
+ "Remove all associations from @var{vhash} with @var{key}, comparing keys
+with @var{equal?}."
+ (vlist-fold (lambda (k+v result)
+ (let ((k (car k+v))
+ (v (cdr k+v)))
+ (if (equal? k key)
+ result
+ (vhash-cons k v result))))
+ vlist-null
+ vhash))
+
+(define vhash-delq (cut vhash-delete <> <> eq? hashq))
+(define vhash-delv (cut vhash-delete <> <> eqv? hashv))
+
+(define (vhash-fold proc seed vhash)
+ "Fold over the key/pair elements of @var{vhash}. For each pair call
address@hidden as @code{(@var{proc} key value result)}."
+ (vlist-fold (lambda (key+value result)
+ (proc (car key+value) (cdr key+value)
+ result))
+ seed
+ vhash))
+
+(define* (alist->vhash alist #:optional (hash hash))
+ "Return the vhash corresponding to @var{alist}, an association list."
+ (fold-right (lambda (pair result)
+ (vhash-cons (car pair) (cdr pair) result hash))
+ vlist-null
+ alist))
+
+;;; vlist.scm ends here
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 541096c..946caea 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -1,6 +1,6 @@
;;; Guile Virtual Machine Assembly
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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,8 +58,6 @@
(define *program-alignment* 8)
-(define *block-alignment* 8)
-
(define (addr+ addr code)
(fold (lambda (x len) (+ (byte-length x) len))
addr
@@ -108,7 +106,7 @@
(define (object->assembly x)
(cond ((eq? x #t) `(make-true))
((eq? x #f) `(make-false))
- ((eq? x %nil) `(make-nil))
+ ((eq? x #nil) `(make-nil))
((null? x) `(make-eol))
((and (integer? x) (exact? x))
(cond ((and (<= -128 x) (< x 128))
@@ -138,7 +136,7 @@
(pmatch code
((make-true) #t)
((make-false) #f) ;; FIXME: Same as the `else' case!
- ((make-nil) %nil)
+ ((make-nil) #nil)
((make-eol) '())
((make-int8 ,n)
(if (< n 128) n (- n 256)))
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index e6fc5bc..8a4c5cd 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Guile VM assembler
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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,111 +24,87 @@
#:use-module (system vm instruction)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevector)
+ #:use-module (rnrs io ports)
#:use-module ((srfi srfi-1) #:select (fold))
- #:use-module ((system vm objcode) #:select (byte-order))
- #:export (compile-bytecode write-bytecode))
+ #:use-module ((srfi srfi-26) #:select (cut))
+ #:export (compile-bytecode))
(define (compile-bytecode assembly env . opts)
(pmatch assembly
((load-program . _)
- ;; the 1- and -1 are so that we drop the load-program byte
- (letrec ((v (make-u8vector (1- (byte-length assembly))))
- (i -1)
- (write-byte (lambda (b)
- (if (>= i 0) (u8vector-set! v i b))
- (set! i (1+ i))))
- (get-addr (lambda () i)))
- (write-bytecode assembly write-byte get-addr '())
- (if (= i (u8vector-length v))
- (values v env env)
- (error "incorrect length in assembly" i (u8vector-length v)))))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ ;; Don't emit the `load-program' byte.
+ (write-bytecode assembly port '() 0 #f)
+ (values (get-bytevector) env env))))
(else (error "bad assembly" assembly))))
-(define (write-bytecode asm write-byte get-addr labels)
- (define (write-char c)
- (write-byte (char->integer c)))
- (define (write-string s)
- (string-for-each write-char s))
- (define (write-uint16-be x)
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand x 255)))
- (define (write-uint16-le x)
- (write-byte (logand x 255))
- (write-byte (logand (ash x -8) 255)))
- (define (write-uint24-be x)
- (write-byte (logand (ash x -16) 255))
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand x 255)))
+(define (write-bytecode asm port labels address emit-opcode?)
+ ;; Write ASM's bytecode to PORT, a (binary) output port. If EMIT-OPCODE? is
+ ;; false, don't emit bytecode for the first opcode encountered. Assume code
+ ;; starts at ADDRESS (an integer). LABELS is assumed to be an alist mapping
+ ;; labels to addresses.
+ (define u32-bv (make-bytevector 4))
+ (define write-byte (cut put-u8 port <>))
+ (define get-addr
+ (let ((start (port-position port)))
+ (lambda ()
+ (+ address (- (port-position port) start)))))
+ (define (write-latin1-string s)
+ (write-loader-len (string-length s))
+ (string-for-each (lambda (c) (write-byte (char->integer c))) s))
+ (define (write-int24-be x)
+ (bytevector-s32-set! u32-bv 0 x (endianness big))
+ (put-bytevector port u32-bv 1 3))
(define (write-uint32-be x)
- (write-byte (logand (ash x -24) 255))
- (write-byte (logand (ash x -16) 255))
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand x 255)))
- (define (write-uint32-le x)
- (write-byte (logand x 255))
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand (ash x -16) 255))
- (write-byte (logand (ash x -24) 255)))
+ (bytevector-u32-set! u32-bv 0 x (endianness big))
+ (put-bytevector port u32-bv))
(define (write-uint32 x)
- (case byte-order
- ((1234) (write-uint32-le x))
- ((4321) (write-uint32-be x))
- (else (error "unknown endianness" byte-order))))
+ (bytevector-u32-native-set! u32-bv 0 x)
+ (put-bytevector port u32-bv))
(define (write-wide-string s)
(write-loader-len (* 4 (string-length s)))
- (string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
+ (put-bytevector port (string->utf32 s (native-endianness))))
(define (write-loader-len len)
(write-byte (ash len -16))
(write-byte (logand (ash len -8) 255))
(write-byte (logand len 255)))
- (define (write-loader str)
- (write-loader-len (string-length str))
- (write-string str))
(define (write-bytevector bv)
(write-loader-len (bytevector-length bv))
- ;; Ew!
- (for-each write-byte (bytevector->u8-list bv)))
+ (put-bytevector port bv))
(define (write-break label)
(let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
(cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
- (else (write-uint24-be offset)))))
+ (else (write-int24-be offset)))))
(let ((inst (car asm))
- (args (cdr asm))
- (write-uint16 (case byte-order
- ((1234) write-uint16-le)
- ((4321) write-uint16-be)
- (else (error "unknown endianness" byte-order)))))
+ (args (cdr asm)))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
- (write-byte opcode)
+ (if emit-opcode?
+ (write-byte opcode))
(pmatch asm
((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (letrec ((i 0)
- (write (lambda (x) (set! i (1+ i)) (write-byte x)))
- (get-addr (lambda () i)))
- (for-each (lambda (asm)
- (write-bytecode asm write get-addr labels))
- code))
+ (fold (lambda (asm address)
+ (let ((start (port-position port)))
+ (write-bytecode asm port labels address #t)
+ (+ address (- (port-position port) start))))
+ 0
+ code)
(if meta
- ;; don't write the load-program byte for metadata
- (letrec ((i -1)
- (write (lambda (x)
- (set! i (1+ i))
- (if (> i 0) (write-byte x))))
- (get-addr (lambda () i)))
- ;; META's bytecode meets the alignment requirements of
- ;; `scm_objcode', thanks to the alignment computed in
- ;; `(language assembly)'.
- (write-bytecode meta write get-addr '()))))
+ ;; Don't emit the `load-program' byte for metadata. Note that
+ ;; META's bytecode meets the alignment requirements of
+ ;; `scm_objcode', thanks to the alignment computed in `(language
+ ;; assembly)'.
+ (write-bytecode meta port '() 0 #f)))
((make-char32 ,x) (write-uint32-be x))
- ((load-number ,str) (write-loader str))
- ((load-string ,str) (write-loader str))
+ ((load-number ,str) (write-latin1-string str))
+ ((load-string ,str) (write-latin1-string str))
((load-wide-string ,str) (write-wide-string str))
- ((load-symbol ,str) (write-loader str))
+ ((load-symbol ,str) (write-latin1-string str))
((load-array ,bv) (write-bytevector bv))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
@@ -141,6 +117,7 @@
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
+ ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else
(cond
((< (instruction-length inst) 0)
diff --git a/module/language/assembly/decompile-bytecode.scm
b/module/language/assembly/decompile-bytecode.scm
index 6d41da2..3ae96d2 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -90,6 +90,8 @@
(lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3))
out)))
((mv-call ,n ,rel1 ,rel2 ,rel3)
(lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
+ ((prompt ,n0 ,rel1 ,rel2 ,rel3)
+ (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
(else
(lp (cons exp out))))))))))
diff --git a/module/language/assembly/disassemble.scm
b/module/language/assembly/disassemble.scm
index 2c0ad4f..4cac32a 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -88,13 +88,6 @@
(else
(error "bad load-program form" asm))))
-(define (disassemble-objects objs)
- (display "Objects:\n\n")
- (let ((len (vector-length objs)))
- (do ((n 0 (1+ n)))
- ((= n len) (newline))
- (print-info n (vector-ref objs n) #f #f))))
-
(define (disassemble-free-vars free-vars)
(display "Free variables:\n\n")
(let lp ((i 0))
@@ -110,7 +103,7 @@
(define (disassemble-meta meta)
(let ((props (filter (lambda (x)
(not (memq (car x) *uninteresting-props*)))
- (cddr meta))))
+ (cdddr meta))))
(unless (null? props)
(display "Properties:\n\n")
(for-each (lambda (x) (print-info #f x #f #f)) props)
@@ -157,6 +150,9 @@
(list "`~s'" v)))))
((mv-call)
(list "MV -> ~A" (assq-ref labels (cadr args))))
+ ((prompt)
+ ;; the H is for handler
+ (list "H -> ~A" (assq-ref labels (cadr args))))
(else
(and=> (assembly->object code)
(lambda (obj) (list "~s" obj)))))))
@@ -164,12 +160,3 @@
;; i am format's daddy.
(define (print-info addr info extra src)
(format #t "address@hidden address@hidden;; address@hidden@[~61t at
~a~]\n" addr info extra src))
-
-(define (simplify x)
- (cond ((string? x)
- (cond ((string-index x #\newline) =>
- (lambda (i) (set! x (substring x 0 i)))))
- (cond ((> (string-length x) 16)
- (set! x (string-append (substring x 0 13) "..."))))))
- x)
-
diff --git a/module/language/ecmascript/array.scm
b/module/language/ecmascript/array.scm
index e9fc3c6..9970345 100644
--- a/module/language/ecmascript/array.scm
+++ b/module/language/ecmascript/array.scm
@@ -1,6 +1,6 @@
;;; ECMAScript for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -63,12 +63,12 @@
(cond ((and (integer? p) (exact? p) (>= 0 p))
(let ((vect (js-array-vector o)))
(if (< p (vector-length vect))
- (vector-set! vect p)
+ (vector-set! vect p v)
;; Fixme: round up to powers of 2?
(let ((new (make-vector (1+ p) 0)))
(vector-move-left! vect 0 (vector-length vect) new 0)
(set! (js-array-vector o) new)
- (vector-set! new p)))))
+ (vector-set! new p v)))))
((or (and (symbol? p) (eq? p 'length))
(and (string? p) (string=? p "length")))
(let ((vect (js-array-vector o)))
@@ -93,7 +93,7 @@
((is-a? (car objs) <js-array-object>)
(let ((v (js-array-vector (car objs))))
(vector-move-left! v 0 (vector-length v)
- rv i (+ i (vector-length v)))
+ rv i)
(lp (cdr objs) (+ i (vector-length v)))))
(else
(error "generic array concats not yet implemented"))))))
diff --git a/module/language/ecmascript/parse-lalr.scm
b/module/language/ecmascript/parse-lalr.scm
deleted file mode 100644
index b702511..0000000
--- a/module/language/ecmascript/parse-lalr.scm
+++ /dev/null
@@ -1,1731 +0,0 @@
-;; (language ecmascript parse-lalr) -- yacc's parser generator, in Guile
-;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc.
-;; Copyright (C) 1996-2002 Dominique Boucher
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-
-;; ---------------------------------------------------------------------- ;;
-#!
-;;; Commentary:
-This file contains yet another LALR(1) parser generator written in
-Scheme. In contrast to other such parser generators, this one
-implements a more efficient algorithm for computing the lookahead sets.
-The algorithm is the same as used in Bison (GNU yacc) and is described
-in the following paper:
-
-"Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and
-T. Pennello, TOPLAS, vol. 4, no. 4, october 1982.
-
-As a consequence, it is not written in a fully functional style.
-In fact, much of the code is a direct translation from C to Scheme
-of the Bison sources.
-
address@hidden Defining a parser
-
-The module @code{(language ecmascript parse-lalr)} declares a macro
-called @code{lalr-parser}:
-
address@hidden
- (lalr-parser tokens rules ...)
address@hidden lisp
-
-This macro, when given appropriate arguments, generates an LALR(1)
-syntax analyzer. The macro accepts at least two arguments. The first
-is a list of symbols which represent the terminal symbols of the
-grammar. The remaining arguments are the grammar production rules.
-
address@hidden Running the parser
-
-The parser generated by the @code{lalr-parser} macro is a function that
-takes two parameters. The first parameter is a lexical analyzer while
-the second is an error procedure.
-
-The lexical analyzer is zero-argument function (a thunk)
-invoked each time the parser needs to look-ahead in the token stream.
-A token is usually a pair whose @code{car} is the symbol corresponding to
-the token (the same symbol as used in the grammar definition). The
address@hidden of the pair is the semantic value associated with the token. For
-example, a string token would have the @code{car} set to @code{'string}
-while the @code{cdr} is set to the string value @code{"hello"}.
-
-Once the end of file is encountered, the lexical analyzer must always
-return the symbol @code{'*eoi*} each time it is invoked.
-
-The error procedure must be a function that accepts at least two
-parameters.
-
address@hidden The grammar format
-
-The grammar is specified by first giving the list of terminals and the
-list of non-terminal definitions. Each non-terminal definition
-is a list where the first element is the non-terminal and the other
-elements are the right-hand sides (lists of grammar symbols). In
-addition to this, each rhs can be followed by a semantic action.
-
-For example, consider the following (yacc) grammar for a very simple
-expression language:
address@hidden
- e : e '+' t
- | e '-' t
- | t
- ;
- t : t '*' f
- : t '/' f
- | f
- ;
- f : ID
- ;
address@hidden example
-The same grammar, written for the scheme parser generator, would look
-like this (with semantic actions)
address@hidden
-(define expr-parser
- (lalr-parser
- ; Terminal symbols
- (ID + - * /)
- ; Productions
- (e (e + t) -> (+ $1 $3)
- (e - t) -> (- $1 $3)
- (t) -> $1)
- (t (t * f) -> (* $1 $3)
- (t / f) -> (/ $1 $3)
- (f) -> $1)
- (f (ID) -> $1)))
address@hidden lisp
-In semantic actions, the symbol @code{$n} refers to the synthesized
-attribute value of the nth symbol in the production. The value
-associated with the non-terminal on the left is the result of
-evaluating the semantic action (it defaults to @code{#f}).
-
-The above grammar implicitly handles operator precedences. It is also
-possible to explicitly assign precedences and associativity to
-terminal symbols and productions a la Yacc. Here is a modified
-(and augmented) version of the grammar:
address@hidden
-(define expr-parser
- (lalr-parser
- ; Terminal symbols
- (ID
- (left: + -)
- (left: * /)
- (nonassoc: uminus))
- (e (e + e) -> (+ $1 $3)
- (e - e) -> (- $1 $3)
- (e * e) -> (* $1 $3)
- (e / e) -> (/ $1 $3)
- (- e (prec: uminus)) -> (- $2)
- (ID) -> $1)))
address@hidden lisp
-The @code{left:} directive is used to specify a set of left-associative
-operators of the same precedence level, the @code{right:} directive for
-right-associative operators, and @code{nonassoc:} for operators that
-are not associative. Note the use of the (apparently) useless
-terminal @code{uminus}. It is only defined in order to assign to the
-penultimate rule a precedence level higher than that of @code{*} and
address@hidden/}. The @code{prec:} directive can only appear as the last
element of a
-rule. Finally, note that precedence levels are incremented from
-left to right, i.e. the precedence level of @code{+} and @code{-} is less
-than the precedence level of @code{*} and @code{/} since the formers appear
-first in the list of terminal symbols (token definitions).
-
address@hidden A final note on conflict resolution
-
-Conflicts in the grammar are handled in a conventional way.
-In the absence of precedence directives,
-Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce
-conflicts are resolved by choosing the rule listed first in the
-grammar definition.
-
-You can print the states of the generated parser by evaluating
address@hidden(print-states)}. The format of the output is similar to the one
-produced by bison when given the -v command-line option.
-;;; Code:
-!#
-
-;;; ---------- SYSTEM DEPENDENT SECTION -----------------
-;; put in a module by Richard Todd
-(define-module (language ecmascript parse-lalr)
- #:export (lalr-parser
- print-states))
-
-;; this code is by Thien-Thi Nguyen, found in a google search
-(begin
- (defmacro def-macro (form . body)
- `(defmacro ,(car form) ,(cdr form) ,@body))
- (def-macro (BITS-PER-WORD) 28)
- (def-macro (lalr-error msg obj) `(throw 'lalr-error ,msg ,obj))
- (def-macro (logical-or x . y) `(logior ,x ,@y)))
-
-;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------
-
-;; - Macros pour la gestion des vecteurs de bits
-
-(def-macro (set-bit v b)
- `(let ((x (quotient ,b (BITS-PER-WORD)))
- (y (expt 2 (remainder ,b (BITS-PER-WORD)))))
- (vector-set! ,v x (logical-or (vector-ref ,v x) y))))
-
-(def-macro (bit-union v1 v2 n)
- `(do ((i 0 (+ i 1)))
- ((= i ,n))
- (vector-set! ,v1 i (logical-or (vector-ref ,v1 i)
- (vector-ref ,v2 i)))))
-
-;; - Macro pour les structures de donnees
-
-(def-macro (new-core) `(make-vector 4 0))
-(def-macro (set-core-number! c n) `(vector-set! ,c 0 ,n))
-(def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s))
-(def-macro (set-core-nitems! c n) `(vector-set! ,c 2 ,n))
-(def-macro (set-core-items! c i) `(vector-set! ,c 3 ,i))
-(def-macro (core-number c) `(vector-ref ,c 0))
-(def-macro (core-acc-sym c) `(vector-ref ,c 1))
-(def-macro (core-nitems c) `(vector-ref ,c 2))
-(def-macro (core-items c) `(vector-ref ,c 3))
-
-(def-macro (new-shift) `(make-vector 3 0))
-(def-macro (set-shift-number! c x) `(vector-set! ,c 0 ,x))
-(def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x))
-(def-macro (set-shift-shifts! c x) `(vector-set! ,c 2 ,x))
-(def-macro (shift-number s) `(vector-ref ,s 0))
-(def-macro (shift-nshifts s) `(vector-ref ,s 1))
-(def-macro (shift-shifts s) `(vector-ref ,s 2))
-
-(def-macro (new-red) `(make-vector 3 0))
-(def-macro (set-red-number! c x) `(vector-set! ,c 0 ,x))
-(def-macro (set-red-nreds! c x) `(vector-set! ,c 1 ,x))
-(def-macro (set-red-rules! c x) `(vector-set! ,c 2 ,x))
-(def-macro (red-number c) `(vector-ref ,c 0))
-(def-macro (red-nreds c) `(vector-ref ,c 1))
-(def-macro (red-rules c) `(vector-ref ,c 2))
-
-
-
-(def-macro (new-set nelem)
- `(make-vector ,nelem 0))
-
-
-(def-macro (vector-map f v)
- `(let ((vm-n (- (vector-length ,v) 1)))
- (let loop ((vm-low 0) (vm-high vm-n))
- (if (= vm-low vm-high)
- (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low))
- (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
- (loop vm-low vm-middle)
- (loop (+ vm-middle 1) vm-high))))))
-
-
-;; - Constantes
-(define STATE-TABLE-SIZE 1009)
-
-
-;; - Tableaux
-(define rrhs #f)
-(define rlhs #f)
-(define ritem #f)
-(define nullable #f)
-(define derives #f)
-(define fderives #f)
-(define firsts #f)
-(define kernel-base #f)
-(define kernel-end #f)
-(define shift-symbol #f)
-(define shift-set #f)
-(define red-set #f)
-(define state-table #f)
-(define acces-symbol #f)
-(define reduction-table #f)
-(define shift-table #f)
-(define consistent #f)
-(define lookaheads #f)
-(define LA #f)
-(define LAruleno #f)
-(define lookback #f)
-(define goto-map #f)
-(define from-state #f)
-(define to-state #f)
-(define includes #f)
-(define F #f)
-(define action-table #f)
-
-;; - Variables
-(define nitems #f)
-(define nrules #f)
-(define nvars #f)
-(define nterms #f)
-(define nsyms #f)
-(define nstates #f)
-(define first-state #f)
-(define last-state #f)
-(define final-state #f)
-(define first-shift #f)
-(define last-shift #f)
-(define first-reduction #f)
-(define last-reduction #f)
-(define nshifts #f)
-(define maxrhs #f)
-(define ngotos #f)
-(define token-set-size #f)
-
-(define (gen-tables! tokens gram)
- (initialize-all)
- (rewrite-grammar
- tokens
- gram
- (lambda (terms terms/prec vars gram gram/actions)
- (set! the-terminals/prec (list->vector terms/prec))
- (set! the-terminals (list->vector terms))
- (set! the-nonterminals (list->vector vars))
- (set! nterms (length terms))
- (set! nvars (length vars))
- (set! nsyms (+ nterms nvars))
- (let ((no-of-rules (length gram/actions))
- (no-of-items (let loop ((l gram/actions) (count 0))
- (if (null? l)
- count
- (loop (cdr l) (+ count (length (caar l))))))))
- (pack-grammar no-of-rules no-of-items gram)
- (set-derives)
- (set-nullable)
- (generate-states)
- (lalr)
- (build-tables)
- (compact-action-table terms)
- gram/actions))))
-
-
-(define (initialize-all)
- (set! rrhs #f)
- (set! rlhs #f)
- (set! ritem #f)
- (set! nullable #f)
- (set! derives #f)
- (set! fderives #f)
- (set! firsts #f)
- (set! kernel-base #f)
- (set! kernel-end #f)
- (set! shift-symbol #f)
- (set! shift-set #f)
- (set! red-set #f)
- (set! state-table (make-vector STATE-TABLE-SIZE '()))
- (set! acces-symbol #f)
- (set! reduction-table #f)
- (set! shift-table #f)
- (set! consistent #f)
- (set! lookaheads #f)
- (set! LA #f)
- (set! LAruleno #f)
- (set! lookback #f)
- (set! goto-map #f)
- (set! from-state #f)
- (set! to-state #f)
- (set! includes #f)
- (set! F #f)
- (set! action-table #f)
- (set! nstates #f)
- (set! first-state #f)
- (set! last-state #f)
- (set! final-state #f)
- (set! first-shift #f)
- (set! last-shift #f)
- (set! first-reduction #f)
- (set! last-reduction #f)
- (set! nshifts #f)
- (set! maxrhs #f)
- (set! ngotos #f)
- (set! token-set-size #f)
- (set! rule-precedences '()))
-
-
-(define (pack-grammar no-of-rules no-of-items gram)
- (set! nrules (+ no-of-rules 1))
- (set! nitems no-of-items)
- (set! rlhs (make-vector nrules #f))
- (set! rrhs (make-vector nrules #f))
- (set! ritem (make-vector (+ 1 nitems) #f))
-
- (let loop ((p gram) (item-no 0) (rule-no 1))
- (if (not (null? p))
- (let ((nt (caar p)))
- (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
- (if (null? prods)
- (loop (cdr p) it-no2 rl-no2)
- (begin
- (vector-set! rlhs rl-no2 nt)
- (vector-set! rrhs rl-no2 it-no2)
- (let loop3 ((rhs (car prods)) (it-no3 it-no2))
- (if (null? rhs)
- (begin
- (vector-set! ritem it-no3 (- rl-no2))
- (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
- (begin
- (vector-set! ritem it-no3 (car rhs))
- (loop3 (cdr rhs) (+ it-no3 1))))))))))))
-
-
-;; Fonction set-derives
-;; --------------------
-(define (set-derives)
- (define delts (make-vector (+ nrules 1) 0))
- (define dset (make-vector nvars -1))
-
- (let loop ((i 1) (j 0)) ; i = 0
- (if (< i nrules)
- (let ((lhs (vector-ref rlhs i)))
- (if (>= lhs 0)
- (begin
- (vector-set! delts j (cons i (vector-ref dset lhs)))
- (vector-set! dset lhs j)
- (loop (+ i 1) (+ j 1)))
- (loop (+ i 1) j)))))
-
- (set! derives (make-vector nvars 0))
-
- (let loop ((i 0))
- (if (< i nvars)
- (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
- (if (< j 0)
- s
- (let ((x (vector-ref delts j)))
- (loop2 (cdr x) (cons (car x) s)))))))
- (vector-set! derives i q)
- (loop (+ i 1))))))
-
-
-
-(define (set-nullable)
- (set! nullable (make-vector nvars #f))
- (let ((squeue (make-vector nvars #f))
- (rcount (make-vector (+ nrules 1) 0))
- (rsets (make-vector nvars #f))
- (relts (make-vector (+ nitems nvars 1) #f)))
- (let loop ((r 0) (s2 0) (p 0))
- (let ((*r (vector-ref ritem r)))
- (if *r
- (if (< *r 0)
- (let ((symbol (vector-ref rlhs (- *r))))
- (if (and (>= symbol 0)
- (not (vector-ref nullable symbol)))
- (begin
- (vector-set! nullable symbol #t)
- (vector-set! squeue s2 symbol)
- (loop (+ r 1) (+ s2 1) p))))
- (let loop2 ((r1 r) (any-tokens #f))
- (let* ((symbol (vector-ref ritem r1)))
- (if (> symbol 0)
- (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
- (if (not any-tokens)
- (let ((ruleno (- symbol)))
- (let loop3 ((r2 r) (p2 p))
- (let ((symbol (vector-ref ritem r2)))
- (if (> symbol 0)
- (begin
- (vector-set! rcount ruleno
- (+ (vector-ref rcount
ruleno) 1))
- (vector-set! relts p2
- (cons (vector-ref rsets
symbol)
- ruleno))
- (vector-set! rsets symbol p2)
- (loop3 (+ r2 1) (+ p2 1)))
- (loop (+ r2 1) s2 p2)))))
- (loop (+ r1 1) s2 p))))))
- (let loop ((s1 0) (s3 s2))
- (if (< s1 s3)
- (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4
s3))
- (if p
- (let* ((x (vector-ref relts p))
- (ruleno (cdr x))
- (y (- (vector-ref rcount ruleno) 1)))
- (vector-set! rcount ruleno y)
- (if (= y 0)
- (let ((symbol (vector-ref rlhs ruleno)))
- (if (and (>= symbol 0)
- (not (vector-ref nullable symbol)))
- (begin
- (vector-set! nullable symbol #t)
- (vector-set! squeue s4 symbol)
- (loop2 (car x) (+ s4 1)))
- (loop2 (car x) s4)))
- (loop2 (car x) s4))))
- (loop (+ s1 1) s4)))))))))
-
-
-
-; Fonction set-firsts qui calcule un tableau de taille
-; nvars et qui donne, pour chaque non-terminal X, une liste des
-; non-terminaux pouvant apparaitre au debut d'une derivation a
-; partir de X.
-
-(define (set-firsts)
- (set! firsts (make-vector nvars '()))
-
- ;; -- initialization
- (let loop ((i 0))
- (if (< i nvars)
- (let loop2 ((sp (vector-ref derives i)))
- (if (null? sp)
- (loop (+ i 1))
- (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
- (if (< -1 sym nvars)
- (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
- (loop2 (cdr sp)))))))
-
- ;; -- reflexive and transitive closure
- (let loop ((continue #t))
- (if continue
- (let loop2 ((i 0) (cont #f))
- (if (>= i nvars)
- (loop cont)
- (let* ((x (vector-ref firsts i))
- (y (let loop3 ((l x) (z x))
- (if (null? l)
- z
- (loop3 (cdr l)
- (sunion (vector-ref firsts (car l)) z))))))
- (if (equal? x y)
- (loop2 (+ i 1) cont)
- (begin
- (vector-set! firsts i y)
- (loop2 (+ i 1) #t))))))))
-
- (let loop ((i 0))
- (if (< i nvars)
- (begin
- (vector-set! firsts i (sinsert i (vector-ref firsts i)))
- (loop (+ i 1))))))
-
-
-
-
-; Fonction set-fderives qui calcule un tableau de taille
-; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant
-; etre derivees a partir de ce non-terminal. (se sert de firsts)
-
-(define (set-fderives)
- (set! fderives (make-vector nvars #f))
-
- (set-firsts)
-
- (let loop ((i 0))
- (if (< i nvars)
- (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
- (if (null? l)
- fd
- (loop2 (cdr l)
- (sunion (vector-ref derives (car l)) fd))))))
- (vector-set! fderives i x)
- (loop (+ i 1))))))
-
-
-; Fonction calculant la fermeture d'un ensemble d'items LR0
-; ou core est une liste d'items
-
-(define (closure core)
- ;; Initialization
- (define ruleset (make-vector nrules #f))
-
- (let loop ((csp core))
- (if (not (null? csp))
- (let ((sym (vector-ref ritem (car csp))))
- (if (< -1 sym nvars)
- (let loop2 ((dsp (vector-ref fderives sym)))
- (if (not (null? dsp))
- (begin
- (vector-set! ruleset (car dsp) #t)
- (loop2 (cdr dsp))))))
- (loop (cdr csp)))))
-
- (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
- (if (< ruleno nrules)
- (if (vector-ref ruleset ruleno)
- (let ((itemno (vector-ref rrhs ruleno)))
- (let loop2 ((c csp) (itemsetv2 itemsetv))
- (if (and (pair? c)
- (< (car c) itemno))
- (loop2 (cdr c) (cons (car c) itemsetv2))
- (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
- (loop (+ ruleno 1) csp itemsetv))
- (let loop2 ((c csp) (itemsetv2 itemsetv))
- (if (pair? c)
- (loop2 (cdr c) (cons (car c) itemsetv2))
- (reverse itemsetv2))))))
-
-
-
-(define (allocate-item-sets)
- (set! kernel-base (make-vector nsyms 0))
- (set! kernel-end (make-vector nsyms #f)))
-
-
-(define (allocate-storage)
- (allocate-item-sets)
- (set! red-set (make-vector (+ nrules 1) 0)))
-
-;; --
-
-
-(define (initialize-states)
- (let ((p (new-core)))
- (set-core-number! p 0)
- (set-core-acc-sym! p #f)
- (set-core-nitems! p 1)
- (set-core-items! p '(0))
-
- (set! first-state (list p))
- (set! last-state first-state)
- (set! nstates 1)))
-
-
-
-(define (generate-states)
- (allocate-storage)
- (set-fderives)
- (initialize-states)
- (let loop ((this-state first-state))
- (if (pair? this-state)
- (let* ((x (car this-state))
- (is (closure (core-items x))))
- (save-reductions x is)
- (new-itemsets is)
- (append-states)
- (if (> nshifts 0)
- (save-shifts x))
- (loop (cdr this-state))))))
-
-
-;; Fonction calculant les symboles sur lesquels il faut "shifter"
-;; et regroupe les items en fonction de ces symboles
-
-(define (new-itemsets itemset)
- ;; - Initialization
- (set! shift-symbol '())
- (let loop ((i 0))
- (if (< i nsyms)
- (begin
- (vector-set! kernel-end i '())
- (loop (+ i 1)))))
-
- (let loop ((isp itemset))
- (if (pair? isp)
- (let* ((i (car isp))
- (sym (vector-ref ritem i)))
- (if (>= sym 0)
- (begin
- (set! shift-symbol (sinsert sym shift-symbol))
- (let ((x (vector-ref kernel-end sym)))
- (if (null? x)
- (begin
- (vector-set! kernel-base sym (cons (+ i 1) x))
- (vector-set! kernel-end sym (vector-ref kernel-base
sym)))
- (begin
- (set-cdr! x (list (+ i 1)))
- (vector-set! kernel-end sym (cdr x)))))))
- (loop (cdr isp)))))
-
- (set! nshifts (length shift-symbol)))
-
-
-
-(define (get-state sym)
- (let* ((isp (vector-ref kernel-base sym))
- (n (length isp))
- (key (let loop ((isp1 isp) (k 0))
- (if (null? isp1)
- (modulo k STATE-TABLE-SIZE)
- (loop (cdr isp1) (+ k (car isp1))))))
- (sp (vector-ref state-table key)))
- (if (null? sp)
- (let ((x (new-state sym)))
- (vector-set! state-table key (list x))
- (core-number x))
- (let loop ((sp1 sp))
- (if (and (= n (core-nitems (car sp1)))
- (let loop2 ((i1 isp) (t (core-items (car sp1))))
- (if (and (pair? i1)
- (= (car i1)
- (car t)))
- (loop2 (cdr i1) (cdr t))
- (null? i1))))
- (core-number (car sp1))
- (if (null? (cdr sp1))
- (let ((x (new-state sym)))
- (set-cdr! sp1 (list x))
- (core-number x))
- (loop (cdr sp1))))))))
-
-
-(define (new-state sym)
- (let* ((isp (vector-ref kernel-base sym))
- (n (length isp))
- (p (new-core)))
- (set-core-number! p nstates)
- (set-core-acc-sym! p sym)
- (if (= sym nvars) (set! final-state nstates))
- (set-core-nitems! p n)
- (set-core-items! p isp)
- (set-cdr! last-state (list p))
- (set! last-state (cdr last-state))
- (set! nstates (+ nstates 1))
- p))
-
-
-;; --
-
-(define (append-states)
- (set! shift-set
- (let loop ((l (reverse shift-symbol)))
- (if (null? l)
- '()
- (cons (get-state (car l)) (loop (cdr l)))))))
-
-;; --
-
-(define (save-shifts core)
- (let ((p (new-shift)))
- (set-shift-number! p (core-number core))
- (set-shift-nshifts! p nshifts)
- (set-shift-shifts! p shift-set)
- (if last-shift
- (begin
- (set-cdr! last-shift (list p))
- (set! last-shift (cdr last-shift)))
- (begin
- (set! first-shift (list p))
- (set! last-shift first-shift)))))
-
-(define (save-reductions core itemset)
- (let ((rs (let loop ((l itemset))
- (if (null? l)
- '()
- (let ((item (vector-ref ritem (car l))))
- (if (< item 0)
- (cons (- item) (loop (cdr l)))
- (loop (cdr l))))))))
- (if (pair? rs)
- (let ((p (new-red)))
- (set-red-number! p (core-number core))
- (set-red-nreds! p (length rs))
- (set-red-rules! p rs)
- (if last-reduction
- (begin
- (set-cdr! last-reduction (list p))
- (set! last-reduction (cdr last-reduction)))
- (begin
- (set! first-reduction (list p))
- (set! last-reduction first-reduction)))))))
-
-
-;; --
-
-(define (lalr)
- (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
- (set-accessing-symbol)
- (set-shift-table)
- (set-reduction-table)
- (set-max-rhs)
- (initialize-LA)
- (set-goto-map)
- (initialize-F)
- (build-relations)
- (digraph includes)
- (compute-lookaheads))
-
-(define (set-accessing-symbol)
- (set! acces-symbol (make-vector nstates #f))
- (let loop ((l first-state))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! acces-symbol (core-number x) (core-acc-sym x))
- (loop (cdr l))))))
-
-(define (set-shift-table)
- (set! shift-table (make-vector nstates #f))
- (let loop ((l first-shift))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! shift-table (shift-number x) x)
- (loop (cdr l))))))
-
-(define (set-reduction-table)
- (set! reduction-table (make-vector nstates #f))
- (let loop ((l first-reduction))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! reduction-table (red-number x) x)
- (loop (cdr l))))))
-
-(define (set-max-rhs)
- (let loop ((p 0) (curmax 0) (length 0))
- (let ((x (vector-ref ritem p)))
- (if x
- (if (>= x 0)
- (loop (+ p 1) curmax (+ length 1))
- (loop (+ p 1) (max curmax length) 0))
- (set! maxrhs curmax)))))
-
-(define (initialize-LA)
- (define (last l)
- (if (null? (cdr l))
- (car l)
- (last (cdr l))))
-
- (set! consistent (make-vector nstates #f))
- (set! lookaheads (make-vector (+ nstates 1) #f))
-
- (let loop ((count 0) (i 0))
- (if (< i nstates)
- (begin
- (vector-set! lookaheads i count)
- (let ((rp (vector-ref reduction-table i))
- (sp (vector-ref shift-table i)))
- (if (and rp
- (or (> (red-nreds rp) 1)
- (and sp
- (not
- (< (vector-ref acces-symbol
- (last (shift-shifts sp)))
- nvars)))))
- (loop (+ count (red-nreds rp)) (+ i 1))
- (begin
- (vector-set! consistent i #t)
- (loop count (+ i 1))))))
-
- (begin
- (vector-set! lookaheads nstates count)
- (let ((c (max count 1)))
- (set! LA (make-vector c #f))
- (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set
token-set-size)))
- (set! LAruleno (make-vector c -1))
- (set! lookback (make-vector c #f)))
- (let loop ((i 0) (np 0))
- (if (< i nstates)
- (if (vector-ref consistent i)
- (loop (+ i 1) np)
- (let ((rp (vector-ref reduction-table i)))
- (if rp
- (let loop2 ((j (red-rules rp)) (np2 np))
- (if (null? j)
- (loop (+ i 1) np2)
- (begin
- (vector-set! LAruleno np2 (car j))
- (loop2 (cdr j) (+ np2 1)))))
- (loop (+ i 1) np))))))))))
-
-
-(define (set-goto-map)
- (set! goto-map (make-vector (+ nvars 1) 0))
- (let ((temp-map (make-vector (+ nvars 1) 0)))
- (let loop ((ng 0) (sp first-shift))
- (if (pair? sp)
- (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
- (if (pair? i)
- (let ((symbol (vector-ref acces-symbol (car i))))
- (if (< symbol nvars)
- (begin
- (vector-set! goto-map symbol
- (+ 1 (vector-ref goto-map symbol)))
- (loop2 (cdr i) (+ ng2 1)))
- (loop2 (cdr i) ng2)))
- (loop ng2 (cdr sp))))
-
- (let loop ((k 0) (i 0))
- (if (< i nvars)
- (begin
- (vector-set! temp-map i k)
- (loop (+ k (vector-ref goto-map i)) (+ i 1)))
-
- (begin
- (do ((i 0 (+ i 1)))
- ((>= i nvars))
- (vector-set! goto-map i (vector-ref temp-map i)))
-
- (set! ngotos ng)
- (vector-set! goto-map nvars ngotos)
- (vector-set! temp-map nvars ngotos)
- (set! from-state (make-vector ngotos #f))
- (set! to-state (make-vector ngotos #f))
-
- (do ((sp first-shift (cdr sp)))
- ((null? sp))
- (let* ((x (car sp))
- (state1 (shift-number x)))
- (do ((i (shift-shifts x) (cdr i)))
- ((null? i))
- (let* ((state2 (car i))
- (symbol (vector-ref acces-symbol state2)))
- (if (< symbol nvars)
- (let ((k (vector-ref temp-map symbol)))
- (vector-set! temp-map symbol (+ k 1))
- (vector-set! from-state k state1)
- (vector-set! to-state k state2))))))))))))))
-
-
-(define (map-goto state symbol)
- (let loop ((low (vector-ref goto-map symbol))
- (high (- (vector-ref goto-map (+ symbol 1)) 1)))
- (if (> low high)
- (begin
- (display (list "Error in map-goto" state symbol) (current-error-port))
- (newline (current-error-port))
- 0)
- (let* ((middle (quotient (+ low high) 2))
- (s (vector-ref from-state middle)))
- (cond
- ((= s state)
- middle)
- ((< s state)
- (loop (+ middle 1) high))
- (else
- (loop low (- middle 1))))))))
-
-
-(define (initialize-F)
- (set! F (make-vector ngotos #f))
- (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set
token-set-size)))
-
- (let ((reads (make-vector ngotos #f)))
-
- (let loop ((i 0) (rowp 0))
- (if (< i ngotos)
- (let* ((rowf (vector-ref F rowp))
- (stateno (vector-ref to-state i))
- (sp (vector-ref shift-table stateno)))
- (if sp
- (let loop2 ((j (shift-shifts sp)) (edges '()))
- (if (pair? j)
- (let ((symbol (vector-ref acces-symbol (car j))))
- (if (< symbol nvars)
- (if (vector-ref nullable symbol)
- (loop2 (cdr j) (cons (map-goto stateno symbol)
- edges))
- (loop2 (cdr j) edges))
- (begin
- (set-bit rowf (- symbol nvars))
- (loop2 (cdr j) edges))))
- (if (pair? edges)
- (vector-set! reads i (reverse edges))))))
- (loop (+ i 1) (+ rowp 1)))))
- (digraph reads)))
-
-(define (add-lookback-edge stateno ruleno gotono)
- (let ((k (vector-ref lookaheads (+ stateno 1))))
- (let loop ((found #f) (i (vector-ref lookaheads stateno)))
- (if (and (not found) (< i k))
- (if (= (vector-ref LAruleno i) ruleno)
- (loop #t i)
- (loop found (+ i 1)))
-
- (if (not found)
- (begin (display "Error in add-lookback-edge : "
(current-error-port))
- (display (list stateno ruleno gotono) (current-error-port))
- (newline (current-error-port)))
- (vector-set! lookback i
- (cons gotono (vector-ref lookback i))))))))
-
-
-(define (transpose r-arg n)
- (let ((new-end (make-vector n #f))
- (new-R (make-vector n #f)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((x (list 'bidon)))
- (vector-set! new-R i x)
- (vector-set! new-end i x)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((sp (vector-ref r-arg i)))
- (if (pair? sp)
- (let loop ((sp2 sp))
- (if (pair? sp2)
- (let* ((x (car sp2))
- (y (vector-ref new-end x)))
- (set-cdr! y (cons i (cdr y)))
- (vector-set! new-end x (cdr y))
- (loop (cdr sp2))))))))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (vector-set! new-R i (cdr (vector-ref new-R i))))
-
- new-R))
-
-
-
-(define (build-relations)
-
- (define (get-state stateno symbol)
- (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
- (stno stateno))
- (if (null? j)
- stno
- (let ((st2 (car j)))
- (if (= (vector-ref acces-symbol st2) symbol)
- st2
- (loop (cdr j) st2))))))
-
- (set! includes (make-vector ngotos #f))
- (do ((i 0 (+ i 1)))
- ((= i ngotos))
- (let ((state1 (vector-ref from-state i))
- (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
- (let loop ((rulep (vector-ref derives symbol1))
- (edges '()))
- (if (pair? rulep)
- (let ((*rulep (car rulep)))
- (let loop2 ((rp (vector-ref rrhs *rulep))
- (stateno state1)
- (states (list state1)))
- (let ((*rp (vector-ref ritem rp)))
- (if (> *rp 0)
- (let ((st (get-state stateno *rp)))
- (loop2 (+ rp 1) st (cons st states)))
- (begin
-
- (if (not (vector-ref consistent stateno))
- (add-lookback-edge stateno *rulep i))
-
- (let loop2 ((done #f)
- (stp (cdr states))
- (rp2 (- rp 1))
- (edgp edges))
- (if (not done)
- (let ((*rp (vector-ref ritem rp2)))
- (if (< -1 *rp nvars)
- (loop2 (not (vector-ref nullable *rp))
- (cdr stp)
- (- rp2 1)
- (cons (map-goto (car stp) *rp) edgp))
- (loop2 #t stp rp2 edgp)))
-
- (loop (cdr rulep) edgp))))))))
- (vector-set! includes i edges)))))
- (set! includes (transpose includes ngotos)))
-
-
-
-(define (compute-lookaheads)
- (let ((n (vector-ref lookaheads nstates)))
- (let loop ((i 0))
- (if (< i n)
- (let loop2 ((sp (vector-ref lookback i)))
- (if (pair? sp)
- (let ((LA-i (vector-ref LA i))
- (F-j (vector-ref F (car sp))))
- (bit-union LA-i F-j token-set-size)
- (loop2 (cdr sp)))
- (loop (+ i 1))))))))
-
-
-
-(define (digraph relation)
- (define infinity (+ ngotos 2))
- (define INDEX (make-vector (+ ngotos 1) 0))
- (define VERTICES (make-vector (+ ngotos 1) 0))
- (define top 0)
- (define R relation)
-
- (define (traverse i)
- (set! top (+ 1 top))
- (vector-set! VERTICES top i)
- (let ((height top))
- (vector-set! INDEX i height)
- (let ((rp (vector-ref R i)))
- (if (pair? rp)
- (let loop ((rp2 rp))
- (if (pair? rp2)
- (let ((j (car rp2)))
- (if (= 0 (vector-ref INDEX j))
- (traverse j))
- (if (> (vector-ref INDEX i)
- (vector-ref INDEX j))
- (vector-set! INDEX i (vector-ref INDEX j)))
- (let ((F-i (vector-ref F i))
- (F-j (vector-ref F j)))
- (bit-union F-i F-j token-set-size))
- (loop (cdr rp2))))))
- (if (= (vector-ref INDEX i) height)
- (let loop ()
- (let ((j (vector-ref VERTICES top)))
- (set! top (- top 1))
- (vector-set! INDEX j infinity)
- (if (not (= i j))
- (begin
- (bit-union (vector-ref F i)
- (vector-ref F j)
- token-set-size)
- (loop)))))))))
-
- (let loop ((i 0))
- (if (< i ngotos)
- (begin
- (if (and (= 0 (vector-ref INDEX i))
- (pair? (vector-ref R i)))
- (traverse i))
- (loop (+ i 1))))))
-
-
-;; ---------------------------------------------------------------------- ;;
-;; operator precedence management ;;
-;; ---------------------------------------------------------------------- ;;
-
-; a vector of precedence descriptors where each element
-; is of the form (terminal type precedence)
-(define the-terminals/prec #f) ; terminal symbols with precedence
-; the precedence is an integer >= 0
-(define (get-symbol-precedence sym)
- (caddr (vector-ref the-terminals/prec sym)))
-; the operator type is either 'none, 'left, 'right, or 'nonassoc
-(define (get-symbol-assoc sym)
- (cadr (vector-ref the-terminals/prec sym)))
-
-(define rule-precedences '())
-(define (add-rule-precedence! rule sym)
- (set! rule-precedences
- (cons (cons rule sym) rule-precedences)))
-
-(define (get-rule-precedence ruleno)
- (cond
- ((assq ruleno rule-precedences)
- => (lambda (p)
- (get-symbol-precedence (cdr p))))
- (else
- ;; process the rule symbols from left to right
- (let loop ((i (vector-ref rrhs ruleno))
- (prec 0))
- (let ((item (vector-ref ritem i)))
- ;; end of rule
- (if (< item 0)
- prec
- (let ((i1 (+ i 1)))
- (if (>= item nvars)
- ;; it's a terminal symbol
- (loop i1 (get-symbol-precedence (- item nvars)))
- (loop i1 prec)))))))))
-
-;; ---------------------------------------------------------------------- ;;
-;; Build the various tables ;;
-;; ---------------------------------------------------------------------- ;;
-(define (build-tables)
-
- (define (resolve-conflict sym rule)
- (let ((sym-prec (get-symbol-precedence sym))
- (sym-assoc (get-symbol-assoc sym))
- (rule-prec (get-rule-precedence rule)))
- (cond
- ((> sym-prec rule-prec) 'shift)
- ((< sym-prec rule-prec) 'reduce)
- ((eq? sym-assoc 'left) 'reduce)
- ((eq? sym-assoc 'right) 'shift)
- (else 'shift))))
-
- ;; --- Add an action to the action table ------------------------------ ;;
- (define (add-action St Sym Act)
- (let* ((x (vector-ref action-table St))
- (y (assv Sym x)))
- (if y
- (if (not (= Act (cdr y)))
- ;; -- there is a conflict
- (begin
- (if (and (<= (cdr y) 0)
- (<= Act 0))
- ;; --- reduce/reduce conflict ----------------------- ;;
- (begin
- (display "%% Reduce/Reduce conflict "
(current-error-port))
- (display "(reduce " (current-error-port))
- (display (- Act) (current-error-port))
- (display ", reduce " (current-error-port))
- (display (- (cdr y)) (current-error-port))
- (display ") on " (current-error-port))
- (print-symbol (+ Sym nvars) (current-error-port))
- (display " in state " (current-error-port))
- (display St (current-error-port))
- (newline (current-error-port))
- (set-cdr! y (max (cdr y) Act)))
- ;; --- shift/reduce conflict ------------------------ ;;
- ;; can we resolve the conflict using precedences?
- (case (resolve-conflict Sym (- (cdr y)))
- ;; -- shift
- ((shift)
- (set-cdr! y Act))
- ;; -- reduce
- ((reduce)
- #f) ; well, nothing to do...
- ;; -- signal a conflict!
- (else
- (display "%% Shift/Reduce conflict "
(current-error-port))
- (display "(shift " (current-error-port))
- (display Act (current-error-port))
- (display ", reduce " (current-error-port))
- (display (- (cdr y)) (current-error-port))
- (display ") on " (current-error-port))
- (print-symbol (+ Sym nvars) (current-error-port))
- (display " in state " (current-error-port))
- (display St (current-error-port))
- (newline (current-error-port))
- (set-cdr! y Act))))))
-
- (vector-set! action-table St (cons (cons Sym Act) x)))))
-
- (set! action-table (make-vector nstates '()))
-
- (do ((i 0 (+ i 1))) ; i = state
- ((= i nstates))
- (let ((red (vector-ref reduction-table i)))
- (if (and red (>= (red-nreds red) 1))
- (if (and (= (red-nreds red) 1) (vector-ref consistent i))
- (add-action i 'default (- (car (red-rules red))))
- (let ((k (vector-ref lookaheads (+ i 1))))
- (let loop ((j (vector-ref lookaheads i)))
- (if (< j k)
- (let ((rule (- (vector-ref LAruleno j)))
- (lav (vector-ref LA j)))
- (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z
0))
- (if (< token nterms)
- (begin
- (let ((in-la-set? (modulo x 2)))
- (if (= in-la-set? 1)
- (add-action i token rule)))
- (if (= y (BITS-PER-WORD))
- (loop2 (+ token 1)
- (vector-ref lav (+ z 1))
- 1
- (+ z 1))
- (loop2 (+ token 1) (quotient x 2) (+ y 1)
z)))))
- (loop (+ j 1)))))))))
-
- (let ((shiftp (vector-ref shift-table i)))
- (if shiftp
- (let loop ((k (shift-shifts shiftp)))
- (if (pair? k)
- (let* ((state (car k))
- (symbol (vector-ref acces-symbol state)))
- (if (>= symbol nvars)
- (add-action i (- symbol nvars) state))
- (loop (cdr k))))))))
-
- (add-action final-state 0 'accept))
-
-(define (compact-action-table terms)
- (define (most-common-action acts)
- (let ((accums '()))
- (let loop ((l acts))
- (if (pair? l)
- (let* ((x (cdar l))
- (y (assv x accums)))
- (if (and (number? x) (< x 0))
- (if y
- (set-cdr! y (+ 1 (cdr y)))
- (set! accums (cons `(,x . 1) accums))))
- (loop (cdr l)))))
-
- (let loop ((l accums) (max 0) (sym #f))
- (if (null? l)
- sym
- (let ((x (car l)))
- (if (> (cdr x) max)
- (loop (cdr l) (cdr x) (car x))
- (loop (cdr l) max sym)))))))
-
- (define (translate-terms acts)
- (map (lambda (act)
- (cons (list-ref terms (car act))
- (cdr act)))
- acts))
-
- (do ((i 0 (+ i 1)))
- ((= i nstates))
- (let ((acts (vector-ref action-table i)))
- (if (vector? (vector-ref reduction-table i))
- (let ((act (most-common-action acts)))
- (vector-set! action-table i
- (cons `(*default* . ,(if act act 'error))
- (translate-terms
- (lalr-filter (lambda (x)
- (not (eq? (cdr x) act)))
- acts)))))
- (vector-set! action-table i
- (cons `(*default* . *error*)
- (translate-terms acts)))))))
-
-
-
-;; --
-
-(define (rewrite-grammar tokens grammar k)
-
- (define eoi '*eoi*)
-
- (define (check-terminal term terms)
- (cond
- ((not (valid-terminal? term))
- (lalr-error "invalid terminal: " term))
- ((member term terms)
- (lalr-error "duplicate definition of terminal: " term))))
-
- (define (prec->type prec)
- (cdr (assq prec '((left: . left)
- (right: . right)
- (nonassoc: . nonassoc)))))
-
- (cond
- ;; --- a few error conditions ---------------------------------------- ;;
- ((not (list? tokens))
- (lalr-error "Invalid token list: " tokens))
- ((not (pair? grammar))
- (lalr-error "Grammar definition must have a non-empty list of productions"
'()))
-
- (else
- ;; --- check the terminals ---------------------------------------- ;;
- (let loop1 ((lst tokens)
- (rev-terms '())
- (rev-terms/prec '())
- (prec-level 0))
- (if (pair? lst)
- (let ((term (car lst)))
- (cond
- ((pair? term)
- (if (and (memq (car term) '(left: right: nonassoc:))
- (not (null? (cdr term))))
- (let ((prec (+ prec-level 1))
- (optype (prec->type (car term))))
- (let loop-toks ((l (cdr term))
- (rev-terms rev-terms)
- (rev-terms/prec rev-terms/prec))
- (if (null? l)
- (loop1 (cdr lst) rev-terms rev-terms/prec prec)
- (let ((term (car l)))
- (check-terminal term rev-terms)
- (loop-toks
- (cdr l)
- (cons term rev-terms)
- (cons (list term optype prec) rev-terms/prec))))))
-
- (lalr-error "invalid operator precedence specification: "
term)))
-
- (else
- (check-terminal term rev-terms)
- (loop1 (cdr lst)
- (cons term rev-terms)
- (cons (list term 'none 0) rev-terms/prec)
- prec-level))))
-
- ;; --- check the grammar rules ------------------------------ ;;
- (let loop2 ((lst grammar) (rev-nonterm-defs '()))
- (if (pair? lst)
- (let ((def (car lst)))
- (if (not (pair? def))
- (lalr-error "Nonterminal definition must be a non-empty
list" '())
- (let ((nonterm (car def)))
- (cond ((not (valid-nonterminal? nonterm))
- (lalr-error "Invalid nonterminal:" nonterm))
- ((or (member nonterm rev-terms)
- (assoc nonterm rev-nonterm-defs))
- (lalr-error "Nonterminal previously defined:"
nonterm))
- (else
- (loop2 (cdr lst)
- (cons def rev-nonterm-defs)))))))
- (let* ((terms (cons eoi (reverse rev-terms)))
- (terms/prec (cons '(eoi none 0) (reverse
rev-terms/prec)))
- (nonterm-defs (reverse rev-nonterm-defs))
- (nonterms (cons '*start* (map car nonterm-defs))))
- (if (= (length nonterms) 1)
- (lalr-error "Grammar must contain at least one
nonterminal" '())
- (let loop-defs ((defs (cons `(*start* (,(cadr
nonterms) ,eoi) -> $1)
- nonterm-defs))
- (ruleno 0)
- (comp-defs '()))
- (if (pair? defs)
- (let* ((nonterm-def (car defs))
- (compiled-def (rewrite-nonterm-def
- nonterm-def
- ruleno
- terms nonterms)))
- (loop-defs (cdr defs)
- (+ ruleno (length compiled-def))
- (cons compiled-def comp-defs)))
-
- (let ((compiled-nonterm-defs (reverse comp-defs)))
- (k terms
- terms/prec
- nonterms
- (map (lambda (x) (cons (caaar x) (map cdar x)))
- compiled-nonterm-defs)
- (apply append
compiled-nonterm-defs))))))))))))))
-
-
-(define *arrow* '->)
-
-(define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
-
- (define No-NT (length nonterms))
-
- (define (encode x)
- (let ((PosInNT (pos-in-list x nonterms)))
- (if PosInNT
- PosInNT
- (let ((PosInT (pos-in-list x terms)))
- (if PosInT
- (+ No-NT PosInT)
- (lalr-error "undefined symbol : " x))))))
-
- (define (process-prec-directive rhs ruleno)
- (let loop ((l rhs))
- (if (null? l)
- '()
- (let ((first (car l))
- (rest (cdr l)))
- (cond
- ((or (member first terms) (member first nonterms))
- (cons first (loop rest)))
- ((and (pair? first)
- (eq? (car first) 'prec:))
- (pair? (cdr first))
- (if (and (pair? (cdr first))
- (member (cadr first) terms))
- (if (null? (cddr first))
- (begin
- (add-rule-precedence! ruleno (pos-in-list (cadr first)
terms))
- (loop rest))
- (lalr-error "prec: directive should be at end of rule: "
rhs))
- (lalr-error "Invalid prec: directive: " first)))
- (else
- (lalr-error "Invalid terminal or nonterminal: " first)))))))
-
-
- (if (not (pair? (cdr nonterm-def)))
- (lalr-error "At least one production needed for nonterminal" (car
nonterm-def))
- (let ((name (symbol->string (car nonterm-def))))
- (let loop1 ((lst (cdr nonterm-def))
- (i 1)
- (rev-productions-and-actions '()))
- (if (not (pair? lst))
- (reverse rev-productions-and-actions)
- (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1)))
- (rest (cdr lst))
- (prod (map encode (cons (car nonterm-def) rhs))))
- (for-each (lambda (x)
- (if (not (or (member x terms) (member x nonterms)))
- (lalr-error "Invalid terminal or nonterminal"
x)))
- rhs)
- (if (and (pair? rest)
- (eq? (car rest) *arrow*)
- (pair? (cdr rest)))
- (loop1 (cddr rest)
- (+ i 1)
- (cons (cons prod (cadr rest))
- rev-productions-and-actions))
- (let* ((rhs-length (length rhs))
- (action
- (cons 'vector
- (cons (list 'quote (string->symbol
- (string-append
- name
- "-"
- (number->string i))))
- (let loop-j ((j 1))
- (if (> j rhs-length)
- '()
- (cons (string->symbol
- (string-append
- "$"
- (number->string j)))
- (loop-j (+ j 1)))))))))
- (loop1 rest
- (+ i 1)
- (cons (cons prod action)
- rev-productions-and-actions))))))))))
-
-(define (valid-nonterminal? x)
- (symbol? x))
-
-(define (valid-terminal? x)
- (symbol? x)) ; DB
-
-;; ---------------------------------------------------------------------- ;;
-;; Miscellaneous ;;
-;; ---------------------------------------------------------------------- ;;
-(define (pos-in-list x lst)
- (let loop ((lst lst) (i 0))
- (cond ((not (pair? lst)) #f)
- ((equal? (car lst) x) i)
- (else (loop (cdr lst) (+ i 1))))))
-
-(define (sunion lst1 lst2) ; union of sorted lists
- (let loop ((L1 lst1)
- (L2 lst2))
- (cond ((null? L1) L2)
- ((null? L2) L1)
- (else
- (let ((x (car L1)) (y (car L2)))
- (cond
- ((> x y)
- (cons y (loop L1 (cdr L2))))
- ((< x y)
- (cons x (loop (cdr L1) L2)))
- (else
- (loop (cdr L1) L2))
- ))))))
-
-(define (sinsert elem lst)
- (let loop ((l1 lst))
- (if (null? l1)
- (cons elem l1)
- (let ((x (car l1)))
- (cond ((< elem x)
- (cons elem l1))
- ((> elem x)
- (cons x (loop (cdr l1))))
- (else
- l1))))))
-
-(define (lalr-filter p lst)
- (let loop ((l lst))
- (if (null? l)
- '()
- (let ((x (car l)) (y (cdr l)))
- (if (p x)
- (cons x (loop y))
- (loop y))))))
-
-;; ---------------------------------------------------------------------- ;;
-;; Debugging tools ... ;;
-;; ---------------------------------------------------------------------- ;;
-(define the-terminals #f) ; names of terminal symbols
-(define the-nonterminals #f) ; non-terminals
-
-(define (print-item item-no)
- (let loop ((i item-no))
- (let ((v (vector-ref ritem i)))
- (if (>= v 0)
- (loop (+ i 1))
- (let* ((rlno (- v))
- (nt (vector-ref rlhs rlno)))
- (display (vector-ref the-nonterminals nt)) (display " --> ")
- (let loop ((i (vector-ref rrhs rlno)))
- (let ((v (vector-ref ritem i)))
- (if (= i item-no)
- (display ". "))
- (if (>= v 0)
- (begin
- (print-symbol v)
- (display " ")
- (loop (+ i 1)))
- (begin
- (display " (rule ")
- (display (- v))
- (display ")")
- (newline))))))))))
-
-(define (print-symbol n . port)
- (display (if (>= n nvars)
- (vector-ref the-terminals (- n nvars))
- (vector-ref the-nonterminals n))
- (if (null? port)
- (current-output-port)
- (car port))))
-
-(define (print-states)
-"Print the states of a generated parser."
- (define (print-action act)
- (cond
- ((eq? act '*error*)
- (display " : Error"))
- ((eq? act 'accept)
- (display " : Accept input"))
- ((< act 0)
- (display " : reduce using rule ")
- (display (- act)))
- (else
- (display " : shift and goto state ")
- (display act)))
- (newline)
- #t)
-
- (define (print-actions acts)
- (let loop ((l acts))
- (if (null? l)
- #t
- (let ((sym (caar l))
- (act (cdar l)))
- (display " ")
- (cond
- ((eq? sym 'default)
- (display "default action"))
- (else
- (if (number? sym)
- (print-symbol (+ sym nvars))
- (display sym))))
- (print-action act)
- (loop (cdr l))))))
-
- (if (not action-table)
- (begin
- (display "No generated parser available!")
- (newline)
- #f)
- (begin
- (display "State table") (newline)
- (display "-----------") (newline) (newline)
-
- (let loop ((l first-state))
- (if (null? l)
- #t
- (let* ((core (car l))
- (i (core-number core))
- (items (core-items core))
- (actions (vector-ref action-table i)))
- (display "state ") (display i) (newline)
- (newline)
- (for-each (lambda (x) (display " ") (print-item x))
- items)
- (newline)
- (print-actions actions)
- (newline)
- (loop (cdr l))))))))
-
-
-
-;; ---------------------------------------------------------------------- ;;
-
-(define build-goto-table
- (lambda ()
- `(vector
- ,@(map
- (lambda (shifts)
- (list 'quote
- (if shifts
- (let loop ((l (shift-shifts shifts)))
- (if (null? l)
- '()
- (let* ((state (car l))
- (symbol (vector-ref acces-symbol state)))
- (if (< symbol nvars)
- (cons `(,symbol . ,state)
- (loop (cdr l)))
- (loop (cdr l))))))
- '())))
- (vector->list shift-table)))))
-
-
-(define build-reduction-table
- (lambda (gram/actions)
- `(vector
- '()
- ,@(map
- (lambda (p)
- (let ((act (cdr p)))
- `(lambda (___stack ___sp ___goto-table ___k)
- ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
- `(let* (,@(if act
- (let loop ((i 1) (l rhs))
- (if (pair? l)
- (let ((rest (cdr l)))
- (cons
- `(,(string->symbol
- (string-append
- "$"
- (number->string
- (+ (- n i) 1))))
- (vector-ref ___stack (- ___sp ,(-
(* i 2) 1))))
- (loop (+ i 1) rest)))
- '()))
- '()))
- ,(if (= nt 0)
- '$1
- `(___push ___stack (- ___sp ,(* 2 n))
- ,nt ___goto-table ,(cdr p) ___k)))))))
-
- gram/actions))))
-
-
-;; @section (api "API")
-
-(define-macro (lalr-parser tokens . rules)
- (let* ((gram/actions (gen-tables! tokens rules))
- (code
- `(letrec ((___max-stack-size 500)
-
- (___atable ',action-table)
- (___gtable ,(build-goto-table))
- (___grow-stack (lambda (stack)
- ;; make a new stack twice as big as
the original
- (let ((new-stack (make-vector (* 2
(vector-length stack)) #f)))
- ;; then copy the elements...
- (let loop ((i (- (vector-length
stack) 1)))
- (if (< i 0)
- new-stack
- (begin
- (vector-set! new-stack i
(vector-ref stack i))
- (loop (- i 1))))))))
-
- (___push (lambda (stack sp new-cat goto-table
lval k)
- (let* ((state (vector-ref stack
sp))
- (new-state (cdr (assq new-cat
(vector-ref goto-table state))))
- (new-sp (+ sp 2))
- (stack (if (< new-sp
(vector-length stack))
- stack
- (___grow-stack
stack))))
- (vector-set! stack new-sp new-state)
- (vector-set! stack (- new-sp 1) lval)
- (k stack new-sp))))
-
- (___action (lambda (x l)
- (let ((y (assq x l)))
- (if y (cdr y) (cdar l)))))
-
- (___rtable ,(build-reduction-table gram/actions)))
-
- (lambda (lexerp errorp)
-
- (let ((stack (make-vector ___max-stack-size 0)))
- (let loop ((stack stack) (sp 0) (input (lexerp)))
- (let* ((state (vector-ref stack sp))
- (i (if (pair? input) (car input) input))
- (attr (if (pair? input) (cdr input) #f))
- (act (___action i (vector-ref ___atable state))))
-
- (if (not (symbol? i))
- (errorp "PARSE ERROR: invalid token: " input))
-
- (cond
-
- ;; Input succesfully parsed
- ((eq? act 'accept)
- (vector-ref stack 1))
-
- ;; Syntax error in input
- ((eq? act '*error*)
- (if (eq? i '*eoi*)
- (errorp "PARSE ERROR : unexpected end of input ")
- (errorp "PARSE ERROR : unexpected token : " input)))
-
- ;; Shift current token on top of the stack
- ((>= act 0)
- (let ((stack (if (< (+ sp 2) (vector-length stack))
- stack
- (___grow-stack stack))))
- (vector-set! stack (+ sp 1) attr)
- (vector-set! stack (+ sp 2) act)
- (loop stack (+ sp 2) (lexerp))))
-
- ;; Reduce by rule (- act)
- (else
- ((vector-ref ___rtable (- act))
- stack sp ___gtable
- (lambda (stack sp)
- (loop stack sp input))))))))))))
- code))
-
-;; arch-tag: 4FE771DE-F56D-11D8-8B77-000A95B4C7DC
diff --git a/module/language/ecmascript/parse.scm
b/module/language/ecmascript/parse.scm
index ce731a7..e9d6673 100644
--- a/module/language/ecmascript/parse.scm
+++ b/module/language/ecmascript/parse.scm
@@ -1,6 +1,6 @@
;;; ECMAScript for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,23 +19,29 @@
;;; Code:
(define-module (language ecmascript parse)
- #:use-module (language ecmascript parse-lalr)
+ #:use-module (system base lalr)
#:use-module (language ecmascript tokenize)
- #:export (read-ecmascript read-ecmascript/1 parse-ecmascript))
+ #:export (read-ecmascript read-ecmascript/1 make-parser))
(define (syntax-error message . args)
(apply throw 'SyntaxError message args))
(define (read-ecmascript port)
- (parse-ecmascript (make-tokenizer port) syntax-error))
+ (let ((parse (make-parser)))
+ (parse (make-tokenizer port) syntax-error)))
(define (read-ecmascript/1 port)
- (parse-ecmascript (make-tokenizer/1 port) syntax-error))
+ (let ((parse (make-parser)))
+ (parse (make-tokenizer/1 port) syntax-error)))
(define *eof-object*
(call-with-input-string "" read-char))
-(define parse-ecmascript
+(define (make-parser)
+ ;; Return a fresh ECMAScript parser. Parsers produced by `lalr-scm' are now
+ ;; stateful (e.g., they won't invoke the tokenizer any more once it has
+ ;; returned `*eoi*'), hence the need to instantiate new parsers.
+
(lalr-parser
;; terminal (i.e. input) token types
(lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma <
@@ -49,289 +55,289 @@
Identifier StringLiteral NumericLiteral RegexpLiteral)
- (Program (SourceElements) -> $1
- (*eoi*) -> *eof-object*)
+ (Program (SourceElements) : $1
+ (*eoi*) : *eof-object*)
;;
;; Verily, here we define statements. Expressions are defined
;; afterwards.
;;
- (SourceElement (Statement) -> $1
- (FunctionDeclaration) -> $1)
-
- (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody
rbrace) -> `(var (,$2 (lambda () ,$6)))
- (function Identifier lparen FormalParameterList rparen
lbrace FunctionBody rbrace) -> `(var (,$2 (lambda ,$4 ,$7))))
- (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) ->
`(lambda () ,$5)
- (function Identifier lparen rparen lbrace FunctionBody
rbrace) -> `(lambda () ,$6)
- (function lparen FormalParameterList rparen lbrace
FunctionBody rbrace) -> `(lambda ,$3 ,$6)
- (function Identifier lparen FormalParameterList rparen
lbrace FunctionBody rbrace) -> `(lambda ,$4 ,$7))
- (FormalParameterList (Identifier) -> `(,$1)
- (FormalParameterList comma Identifier) -> `(,@$1 ,$3))
- (SourceElements (SourceElement) -> $1
- (SourceElements SourceElement) -> (if (and (pair? $1) (eq?
(car $1) 'begin))
+ (SourceElement (Statement) : $1
+ (FunctionDeclaration) : $1)
+
+ (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody
rbrace) : `(var (,$2 (lambda () ,$6)))
+ (function Identifier lparen FormalParameterList rparen
lbrace FunctionBody rbrace) : `(var (,$2 (lambda ,$4 ,$7))))
+ (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) :
`(lambda () ,$5)
+ (function Identifier lparen rparen lbrace FunctionBody
rbrace) : `(lambda () ,$6)
+ (function lparen FormalParameterList rparen lbrace
FunctionBody rbrace) : `(lambda ,$3 ,$6)
+ (function Identifier lparen FormalParameterList rparen
lbrace FunctionBody rbrace) : `(lambda ,$4 ,$7))
+ (FormalParameterList (Identifier) : `(,$1)
+ (FormalParameterList comma Identifier) : `(,@$1 ,$3))
+ (SourceElements (SourceElement) : $1
+ (SourceElements SourceElement) : (if (and (pair? $1) (eq?
(car $1) 'begin))
`(begin ,@(cdr $1)
,$2)
`(begin ,$1 ,$2)))
- (FunctionBody (SourceElements) -> $1)
-
- (Statement (Block) -> $1
- (VariableStatement) -> $1
- (EmptyStatement) -> $1
- (ExpressionStatement) -> $1
- (IfStatement) -> $1
- (IterationStatement) -> $1
- (ContinueStatement) -> $1
- (BreakStatement) -> $1
- (ReturnStatement) -> $1
- (WithStatement) -> $1
- (LabelledStatement) -> $1
- (SwitchStatement) -> $1
- (ThrowStatement) -> $1
- (TryStatement) -> $1)
-
- (Block (lbrace StatementList rbrace) -> `(block ,$2))
- (StatementList (Statement) -> $1
- (StatementList Statement) -> (if (and (pair? $1) (eq? (car
$1) 'begin))
+ (FunctionBody (SourceElements) : $1)
+
+ (Statement (Block) : $1
+ (VariableStatement) : $1
+ (EmptyStatement) : $1
+ (ExpressionStatement) : $1
+ (IfStatement) : $1
+ (IterationStatement) : $1
+ (ContinueStatement) : $1
+ (BreakStatement) : $1
+ (ReturnStatement) : $1
+ (WithStatement) : $1
+ (LabelledStatement) : $1
+ (SwitchStatement) : $1
+ (ThrowStatement) : $1
+ (TryStatement) : $1)
+
+ (Block (lbrace StatementList rbrace) : `(block ,$2))
+ (StatementList (Statement) : $1
+ (StatementList Statement) : (if (and (pair? $1) (eq? (car
$1) 'begin))
`(begin ,@(cdr $1) ,$2)
`(begin ,$1 ,$2)))
- (VariableStatement (var VariableDeclarationList) -> `(var ,@$2))
- (VariableDeclarationList (VariableDeclaration) -> `(,$1)
- (VariableDeclarationList comma
VariableDeclaration) -> `(,@$1 ,$2))
- (VariableDeclarationListNoIn (VariableDeclarationNoIn) -> `(,$1)
- (VariableDeclarationListNoIn comma
VariableDeclarationNoIn) -> `(,@$1 ,$2))
- (VariableDeclaration (Identifier) -> `(,$1)
- (Identifier Initialiser) -> `(,$1 ,$2))
- (VariableDeclarationNoIn (Identifier) -> `(,$1)
- (Identifier Initialiser) -> `(,$1 ,$2))
- (Initialiser (= AssignmentExpression) -> $2)
- (InitialiserNoIn (= AssignmentExpressionNoIn) -> $2)
+ (VariableStatement (var VariableDeclarationList) : `(var ,@$2))
+ (VariableDeclarationList (VariableDeclaration) : `(,$1)
+ (VariableDeclarationList comma
VariableDeclaration) : `(,@$1 ,$2))
+ (VariableDeclarationListNoIn (VariableDeclarationNoIn) : `(,$1)
+ (VariableDeclarationListNoIn comma
VariableDeclarationNoIn) : `(,@$1 ,$2))
+ (VariableDeclaration (Identifier) : `(,$1)
+ (Identifier Initialiser) : `(,$1 ,$2))
+ (VariableDeclarationNoIn (Identifier) : `(,$1)
+ (Identifier Initialiser) : `(,$1 ,$2))
+ (Initialiser (= AssignmentExpression) : $2)
+ (InitialiserNoIn (= AssignmentExpressionNoIn) : $2)
- (EmptyStatement (semicolon) -> '(begin))
+ (EmptyStatement (semicolon) : '(begin))
- (ExpressionStatement (Expression semicolon) -> $1)
+ (ExpressionStatement (Expression semicolon) : $1)
- (IfStatement (if lparen Expression rparen Statement else Statement) -> `(if
,$3 ,$5 ,$7)
- (if lparen Expression rparen Statement) -> `(if ,$3 ,$5))
+ (IfStatement (if lparen Expression rparen Statement else Statement) : `(if
,$3 ,$5 ,$7)
+ (if lparen Expression rparen Statement) : `(if ,$3 ,$5))
- (IterationStatement (do Statement while lparen Expression rparen semicolon)
-> `(do ,$2 ,$5)
+ (IterationStatement (do Statement while lparen Expression rparen semicolon)
: `(do ,$2 ,$5)
- (while lparen Expression rparen Statement) -> `(while
,$3 ,$5)
+ (while lparen Expression rparen Statement) : `(while
,$3 ,$5)
- (for lparen semicolon semicolon rparen Statement) ->
`(for #f #f #f ,$6)
- (for lparen semicolon semicolon Expression rparen
Statement) -> `(for #f #f ,$5 ,$7)
- (for lparen semicolon Expression semicolon rparen
Statement) -> `(for #f ,$4 #f ,$7)
- (for lparen semicolon Expression semicolon Expression
rparen Statement) -> `(for #f ,$4 ,$6 ,$8)
+ (for lparen semicolon semicolon rparen Statement) :
`(for #f #f #f ,$6)
+ (for lparen semicolon semicolon Expression rparen
Statement) : `(for #f #f ,$5 ,$7)
+ (for lparen semicolon Expression semicolon rparen
Statement) : `(for #f ,$4 #f ,$7)
+ (for lparen semicolon Expression semicolon Expression
rparen Statement) : `(for #f ,$4 ,$6 ,$8)
- (for lparen ExpressionNoIn semicolon semicolon rparen
Statement) -> `(for ,$3 #f #f ,$7)
- (for lparen ExpressionNoIn semicolon semicolon
Expression rparen Statement) -> `(for ,$3 #f ,$6 ,$8)
- (for lparen ExpressionNoIn semicolon Expression
semicolon rparen Statement) -> `(for ,$3 ,$5 #f ,$8)
- (for lparen ExpressionNoIn semicolon Expression
semicolon Expression rparen Statement) -> `(for ,$3 ,$5 ,$7 ,$9)
+ (for lparen ExpressionNoIn semicolon semicolon rparen
Statement) : `(for ,$3 #f #f ,$7)
+ (for lparen ExpressionNoIn semicolon semicolon
Expression rparen Statement) : `(for ,$3 #f ,$6 ,$8)
+ (for lparen ExpressionNoIn semicolon Expression
semicolon rparen Statement) : `(for ,$3 ,$5 #f ,$8)
+ (for lparen ExpressionNoIn semicolon Expression
semicolon Expression rparen Statement) : `(for ,$3 ,$5 ,$7 ,$9)
- (for lparen var VariableDeclarationListNoIn semicolon
semicolon rparen Statement) -> `(for (var ,@$4) #f #f ,$8)
- (for lparen var VariableDeclarationListNoIn semicolon
semicolon Expression rparen Statement) -> `(for (var ,@$4) #f ,$7 ,$9)
- (for lparen var VariableDeclarationListNoIn semicolon
Expression semicolon rparen Statement) -> `(for (var ,@$4) ,$6 #f ,$9)
- (for lparen var VariableDeclarationListNoIn semicolon
Expression semicolon Expression rparen Statement) -> `(for (var ,@$4) ,$6 ,$8
,$10)
+ (for lparen var VariableDeclarationListNoIn semicolon
semicolon rparen Statement) : `(for (var ,@$4) #f #f ,$8)
+ (for lparen var VariableDeclarationListNoIn semicolon
semicolon Expression rparen Statement) : `(for (var ,@$4) #f ,$7 ,$9)
+ (for lparen var VariableDeclarationListNoIn semicolon
Expression semicolon rparen Statement) : `(for (var ,@$4) ,$6 #f ,$9)
+ (for lparen var VariableDeclarationListNoIn semicolon
Expression semicolon Expression rparen Statement) : `(for (var ,@$4) ,$6 ,$8
,$10)
- (for lparen LeftHandSideExpression in Expression rparen
Statement) -> `(for-in ,$3 ,$5 ,$7)
- (for lparen var VariableDeclarationNoIn in Expression
rparen Statement) -> `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8)))
+ (for lparen LeftHandSideExpression in Expression rparen
Statement) : `(for-in ,$3 ,$5 ,$7)
+ (for lparen var VariableDeclarationNoIn in Expression
rparen Statement) : `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8)))
- (ContinueStatement (continue Identifier semicolon) -> `(continue ,$2)
- (continue semicolon) -> `(continue))
+ (ContinueStatement (continue Identifier semicolon) : `(continue ,$2)
+ (continue semicolon) : `(continue))
- (BreakStatement (break Identifier semicolon) -> `(break ,$2)
- (break semicolon) -> `(break))
+ (BreakStatement (break Identifier semicolon) : `(break ,$2)
+ (break semicolon) : `(break))
- (ReturnStatement (return Expression semicolon) -> `(return ,$2)
- (return semicolon) -> `(return))
+ (ReturnStatement (return Expression semicolon) : `(return ,$2)
+ (return semicolon) : `(return))
- (WithStatement (with lparen Expression rparen Statement) -> `(with ,$3 ,$5))
+ (WithStatement (with lparen Expression rparen Statement) : `(with ,$3 ,$5))
- (SwitchStatement (switch lparen Expression rparen CaseBlock) -> `(switch
,$3 ,@$5))
- (CaseBlock (lbrace rbrace) -> '()
- (lbrace CaseClauses rbrace) -> $2
- (lbrace CaseClauses DefaultClause rbrace) -> `(,@$2 ,@$3)
- (lbrace DefaultClause rbrace) -> `(,$2)
- (lbrace DefaultClause CaseClauses rbrace) -> `(,@$2 ,@$3))
- (CaseClauses (CaseClause) -> `(,$1)
- (CaseClauses CaseClause) -> `(,@$1 ,$2))
- (CaseClause (case Expression colon) -> `(case ,$2)
- (case Expression colon StatementList) -> `(case ,$2 ,$4))
- (DefaultClause (default colon) -> `(default)
- (default colon StatementList) -> `(default ,$3))
+ (SwitchStatement (switch lparen Expression rparen CaseBlock) : `(switch ,$3
,@$5))
+ (CaseBlock (lbrace rbrace) : '()
+ (lbrace CaseClauses rbrace) : $2
+ (lbrace CaseClauses DefaultClause rbrace) : `(,@$2 ,@$3)
+ (lbrace DefaultClause rbrace) : `(,$2)
+ (lbrace DefaultClause CaseClauses rbrace) : `(,@$2 ,@$3))
+ (CaseClauses (CaseClause) : `(,$1)
+ (CaseClauses CaseClause) : `(,@$1 ,$2))
+ (CaseClause (case Expression colon) : `(case ,$2)
+ (case Expression colon StatementList) : `(case ,$2 ,$4))
+ (DefaultClause (default colon) : `(default)
+ (default colon StatementList) : `(default ,$3))
- (LabelledStatement (Identifier colon Statement) -> `(label ,$1 ,$3))
+ (LabelledStatement (Identifier colon Statement) : `(label ,$1 ,$3))
- (ThrowStatement (throw Expression semicolon) -> `(throw ,$2))
+ (ThrowStatement (throw Expression semicolon) : `(throw ,$2))
- (TryStatement (try Block Catch) -> `(try ,$2 ,$3 #f)
- (try Block Finally) -> `(try ,$2 #f ,$3)
- (try Block Catch Finally) -> `(try ,$2 ,$3 ,$4))
- (Catch (catch lparen Identifier rparen Block) -> `(catch ,$3 ,$5))
- (Finally (finally Block) -> `(finally ,$2))
+ (TryStatement (try Block Catch) : `(try ,$2 ,$3 #f)
+ (try Block Finally) : `(try ,$2 #f ,$3)
+ (try Block Catch Finally) : `(try ,$2 ,$3 ,$4))
+ (Catch (catch lparen Identifier rparen Block) : `(catch ,$3 ,$5))
+ (Finally (finally Block) : `(finally ,$2))
;;
;; As promised, expressions. We build up to Expression bottom-up, so
;; as to get operator precedence right.
;;
- (PrimaryExpression (this) -> 'this
- (null) -> 'null
- (true) -> 'true
- (false) -> 'false
- (Identifier) -> `(ref ,$1)
- (StringLiteral) -> `(string ,$1)
- (RegexpLiteral) -> `(regexp ,$1)
- (NumericLiteral) -> `(number ,$1)
- (ArrayLiteral) -> $1
- (ObjectLiteral) -> $1
- (lparen Expression rparen) -> $2)
-
- (ArrayLiteral (lbracket rbracket) -> '(array)
- (lbracket Elision rbracket) -> '(array ,@$2)
- (lbracket ElementList rbracket) -> `(array ,@$2)
- (lbracket ElementList comma rbracket) -> `(array ,@$2)
- (lbracket ElementList comma Elision rbracket) -> `(array
,@$2))
- (ElementList (AssignmentExpression) -> `(,$1)
- (Elision AssignmentExpression) -> `(,@$1 ,$2)
- (ElementList comma AssignmentExpression) -> `(,@$1 ,$3)
- (ElementList comma Elision AssignmentExpression) -> `(,@$1
,@$3 ,$4))
- (Elision (comma) -> '((number 0))
- (Elision comma) -> `(,@$1 (number 0)))
-
- (ObjectLiteral (lbrace rbrace) -> `(object)
- (lbrace PropertyNameAndValueList rbrace) -> `(object ,@$2))
- (PropertyNameAndValueList (PropertyName colon AssignmentExpression) ->
`((,$1 ,$3))
- (PropertyNameAndValueList comma PropertyName
colon AssignmentExpression) -> `(,@$1 (,$3 ,$5)))
- (PropertyName (Identifier) -> $1
- (StringLiteral) -> (string->symbol $1)
- (NumericLiteral) -> $1)
-
- (MemberExpression (PrimaryExpression) -> $1
- (FunctionExpression) -> $1
- (MemberExpression lbracket Expression rbracket) -> `(aref
,$1 ,$3)
- (MemberExpression dot Identifier) -> `(pref ,$1 ,$3)
- (new MemberExpression Arguments) -> `(new ,$2 ,$3))
-
- (NewExpression (MemberExpression) -> $1
- (new NewExpression) -> `(new ,$2 ()))
-
- (CallExpression (MemberExpression Arguments) -> `(call ,$1 ,$2)
- (CallExpression Arguments) -> `(call ,$1 ,$2)
- (CallExpression lbracket Expression rbracket) -> `(aref ,$1
,$3)
- (CallExpression dot Identifier) -> `(pref ,$1 ,$3))
- (Arguments (lparen rparen) -> '()
- (lparen ArgumentList rparen) -> $2)
- (ArgumentList (AssignmentExpression) -> `(,$1)
- (ArgumentList comma AssignmentExpression) -> `(,@$1 ,$3))
-
- (LeftHandSideExpression (NewExpression) -> $1
- (CallExpression) -> $1)
-
- (PostfixExpression (LeftHandSideExpression) -> $1
- (LeftHandSideExpression ++) -> `(postinc ,$1)
- (LeftHandSideExpression --) -> `(postdec ,$1))
-
- (UnaryExpression (PostfixExpression) -> $1
- (delete UnaryExpression) -> `(delete ,$2)
- (void UnaryExpression) -> `(void ,$2)
- (typeof UnaryExpression) -> `(typeof ,$2)
- (++ UnaryExpression) -> `(preinc ,$2)
- (-- UnaryExpression) -> `(predec ,$2)
- (+ UnaryExpression) -> `(+ ,$2)
- (- UnaryExpression) -> `(- ,$2)
- (~ UnaryExpression) -> `(~ ,$2)
- (! UnaryExpression) -> `(! ,$2))
-
- (MultiplicativeExpression (UnaryExpression) -> $1
- (MultiplicativeExpression * UnaryExpression) ->
`(* ,$1 ,$3)
- (MultiplicativeExpression / UnaryExpression) ->
`(/ ,$1 ,$3)
- (MultiplicativeExpression % UnaryExpression) ->
`(% ,$1 ,$3))
-
- (AdditiveExpression (MultiplicativeExpression) -> $1
- (AdditiveExpression + MultiplicativeExpression) -> `(+
,$1 ,$3)
- (AdditiveExpression - MultiplicativeExpression) -> `(-
,$1 ,$3))
-
- (ShiftExpression (AdditiveExpression) -> $1
- (ShiftExpression << MultiplicativeExpression) -> `(<< ,$1
,$3)
- (ShiftExpression >> MultiplicativeExpression) -> `(>> ,$1
,$3)
- (ShiftExpression >>> MultiplicativeExpression) -> `(>>>
,$1 ,$3))
-
- (RelationalExpression (ShiftExpression) -> $1
- (RelationalExpression < ShiftExpression) -> `(< ,$1
,$3)
- (RelationalExpression > ShiftExpression) -> `(> ,$1
,$3)
- (RelationalExpression <= ShiftExpression) -> `(<= ,$1
,$3)
- (RelationalExpression >= ShiftExpression) -> `(>= ,$1
,$3)
- (RelationalExpression instanceof ShiftExpression) ->
`(instanceof ,$1 ,$3)
- (RelationalExpression in ShiftExpression) -> `(in ,$1
,$3))
-
- (RelationalExpressionNoIn (ShiftExpression) -> $1
- (RelationalExpressionNoIn < ShiftExpression) ->
`(< ,$1 ,$3)
- (RelationalExpressionNoIn > ShiftExpression) ->
`(> ,$1 ,$3)
- (RelationalExpressionNoIn <= ShiftExpression) ->
`(<= ,$1 ,$3)
- (RelationalExpressionNoIn >= ShiftExpression) ->
`(>= ,$1 ,$3)
- (RelationalExpressionNoIn instanceof
ShiftExpression) -> `(instanceof ,$1 ,$3))
-
- (EqualityExpression (RelationalExpression) -> $1
- (EqualityExpression == RelationalExpression) -> `(==
,$1 ,$3)
- (EqualityExpression != RelationalExpression) -> `(!=
,$1 ,$3)
- (EqualityExpression === RelationalExpression) -> `(===
,$1 ,$3)
- (EqualityExpression !== RelationalExpression) -> `(!==
,$1 ,$3))
-
- (EqualityExpressionNoIn (RelationalExpressionNoIn) -> $1
- (EqualityExpressionNoIn ==
RelationalExpressionNoIn) -> `(== ,$1 ,$3)
- (EqualityExpressionNoIn !=
RelationalExpressionNoIn) -> `(!= ,$1 ,$3)
- (EqualityExpressionNoIn ===
RelationalExpressionNoIn) -> `(=== ,$1 ,$3)
- (EqualityExpressionNoIn !==
RelationalExpressionNoIn) -> `(!== ,$1 ,$3))
-
- (BitwiseANDExpression (EqualityExpression) -> $1
- (BitwiseANDExpression & EqualityExpression) -> `(&
,$1 ,$3))
- (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) -> $1
- (BitwiseANDExpressionNoIn &
EqualityExpressionNoIn) -> `(& ,$1 ,$3))
-
- (BitwiseXORExpression (BitwiseANDExpression) -> $1
- (BitwiseXORExpression ^ BitwiseANDExpression) -> `(^
,$1 ,$3))
- (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) -> $1
- (BitwiseXORExpressionNoIn ^
BitwiseANDExpressionNoIn) -> `(^ ,$1 ,$3))
-
- (BitwiseORExpression (BitwiseXORExpression) -> $1
- (BitwiseORExpression bor BitwiseXORExpression) ->
`(bor ,$1 ,$3))
- (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) -> $1
- (BitwiseORExpressionNoIn bor
BitwiseXORExpressionNoIn) -> `(bor ,$1 ,$3))
-
- (LogicalANDExpression (BitwiseORExpression) -> $1
- (LogicalANDExpression && BitwiseORExpression) ->
`(and ,$1 ,$3))
- (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) -> $1
- (LogicalANDExpressionNoIn &&
BitwiseORExpressionNoIn) -> `(and ,$1 ,$3))
-
- (LogicalORExpression (LogicalANDExpression) -> $1
- (LogicalORExpression or LogicalANDExpression) -> `(or
,$1 ,$3))
- (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) -> $1
- (LogicalORExpressionNoIn or
LogicalANDExpressionNoIn) -> `(or ,$1 ,$3))
-
- (ConditionalExpression (LogicalORExpression) -> $1
- (LogicalORExpression ? AssignmentExpression colon
AssignmentExpression) -> `(if ,$1 ,$3 ,$5))
- (ConditionalExpressionNoIn (LogicalORExpressionNoIn) -> $1
- (LogicalORExpressionNoIn ?
AssignmentExpressionNoIn colon AssignmentExpressionNoIn) -> `(if ,$1 ,$3 ,$5))
-
- (AssignmentExpression (ConditionalExpression) -> $1
- (LeftHandSideExpression AssignmentOperator
AssignmentExpression) -> `(,$2 ,$1 ,$3))
- (AssignmentExpressionNoIn (ConditionalExpressionNoIn) -> $1
- (LeftHandSideExpression AssignmentOperator
AssignmentExpressionNoIn) -> `(,$2 ,$1 ,$3))
- (AssignmentOperator (=) -> '=
- (*=) -> '*=
- (/=) -> '/=
- (%=) -> '%=
- (+=) -> '+=
- (-=) -> '-=
- (<<=) -> '<<=
- (>>=) -> '>>=
- (>>>=) -> '>>>=
- (&=) -> '&=
- (^=) -> '^=
- (bor=) -> 'bor=)
-
- (Expression (AssignmentExpression) -> $1
- (Expression comma AssignmentExpression) -> `(begin ,$1 ,$3))
- (ExpressionNoIn (AssignmentExpressionNoIn) -> $1
- (ExpressionNoIn comma AssignmentExpressionNoIn) -> `(begin
,$1 ,$3))))
+ (PrimaryExpression (this) : 'this
+ (null) : 'null
+ (true) : 'true
+ (false) : 'false
+ (Identifier) : `(ref ,$1)
+ (StringLiteral) : `(string ,$1)
+ (RegexpLiteral) : `(regexp ,$1)
+ (NumericLiteral) : `(number ,$1)
+ (ArrayLiteral) : $1
+ (ObjectLiteral) : $1
+ (lparen Expression rparen) : $2)
+
+ (ArrayLiteral (lbracket rbracket) : '(array)
+ (lbracket Elision rbracket) : '(array ,@$2)
+ (lbracket ElementList rbracket) : `(array ,@$2)
+ (lbracket ElementList comma rbracket) : `(array ,@$2)
+ (lbracket ElementList comma Elision rbracket) : `(array ,@$2))
+ (ElementList (AssignmentExpression) : `(,$1)
+ (Elision AssignmentExpression) : `(,@$1 ,$2)
+ (ElementList comma AssignmentExpression) : `(,@$1 ,$3)
+ (ElementList comma Elision AssignmentExpression) : `(,@$1 ,@$3
,$4))
+ (Elision (comma) : '((number 0))
+ (Elision comma) : `(,@$1 (number 0)))
+
+ (ObjectLiteral (lbrace rbrace) : `(object)
+ (lbrace PropertyNameAndValueList rbrace) : `(object ,@$2))
+ (PropertyNameAndValueList (PropertyName colon AssignmentExpression) :
`((,$1 ,$3))
+ (PropertyNameAndValueList comma PropertyName
colon AssignmentExpression) : `(,@$1 (,$3 ,$5)))
+ (PropertyName (Identifier) : $1
+ (StringLiteral) : (string->symbol $1)
+ (NumericLiteral) : $1)
+
+ (MemberExpression (PrimaryExpression) : $1
+ (FunctionExpression) : $1
+ (MemberExpression lbracket Expression rbracket) : `(aref
,$1 ,$3)
+ (MemberExpression dot Identifier) : `(pref ,$1 ,$3)
+ (new MemberExpression Arguments) : `(new ,$2 ,$3))
+
+ (NewExpression (MemberExpression) : $1
+ (new NewExpression) : `(new ,$2 ()))
+
+ (CallExpression (MemberExpression Arguments) : `(call ,$1 ,$2)
+ (CallExpression Arguments) : `(call ,$1 ,$2)
+ (CallExpression lbracket Expression rbracket) : `(aref ,$1
,$3)
+ (CallExpression dot Identifier) : `(pref ,$1 ,$3))
+ (Arguments (lparen rparen) : '()
+ (lparen ArgumentList rparen) : $2)
+ (ArgumentList (AssignmentExpression) : `(,$1)
+ (ArgumentList comma AssignmentExpression) : `(,@$1 ,$3))
+
+ (LeftHandSideExpression (NewExpression) : $1
+ (CallExpression) : $1)
+
+ (PostfixExpression (LeftHandSideExpression) : $1
+ (LeftHandSideExpression ++) : `(postinc ,$1)
+ (LeftHandSideExpression --) : `(postdec ,$1))
+
+ (UnaryExpression (PostfixExpression) : $1
+ (delete UnaryExpression) : `(delete ,$2)
+ (void UnaryExpression) : `(void ,$2)
+ (typeof UnaryExpression) : `(typeof ,$2)
+ (++ UnaryExpression) : `(preinc ,$2)
+ (-- UnaryExpression) : `(predec ,$2)
+ (+ UnaryExpression) : `(+ ,$2)
+ (- UnaryExpression) : `(- ,$2)
+ (~ UnaryExpression) : `(~ ,$2)
+ (! UnaryExpression) : `(! ,$2))
+
+ (MultiplicativeExpression (UnaryExpression) : $1
+ (MultiplicativeExpression * UnaryExpression) :
`(* ,$1 ,$3)
+ (MultiplicativeExpression / UnaryExpression) :
`(/ ,$1 ,$3)
+ (MultiplicativeExpression % UnaryExpression) :
`(% ,$1 ,$3))
+
+ (AdditiveExpression (MultiplicativeExpression) : $1
+ (AdditiveExpression + MultiplicativeExpression) : `(+
,$1 ,$3)
+ (AdditiveExpression - MultiplicativeExpression) : `(-
,$1 ,$3))
+
+ (ShiftExpression (AdditiveExpression) : $1
+ (ShiftExpression << MultiplicativeExpression) : `(<< ,$1
,$3)
+ (ShiftExpression >> MultiplicativeExpression) : `(>> ,$1
,$3)
+ (ShiftExpression >>> MultiplicativeExpression) : `(>>> ,$1
,$3))
+
+ (RelationalExpression (ShiftExpression) : $1
+ (RelationalExpression < ShiftExpression) : `(< ,$1
,$3)
+ (RelationalExpression > ShiftExpression) : `(> ,$1
,$3)
+ (RelationalExpression <= ShiftExpression) : `(<= ,$1
,$3)
+ (RelationalExpression >= ShiftExpression) : `(>= ,$1
,$3)
+ (RelationalExpression instanceof ShiftExpression) :
`(instanceof ,$1 ,$3)
+ (RelationalExpression in ShiftExpression) : `(in ,$1
,$3))
+
+ (RelationalExpressionNoIn (ShiftExpression) : $1
+ (RelationalExpressionNoIn < ShiftExpression) :
`(< ,$1 ,$3)
+ (RelationalExpressionNoIn > ShiftExpression) :
`(> ,$1 ,$3)
+ (RelationalExpressionNoIn <= ShiftExpression) :
`(<= ,$1 ,$3)
+ (RelationalExpressionNoIn >= ShiftExpression) :
`(>= ,$1 ,$3)
+ (RelationalExpressionNoIn instanceof
ShiftExpression) : `(instanceof ,$1 ,$3))
+
+ (EqualityExpression (RelationalExpression) : $1
+ (EqualityExpression == RelationalExpression) : `(== ,$1
,$3)
+ (EqualityExpression != RelationalExpression) : `(!= ,$1
,$3)
+ (EqualityExpression === RelationalExpression) : `(===
,$1 ,$3)
+ (EqualityExpression !== RelationalExpression) : `(!==
,$1 ,$3))
+
+ (EqualityExpressionNoIn (RelationalExpressionNoIn) : $1
+ (EqualityExpressionNoIn ==
RelationalExpressionNoIn) : `(== ,$1 ,$3)
+ (EqualityExpressionNoIn !=
RelationalExpressionNoIn) : `(!= ,$1 ,$3)
+ (EqualityExpressionNoIn ===
RelationalExpressionNoIn) : `(=== ,$1 ,$3)
+ (EqualityExpressionNoIn !==
RelationalExpressionNoIn) : `(!== ,$1 ,$3))
+
+ (BitwiseANDExpression (EqualityExpression) : $1
+ (BitwiseANDExpression & EqualityExpression) : `(& ,$1
,$3))
+ (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) : $1
+ (BitwiseANDExpressionNoIn &
EqualityExpressionNoIn) : `(& ,$1 ,$3))
+
+ (BitwiseXORExpression (BitwiseANDExpression) : $1
+ (BitwiseXORExpression ^ BitwiseANDExpression) : `(^
,$1 ,$3))
+ (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) : $1
+ (BitwiseXORExpressionNoIn ^
BitwiseANDExpressionNoIn) : `(^ ,$1 ,$3))
+
+ (BitwiseORExpression (BitwiseXORExpression) : $1
+ (BitwiseORExpression bor BitwiseXORExpression) : `(bor
,$1 ,$3))
+ (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) : $1
+ (BitwiseORExpressionNoIn bor
BitwiseXORExpressionNoIn) : `(bor ,$1 ,$3))
+
+ (LogicalANDExpression (BitwiseORExpression) : $1
+ (LogicalANDExpression && BitwiseORExpression) : `(and
,$1 ,$3))
+ (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) : $1
+ (LogicalANDExpressionNoIn &&
BitwiseORExpressionNoIn) : `(and ,$1 ,$3))
+
+ (LogicalORExpression (LogicalANDExpression) : $1
+ (LogicalORExpression or LogicalANDExpression) : `(or
,$1 ,$3))
+ (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) : $1
+ (LogicalORExpressionNoIn or
LogicalANDExpressionNoIn) : `(or ,$1 ,$3))
+
+ (ConditionalExpression (LogicalORExpression) : $1
+ (LogicalORExpression ? AssignmentExpression colon
AssignmentExpression) : `(if ,$1 ,$3 ,$5))
+ (ConditionalExpressionNoIn (LogicalORExpressionNoIn) : $1
+ (LogicalORExpressionNoIn ?
AssignmentExpressionNoIn colon AssignmentExpressionNoIn) : `(if ,$1 ,$3 ,$5))
+
+ (AssignmentExpression (ConditionalExpression) : $1
+ (LeftHandSideExpression AssignmentOperator
AssignmentExpression) : `(,$2 ,$1 ,$3))
+ (AssignmentExpressionNoIn (ConditionalExpressionNoIn) : $1
+ (LeftHandSideExpression AssignmentOperator
AssignmentExpressionNoIn) : `(,$2 ,$1 ,$3))
+ (AssignmentOperator (=) : '=
+ (*=) : '*=
+ (/=) : '/=
+ (%=) : '%=
+ (+=) : '+=
+ (-=) : '-=
+ (<<=) : '<<=
+ (>>=) : '>>=
+ (>>>=) : '>>>=
+ (&=) : '&=
+ (^=) : '^=
+ (bor=) : 'bor=)
+
+ (Expression (AssignmentExpression) : $1
+ (Expression comma AssignmentExpression) : `(begin ,$1 ,$3))
+ (ExpressionNoIn (AssignmentExpressionNoIn) : $1
+ (ExpressionNoIn comma AssignmentExpressionNoIn) : `(begin
,$1 ,$3))))
diff --git a/module/language/ecmascript/tokenize.scm
b/module/language/ecmascript/tokenize.scm
index 2ab8045..65a8b1e 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -1,6 +1,6 @@
;;; ECMAScript for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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,7 @@
(define-module (language ecmascript tokenize)
#:use-module (ice-9 rdelim)
#:use-module ((srfi srfi-1) #:select (unfold-right))
+ #:use-module (system base lalr)
#:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
(define (syntax-error message . args)
@@ -75,8 +76,8 @@
(lp (read-char port))))))
(div?
(case c1
- ((#\=) (read-char port) `(/= . #f))
- (else `(/ . #f))))
+ ((#\=) (read-char port) (make-lexical-token '/= #f #f))
+ (else (make-lexical-token '/ #f #f))))
(else
(read-regexp port)))))
@@ -95,7 +96,9 @@
(char-numeric? c)
(char=? c #\$)
(char=? c #\_))))
- `(RegexpLiteral . (,(string-append head str) . ,(reverse
flags)))
+ (make-lexical-token 'RegexpLiteral #f
+ (cons (string-append head str)
+ (reverse flags)))
(begin (read-char port)
(lp (peek-char port) (cons c flags))))))
((char=? terminator #\\)
@@ -216,7 +219,7 @@
("import" . import)
("public" . public)))
-(define (read-identifier port)
+(define (read-identifier port loc)
(let lp ((c (peek-char port)) (chars '()))
(if (or (eof-object? c)
(not (or (char-alphabetic? c)
@@ -225,10 +228,11 @@
(char=? c #\_))))
(let ((word (list->string (reverse chars))))
(cond ((assoc-ref *keywords* word)
- => (lambda (x) `(,x . #f)))
+ => (lambda (x) (make-lexical-token x loc #f)))
((assoc-ref *future-reserved-words* word)
(syntax-error "word is reserved for the future, dude." word))
- (else `(Identifier . ,(string->symbol word)))))
+ (else (make-lexical-token 'Identifier loc
+ (string->symbol word)))))
(begin (read-char port)
(lp (peek-char port) (cons c chars))))))
@@ -368,7 +372,7 @@
(else
(lp (cons (list (string-ref (caar puncs) 0) #f)
nodes)
puncs))))))
- (lambda (port)
+ (lambda (port loc)
(let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
(cond
((assv-ref tree c)
@@ -376,15 +380,17 @@
(read-char port)
(lp (peek-char port) (cdr node-tail) (car node-tail))))
(candidate
- `(,candidate . #f))
+ (make-lexical-token candidate loc #f))
(else
(syntax-error "bad syntax: character not allowed" c)))))))
(define (next-token port div?)
- (let ((c (peek-char port))
- (props `((filename . ,(port-filename port))
- (line . ,(port-line port))
- (column . ,(port-column port)))))
+ (let ((c (peek-char port))
+ (loc (make-source-location (port-filename port)
+ (port-line port)
+ (port-column port)
+ (false-if-exception (seek port 0 SEEK_CUR))
+ #f)))
(let ((tok
(case c
((#\ht #\vt #\np #\space)
@@ -400,7 +406,7 @@
(read-slash port div?))
((#\" #\')
; string literal
- `(StringLiteral . ,(read-string port)))
+ (make-lexical-token 'StringLiteral loc (read-string port)))
(else
(cond
((eof-object? c)
@@ -409,15 +415,14 @@
(char=? c #\$)
(char=? c #\_))
;; reserved word or identifier
- (read-identifier port))
+ (read-identifier port loc))
((char-numeric? c)
;; numeric -- also accept . FIXME, requires lookahead
- `(NumericLiteral . ,(read-numeric port)))
+ (make-lexical-token 'NumericLiteral loc (read-numeric port)))
(else
;; punctuation
- (read-punctuation port)))))))
- (if (pair? tok)
- (set-source-properties! tok props))
+ (read-punctuation port loc)))))))
+
tok)))
(define (make-tokenizer port)
@@ -435,31 +440,32 @@
(if eoi?
'*eoi*
(let ((tok (next-token port div?)))
- (case (if (pair? tok) (car tok) tok)
+ (case (if (lexical-token? tok) (lexical-token-category tok) tok)
((lparen)
- (set! stack (cons 'lparen stack)))
+ (set! stack (make-lexical-token 'lparen #f stack)))
((rparen)
(if (and (pair? stack) (eq? (car stack) 'lparen))
(set! stack (cdr stack))
(syntax-error "unexpected right parenthesis")))
((lbracket)
- (set! stack (cons 'lbracket stack)))
+ (set! stack (make-lexical-token 'lbracket #f stack)))
((rbracket)
(if (and (pair? stack) (eq? (car stack) 'lbracket))
(set! stack (cdr stack))
(syntax-error "unexpected right bracket" stack)))
((lbrace)
- (set! stack (cons 'lbrace stack)))
+ (set! stack (make-lexical-token 'lbrace #f stack)))
((rbrace)
(if (and (pair? stack) (eq? (car stack) 'lbrace))
(set! stack (cdr stack))
(syntax-error "unexpected right brace" stack)))
((semicolon)
(set! eoi? (null? stack))))
- (set! div? (and (pair? tok)
- (or (eq? (car tok) 'Identifier)
- (eq? (car tok) 'NumericLiteral)
- (eq? (car tok) 'StringLiteral))))
+ (set! div? (and (lexical-token? tok)
+ (let ((cat (lexical-token-category tok)))
+ (or (eq? cat 'Identifier)
+ (eq? cat 'NumericLiteral)
+ (eq? cat 'StringLiteral)))))
tok)))))
(define (tokenize port)
diff --git a/module/language/elisp/README b/module/language/elisp/README
index 4f33711..b93550f 100644
--- a/module/language/elisp/README
+++ b/module/language/elisp/README
@@ -31,7 +31,7 @@ Especially still missing:
* anonymous macros
Other ideas and things to think about:
- * %nil vs. #f/'() handling in Guile
+ * #nil vs. #f/'() handling in Guile
Compiler options implemented:
* #:disable-void-check ['all / '(sym1 sym2 sym3)] to disable the check
diff --git a/module/language/elisp/compile-tree-il.scm
b/module/language/elisp/compile-tree-il.scm
index 9778d1a..47b49d6 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -750,7 +750,7 @@
; (if condition
; (begin body
; (iterate))
- ; %nil))))
+ ; #nil))))
; (iterate))
;
; As letrec is not directly accessible from elisp, while is implemented
here
diff --git a/module/language/elisp/runtime.scm
b/module/language/elisp/runtime.scm
index cb562c3..0d783b6 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 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
@@ -39,10 +39,9 @@
(define void (list 42))
-; Values for t and nil.
+; Values for t and nil. (FIXME remove this abstraction)
-; FIXME: Use real nil.
-(define nil-value #f)
+(define nil-value #nil)
(define t-value #t)
diff --git a/module/language/elisp/runtime/macro-slot.scm
b/module/language/elisp/runtime/macro-slot.scm
index 11ab59b..e28fa31 100644
--- a/module/language/elisp/runtime/macro-slot.scm
+++ b/module/language/elisp/runtime/macro-slot.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010 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
@@ -84,27 +84,32 @@
; The and and or forms can also be easily defined with macros.
(built-in-macro and
- (lambda (. args)
- (if (null? args)
- 't
- (let iterate ((tail args))
- (if (null? (cdr tail))
- (car tail)
- `(if ,(car tail)
- ,(iterate (cdr tail))
- nil))))))
+ (case-lambda
+ (() 't)
+ ((x) x)
+ ((x . args)
+ (let iterate ((x x) (tail args))
+ (if (null? tail)
+ x
+ `(if ,x
+ ,(iterate (car tail) (cdr tail))
+ nil))))))
(built-in-macro or
- (lambda (. args)
- (let iterate ((tail args))
- (if (null? tail)
- 'nil
- (let ((var (gensym)))
- `(without-void-checks (,var)
- (lexical-let ((,var ,(car tail)))
- (if ,var
- ,var
- ,(iterate (cdr tail))))))))))
+ (case-lambda
+ (() 'nil)
+ ((x) x)
+ ((x . args)
+ (let iterate ((x x) (tail args))
+ (if (null? tail)
+ x
+ (let ((var (gensym)))
+ `(without-void-checks
+ (,var)
+ (lexical-let ((,var ,x))
+ (if ,var
+ ,var
+ ,(iterate (car tail) (cdr tail)))))))))))
; Define the dotimes and dolist iteration macros.
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 1c46541..9c23854 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -1,6 +1,6 @@
;;; Guile Low Intermediate Language
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -75,6 +75,8 @@
<glil-mv-call> make-glil-mv-call glil-mv-call?
glil-mv-call-nargs glil-mv-call-ra
+ <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label
glil-prompt-escape-only?
+
parse-glil unparse-glil))
(define (print-glil x port)
@@ -101,7 +103,8 @@
(<glil-label> label)
(<glil-branch> inst label)
(<glil-call> inst nargs)
- (<glil-mv-call> nargs ra))
+ (<glil-mv-call> nargs ra)
+ (<glil-prompt> label escape-only?))
@@ -129,6 +132,8 @@
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
+ ((prompt ,label ,escape-only?)
+ (make-glil-prompt label escape-only?))
(else (error "invalid glil" x))))
(define (unparse-glil glil)
@@ -160,4 +165,6 @@
((<glil-label> label) `(label ,label))
((<glil-branch> inst label) `(branch ,inst ,label))
((<glil-call> inst nargs) `(call ,inst ,nargs))
- ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))))
+ ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
+ ((<glil-prompt> label escape-only?)
+ `(prompt ,label escape-only?))))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index 32c5a9d..bfc0a36 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -1,6 +1,6 @@
;;; Guile VM assembler
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -333,13 +333,20 @@
arities))
((<glil-mv-bind> vars rest)
- (values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars addr)
- source-alist
- label-alist
- object-alist
- arities))
-
+ (if (integer? vars)
+ (values `((truncate-values ,vars ,(if rest 1 0)))
+ bindings
+ source-alist
+ label-alist
+ object-alist
+ arities)
+ (values `((truncate-values ,(length vars) ,(if rest 1 0)))
+ (open-binding bindings vars addr)
+ source-alist
+ label-alist
+ object-alist
+ arities)))
+
((<glil-unbind>)
(values '()
(close-binding bindings addr)
@@ -512,7 +519,10 @@
(error "Wrong number of stack arguments to instruction:" inst
nargs)))))
((<glil-mv-call> nargs ra)
- (emit-code `((mv-call ,nargs ,ra))))))
+ (emit-code `((mv-call ,nargs ,ra))))
+
+ ((<glil-prompt> label escape-only?)
+ (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
(define (dump-object x addr)
(define (too-long x)
@@ -558,7 +568,8 @@
`(,@kar
,@(dump-object (cdr x) (addr+ addr kar))
(cons))))
- ((vector? x)
+ ((and (vector? x)
+ (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
(let* ((len (vector-length x))
(tail (if (>= len 65536)
(too-long "vector")
@@ -579,6 +590,21 @@
(addr+ (addr+ addr type) shape)
8
4))))
+ ((array? x)
+ ;; an array of generic scheme values
+ (let* ((contents (array-contents x))
+ (len (vector-length contents)))
+ (let dump-objects ((i 0) (codes '()) (addr addr))
+ (if (< i len)
+ (let ((code (dump-object (vector-ref contents i) addr)))
+ (dump-objects (1+ i) (cons code codes)
+ (addr+ addr code)))
+ (fold append
+ `(,@(dump-object (array-shape x) addr)
+ (make-array ,(quotient (ash len -16) 256)
+ ,(logand #xff (ash len -8))
+ ,(logand #xff len)))
+ codes)))))
(else
(error "assemble: unrecognized object" x))))
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
index 9163538..a50b640 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -123,7 +123,7 @@
((make-false)
(lp (cdr in) (cons #f stack) out (1+ pos)))
((make-nil)
- (lp (cdr in) (cons %nil stack) out (1+ pos)))
+ (lp (cdr in) (cons #nil stack) out (1+ pos)))
((load-program ,labels ,sublen ,meta . ,body)
(lp (cdr in)
(cons (decompile-load-program (decompile-meta meta)
@@ -183,9 +183,9 @@
(cons (make-glil-call 'mul 2)
(emit-constants (list-head stack 2) out))
(+ pos 1)))
- ((goto/args ,n)
+ ((tail-call ,n)
(lp (cdr in) (list-tail stack (1+ n))
- (cons (make-glil-call 'goto/args n)
+ (cons (make-glil-call 'tail-call n)
(emit-constants (list-head stack (1+ n)) out))
(+ pos 2)))
(else (error "unsupported decompilation" (car in)))))))))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 9837c5c..707dd1f 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -53,6 +53,11 @@
(lp (acons (binding:index b) (list b) ret)
(cdr locs))))))))
+(define (program-free-variables program)
+ (list->vector
+ (map (lambda (i) (program-free-variable-ref program i))
+ (iota (program-num-free-variables program)))))
+
(define (decompile-value x env opts)
(cond
((program? x)
diff --git a/module/language/scheme/compile-tree-il.scm
b/module/language/scheme/compile-tree-il.scm
index 5d01a26..6db2572 100644
--- a/module/language/scheme/compile-tree-il.scm
+++ b/module/language/scheme/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Scheme specification
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -29,6 +29,6 @@
(save-module-excursion
(lambda ()
(set-current-module e)
- (let* ((x (sc-expand x 'c '(compile load eval)))
+ (let* ((x (macroexpand x 'c '(compile load eval)))
(cenv (current-module)))
(values x cenv cenv)))))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 3ac3856..8daf49a 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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
@@ -45,6 +45,12 @@
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
<let-values> let-values? make-let-values let-values-src
let-values-exp let-values-body
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder
dynwind-body dynwind-unwinder
+ <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals
dynlet-body
+ <dynref> dynref? make-dynref dynref-src dynref-fluid
+ <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
+ <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body
prompt-handler
+ <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
parse-tree-il
unparse-tree-il
@@ -74,7 +80,13 @@
(<let> names vars vals body)
(<letrec> names vars vals body)
(<fix> names vars vals body)
- (<let-values> exp body))
+ (<let-values> exp body)
+ (<dynwind> winder body unwinder)
+ (<dynlet> fluids vals body)
+ (<dynref> fluid)
+ (<dynset> fluid exp)
+ (<prompt> tag body handler)
+ (<abort> tag args tail))
@@ -165,6 +177,24 @@
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
+ ((dynwind ,winder ,body ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+
+ ((dynlet ,fluids ,vals ,body)
+ (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
+
+ ((dynref ,fluid)
+ (make-dynref loc (retrans fluid)))
+
+ ((dynset ,fluid ,exp)
+ (make-dynset loc (retrans fluid) (retrans exp)))
+
+ ((prompt ,tag ,body ,handler)
+ (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
+
+ ((abort ,tag ,args ,tail)
+ (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
+
(else
(error "unrecognized tree-il" exp)))))
@@ -227,7 +257,28 @@
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<let-values> exp body)
- `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+ `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
+
+ ((<dynwind> body winder unwinder)
+ `(dynwind ,(unparse-tree-il body)
+ ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
+
+ ((<dynlet> fluids vals body)
+ `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
+ ,(unparse-tree-il body)))
+
+ ((<dynref> fluid)
+ `(dynref ,(unparse-tree-il fluid)))
+
+ ((<dynset> fluid exp)
+ `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
+
+ ((<prompt> tag body handler)
+ `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)))
+
+ ((<abort> tag args tail)
+ `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
+ ,(unparse-tree-il tail)))))
(define (tree-il->scheme e)
(record-case e
@@ -299,7 +350,34 @@
((<let-values> exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
- ,(tree-il->scheme (make-lambda #f '() body))))))
+ ,(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)
+ `((@ (ice-9 control) 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-fold leaf down up seed tree)
@@ -352,6 +430,24 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
+ ((<dynwind> body winder unwinder)
+ (up tree (loop unwinder
+ (loop winder
+ (loop body (down tree result))))))
+ ((<dynlet> fluids vals body)
+ (up tree (loop body
+ (loop vals
+ (loop fluids (down tree result))))))
+ ((<dynref> fluid)
+ (up tree (loop fluid (down tree result))))
+ ((<dynset> fluid exp)
+ (up tree (loop exp (loop fluid (down tree result)))))
+ ((<prompt> tag body handler)
+ (up tree
+ (loop tag (loop body (loop handler
+ (down tree result))))))
+ ((<abort> tag args tail)
+ (up tree (loop tail (loop args (loop tag (down tree result))))))
(else
(leaf tree result))))))
@@ -407,6 +503,27 @@ This is an implementation of `foldts' as described by Andy
Wingo in
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
+ ((<dynwind> body winder unwinder)
+ (let*-values (((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts winder seed ...)))
+ (foldts unwinder seed ...)))
+ ((<dynlet> fluids vals body)
+ (let*-values (((seed ...) (fold-values foldts fluids seed
...))
+ ((seed ...) (fold-values foldts vals seed
...)))
+ (foldts body seed ...)))
+ ((<dynref> fluid)
+ (foldts fluid seed ...))
+ ((<dynset> fluid exp)
+ (let*-values (((seed ...) (foldts fluid seed ...)))
+ (foldts exp seed ...)))
+ ((<prompt> tag body handler)
+ (let*-values (((seed ...) (foldts tag seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (foldts handler seed ...)))
+ ((<abort> tag args tail)
+ (let*-values (((seed ...) (foldts tag seed ...))
+ ((seed ...) (fold-values foldts args seed
...)))
+ (foldts tail seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))))
@@ -463,6 +580,33 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
+ ((<dynwind> body winder unwinder)
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-unwinder x) (lp unwinder)))
+
+ ((<dynlet> fluids vals body)
+ (set! (dynlet-fluids x) (map lp fluids))
+ (set! (dynlet-vals x) (map lp vals))
+ (set! (dynlet-body x) (lp body)))
+
+ ((<dynref> fluid)
+ (set! (dynref-fluid x) (lp fluid)))
+
+ ((<dynset> fluid exp)
+ (set! (dynset-fluid x) (lp fluid))
+ (set! (dynset-exp x) (lp exp)))
+
+ ((<prompt> tag body handler)
+ (set! (prompt-tag x) (lp tag))
+ (set! (prompt-body x) (lp body))
+ (set! (prompt-handler x) (lp handler)))
+
+ ((<abort> tag args tail)
+ (set! (abort-tag x) (lp tag))
+ (set! (abort-args x) (map lp args))
+ (set! (abort-tail x) (lp tail)))
+
(else #f))
(or (f x) x)))
@@ -519,5 +663,32 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
+ ((<dynwind> body winder unwinder)
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-unwinder x) (lp unwinder)))
+
+ ((<dynlet> fluids vals body)
+ (set! (dynlet-fluids x) (map lp fluids))
+ (set! (dynlet-vals x) (map lp vals))
+ (set! (dynlet-body x) (lp body)))
+
+ ((<dynref> fluid)
+ (set! (dynref-fluid x) (lp fluid)))
+
+ ((<dynset> fluid exp)
+ (set! (dynset-fluid x) (lp fluid))
+ (set! (dynset-exp x) (lp exp)))
+
+ ((<prompt> tag body handler)
+ (set! (prompt-tag x) (lp tag))
+ (set! (prompt-body x) (lp body))
+ (set! (prompt-handler x) (lp handler)))
+
+ ((<abort> tag args tail)
+ (set! (abort-tag x) (lp tag))
+ (set! (abort-args x) (map lp args))
+ (set! (abort-tail x) (lp tail)))
+
(else #f))
x)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index a8f8e4a..0c3cbf8 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1,17 +1,17 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010 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
@@ -21,6 +21,8 @@
(define-module (language tree-il analyze)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 vlist)
#:use-module (system base syntax)
#:use-module (system base message)
#:use-module (system vm program)
@@ -29,6 +31,7 @@
#:export (analyze-lexicals
analyze-tree
unused-variable-analysis
+ unused-toplevel-analysis
unbound-variable-analysis
arity-analysis))
@@ -79,9 +82,9 @@
;; this specific case. A proper solution would be some sort of liveness
;; analysis, and not our linear allocation algorithm.
;;
-;; Closure variables are captured when a closure is created, and stored
-;; in a vector. Each closure variable has a unique index into that
-;; vector.
+;; Closure variables are captured when a closure is created, and stored in a
+;; vector inline to the closure object itself. Each closure variable has a
+;; unique index into that vector.
;;
;; There is one more complication. Procedures bound by <fix> may, in
;; some cases, be rendered inline to their parent procedure. That is to
@@ -122,11 +125,18 @@
;; generated code can skip argument checks at runtime if they match at
;; compile-time.
;;
+;; Also, while we're a-traversing and an-allocating, we check prompt
+;; handlers to see if the "continuation" argument is used. If not, we
+;; mark the prompt as being "escape-only". This allows us to implement
+;; `catch' and `throw' using `prompt' and `control', but without causing
+;; a continuation to be reified. Heh heh.
+;;
;; That is:
;;
;; sym -> {lambda -> address}
;; lambda -> (labels . free-locs)
;; lambda-case -> (gensym . nlocs)
+;; prompt -> escape-only?
;;
;; address ::= (local? boxed? . index)
;; labels ::= ((sym . lambda) ...)
@@ -326,6 +336,24 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
+ ((<dynwind> body winder unwinder)
+ (lset-union eq? (step body) (step winder) (step unwinder)))
+
+ ((<dynlet> fluids vals body)
+ (apply lset-union eq? (step body) (map step (append fluids vals))))
+
+ ((<dynref> fluid)
+ (step fluid))
+
+ ((<dynset> fluid exp)
+ (lset-union eq? (step fluid) (step exp)))
+
+ ((<prompt> tag body handler)
+ (lset-union eq? (step tag) (step body) (step handler)))
+
+ ((<abort> tag args tail)
+ (apply lset-union eq? (step tag) (step tail) (map step args)))
+
(else '())))
;; allocation: sym -> {lambda -> address}
@@ -388,7 +416,7 @@
(allocate! body proc n)
;; inits not logically at the end, but they
;; are the list...
- (map (lambda (x) (allocate! x body n)) inits))))
+ (map (lambda (x) (allocate! x proc n)) inits))))
;; label and nlocs for the case
(hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
nlocs)
@@ -477,6 +505,29 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
+ ((<dynwind> body winder unwinder)
+ (max (recur body) (recur winder) (recur unwinder)))
+
+ ((<dynlet> fluids vals body)
+ (apply max (recur body) (map recur (append fluids vals))))
+
+ ((<dynref> fluid)
+ (recur fluid))
+
+ ((<dynset> fluid exp)
+ (max (recur fluid) (recur exp)))
+
+ ((<prompt> tag body handler)
+ (let ((cont-var (and (lambda-case? handler)
+ (pair? (lambda-case-vars handler))
+ (car (lambda-case-vars handler)))))
+ (hashq-set! allocation x
+ (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
+ (max (recur tag) (recur body) (recur handler))))
+
+ ((<abort> tag args tail)
+ (apply max (recur tag) (recur tail) (map recur args)))
+
(else n)))
(analyze! x #f '() #t #f)
@@ -492,33 +543,47 @@
(define-record-type <tree-analysis>
(make-tree-analysis leaf down up post init)
tree-analysis?
- (leaf tree-analysis-leaf) ;; (lambda (x result env) ...)
- (down tree-analysis-down) ;; (lambda (x result env) ...)
- (up tree-analysis-up) ;; (lambda (x result env) ...)
+ (leaf tree-analysis-leaf) ;; (lambda (x result env locs) ...)
+ (down tree-analysis-down) ;; (lambda (x result env locs) ...)
+ (up tree-analysis-up) ;; (lambda (x result env locs) ...)
(post tree-analysis-post) ;; (lambda (result env) ...)
(init tree-analysis-init)) ;; arbitrary value
(define (analyze-tree analyses tree env)
"Run all tree analyses listed in ANALYSES on TREE for ENV, using
-`tree-il-fold'. Return TREE."
- (define (traverse proc)
+`tree-il-fold'. Return TREE. The leaf/down/up procedures of each analysis are
+passed a ``location stack', which is the stack of `tree-il-src' values for each
+parent tree (a list); it can be used to approximate source location when
+accurate information is missing from a given `tree-il' element."
+
+ (define (traverse proc update-locs)
+ ;; Return a tree traversing procedure that returns a list of analysis
+ ;; results prepended by the location stack.
(lambda (x results)
- (map (lambda (analysis result)
- ((proc analysis) x result env))
- analyses
- results)))
+ (let ((locs (update-locs x (car results))))
+ (cons locs ;; the location stack
+ (map (lambda (analysis result)
+ ((proc analysis) x result env locs))
+ analyses
+ (cdr results))))))
+
+ ;; Keeping/extending/shrinking the location stack.
+ (define (keep-locs x locs) locs)
+ (define (extend-locs x locs) (cons (tree-il-src x) locs))
+ (define (shrink-locs x locs) (cdr locs))
(let ((results
- (tree-il-fold (traverse tree-analysis-leaf)
- (traverse tree-analysis-down)
- (traverse tree-analysis-up)
- (map tree-analysis-init analyses)
+ (tree-il-fold (traverse tree-analysis-leaf keep-locs)
+ (traverse tree-analysis-down extend-locs)
+ (traverse tree-analysis-up shrink-locs)
+ (cons '() ;; empty location stack
+ (map tree-analysis-init analyses))
tree)))
(for-each (lambda (analysis result)
((tree-analysis-post analysis) result env))
analyses
- results))
+ (cdr results)))
tree)
@@ -528,90 +593,77 @@
;;;
;; <binding-info> records are used during tree traversals in
-;; `report-unused-variables'. They contain a list of the local vars
-;; currently in scope, a list of locals vars that have been referenced, and a
-;; "location stack" (the stack of `tree-il-src' values for each parent tree).
+;; `unused-variable-analysis'. They contain a list of the local vars
+;; currently in scope, and a list of locals vars that have been referenced.
(define-record-type <binding-info>
- (make-binding-info vars refs locs)
+ (make-binding-info vars refs)
binding-info?
(vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
- (refs binding-info-refs) ;; (GENSYM ...)
- (locs binding-info-locs)) ;; (LOCATION ...)
+ (refs binding-info-refs)) ;; (GENSYM ...)
(define unused-variable-analysis
;; Report unused variables in the given tree.
(make-tree-analysis
- (lambda (x info env)
+ (lambda (x info env locs)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
+ (vars (binding-info-vars info)))
(record-case x
((<lexical-ref> gensym)
- (make-binding-info vars (cons gensym refs) locs))
+ (make-binding-info vars (vhash-consq gensym #t refs)))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Going down into X: extend INFO's variable list
;; accordingly.
(let ((refs (binding-info-refs info))
(vars (binding-info-vars info))
- (locs (binding-info-locs info))
(src (tree-il-src x)))
(define (extend inner-vars inner-names)
- (append (map (lambda (var name)
- (list var name src))
- inner-vars
- inner-names)
- vars))
+ (fold (lambda (var name vars)
+ (vhash-consq var (list name src) vars))
+ vars
+ inner-vars
+ inner-names))
+
(record-case x
((<lexical-set> gensym)
- (make-binding-info vars (cons gensym refs)
- (cons src locs)))
+ (make-binding-info vars (vhash-consq gensym #t refs)))
((<lambda-case> req opt inits rest kw vars)
(let ((names `(,@req
,@(or opt '())
,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '()))))
- (make-binding-info (extend vars names) refs
- (cons src locs))))
+ (make-binding-info (extend vars names) refs)))
((<let> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
+ (make-binding-info (extend vars names) refs))
((<letrec> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
+ (make-binding-info (extend vars names) refs))
((<fix> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
+ (make-binding-info (extend vars names) refs))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Leaving X's scope: shrink INFO's variable list
;; accordingly and reported unused nested variables.
(let ((refs (binding-info-refs info))
- (vars (binding-info-vars info))
- (locs (binding-info-locs info)))
+ (vars (binding-info-vars info)))
(define (shrink inner-vars refs)
- (for-each (lambda (var)
- (let ((gensym (car var)))
- ;; Don't report lambda parameters as
- ;; unused.
- (if (and (not (memq gensym refs))
- (not (and (lambda-case? x)
- (memq gensym
- inner-vars))))
- (let ((name (cadr var))
- ;; We can get approximate
- ;; source location by going up
- ;; the LOCS location stack.
- (loc (or (caddr var)
- (find pair? locs))))
- (warning 'unused-variable loc name)))))
- (filter (lambda (var)
- (memq (car var) inner-vars))
- vars))
- (fold alist-delete vars inner-vars))
+ (vlist-for-each
+ (lambda (var)
+ (let ((gensym (car var)))
+ ;; Don't report lambda parameters as unused.
+ (if (and (memq gensym inner-vars)
+ (not (vhash-assq gensym refs))
+ (not (lambda-case? x)))
+ (let ((name (cadr var))
+ ;; We can get approximate source location by going up
+ ;; the LOCS location stack.
+ (loc (or (caddr var)
+ (find pair? locs))))
+ (warning 'unused-variable loc name)))))
+ vars)
+ (vlist-drop vars (length inner-vars)))
;; For simplicity, we leave REFS untouched, i.e., with
;; names of variables that are now going out of scope.
@@ -619,21 +671,173 @@
;; makes REFS unnecessarily fat.
(record-case x
((<lambda-case> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
((<let> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
((<letrec> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
((<fix> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
+ (make-binding-info (shrink vars refs) refs))
(else info))))
(lambda (result env) #t)
- (make-binding-info '() '() '())))
+ (make-binding-info vlist-null vlist-null)))
+
+
+;;;
+;;; Unused top-level variable analysis.
+;;;
+
+;; <reference-graph> record top-level definitions that are made, references to
+;; top-level definitions and their context (the top-level definition in which
+;; the reference appears), as well as the current context (the top-level
+;; definition we're currently in). The second part (`refs' below) is
+;; effectively a graph from which we can determine unused top-level
definitions.
+(define-record-type <reference-graph>
+ (make-reference-graph refs defs toplevel-context)
+ reference-graph?
+ (defs reference-graph-defs) ;; ((NAME . LOC) ...)
+ (refs reference-graph-refs) ;; ((REF-CONTEXT REF ...) ...)
+ (toplevel-context reference-graph-toplevel-context)) ;; NAME | #f
+
+(define (graph-reachable-nodes root refs reachable)
+ ;; Add to REACHABLE the nodes reachable from ROOT in graph REFS. REFS is a
+ ;; vhash mapping nodes to the list of their children: for instance,
+ ;; ((A -> (B C)) (B -> (A)) (C -> ())) corresponds to
+ ;;
+ ;; ,-------.
+ ;; v |
+ ;; A ----> B
+ ;; |
+ ;; v
+ ;; C
+ ;;
+ ;; REACHABLE is a vhash of nodes known to be otherwise reachable.
+
+ (let loop ((root root)
+ (path vlist-null)
+ (result reachable))
+ (if (or (vhash-assq root path)
+ (vhash-assq root result))
+ result
+ (let* ((children (or (and=> (vhash-assq root refs) cdr) '()))
+ (path (vhash-consq root #t path))
+ (result (fold (lambda (kid result)
+ (loop kid path result))
+ result
+ children)))
+ (fold (lambda (kid result)
+ (vhash-consq kid #t result))
+ result
+ children)))))
+
+(define (graph-reachable-nodes* roots refs)
+ ;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS.
+ (vlist-fold (lambda (root+true result)
+ (let* ((root (car root+true))
+ (reachable (graph-reachable-nodes root refs result)))
+ (vhash-consq root #t reachable)))
+ vlist-null
+ roots))
+
+(define (partition* pred vhash)
+ ;; Partition VHASH according to PRED. Return the two resulting vhashes.
+ (let ((result
+ (vlist-fold (lambda (k+v result)
+ (let ((k (car k+v))
+ (v (cdr k+v))
+ (r1 (car result))
+ (r2 (cdr result)))
+ (if (pred k)
+ (cons (vhash-consq k v r1) r2)
+ (cons r1 (vhash-consq k v r2)))))
+ (cons vlist-null vlist-null)
+ vhash)))
+ (values (car result) (cdr result))))
+
+(define unused-toplevel-analysis
+ ;; Report unused top-level definitions that are not exported.
+ (let ((add-ref-from-context
+ (lambda (graph name)
+ ;; Add an edge CTX -> NAME in GRAPH.
+ (let* ((refs (reference-graph-refs graph))
+ (defs (reference-graph-defs graph))
+ (ctx (reference-graph-toplevel-context graph))
+ (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '())))
+ (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs)
+ defs ctx)))))
+ (define (macro-variable? name env)
+ (and (module? env)
+ (let ((var (module-variable env name)))
+ (and var (variable-bound? var)
+ (macro? (variable-ref var))))))
+
+ (make-tree-analysis
+ (lambda (x graph env locs)
+ ;; X is a leaf.
+ (let ((ctx (reference-graph-toplevel-context graph)))
+ (record-case x
+ ((<toplevel-ref> name src)
+ (add-ref-from-context graph name))
+ (else graph))))
+
+ (lambda (x graph env locs)
+ ;; Going down into X.
+ (let ((ctx (reference-graph-toplevel-context graph))
+ (refs (reference-graph-refs graph))
+ (defs (reference-graph-defs graph)))
+ (record-case x
+ ((<toplevel-define> name src)
+ (let ((refs refs)
+ (defs (vhash-consq name (or src (find pair? locs))
+ defs)))
+ (make-reference-graph refs defs name)))
+ ((<toplevel-set> name src)
+ (add-ref-from-context graph name))
+ (else graph))))
+
+ (lambda (x graph env locs)
+ ;; Leaving X's scope.
+ (record-case x
+ ((<toplevel-define>)
+ (let ((refs (reference-graph-refs graph))
+ (defs (reference-graph-defs graph)))
+ (make-reference-graph refs defs #f)))
+ (else graph)))
+
+ (lambda (graph env)
+ ;; Process the resulting reference graph: determine all private
definitions
+ ;; not reachable from any public definition. Macros
+ ;; (syntax-transformers), which are globally bound, never considered
+ ;; unused since we can't tell whether a macro is actually used; in
+ ;; addition, macros are considered roots of the graph since they may use
+ ;; private bindings. FIXME: The `make-syntax-transformer' calls don't
+ ;; contain any literal `toplevel-ref' of the global bindings they use so
+ ;; this strategy fails.
+ (define (exported? name)
+ (if (module? env)
+ (module-variable (module-public-interface env) name)
+ #t))
+
+ (let-values (((public-defs private-defs)
+ (partition* (lambda (name)
+ (or (exported? name)
+ (macro-variable? name env)))
+ (reference-graph-defs graph))))
+ (let* ((roots (vhash-consq #f #t public-defs))
+ (refs (reference-graph-refs graph))
+ (reachable (graph-reachable-nodes* roots refs))
+ (unused (vlist-filter (lambda (name+src)
+ (not (vhash-assq (car name+src)
+ reachable)))
+ private-defs)))
+ (vlist-for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unused-toplevel loc name)))
+ unused))))
+
+ (make-reference-graph vlist-null vlist-null #f))))
;;;
@@ -642,14 +846,13 @@
;; <toplevel-info> records are used during tree traversal in search of
;; possibly unbound variable. They contain a list of references to
-;; potentially unbound top-level variables, a list of the top-level defines
-;; that have been encountered, and a "location stack" (see above).
+;; potentially unbound top-level variables, and a list of the top-level
+;; defines that have been encountered.
(define-record-type <toplevel-info>
- (make-toplevel-info refs defs locs)
+ (make-toplevel-info refs defs)
toplevel-info?
(refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
- (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
- (locs toplevel-info-locs)) ;; (LOCATION ...)
+ (defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
;; If application of PROC to ARGS is a GOOPS top-level definition, return
@@ -679,49 +882,44 @@
(define unbound-variable-analysis
;; Report possibly unbound variables in the given tree.
(make-tree-analysis
- (lambda (x info env)
+ (lambda (x info env locs)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
+ (defs (toplevel-info-defs info)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
- (memq name defs)))
+ (vhash-assq name defs)))
(record-case x
((<toplevel-ref> name src)
(if (bound? name)
info
(let ((src (or src (find pair? locs))))
- (make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
+ (make-toplevel-info (vhash-consq name src refs)
+ defs))))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Going down into X.
(let* ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info))
- (src (tree-il-src x))
- (locs (cons src (toplevel-info-locs info))))
+ (src (tree-il-src x)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
- (memq name defs)))
+ (vhash-assq name defs)))
(record-case x
((<toplevel-set> name src)
(if (bound? name)
- (make-toplevel-info refs defs locs)
+ (make-toplevel-info refs defs)
(let ((src (find pair? locs)))
- (make-toplevel-info (alist-cons name src refs)
- defs
- locs))))
+ (make-toplevel-info (vhash-consq name src refs)
+ defs))))
((<toplevel-define> name)
- (make-toplevel-info (alist-delete name refs eq?)
- (cons name defs)
- locs))
+ (make-toplevel-info (vhash-delete name refs eq?)
+ (vhash-consq name #t defs)))
((<application> proc args)
;; Check for a dynamic top-level definition, as is
@@ -729,30 +927,26 @@
(let ((name (goops-toplevel-definition proc args
env)))
(if (symbol? name)
- (make-toplevel-info (alist-delete name refs
+ (make-toplevel-info (vhash-delete name refs
eq?)
- (cons name defs)
- locs)
- (make-toplevel-info refs defs locs))))
+ (vhash-consq name #t defs))
+ (make-toplevel-info refs defs))))
(else
- (make-toplevel-info refs defs locs)))))
+ (make-toplevel-info refs defs)))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Leaving X's scope.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (locs (toplevel-info-locs info)))
- (make-toplevel-info refs defs (cdr locs))))
+ info)
(lambda (toplevel env)
;; Post-process the result.
- (for-each (lambda (name+loc)
- (let ((name (car name+loc))
- (loc (cdr name+loc)))
- (warning 'unbound-variable loc name)))
- (reverse (toplevel-info-refs toplevel))))
+ (vlist-for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unbound-variable loc name)))
+ (vlist-reverse (toplevel-info-refs toplevel))))
- (make-toplevel-info '() '() '())))
+ (make-toplevel-info vlist-null vlist-null)))
;;;
@@ -860,10 +1054,10 @@
(define arity-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x info env)
+ (lambda (x info env locs)
;; X is a leaf.
info)
- (lambda (x info env)
+ (lambda (x info env locs)
;; Down into X.
(define (extend lexical-name val info)
;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
@@ -873,20 +1067,20 @@
(record-case val
((<lambda> body)
(make-arity-info toplevel-calls
- (alist-cons lexical-name val
- lexical-lambdas)
+ (vhash-consq lexical-name val
+ lexical-lambdas)
toplevel-lambdas))
((<lexical-ref> gensym)
;; lexical alias
- (let ((val* (assq gensym lexical-lambdas)))
+ (let ((val* (vhash-assq gensym lexical-lambdas)))
(if (pair? val*)
(extend lexical-name (cdr val*) info)
info)))
((<toplevel-ref> name)
;; top-level alias
(make-arity-info toplevel-calls
- (alist-cons lexical-name val
- lexical-lambdas)
+ (vhash-consq lexical-name val
+ lexical-lambdas)
toplevel-lambdas))
(else info))))
@@ -900,17 +1094,17 @@
((<lambda> body)
(make-arity-info toplevel-calls
lexical-lambdas
- (alist-cons name exp toplevel-lambdas)))
+ (vhash-consq name exp toplevel-lambdas)))
((<toplevel-ref> name)
;; alias for another toplevel
- (let ((proc (assq name toplevel-lambdas)))
+ (let ((proc (vhash-assq name toplevel-lambdas)))
(make-arity-info toplevel-calls
lexical-lambdas
- (alist-cons (toplevel-define-name x)
- (if (pair? proc)
- (cdr proc)
- exp)
- toplevel-lambdas))))
+ (vhash-consq (toplevel-define-name x)
+ (if (pair? proc)
+ (cdr proc)
+ exp)
+ toplevel-lambdas))))
(else info)))
((<let> vars vals)
(fold extend info vars vals))
@@ -925,16 +1119,16 @@
(validate-arity proc x #t)
info)
((<toplevel-ref> name)
- (make-arity-info (alist-cons name x toplevel-calls)
+ (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas
toplevel-lambdas))
((<lexical-ref> gensym)
- (let ((proc (assq gensym lexical-lambdas)))
+ (let ((proc (vhash-assq gensym lexical-lambdas)))
(if (pair? proc)
(record-case (cdr proc)
((<toplevel-ref> name)
;; alias to toplevel
- (make-arity-info (alist-cons name x toplevel-calls)
+ (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas
toplevel-lambdas))
(else
@@ -947,7 +1141,7 @@
(else info)))
(else info))))
- (lambda (x info env)
+ (lambda (x info env locs)
;; Up from X.
(define (shrink name val info)
;; Remove NAME from the lexical-lambdas of INFO.
@@ -955,7 +1149,9 @@
(lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info)))
(make-arity-info toplevel-calls
- (alist-delete name lexical-lambdas eq?)
+ (if (vhash-assq name lexical-lambdas)
+ (vlist-tail lexical-lambdas)
+ lexical-lambdas)
toplevel-lambdas)))
(let ((toplevel-calls (toplevel-procedure-calls info))
@@ -976,26 +1172,25 @@
;; encountered.
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
- (for-each (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
- (proc
- (or (assoc-ref toplevel-lambdas name)
- (and (module? env)
- (false-if-exception
- (module-ref env name)))))
- (proc*
- ;; handle toplevel aliases
- (if (toplevel-ref? proc)
- (let ((name (toplevel-ref-name proc)))
- (and (module? env)
- (false-if-exception
- (module-ref env name))))
- proc)))
- ;; (format #t "toplevel-call to ~A (~A) from ~A~%"
- ;; name proc* application)
- (if (or (lambda? proc*) (procedure? proc*))
- (validate-arity proc* application (lambda? proc*)))))
- toplevel-calls)))
-
- (make-arity-info '() '() '())))
+ (vlist-for-each
+ (lambda (name+application)
+ (let* ((name (car name+application))
+ (application (cdr name+application))
+ (proc
+ (or (and=> (vhash-assq name toplevel-lambdas) cdr)
+ (and (module? env)
+ (false-if-exception
+ (module-ref env name)))))
+ (proc*
+ ;; handle toplevel aliases
+ (if (toplevel-ref? proc)
+ (let ((name (toplevel-ref-name proc)))
+ (and (module? env)
+ (false-if-exception
+ (module-ref env name))))
+ proc)))
+ (if (or (lambda? proc*) (procedure? proc*))
+ (validate-arity proc* application (lambda? proc*)))))
+ toplevel-calls)))
+
+ (make-arity-info vlist-null vlist-null vlist-null)))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index c0dae64..b45423a 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010 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
@@ -45,6 +45,7 @@
(define %warning-passes
`((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
(arity-mismatch . ,arity-analysis)))
@@ -64,11 +65,10 @@
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
- (with-fluid* *comp-module* e
- (lambda ()
- (values (flatten-lambda x #f allocation)
- e
- e)))))
+ (with-fluids ((*comp-module* e))
+ (values (flatten-lambda x #f allocation)
+ e
+ e))))
@@ -115,8 +115,11 @@
((variable-ref . 1) . variable-ref)
;; nb, *not* variable-set! -- the args are switched
((variable-set . 2) . variable-set)
+ ((variable-bound? . 1) . variable-bound?)
((struct? . 1) . struct?)
((struct-vtable . 1) . struct-vtable)
+ ((struct-ref . 2) . struct-ref)
+ ((struct-set! . 3) . struct-set)
(make-struct . make-struct)
;; hack for javascript
@@ -173,7 +176,7 @@
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t ,boxed? . ,n)
(list id boxed? n))
- (,x (error "badness" x))))
+ (,x (error "badness" id v x))))
ids
vars))
@@ -277,7 +280,7 @@
((tail)
(comp-push proc)
(for-each comp-push args)
- (emit-code src (make-glil-call 'goto/apply (1+ (length
args)))))
+ (emit-code src (make-glil-call 'tail-apply (1+ (length
args)))))
((push)
(emit-code src (make-glil-call 'new-frame 0))
(comp-push proc)
@@ -344,12 +347,12 @@
(comp-push producer)
(emit-code src (make-glil-mv-call 0 MV))
(case context
- ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
(else (emit-code src (make-glil-call 'call 1))
(emit-branch #f 'br POST)))
(emit-label MV)
(case context
- ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
(else (emit-code src (make-glil-call 'call/nargs 0))
(emit-label POST)
(if (eq? context 'drop)
@@ -362,7 +365,7 @@
(case context
((tail)
(comp-push (car args))
- (emit-code src (make-glil-call 'goto/cc 1)))
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
((vals)
(comp-vals
(make-application
@@ -482,7 +485,7 @@
(for-each comp-push args)
(let ((len (length args)))
(case context
- ((tail) (emit-code src (make-glil-call 'goto/args len)))
+ ((tail) (emit-code src (make-glil-call 'tail-call len)))
((push) (emit-code src (make-glil-call 'call len))
(maybe-emit-return))
((vals) (emit-code src (make-glil-mv-call len MVRA))
@@ -492,8 +495,7 @@
(emit-code #f (make-glil-call 'drop 1))
(emit-branch #f 'br (or RA POST))
(emit-label MV)
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
+ (emit-code #f (make-glil-mv-bind 0 #f))
(if RA
(emit-branch #f 'br RA)
(emit-label POST)))))))))
@@ -663,8 +665,8 @@
(emit-code #f (make-glil-lexical local? #f 'ref n)))
(else (error "what" x loc))))
free-locs)
- (emit-code #f (make-glil-call 'vector (length free-locs)))
- (emit-code #f (make-glil-call 'make-closure 2)))))))
+ (emit-code #f (make-glil-call 'make-closure
+ (length free-locs))))))))
(maybe-emit-return))
((<lambda-case> src req opt rest kw inits vars alternate body)
@@ -812,13 +814,16 @@
((hashq-ref allocation x)
;; allocating a closure
(emit-code #f (flatten-lambda x v allocation))
- (if (not (null? (cdr (hashq-ref allocation x))))
- ;; Need to make-closure first, but with a temporary #f
- ;; free-variables vector, so we are mutating fresh
- ;; closures on the heap.
- (begin
- (emit-code #f (make-glil-const #f))
- (emit-code #f (make-glil-call 'make-closure 2))))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
+ (if (not (null? free-locs))
+ ;; Need to make-closure first, so we have a fresh closure
on
+ ;; the heap, but with a temporary free values.
+ (begin
+ (for-each (lambda (loc)
+ (emit-code #f (make-glil-const #f)))
+ free-locs)
+ (emit-code #f (make-glil-call 'make-closure
+ (length free-locs))))))
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
@@ -868,7 +873,6 @@
(emit-code #f (make-glil-lexical local? #f 'ref n)))
(else (error "what" x loc))))
free-locs)
- (emit-code #f (make-glil-call 'vector (length free-locs)))
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code #f (make-glil-lexical #t #f 'fix n)))
@@ -903,4 +907,226 @@
(,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
- (emit-code #f (make-glil-unbind)))))))))
+ (emit-code #f (make-glil-unbind))))))
+
+ ;; much trickier than i thought this would be, at first, due to the need
+ ;; to have body's return value(s) on the stack while the unwinder runs,
+ ;; then proceed with returning or dropping or what-have-you, interacting
+ ;; with RA and MVRA. What have you, I say.
+ ((<dynwind> src body winder unwinder)
+ (comp-push winder)
+ (comp-push unwinder)
+ (comp-drop (make-application src winder '()))
+ (emit-code #f (make-glil-call 'wind 2))
+
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop (make-application src unwinder '()))
+ ;; ...and return the val
+ (emit-code #f (make-glil-call 'return 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop (make-application src unwinder '()))
+ ;; and return the values.
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ ;; we only want one value. so ask for one value
+ (comp-push body)
+ ;; and unwind, leaving the val on the stack
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop (make-application src unwinder '())))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop (make-application src unwinder '()))
+ ;; and goto the MVRA.
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values. then unwind...
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop (make-application src unwinder '()))
+ ;; and fall through, or goto RA if there is one.
+ (if RA
+ (emit-branch #f 'br RA)))))
+
+ ((<dynlet> src fluids vals body)
+ (for-each comp-push fluids)
+ (for-each comp-push vals)
+ (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
+
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ ;; NB: in tail case, it is possible to preserve asymptotic tail
+ ;; recursion, via merging unwind-fluids structures -- but we'd need
+ ;; to compile in the body twice (once in tail context, assuming the
+ ;; caller unwinds, and once with this trampoline thing, unwinding
+ ;; ourselves).
+ (comp-vals body MV)
+ ;; one value: unwind and return
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-code #f (make-glil-call 'return 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind and return values
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ (comp-push body)
+ (emit-code #f (make-glil-call 'unwind-fluids 0)))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind and goto MVRA
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values. then unwind...
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ ;; and fall through, or goto RA if there is one.
+ (if RA
+ (emit-branch #f 'br RA)))))
+
+ ((<dynref> src fluid)
+ (case context
+ ((drop)
+ (comp-drop fluid))
+ ((push vals tail)
+ (comp-push fluid)
+ (emit-code #f (make-glil-call 'fluid-ref 1))))
+ (maybe-emit-return))
+
+ ((<dynset> src fluid exp)
+ (comp-push fluid)
+ (comp-push exp)
+ (emit-code #f (make-glil-call 'fluid-set 2))
+ (case context
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ;; What's the deal here? The deal is that we are compiling the start of a
+ ;; delimited continuation. We try to avoid heap allocation in the normal
+ ;; case; so the body is an expression, not a thunk, and we try to render
+ ;; the handler inline. Also we did some analysis, in analyze.scm, so that
+ ;; if the continuation isn't referenced, we don't reify it. This makes it
+ ;; possible to implement catch and throw with delimited continuations,
+ ;; without any overhead.
+ ((<prompt> src tag body handler)
+ (let ((H (make-label))
+ (POST (make-label))
+ (escape-only? (hashq-ref allocation x)))
+ ;; First, set up the prompt.
+ (comp-push tag)
+ (emit-code src (make-glil-prompt H escape-only?))
+
+ ;; Then we compile the body, with its normal return path, unwinding
+ ;; before proceeding.
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: unwind and return
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-code #f (make-glil-call 'return 1))
+ ;; multiple values: unwind and return
+ (emit-label MV)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ ;; we only want one value. so ask for one value, unwind, and jump
to
+ ;; post
+ (comp-push body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br POST))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+ ;; multiple values: unwind and goto MVRA
+ (emit-label MV)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values, then unwind & fall through.
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br (or RA POST))))
+
+ (emit-label H)
+ ;; Now the handler. The stack is now made up of the continuation, and
+ ;; then the args to the continuation (pushed separately), and then the
+ ;; number of args, including the continuation.
+ (record-case handler
+ ((<lambda-case> req opt kw rest vars body alternate)
+ (if (or opt kw alternate)
+ (error "unexpected lambda-case in prompt" x))
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ vars allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind))))
+
+ (if (or (eq? context 'push)
+ (and (eq? context 'drop) (not RA)))
+ (emit-label POST))))
+
+ ((<abort> src tag args tail)
+ (comp-push tag)
+ (for-each comp-push args)
+ (comp-push tail)
+ (emit-code src (make-glil-call 'abort (length args)))
+ ;; so, the abort can actually return. if it does, the values will be on
+ ;; the stack, then the MV marker, just as in an MV context.
+ (case context
+ ((tail)
+ ;; Return values.
+ (emit-code #f (make-glil-call 'return/nvalues 1)))
+ ((drop)
+ ;; Drop all values and goto RA, or otherwise fall through.
+ (emit-code #f (make-glil-mv-bind 0 #f))
+ (if RA (emit-branch #f 'br RA)))
+ ((push)
+ ;; Truncate to one value.
+ (emit-code #f (make-glil-mv-bind 1 #f)))
+ ((vals)
+ ;; Go to MVRA.
+ (emit-branch #f 'br MVRA)))))))
diff --git a/module/language/tree-il/inline.scm
b/module/language/tree-il/inline.scm
index fa1c1d5..8dd7dd3 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -1,6 +1,6 @@
;;; a simple inliner
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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,5 +110,55 @@
((<fix> vars body)
(if (null? vars) body x))
+ ((<lambda-case> req opt rest kw vars body alternate)
+ (define (args-compatible? args vars)
+ (let lp ((args args) (vars vars))
+ (cond
+ ((null? args) (null? vars))
+ ((null? vars) #f)
+ ((and (lexical-ref? (car args))
+ (eq? (lexical-ref-gensym (car args)) (car vars)))
+ (lp (cdr args) (cdr vars)))
+ (else #f))))
+
+ (and (not opt) (not kw) rest (not alternate)
+ (record-case body
+ ((<application> proc args)
+ ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+ (and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@apply)
+ (pair? args)
+ (lambda? (car args))
+ (args-compatible? (cdr args) vars)
+ (lambda-body (car args))))
+ (else #f))))
+
+ ;; Actually the opposite of inlining -- if the prompt cannot be proven to
+ ;; be escape-only, ensure that its body is the application of a thunk.
+ ((<prompt> src tag body handler)
+ (define (escape-only? handler)
+ (and (pair? (lambda-case-req handler))
+ (let ((cont (car (lambda-case-vars handler))))
+ (tree-il-fold (lambda (leaf escape-only?)
+ (and escape-only?
+ (not
+ (and (lexical-ref? leaf)
+ (eq? (lexical-ref-gensym leaf)
cont)))))
+ (lambda (down escape-only?) escape-only?)
+ (lambda (up escape-only?) escape-only?)
+ #t
+ (lambda-case-body handler)))))
+ (define (make-thunk body)
+ (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body
#f)))
+
+ (if (or (and (application? body)
+ (lambda? (application-proc body))
+ (null? (application-args body)))
+ (escape-only? handler))
+ x
+ (make-prompt src tag
+ (make-application #f (make-thunk body) '())
+ handler)))
+
(else #f)))
(post-order! inline1 x))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 83eab6f..b6953ca 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
;;; open-coding primitive procedures
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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,6 +23,7 @@
#:use-module (rnrs bytevector)
#:use-module (system base syntax)
#:use-module (language tree-il)
+ #:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
expand-primitives! effect-free-primitive?))
@@ -32,6 +33,8 @@
call-with-values @call-with-values
call-with-current-continuation @call-with-current-continuation
call/cc
+ dynamic-wind
+ @dynamic-wind
values
eq? eqv? equal?
memq memv
@@ -55,32 +58,42 @@
vector-ref vector-set!
variable-ref variable-set!
+ variable-bound?
;; args of variable-set are switched; it needs special help
- struct? struct-vtable make-struct
+ fluid-ref fluid-set!
+
+ @prompt call-with-prompt @abort abort-to-prompt
+
+ struct? struct-vtable make-struct struct-ref struct-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!))
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+ f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
(define (add-interesting-primitive! name)
(hashq-set! *interesting-primitive-vars*
@@ -106,7 +119,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref
- struct? struct-vtable make-struct
+ struct? struct-vtable make-struct struct-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref
@@ -171,13 +184,15 @@
((symbol? in) `(cons* ,@(reverse out) ,in))
((pair? (car in))
(lp (cdr in)
- (cons `(make-application src (make-primitive-ref src ',(caar
in))
- ,(inline-args (cdar in)))
+ (cons (if (eq? (caar in) 'quote)
+ `(make-const src ,@(cdar in))
+ `(make-application src (make-primitive-ref src
',(caar in))
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
(lp (cdr in) (cons (car in) out)))
- ((number? (car in))
+ ((self-evaluating? (car in))
(lp (cdr in) (cons `(make-const src ,(car in)) out)))
(else
(error "what what" (car in))))))
@@ -301,3 +316,174 @@
;; swap args
(define-primitive-expander variable-set! (var val)
(variable-set val var))
+
+(define-primitive-expander u8vector-ref (vec i)
+ (bytevector-u8-ref vec i))
+(define-primitive-expander u8vector-set! (vec i x)
+ (bytevector-u8-set! vec i x))
+(define-primitive-expander s8vector-ref (vec i)
+ (bytevector-s8-ref vec i))
+(define-primitive-expander s8vector-set! (vec i x)
+ (bytevector-s8-set! vec i x))
+
+(define-primitive-expander u16vector-ref (vec i)
+ (bytevector-u16-native-ref vec (* i 2)))
+(define-primitive-expander u16vector-set! (vec i x)
+ (bytevector-u16-native-set! vec (* i 2) x))
+(define-primitive-expander s16vector-ref (vec i)
+ (bytevector-s16-native-ref vec (* i 2)))
+(define-primitive-expander s16vector-set! (vec i x)
+ (bytevector-s16-native-set! vec (* i 2) x))
+
+(define-primitive-expander u32vector-ref (vec i)
+ (bytevector-u32-native-ref vec (* i 4)))
+(define-primitive-expander u32vector-set! (vec i x)
+ (bytevector-u32-native-set! vec (* i 4) x))
+(define-primitive-expander s32vector-ref (vec i)
+ (bytevector-s32-native-ref vec (* i 4)))
+(define-primitive-expander s32vector-set! (vec i x)
+ (bytevector-s32-native-set! vec (* i 4) x))
+
+(define-primitive-expander u64vector-ref (vec i)
+ (bytevector-u64-native-ref vec (* i 8)))
+(define-primitive-expander u64vector-set! (vec i x)
+ (bytevector-u64-native-set! vec (* i 8) x))
+(define-primitive-expander s64vector-ref (vec i)
+ (bytevector-s64-native-ref vec (* i 8)))
+(define-primitive-expander s64vector-set! (vec i x)
+ (bytevector-s64-native-set! vec (* i 8) x))
+
+(define-primitive-expander f32vector-ref (vec i)
+ (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+ (bytevector-ieee-single-native-set! vec (* i 4) x))
+(define-primitive-expander f32vector-ref (vec i)
+ (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+ (bytevector-ieee-single-native-set! vec (* i 4) x))
+
+(define-primitive-expander f64vector-ref (vec i)
+ (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+ (bytevector-ieee-double-native-set! vec (* i 8) x))
+(define-primitive-expander f64vector-ref (vec i)
+ (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+ (bytevector-ieee-double-native-set! vec (* i 8) x))
+
+(hashq-set! *primitive-expand-table*
+ 'dynamic-wind
+ (case-lambda
+ ((src pre thunk post)
+ ;; Here we will make concessions to the fact that our inliner is
+ ;; lame, and add a hack.
+ (cond
+ ((lambda? thunk)
+ (let ((PRE (gensym " pre"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre post)
+ (list PRE POST)
+ (list pre post)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ (make-application #f thunk '())
+ (make-lexical-ref #f 'post POST)))))
+ (else
+ (let ((PRE (gensym " pre"))
+ (THUNK (gensym " thunk"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre thunk post)
+ (list PRE THUNK POST)
+ (list pre thunk post)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ (make-application #f (make-lexical-ref #f 'thunk THUNK)
'())
+ (make-lexical-ref #f 'post POST)))))))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@dynamic-wind
+ (case-lambda
+ ((src pre expr post)
+ (let ((PRE (gensym " pre"))
+ (POST (gensym " post")))
+ (make-let
+ src
+ '(pre post)
+ (list PRE POST)
+ (list pre post)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'pre PRE)
+ expr
+ (make-lexical-ref #f 'post POST)))))))
+
+(hashq-set! *primitive-expand-table*
+ 'fluid-ref
+ (case-lambda
+ ((src fluid) (make-dynref src fluid))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ 'fluid-set!
+ (case-lambda
+ ((src fluid exp) (make-dynset src fluid exp))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@prompt
+ (case-lambda
+ ((src tag exp handler)
+ (let ((args-sym (gensym)))
+ (make-prompt
+ src tag exp
+ ;; 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)))
+
+(hashq-set! *primitive-expand-table*
+ '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)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table*
+ '@abort
+ (case-lambda
+ ((src tag tail-args)
+ (make-abort src tag '() tail-args))
+ (else #f)))
+(hashq-set! *primitive-expand-table*
+ 'abort-to-prompt
+ (case-lambda
+ ((src tag . args)
+ (make-abort src tag args (make-const #f '())))
+ (else #f)))
diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm
index 32929c6..9b8ac45 100644
--- a/module/rnrs/bytevector.scm
+++ b/module/rnrs/bytevector.scm
@@ -1,6 +1,6 @@
-;;;; bytevector.scm --- R6RS bytevector API
+;;;; bytevector.scm --- R6RS bytevector API -*- coding: utf-8 -*-
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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
@@ -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
-;;; Author: Ludovic Courtès <address@hidden>
+;;; Author: Ludovic Courtès <address@hidden>
;;; Commentary:
;;;
@@ -71,15 +71,12 @@
utf8->string utf16->string utf32->string))
-(load-extension "libguile" "scm_init_bytevectors")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_bytevectors")
(define-macro (endianness sym)
(if (memq sym '(big little))
`(quote ,sym)
(error "unsupported endianness" sym)))
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
-
;;; bytevector.scm ends here
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index d1b96b3..17d4907 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -1,6 +1,6 @@
-;;;; ports.scm --- R6RS port API
+;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*-
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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
@@ -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
-;;; Author: Ludovic Courtès <address@hidden>
+;;; Author: Ludovic Courtès <address@hidden>
;;; Commentary:
;;;
@@ -52,7 +52,8 @@
;; binary output
put-u8 put-bytevector))
-(load-extension "libguile" "scm_init_r6rs_ports")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_r6rs_ports")
@@ -104,8 +105,4 @@ read from/written to in @var{port}."
(lambda ()
(close-port port))))
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
-
;;; ports.scm ends here
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 9b14f2f..3e451a6 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -1,6 +1,6 @@
-;;; Compile --- Command-line Guile Scheme compiler
+;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
-;; Copyright 2005,2008,2009 Free Software Foundation, Inc.
+;; Copyright 2005,2008,2009,2010 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
@@ -177,7 +177,3 @@ Report bugs to <~A>.~%"
input-files)))
(define main compile)
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
diff --git a/module/scripts/snarf-check-and-output-texi.scm
b/module/scripts/snarf-check-and-output-texi.scm
index 0e7efae..f92c833 100644
--- a/module/scripts/snarf-check-and-output-texi.scm
+++ b/module/scripts/snarf-check-and-output-texi.scm
@@ -262,6 +262,17 @@
(set! *file* file)
(set! *line* line))
+ ;; newer gccs like to throw around more location markers into the
+ ;; preprocessed source; these (hash . hash) bits are what they translate
to
+ ;; in snarfy terms.
+ (('location ('string . file) ('int . line) ('hash . 'hash))
+ (set! *file* file)
+ (set! *line* line))
+
+ (('location ('hash . 'hash) ('string . file) ('int . line) ('hash .
'hash))
+ (set! *file* file)
+ (set! *line* line))
+
(('arglist rest ...)
(set! *args* (do-arglist rest)))
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 4a171b4..4921a95 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -1,6 +1,6 @@
;;; srfi-18.scm --- Multithreading support
-;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010 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
@@ -105,7 +105,6 @@
(define terminated-thread-exception (list 'terminated-thread-exception))
(define uncaught-exception (list 'uncaught-exception))
-(define mutex-owners (make-weak-key-hash-table))
(define object-names (make-weak-key-hash-table))
(define object-specifics (make-weak-key-hash-table))
(define thread-start-conds (make-weak-key-hash-table))
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index 8a86b35..e73e4d6 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -1,6 +1,6 @@
;;; srfi-19.scm --- Time/Date Library
-;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010 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
@@ -43,15 +43,8 @@
:use-module (srfi srfi-8)
:use-module (srfi srfi-9)
:autoload (ice-9 rdelim) (read-line)
- :use-module (ice-9 i18n))
-
-(begin-deprecated
- ;; Prevent `export' from re-exporting core bindings. This behaviour
- ;; of `export' is deprecated and will disappear in one of the next
- ;; releases.
- (define current-time #f))
-
-(export ;; Constants
+ :use-module (ice-9 i18n)
+ :export (;; Constants
time-duration
time-monotonic
time-process
@@ -116,6 +109,8 @@
modified-julian-day->time-tai
modified-julian-day->time-utc
time-monotonic->date
+ time-monotonic->julian-day
+ time-monotonic->modified-julian-day
time-monotonic->time-tai
time-monotonic->time-tai!
time-monotonic->time-utc
@@ -136,7 +131,7 @@
time-utc->time-tai!
;; Date to string/string to date converters.
date->string
- string->date)
+ string->date))
(cond-expand-provide (current-module) '(srfi-19))
@@ -738,9 +733,6 @@
(or (= (modulo year 400) 0)
(and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
-(define (leap-year? date)
- (priv:leap-year? (date-year date)))
-
;; Map 1-based month number M to number of days in the year before the
;; start of month M (in a non-leap year).
(define priv:month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 5d6557d..7f1ff7f 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -1,6 +1,6 @@
-;;; srfi-35.scm --- Conditions
+;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
-;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2009, 2010 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
@@ -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
-;;; Author: Ludovic Courtès <address@hidden>
+;;; Author: Ludovic Courtès <address@hidden>
;;; Commentary:
@@ -352,9 +352,4 @@ by C."
(define-condition-type &error &serious
error?)
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
-
;;; srfi-35.scm ends here
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index b133f21..8438ba3 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -1,6 +1,6 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
-;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 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
@@ -26,46 +26,111 @@
;;; Code:
-(define-module (srfi srfi-4))
+(define-module (srfi srfi-4)
+ #:use-module (rnrs bytevector)
+ #:export (;; Unsigned 8-bit vectors.
+ u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+ u8vector-set! u8vector->list list->u8vector
+
+ ;; Signed 8-bit vectors.
+ s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+ s8vector-set! s8vector->list list->s8vector
+
+ ;; Unsigned 16-bit vectors.
+ u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+ u16vector-set! u16vector->list list->u16vector
+
+ ;; Signed 16-bit vectors.
+ s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+ s16vector-set! s16vector->list list->s16vector
+
+ ;; Unsigned 32-bit vectors.
+ u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+ u32vector-set! u32vector->list list->u32vector
+
+ ;; Signed 32-bit vectors.
+ s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+ s32vector-set! s32vector->list list->s32vector
+
+ ;; Unsigned 64-bit vectors.
+ u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+ u64vector-set! u64vector->list list->u64vector
+
+ ;; Signed 64-bit vectors.
+ s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+ s64vector-set! s64vector->list list->s64vector
+
+ ;; 32-bit floating point vectors.
+ f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+ f32vector-set! f32vector->list list->f32vector
+
+ ;; 64-bit floating point vectors.
+ f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+ f64vector-set! f64vector->list list->f64vector))
+
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+ `(begin
+ (define (,(symbol-append tag 'vector?) obj)
+ (and (uniform-vector? obj)
+ (eq? (uniform-vector-element-type obj) ',tag)))
+ (define (,(symbol-append 'make- tag 'vector) len . fill)
+ (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)))))
+ (if (integer? len)
+ len
+ (error "fractional length" v ',tag ,size))))
+ (define (,(symbol-append tag 'vector) . elts)
+ (,(symbol-append 'list-> tag 'vector) elts))
+ (define (,(symbol-append 'list-> tag 'vector) elts)
+ (let* ((len (length elts))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0) (elts elts))
+ (if (and (< i len) (pair? elts))
+ (begin
+ (,(symbol-append tag 'vector-set!) v i (car elts))
+ (lp (1+ i) (cdr elts)))
+ v))))
+ (define (,(symbol-append tag 'vector->list) v)
+ (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+ (if (< i 0)
+ elts
+ (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+ (define (,(symbol-append tag 'vector-ref) v i)
+ (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define-bytevector-type u8 u8 1)
+(define-bytevector-type s8 s8 1)
+(define-bytevector-type u16 u16-native 2)
+(define-bytevector-type s16 s16-native 2)
+(define-bytevector-type u32 u32-native 4)
+(define-bytevector-type s32 s32-native 4)
+(define-bytevector-type u64 u64-native 8)
+(define-bytevector-type s64 s64-native 8)
+(define-bytevector-type f32 ieee-single-native 4)
+(define-bytevector-type f64 ieee-double-native 8)
+
+(define (bytevector-c32-ref v i)
+ (make-rectangular (bytevector-ieee-single-native-ref v i)
+ (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-set! v i x)
+ (bytevector-ieee-single-native-set! v i x)
+ (bytevector-ieee-single-native-set! v (+ i 4) x))
+(define-bytevector-type c32 c32 8)
+
+(define (bytevector-c64-ref v i)
+ (make-rectangular (bytevector-ieee-double-native-ref v i)
+ (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-set! v i x)
+ (bytevector-ieee-double-native-set! v i x)
+ (bytevector-ieee-double-native-set! v (+ i 8) x))
+(define-bytevector-type c64 c64 16)
-(re-export
-;;; Unsigned 8-bit vectors.
- u8vector? make-u8vector u8vector u8vector-length u8vector-ref
- u8vector-set! u8vector->list list->u8vector
-;;; Signed 8-bit vectors.
- s8vector? make-s8vector s8vector s8vector-length s8vector-ref
- s8vector-set! s8vector->list list->s8vector
-
-;;; Unsigned 16-bit vectors.
- u16vector? make-u16vector u16vector u16vector-length u16vector-ref
- u16vector-set! u16vector->list list->u16vector
-
-;;; Signed 16-bit vectors.
- s16vector? make-s16vector s16vector s16vector-length s16vector-ref
- s16vector-set! s16vector->list list->s16vector
-
-;;; Unsigned 32-bit vectors.
- u32vector? make-u32vector u32vector u32vector-length u32vector-ref
- u32vector-set! u32vector->list list->u32vector
-
-;;; Signed 32-bit vectors.
- s32vector? make-s32vector s32vector s32vector-length s32vector-ref
- s32vector-set! s32vector->list list->s32vector
-
-;;; Unsigned 64-bit vectors.
- u64vector? make-u64vector u64vector u64vector-length u64vector-ref
- u64vector-set! u64vector->list list->u64vector
-
-;;; Signed 64-bit vectors.
- s64vector? make-s64vector s64vector s64vector-length s64vector-ref
- s64vector-set! s64vector->list list->s64vector
-
-;;; 32-bit floating point vectors.
- f32vector? make-f32vector f32vector f32vector-length f32vector-ref
- f32vector-set! f32vector->list list->f32vector
-
-;;; 64-bit floating point vectors.
- f64vector? make-f64vector f64vector f64vector-length f64vector-ref
- f64vector-set! f64vector->list list->f64vector
- )
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index c5c41ea..ccb1ab1 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -23,13 +23,77 @@
;;; Code:
(define-module (srfi srfi-4 gnu)
+ #:use-module (rnrs bytevector)
#:use-module (srfi srfi-4)
- #:export (;; Somewhat polymorphic conversions.
+ #:export (;; Complex numbers with 32- and 64-bit components.
+ c32vector? make-c32vector c32vector c32vector-length c32vector-ref
+ c32vector-set! c32vector->list list->c32vector
+
+ c64vector? make-c64vector c64vector c64vector-length c64vector-ref
+ c64vector-set! c64vector->list list->c64vector
+
+ make-srfi-4-vector
+
+ ;; Somewhat polymorphic conversions.
any->u8vector any->s8vector any->u16vector any->s16vector
any->u32vector any->s32vector any->u64vector any->s64vector
any->f32vector any->f64vector any->c32vector any->c64vector))
+(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector))
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+ `(begin
+ (define (,(symbol-append tag 'vector?) obj)
+ (and (uniform-vector? obj)
+ (eq? (uniform-vector-element-type obj) ',tag)))
+ (define (,(symbol-append 'make- tag 'vector) len . fill)
+ (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)))))
+ (if (integer? len)
+ len
+ (error "fractional length" v ',tag ,size))))
+ (define (,(symbol-append tag 'vector) . elts)
+ (,(symbol-append 'list-> tag 'vector) elts))
+ (define (,(symbol-append 'list-> tag 'vector) elts)
+ (let* ((len (length elts))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0) (elts elts))
+ (if (and (< i len) (pair? elts))
+ (begin
+ (,(symbol-append tag 'vector-set!) v i (car elts))
+ (lp (1+ i) (cdr elts)))
+ v))))
+ (define (,(symbol-append tag 'vector->list) v)
+ (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+ (if (< i 0)
+ elts
+ (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+ (define (,(symbol-append tag 'vector-ref) v i)
+ (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define (bytevector-c32-native-ref v i)
+ (make-rectangular (bytevector-ieee-single-native-ref v i)
+ (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-native-set! v i x)
+ (bytevector-ieee-single-native-set! v i x)
+ (bytevector-ieee-single-native-set! v (+ i 4) x))
+(define (bytevector-c64-native-ref v i)
+ (make-rectangular (bytevector-ieee-double-native-ref v i)
+ (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-native-set! v i x)
+ (bytevector-ieee-double-native-set! v i x)
+ (bytevector-ieee-double-native-set! v (+ i 8) x))
+(define-bytevector-type c32 c32-native 8)
+(define-bytevector-type c64 c64-native 16)
+
(define-macro (define-any->vector . tags)
`(begin
,@(map (lambda (tag)
diff --git a/module/srfi/srfi-88.scm b/module/srfi/srfi-88.scm
index 9538f5c..b9056a4 100644
--- a/module/srfi/srfi-88.scm
+++ b/module/srfi/srfi-88.scm
@@ -1,6 +1,6 @@
-;;; srfi-88.scm --- Keyword Objects
+;;; srfi-88.scm --- Keyword Objects -*- coding: utf-8 -*-
-;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010 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
@@ -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
-;;; Author: Ludovic Courtès <address@hidden>
+;;; Author: Ludovic Courtès <address@hidden>
;;; Commentary:
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index bd7dae8..39f4e34 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 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010 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
@@ -88,6 +88,7 @@
((_ formals ...)
#'(begin body ...))
(_
+ (identifier? x)
#'proc-name))))))))))
(define-syntax define-record-type
@@ -118,7 +119,7 @@
(ctor-args (map (lambda (field)
(cons (syntax->datum field) field))
#'(field ...))))
- #`(define #,constructor-spec
+ #`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
#,@(unfold
(lambda (field-num)
diff --git a/module/statprof.scm b/module/statprof.scm
new file mode 100644
index 0000000..2a6cf12
--- /dev/null
+++ b/module/statprof.scm
@@ -0,0 +1,704 @@
+;;;; (statprof) -- a statistical profiler for Guile
+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+
+;;; Commentary:
+;;
+;;@code{(statprof)} is intended to be a fairly simple
+;;statistical profiler for guile. It is in the early stages yet, so
+;;consider its output still suspect, and please report any bugs to
+;;@email{guile-devel at gnu.org}, or to me directly at @email{rlb at
+;;defaultvalue.org}.
+;;
+;;A simple use of statprof would look like this:
+;;
+;;@example
+;; (statprof-reset 0 50000 #t)
+;; (statprof-start)
+;; (do-something)
+;; (statprof-stop)
+;; (statprof-display)
+;;@end example
+;;
+;;This would reset statprof, clearing all accumulated statistics, then
+;;start profiling, run some code, stop profiling, and finally display a
+;;gprof flat-style table of statistics which will look something like
+;;this:
+;;
+;;@example
+;; % cumulative self self total
+;; time seconds seconds calls ms/call ms/call name
+;; 35.29 0.23 0.23 2002 0.11 0.11 -
+;; 23.53 0.15 0.15 2001 0.08 0.08 positive?
+;; 23.53 0.15 0.15 2000 0.08 0.08 +
+;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing
+;; 5.88 0.64 0.04 2001 0.02 0.32 loop
+;; 0.00 0.15 0.00 1 0.00 150.59 do-something
+;; ...
+;;@end example
+;;
+;;All of the numerical data with the exception of the calls column is
+;;statistically approximate. In the following column descriptions, and
+;;in all of statprof, "time" refers to execution time (both user and
+;;system), not wall clock time.
+;;
+;;@table @asis
+;;@item % time
+;;The percent of the time spent inside the procedure itself
+;;(not counting children).
+;;@item cumulative seconds
+;;The total number of seconds spent in the procedure, including
+;;children.
+;;@item self seconds
+;;The total number of seconds spent in the procedure itself (not counting
+;;children).
+;;@item calls
+;;The total number of times the procedure was called.
+;;@item self ms/call
+;;The average time taken by the procedure itself on each call, in ms.
+;;@item total ms/call
+;;The average time taken by each call to the procedure, including time
+;;spent in child functions.
+;;@item name
+;;The name of the procedure.
+;;@end table
+;;
+;;The profiler uses @code{eq?} and the procedure object itself to
+;;identify the procedures, so it won't confuse different procedures with
+;;the same name. They will show up as two different rows in the output.
+;;
+;;Right now the profiler is quite simplistic. I cannot provide
+;;call-graphs or other higher level information. What you see in the
+;;table is pretty much all there is. Patches are welcome :-)
+;;
+;;@section Implementation notes
+;;
+;;The profiler works by setting the unix profiling signal
+;;@code{ITIMER_PROF} to go off after the interval you define in the call
+;;to @code{statprof-reset}. When the signal fires, a sampling routine is
+;;run which looks at the current procedure that's executing, and then
+;;crawls up the stack, and for each procedure encountered, increments
+;;that procedure's sample count. Note that if a procedure is encountered
+;;multiple times on a given stack, it is only counted once. After the
+;;sampling is complete, the profiler resets profiling timer to fire
+;;again after the appropriate interval.
+;;
+;;Meanwhile, the profiler keeps track, via @code{get-internal-run-time},
+;;how much CPU time (system and user -- which is also what
+;;@code{ITIMER_PROF} tracks), has elapsed while code has been executing
+;;within a statprof-start/stop block.
+;;
+;;The profiler also tries to avoid counting or timing its own code as
+;;much as possible.
+;;
+;;; Code:
+
+;; When you add new features, please also add tests to ./tests/ if you
+;; have time, and then add the new files to ./run-tests. Also, if
+;; anyone's bored, there are a lot of existing API bits that don't
+;; have tests yet.
+
+;; TODO
+;;
+;; Check about profiling C functions -- does profiling primitives work?
+;; Also look into stealing code from qprof so we can sample the C stack
+;; Call graphs?
+
+(define-module (statprof)
+ #:use-module (srfi srfi-1)
+ #:autoload (ice-9 format) (format)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:export (statprof-active?
+ statprof-start
+ statprof-stop
+ statprof-reset
+
+ statprof-accumulated-time
+ statprof-sample-count
+ statprof-fold-call-data
+ statprof-proc-call-data
+ statprof-call-data-name
+ statprof-call-data-calls
+ statprof-call-data-cum-samples
+ statprof-call-data-self-samples
+ statprof-call-data->stats
+
+ statprof-stats-proc-name
+ statprof-stats-%-time-in-proc
+ statprof-stats-cum-secs-in-proc
+ statprof-stats-self-secs-in-proc
+ statprof-stats-calls
+ statprof-stats-self-secs-per-call
+ statprof-stats-cum-secs-per-call
+
+ statprof-display
+ statprof-display-anomolies
+
+ statprof-fetch-stacks
+ statprof-fetch-call-tree
+
+ statprof
+ with-statprof))
+
+
+;; This profiler tracks two numbers for every function called while
+;; it's active. It tracks the total number of calls, and the number
+;; of times the function was active when the sampler fired.
+;;
+;; Globally the profiler tracks the total time elapsed and the number
+;; of times the sampler was fired.
+;;
+;; Right now, this profiler is not per-thread and is not thread safe.
+
+(define accumulated-time #f) ; total so far.
+(define last-start-time #f) ; start-time when timer is active.
+(define sample-count #f) ; total count of sampler calls.
+(define sampling-frequency #f) ; in (seconds . microseconds)
+(define remaining-prof-time #f) ; time remaining when prof suspended.
+(define profile-level 0) ; for user start/stop nesting.
+(define %count-calls? #t) ; whether to catch apply-frame.
+(define gc-time-taken 0) ; gc time between statprof-start and
+ ; statprof-stop.
+(define record-full-stacks? #f) ; if #t, stash away the stacks
+ ; for later analysis.
+(define stacks '())
+
+;; procedure-data will be a hash where the key is the function object
+;; itself and the value is the data. The data will be a vector like
+;; this: #(name call-count cum-sample-count self-sample-count)
+(define procedure-data #f)
+
+;; If you change the call-data data structure, you need to also change
+;; sample-uncount-frame.
+(define (make-call-data proc call-count cum-sample-count self-sample-count)
+ (vector proc call-count cum-sample-count self-sample-count))
+(define (call-data-proc cd) (vector-ref cd 0))
+(define (call-data-name cd) (procedure-name (call-data-proc cd)))
+(define (call-data-printable cd)
+ (or (call-data-name cd)
+ (with-output-to-string (lambda () (write (call-data-proc cd))))))
+(define (call-data-call-count cd) (vector-ref cd 1))
+(define (call-data-cum-sample-count cd) (vector-ref cd 2))
+(define (call-data-self-sample-count cd) (vector-ref cd 3))
+
+(define (inc-call-data-call-count! cd)
+ (vector-set! cd 1 (1+ (vector-ref cd 1))))
+(define (inc-call-data-cum-sample-count! cd)
+ (vector-set! cd 2 (1+ (vector-ref cd 2))))
+(define (inc-call-data-self-sample-count! cd)
+ (vector-set! cd 3 (1+ (vector-ref cd 3))))
+
+(define-macro (accumulate-time stop-time)
+ `(set! accumulated-time
+ (+ accumulated-time 0.0 (- ,stop-time last-start-time))))
+
+(define (get-call-data proc)
+ (let ((k (if (or (not (program? proc))
+ (zero? (program-num-free-variables proc)))
+ proc
+ (program-objcode proc))))
+ (or (hashq-ref procedure-data k)
+ (let ((call-data (make-call-data proc 0 0 0)))
+ (hashq-set! procedure-data k call-data)
+ call-data))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SIGPROF handler
+
+(define (sample-stack-procs stack)
+ (let ((stacklen (stack-length stack))
+ (hit-count-call? #f))
+
+ (if record-full-stacks?
+ (set! stacks (cons stack stacks)))
+
+ (set! sample-count (+ sample-count 1))
+ ;; Now accumulate stats for the whole stack.
+ (let loop ((frame (stack-ref stack 0))
+ (procs-seen (make-hash-table 13))
+ (self #f))
+ (cond
+ ((not frame)
+ (hash-fold
+ (lambda (proc val accum)
+ (inc-call-data-cum-sample-count!
+ (get-call-data proc)))
+ #f
+ procs-seen)
+ (and=> (and=> self get-call-data)
+ inc-call-data-self-sample-count!))
+ ((frame-procedure frame)
+ => (lambda (proc)
+ (cond
+ ((eq? proc count-call)
+ ;; We're not supposed to be sampling count-call and
+ ;; its sub-functions, so loop again with a clean
+ ;; slate.
+ (set! hit-count-call? #t)
+ (loop (frame-previous frame) (make-hash-table 13) #f))
+ (else
+ (hashq-set! procs-seen proc #t)
+ (loop (frame-previous frame)
+ procs-seen
+ (or self proc))))))
+ (else
+ (loop (frame-previous frame) procs-seen self))))
+ hit-count-call?))
+
+(define inside-profiler? #f)
+
+(define (profile-signal-handler sig)
+ (set! inside-profiler? #t)
+
+ ;; FIXME: with-statprof should be able to set an outer frame for the
+ ;; stack cut
+ (if (positive? profile-level)
+ (let* ((stop-time (get-internal-run-time))
+ ;; cut down to the signal handler. note that this will only
+ ;; work if statprof.scm is compiled; otherwise we get
+ ;; `eval' on the stack instead, because if it's not
+ ;; compiled, profile-signal-handler is a thunk that
+ ;; tail-calls eval. perhaps we should always compile the
+ ;; signal handler instead...
+ (stack (or (make-stack #t profile-signal-handler)
+ (pk 'what! (make-stack #t))))
+ (inside-apply-trap? (sample-stack-procs stack)))
+
+ (if (not inside-apply-trap?)
+ (begin
+ ;; disabling here is just a little more efficient, but
+ ;; not necessary given inside-profiler?. We can't just
+ ;; disable unconditionally at the top of this function
+ ;; and eliminate inside-profiler? because it seems to
+ ;; confuse guile wrt re-enabling the trap when
+ ;; count-call finishes.
+ (if %count-calls?
+ (set-vm-trace-level! (the-vm)
+ (1- (vm-trace-level (the-vm)))))
+ (accumulate-time stop-time)))
+
+ (setitimer ITIMER_PROF
+ 0 0
+ (car sampling-frequency)
+ (cdr sampling-frequency))
+
+ (if (not inside-apply-trap?)
+ (begin
+ (set! last-start-time (get-internal-run-time))
+ (if %count-calls?
+ (set-vm-trace-level! (the-vm)
+ (1+ (vm-trace-level (the-vm)))))))))
+
+ (set! inside-profiler? #f))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Count total calls.
+
+(define (count-call frame)
+ (if (not inside-profiler?)
+ (begin
+ (accumulate-time (get-internal-run-time))
+
+ (and=> (frame-procedure frame)
+ (lambda (proc)
+ (inc-call-data-call-count!
+ (get-call-data proc))))
+
+ (set! last-start-time (get-internal-run-time)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (statprof-active?)
+ "Returns @code{#t} if @code{statprof-start} has been called more times
+than @code{statprof-stop}, @code{#f} otherwise."
+ (positive? profile-level))
+
+;; Do not call this from statprof internal functions -- user only.
+(define (statprof-start)
+ "Start the address@hidden"
+ ;; After some head-scratching, I don't *think* I need to mask/unmask
+ ;; signals here, but if I'm wrong, please let me know.
+ (set! profile-level (+ profile-level 1))
+ (if (= profile-level 1)
+ (let* ((rpt remaining-prof-time)
+ (use-rpt? (and rpt
+ (or (positive? (car rpt))
+ (positive? (cdr rpt))))))
+ (set! remaining-prof-time #f)
+ (set! last-start-time (get-internal-run-time))
+ (set! gc-time-taken
+ (cdr (assq 'gc-time-taken (gc-stats))))
+ (if use-rpt?
+ (setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt))
+ (setitimer ITIMER_PROF
+ 0 0
+ (car sampling-frequency)
+ (cdr sampling-frequency)))
+ (if %count-calls?
+ (add-hook! (vm-apply-hook (the-vm)) count-call))
+ (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+ #t)))
+
+;; Do not call this from statprof internal functions -- user only.
+(define (statprof-stop)
+ "Stop the address@hidden"
+ ;; After some head-scratching, I don't *think* I need to mask/unmask
+ ;; signals here, but if I'm wrong, please let me know.
+ (set! profile-level (- profile-level 1))
+ (if (zero? profile-level)
+ (begin
+ (set! gc-time-taken
+ (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
+ (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
+ (if %count-calls?
+ (remove-hook! (vm-apply-hook (the-vm)) count-call))
+ ;; I believe that we need to do this before getting the time
+ ;; (unless we want to make things even more complicated).
+ (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
+ (accumulate-time (get-internal-run-time))
+ (set! last-start-time #f))))
+
+(define (statprof-reset sample-seconds sample-microseconds count-calls?
+ . full-stacks?)
+ "Reset the statprof sampler interval to @var{sample-seconds} and
address@hidden If @var{count-calls?} is true, arrange to
+instrument procedure calls as well as collecting statistical profiling
+data. If @var{full-stacks?} is true, collect all sampled stacks into a
+list for later analysis.
+
+Enables traps and debugging as necessary."
+ (if (positive? profile-level)
+ (error "Can't reset profiler while profiler is running."))
+ (set! %count-calls? count-calls?)
+ (set! accumulated-time 0)
+ (set! last-start-time #f)
+ (set! sample-count 0)
+ (set! sampling-frequency (cons sample-seconds sample-microseconds))
+ (set! remaining-prof-time #f)
+ (set! procedure-data (make-hash-table 131))
+ (set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
+ (set! stacks '())
+ (debug-enable 'debug)
+ (sigaction SIGPROF profile-signal-handler)
+ #t)
+
+(define (statprof-fold-call-data proc init)
+ "Fold @var{proc} over the call-data accumulated by statprof. Cannot be
+called while statprof is active. @var{proc} should take two arguments,
address@hidden(@var{call-data} @var{prior-result})}.
+
+Note that a given proc-name may appear multiple times, but if it does,
+it represents different functions with the same name."
+ (if (positive? profile-level)
+ (error "Can't call statprof-fold-called while profiler is running."))
+
+ (hash-fold
+ (lambda (key value prior-result)
+ (proc value prior-result))
+ init
+ procedure-data))
+
+(define (statprof-proc-call-data proc)
+ "Returns the call-data associated with @var{proc}, or @code{#f} if
+none is available."
+ (if (positive? profile-level)
+ (error "Can't call statprof-fold-called while profiler is running."))
+
+ (hashq-ref procedure-data proc))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Stats
+
+(define (statprof-call-data->stats call-data)
+ "Returns an object of type @code{statprof-stats}."
+ ;; returns (vector proc-name
+ ;; %-time-in-proc
+ ;; cum-seconds-in-proc
+ ;; self-seconds-in-proc
+ ;; num-calls
+ ;; self-secs-per-call
+ ;; total-secs-per-call)
+
+ (let* ((proc-name (call-data-printable call-data))
+ (self-samples (call-data-self-sample-count call-data))
+ (cum-samples (call-data-cum-sample-count call-data))
+ (all-samples (statprof-sample-count))
+ (secs-per-sample (/ (statprof-accumulated-time)
+ (statprof-sample-count)))
+ (num-calls (and %count-calls? (statprof-call-data-calls call-data))))
+
+ (vector proc-name
+ (* (/ self-samples all-samples) 100.0)
+ (* cum-samples secs-per-sample 1.0)
+ (* self-samples secs-per-sample 1.0)
+ num-calls
+ (and num-calls ;; maybe we only sampled in children
+ (if (zero? self-samples) 0.0
+ (/ (* self-samples secs-per-sample) 1.0 num-calls)))
+ (and num-calls ;; cum-samples must be positive
+ (/ (* cum-samples secs-per-sample)
+ 1.0
+ ;; num-calls might be 0 if we entered statprof during the
+ ;; dynamic extent of the call
+ (max num-calls 1))))))
+
+(define (statprof-stats-proc-name stats) (vector-ref stats 0))
+(define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
+(define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2))
+(define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3))
+(define (statprof-stats-calls stats) (vector-ref stats 4))
+(define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5))
+(define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stats-sorter x y)
+ (let ((diff (- (statprof-stats-self-secs-in-proc x)
+ (statprof-stats-self-secs-in-proc y))))
+ (positive?
+ (if (= diff 0)
+ (- (statprof-stats-cum-secs-in-proc x)
+ (statprof-stats-cum-secs-in-proc y))
+ diff))))
+
+(define (statprof-display . port)
+ "Displays a gprof-like summary of the statistics collected. Unless an
+optional @var{port} argument is passed, uses the current output port."
+ (if (null? port) (set! port (current-output-port)))
+
+ (cond
+ ((zero? (statprof-sample-count))
+ (format port "No samples recorded.\n"))
+ (else
+ (let* ((stats-list (statprof-fold-call-data
+ (lambda (data prior-value)
+ (cons (statprof-call-data->stats data)
+ prior-value))
+ '()))
+ (sorted-stats (sort stats-list stats-sorter)))
+
+ (define (display-stats-line stats)
+ (if %count-calls?
+ (format port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f "
+ (statprof-stats-%-time-in-proc stats)
+ (statprof-stats-cum-secs-in-proc stats)
+ (statprof-stats-self-secs-in-proc stats)
+ (statprof-stats-calls stats)
+ (* 1000 (statprof-stats-self-secs-per-call stats))
+ (* 1000 (statprof-stats-cum-secs-per-call stats)))
+ (format port "~6,2f ~9,2f ~9,2f "
+ (statprof-stats-%-time-in-proc stats)
+ (statprof-stats-cum-secs-in-proc stats)
+ (statprof-stats-self-secs-in-proc stats)))
+ (display (statprof-stats-proc-name stats) port)
+ (newline port))
+
+ (if %count-calls?
+ (begin
+ (format port "~5a ~10a ~7a ~8a ~8a ~8a address@hidden"
+ "% " "cumulative" "self" "" "self" "total" "")
+ (format port "~5a ~9a ~8a ~8a ~8a ~8a address@hidden"
+ "time" "seconds" "seconds" "calls" "ms/call" "ms/call"
"name"))
+ (begin
+ (format port "~5a ~10a ~7a address@hidden"
+ "%" "cumulative" "self" "")
+ (format port "~5a ~10a ~7a address@hidden"
+ "time" "seconds" "seconds" "name")))
+
+ (for-each display-stats-line sorted-stats)
+
+ (display "---\n" port)
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count))
+ (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
+ (statprof-accumulated-time)
+ (/ gc-time-taken internal-time-units-per-second))))))
+
+(define (statprof-display-anomolies)
+ "A sanity check that attempts to detect anomolies in statprof's
address@hidden"
+ (statprof-fold-call-data
+ (lambda (data prior-value)
+ (if (and %count-calls?
+ (zero? (call-data-call-count data))
+ (positive? (call-data-cum-sample-count data)))
+ (simple-format #t
+ "==[~A ~A ~A]\n"
+ (call-data-name data)
+ (call-data-call-count data)
+ (call-data-cum-sample-count data))))
+ #f)
+ (simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
+
+(define (statprof-accumulated-time)
+ "Returns the time accumulated during the last statprof address@hidden"
+ (if (positive? profile-level)
+ (error "Can't get accumulated time while profiler is running."))
+ (/ accumulated-time internal-time-units-per-second))
+
+(define (statprof-sample-count)
+ "Returns the number of samples taken during the last statprof address@hidden"
+ (if (positive? profile-level)
+ (error "Can't get accumulated time while profiler is running."))
+ sample-count)
+
+(define statprof-call-data-name call-data-name)
+(define statprof-call-data-calls call-data-call-count)
+(define statprof-call-data-cum-samples call-data-cum-sample-count)
+(define statprof-call-data-self-samples call-data-self-sample-count)
+
+(define (statprof-fetch-stacks)
+ "Returns a list of stacks, as they were captured since the last call
+to @code{statprof-reset}.
+
+Note that stacks are only collected if the @var{full-stacks?} argument
+to @code{statprof-reset} is true."
+ stacks)
+
+(define procedure=?
+ (lambda (a b)
+ (cond
+ ((eq? a b))
+ ((and (program? a) (program? b))
+ (eq? (program-objcode a) (program-objcode b)))
+ (else
+ #f))))
+
+;; tree ::= (car n . tree*)
+
+(define (lists->trees lists equal?)
+ (let lp ((in lists) (n-terminal 0) (tails '()))
+ (cond
+ ((null? in)
+ (let ((trees (map (lambda (tail)
+ (cons (car tail)
+ (lists->trees (cdr tail) equal?)))
+ tails)))
+ (cons (apply + n-terminal (map cadr trees))
+ (sort trees
+ (lambda (a b) (> (cadr a) (cadr b)))))))
+ ((null? (car in))
+ (lp (cdr in) (1+ n-terminal) tails))
+ ((find (lambda (x) (equal? (car x) (caar in)))
+ tails)
+ => (lambda (tail)
+ (lp (cdr in)
+ n-terminal
+ (assq-set! tails
+ (car tail)
+ (cons (cdar in) (cdr tail))))))
+ (else
+ (lp (cdr in)
+ n-terminal
+ (acons (caar in) (list (cdar in)) tails))))))
+
+(define (stack->procedures stack)
+ (filter identity
+ (unfold-right (lambda (x) (not x))
+ frame-procedure
+ frame-previous
+ (stack-ref stack 0))))
+
+(define (statprof-fetch-call-tree)
+ "Return a call tree for the previous statprof run.
+
+The return value is a list of nodes, each of which is of the type:
address@hidden
+ node ::= (@var{proc} @var{count} . @var{nodes})
address@hidden code"
+ (cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
+
+(define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
+ (full-stacks? #f))
+ "Profiles the execution of @var{thunk}.
+
+The stack will be sampled @var{hz} times per second, and the thunk itself will
+be called @var{loop} times.
+
+If @var{count-calls?} is true, all procedure calls will be recorded. This
+operation is somewhat expensive.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
address@hidden to retrieve the last-stored stacks."
+
+ (dynamic-wind
+ (lambda ()
+ (statprof-reset (inexact->exact (floor (/ 1 hz)))
+ (inexact->exact (* 1e6 (- (/ 1 hz)
+ (floor (/ 1 hz)))))
+ count-calls?
+ full-stacks?)
+ (statprof-start))
+ (lambda ()
+ (let lp ((i loop))
+ (if (not (zero? i))
+ (begin
+ (thunk)
+ (lp (1- i))))))
+ (lambda ()
+ (statprof-stop)
+ (statprof-display)
+ (set! procedure-data #f))))
+
+(define-macro (with-statprof . args)
+ "Profiles the expressions in its body.
+
+Keyword arguments:
+
address@hidden @code
address@hidden #:loop
+Execute the body @var{loop} number of times, or @code{#f} for no looping
+
+default: @code{#f}
address@hidden #:hz
+Sampling rate
+
+default: @code{20}
address@hidden #:count-calls?
+Whether to instrument each function call (expensive)
+
+default: @code{#f}
address@hidden #:full-stacks?
+Whether to collect away all sampled stacks into a list
+
+default: @code{#f}
address@hidden table"
+ (define (kw-arg-ref kw args def)
+ (cond
+ ((null? args) (error "Invalid macro body"))
+ ((keyword? (car args))
+ (if (eq? (car args) kw)
+ (cadr args)
+ (kw-arg-ref kw (cddr args) def)))
+ ((eq? kw #f def) ;; asking for the body
+ args)
+ (else def))) ;; kw not found
+ `((@ (statprof) statprof)
+ (lambda () ,@(kw-arg-ref #f args #f))
+ #:loop ,(kw-arg-ref #:loop args 1)
+ #:hz ,(kw-arg-ref #:hz args 100)
+ #:count-calls? ,(kw-arg-ref #:count-calls? args #f)
+ #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
+
diff --git a/module/sxml/apply-templates.scm b/module/sxml/apply-templates.scm
new file mode 100644
index 0000000..0ee2747
--- /dev/null
+++ b/module/sxml/apply-templates.scm
@@ -0,0 +1,102 @@
+;;;; (sxml apply-templates) -- xslt-like transformation for sxml
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as
apply-templates.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;; Pre-order traversal of a tree and creation of a new tree:
+;;
+;;@smallexample
+;; apply-templates:: tree x <templates> -> <new-tree>
+;;@end smallexample
+;; where
+;;@smallexample
+;; <templates> ::= (<template> ...)
+;; <template> ::= (<node-test> <node-test> ... <node-test> . <handler>)
+;; <node-test> ::= an argument to node-typeof? above
+;; <handler> ::= <tree> -> <new-tree>
+;;@end smallexample
+;;
+;; This procedure does a @emph{normal}, pre-order traversal of an SXML
+;; tree. It walks the tree, checking at each node against the list of
+;; matching templates.
+;;
+;; If the match is found (which must be unique, i.e., unambiguous), the
+;; corresponding handler is invoked and given the current node as an
+;; argument. The result from the handler, which must be a @code{<tree>},
+;; takes place of the current node in the resulting tree.
+;;
+;; The name of the function is not accidental: it resembles rather
+;; closely an @code{apply-templates} function of XSLT.
+;;
+;;; Code:
+
+(define-module (sxml apply-templates)
+ #:use-module (sxml ssax)
+ #:use-module ((sxml xpath) :hide (filter))
+
+ #:export (apply-templates))
+
+(define (apply-templates tree templates)
+
+ ; Filter the list of templates. If a template does not
+ ; contradict the given node (that is, its head matches
+ ; the type of the node), chop off the head and keep the
+ ; rest as the result. All contradicting templates are removed.
+ (define (filter-templates node templates)
+ (cond
+ ((null? templates) templates)
+ ((not (pair? (car templates))) ; A good template must be a list
+ (filter-templates node (cdr templates)))
+ (((node-typeof? (caar templates)) node)
+ (cons (cdar templates) (filter-templates node (cdr templates))))
+ (else
+ (filter-templates node (cdr templates)))))
+
+ ; Here <templates> ::= [<template> | <handler>]
+ ; If there is a <handler> in the above list, it must
+ ; be only one. If found, return it; otherwise, return #f
+ (define (find-handler templates)
+ (and (pair? templates)
+ (cond
+ ((procedure? (car templates))
+ (if (find-handler (cdr templates))
+ (error "ambiguous template match"))
+ (car templates))
+ (else (find-handler (cdr templates))))))
+
+ (let loop ((tree tree) (active-templates '()))
+ ;(cout "active-templates: " active-templates nl "tree: " tree nl)
+ (if (nodeset? tree)
+ (map-union (lambda (a-tree) (loop a-tree active-templates)) tree)
+ (let ((still-active-templates
+ (append
+ (filter-templates tree active-templates)
+ (filter-templates tree templates))))
+ (cond
+ ;((null? still-active-templates) '())
+ ((find-handler still-active-templates) =>
+ (lambda (handler) (handler tree)))
+ ((not (pair? tree)) '())
+ (else
+ (loop (cdr tree) still-active-templates)))))))
+
+;;; arch-tag: 88cd87de-8825-4ab3-9721-cf99694fb787
+;;; templates.scm ends here
diff --git a/module/sxml/fold.scm b/module/sxml/fold.scm
new file mode 100644
index 0000000..0d2a5bc
--- /dev/null
+++ b/module/sxml/fold.scm
@@ -0,0 +1,250 @@
+;;;; (sxml fold) -- transformation of sxml via fold operations
+;;;;
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Written 2007 by Andy Wingo <wingo at pobox dot com>.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;; @code{(sxml fold)} defines a number of variants of the @dfn{fold}
+;; algorithm for use in transforming SXML trees. Additionally it defines
+;; the layout operator, @code{fold-layout}, which might be described as
+;; a context-passing variant of SSAX's @code{pre-post-order}.
+;;
+;;; Code:
+
+(define-module (sxml fold)
+ #:use-module (srfi srfi-1)
+ #:export (foldt
+ foldts
+ foldts*
+ fold-values
+ foldts*-values
+ fold-layout))
+
+(define (atom? x)
+ (not (pair? x)))
+
+(define (foldt fup fhere tree)
+ "The standard multithreaded tree fold.
+
address@hidden is of type [a] -> a. @var{fhere} is of type object -> a.
+"
+ (if (atom? tree)
+ (fhere tree)
+ (fup (map (lambda (kid)
+ (foldt fup fhere kid))
+ tree))))
+
+(define (foldts fdown fup fhere seed tree)
+ "The single-threaded tree fold originally defined in SSAX.
address@hidden ssax,,(sxml ssax)}, for more information."
+ (if (atom? tree)
+ (fhere seed tree)
+ (fup seed
+ (fold (lambda (kid kseed)
+ (foldts fdown fup fhere kseed kid))
+ (fdown seed tree)
+ tree)
+ tree)))
+
+(define (foldts* fdown fup fhere seed tree)
+ "A variant of @ref{sxml fold foldts,,foldts} that allows pre-order
+tree rewrites. Originally defined in Andy Wingo's 2007 paper,
address@hidden of fold to XML transformation}."
+ (if (atom? tree)
+ (fhere seed tree)
+ (call-with-values
+ (lambda () (fdown seed tree))
+ (lambda (kseed tree)
+ (fup seed
+ (fold (lambda (kid kseed)
+ (foldts* fdown fup fhere
+ kseed kid))
+ kseed
+ tree)
+ tree)))))
+
+(define (fold-values proc list . seeds)
+ "A variant of @ref{SRFI-1 Fold and Map, fold} that allows multi-valued
+seeds. Note that the order of the arguments differs from that of
address@hidden"
+ (if (null? list)
+ (apply values seeds)
+ (call-with-values
+ (lambda () (apply proc (car list) seeds))
+ (lambda seeds
+ (apply fold-values proc (cdr list) seeds)))))
+
+(define (foldts*-values fdown fup fhere tree . seeds)
+ "A variant of @ref{sxml fold foldts*,,foldts*} that allows
+multi-valued seeds. Originally defined in Andy Wingo's 2007 paper,
address@hidden of fold to XML transformation}."
+ (if (atom? tree)
+ (apply fhere tree seeds)
+ (call-with-values
+ (lambda () (apply fdown tree seeds))
+ (lambda (tree . kseeds)
+ (call-with-values
+ (lambda ()
+ (apply fold-values
+ (lambda (tree . seeds)
+ (apply foldts*-values
+ fdown fup fhere tree seeds))
+ tree kseeds))
+ (lambda kseeds
+ (apply fup tree (append seeds kseeds))))))))
+
+(define (assq-ref alist key default)
+ (cond ((assq key alist) => cdr)
+ (else default)))
+
+(define (fold-layout tree bindings params layout stylesheet)
+ "A traversal combinator in the spirit of SSAX's @ref{sxml transform
+pre-post-order,,pre-post-order}.
+
address@hidden was originally presented in Andy Wingo's 2007 paper,
address@hidden of fold to XML transformation}.
+
address@hidden
+bindings := (<binding>...)
+binding := (<tag> <bandler-pair>...)
+ | (*default* . <post-handler>)
+ | (*text* . <text-handler>)
+tag := <symbol>
+handler-pair := (pre-layout . <pre-layout-handler>)
+ | (post . <post-handler>)
+ | (bindings . <bindings>)
+ | (pre . <pre-handler>)
+ | (macro . <macro-handler>)
address@hidden example
+
address@hidden @var
address@hidden pre-layout-handler
+A function of three arguments:
+
address@hidden @var
address@hidden kids
+the kids of the current node, before traversal
address@hidden params
+the params of the current node
address@hidden layout
+the layout coming into this node
address@hidden table
+
address@hidden is expected to use this information to return a
+layout to pass to the kids. The default implementation returns the
+layout given in the arguments.
+
address@hidden post-handler
+A function of five arguments:
address@hidden @var
address@hidden tag
+the current tag being processed
address@hidden params
+the params of the current node
address@hidden layout
+the layout coming into the current node, before any kids were processed
address@hidden klayout
+the layout after processing all of the children
address@hidden kids
+the already-processed child nodes
address@hidden table
+
address@hidden should return two values, the layout to pass to the
+next node and the final tree.
+
address@hidden text-handler
address@hidden is a function of three arguments:
address@hidden @var
address@hidden text
+the string
address@hidden params
+the current params
address@hidden layout
+the current layout
address@hidden table
+
address@hidden should return two values, the layout to pass to the
+next node and the value to which the string should transform.
address@hidden table
+"
+ (define (err . args)
+ (error "no binding available" args))
+ (define (fdown tree bindings pcont params layout ret)
+ (define (fdown-helper new-bindings new-layout cont)
+ (let ((cont-with-tag (lambda args
+ (apply cont (car tree) args)))
+ (bindings (if new-bindings
+ (append new-bindings bindings)
+ bindings))
+ (style-params (assq-ref stylesheet (car tree) '())))
+ (cond
+ ((null? (cdr tree))
+ (values
+ '() bindings cont-with-tag (cons style-params params) new-layout
'()))
+ ((and (pair? (cadr tree)) (eq? (caadr tree) '@))
+ (let ((params (cons (append (cdadr tree) style-params) params)))
+ (values
+ (cddr tree) bindings cont-with-tag params new-layout '())))
+ (else
+ (values
+ (cdr tree) bindings cont-with-tag (cons style-params params)
new-layout '())))))
+ (define (no-bindings)
+ (fdown-helper #f layout (assq-ref bindings '*default* err)))
+ (define (macro macro-handler)
+ (fdown (apply macro-handler tree)
+ bindings pcont params layout ret))
+ (define (pre pre-handler)
+ (values '() bindings
+ (lambda (params layout old-layout kids)
+ (values layout (reverse kids)))
+ params layout (apply pre-handler tree)))
+ (define (have-bindings tag-bindings)
+ (fdown-helper
+ (assq-ref tag-bindings 'bindings #f)
+ ((assq-ref tag-bindings 'pre-layout
+ (lambda (tag params layout)
+ layout))
+ tree params layout)
+ (assq-ref tag-bindings 'post
+ (assq-ref bindings '*default* err))))
+ (let ((tag-bindings (assq-ref bindings (car tree) #f)))
+ (cond
+ ((not tag-bindings) (no-bindings))
+ ((assq-ref tag-bindings 'macro #f) => macro)
+ ((assq-ref tag-bindings 'pre #f) => pre)
+ (else (have-bindings tag-bindings)))))
+ (define (fup tree bindings cont params layout ret
+ kbindings kcont kparams klayout kret)
+ (call-with-values
+ (lambda ()
+ (kcont kparams layout klayout (reverse kret)))
+ (lambda (klayout kret)
+ (values bindings cont params klayout (cons kret ret)))))
+ (define (fhere tree bindings cont params layout ret)
+ (call-with-values
+ (lambda ()
+ ((assq-ref bindings '*text* err) tree params layout))
+ (lambda (tlayout tret)
+ (values bindings cont params tlayout (cons tret ret)))))
+ (call-with-values
+ (lambda ()
+ (foldts*-values
+ fdown fup fhere tree bindings #f (cons params '()) layout '()))
+ (lambda (bindings cont params layout ret)
+ (values (car ret) layout))))
diff --git a/module/sxml/simple.scm b/module/sxml/simple.scm
new file mode 100644
index 0000000..a1b4854
--- /dev/null
+++ b/module/sxml/simple.scm
@@ -0,0 +1,169 @@
+;;;; (sxml simple) -- a simple interface to the SSAX parser
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;; Originally written by Oleg Kiselyov <oleg at pobox dot com> as
SXML-to-HTML.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;A simple interface to XML parsing and serialization.
+;;
+;;; Code:
+
+(define-module (sxml simple)
+ #:use-module (sxml ssax)
+ #:use-module (sxml transform)
+ #:use-module (ice-9 optargs)
+ #:use-module (srfi srfi-13)
+ #:export (xml->sxml sxml->xml sxml->string universal-sxslt-rules))
+
+(define* (xml->sxml #:optional (port (current-input-port)))
+ "Use SSAX to parse an XML document into SXML. Takes one optional
+argument, @var{port}, which defaults to the current input port."
+ (ssax:xml->sxml port '()))
+
+;; Universal transformation rules. Works for all XML.
+(define universal-sxslt-rules
+ #;
+ "A set of @code{pre-post-order} rules that transform any SXML tree
+into a form suitable for XML serialization by @code{(sxml transform)}'s
address@hidden:send-reply}. Used internally by @code{sxml->xml}."
+ `((@
+ ((*default* . ,(lambda (attr-key . value) ((enattr attr-key) value))))
+ . ,(lambda (trigger . value) (list '@ value)))
+ (*ENTITY* . ,(lambda (tag name) (list "&" name ";")))
+ (*PI* . ,(lambda (pi tag str) (list "<?" tag " " str "?>")))
+ ;; Is this right for entities? I don't have a reference for
+ ;; public-id/system-id at the moment...
+ (*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
+ (*text* . ,(lambda (trigger str)
+ (if (string? str) (string->escaped-xml str) str)))))
+
+(define* (sxml->xml tree #:optional (port (current-output-port)))
+ "Serialize the sxml tree @var{tree} as XML. The output will be written
+to the current output port, unless the optional argument @var{port} is
+present."
+ (with-output-to-port port
+ (lambda ()
+ (SRV:send-reply
+ (post-order
+ tree
+ universal-sxslt-rules)))))
+
+(define (sxml->string sxml)
+ "Detag an sxml tree @var{sxml} into a string. Does not perform any
+formatting."
+ (string-concatenate-reverse
+ (foldts
+ (lambda (seed tree) ; fdown
+ '())
+ (lambda (seed kid-seed tree) ; fup
+ (append! kid-seed seed))
+ (lambda (seed tree) ; fhere
+ (if (string? tree) (cons tree seed) seed))
+ '()
+ sxml)))
+
+;; The following two functions serialize tags and attributes. They are
+;; being used in the node handlers for the post-order function, see
+;; above.
+
+(define (check-name name)
+ (let* ((str (symbol->string name))
+ (i (string-index str #\:))
+ (head (or (and i (substring str 0 i)) str))
+ (tail (and i (substring str (1+ i)))))
+ (and i (string-index (substring str (1+ i)) #\:)
+ (error "Invalid QName: more than one colon" name))
+ (for-each
+ (lambda (s)
+ (and s
+ (or (char-alphabetic? (string-ref s 0))
+ (eq? (string-ref s 0) #\_)
+ (error "Invalid name starting character" s name))
+ (string-for-each
+ (lambda (c)
+ (or (char-alphabetic? c) (string-index "0123456789.-_" c)
+ (error "Invalid name character" c s name)))
+ s)))
+ (list head tail))))
+
+(define (entag tag)
+ (check-name tag)
+ (lambda elems
+ (if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
+ (list #\< tag (cdar elems)
+ (if (pair? (cdr elems))
+ (list #\> (cdr elems) "</" tag #\>)
+ " />"))
+ (list #\< tag
+ (if (pair? elems)
+ (list #\> elems "</" tag #\>)
+ " />")))))
+
+(define (enattr attr-key)
+ (check-name attr-key)
+ (let ((attr-str (symbol->string attr-key)))
+ (lambda (value)
+ (list #\space attr-str
+ "=\"" (and (not (null? value)) value) #\"))))
+
+(define (make-char-quotator char-encoding)
+ (let ((bad-chars (map car char-encoding)))
+
+ ;; Check to see if str contains one of the characters in charset,
+ ;; from the position i onward. If so, return that character's index.
+ ;; otherwise, return #f
+ (define (index-cset str i charset)
+ (let loop ((i i))
+ (and (< i (string-length str))
+ (if (memv (string-ref str i) charset) i
+ (loop (+ 1 i))))))
+
+ ;; The body of the function
+ (lambda (str)
+ (let ((bad-pos (index-cset str 0 bad-chars)))
+ (if (not bad-pos) str ; str had all good chars
+ (string-concatenate-reverse
+ (let loop ((from 0) (to bad-pos) (out '()))
+ (cond
+ ((>= from (string-length str)) out)
+ ((not to)
+ (cons (substring str from (string-length str)) out))
+ (else
+ (let ((quoted-char
+ (cdr (assv (string-ref str to) char-encoding)))
+ (new-to
+ (index-cset str (+ 1 to) bad-chars)))
+ (loop (1+ to) new-to
+ (if (< from to)
+ (cons* quoted-char (substring str from to) out)
+ (cons quoted-char out)))))))))))))
+
+;; Given a string, check to make sure it does not contain characters
+;; such as '<' or '&' that require encoding. Return either the original
+;; string, or a list of string fragments with special characters
+;; replaced by appropriate character entities.
+
+(define string->escaped-xml
+ (make-char-quotator
+ '((#\< . "<") (#\> . ">") (#\& . "&") (#\" . """))))
+
+;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac
+;;; simple.scm ends here
+
diff --git a/module/sxml/ssax.scm b/module/sxml/ssax.scm
new file mode 100644
index 0000000..8794927
--- /dev/null
+++ b/module/sxml/ssax.scm
@@ -0,0 +1,246 @@
+;;;; (sxml ssax) -- the SSAX parser
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;; Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com>
as SSAX.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;@subheading Functional XML parsing framework
+;@subsubheading SAX/DOM and SXML parsers with support for XML Namespaces and
validation
+;
+; This is a package of low-to-high level lexing and parsing procedures
+; that can be combined to yield a SAX, a DOM, a validating parser, or
+; a parser intended for a particular document type. The procedures in
+; the package can be used separately to tokenize or parse various
+; pieces of XML documents. The package supports XML Namespaces,
+; internal and external parsed entities, user-controlled handling of
+; whitespace, and validation. This module therefore is intended to be
+; a framework, a set of "Lego blocks" you can use to build a parser
+; following any discipline and performing validation to any degree. As
+; an example of the parser construction, this file includes a
+; semi-validating SXML parser.
+
+; The present XML framework has a "sequential" feel of SAX yet a
+; "functional style" of DOM. Like a SAX parser, the framework scans the
+; document only once and permits incremental processing. An application
+; that handles document elements in order can run as efficiently as
+; possible. @emph{Unlike} a SAX parser, the framework does not require
+; an application register stateful callbacks and surrender control to
+; the parser. Rather, it is the application that can drive the framework
+; -- calling its functions to get the current lexical or syntax element.
+; These functions do not maintain or mutate any state save the input
+; port. Therefore, the framework permits parsing of XML in a pure
+; functional style, with the input port being a monad (or a linear,
+; read-once parameter).
+
+; Besides the @var{port}, there is another monad -- @var{seed}. Most of
+; the middle- and high-level parsers are single-threaded through the
+; @var{seed}. The functions of this framework do not process or affect
+; the @var{seed} in any way: they simply pass it around as an instance
+; of an opaque datatype. User functions, on the other hand, can use the
+; seed to maintain user's state, to accumulate parsing results, etc. A
+; user can freely mix his own functions with those of the framework. On
+; the other hand, the user may wish to instantiate a high-level parser:
+; @code{SSAX:make-elem-parser} or @code{SSAX:make-parser}. In the latter
+; case, the user must provide functions of specific signatures, which
+; are called at predictable moments during the parsing: to handle
+; character data, element data, or processing instructions (PI). The
+; functions are always given the @var{seed}, among other parameters, and
+; must return the new @var{seed}.
+
+; From a functional point of view, XML parsing is a combined
+; pre-post-order traversal of a "tree" that is the XML document
+; itself. This down-and-up traversal tells the user about an element
+; when its start tag is encountered. The user is notified about the
+; element once more, after all element's children have been
+; handled. The process of XML parsing therefore is a fold over the
+; raw XML document. Unlike a fold over trees defined in [1], the
+; parser is necessarily single-threaded -- obviously as elements
+; in a text XML document are laid down sequentially. The parser
+; therefore is a tree fold that has been transformed to accept an
+; accumulating parameter [1,2].
+
+; Formally, the denotational semantics of the parser can be expressed
+; as
+;@smallexample
+; parser:: (Start-tag -> Seed -> Seed) ->
+; (Start-tag -> Seed -> Seed -> Seed) ->
+; (Char-Data -> Seed -> Seed) ->
+; XML-text-fragment -> Seed -> Seed
+; parser fdown fup fchar "<elem attrs> content </elem>" seed
+; = fup "<elem attrs>" seed
+; (parser fdown fup fchar "content" (fdown "<elem attrs>" seed))
+;
+; parser fdown fup fchar "char-data content" seed
+; = parser fdown fup fchar "content" (fchar "char-data" seed)
+;
+; parser fdown fup fchar "elem-content content" seed
+; = parser fdown fup fchar "content" (
+; parser fdown fup fchar "elem-content" seed)
+;@end smallexample
+
+; Compare the last two equations with the left fold
+;@smallexample
+; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
+;@end smallexample
+
+; The real parser created by @code{SSAX:make-parser} is slightly more
+; complicated, to account for processing instructions, entity
+; references, namespaces, processing of document type declaration, etc.
+
+
+; The XML standard document referred to in this module is
+; @uref{http://www.w3.org/TR/1998/REC-xml-19980210.html}
+;
+; The present file also defines a procedure that parses the text of an
+; XML document or of a separate element into SXML, an S-expression-based
+; model of an XML Information Set. SXML is also an Abstract Syntax Tree
+; of an XML document. SXML is similar but not identical to DOM; SXML is
+; particularly suitable for Scheme-based XML/HTML authoring, SXPath
+; queries, and tree transformations. See SXML.html for more details.
+; SXML is a term implementation of evaluation of the XML document [3].
+; The other implementation is context-passing.
+
+; The present frameworks fully supports the XML Namespaces Recommendation:
+; @uref{http://www.w3.org/TR/REC-xml-names/}
+; Other links:
+;@table @asis
+;@item [1]
+; Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
+; Proc. ICFP'98, 1998, pp. 273-279.
+;@item [2]
+; Richard S. Bird, The promotion and accumulation strategies in
+; transformational programming, ACM Trans. Progr. Lang. Systems,
+; 6(4):487-504, October 1984.
+;@item [3]
+; Ralf Hinze, "Deriving Backtracking Monad Transformers,"
+; Functional Pearl. Proc ICFP'00, pp. 186-197.
+;@end table
+;;
+;;; Code:
+
+(define-module (sxml ssax)
+ #:use-module (sxml ssax input-parse)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+
+ #:export (current-ssax-error-port
+ with-ssax-error-to-port
+ xml-token? xml-token-kind xml-token-head
+ make-empty-attlist attlist-add
+ attlist-null?
+ attlist-remove-top
+ attlist->alist attlist-fold
+ ssax:uri-string->symbol
+ ssax:skip-internal-dtd
+ ssax:read-pi-body-as-string
+ ssax:reverse-collect-str-drop-ws
+ ssax:read-markup-token
+ ssax:read-cdata-body
+ ssax:read-char-ref
+ ssax:read-attributes
+ ssax:complete-start-tag
+ ssax:read-external-id
+ ssax:read-char-data
+ ssax:xml->sxml
+ ssax:make-parser
+ ssax:make-pi-parser
+ ssax:make-elem-parser))
+
+(define (parser-error port message . rest)
+ (apply throw 'parser-error port message rest))
+(define ascii->char integer->char)
+(define char->ascii char->integer)
+
+(define *current-ssax-error-port* (make-fluid))
+(define (current-ssax-error-port)
+ (fluid-ref *current-ssax-error-port*))
+
+(define (with-ssax-error-to-port port thunk)
+ (with-fluids ((*current-ssax-error-port* port))
+ (thunk)))
+
+(define (ssax:warn port msg . args)
+ (format (current-ssax-error-port)
+ ";;; SSAX warning: ~a ~a\n" msg args))
+
+(define (ucscode->string codepoint)
+ (string (integer->char codepoint)))
+
+(define char-newline #\newline)
+(define char-return #\return)
+(define char-tab #\tab)
+(define nl "\n")
+
+;; if condition is true, execute stmts in turn and return the result of
+;; the last statement otherwise, return #f
+(define-syntax when
+ (syntax-rules ()
+ ((when condition . stmts)
+ (and condition (begin . stmts)))))
+
+;; Execute a sequence of forms and return the result of the _first_ one.
+;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with
+;; side effects and return a value that must be computed before some or
+;; all of the side effects happen.
+(define-syntax begin0
+ (syntax-rules ()
+ ((begin0 form form1 ... )
+ (let ((val form)) form1 ... val))))
+
+; Like let* but allowing for multiple-value bindings
+(define-syntax let*-values
+ (syntax-rules ()
+ ((let*-values () . bodies) (begin . bodies))
+ ((let*-values (((var) initializer) . rest) . bodies)
+ (let ((var initializer)) ; a single var optimization
+ (let*-values rest . bodies)))
+ ((let*-values ((vars initializer) . rest) . bodies)
+ (call-with-values (lambda () initializer) ; the most generic case
+ (lambda vars (let*-values rest . bodies))))))
+
+;; needed for some dumb reason
+(define inc 1+)
+(define dec 1-)
+
+(define-syntax include-from-path/filtered
+ (lambda (x)
+ (define (read-filtered accept-list file)
+ (with-input-from-file (%search-load-path file)
+ (lambda ()
+ (let loop ((sexp (read)) (out '()))
+ (cond
+ ((eof-object? sexp) (reverse out))
+ ((and (pair? sexp) (memq (car sexp) accept-list))
+ (loop (read) (cons sexp out)))
+ (else
+ (loop (read) out)))))))
+ (syntax-case x ()
+ ((_ accept-list file)
+ (with-syntax (((exp ...) (datum->syntax
+ x
+ (read-filtered
+ (syntax->datum #'accept-list)
+ (syntax->datum #'file)))))
+ #'(begin exp ...))))))
+
+(include-from-path "sxml/upstream/assert.scm")
+(include-from-path/filtered
+ (define define-syntax ssax:define-labeled-arg-macro)
+ "sxml/upstream/SSAX.scm")
diff --git a/module/sxml/ssax/input-parse.scm b/module/sxml/ssax/input-parse.scm
new file mode 100644
index 0000000..6e845ee
--- /dev/null
+++ b/module/sxml/ssax/input-parse.scm
@@ -0,0 +1,180 @@
+;;;; (sxml ssax input-parse) -- a simple lexer
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as
input-parse.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;; A simple lexer.
+;;
+;; The procedures in this module surprisingly often suffice to parse an
+;; input stream. They either skip, or build and return tokens, according
+;; to inclusion or delimiting semantics. The list of characters to
+;; expect, include, or to break at may vary from one invocation of a
+;; function to another. This allows the functions to easily parse even
+;; context-sensitive languages.
+;;
+;; EOF is generally frowned on, and thrown up upon if encountered.
+;; Exceptions are mentioned specifically. The list of expected
+;; characters (characters to skip until, or break-characters) may
+;; include an EOF "character", which is to be coded as the symbol,
+;; @code{*eof*}.
+;;
+;; The input stream to parse is specified as a @dfn{port}, which is
+;; usually the last (and optional) argument. It defaults to the current
+;; input port if omitted.
+;;
+;; If the parser encounters an error, it will throw an exception to the
+;; key @code{parser-error}. The arguments will be of the form
+;; @code{(@var{port} @var{message} @var{specialising-msg}*)}.
+;;
+;; The first argument is a port, which typically points to the offending
+;; character or its neighborhood. You can then use @code{port-column}
+;; and @code{port-line} to query the current position. @var{message} is
+;; the description of the error. Other arguments supply more details
+;; about the problem.
+;;
+;;; Code:
+
+(define-module (sxml ssax input-parse)
+ #:use-module (ice-9 rdelim)
+ #:export (peek-next-char
+ assert-curr-char
+ skip-until
+ skip-while
+ next-token
+ next-token-of
+ read-text-line
+ read-string
+ find-string-from-port?))
+
+(define ascii->char integer->char)
+(define char->ascii char->integer)
+(define char-newline #\newline)
+(define char-return #\return)
+(define inc 1+)
+(define dec 1-)
+
+;; rewrite oleg's define-opt into define* style
+(define-macro (define-opt bindings body . body-rest)
+ (let* ((rev-bindings (reverse bindings))
+ (opt-bindings
+ (and (pair? rev-bindings) (pair? (car rev-bindings))
+ (eq? 'optional (caar rev-bindings))
+ (cdar rev-bindings))))
+ (if opt-bindings
+ `(define* ,(append (reverse (cons #:optional (cdr rev-bindings)))
+ opt-bindings)
+ ,body ,@body-rest)
+ `(define* ,bindings ,body ,@body-rest))))
+
+(define (parser-error port message . rest)
+ (apply throw 'parser-error port message rest))
+
+(include-from-path "sxml/upstream/input-parse.scm")
+
+;; This version for guile is quite speedy, due to read-delimited (which
+;; is implemented in C).
+(define-opt (next-token prefix-skipped-chars break-chars
+ (optional (comment "") (port (current-input-port))) )
+ (let ((delims (list->string (delete '*eof* break-chars))))
+ (if (eof-object? (if (null? prefix-skipped-chars)
+ (peek-char port)
+ (skip-while prefix-skipped-chars port)))
+ (if (memq '*eof* break-chars)
+ ""
+ (parser-error port "EOF while reading a token " comment))
+ (let ((token (read-delimited delims port 'peek)))
+ (if (and (eof-object? (peek-char port))
+ (not (memq '*eof* break-chars)))
+ (parser-error port "EOF while reading a token " comment)
+ token)))))
+
+(define-opt (read-text-line (optional (port (current-input-port))) )
+ (read-line port))
+
+;; Written 1995, 1996 by Oleg Kiselyov (address@hidden)
+;; Modified 1996, 1997, 1998, 2001 by A. Jaffer (address@hidden)
+;; Modified 2003 by Steve VanDevender (address@hidden)
+;; Modified 2004 Andy Wingo <wingo at pobox dot com>
+;; This function is from SLIB's strsrch.scm, and is in the public domain.
+(define (find-string-from-port? str <input-port> . max-no-char)
+ "Looks for @var{str} in @var{<input-port>}, optionally within the
+first @var{max-no-char} characters."
+ (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
+ (letrec
+ ((no-chars-read 0)
+ (peeked? #f)
+ (my-peek-char ; Return a peeked char or #f
+ (lambda () (and (or (not (number? max-no-char))
+ (< no-chars-read max-no-char))
+ (let ((c (peek-char <input-port>)))
+ (cond (peeked? c)
+ ((eof-object? c) #f)
+ ((procedure? max-no-char)
+ (set! peeked? #t)
+ (if (max-no-char c) #f c))
+ ((eqv? max-no-char c) #f)
+ (else c))))))
+ (next-char (lambda () (set! peeked? #f) (read-char <input-port>)
+ (set! no-chars-read (+ 1 no-chars-read))))
+ (match-1st-char ; of the string str
+ (lambda ()
+ (let ((c (my-peek-char)))
+ (and c
+ (begin (next-char)
+ (if (char=? c (string-ref str 0))
+ (match-other-chars 1)
+ (match-1st-char)))))))
+ ;; There has been a partial match, up to the point pos-to-match
+ ;; (for example, str[0] has been found in the stream)
+ ;; Now look to see if str[pos-to-match] for would be found, too
+ (match-other-chars
+ (lambda (pos-to-match)
+ (if (>= pos-to-match (string-length str))
+ no-chars-read ; the entire string has matched
+ (let ((c (my-peek-char)))
+ (and c
+ (if (not (char=? c (string-ref str pos-to-match)))
+ (backtrack 1 pos-to-match)
+ (begin (next-char)
+ (match-other-chars (+ 1 pos-to-match)))))))))
+
+ ;; There had been a partial match, but then a wrong char showed up.
+ ;; Before discarding previously read (and matched) characters, we check
+ ;; to see if there was some smaller partial match. Note, characters read
+ ;; so far (which matter) are those of str[0..matched-substr-len - 1]
+ ;; In other words, we will check to see if there is such i>0 that
+ ;; substr(str,0,j) = substr(str,i,matched-substr-len)
+ ;; where j=matched-substr-len - i
+ (backtrack
+ (lambda (i matched-substr-len)
+ (let ((j (- matched-substr-len i)))
+ (if (<= j 0)
+ ;; backed off completely to the begining of str
+ (match-1st-char)
+ (let loop ((k 0))
+ (if (>= k j)
+ (match-other-chars j) ; there was indeed a shorter match
+ (if (char=? (string-ref str k)
+ (string-ref str (+ i k)))
+ (loop (+ 1 k))
+ (backtrack (+ 1 i) matched-substr-len))))))))
+ )
+ (match-1st-char)))
diff --git a/module/sxml/transform.scm b/module/sxml/transform.scm
new file mode 100644
index 0000000..c905456
--- /dev/null
+++ b/module/sxml/transform.scm
@@ -0,0 +1,298 @@
+;;;; (sxml transform) -- pre- and post-order sxml transformation
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;; Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as
SXML-tree-trans.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;@heading SXML expression tree transformers
+;
+;@subheading Pre-Post-order traversal of a tree and creation of a new tree
+;@smallexample
+;pre-post-order:: <tree> x <bindings> -> <new-tree>
+;@end smallexample
+; where
+;@smallexample
+; <bindings> ::= (<binding> ...)
+; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
+; (<trigger-symbol> *macro* . <handler>) |
+; (<trigger-symbol> <new-bindings> . <handler>) |
+; (<trigger-symbol> . <handler>)
+; <trigger-symbol> ::= XMLname | *text* | *default*
+; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
+;@end smallexample
+;
+; The pre-post-order function visits the nodes and nodelists
+; pre-post-order (depth-first). For each @code{<Node>} of the form
+; @code{(@var{name} <Node> ...)}, it looks up an association with the
+; given @var{name} among its @var{<bindings>}. If failed,
+; @code{pre-post-order} tries to locate a @code{*default*} binding. It's
+; an error if the latter attempt fails as well. Having found a binding,
+; the @code{pre-post-order} function first checks to see if the binding
+; is of the form
+;@smallexample
+; (<trigger-symbol> *preorder* . <handler>)
+;@end smallexample
+;
+; If it is, the handler is 'applied' to the current node. Otherwise, the
+; pre-post-order function first calls itself recursively for each child
+; of the current node, with @var{<new-bindings>} prepended to the
+; @var{<bindings>} in effect. The result of these calls is passed to the
+; @var{<handler>} (along with the head of the current @var{<Node>}). To
+; be more precise, the handler is _applied_ to the head of the current
+; node and its processed children. The result of the handler, which
+; should also be a @code{<tree>}, replaces the current @var{<Node>}. If
+; the current @var{<Node>} is a text string or other atom, a special
+; binding with a symbol @code{*text*} is looked up.
+;
+; A binding can also be of a form
+;@smallexample
+; (<trigger-symbol> *macro* . <handler>)
+;@end smallexample
+; This is equivalent to @code{*preorder*} described above. However, the
+; result is re-processed again, with the current stylesheet.
+;;
+;;; Code:
+
+(define-module (sxml transform)
+ #:export (SRV:send-reply
+ foldts
+ post-order
+ pre-post-order
+ replace-range))
+
+;; Upstream version:
+; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $
+
+; Like let* but allowing for multiple-value bindings
+(define-macro (let*-values bindings . body)
+ (if (null? bindings) (cons 'begin body)
+ (apply
+ (lambda (vars initializer)
+ (let ((cont
+ (cons 'let*-values
+ (cons (cdr bindings) body))))
+ (cond
+ ((not (pair? vars)) ; regular let case, a single var
+ `(let ((,vars ,initializer)) ,cont))
+ ((null? (cdr vars)) ; single var, see the prev case
+ `(let ((,(car vars) ,initializer)) ,cont))
+ (else ; the most generic case
+ `(call-with-values (lambda () ,initializer)
+ (lambda ,vars ,cont))))))
+ (car bindings))))
+
+(define (SRV:send-reply . fragments)
+ "Output the @var{fragments} to the current output port.
+
+The fragments are a list of strings, characters, numbers, thunks,
address@hidden, @code{#t} -- and other fragments. The function traverses the
+tree depth-first, writes out strings and characters, executes thunks,
+and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
+anything was written at all; otherwise the result is @code{#f} If
address@hidden occurs among the fragments, it is not written out but causes
+the result of @code{SRV:send-reply} to be @code{#t}."
+ (let loop ((fragments fragments) (result #f))
+ (cond
+ ((null? fragments) result)
+ ((not (car fragments)) (loop (cdr fragments) result))
+ ((null? (car fragments)) (loop (cdr fragments) result))
+ ((eq? #t (car fragments)) (loop (cdr fragments) #t))
+ ((pair? (car fragments))
+ (loop (cdr fragments) (loop (car fragments) result)))
+ ((procedure? (car fragments))
+ ((car fragments))
+ (loop (cdr fragments) #t))
+ (else
+ (display (car fragments))
+ (loop (cdr fragments) #t)))))
+
+
+
+;------------------------------------------------------------------------
+; Traversal of an SXML tree or a grove:
+; a <Node> or a <Nodelist>
+;
+; A <Node> and a <Nodelist> are mutually-recursive datatypes that
+; underlie the SXML tree:
+; <Node> ::= (name . <Nodelist>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; <Nodelist> ::= (<Node> ...)
+; Nodelists, and Nodes other than text strings are both lists. A
+; <Nodelist> however is either an empty list, or a list whose head is
+; not a symbol (an atom in general). A symbol at the head of a node is
+; either an XML name (in which case it's a tag of an XML element), or
+; an administrative name such as '@'.
+; See SXPath.scm and SSAX.scm for more information on SXML.
+
+
+;; see the commentary for docs
+(define (pre-post-order tree bindings)
+ (let* ((default-binding (assq '*default* bindings))
+ (text-binding (or (assq '*text* bindings) default-binding))
+ (text-handler ; Cache default and text bindings
+ (and text-binding
+ (if (procedure? (cdr text-binding))
+ (cdr text-binding) (cddr text-binding)))))
+ (let loop ((tree tree))
+ (cond
+ ((null? tree) '())
+ ((not (pair? tree))
+ (let ((trigger '*text*))
+ (if text-handler (text-handler trigger tree)
+ (error "Unknown binding for " trigger " and no default"))))
+ ((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
+ (else ; tree is an SXML node
+ (let* ((trigger (car tree))
+ (binding (or (assq trigger bindings) default-binding)))
+ (cond
+ ((not binding)
+ (error "Unknown binding for " trigger " and no default"))
+ ((not (pair? (cdr binding))) ; must be a procedure: handler
+ (apply (cdr binding) trigger (map loop (cdr tree))))
+ ((eq? '*preorder* (cadr binding))
+ (apply (cddr binding) tree))
+ ((eq? '*macro* (cadr binding))
+ (loop (apply (cddr binding) tree)))
+ (else ; (cadr binding) is a local binding
+ (apply (cddr binding) trigger
+ (pre-post-order (cdr tree) (append (cadr binding) bindings)))
+ ))))))))
+
+; post-order is a strict subset of pre-post-order without *preorder*
+; (let alone *macro*) traversals.
+; Now pre-post-order is actually faster than the old post-order.
+; The function post-order is deprecated and is aliased below for
+; backward compatibility.
+(define post-order pre-post-order)
+
+;------------------------------------------------------------------------
+; Extended tree fold
+; tree = atom | (node-name tree ...)
+;
+; foldts fdown fup fhere seed (Leaf str) = fhere seed str
+; foldts fdown fup fhere seed (Nd kids) =
+; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
+
+; procedure fhere: seed -> atom -> seed
+; procedure fdown: seed -> node -> seed
+; procedure fup: parent-seed -> last-kid-seed -> node -> seed
+; foldts returns the final seed
+
+(define (foldts fdown fup fhere seed tree)
+ (cond
+ ((null? tree) seed)
+ ((not (pair? tree)) ; An atom
+ (fhere seed tree))
+ (else
+ (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
+ (if (null? kids)
+ (fup seed kid-seed tree)
+ (loop (foldts fdown fup fhere kid-seed (car kids))
+ (cdr kids)))))))
+
+;------------------------------------------------------------------------
+; Traverse a forest depth-first and cut/replace ranges of nodes.
+;
+; The nodes that define a range don't have to have the same immediate
+; parent, don't have to be on the same level, and the end node of a
+; range doesn't even have to exist. A replace-range procedure removes
+; nodes from the beginning node of the range up to (but not including)
+; the end node of the range. In addition, the beginning node of the
+; range can be replaced by a node or a list of nodes. The range of
+; nodes is cut while depth-first traversing the forest. If all
+; branches of the node are cut a node is cut as well. The procedure
+; can cut several non-overlapping ranges from a forest.
+
+; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+; where
+; type FOREST = (NODE ...)
+; type NODE = Atom | (Name . FOREST) | FOREST
+;
+; The range of nodes is specified by two predicates, beg-pred and end-pred.
+; beg-pred:: NODE -> #f | FOREST
+; end-pred:: NODE -> #f | FOREST
+; The beg-pred predicate decides on the beginning of the range. The node
+; for which the predicate yields non-#f marks the beginning of the range
+; The non-#f value of the predicate replaces the node. The value can be a
+; list of nodes. The replace-range procedure then traverses the tree and skips
+; all the nodes, until the end-pred yields non-#f. The value of the end-pred
+; replaces the end-range node. The new end node and its brothers will be
+; re-scanned.
+; The predicates are evaluated pre-order. We do not descend into a node that
+; is marked as the beginning of the range.
+
+(define (replace-range beg-pred end-pred forest)
+
+ ; loop forest keep? new-forest
+ ; forest is the forest to traverse
+ ; new-forest accumulates the nodes we will keep, in the reverse
+ ; order
+ ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
+ ; traverse its children and keep those that are not in the skip range.
+ ; If keep? is #f, skip the current node if atomic. Otherwise,
+ ; traverse its children. If all children are skipped, skip the node
+ ; as well.
+
+ (define (loop forest keep? new-forest)
+ (if (null? forest) (values (reverse new-forest) keep?)
+ (let ((node (car forest)))
+ (if keep?
+ (cond ; accumulate mode
+ ((beg-pred node) => ; see if the node starts the skip range
+ (lambda (repl-branches) ; if so, skip/replace the node
+ (loop (cdr forest) #f
+ (append (reverse repl-branches) new-forest))))
+ ((not (pair? node)) ; it's an atom, keep it
+ (loop (cdr forest) keep? (cons node new-forest)))
+ (else
+ (let*-values
+ (((node?) (symbol? (car node))) ; or is it a nodelist?
+ ((new-kids keep?) ; traverse its children
+ (loop (if node? (cdr node) node) #t '())))
+ (loop (cdr forest) keep?
+ (cons
+ (if node? (cons (car node) new-kids) new-kids)
+ new-forest)))))
+ ; skip mode
+ (cond
+ ((end-pred node) => ; end the skip range
+ (lambda (repl-branches) ; repl-branches will be re-scanned
+ (loop (append repl-branches (cdr forest)) #t
+ new-forest)))
+ ((not (pair? node)) ; it's an atom, skip it
+ (loop (cdr forest) keep? new-forest))
+ (else
+ (let*-values
+ (((node?) (symbol? (car node))) ; or is it a nodelist?
+ ((new-kids keep?) ; traverse its children
+ (loop (if node? (cdr node) node) #f '())))
+ (loop (cdr forest) keep?
+ (if (or keep? (pair? new-kids))
+ (cons
+ (if node? (cons (car node) new-kids) new-kids)
+ new-forest)
+ new-forest) ; if all kids are skipped
+ )))))))) ; skip the node too
+
+ (let*-values (((new-forest keep?) (loop forest #t '())))
+ new-forest))
+
+;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
+;;; transform.scm ends here
diff --git a/module/sxml/upstream/COPYING.SSAX
b/module/sxml/upstream/COPYING.SSAX
new file mode 100644
index 0000000..9dc72b8
--- /dev/null
+++ b/module/sxml/upstream/COPYING.SSAX
@@ -0,0 +1,2 @@
+The files in this directory are imported directly from upstream SSAX,
+and are in the public domain.
diff --git a/module/sxml/upstream/SSAX.scm b/module/sxml/upstream/SSAX.scm
new file mode 100644
index 0000000..776e311
--- /dev/null
+++ b/module/sxml/upstream/SSAX.scm
@@ -0,0 +1,3212 @@
+; Functional XML parsing framework: SAX/DOM and SXML parsers
+; with support for XML Namespaces and validation
+;
+; This is a package of low-to-high level lexing and parsing procedures
+; that can be combined to yield a SAX, a DOM, a validating parsers, or
+; a parser intended for a particular document type. The procedures in
+; the package can be used separately to tokenize or parse various
+; pieces of XML documents. The package supports XML Namespaces,
+; internal and external parsed entities, user-controlled handling of
+; whitespace, and validation. This module therefore is intended to be
+; a framework, a set of "Lego blocks" you can use to build a parser
+; following any discipline and performing validation to any degree. As
+; an example of the parser construction, this file includes a
+; semi-validating SXML parser.
+
+; The present XML framework has a "sequential" feel of SAX yet a
+; "functional style" of DOM. Like a SAX parser, the framework scans
+; the document only once and permits incremental processing. An
+; application that handles document elements in order can run as
+; efficiently as possible. _Unlike_ a SAX parser, the framework does
+; not require an application register stateful callbacks and surrender
+; control to the parser. Rather, it is the application that can drive
+; the framework -- calling its functions to get the current lexical or
+; syntax element. These functions do not maintain or mutate any state
+; save the input port. Therefore, the framework permits parsing of XML
+; in a pure functional style, with the input port being a monad (or a
+; linear, read-once parameter).
+
+; Besides the PORT, there is another monad -- SEED. Most of the
+; middle- and high-level parsers are single-threaded through the
+; seed. The functions of this framework do not process or affect the
+; SEED in any way: they simply pass it around as an instance of an
+; opaque datatype. User functions, on the other hand, can use the
+; seed to maintain user's state, to accumulate parsing results, etc. A
+; user can freely mix his own functions with those of the
+; framework. On the other hand, the user may wish to instantiate a
+; high-level parser: ssax:make-elem-parser or ssax:make-parser. In
+; the latter case, the user must provide functions of specific
+; signatures, which are called at predictable moments during the
+; parsing: to handle character data, element data, or processing
+; instructions (PI). The functions are always given the SEED, among
+; other parameters, and must return the new SEED.
+
+; From a functional point of view, XML parsing is a combined
+; pre-post-order traversal of a "tree" that is the XML document
+; itself. This down-and-up traversal tells the user about an element
+; when its start tag is encountered. The user is notified about the
+; element once more, after all element's children have been
+; handled. The process of XML parsing therefore is a fold over the
+; raw XML document. Unlike a fold over trees defined in [1], the
+; parser is necessarily single-threaded -- obviously as elements
+; in a text XML document are laid down sequentially. The parser
+; therefore is a tree fold that has been transformed to accept an
+; accumulating parameter [1,2].
+
+; Formally, the denotational semantics of the parser can be expressed
+; as
+; parser:: (Start-tag -> Seed -> Seed) ->
+; (Start-tag -> Seed -> Seed -> Seed) ->
+; (Char-Data -> Seed -> Seed) ->
+; XML-text-fragment -> Seed -> Seed
+; parser fdown fup fchar "<elem attrs> content </elem>" seed
+; = fup "<elem attrs>" seed
+; (parser fdown fup fchar "content" (fdown "<elem attrs>" seed))
+;
+; parser fdown fup fchar "char-data content" seed
+; = parser fdown fup fchar "content" (fchar "char-data" seed)
+;
+; parser fdown fup fchar "elem-content content" seed
+; = parser fdown fup fchar "content" (
+; parser fdown fup fchar "elem-content" seed)
+
+; Compare the last two equations with the left fold
+; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
+
+; The real parser created my ssax:make-parser is slightly more complicated,
+; to account for processing instructions, entity references, namespaces,
+; processing of document type declaration, etc.
+
+
+; The XML standard document referred to in this module is
+; http://www.w3.org/TR/1998/REC-xml-19980210.html
+;
+; The present file also defines a procedure that parses the text of an
+; XML document or of a separate element into SXML, an
+; S-expression-based model of an XML Information Set. SXML is also an
+; Abstract Syntax Tree of an XML document. SXML is similar
+; but not identical to DOM; SXML is particularly suitable for
+; Scheme-based XML/HTML authoring, SXPath queries, and tree
+; transformations. See SXML.html for more details.
+; SXML is a term implementation of evaluation of the XML document [3].
+; The other implementation is context-passing.
+
+; The present frameworks fully supports the XML Namespaces Recommendation:
+; http://www.w3.org/TR/REC-xml-names/
+; Other links:
+; [1] Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
+; Proc. ICFP'98, 1998, pp. 273-279.
+; [2] Richard S. Bird, The promotion and accumulation strategies in
+; transformational programming, ACM Trans. Progr. Lang. Systems,
+; 6(4):487-504, October 1984.
+; [3] Ralf Hinze, "Deriving Backtracking Monad Transformers,"
+; Functional Pearl. Proc ICFP'00, pp. 186-197.
+
+; IMPORT
+; parser-error ssax:warn, see Handling of errors, below
+; functions declared in files util.scm, input-parse.scm and look-for-str.scm
+; char-encoding.scm for various platform-specific character-encoding functions.
+; From SRFI-13: string-concatenate/shared and string-concatenate-reverse/shared
+; If a particular implementation lacks SRFI-13 support, please
+; include the file srfi-13-local.scm
+
+; Handling of errors
+; This package relies on a function parser-error, which must be defined
+; by a user of the package. The function has the following signature:
+; parser-error PORT MESSAGE SPECIALISING-MSG*
+; Many procedures of this package call 'parser-error' whenever a
+; parsing, well-formedness or validation error is encountered. The
+; first argument is a port, which typically points to the offending
+; character or its neighborhood. Most of the Scheme systems let the
+; user query a PORT for the current position. The MESSAGE argument
+; indicates a failed XML production or a failed XML constraint. The
+; latter is referred to by its anchor name in the XML Recommendation
+; or XML Namespaces Recommendation. The parsing library (e.g.,
+; next-token, assert-curr-char) invoke 'parser-error' as well, in
+; exactly the same way. See input-parse.scm for more details.
+; See
+; http://pair.com/lisovsky/download/parse-error.scm
+; for an excellent example of such a redefined parser-error function.
+;
+; In addition, the present code invokes a function ssax:warn
+; ssax:warn PORT MESSAGE SPECIALISING-MSG*
+; to notify the user about warnings that are NOT errors but still
+; may alert the user.
+;
+; Again, parser-error and ssax:warn are supposed to be defined by the
+; user. However, if a run-test macro below is set to include
+; self-tests, this present code does provide the definitions for these
+; functions to allow tests to run.
+
+; Misc notes
+; It seems it is highly desirable to separate tests out in a dedicated
+; file.
+;
+; Jim Bender wrote on Mon, 9 Sep 2002 20:03:42 EDT on the SSAX-SXML
+; mailing list (message A fine-grained "lego")
+; The task was to record precise source location information, as PLT
+; does with its current XML parser. That parser records the start and
+; end location (filepos, line#, column#) for pi, elements, attributes,
+; chuncks of "pcdata".
+; As suggested above, though, in some cases I needed to be able force
+; open an interface that did not yet exist. For instance, I added an
+; "end-char-data-hook", which would be called at the end of char-data
+; fragment. This returns a function of type (seed -> seed) which is
+; invoked on the current seed only if read-char-data has indeed reached
+; the end of a block of char data (after reading a new token.
+; But the deepest interface that I needed to expose was that of reading
+; attributes. In the official distribution, this is not even a separate
+; function. Instead, it is embedded within SSAX:read-attributes. This
+; required some small re-structuring as well.
+; This definitely will not be to everyone's taste (nor needed by most).
+; Certainly, the existing make-parser interface addresses most custom
+; needs. And likely 80-90 lines of a "link specification" to create a
+; parser from many tiny little lego blocks may please only a few, while
+; appalling others.
+; The code is available at http://celtic.benderweb.net/ssax-lego.plt or
+; http://celtic.benderweb.net/ssax-lego.tar.gz
+; In the examples directory, I provide:
+; - a unit version of the make-parser interface,
+; - a simple SXML parser using that interface,
+; - an SXML parser which directly uses the "new lego",
+; - a pseudo-SXML parser, which records source location information
+; - and lastly a parser which returns the structures used in PLT's xml
+; collection, with source location information
+
+; $Id: SSAX.scm,v 5.1 2004/07/07 16:02:30 sperber Exp $
+;^^^^^^^^^
+
+
+ ; See the Makefile in the ../tests directory
+ ; (in particular, the rule vSSAX) for an example of how
+ ; to run this code on various Scheme systems.
+ ; See SSAX examples for many samples of using this code,
+ ; again, on a variety of Scheme systems.
+ ; See http://ssax.sf.net/
+
+
+; The following macro runs built-in test cases -- or does not run,
+; depending on which of the two cases below you commented out
+; Case 1: no tests:
+;(define-macro run-test (lambda body '(begin #f)))
+;(define-syntax run-test (syntax-rules () ((run-test . args) (begin #f))))
+
+; Case 2: with tests.
+; The following macro could've been defined just as
+; (define-macro run-test (lambda body `(begin (display "\n-->Test\n") ,@body)))
+;
+; Instead, it's more involved, to make up for case-insensitivity of
+; symbols on some Scheme systems. In Gambit, symbols are case
+; sensitive: (eq? 'A 'a) is #f and (eq? 'Aa (string->symbol "Aa")) is
+; #t. On some systems, symbols are case-insensitive and just the
+; opposite is true. Therefore, we introduce a notation '"ASymbol" (a
+; quoted string) that stands for a case-_sensitive_ ASymbol -- on any
+; R5RS Scheme system. This notation is valid only within the body of
+; run-test.
+; The notation is implemented by scanning the run-test's
+; body and replacing every occurrence of (quote "str") with the result
+; of (string->symbol "str"). We can do such a replacement at macro-expand
+; time (rather than at run time).
+
+; Here's the previous version of run-test, implemented as a low-level
+; macro.
+; (define-macro run-test
+; (lambda body
+; (define (re-write body)
+; (cond
+; ((vector? body)
+; (list->vector (re-write (vector->list body))))
+; ((not (pair? body)) body)
+; ((and (eq? 'quote (car body)) (pair? (cdr body))
+; (string? (cadr body)))
+; (string->symbol (cadr body)))
+; (else (cons (re-write (car body)) (re-write (cdr body))))))
+; (cons 'begin (re-write body))))
+;
+; For portability, it is re-written as syntax-rules. The syntax-rules
+; version is less powerful: for example, it can't handle
+; (case x (('"Foo") (do-on-Foo))) whereas the low-level macro
+; could correctly place a case-sensitive symbol at the right place.
+; We also do not scan vectors (because we don't use them here).
+; Twice-deep quasiquotes aren't handled either.
+; Still, the syntax-rules version satisfies our immediate needs.
+; Incidentally, I originally didn't believe that the macro below
+; was at all possible.
+;
+; The macro is written in a continuation-passing style. A continuation
+; typically has the following structure: (k-head ! . args)
+; When the continuation is invoked, we expand into
+; (k-head <computed-result> . arg). That is, the dedicated symbol !
+; is the placeholder for the result.
+;
+; It seems that the most modular way to write the run-test macro would
+; be the following
+;
+; (define-syntax run-test
+; (syntax-rules ()
+; ((run-test . ?body)
+; (letrec-syntax
+; ((scan-exp ; (scan-exp body k)
+; (syntax-rules (quote quasiquote !)
+; ((scan-exp (quote (hd . tl)) k)
+; (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+; ((scan-exp (quote x) (k-head ! . args))
+; (k-head
+; (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+; . args))
+; ((scan-exp (hd . tl) k)
+; (scan-exp hd (do-tl ! scan-exp tl k)))
+; ((scan-exp x (k-head ! . args))
+; (k-head x . args))))
+; (do-tl
+; (syntax-rules (!)
+; ((do-tl processed-hd fn () (k-head ! . args))
+; (k-head (processed-hd) . args))
+; ((do-tl processed-hd fn old-tl k)
+; (fn old-tl (do-cons ! processed-hd k)))))
+; ...
+; (do-finish
+; (syntax-rules ()
+; ((do-finish (new-body)) new-body)
+; ((do-finish new-body) (begin . new-body))))
+; ...
+; (scan-exp ?body (do-finish !))
+; ))))
+;
+; Alas, that doesn't work on all systems. We hit yet another dark
+; corner of the R5RS macros. The reason is that run-test is used in
+; the code below to introduce definitions. For example:
+; (run-test
+; (define (ssax:warn port msg . other-msg)
+; (apply cerr (cons* nl "Warning: " msg other-msg)))
+; )
+; This code expands to
+; (begin
+; (define (ssax:warn port msg . other-msg) ...))
+; so the definition gets spliced in into the top level. Right?
+; Well, On Petite Chez Scheme it is so. However, many other systems
+; don't like this approach. The reason is that the invocation of
+; (run-test (define (ssax:warn port msg . other-msg) ...))
+; first expands into
+; (letrec-syntax (...)
+; (scan-exp ((define (ssax:warn port msg . other-msg) ...)) ...))
+; because of the presence of (letrec-syntax ...), the begin form that
+; is generated eventually is no longer at the top level! The begin
+; form in Scheme is an overloading of two distinct forms: top-level
+; begin and the other begin. The forms have different rules: for example,
+; (begin (define x 1)) is OK for a top-level begin but not OK for
+; the other begin. Some Scheme systems see the that the macro
+; (run-test ...) expands into (letrec-syntax ...) and decide right there
+; that any further (begin ...) forms are NOT top-level begin forms.
+; The only way out is to make sure all our macros are top-level.
+; The best approach <sigh> seems to be to make run-test one huge
+; top-level macro.
+
+
+(define-syntax run-test
+ (syntax-rules (define)
+ ((run-test "scan-exp" (define vars body))
+ (define vars (run-test "scan-exp" body)))
+ ((run-test "scan-exp" ?body)
+ (letrec-syntax
+ ((scan-exp ; (scan-exp body k)
+ (syntax-rules (quote quasiquote !)
+ ((scan-exp '() (k-head ! . args))
+ (k-head '() . args))
+ ((scan-exp (quote (hd . tl)) k)
+ (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+ ((scan-exp (quasiquote (hd . tl)) k)
+ (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+ ((scan-exp (quote x) (k-head ! . args))
+ (k-head
+ (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+ . args))
+ ((scan-exp (hd . tl) k)
+ (scan-exp hd (do-tl ! scan-exp tl k)))
+ ((scan-exp x (k-head ! . args))
+ (k-head x . args))))
+ (do-tl
+ (syntax-rules (!)
+ ((do-tl processed-hd fn () (k-head ! . args))
+ (k-head (processed-hd) . args))
+ ((do-tl processed-hd fn old-tl k)
+ (fn old-tl (do-cons ! processed-hd k)))))
+ (do-cons
+ (syntax-rules (!)
+ ((do-cons processed-tl processed-hd (k-head ! . args))
+ (k-head (processed-hd . processed-tl) . args))))
+ (do-wrap
+ (syntax-rules (!)
+ ((do-wrap val fn (k-head ! . args))
+ (k-head (fn val) . args))))
+ (do-finish
+ (syntax-rules ()
+ ((do-finish new-body) new-body)))
+
+ (scan-lit-lst ; scan literal list
+ (syntax-rules (quote unquote unquote-splicing !)
+ ((scan-lit-lst '() (k-head ! . args))
+ (k-head '() . args))
+ ((scan-lit-lst (quote (hd . tl)) k)
+ (do-tl quote scan-lit-lst ((hd . tl)) k))
+ ((scan-lit-lst (unquote x) k)
+ (scan-exp x (do-wrap ! unquote k)))
+ ((scan-lit-lst (unquote-splicing x) k)
+ (scan-exp x (do-wrap ! unquote-splicing k)))
+ ((scan-lit-lst (quote x) (k-head ! . args))
+ (k-head
+ ,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
+ . args))
+ ((scan-lit-lst (hd . tl) k)
+ (scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
+ ((scan-lit-lst x (k-head ! . args))
+ (k-head x . args))))
+ )
+ (scan-exp ?body (do-finish !))))
+ ((run-test body ...)
+ (begin
+ (run-test "scan-exp" body) ...))
+))
+
+;========================================================================
+; Data Types
+
+; TAG-KIND
+; a symbol 'START, 'END, 'PI, 'DECL, 'COMMENT, 'CDSECT
+; or 'ENTITY-REF that identifies a markup token
+
+; UNRES-NAME
+; a name (called GI in the XML Recommendation) as given in an xml
+; document for a markup token: start-tag, PI target, attribute name.
+; If a GI is an NCName, UNRES-NAME is this NCName converted into
+; a Scheme symbol. If a GI is a QName, UNRES-NAME is a pair of
+; symbols: (PREFIX . LOCALPART)
+
+; RES-NAME
+; An expanded name, a resolved version of an UNRES-NAME.
+; For an element or an attribute name with a non-empty namespace URI,
+; RES-NAME is a pair of symbols, (URI-SYMB . LOCALPART).
+; Otherwise, it's a single symbol.
+
+; ELEM-CONTENT-MODEL
+; A symbol:
+; ANY - anything goes, expect an END tag.
+; EMPTY-TAG - no content, and no END-tag is coming
+; EMPTY - no content, expect the END-tag as the next token
+; PCDATA - expect character data only, and no children elements
+; MIXED
+; ELEM-CONTENT
+
+; URI-SYMB
+; A symbol representing a namespace URI -- or other symbol chosen
+; by the user to represent URI. In the former case,
+; URI-SYMB is created by %-quoting of bad URI characters and
+; converting the resulting string into a symbol.
+
+; NAMESPACES
+; A list representing namespaces in effect. An element of the list
+; has one of the following forms:
+; (PREFIX URI-SYMB . URI-SYMB) or
+; (PREFIX USER-PREFIX . URI-SYMB)
+; USER-PREFIX is a symbol chosen by the user
+; to represent the URI.
+; (#f USER-PREFIX . URI-SYMB)
+; Specification of the user-chosen prefix and a URI-SYMBOL.
+; (*DEFAULT* USER-PREFIX . URI-SYMB)
+; Declaration of the default namespace
+; (*DEFAULT* #f . #f)
+; Un-declaration of the default namespace. This notation
+; represents overriding of the previous declaration
+; A NAMESPACES list may contain several elements for the same PREFIX.
+; The one closest to the beginning of the list takes effect.
+
+; ATTLIST
+; An ordered collection of (NAME . VALUE) pairs, where NAME is
+; a RES-NAME or an UNRES-NAME. The collection is an ADT
+
+; STR-HANDLER
+; A procedure of three arguments: STRING1 STRING2 SEED
+; returning a new SEED
+; The procedure is supposed to handle a chunk of character data
+; STRING1 followed by a chunk of character data STRING2.
+; STRING2 is a short string, often "\n" and even ""
+
+; ENTITIES
+; An assoc list of pairs:
+; (named-entity-name . named-entity-body)
+; where named-entity-name is a symbol under which the entity was
+; declared, named-entity-body is either a string, or
+; (for an external entity) a thunk that will return an
+; input port (from which the entity can be read).
+; named-entity-body may also be #f. This is an indication that a
+; named-entity-name is currently being expanded. A reference to
+; this named-entity-name will be an error: violation of the
+; WFC nonrecursion.
+
+; XML-TOKEN -- a record
+
+; In Gambit, you can use the following declaration:
+; (define-structure xml-token kind head)
+; The following declaration is "standard" as it follows SRFI-9:
+;;(define-record-type xml-token (make-xml-token kind head) xml-token?
+;; (kind xml-token-kind)
+;; (head xml-token-head) )
+; No field mutators are declared as SSAX is a pure functional parser
+;
+; But to make the code more portable, we define xml-token simply as
+; a pair. It suffices for us. Furthermore, xml-token-kind and xml-token-head
+; can be defined as simple procedures. However, they are declared as
+; macros below for efficiency.
+
+(define (make-xml-token kind head) (cons kind head))
+(define xml-token? pair?)
+(define-syntax xml-token-kind
+ (syntax-rules () ((xml-token-kind token) (car token))))
+(define-syntax xml-token-head
+ (syntax-rules () ((xml-token-head token) (cdr token))))
+
+; (define-macro xml-token-kind (lambda (token) `(car ,token)))
+; (define-macro xml-token-head (lambda (token) `(cdr ,token)))
+
+; This record represents a markup, which is, according to the XML
+; Recommendation, "takes the form of start-tags, end-tags, empty-element tags,
+; entity references, character references, comments, CDATA section delimiters,
+; document type declarations, and processing instructions."
+;
+; kind -- a TAG-KIND
+; head -- an UNRES-NAME. For xml-tokens of kinds 'COMMENT and
+; 'CDSECT, the head is #f
+;
+; For example,
+; <P> => kind='START, head='P
+; </P> => kind='END, head='P
+; <BR/> => kind='EMPTY-EL, head='BR
+; <!DOCTYPE OMF ...> => kind='DECL, head='DOCTYPE
+; <?xml version="1.0"?> => kind='PI, head='xml
+; &my-ent; => kind = 'ENTITY-REF, head='my-ent
+;
+; Character references are not represented by xml-tokens as these references
+; are transparently resolved into the corresponding characters.
+;
+
+
+
+; XML-DECL -- a record
+
+; The following is Gambit-specific, see below for a portable declaration
+;(define-structure xml-decl elems entities notations)
+
+; The record represents a datatype of an XML document: the list of
+; declared elements and their attributes, declared notations, list of
+; replacement strings or loading procedures for parsed general
+; entities, etc. Normally an xml-decl record is created from a DTD or
+; an XML Schema, although it can be created and filled in in many other
+; ways (e.g., loaded from a file).
+;
+; elems: an (assoc) list of decl-elem or #f. The latter instructs
+; the parser to do no validation of elements and attributes.
+;
+; decl-elem: declaration of one element:
+; (elem-name elem-content decl-attrs)
+; elem-name is an UNRES-NAME for the element.
+; elem-content is an ELEM-CONTENT-MODEL.
+; decl-attrs is an ATTLIST, of (ATTR-NAME . VALUE) associations
+; !!!This element can declare a user procedure to handle parsing of an
+; element (e.g., to do a custom validation, or to build a hash of
+; IDs as they're encountered).
+;
+; decl-attr: an element of an ATTLIST, declaration of one attribute
+; (attr-name content-type use-type default-value)
+; attr-name is an UNRES-NAME for the declared attribute
+; content-type is a symbol: CDATA, NMTOKEN, NMTOKENS, ...
+; or a list of strings for the enumerated type.
+; use-type is a symbol: REQUIRED, IMPLIED, FIXED
+; default-value is a string for the default value, or #f if not given.
+;
+;
+
+; see a function make-empty-xml-decl to make a XML declaration entry
+; suitable for a non-validating parsing.
+
+
+;-------------------------
+; Utilities
+
+; ssax:warn PORT MESSAGE SPECIALISING-MSG*
+; to notify the user about warnings that are NOT errors but still
+; may alert the user.
+; Result is unspecified.
+; We need to define the function to allow the self-tests to run.
+; Normally the definition of ssax:warn is to be provided by the user.
+(run-test
+ (define (ssax:warn port msg . other-msg)
+ (apply cerr (cons* nl "Warning: " msg other-msg)))
+)
+
+
+; parser-error PORT MESSAGE SPECIALISING-MSG*
+; to let the user know of a syntax error or a violation of a
+; well-formedness or validation constraint.
+; Result is unspecified.
+; We need to define the function to allow the self-tests to run.
+; Normally the definition of parser-error is to be provided by the user.
+(run-test
+ (define (parser-error port msg . specializing-msgs)
+ (apply error (cons msg specializing-msgs)))
+)
+
+; The following is a function that is often used in validation tests,
+; to make sure that the computed result matches the expected one.
+; This function is a standard equal? predicate with one exception.
+; On Scheme systems where (string->symbol "A") and a symbol A
+; are the same, equal_? is precisely equal?
+; On other Scheme systems, we compare symbols disregarding their case.
+; Since this function is used only in tests, we don't have to
+; strive to make it efficient.
+(run-test
+ (define (equal_? e1 e2)
+ (if (eq? 'A (string->symbol "A")) (equal? e1 e2)
+ (cond
+ ((symbol? e1)
+ (and (symbol? e2)
+ (string-ci=? (symbol->string e1) (symbol->string e2))))
+ ((pair? e1)
+ (and (pair? e2)
+ (equal_? (car e1) (car e2)) (equal_? (cdr e1) (cdr e2))))
+ ((vector? e1)
+ (and (vector? e2) (equal_? (vector->list e1) (vector->list e2))))
+ (else
+ (equal? e1 e2)))))
+)
+
+; The following function, which is often used in validation tests,
+; lets us conveniently enter newline, CR and tab characters in a character
+; string.
+; unesc-string: ESC-STRING -> STRING
+; where ESC-STRING is a character string that may contain
+; %n -- for #\newline
+; %r -- for #\return
+; %t -- for #\tab
+; %% -- for #\%
+;
+; The result of unesc-string is a character string with all %-combinations
+; above replaced with their character equivalents
+
+(run-test
+ (define (unesc-string str)
+ (call-with-input-string str
+ (lambda (port)
+ (let loop ((frags '()))
+ (let* ((token (next-token '() '(#\% *eof*) "unesc-string" port))
+ (cterm (read-char port))
+ (frags (cons token frags)))
+ (if (eof-object? cterm) (string-concatenate-reverse/shared frags)
+ (let ((cchar (read-char port))) ; char after #\%
+ (if (eof-object? cchar)
+ (error "unexpected EOF after reading % in unesc-string:" str)
+ (loop
+ (cons
+ (case cchar
+ ((#\n) (string #\newline))
+ ((#\r) (string char-return))
+ ((#\t) (string char-tab))
+ ((#\%) "%")
+ (else (error "bad %-char in unesc-string:" cchar)))
+ frags))))))))))
+)
+
+
+; Test if a string is made of only whitespace
+; An empty string is considered made of whitespace as well
+(define (string-whitespace? str)
+ (let ((len (string-length str)))
+ (cond
+ ((zero? len) #t)
+ ((= 1 len) (char-whitespace? (string-ref str 0)))
+ ((= 2 len) (and (char-whitespace? (string-ref str 0))
+ (char-whitespace? (string-ref str 1))))
+ (else
+ (let loop ((i 0))
+ (or (>= i len)
+ (and (char-whitespace? (string-ref str i))
+ (loop (inc i)))))))))
+
+; Find val in alist
+; Return (values found-el remaining-alist) or
+; (values #f alist)
+
+(define (assq-values val alist)
+ (let loop ((alist alist) (scanned '()))
+ (cond
+ ((null? alist) (values #f scanned))
+ ((equal? val (caar alist))
+ (values (car alist) (append scanned (cdr alist))))
+ (else
+ (loop (cdr alist) (cons (car alist) scanned))))))
+
+; From SRFI-1
+(define (fold-right kons knil lis1)
+ (let recur ((lis lis1))
+ (if (null? lis) knil
+ (let ((head (car lis)))
+ (kons head (recur (cdr lis)))))))
+
+; Left fold combinator for a single list
+(define (fold kons knil lis1)
+ (let lp ((lis lis1) (ans knil))
+ (if (null? lis) ans
+ (lp (cdr lis) (kons (car lis) ans)))))
+
+
+
+;========================================================================
+; Lower-level parsers and scanners
+;
+; They deal with primitive lexical units (Names, whitespaces, tags)
+; and with pieces of more generic productions. Most of these parsers
+; must be called in appropriate context. For example, ssax:complete-start-tag
+; must be called only when the start-tag has been detected and its GI
+; has been read.
+
+;------------------------------------------------------------------------
+; Low-level parsing code
+
+; Skip the S (whitespace) production as defined by
+; [3] S ::= (#x20 | #x9 | #xD | #xA)
+; The procedure returns the first not-whitespace character it
+; encounters while scanning the PORT. This character is left
+; on the input stream.
+
+(define ssax:S-chars (map ascii->char '(32 10 9 13)))
+
+(define (ssax:skip-S port)
+ (skip-while ssax:S-chars port))
+
+
+; Read a Name lexem and return it as string
+; [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':'
+; | CombiningChar | Extender
+; [5] Name ::= (Letter | '_' | ':') (NameChar)*
+;
+; This code supports the XML Namespace Recommendation REC-xml-names,
+; which modifies the above productions as follows:
+;
+; [4] NCNameChar ::= Letter | Digit | '.' | '-' | '_'
+; | CombiningChar | Extender
+; [5] NCName ::= (Letter | '_') (NCNameChar)*
+; As the Rec-xml-names says,
+; "An XML document conforms to this specification if all other tokens
+; [other than element types and attribute names] in the document which
+; are required, for XML conformance, to match the XML production for
+; Name, match this specification's production for NCName."
+; Element types and attribute names must match the production QName,
+; defined below.
+
+; Check to see if a-char may start a NCName
+(define (ssax:ncname-starting-char? a-char)
+ (and (char? a-char)
+ (or
+ (char-alphabetic? a-char)
+ (char=? #\_ a-char))))
+
+
+; Read a NCName starting from the current position in the PORT and
+; return it as a symbol.
+(define (ssax:read-NCName port)
+ (let ((first-char (peek-char port)))
+ (or (ssax:ncname-starting-char? first-char)
+ (parser-error port "XMLNS [4] for '" first-char "'")))
+ (string->symbol
+ (next-token-of
+ (lambda (c)
+ (cond
+ ((eof-object? c) #f)
+ ((char-alphabetic? c) c)
+ ((string-index "0123456789.-_" c) c)
+ (else #f)))
+ port)))
+
+; Read a (namespace-) Qualified Name, QName, from the current
+; position in the PORT.
+; From REC-xml-names:
+; [6] QName ::= (Prefix ':')? LocalPart
+; [7] Prefix ::= NCName
+; [8] LocalPart ::= NCName
+; Return: an UNRES-NAME
+(define (ssax:read-QName port)
+ (let ((prefix-or-localpart (ssax:read-NCName port)))
+ (case (peek-char port)
+ ((#\:) ; prefix was given after all
+ (read-char port) ; consume the colon
+ (cons prefix-or-localpart (ssax:read-NCName port)))
+ (else prefix-or-localpart) ; Prefix was omitted
+ )))
+
+; The prefix of the pre-defined XML namespace
+(define ssax:Prefix-XML (string->symbol "xml"))
+
+(run-test
+ (assert (eq? '_
+ (call-with-input-string "_" ssax:read-NCName)))
+ (assert (eq? '_
+ (call-with-input-string "_" ssax:read-QName)))
+ (assert (eq? (string->symbol "_abc_")
+ (call-with-input-string "_abc_;" ssax:read-NCName)))
+ (assert (eq? (string->symbol "_abc_")
+ (call-with-input-string "_abc_;" ssax:read-QName)))
+ (assert (eq? (string->symbol "_a.b")
+ (call-with-input-string "_a.b " ssax:read-QName)))
+ (assert (equal? (cons (string->symbol "_a.b") (string->symbol "d.1-ef-"))
+ (call-with-input-string "_a.b:d.1-ef-;" ssax:read-QName)))
+ (assert (equal? (cons (string->symbol "a") (string->symbol "b"))
+ (call-with-input-string "a:b:c" ssax:read-QName)))
+
+ (assert (failed? (call-with-input-string ":abc" ssax:read-NCName)))
+ (assert (failed? (call-with-input-string "1:bc" ssax:read-NCName)))
+)
+
+; Compare one RES-NAME or an UNRES-NAME with the other.
+; Return a symbol '<, '>, or '= depending on the result of
+; the comparison.
+; Names without PREFIX are always smaller than those with the PREFIX.
+(define name-compare
+ (letrec ((symbol-compare
+ (lambda (symb1 symb2)
+ (cond
+ ((eq? symb1 symb2) '=)
+ ((string<? (symbol->string symb1) (symbol->string symb2))
+ '<)
+ (else '>)))))
+ (lambda (name1 name2)
+ (cond
+ ((symbol? name1) (if (symbol? name2) (symbol-compare name1 name2)
+ '<))
+ ((symbol? name2) '>)
+ ((eq? name2 ssax:largest-unres-name) '<)
+ ((eq? name1 ssax:largest-unres-name) '>)
+ ((eq? (car name1) (car name2)) ; prefixes the same
+ (symbol-compare (cdr name1) (cdr name2)))
+ (else (symbol-compare (car name1) (car name2)))))))
+
+; An UNRES-NAME that is postulated to be larger than anything that can occur in
+; a well-formed XML document.
+; name-compare enforces this postulate.
+(define ssax:largest-unres-name (cons
+ (string->symbol "#LARGEST-SYMBOL")
+ (string->symbol "#LARGEST-SYMBOL")))
+
+(run-test
+ (assert (eq? '= (name-compare 'ABC 'ABC)))
+ (assert (eq? '< (name-compare 'ABC 'ABCD)))
+ (assert (eq? '> (name-compare 'XB 'ABCD)))
+ (assert (eq? '> (name-compare '(HTML . PRE) 'PRE)))
+ (assert (eq? '< (name-compare 'HTML '(HTML . PRE))))
+ (assert (eq? '= (name-compare '(HTML . PRE) '(HTML . PRE))))
+ (assert (eq? '< (name-compare '(HTML . PRE) '(XML . PRE))))
+ (assert (eq? '> (name-compare '(HTML . PRE) '(HTML . P))))
+ (assert (eq? '< (name-compare '(HTML . PRE) ssax:largest-unres-name)))
+ (assert (eq? '< (name-compare '(ZZZZ . ZZZ) ssax:largest-unres-name)))
+ (assert (eq? '> (name-compare ssax:largest-unres-name '(ZZZZ . ZZZ) )))
+)
+
+
+
+; procedure: ssax:read-markup-token PORT
+; This procedure starts parsing of a markup token. The current position
+; in the stream must be #\<. This procedure scans enough of the input stream
+; to figure out what kind of a markup token it is seeing. The procedure returns
+; an xml-token structure describing the token. Note, generally reading
+; of the current markup is not finished! In particular, no attributes of
+; the start-tag token are scanned.
+;
+; Here's a detailed break out of the return values and the position in the PORT
+; when that particular value is returned:
+; PI-token: only PI-target is read.
+; To finish the Processing Instruction and disregard it,
+; call ssax:skip-pi. ssax:read-attributes may be useful
+; as well (for PIs whose content is attribute-value
+; pairs)
+; END-token: The end tag is read completely; the current position
+; is right after the terminating #\> character.
+; COMMENT is read and skipped completely. The current position
+; is right after "-->" that terminates the comment.
+; CDSECT The current position is right after "<!CDATA["
+; Use ssax:read-cdata-body to read the rest.
+; DECL We have read the keyword (the one that follows "<!")
+; identifying this declaration markup. The current
+; position is after the keyword (usually a
+; whitespace character)
+;
+; START-token We have read the keyword (GI) of this start tag.
+; No attributes are scanned yet. We don't know if this
+; tag has an empty content either.
+; Use ssax:complete-start-tag to finish parsing of
+; the token.
+
+(define ssax:read-markup-token ; procedure ssax:read-markup-token port
+ (let ()
+ ; we have read "<!-". Skip through the rest of the comment
+ ; Return the 'COMMENT token as an indication we saw a comment
+ ; and skipped it.
+ (define (skip-comment port)
+ (assert-curr-char '(#\-) "XML [15], second dash" port)
+ (if (not (find-string-from-port? "-->" port))
+ (parser-error port "XML [15], no -->"))
+ (make-xml-token 'COMMENT #f))
+
+ ; we have read "<![" that must begin a CDATA section
+ (define (read-cdata port)
+ (assert (string=? "CDATA[" (read-string 6 port)))
+ (make-xml-token 'CDSECT #f))
+
+ (lambda (port)
+ (assert-curr-char '(#\<) "start of the token" port)
+ (case (peek-char port)
+ ((#\/) (read-char port)
+ (begin0 (make-xml-token 'END (ssax:read-QName port))
+ (ssax:skip-S port)
+ (assert-curr-char '(#\>) "XML [42]" port)))
+ ((#\?) (read-char port) (make-xml-token 'PI (ssax:read-NCName port)))
+ ((#\!)
+ (case (peek-next-char port)
+ ((#\-) (read-char port) (skip-comment port))
+ ((#\[) (read-char port) (read-cdata port))
+ (else (make-xml-token 'DECL (ssax:read-NCName port)))))
+ (else (make-xml-token 'START (ssax:read-QName port)))))
+))
+
+
+; The current position is inside a PI. Skip till the rest of the PI
+(define (ssax:skip-pi port)
+ (if (not (find-string-from-port? "?>" port))
+ (parser-error port "Failed to find ?> terminating the PI")))
+
+
+; The current position is right after reading the PITarget. We read the
+; body of PI and return is as a string. The port will point to the
+; character right after '?>' combination that terminates PI.
+; [16] PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'
+
+(define (ssax:read-pi-body-as-string port)
+ (ssax:skip-S port) ; skip WS after the PI target name
+ (string-concatenate/shared
+ (let loop ()
+ (let ((pi-fragment
+ (next-token '() '(#\?) "reading PI content" port)))
+ (if (eqv? #\> (peek-next-char port))
+ (begin
+ (read-char port)
+ (cons pi-fragment '()))
+ (cons* pi-fragment "?" (loop)))))))
+
+(run-test
+ (assert (equal? "p1 content "
+ (call-with-input-string "<?pi1 p1 content ?>"
+ (lambda (port)
+ (ssax:read-markup-token port)
+ (ssax:read-pi-body-as-string port)))))
+ (assert (equal? "pi2? content? ?"
+ (call-with-input-string "<?pi2 pi2? content? ??>"
+ (lambda (port)
+ (ssax:read-markup-token port)
+ (ssax:read-pi-body-as-string port)))))
+)
+
+;(define (ssax:read-pi-body-as-name-values port)
+
+; The current pos in the port is inside an internal DTD subset
+; (e.g., after reading #\[ that begins an internal DTD subset)
+; Skip until the "]>" combination that terminates this DTD
+(define (ssax:skip-internal-dtd port)
+ (if (not (find-string-from-port? "]>" port))
+ (parser-error port
+ "Failed to find ]> terminating the internal DTD subset")))
+
+
+; procedure+: ssax:read-cdata-body PORT STR-HANDLER SEED
+;
+; This procedure must be called after we have read a string "<![CDATA["
+; that begins a CDATA section. The current position must be the first
+; position of the CDATA body. This function reads _lines_ of the CDATA
+; body and passes them to a STR-HANDLER, a character data consumer.
+;
+; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
+; The first STRING1 argument to STR-HANDLER never contains a newline.
+; The second STRING2 argument often will. On the first invocation of
+; the STR-HANDLER, the seed is the one passed to ssax:read-cdata-body
+; as the third argument. The result of this first invocation will be
+; passed as the seed argument to the second invocation of the line
+; consumer, and so on. The result of the last invocation of the
+; STR-HANDLER is returned by the ssax:read-cdata-body. Note a
+; similarity to the fundamental 'fold' iterator.
+;
+; Within a CDATA section all characters are taken at their face value,
+; with only three exceptions:
+; CR, LF, and CRLF are treated as line delimiters, and passed
+; as a single #\newline to the STR-HANDLER
+; "]]>" combination is the end of the CDATA section.
+; > is treated as an embedded #\> character
+; Note, < and & are not specially recognized (and are not expanded)!
+
+(define ssax:read-cdata-body
+ (let ((cdata-delimiters (list char-return #\newline #\] #\&)))
+
+ (lambda (port str-handler seed)
+ (let loop ((seed seed))
+ (let ((fragment (next-token '() cdata-delimiters
+ "reading CDATA" port)))
+ ; that is, we're reading the char after the 'fragment'
+ (case (read-char port)
+ ((#\newline) (loop (str-handler fragment nl seed)))
+ ((#\])
+ (if (not (eqv? (peek-char port) #\]))
+ (loop (str-handler fragment "]" seed))
+ (let check-after-second-braket
+ ((seed (if (string-null? fragment) seed
+ (str-handler fragment "" seed))))
+ (case (peek-next-char port) ; after the second bracket
+ ((#\>) (read-char port) seed) ; we have read "]]>"
+ ((#\]) (check-after-second-braket
+ (str-handler "]" "" seed)))
+ (else (loop (str-handler "]]" "" seed)))))))
+ ((#\&) ; Note that #\& within CDATA may stand for itself
+ (let ((ent-ref ; it does not have to start an entity ref
+ (next-token-of (lambda (c)
+ (and (not (eof-object? c)) (char-alphabetic? c) c)) port)))
+ (cond ; ">" is to be replaced with #\>
+ ((and (string=? "gt" ent-ref) (eqv? (peek-char port) #\;))
+ (read-char port)
+ (loop (str-handler fragment ">" seed)))
+ (else
+ (loop
+ (str-handler ent-ref ""
+ (str-handler fragment "&" seed)))))))
+ (else ; Must be CR: if the next char is #\newline, skip it
+ (if (eqv? (peek-char port) #\newline) (read-char port))
+ (loop (str-handler fragment nl seed)))
+ ))))))
+
+; a few lines of validation code
+(run-test (letrec
+ ((consumer (lambda (fragment foll-fragment seed)
+ (cons* (if (equal? foll-fragment (string #\newline))
+ " NL" foll-fragment) fragment seed)))
+ (test (lambda (str expected-result)
+ (newline) (display "body: ") (write str)
+ (newline) (display "Result: ")
+ (let ((result
+ (reverse
+ (call-with-input-string (unesc-string str)
+ (lambda (port) (ssax:read-cdata-body port consumer '()))
+ ))))
+ (write result)
+ (assert (equal? result expected-result)))))
+ )
+ (test "]]>" '())
+ (test "abcd]]>" '("abcd" ""))
+ (test "abcd]]]>" '("abcd" "" "]" ""))
+ (test "abcd]]]]>" '("abcd" "" "]" "" "]" ""))
+ (test "abcd]]]]]>" '("abcd" "" "]" "" "]" "" "]" ""))
+ (test "abcd]]]a]]>" '("abcd" "" "]" "" "]]" "" "a" ""))
+ (test "abc%r%ndef%n]]>" '("abc" " NL" "def" " NL"))
+ (test "%r%n%r%n]]>" '("" " NL" "" " NL"))
+ (test "%r%n%r%na]]>" '("" " NL" "" " NL" "a" ""))
+ (test "%r%r%r%na]]>" '("" " NL" "" " NL" "" " NL" "a" ""))
+ (test "abc&!!!]]>" '("abc" "&" "" "" "!!!" ""))
+ (test "abc]]>>&]]]>and]]>"
+ '("abc" "" "]]" "" "" ">" "" "&" "gt" "" "" "&" "amp" "" ";" "" "]" ""
+ "]]" "" "" ">" "and" ""))
+))
+
+
+; procedure+: ssax:read-char-ref PORT
+;
+; [66] CharRef ::= '&#' [0-9]+ ';'
+; | '&#x' [0-9a-fA-F]+ ';'
+;
+; This procedure must be called after we we have read "&#"
+; that introduces a char reference.
+; The procedure reads this reference and returns the corresponding char
+; The current position in PORT will be after ";" that terminates
+; the char reference
+; Faults detected:
+; WFC: XML-Spec.html#wf-Legalchar
+;
+; According to Section "4.1 Character and Entity References"
+; of the XML Recommendation:
+; "[Definition: A character reference refers to a specific character
+; in the ISO/IEC 10646 character set, for example one not directly
+; accessible from available input devices.]"
+; Therefore, we use a ucscode->string function to convert a character
+; code into the character -- *regardless* of the current character
+; encoding of the input stream.
+
+(define (ssax:read-char-ref port)
+ (let* ((base
+ (cond ((eqv? (peek-char port) #\x) (read-char port) 16)
+ (else 10)))
+ (name (next-token '() '(#\;) "XML [66]" port))
+ (char-code (string->number name base)))
+ (read-char port) ; read the terminating #\; char
+ (if (integer? char-code) (ucscode->string char-code)
+ (parser-error port "[wf-Legalchar] broken for '" name "'"))))
+
+
+; procedure+: ssax:handle-parsed-entity PORT NAME ENTITIES
+; CONTENT-HANDLER STR-HANDLER SEED
+;
+; Expand and handle a parsed-entity reference
+; port - a PORT
+; name - the name of the parsed entity to expand, a symbol
+; entities - see ENTITIES
+; content-handler -- procedure PORT ENTITIES SEED
+; that is supposed to return a SEED
+; str-handler - a STR-HANDLER. It is called if the entity in question
+; turns out to be a pre-declared entity
+;
+; The result is the one returned by CONTENT-HANDLER or STR-HANDLER
+; Faults detected:
+; WFC: XML-Spec.html#wf-entdeclared
+; WFC: XML-Spec.html#norecursion
+
+(define ssax:predefined-parsed-entities
+ `(
+ (,(string->symbol "amp") . "&")
+ (,(string->symbol "lt") . "<")
+ (,(string->symbol "gt") . ">")
+ (,(string->symbol "apos") . "'")
+ (,(string->symbol "quot") . "\"")))
+
+(define (ssax:handle-parsed-entity port name entities
+ content-handler str-handler seed)
+ (cond ; First we check the list of the declared entities
+ ((assq name entities) =>
+ (lambda (decl-entity)
+ (let ((ent-body (cdr decl-entity)) ; mark the list to prevent recursion
+ (new-entities (cons (cons name #f) entities)))
+ (cond
+ ((string? ent-body)
+ (call-with-input-string ent-body
+ (lambda (port) (content-handler port new-entities seed))))
+ ((procedure? ent-body)
+ (let ((port (ent-body)))
+ (begin0
+ (content-handler port new-entities seed)
+ (close-input-port port))))
+ (else
+ (parser-error port "[norecursion] broken for " name))))))
+ ((assq name ssax:predefined-parsed-entities)
+ => (lambda (decl-entity)
+ (str-handler (cdr decl-entity) "" seed)))
+ (else (parser-error port "[wf-entdeclared] broken for " name))))
+
+
+
+; The ATTLIST Abstract Data Type
+; Currently is implemented as an assoc list sorted in the ascending
+; order of NAMES.
+
+(define (make-empty-attlist) '())
+
+; Add a name-value pair to the existing attlist preserving the order
+; Return the new list, in the sorted ascending order.
+; Return #f if a pair with the same name already exists in the attlist
+
+(define (attlist-add attlist name-value)
+ (if (null? attlist) (cons name-value attlist)
+ (case (name-compare (car name-value) (caar attlist))
+ ((=) #f)
+ ((<) (cons name-value attlist))
+ (else (cons (car attlist) (attlist-add (cdr attlist) name-value)))
+ )))
+
+(define attlist-null? null?)
+
+; Given an non-null attlist, return a pair of values: the top and the rest
+(define (attlist-remove-top attlist)
+ (values (car attlist) (cdr attlist)))
+
+(define (attlist->alist attlist) attlist)
+(define attlist-fold fold)
+
+; procedure+: ssax:read-attributes PORT ENTITIES
+;
+; This procedure reads and parses a production Attribute*
+; [41] Attribute ::= Name Eq AttValue
+; [10] AttValue ::= '"' ([^<&"] | Reference)* '"'
+; | "'" ([^<&'] | Reference)* "'"
+; [25] Eq ::= S? '=' S?
+;
+;
+; The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as string)
+; pairs. The current character on the PORT is a non-whitespace character
+; that is not an ncname-starting character.
+;
+; Note the following rules to keep in mind when reading an 'AttValue'
+; "Before the value of an attribute is passed to the application
+; or checked for validity, the XML processor must normalize it as follows:
+; - a character reference is processed by appending the referenced
+; character to the attribute value
+; - an entity reference is processed by recursively processing the
+; replacement text of the entity [see ENTITIES]
+; [named entities amp lt gt quot apos are assumed pre-declared]
+; - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20
+; to the normalized value, except that only a single #x20 is appended for a
+; "#xD#xA" sequence that is part of an external parsed entity or the
+; literal entity value of an internal parsed entity
+; - other characters are processed by appending them to the normalized value "
+;
+;
+; Faults detected:
+; WFC: XML-Spec.html#CleanAttrVals
+; WFC: XML-Spec.html#uniqattspec
+
+(define ssax:read-attributes ; ssax:read-attributes port entities
+ (let ((value-delimeters (append ssax:S-chars '(#\< #\&))))
+ ; Read the AttValue from the PORT up to the delimiter
+ ; (which can be a single or double-quote character,
+ ; or even a symbol *eof*)
+ ; 'prev-fragments' is the list of string fragments, accumulated
+ ; so far, in reverse order.
+ ; Return the list of fragments with newly read fragments
+ ; prepended.
+ (define (read-attrib-value delimiter port entities prev-fragments)
+ (let* ((new-fragments
+ (cons (next-token '() (cons delimiter value-delimeters)
+ "XML [10]" port)
+ prev-fragments))
+ (cterm (read-char port)))
+ (cond
+ ((or (eof-object? cterm) (eqv? cterm delimiter))
+ new-fragments)
+ ((eqv? cterm char-return) ; treat a CR and CRLF as a LF
+ (if (eqv? (peek-char port) #\newline) (read-char port))
+ (read-attrib-value delimiter port entities
+ (cons " " new-fragments)))
+ ((memv cterm ssax:S-chars)
+ (read-attrib-value delimiter port entities
+ (cons " " new-fragments)))
+ ((eqv? cterm #\&)
+ (cond
+ ((eqv? (peek-char port) #\#)
+ (read-char port)
+ (read-attrib-value delimiter port entities
+ (cons (ssax:read-char-ref port) new-fragments)))
+ (else
+ (read-attrib-value delimiter port entities
+ (read-named-entity port entities new-fragments)))))
+ (else (parser-error port "[CleanAttrVals] broken")))))
+
+ ; we have read "&" that introduces a named entity reference.
+ ; read this reference and return the result of
+ ; normalizing of the corresponding string
+ ; (that is, read-attrib-value is applied to the replacement
+ ; text of the entity)
+ ; The current position will be after ";" that terminates
+ ; the entity reference
+ (define (read-named-entity port entities fragments)
+ (let ((name (ssax:read-NCName port)))
+ (assert-curr-char '(#\;) "XML [68]" port)
+ (ssax:handle-parsed-entity port name entities
+ (lambda (port entities fragments)
+ (read-attrib-value '*eof* port entities fragments))
+ (lambda (str1 str2 fragments)
+ (if (equal? "" str2) (cons str1 fragments)
+ (cons* str2 str1 fragments)))
+ fragments)))
+
+ (lambda (port entities)
+ (let loop ((attr-list (make-empty-attlist)))
+ (if (not (ssax:ncname-starting-char? (ssax:skip-S port))) attr-list
+ (let ((name (ssax:read-QName port)))
+ (ssax:skip-S port)
+ (assert-curr-char '(#\=) "XML [25]" port)
+ (ssax:skip-S port)
+ (let ((delimiter
+ (assert-curr-char '(#\' #\" ) "XML [10]" port)))
+ (loop
+ (or (attlist-add attr-list
+ (cons name
+ (string-concatenate-reverse/shared
+ (read-attrib-value delimiter port entities
+ '()))))
+ (parser-error port "[uniqattspec] broken for " name))))))))
+))
+
+; a few lines of validation code
+(run-test (letrec
+ ((test (lambda (str decl-entities expected-res)
+ (newline) (display "input: ") (write str)
+ (newline) (display "Result: ")
+ (let ((result
+ (call-with-input-string (unesc-string str)
+ (lambda (port)
+ (ssax:read-attributes port decl-entities)))))
+ (write result) (newline)
+ (assert (equal? result expected-res))))))
+ (test "" '() '())
+ (test "href='http://a%tb%r%n%r%n%nc'" '()
+ `((,(string->symbol "href") . "http://a b c")))
+ (test "href='http://a%tb%r%r%n%rc'" '()
+ `((,(string->symbol "href") . "http://a b c")))
+ (test "_1 ='12&' _2= \"%r%n%t12 3\">" '()
+ `((_1 . "12&") (_2 . ,(unesc-string " 12%n3"))))
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ '((ent . "<xx>"))
+ `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+ (,(string->symbol "Next") . "12<xx>34")))
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ '((ent . "<xx>"))
+ `((,(string->symbol "Abc") . ,(unesc-string "<&>%r"))
+ (,(string->symbol "Next") . "12<xx>34")))
+ (test "%tAbc='<&>
'%nNext='12&en;34' />"
+ `((en . ,(lambda () (open-input-string ""xx'"))))
+ `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+ (,(string->symbol "Next") . "12\"xx'34")))
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ '((ent . "<&ent1;T;>") (ent1 . "&"))
+ `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+ (,(string->symbol "Next") . "12<&T;>34")))
+ (assert (failed?
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ '((ent . "<&ent1;T;>") (ent1 . "&")) '())))
+ (assert (failed?
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ '((ent . "<&ent;T;>") (ent1 . "&")) '())))
+ (assert (failed?
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ '((ent . "<&ent1;T;>") (ent1 . "&ent;")) '())))
+ (test "html:href='http://a%tb%r%n%r%n%nc'" '()
+ `(((,(string->symbol "html") . ,(string->symbol "href"))
+ . "http://a b c")))
+ (test "html:href='ref1' html:src='ref2'" '()
+ `(((,(string->symbol "html") . ,(string->symbol "href"))
+ . "ref1")
+ ((,(string->symbol "html") . ,(string->symbol "src"))
+ . "ref2")))
+ (test "html:href='ref1' xml:html='ref2'" '()
+ `(((,(string->symbol "html") . ,(string->symbol "href"))
+ . "ref1")
+ ((,ssax:Prefix-XML . ,(string->symbol "html"))
+ . "ref2")))
+ (assert (failed? (test "html:href='ref1' html:href='ref2'" '() '())))
+ (assert (failed? (test "html:href='<' html:href='ref2'" '() '())))
+ (assert (failed? (test "html:href='ref1' html:href='&ref2;'" '() '())))
+))
+
+; ssax:resolve-name PORT UNRES-NAME NAMESPACES apply-default-ns?
+;
+; Convert an UNRES-NAME to a RES-NAME given the appropriate NAMESPACES
+; declarations.
+; the last parameter apply-default-ns? determines if the default
+; namespace applies (for instance, it does not for attribute names)
+;
+; Per REC-xml-names/#nsc-NSDeclared, "xml" prefix is considered pre-declared
+; and bound to the namespace name "http://www.w3.org/XML/1998/namespace";.
+;
+; This procedure tests for the namespace constraints:
+; http://www.w3.org/TR/REC-xml-names/#nsc-NSDeclared
+
+(define (ssax:resolve-name port unres-name namespaces apply-default-ns?)
+ (cond
+ ((pair? unres-name) ; it's a QNAME
+ (cons
+ (cond
+ ((assq (car unres-name) namespaces) => cadr)
+ ((eq? (car unres-name) ssax:Prefix-XML) ssax:Prefix-XML)
+ (else
+ (parser-error port "[nsc-NSDeclared] broken; prefix " (car unres-name))))
+ (cdr unres-name)))
+ (apply-default-ns? ; Do apply the default namespace, if any
+ (let ((default-ns (assq '*DEFAULT* namespaces)))
+ (if (and default-ns (cadr default-ns))
+ (cons (cadr default-ns) unres-name)
+ unres-name))) ; no default namespace declared
+ (else unres-name))) ; no prefix, don't apply the default-ns
+
+
+(run-test
+ (let* ((namespaces
+ '((HTML UHTML . URN-HTML)
+ (HTML UHTML-1 . URN-HTML)
+ (A UHTML . URN-HTML)))
+ (namespaces-def
+ (cons
+ '(*DEFAULT* DEF . URN-DEF) namespaces))
+ (namespaces-undef
+ (cons
+ '(*DEFAULT* #f . #f) namespaces-def))
+ (port (current-input-port)))
+
+ (assert (equal? 'ABC
+ (ssax:resolve-name port 'ABC namespaces #t)))
+ (assert (equal? '(DEF . ABC)
+ (ssax:resolve-name port 'ABC namespaces-def #t)))
+ (assert (equal? 'ABC
+ (ssax:resolve-name port 'ABC namespaces-def #f)))
+ (assert (equal? 'ABC
+ (ssax:resolve-name port 'ABC namespaces-undef #t)))
+ (assert (equal? '(UHTML . ABC)
+ (ssax:resolve-name port '(HTML . ABC) namespaces-def #t)))
+ (assert (equal? '(UHTML . ABC)
+ (ssax:resolve-name port '(HTML . ABC) namespaces-def #f)))
+ (assert (equal? `(,ssax:Prefix-XML . space)
+ (ssax:resolve-name port
+ `(,(string->symbol "xml") . space) namespaces-def #f)))
+ (assert (failed?
+ (ssax:resolve-name port '(XXX . ABC) namespaces-def #f)))
+))
+
+
+; procedure+: ssax:uri-string->symbol URI-STR
+; Convert a URI-STR to an appropriate symbol
+(define (ssax:uri-string->symbol uri-str)
+ (string->symbol uri-str))
+
+; procedure+: ssax:complete-start-tag TAG PORT ELEMS ENTITIES NAMESPACES
+;
+; This procedure is to complete parsing of a start-tag markup. The
+; procedure must be called after the start tag token has been
+; read. TAG is an UNRES-NAME. ELEMS is an instance of xml-decl::elems;
+; it can be #f to tell the function to do _no_ validation of elements
+; and their attributes.
+;
+; This procedure returns several values:
+; ELEM-GI: a RES-NAME.
+; ATTRIBUTES: element's attributes, an ATTLIST of (RES-NAME . STRING)
+; pairs. The list does NOT include xmlns attributes.
+; NAMESPACES: the input list of namespaces amended with namespace
+; (re-)declarations contained within the start-tag under parsing
+; ELEM-CONTENT-MODEL
+
+; On exit, the current position in PORT will be the first character after
+; #\> that terminates the start-tag markup.
+;
+; Faults detected:
+; VC: XML-Spec.html#enum
+; VC: XML-Spec.html#RequiredAttr
+; VC: XML-Spec.html#FixedAttr
+; VC: XML-Spec.html#ValueType
+; WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved)
+; VC: XML-Spec.html#elementvalid
+; WFC: REC-xml-names/#dt-NSName
+
+; Note, although XML Recommendation does not explicitly say it,
+; xmlns and xmlns: attributes don't have to be declared (although they
+; can be declared, to specify their default value)
+
+; Procedure: ssax:complete-start-tag tag-head port elems entities namespaces
+(define ssax:complete-start-tag
+
+ (let ((xmlns (string->symbol "xmlns"))
+ (largest-dummy-decl-attr (list ssax:largest-unres-name #f #f #f)))
+
+ ; Scan through the attlist and validate it, against decl-attrs
+ ; Return an assoc list with added fixed or implied attrs.
+ ; Note that both attlist and decl-attrs are ATTLISTs, and therefore,
+ ; sorted
+ (define (validate-attrs port attlist decl-attrs)
+
+ ; Check to see decl-attr is not of use type REQUIRED. Add
+ ; the association with the default value, if any declared
+ (define (add-default-decl decl-attr result)
+ (let*-values
+ (((attr-name content-type use-type default-value)
+ (apply values decl-attr)))
+ (and (eq? use-type 'REQUIRED)
+ (parser-error port "[RequiredAttr] broken for" attr-name))
+ (if default-value
+ (cons (cons attr-name default-value) result)
+ result)))
+
+ (let loop ((attlist attlist) (decl-attrs decl-attrs) (result '()))
+ (if (attlist-null? attlist)
+ (attlist-fold add-default-decl result decl-attrs)
+ (let*-values
+ (((attr attr-others)
+ (attlist-remove-top attlist))
+ ((decl-attr other-decls)
+ (if (attlist-null? decl-attrs)
+ (values largest-dummy-decl-attr decl-attrs)
+ (attlist-remove-top decl-attrs)))
+ )
+ (case (name-compare (car attr) (car decl-attr))
+ ((<)
+ (if (or (eq? xmlns (car attr))
+ (and (pair? (car attr)) (eq? xmlns (caar attr))))
+ (loop attr-others decl-attrs (cons attr result))
+ (parser-error port "[ValueType] broken for " attr)))
+ ((>)
+ (loop attlist other-decls
+ (add-default-decl decl-attr result)))
+ (else ; matched occurrence of an attr with its declaration
+ (let*-values
+ (((attr-name content-type use-type default-value)
+ (apply values decl-attr)))
+ ; Run some tests on the content of the attribute
+ (cond
+ ((eq? use-type 'FIXED)
+ (or (equal? (cdr attr) default-value)
+ (parser-error port "[FixedAttr] broken for " attr-name)))
+ ((eq? content-type 'CDATA) #t) ; everything goes
+ ((pair? content-type)
+ (or (member (cdr attr) content-type)
+ (parser-error port "[enum] broken for " attr-name "="
+ (cdr attr))))
+ (else
+ (ssax:warn port "declared content type " content-type
+ " not verified yet")))
+ (loop attr-others other-decls (cons attr result)))))
+ ))))
+
+
+ ; Add a new namespace declaration to namespaces.
+ ; First we convert the uri-str to a uri-symbol and search namespaces for
+ ; an association (_ user-prefix . uri-symbol).
+ ; If found, we return the argument namespaces with an association
+ ; (prefix user-prefix . uri-symbol) prepended.
+ ; Otherwise, we prepend (prefix uri-symbol . uri-symbol)
+ (define (add-ns port prefix uri-str namespaces)
+ (and (equal? "" uri-str)
+ (parser-error port "[dt-NSName] broken for " prefix))
+ (let ((uri-symbol (ssax:uri-string->symbol uri-str)))
+ (let loop ((nss namespaces))
+ (cond
+ ((null? nss)
+ (cons (cons* prefix uri-symbol uri-symbol) namespaces))
+ ((eq? uri-symbol (cddar nss))
+ (cons (cons* prefix (cadar nss) uri-symbol) namespaces))
+ (else (loop (cdr nss)))))))
+
+ ; partition attrs into proper attrs and new namespace declarations
+ ; return two values: proper attrs and the updated namespace declarations
+ (define (adjust-namespace-decl port attrs namespaces)
+ (let loop ((attrs attrs) (proper-attrs '()) (namespaces namespaces))
+ (cond
+ ((null? attrs) (values proper-attrs namespaces))
+ ((eq? xmlns (caar attrs)) ; re-decl of the default namespace
+ (loop (cdr attrs) proper-attrs
+ (if (equal? "" (cdar attrs)) ; un-decl of the default ns
+ (cons (cons* '*DEFAULT* #f #f) namespaces)
+ (add-ns port '*DEFAULT* (cdar attrs) namespaces))))
+ ((and (pair? (caar attrs)) (eq? xmlns (caaar attrs)))
+ (loop (cdr attrs) proper-attrs
+ (add-ns port (cdaar attrs) (cdar attrs) namespaces)))
+ (else
+ (loop (cdr attrs) (cons (car attrs) proper-attrs) namespaces)))))
+
+ ; The body of the function
+ (lambda (tag-head port elems entities namespaces)
+ (let*-values
+ (((attlist) (ssax:read-attributes port entities))
+ ((empty-el-tag?)
+ (begin
+ (ssax:skip-S port)
+ (and
+ (eqv? #\/
+ (assert-curr-char '(#\> #\/) "XML [40], XML [44], no '>'" port))
+ (assert-curr-char '(#\>) "XML [44], no '>'" port))))
+ ((elem-content decl-attrs) ; see xml-decl for their type
+ (if elems ; elements declared: validate!
+ (cond
+ ((assoc tag-head elems) =>
+ (lambda (decl-elem) ; of type xml-decl::decl-elem
+ (values
+ (if empty-el-tag? 'EMPTY-TAG (cadr decl-elem))
+ (caddr decl-elem))))
+ (else
+ (parser-error port "[elementvalid] broken, no decl for " tag-head)))
+ (values ; non-validating parsing
+ (if empty-el-tag? 'EMPTY-TAG 'ANY)
+ #f) ; no attributes declared
+ ))
+ ((merged-attrs) (if decl-attrs (validate-attrs port attlist decl-attrs)
+ (attlist->alist attlist)))
+ ((proper-attrs namespaces)
+ (adjust-namespace-decl port merged-attrs namespaces))
+ )
+ ;(cerr "proper attrs: " proper-attrs nl)
+ ; build the return value
+ (values
+ (ssax:resolve-name port tag-head namespaces #t)
+ (fold-right
+ (lambda (name-value attlist)
+ (or
+ (attlist-add attlist
+ (cons (ssax:resolve-name port (car name-value) namespaces #f)
+ (cdr name-value)))
+ (parser-error port "[uniqattspec] after NS expansion broken for "
+ name-value)))
+ (make-empty-attlist)
+ proper-attrs)
+ namespaces
+ elem-content)))))
+
+(run-test
+ (let* ((urn-a (string->symbol "urn:a"))
+ (urn-b (string->symbol "urn:b"))
+ (urn-html (string->symbol "http://w3c.org/html";))
+ (namespaces
+ `((#f '"UHTML" . ,urn-html)
+ ('"A" '"UA" . ,urn-a)))
+ (test
+ (lambda (tag-head-name elems str)
+ (call-with-input-string str
+ (lambda (port)
+ (call-with-values
+ (lambda ()
+ (ssax:complete-start-tag
+ (call-with-input-string tag-head-name
+ (lambda (port) (ssax:read-QName port)))
+ port
+ elems '() namespaces))
+ list))))))
+
+ ; First test with no validation of elements
+ ;(test "TAG1" #f "")
+ (assert (equal? `('"TAG1" () ,namespaces ANY)
+ (test "TAG1" #f ">")))
+ (assert (equal? `('"TAG1" () ,namespaces EMPTY-TAG)
+ (test "TAG1" #f "/>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "a")) ,namespaces EMPTY-TAG)
+ (test "TAG1" #f "HREF='a'/>")))
+ (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a"))
+ ,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY)
+ (test "TAG1" #f "HREF='a' xmlns='urn:a'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "a"))
+ ,(cons '(*DEFAULT* #f . #f) namespaces) ANY)
+ (test "TAG1" #f "HREF='a' xmlns=''>")))
+ (assert (failed? (test "UA:TAG1" #f "HREF='a' xmlns=''/>")))
+ (assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a"))
+ ,(cons '(*DEFAULT* #f . #f) namespaces) ANY)
+ (test "A:TAG1" #f "A:HREF='a' xmlns=''>")))
+ (assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a"))
+ ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) ANY)
+ (test "A:TAG1" #f "A:HREF='a' xmlns='urn:b'>")))
+ (assert (failed? (test "B:TAG1" #f "A:HREF='a' xmlns:b=''/>")))
+ (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a"))
+ ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
+ (test "B:TAG1" #f "A:HREF='a' xmlns:B='urn:b'>")))
+ (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")
+ ((,urn-b . '"SRC") . "b"))
+ ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
+ (test "B:TAG1" #f
+ "B:SRC='b' A:HREF='a' xmlns:B='urn:b'>")))
+ (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")
+ ((,urn-b . '"HREF") . "b"))
+ ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
+ (test "B:TAG1" #f
+ "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:b'>")))
+ ; must be an error! Duplicate attr
+ (assert (failed? (test "B:TAG1" #f
+ "HREF=\"b\" HREF='a' xmlns:B='urn:a'/>")))
+ ; must be an error! Duplicate attr after ns expansion
+ (assert (failed? (test "B:TAG1" #f
+ "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:a'/>")))
+ (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a")
+ (('"UA" . '"HREF") . "b"))
+ ,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY)
+ (test "TAG1" #f
+ "A:HREF=\"b\" HREF='a' xmlns='urn:a'>")))
+ (assert (equal? `('"TAG1" ((('"UHTML" . '"HREF") . "a")
+ ((,urn-b . '"HREF") . "b"))
+ ,(append `(
+ ('"HTML" '"UHTML" . ,urn-html)
+ ('"B" ,urn-b . ,urn-b))
+ namespaces) ANY)
+ (test "TAG1" #f
+ "B:HREF=\"b\" xmlns:B='urn:b'
xmlns:HTML='http://w3c.org/html' HTML:HREF='a' >")))
+
+ ; Now test the validating parsing
+ ; No decl for tag1
+ (assert (failed? (test "TAG1" '((TAG2 ANY ()))
+ "B:HREF='b' xmlns:B='urn:b'>")))
+ ; No decl for HREF elem
+;; (cond-expand
+;; ((not (or scm mit-scheme)) ; Regretfully, SCM treats '() as #f
+;; (assert (failed?
+;; (test "TAG1" '(('"TAG1" ANY ()))
+;; "B:HREF='b' xmlns:B='urn:b'>"))))
+;; (else #t))
+ ; No decl for HREF elem
+ (assert (failed?
+ (test "TAG1" '(('"TAG1" ANY (('"HREF1" CDATA IMPLIED #f))))
+ "B:HREF='b' xmlns:B='urn:b'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces EMPTY-TAG)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
+ "HREF='b'/>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
+ "HREF='b'>")))
+ ; Req'd attribute not given error
+ (assert (failed?
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
+ ">")))
+ ; Wrong content-type of the attribute
+ (assert (failed?
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c") REQUIRED #f))))
+ "HREF='b'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c" "b") IMPLIED #f))))
+ "HREF='b'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "c"))))
+ "HREF='b'>")))
+ ; Bad fixed attribute
+ (assert (failed?
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "c"))))
+ "HREF='b'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b"))))
+ "HREF='b'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b")))) ">")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "b")))) ">")))
+ (assert (equal? `('"TAG1" () ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED #f)))) ">")))
+ ; Undeclared attr
+ (assert (failed?
+ (test "TAG1"
+ '(('"TAG1" PCDATA ((('"A" . '"HREF") CDATA IMPLIED "c"))))
+ "HREF='b'>")))
+ (assert (equal? `('"TAG1" (('"HREF" . "b") (('"UA" . '"HREF") . "c"))
+ ,namespaces PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
+ (('"A" . '"HREF") CDATA IMPLIED "c"))))
+ "HREF='b'>")))
+ (assert (equal? `(('"UA" . '"TAG1")
+ (('"HREF" . "b") (('"UA" . '"HREF") . "c"))
+ ,namespaces PCDATA)
+ (test "A:TAG1" '((('"A" . '"TAG1") PCDATA
+ (('"HREF" NMTOKEN REQUIRED #f)
+ (('"A" . '"HREF") CDATA IMPLIED "c"))))
+ "HREF='b'>")))
+ (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
+ ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
+ (test "B:TAG1" '((('"B" . '"TAG1") PCDATA (('"HREF" CDATA REQUIRED #f)
+ (('"xmlns" . '"B") CDATA IMPLIED "urn:b"))))
+ "HREF='b'>")))
+ (assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b"))
+ ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
+ (test "B:TAG1" '((('"B" . '"TAG1") PCDATA
+ ((('"B" . '"HREF") CDATA REQUIRED #f)
+ (('"xmlns" . '"B") CDATA IMPLIED "urn:b"))))
+ "B:HREF='b'>")))
+ (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
+ ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
+ ('"xmlns" CDATA IMPLIED "urn:b"))))
+ "HREF='b'>")))
+ ; xmlns not declared
+ (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
+ ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA)
+ (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
+ )))
+ "HREF='b' xmlns='urn:b'>")))
+ ; xmlns:B not declared
+ (assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b"))
+ ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
+ (test "B:TAG1" '((('"B" . '"TAG1") PCDATA
+ ((('"B" . '"HREF") CDATA REQUIRED #f)
+ )))
+ "B:HREF='b' xmlns:B='urn:b'>")))
+))
+
+; procedure+: ssax:read-external-id PORT
+;
+; This procedure parses an ExternalID production:
+; [75] ExternalID ::= 'SYSTEM' S SystemLiteral
+; | 'PUBLIC' S PubidLiteral S SystemLiteral
+; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'")
+; [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
+; [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9]
+; | [-'()+,./:=?;address@hidden
+;
+; This procedure is supposed to be called when an ExternalID is expected;
+; that is, the current character must be either #\S or #\P that start
+; correspondingly a SYSTEM or PUBLIC token. This procedure returns the
+; SystemLiteral as a string. A PubidLiteral is disregarded if present.
+
+(define (ssax:read-external-id port)
+ (let ((discriminator (ssax:read-NCName port)))
+ (assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" port)
+ (ssax:skip-S port)
+ (let ((delimiter
+ (assert-curr-char '(#\' #\" ) "XML [11], XML [12]" port)))
+ (cond
+ ((eq? discriminator (string->symbol "SYSTEM"))
+ (begin0
+ (next-token '() (list delimiter) "XML [11]" port)
+ (read-char port) ; reading the closing delim
+ ))
+ ((eq? discriminator (string->symbol "PUBLIC"))
+ (skip-until (list delimiter) port)
+ (assert-curr-char ssax:S-chars "space after PubidLiteral" port)
+ (ssax:skip-S port)
+ (let* ((delimiter
+ (assert-curr-char '(#\' #\" ) "XML [11]" port))
+ (systemid
+ (next-token '() (list delimiter) "XML [11]" port)))
+ (read-char port) ; reading the closing delim
+ systemid))
+ (else
+ (parser-error port "XML [75], " discriminator
+ " rather than SYSTEM or PUBLIC"))))))
+
+
+;-----------------------------------------------------------------------------
+; Higher-level parsers and scanners
+;
+; They parse productions corresponding to the whole (document) entity
+; or its higher-level pieces (prolog, root element, etc).
+
+
+; Scan the Misc production in the context
+; [1] document ::= prolog element Misc*
+; [22] prolog ::= XMLDecl? Misc* (doctypedec l Misc*)?
+; [27] Misc ::= Comment | PI | S
+;
+; The following function should be called in the prolog or epilog contexts.
+; In these contexts, whitespaces are completely ignored.
+; The return value from ssax:scan-Misc is either a PI-token,
+; a DECL-token, a START token, or EOF.
+; Comments are ignored and not reported.
+
+(define (ssax:scan-Misc port)
+ (let loop ((c (ssax:skip-S port)))
+ (cond
+ ((eof-object? c) c)
+ ((not (char=? c #\<))
+ (parser-error port "XML [22], char '" c "' unexpected"))
+ (else
+ (let ((token (ssax:read-markup-token port)))
+ (case (xml-token-kind token)
+ ((COMMENT) (loop (ssax:skip-S port)))
+ ((PI DECL START) token)
+ (else
+ (parser-error port "XML [22], unexpected token of kind "
+ (xml-token-kind token)
+ ))))))))
+
+; procedure+: ssax:read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
+;
+; This procedure is to read the character content of an XML document
+; or an XML element.
+; [43] content ::=
+; (element | CharData | Reference | CDSect | PI
+; | Comment)*
+; To be more precise, the procedure reads CharData, expands CDSect
+; and character entities, and skips comments. The procedure stops
+; at a named reference, EOF, at the beginning of a PI or a start/end tag.
+;
+; port
+; a PORT to read
+; expect-eof?
+; a boolean indicating if EOF is normal, i.e., the character
+; data may be terminated by the EOF. EOF is normal
+; while processing a parsed entity.
+; str-handler
+; a STR-HANDLER
+; seed
+; an argument passed to the first invocation of STR-HANDLER.
+;
+; The procedure returns two results: SEED and TOKEN.
+; The SEED is the result of the last invocation of STR-HANDLER, or the
+; original seed if STR-HANDLER was never called.
+;
+; TOKEN can be either an eof-object (this can happen only if
+; expect-eof? was #t), or:
+; - an xml-token describing a START tag or an END-tag;
+; For a start token, the caller has to finish reading it.
+; - an xml-token describing the beginning of a PI. It's up to an
+; application to read or skip through the rest of this PI;
+; - an xml-token describing a named entity reference.
+;
+; CDATA sections and character references are expanded inline and
+; never returned. Comments are silently disregarded.
+;
+; As the XML Recommendation requires, all whitespace in character data
+; must be preserved. However, a CR character (#xD) must be disregarded
+; if it appears before a LF character (#xA), or replaced by a #xA character
+; otherwise. See Secs. 2.10 and 2.11 of the XML Recommendation. See also
+; the canonical XML Recommendation.
+
+ ; ssax:read-char-data port expect-eof? str-handler seed
+(define ssax:read-char-data
+ (let
+ ((terminators-usual (list #\< #\& char-return))
+ (terminators-usual-eof (list #\< '*eof* #\& char-return))
+
+ (handle-fragment
+ (lambda (fragment str-handler seed)
+ (if (string-null? fragment) seed
+ (str-handler fragment "" seed))))
+ )
+
+ (lambda (port expect-eof? str-handler seed)
+
+ ; Very often, the first character we encounter is #\<
+ ; Therefore, we handle this case in a special, fast path
+ (if (eqv? #\< (peek-char port))
+
+ ; The fast path
+ (let ((token (ssax:read-markup-token port)))
+ (case (xml-token-kind token)
+ ((START END) ; The most common case
+ (values seed token))
+ ((CDSECT)
+ (let ((seed (ssax:read-cdata-body port str-handler seed)))
+ (ssax:read-char-data port expect-eof? str-handler seed)))
+ ((COMMENT) (ssax:read-char-data port expect-eof?
+ str-handler seed))
+ (else
+ (values seed token))))
+
+
+ ; The slow path
+ (let ((char-data-terminators
+ (if expect-eof? terminators-usual-eof terminators-usual)))
+
+ (let loop ((seed seed))
+ (let* ((fragment
+ (next-token '() char-data-terminators
+ "reading char data" port))
+ (term-char (peek-char port)) ; one of char-data-terminators
+ )
+ (if (eof-object? term-char)
+ (values
+ (handle-fragment fragment str-handler seed)
+ term-char)
+ (case term-char
+ ((#\<)
+ (let ((token (ssax:read-markup-token port)))
+ (case (xml-token-kind token)
+ ((CDSECT)
+ (loop
+ (ssax:read-cdata-body port str-handler
+ (handle-fragment fragment str-handler seed))))
+ ((COMMENT)
+ (loop (handle-fragment fragment str-handler seed)))
+ (else
+ (values
+ (handle-fragment fragment str-handler seed)
+ token)))))
+ ((#\&)
+ (case (peek-next-char port)
+ ((#\#) (read-char port)
+ (loop (str-handler fragment
+ (ssax:read-char-ref port)
+ seed)))
+ (else
+ (let ((name (ssax:read-NCName port)))
+ (assert-curr-char '(#\;) "XML [68]" port)
+ (values
+ (handle-fragment fragment str-handler seed)
+ (make-xml-token 'ENTITY-REF name))))))
+ (else ; This must be a CR character
+ (if (eqv? (peek-next-char port) #\newline)
+ (read-char port))
+ (loop (str-handler fragment (string #\newline) seed))))
+ ))))))))
+
+
+; a few lines of validation code
+(run-test (letrec
+ ((a-tag (make-xml-token 'START (string->symbol "BR")))
+ (a-ref (make-xml-token 'ENTITY-REF (string->symbol "lt")))
+ (eof-object (lambda () eof-object)) ; a unique value
+ (str-handler (lambda (fragment foll-fragment seed)
+ (if (string-null? foll-fragment) (cons fragment seed)
+ (cons* foll-fragment fragment seed))))
+ (test (lambda (str expect-eof? expected-data expected-token)
+ (newline) (display "body: ") (write str)
+ (newline) (display "Result: ")
+ (let*-values
+ (((seed token)
+ (call-with-input-string (unesc-string str)
+ (lambda (port)
+ (ssax:read-char-data port expect-eof? str-handler '()))))
+ ((result) (reverse seed)))
+ (write result)
+ (display " ")
+ (display token)
+ (assert (equal? result (map unesc-string expected-data))
+ (if (eq? expected-token eof-object)
+ (eof-object? token)
+ (equal? token expected-token))))))
+ )
+ (test "" #t '() eof-object)
+ (assert (failed? (test "" #f '() eof-object)))
+ (test " " #t '(" ") eof-object)
+ (test "<BR/>" #f '() a-tag)
+ (test " <BR />" #f '(" ") a-tag)
+
+ (test " <" #f '(" ") a-ref)
+ (test " a<" #f '(" a") a-ref)
+ (test " a <" #f '(" a ") a-ref)
+
+ (test " <!-- comment--> a a<BR/>" #f '(" " " a a") a-tag)
+ (test " <!-- comment-->%ra a<BR/>" #f '(" " "" "%n" "a a") a-tag)
+ (test " <!-- comment-->%r%na a<BR/>" #f '(" " "" "%n" "a a") a-tag)
+ (test " <!-- comment-->%r%na%t%r%r%na<BR/>" #f
+ '(" " "" "%n" "a%t" "%n" "" "%n" "a") a-tag)
+ (test "a<!-- comment--> a a<BR/>" #f '("a" " a a") a-tag)
+ (test "!<BR/>" #f '("" "!") a-tag)
+ (test "!%n<BR/>" #f '("" "!" "%n") a-tag)
+ (test "%t!%n<BR/>" #f '("%t" "!" "%n") a-tag)
+ (test "%t!%na a<BR/>" #f '("%t" "!" "%na a") a-tag)
+ (test "%t!%ra a<BR/>" #f '("%t" "!" "" "%n" "a a") a-tag)
+ (test "%t!%r%na a<BR/>" #f '("%t" "!" "" "%n" "a a") a-tag)
+
+ (test " %ta ! b <BR/>" #f '(" %ta " "!" " b ") a-tag)
+ (test " %ta   b <BR/>" #f '(" %ta " " " " b ") a-tag)
+
+ (test "<![CDATA[<]]><BR/>" #f '("<") a-tag)
+ (test "<![CDATA[]]]><BR/>" #f '("]") a-tag)
+ (test "%t<![CDATA[<]]><BR/>" #f '("%t" "<") a-tag)
+ (test "%t<![CDATA[<]]>a b<BR/>" #f '("%t" "<" "a b") a-tag)
+ (test "%t<![CDATA[<]]> a b<BR/>" #f '("%t" "<" " a b") a-tag)
+
+ (test "%td <![CDATA[ <%r%r%n]]> a b<BR/>" #f
+ '("%td " " <" "%n" "" "%n" " a b") a-tag)
+))
+
+
+
+; procedure+: ssax:assert-token TOKEN KIND GI
+; Make sure that TOKEN is of anticipated KIND and has anticipated GI
+; Note GI argument may actually be a pair of two symbols, Namespace
+; URI or the prefix, and of the localname.
+; If the assertion fails, error-cont is evaluated by passing it
+; three arguments: token kind gi. The result of error-cont is returned.
+(define (ssax:assert-token token kind gi error-cont)
+ (or
+ (and (xml-token? token)
+ (eq? kind (xml-token-kind token))
+ (equal? gi (xml-token-head token)))
+ (error-cont token kind gi)))
+
+;========================================================================
+; Highest-level parsers: XML to SXML
+
+; These parsers are a set of syntactic forms to instantiate a SSAX parser.
+; A user can instantiate the parser to do the full validation, or
+; no validation, or any particular validation. The user specifies
+; which PI he wants to be notified about. The user tells what to do
+; with the parsed character and element data. The latter handlers
+; determine if the parsing follows a SAX or a DOM model.
+
+; syntax: ssax:make-pi-parser my-pi-handlers
+; Create a parser to parse and process one Processing Element (PI).
+
+; my-pi-handlers
+; An assoc list of pairs (PI-TAG . PI-HANDLER)
+; where PI-TAG is an NCName symbol, the PI target, and
+; PI-HANDLER is a procedure PORT PI-TAG SEED
+; where PORT points to the first symbol after the PI target.
+; The handler should read the rest of the PI up to and including
+; the combination '?>' that terminates the PI. The handler should
+; return a new seed.
+; One of the PI-TAGs may be the symbol *DEFAULT*. The corresponding
+; handler will handle PIs that no other handler will. If the
+; *DEFAULT* PI-TAG is not specified, ssax:make-pi-parser will assume
+; the default handler that skips the body of the PI
+;
+; The output of the ssax:make-pi-parser is a procedure
+; PORT PI-TAG SEED
+; that will parse the current PI according to the user-specified handlers.
+;
+; The previous version of ssax:make-pi-parser was a low-level macro:
+; (define-macro ssax:make-pi-parser
+; (lambda (my-pi-handlers)
+; `(lambda (port target seed)
+; (case target
+; ; Generate the body of the case statement
+; ,@(let loop ((pi-handlers my-pi-handlers) (default #f))
+; (cond
+; ((null? pi-handlers)
+; (if default `((else (,default port target seed)))
+; '((else
+; (ssax:warn port "Skipping PI: " target nl)
+; (ssax:skip-pi port)
+; seed))))
+; ((eq? '*DEFAULT* (caar pi-handlers))
+; (loop (cdr pi-handlers) (cdar pi-handlers)))
+; (else
+; (cons
+; `((,(caar pi-handlers)) (,(cdar pi-handlers) port target seed))
+; (loop (cdr pi-handlers) default)))))))))
+
+(define-syntax ssax:make-pi-parser
+ (syntax-rules ()
+ ((ssax:make-pi-parser orig-handlers)
+ (letrec-syntax
+ ; Generate the clauses of the case statement
+ ((loop
+ (syntax-rules (*DEFAULT*)
+ ((loop () #f accum port target seed) ; no default
+ (make-case
+ ((else
+ (ssax:warn port "Skipping PI: " target nl)
+ (ssax:skip-pi port)
+ seed)
+ . accum)
+ () target))
+ ((loop () default accum port target seed)
+ (make-case
+ ((else (default port target seed)) . accum)
+ () target))
+ ((loop ((*DEFAULT* . default) . handlers) old-def accum
+ port target seed)
+ (loop handlers default accum port target seed))
+ ((loop ((tag . handler) . handlers) default accum port target seed)
+ (loop handlers default
+ (((tag) (handler port target seed)) . accum)
+ port target seed))
+ ))
+ (make-case ; Reverse the clauses, make the 'case'
+ (syntax-rules ()
+ ((make-case () clauses target)
+ (case target . clauses))
+ ((make-case (clause . clauses) accum target)
+ (make-case clauses (clause . accum) target)))
+ ))
+ (lambda (port target seed)
+ (loop orig-handlers #f () port target seed))
+ ))))
+
+(run-test
+ (pp (ssax:make-pi-parser ()))
+ (pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed)))))
+ (pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed))
+ (html . list)
+ (*DEFAULT* . ssax:warn))))
+)
+
+; syntax: ssax:make-elem-parser my-new-level-seed my-finish-element
+; my-char-data-handler my-pi-handlers
+
+; Create a parser to parse and process one element, including its
+; character content or children elements. The parser is typically
+; applied to the root element of a document.
+
+; my-new-level-seed
+; procedure ELEM-GI ATTRIBUTES NAMESPACES EXPECTED-CONTENT SEED
+; where ELEM-GI is a RES-NAME of the element
+; about to be processed.
+; This procedure is to generate the seed to be passed
+; to handlers that process the content of the element.
+; This is the function identified as 'fdown' in the denotational
+; semantics of the XML parser given in the title comments to this
+; file.
+;
+; my-finish-element
+; procedure ELEM-GI ATTRIBUTES NAMESPACES PARENT-SEED SEED
+; This procedure is called when parsing of ELEM-GI is finished.
+; The SEED is the result from the last content parser (or
+; from my-new-level-seed if the element has the empty content).
+; PARENT-SEED is the same seed as was passed to my-new-level-seed.
+; The procedure is to generate a seed that will be the result
+; of the element parser.
+; This is the function identified as 'fup' in the denotational
+; semantics of the XML parser given in the title comments to this
+; file.
+;
+; my-char-data-handler
+; A STR-HANDLER
+;
+; my-pi-handlers
+; See ssax:make-pi-handler above
+;
+
+; The generated parser is a
+; procedure START-TAG-HEAD PORT ELEMS ENTITIES
+; NAMESPACES PRESERVE-WS? SEED
+; The procedure must be called after the start tag token has been
+; read. START-TAG-HEAD is an UNRES-NAME from the start-element tag.
+; ELEMS is an instance of xml-decl::elems.
+; See ssax:complete-start-tag::preserve-ws?
+
+; Faults detected:
+; VC: XML-Spec.html#elementvalid
+; WFC: XML-Spec.html#GIMatch
+
+
+(define-syntax ssax:make-elem-parser
+ (syntax-rules ()
+ ((ssax:make-elem-parser my-new-level-seed my-finish-element
+ my-char-data-handler my-pi-handlers)
+
+ (lambda (start-tag-head port elems entities namespaces
+ preserve-ws? seed)
+
+ (define xml-space-gi (cons ssax:Prefix-XML
+ (string->symbol "space")))
+
+ (let handle-start-tag ((start-tag-head start-tag-head)
+ (port port) (entities entities)
+ (namespaces namespaces)
+ (preserve-ws? preserve-ws?) (parent-seed seed))
+ (let*-values
+ (((elem-gi attributes namespaces expected-content)
+ (ssax:complete-start-tag start-tag-head port elems
+ entities namespaces))
+ ((seed)
+ (my-new-level-seed elem-gi attributes
+ namespaces expected-content parent-seed)))
+ (case expected-content
+ ((EMPTY-TAG)
+ (my-finish-element
+ elem-gi attributes namespaces parent-seed seed))
+ ((EMPTY) ; The end tag must immediately follow
+ (ssax:assert-token
+ (and (eqv? #\< (ssax:skip-S port)) (ssax:read-markup-token port))
+ 'END start-tag-head
+ (lambda (token exp-kind exp-head)
+ (parser-error port "[elementvalid] broken for " token
+ " while expecting "
+ exp-kind exp-head)))
+ (my-finish-element
+ elem-gi attributes namespaces parent-seed seed))
+ (else ; reading the content...
+ (let ((preserve-ws? ; inherit or set the preserve-ws? flag
+ (cond
+ ((assoc xml-space-gi attributes) =>
+ (lambda (name-value)
+ (equal? "preserve" (cdr name-value))))
+ (else preserve-ws?))))
+ (let loop ((port port) (entities entities)
+ (expect-eof? #f) (seed seed))
+ (let*-values
+ (((seed term-token)
+ (ssax:read-char-data port expect-eof?
+ my-char-data-handler seed)))
+ (if (eof-object? term-token)
+ seed
+ (case (xml-token-kind term-token)
+ ((END)
+ (ssax:assert-token term-token 'END start-tag-head
+ (lambda (token exp-kind exp-head)
+ (parser-error port "[GIMatch] broken for "
+ term-token " while expecting "
+ exp-kind exp-head)))
+ (my-finish-element
+ elem-gi attributes namespaces parent-seed seed))
+ ((PI)
+ (let ((seed
+ ((ssax:make-pi-parser my-pi-handlers)
+ port (xml-token-head term-token) seed)))
+ (loop port entities expect-eof? seed)))
+ ((ENTITY-REF)
+ (let ((seed
+ (ssax:handle-parsed-entity
+ port (xml-token-head term-token)
+ entities
+ (lambda (port entities seed)
+ (loop port entities #t seed))
+ my-char-data-handler
+ seed))) ; keep on reading the content after ent
+ (loop port entities expect-eof? seed)))
+ ((START) ; Start of a child element
+ (if (eq? expected-content 'PCDATA)
+ (parser-error port "[elementvalid] broken for "
+ elem-gi
+ " with char content only; unexpected token "
+ term-token))
+ ; Do other validation of the element content
+ (let ((seed
+ (handle-start-tag
+ (xml-token-head term-token)
+ port entities namespaces
+ preserve-ws? seed)))
+ (loop port entities expect-eof? seed)))
+ (else
+ (parser-error port "XML [43] broken for "
+ term-token))))))))
+ )))
+))))
+
+
+; syntax: ssax:make-parser user-handler-tag user-handler-proc ...
+;
+; Create an XML parser, an instance of the XML parsing framework.
+; This will be a SAX, a DOM, or a specialized parser depending
+; on the supplied user-handlers.
+
+; user-handler-tag is a symbol that identifies a procedural expression
+; that follows the tag. Given below are tags and signatures of the
+; corresponding procedures. Not all tags have to be specified. If some
+; are omitted, reasonable defaults will apply.
+;
+
+; tag: DOCTYPE
+; handler-procedure: PORT DOCNAME SYSTEMID INTERNAL-SUBSET? SEED
+; If internal-subset? is #t, the current position in the port
+; is right after we have read #\[ that begins the internal DTD subset.
+; We must finish reading of this subset before we return
+; (or must call skip-internal-subset if we aren't interested in reading it).
+; The port at exit must be at the first symbol after the whole
+; DOCTYPE declaration.
+; The handler-procedure must generate four values:
+; ELEMS ENTITIES NAMESPACES SEED
+; See xml-decl::elems for ELEMS. It may be #f to switch off the validation.
+; NAMESPACES will typically contain USER-PREFIXes for selected URI-SYMBs.
+; The default handler-procedure skips the internal subset,
+; if any, and returns (values #f '() '() seed)
+
+; tag: UNDECL-ROOT
+; handler-procedure: ELEM-GI SEED
+; where ELEM-GI is an UNRES-NAME of the root element. This procedure
+; is called when an XML document under parsing contains _no_ DOCTYPE
+; declaration.
+; The handler-procedure, as a DOCTYPE handler procedure above,
+; must generate four values:
+; ELEMS ENTITIES NAMESPACES SEED
+; The default handler-procedure returns (values #f '() '() seed)
+
+; tag: DECL-ROOT
+; handler-procedure: ELEM-GI SEED
+; where ELEM-GI is an UNRES-NAME of the root element. This procedure
+; is called when an XML document under parsing does contains the DOCTYPE
+; declaration.
+; The handler-procedure must generate a new SEED (and verify
+; that the name of the root element matches the doctype, if the handler
+; so wishes).
+; The default handler-procedure is the identity function.
+
+; tag: NEW-LEVEL-SEED
+; handler-procedure: see ssax:make-elem-parser, my-new-level-seed
+
+; tag: FINISH-ELEMENT
+; handler-procedure: see ssax:make-elem-parser, my-finish-element
+
+; tag: CHAR-DATA-HANDLER
+; handler-procedure: see ssax:make-elem-parser, my-char-data-handler
+
+; tag: PI
+; handler-procedure: see ssax:make-pi-parser
+; The default value is '()
+
+; The generated parser is a
+; procedure PORT SEED
+
+; This procedure parses the document prolog and then exits to
+; an element parser (created by ssax:make-elem-parser) to handle
+; the rest.
+;
+; [1] document ::= prolog element Misc*
+; [22] prolog ::= XMLDecl? Misc* (doctypedec | Misc*)?
+; [27] Misc ::= Comment | PI | S
+;
+; [28] doctypedecl ::= '<!DOCTYPE' S Name (S ExternalID)? S?
+; ('[' (markupdecl | PEReference | S)* ']' S?)? '>'
+; [29] markupdecl ::= elementdecl | AttlistDecl
+; | EntityDecl
+; | NotationDecl | PI
+; | Comment
+;
+
+
+; This is ssax:make-parser with all the (specialization) handlers given
+; as positional arguments. It is called by ssax:make-parser, see below
+(define-syntax ssax:make-parser/positional-args
+ (syntax-rules ()
+ ((ssax:make-parser/positional-args
+ *handler-DOCTYPE
+ *handler-UNDECL-ROOT
+ *handler-DECL-ROOT
+ *handler-NEW-LEVEL-SEED
+ *handler-FINISH-ELEMENT
+ *handler-CHAR-DATA-HANDLER
+ *handler-PI)
+ (lambda (port seed)
+
+ ; We must've just scanned the DOCTYPE token
+ ; Handle the doctype declaration and exit to
+ ; scan-for-significant-prolog-token-2, and eventually, to the
+ ; element parser.
+ (define (handle-decl port token-head seed)
+ (or (eq? (string->symbol "DOCTYPE") token-head)
+ (parser-error port "XML [22], expected DOCTYPE declaration, found "
+ token-head))
+ (assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" port)
+ (ssax:skip-S port)
+ (let*-values
+ (((docname) (ssax:read-QName port))
+ ((systemid)
+ (and (ssax:ncname-starting-char? (ssax:skip-S port))
+ (ssax:read-external-id port)))
+ ((internal-subset?)
+ (begin (ssax:skip-S port)
+ (eqv? #\[ (assert-curr-char '(#\> #\[)
+ "XML [28], end-of-DOCTYPE" port))))
+ ((elems entities namespaces seed)
+ (*handler-DOCTYPE port docname systemid
+ internal-subset? seed))
+ )
+ (scan-for-significant-prolog-token-2 port elems entities namespaces
+ seed)))
+
+
+ ; Scan the leading PIs until we encounter either a doctype declaration
+ ; or a start token (of the root element)
+ ; In the latter two cases, we exit to the appropriate continuation
+ (define (scan-for-significant-prolog-token-1 port seed)
+ (let ((token (ssax:scan-Misc port)))
+ (if (eof-object? token)
+ (parser-error port "XML [22], unexpected EOF")
+ (case (xml-token-kind token)
+ ((PI)
+ (let ((seed
+ ((ssax:make-pi-parser *handler-PI)
+ port (xml-token-head token) seed)))
+ (scan-for-significant-prolog-token-1 port seed)))
+ ((DECL) (handle-decl port (xml-token-head token) seed))
+ ((START)
+ (let*-values
+ (((elems entities namespaces seed)
+ (*handler-UNDECL-ROOT (xml-token-head token) seed)))
+ (element-parser (xml-token-head token) port elems
+ entities namespaces #f seed)))
+ (else (parser-error port "XML [22], unexpected markup "
+ token))))))
+
+
+ ; Scan PIs after the doctype declaration, till we encounter
+ ; the start tag of the root element. After that we exit
+ ; to the element parser
+ (define (scan-for-significant-prolog-token-2 port elems entities
+ namespaces seed)
+ (let ((token (ssax:scan-Misc port)))
+ (if (eof-object? token)
+ (parser-error port "XML [22], unexpected EOF")
+ (case (xml-token-kind token)
+ ((PI)
+ (let ((seed
+ ((ssax:make-pi-parser *handler-PI)
+ port (xml-token-head token) seed)))
+ (scan-for-significant-prolog-token-2 port elems entities
+ namespaces seed)))
+ ((START)
+ (element-parser (xml-token-head token) port elems
+ entities namespaces #f
+ (*handler-DECL-ROOT (xml-token-head token) seed)))
+ (else (parser-error port "XML [22], unexpected markup "
+ token))))))
+
+
+ ; A procedure start-tag-head port elems entities namespaces
+ ; preserve-ws? seed
+ (define element-parser
+ (ssax:make-elem-parser *handler-NEW-LEVEL-SEED
+ *handler-FINISH-ELEMENT
+ *handler-CHAR-DATA-HANDLER
+ *handler-PI))
+
+ ; Get the ball rolling ...
+ (scan-for-significant-prolog-token-1 port seed)
+))))
+
+
+
+; The following meta-macro turns a regular macro (with positional
+; arguments) into a form with keyword (labeled) arguments. We later
+; use the meta-macro to convert ssax:make-parser/positional-args into
+; ssax:make-parser. The latter provides a prettier (with labeled
+; arguments and defaults) interface to
+; ssax:make-parser/positional-args
+;
+; ssax:define-labeled-arg-macro LABELED-ARG-MACRO-NAME
+; (POS-MACRO-NAME ARG-DESCRIPTOR ...)
+; expands into the definition of a macro
+; LABELED-ARG-MACRO-NAME KW-NAME KW-VALUE KW-NAME1 KW-VALUE1 ...
+; which, in turn, expands into
+; POS-MACRO-NAME ARG1 ARG2 ...
+; where each ARG1 etc. comes either from KW-VALUE or from
+; the deafult part of ARG-DESCRIPTOR. ARG1 corresponds to the first
+; ARG-DESCRIPTOR, ARG2 corresponds to the second descriptor, etc.
+; Here ARG-DESCRIPTOR describes one argument of the positional macro.
+; It has the form
+; (ARG-NAME DEFAULT-VALUE)
+; or
+; (ARG-NAME)
+; In the latter form, the default value is not given, so that the invocation of
+; LABELED-ARG-MACRO-NAME must mention the corresponding parameter.
+; ARG-NAME can be anything: an identifier, a string, or even a number.
+
+
+(define-syntax ssax:define-labeled-arg-macro
+ (syntax-rules ()
+ ((ssax:define-labeled-arg-macro
+ labeled-arg-macro-name
+ (positional-macro-name
+ (arg-name . arg-def) ...))
+ (define-syntax labeled-arg-macro-name
+ (syntax-rules ()
+ ((labeled-arg-macro-name . kw-val-pairs)
+ (letrec-syntax
+ ((find
+ (syntax-rules (arg-name ...)
+ ((find k-args (arg-name . default) arg-name
+ val . others) ; found arg-name among kw-val-pairs
+ (next val . k-args)) ...
+ ((find k-args key arg-no-match-name val . others)
+ (find k-args key . others))
+ ((find k-args (arg-name default)) ; default must be here
+ (next default . k-args)) ...
+ ))
+ (next ; pack the continuation to find
+ (syntax-rules ()
+ ((next val vals key . keys)
+ (find ((val . vals) . keys) key . kw-val-pairs))
+ ((next val vals) ; processed all arg-descriptors
+ (rev-apply (val) vals))))
+ (rev-apply
+ (syntax-rules ()
+ ((rev-apply form (x . xs))
+ (rev-apply (x . form) xs))
+ ((rev-apply form ()) form))))
+ (next positional-macro-name ()
+ (arg-name . arg-def) ...))))))))
+
+
+; The definition of ssax:make-parser
+(ssax:define-labeled-arg-macro ssax:make-parser
+ (ssax:make-parser/positional-args
+ (DOCTYPE
+ (lambda (port docname systemid internal-subset? seed)
+ (when internal-subset?
+ (ssax:warn port "Internal DTD subset is not currently handled ")
+ (ssax:skip-internal-dtd port))
+ (ssax:warn port "DOCTYPE DECL " docname " "
+ systemid " found and skipped")
+ (values #f '() '() seed)
+ ))
+ (UNDECL-ROOT
+ (lambda (elem-gi seed) (values #f '() '() seed)))
+ (DECL-ROOT
+ (lambda (elem-gi seed) seed))
+ (NEW-LEVEL-SEED) ; required
+ (FINISH-ELEMENT) ; required
+ (CHAR-DATA-HANDLER) ; required
+ (PI ())
+ ))
+
+(run-test
+ (letrec ((simple-parser
+ (lambda (str doctype-fn)
+ (call-with-input-string str
+ (lambda (port)
+ ((ssax:make-parser
+ NEW-LEVEL-SEED
+ (lambda (elem-gi attributes namespaces
+ expected-content seed)
+ '())
+
+ FINISH-ELEMENT
+ (lambda (elem-gi attributes namespaces parent-seed seed)
+ (let
+ ((seed (if (null? namespaces) (reverse seed)
+ (cons (list '*NAMESPACES* namespaces)
+ (reverse seed)))))
+ (let ((seed (if (attlist-null? attributes) seed
+ (cons
+ (cons '@
+ (map (lambda (attr)
+ (list (car attr) (cdr attr)))
+ (attlist->alist attributes)))
+ seed))))
+ (cons (cons elem-gi seed) parent-seed))))
+
+ CHAR-DATA-HANDLER
+ (lambda (string1 string2 seed)
+ (if (string-null? string2) (cons string1 seed)
+ (cons* string2 string1 seed)))
+
+ DOCTYPE
+ (lambda (port docname systemid internal-subset? seed)
+ (when internal-subset?
+ (ssax:warn port
+ "Internal DTD subset is not currently handled ")
+ (ssax:skip-internal-dtd port))
+ (ssax:warn port "DOCTYPE DECL " docname " "
+ systemid " found and skipped")
+ (doctype-fn docname seed))
+
+ UNDECL-ROOT
+ (lambda (elem-gi seed)
+ (doctype-fn elem-gi seed))
+ )
+ port '())))))
+
+ (dummy-doctype-fn (lambda (elem-gi seed) (values #f '() '() seed)))
+ (test
+ (lambda (str doctype-fn expected)
+ (cout nl "Parsing: " str nl)
+ (let ((result (simple-parser (unesc-string str) doctype-fn)))
+ (write result)
+ (assert (equal? result expected)))))
+ )
+
+ (test "<BR/>" dummy-doctype-fn '(('"BR")))
+ (assert (failed? (test "<BR>" dummy-doctype-fn '())))
+ (test "<BR></BR>" dummy-doctype-fn '(('"BR")))
+ (assert (failed? (test "<BR></BB>" dummy-doctype-fn '())))
+
+ (test " <A HREF='URL'> link <I>itlink </I> &amp;</A>"
+ dummy-doctype-fn
+ '(('"A" (@ ('"HREF" "URL")) " link " ('"I" "itlink ")
+ " " "&" "amp;")))
+
+ (test
+ " <A HREF='URL' xml:space='preserve'> link <I>itlink </I>
&amp;</A>" dummy-doctype-fn
+ '(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve"))
+ " link " ('"I" "itlink ") " " "&" "amp;")))
+
+ (test " <A HREF='URL' xml:space='preserve'> link <I
xml:space='default'>itlink </I> &amp;</A>" dummy-doctype-fn
+ '(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve"))
+ " link "
+ ('"I" (@ (('"xml" . '"space") "default")) "itlink ")
+ " " "&" "amp;")))
+ (test "<itemize><item>This is item 1 </item>%n<!-- Just:a comment
--><item>Item 2</item>%n </itemize>" dummy-doctype-fn
+ `(('"itemize" ('"item" "This is item 1 ")
+ ,(unesc-string "%n") ('"item" "Item 2") ,(unesc-string "%n "))))
+ (test " <P><![CDATA[<BR>%n<![CDATA[<BR>]]>]]></P>"
+ dummy-doctype-fn `(('"P" "<BR>" ,nl "<![CDATA[<BR>" "]]" "" ">")))
+
+ (test " <P><![CDATA[<BR>%r<![CDATA[<BR>]]>]]></P>"
+ dummy-doctype-fn `(('"P" "<BR>" ,nl "<![CDATA[<BR>" "]]" "" ">")))
+
+ (test "<?xml version='1.0'?>%n%n<Reports TStamp='1'></Reports>"
+ dummy-doctype-fn '(('"Reports" (@ ('"TStamp" "1")))))
+ (test "%n<?PI xxx?><!-- Comment %n -%r-->%n<?PI1 zzz?><T/>"
+ dummy-doctype-fn '(('"T")))
+ (test "<!DOCTYPE T SYSTEM 'system1' ><!-- comment -->%n<T/>"
+ (lambda (elem-gi seed) (assert (equal? elem-gi ''"T"))
+ (values #f '() '() seed))
+ '(('"T")))
+ (test "<!DOCTYPE T PUBLIC '//EN/T' \"system1\" [ <!ELEMENT a 'aa'>
]>%n<?pi?><T/>"
+ (lambda (elem-gi seed) (assert (equal? elem-gi ''"T"))
+ (values #f '() '() seed))
+ '(('"T")))
+ (test "<BR/>"
+ (lambda (elem-gi seed)
+ (values '(('"BR" EMPTY ())) '() '() seed)) '(('"BR")))
+ (test "<BR></BR>"
+ (lambda (elem-gi seed)
+ (values '(('"BR" EMPTY ())) '() '() seed)) '(('"BR")))
+ (assert (failed? (test "<BR>aa</BR>"
+ (lambda (elem-gi seed)
+ (values '(('"BR" EMPTY ())) '() '() seed)) '())))
+ (test "<BR>aa</BR>"
+ (lambda (elem-gi seed)
+ (values '(('"BR" PCDATA ())) '() '() seed)) '(('"BR" "aa")))
+ (assert (failed? (test "<BR>a<I>a</I></BR>"
+ (lambda (elem-gi seed)
+ (values '(('"BR" PCDATA ())) '() '() seed)) '())))
+ (test "<BR>a<I>a</I></BR>"
+ (lambda (elem-gi seed)
+ (values '(('"BR" ANY ()) ('"I" PCDATA ())) '() '() seed))
+ '(('"BR" "a" ('"I" "a"))))
+
+
+ (test "<DIV>Example: \"&example;\"</DIV>"
+ (lambda (elem-gi seed)
+ (values #f '((example . "<P>An ampersand (&) may be escaped
numerically (&#38;) or with a general entity (&amp;).</P>")) '() seed))
+ '(('"DIV" "Example: \""
+ ('"P" "An ampersand (" "&" ") may be escaped numerically (" "&"
"#38;) or with a general entity (" "&" "amp;).") "\"")))
+ (test "<DIV>Example: \"&example;\" <P/></DIV>"
+ (lambda (elem-gi seed)
+ (values #f '(('"quote" . "<I>example:</I> ex")
+ ('"example" . "<Q>"e;!</Q>?")) '() seed))
+ '(('"DIV" "Example: \"" ('"Q" ('"I" "example:") " ex" "!") "?"
+ "\" " ('"P"))))
+ (assert (failed?
+ (test "<DIV>Example: \"&example;\" <P/></DIV>"
+ (lambda (elem-gi seed)
+ (values #f '(('"quote" . "<I>example:")
+ ('"example" . "<Q>"e;</I>!</Q>?")) '() seed))
+ '())))
+
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values #f '() '() seed))
+ '((('"URI1" . '"DIV") (@ ('"B" "B") (('"URI1" . '"B") "A"))
+ (*NAMESPACES* (('"A" '"URI1" . '"URI1")
+ (*DEFAULT* '"URI1" . '"URI1")))
+ (('"URI1" . '"P")
+ (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"URI1" . '"URI1")
+ (*DEFAULT* '"URI1" . '"URI1")))
+ ('"BR"
+ (*NAMESPACES* ((*DEFAULT* #f . #f)
+ ('"A" '"URI1" . '"URI1")
+ (*DEFAULT* '"URI1" . '"URI1"))))))))
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values #f '() '((#f '"UA" . '"URI1")) seed))
+ '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A"))
+ (*NAMESPACES* (('"A" '"UA" . '"URI1")
+ (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+ (('"UA" . '"P")
+ (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"UA" . '"URI1")
+ (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+ ('"BR"
+ (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"UA" . '"URI1")
+ (*DEFAULT* '"UA" . '"URI1")
+ (#f '"UA" . '"URI1"))))))))
+ ; uniqattr should fail
+ (assert (failed?
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values
+ `(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+ (('"A" . '"B") CDATA IMPLIED #f)
+ (('"C" . '"B") CDATA IMPLIED "xx")
+ (('"xmlns" . '"C") CDATA IMPLIED "URI1")
+ ))
+ (('"A" . '"P") ANY ()) ('"BR" '"EMPTY" ()))
+ '() '((#f '"UA" . '"URI1")) seed))
+ '())))
+ ; prefix C undeclared
+ (assert (failed?
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values
+ '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+ ('"xmlns" CDATA IMPLIED "URI1")
+ (('"A" . '"B") CDATA IMPLIED #f)
+ (('"C" . '"B") CDATA IMPLIED "xx")
+ ))
+ (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+ '() '((#f '"UA" . '"URI1")) seed))
+ '())))
+
+ ; contradiction to xmlns declaration
+ (assert (failed?
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values
+ '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+ ('"xmlns" CDATA FIXED "URI2")
+ (('"A" . '"B") CDATA IMPLIED #f)
+ ))
+ (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+ '() '((#f '"UA" . '"URI1")) seed))
+ '())))
+
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values
+ '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+ ('"xmlns" CDATA FIXED "URI1")
+ (('"A" . '"B") CDATA IMPLIED #f)
+ ))
+ (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+ '() '((#f '"UA" . '"URI1")) seed))
+ '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A"))
+ (*NAMESPACES* ((*DEFAULT* '"UA" . '"URI1")
+ ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+ (('"UA" . '"P")
+ (*NAMESPACES* ((*DEFAULT* #f . #f)
+ (*DEFAULT* '"UA" . '"URI1")
+ ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+ ('"BR"
+ (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1")
+ ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1"))))))))
+
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>"
+ (lambda (elem-gi seed)
+ (values
+ '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+ (('"A" . '"B") CDATA IMPLIED #f)
+ (('"C" . '"B") CDATA IMPLIED "xx")
+ (('"xmlns" . '"C") CDATA IMPLIED "URI2")
+ ))
+ (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+ '() '((#f '"UA" . '"URI1")) seed))
+ '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A")
+ (('"URI2" . '"B") "xx"))
+ (*NAMESPACES* ((*DEFAULT* '"UA" . '"URI1")
+ ('"A" '"UA" . '"URI1")
+ ('"C" '"URI2" . '"URI2")
+ (#f '"UA" . '"URI1")))
+ (('"UA" . '"P")
+ (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1")
+ ('"A" '"UA" . '"URI1")
+ ('"C" '"URI2" . '"URI2") (#f '"UA" . '"URI1")))
+ ('"BR"
+ (*NAMESPACES* ((*DEFAULT* #f . #f)
+ (*DEFAULT* '"UA" . '"URI1")
+ ('"A" '"UA" . '"URI1")
+ ('"C" '"URI2" . '"URI2")
+ (#f '"UA" . '"URI1"))))))))
+))
+
+
+
+;========================================================================
+; Highest-level parsers: XML to SXML
+;
+
+; First, a few utility procedures that turned out useful
+
+; ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We can prove from the general case below that if LIST-OF-FRAGS
+; has zero or one element, the result of the procedure is equal?
+; to its argument. This fact justifies the shortcut evaluation below.
+(define (ssax:reverse-collect-str fragments)
+ (cond
+ ((null? fragments) '()) ; a shortcut
+ ((null? (cdr fragments)) fragments) ; see the comment above
+ (else
+ (let loop ((fragments fragments) (result '()) (strs '()))
+ (cond
+ ((null? fragments)
+ (if (null? strs) result
+ (cons (string-concatenate/shared strs) result)))
+ ((string? (car fragments))
+ (loop (cdr fragments) result (cons (car fragments) strs)))
+ (else
+ (loop (cdr fragments)
+ (cons
+ (car fragments)
+ (if (null? strs) result
+ (cons (string-concatenate/shared strs) result)))
+ '())))))))
+
+
+; ssax:reverse-collect-str-drop-ws LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We also drop "unsignificant" whitespace, that is, whitespace
+; in front, behind and between elements. The whitespace that
+; is included in character data is not affected.
+; We use this procedure to "intelligently" drop "insignificant"
+; whitespace in the parsed SXML. If the strict compliance with
+; the XML Recommendation regarding the whitespace is desired, please
+; use the ssax:reverse-collect-str procedure instead.
+
+(define (ssax:reverse-collect-str-drop-ws fragments)
+ (cond
+ ((null? fragments) '()) ; a shortcut
+ ((null? (cdr fragments)) ; another shortcut
+ (if (and (string? (car fragments)) (string-whitespace? (car fragments)))
+ '() fragments)) ; remove trailing ws
+ (else
+ (let loop ((fragments fragments) (result '()) (strs '())
+ (all-whitespace? #t))
+ (cond
+ ((null? fragments)
+ (if all-whitespace? result ; remove leading ws
+ (cons (string-concatenate/shared strs) result)))
+ ((string? (car fragments))
+ (loop (cdr fragments) result (cons (car fragments) strs)
+ (and all-whitespace?
+ (string-whitespace? (car fragments)))))
+ (else
+ (loop (cdr fragments)
+ (cons
+ (car fragments)
+ (if all-whitespace? result
+ (cons (string-concatenate/shared strs) result)))
+ '() #t)))))))
+
+
+; procedure: ssax:xml->sxml PORT NAMESPACE-PREFIX-ASSIG
+;
+; This is an instance of a SSAX parser above that returns an SXML
+; representation of the XML document to be read from PORT.
+; NAMESPACE-PREFIX-ASSIG is a list of (USER-PREFIX . URI-STRING)
+; that assigns USER-PREFIXes to certain namespaces identified by
+; particular URI-STRINGs. It may be an empty list.
+; The procedure returns an SXML tree. The port points out to the
+; first character after the root element.
+
+(define (ssax:xml->sxml port namespace-prefix-assig)
+ (letrec
+ ((namespaces
+ (map (lambda (el)
+ (cons* #f (car el) (ssax:uri-string->symbol (cdr el))))
+ namespace-prefix-assig))
+
+ (RES-NAME->SXML
+ (lambda (res-name)
+ (string->symbol
+ (string-append
+ (symbol->string (car res-name))
+ ":"
+ (symbol->string (cdr res-name))))))
+
+ )
+ (let ((result
+ (reverse
+ ((ssax:make-parser
+ NEW-LEVEL-SEED
+ (lambda (elem-gi attributes namespaces
+ expected-content seed)
+ '())
+
+ FINISH-ELEMENT
+ (lambda (elem-gi attributes namespaces parent-seed seed)
+ (let ((seed (ssax:reverse-collect-str seed))
+ (attrs
+ (attlist-fold
+ (lambda (attr accum)
+ (cons (list
+ (if (symbol? (car attr)) (car attr)
+ (RES-NAME->SXML (car attr)))
+ (cdr attr)) accum))
+ '() attributes)))
+ (cons
+ (cons
+ (if (symbol? elem-gi) elem-gi
+ (RES-NAME->SXML elem-gi))
+ (if (null? attrs) seed
+ (cons (cons '@ attrs) seed)))
+ parent-seed)))
+
+ CHAR-DATA-HANDLER
+ (lambda (string1 string2 seed)
+ (if (string-null? string2) (cons string1 seed)
+ (cons* string2 string1 seed)))
+
+ DOCTYPE
+ (lambda (port docname systemid internal-subset? seed)
+ (when internal-subset?
+ (ssax:warn port
+ "Internal DTD subset is not currently handled ")
+ (ssax:skip-internal-dtd port))
+ (ssax:warn port "DOCTYPE DECL " docname " "
+ systemid " found and skipped")
+ (values #f '() namespaces seed))
+
+ UNDECL-ROOT
+ (lambda (elem-gi seed)
+ (values #f '() namespaces seed))
+
+ PI
+ ((*DEFAULT* .
+ (lambda (port pi-tag seed)
+ (cons
+ (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+ seed))))
+ )
+ port '()))))
+ (cons '*TOP*
+ (if (null? namespace-prefix-assig) result
+ (cons
+ (list '@ (cons '*NAMESPACES*
+ (map (lambda (ns) (list (car ns) (cdr ns)))
+ namespace-prefix-assig)))
+ result)))
+)))
+
+; For backwards compatibility
+(define SSAX:XML->SXML ssax:xml->sxml)
+
+
+; a few lines of validation code
+(run-test (letrec
+ ((test (lambda (str namespace-assig expected-res)
+ (newline) (display "input: ")
+ (write (unesc-string str)) (newline) (display "Result: ")
+ (let ((result
+ (call-with-input-string (unesc-string str)
+ (lambda (port)
+ (ssax:xml->sxml port namespace-assig)))))
+ (pp result)
+ (assert (equal_? result expected-res))))))
+
+ (test " <BR/>" '() '(*TOP* (BR)))
+ (test "<BR></BR>" '() '(*TOP* (BR)))
+ (test " <BR CLEAR='ALL'%nCLASS='Class1'/>" '()
+ '(*TOP* (BR (@ (CLEAR "ALL") (CLASS "Class1")))))
+ (test " <A HREF='URL'> link <I>itlink </I> &amp;</A>" '()
+ '(*TOP* (A (@ (HREF "URL")) " link " (I "itlink ") " &")))
+ (test " <A HREF='URL' xml:space='preserve'> link <I>itlink </I>
&amp;</A>" '()
+ '(*TOP* (A (@ (xml:space "preserve") (HREF "URL"))
+ " link " (I "itlink ") " &")))
+ (test " <A HREF='URL' xml:space='preserve'> link <I
xml:space='default'>itlink </I> &amp;</A>" '()
+ '(*TOP* (A (@ (xml:space "preserve") (HREF "URL"))
+ " link " (I (@ (xml:space "default"))
+ "itlink ") " &")))
+ (test " <P><?pi1 p1 content ?>?<?pi2 pi2? content? ??></P>" '()
+ '(*TOP* (P (*PI* pi1 "p1 content ") "?"
+ (*PI* pi2 "pi2? content? ?"))))
+ (test " <P>some text <![CDATA[<]]>1%n"<B>strong</B>"%r</P>"
+ '()
+ `(*TOP* (P ,(unesc-string "some text <1%n\"")
+ (B "strong") ,(unesc-string "\"%n"))))
+ (test " <P><![CDATA[<BR>%n<![CDATA[<BR>]]>]]></P>" '()
+ `(*TOP* (P ,(unesc-string "<BR>%n<![CDATA[<BR>]]>"))))
+; (test "<T1><T2>it's%r%nand that%n</T2>%r%n%r%n%n</T1>" '()
+; '(*TOP* (T1 (T2 "it's%nand that%n") "%n%n%n")))
+ (test "<T1><T2>it's%r%nand that%n</T2>%r%n%r%n%n</T1>" '()
+ `(*TOP* (T1 (T2 ,(unesc-string "it's%nand that%n")) ,(unesc-string
"%n%n%n"))))
+ (test "<T1><T2>it's%rand that%n</T2>%r%n%r%n%n</T1>" '()
+ `(*TOP* (T1 (T2 ,(unesc-string "it's%nand that%n")) ,(unesc-string
"%n%n%n"))))
+ (test "<!DOCTYPE T SYSTEM 'system1' ><!-- comment -->%n<T/>" '()
+ '(*TOP* (T)))
+ (test "<?xml version='1.0'?>%n<WEIGHT unit=\"pound\">%n<NET
certified='certified'> 67 </NET>%n<GROSS> 95 </GROSS>%n</WEIGHT>" '()
+ `(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound"))
+ ,nl (NET (@ (certified "certified")) " 67 ") ,nl
+ (GROSS " 95 ") ,nl)
+ ))
+; (test "<?xml version='1.0'?>%n<WEIGHT unit=\"pound\">%n<NET
certified='certified'> 67 </NET>%n<GROSS> 95 </GROSS>%n</WEIGHT>" '()
+; '(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound"))
+; "%n" (NET (@ (certified "certified")) " 67 ")
+; "%n" (GROSS " 95 ") "%n")
+; ))
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>" '()
+ '(*TOP* (URI1:DIV (@ (URI1:B "A") (B "B")) (URI1:P (BR)))))
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P
xmlns=''><BR/></A:P></DIV>" '((UA . "URI1"))
+ '(*TOP* (@ (*NAMESPACES* (UA "URI1")))
+ (UA:DIV (@ (UA:B "A") (B "B")) (UA:P (BR)))))
+
+ ; A few tests from XML Namespaces Recommendation
+ (test (string-append
+ "<x xmlns:edi='http://ecommerce.org/schema'>"
+ "<!-- the 'taxClass' attribute's ns http://ecommerce.org/schema
-->"
+ "<lineItem edi:taxClass='exempt'>Baby food</lineItem>" nl
+ "</x>") '()
+ `(*TOP*
+ (x (lineItem
+ (@ (http://ecommerce.org/schema:taxClass "exempt"))
+ "Baby food") ,nl)))
+ (test (string-append
+ "<x xmlns:edi='http://ecommerce.org/schema'>"
+ "<!-- the 'taxClass' attribute's ns http://ecommerce.org/schema
-->"
+ "<lineItem edi:taxClass='exempt'>Baby food</lineItem>"
+ "</x>") '((EDI . "http://ecommerce.org/schema";))
+ '(*TOP*
+ (@ (*NAMESPACES* (EDI "http://ecommerce.org/schema";)))
+ (x (lineItem
+ (@ (EDI:taxClass "exempt"))
+ "Baby food"))))
+
+ (test (string-append
+ "<bk:book xmlns:bk='urn:loc.gov:books' "
+ "xmlns:isbn='urn:ISBN:0-395-36341-6'>"
+ "<bk:title>Cheaper by the Dozen</bk:title>"
+ "<isbn:number>1568491379</isbn:number></bk:book>")
+ '()
+ '(*TOP* (urn:loc.gov:books:book
+ (urn:loc.gov:books:title "Cheaper by the Dozen")
+ (urn:ISBN:0-395-36341-6:number "1568491379"))))
+
+ (test (string-append
+ "<!-- initially, the default namespace is 'books' -->"
+ "<book xmlns='urn:loc.gov:books' "
+ "xmlns:isbn='urn:ISBN:0-395-36341-6'>"
+ "<title>Cheaper by the Dozen</title>"
+ "<isbn:number>1568491379</isbn:number>"
+ "<notes>"
+ "<!-- make HTML the default namespace for some commentary -->"
+ "<p xmlns='urn:w3-org-ns:HTML'>"
+ "This is a <i>funny</i> book!"
+ "</p>"
+ "</notes>"
+ "</book>") '()
+ '(*TOP* (urn:loc.gov:books:book
+ (urn:loc.gov:books:title "Cheaper by the Dozen")
+ (urn:ISBN:0-395-36341-6:number "1568491379")
+ (urn:loc.gov:books:notes
+ (urn:w3-org-ns:HTML:p
+ "This is a " (urn:w3-org-ns:HTML:i "funny")
+ " book!")))))
+
+ (test (string-append
+ "<Beers>"
+ "<!-- the default namespace is now that of HTML -->"
+ "<table xmlns='http://www.w3.org/TR/REC-html40'>"
+ "<th><td>Name</td><td>Origin</td><td>Description</td></th>"
+ "<tr>"
+ "<!-- no default namespace inside table cells -->"
+ "<td><brandName xmlns=\"\">Huntsman</brandName></td>"
+ "<td><origin xmlns=''>Bath, UK</origin></td>"
+ "<td>"
+ "<details xmlns=''><class>Bitter</class><hop>Fuggles</hop>"
+ "<pro>Wonderful hop, light alcohol, good summer beer</pro>"
+ "<con>Fragile; excessive variance pub to pub</con>"
+ "</details>"
+ "</td>"
+ "</tr>"
+ "</table>"
+ "</Beers>")
+ '((html . "http://www.w3.org/TR/REC-html40";))
+ '(*TOP*
+ (@ (*NAMESPACES* (html "http://www.w3.org/TR/REC-html40";)))
+ (Beers (html:table
+ (html:th (html:td "Name")
+ (html:td "Origin")
+ (html:td "Description"))
+ (html:tr (html:td (brandName "Huntsman"))
+ (html:td (origin "Bath, UK"))
+ (html:td
+ (details
+ (class "Bitter")
+ (hop "Fuggles")
+ (pro "Wonderful hop, light alcohol, good summer beer")
+ (con "Fragile; excessive variance pub to pub"))))))))
+
+ (test (string-append
+ "<!-- 1 --><RESERVATION xmlns:HTML='http://www.w3.org/TR/REC-html40'>"
+ "<!-- 2 --><NAME HTML:CLASS=\"largeSansSerif\">Layman, A</NAME>"
+ "<!-- 3 --><SEAT CLASS='Y' HTML:CLASS=\"largeMonotype\">33B</SEAT>"
+ "<!-- 4 --><HTML:A HREF='/cgi-bin/ResStatus'>Check Status</HTML:A>"
+ "<!-- 5 --><DEPARTURE>1997-05-24T07:55:00+1</DEPARTURE></RESERVATION>")
+ '((HTML . "http://www.w3.org/TR/REC-html40";))
+ '(*TOP*
+ (@ (*NAMESPACES* (HTML "http://www.w3.org/TR/REC-html40";)))
+ (RESERVATION
+ (NAME (@ (HTML:CLASS "largeSansSerif")) "Layman, A")
+ (SEAT (@ (HTML:CLASS "largeMonotype") (CLASS "Y")) "33B")
+ (HTML:A (@ (HREF "/cgi-bin/ResStatus")) "Check Status")
+ (DEPARTURE "1997-05-24T07:55:00+1"))))
+ ; Part of RDF from the XML Infoset
+ (test (string-concatenate/shared '(
+ "<?xml version='1.0' encoding='utf-8' standalone='yes'?>"
+ "<!-- this can be decoded as US-ASCII or iso-8859-1 as well,"
+ " since it contains no characters outside the US-ASCII repertoire -->"
+ "<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'"
+ " xmlns:rdfs='http://www.w3.org/2000/01/rdf-schema#'"
+ " xmlns='http://www.w3.org/2001/02/infoset#'>"
+ "<rdfs:Class ID='Boolean'/>"
+ "<Boolean ID='Boolean.true'/>"
+ "<Boolean ID='Boolean.false'/>"
+ "<!--Info item classes-->"
+ "<rdfs:Class ID='InfoItem'/>"
+ "<rdfs:Class ID='Document' rdfs:subClassOf='#InfoItem'/>"
+ "<rdfs:Class ID='Element' rdfs:subClassOf='#InfoItem'/>"
+ "<rdfs:Class ID='Attribute' rdfs:subClassOf='#InfoItem'/>"
+ "<rdfs:Class ID='InfoItemSet'
+ rdfs:subClassOf='http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag'/>"
+ "<rdfs:Class ID='AttributeSet' rdfs:subClassOf='#InfoItemSet'/>"
+ "<!--Info item properties-->"
+ "<rdfs:Property ID='allDeclarationsProcessed'>"
+ "<rdfs:domain resource='#Document'/>"
+ "<rdfs:range resource='#Boolean'/></rdfs:Property>"
+ "<rdfs:Property ID='attributes'>"
+ "<rdfs:domain resource='#Element'/>"
+ "<rdfs:range resource='#AttributeSet'/>"
+ "</rdfs:Property>"
+ "</rdf:RDF>"))
+ '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#";)
+ (RDFS . "http://www.w3.org/2000/01/rdf-schema#";)
+ (ISET . "http://www.w3.org/2001/02/infoset#";))
+ '(*TOP* (@ (*NAMESPACES*
+ (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#";)
+ (RDFS "http://www.w3.org/2000/01/rdf-schema#";)
+ (ISET "http://www.w3.org/2001/02/infoset#";)))
+ (*PI* xml "version='1.0' encoding='utf-8' standalone='yes'")
+ (RDF:RDF
+ (RDFS:Class (@ (ID "Boolean")))
+ (ISET:Boolean (@ (ID "Boolean.true")))
+ (ISET:Boolean (@ (ID "Boolean.false")))
+ (RDFS:Class (@ (ID "InfoItem")))
+ (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Document")))
+ (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Element")))
+ (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Attribute")))
+ (RDFS:Class
+ (@ (RDFS:subClassOf
+ "http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag";)
+ (ID "InfoItemSet")))
+ (RDFS:Class
+ (@ (RDFS:subClassOf "#InfoItemSet") (ID "AttributeSet")))
+ (RDFS:Property
+ (@ (ID "allDeclarationsProcessed"))
+ (RDFS:domain (@ (resource "#Document")))
+ (RDFS:range (@ (resource "#Boolean"))))
+ (RDFS:Property
+ (@ (ID "attributes"))
+ (RDFS:domain (@ (resource "#Element")))
+ (RDFS:range (@ (resource "#AttributeSet")))))))
+
+ ; Part of RDF from RSS of the Daemon News Mall
+ (test (string-concatenate/shared (list-intersperse '(
+ "<?xml version='1.0'?><rdf:RDF "
+ "xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' "
+ "xmlns='http://my.netscape.com/rdf/simple/0.9/'>"
+ "<channel>"
+ "<title>Daemon News Mall</title>"
+ "<link>http://mall.daemonnews.org/</link>"
+ "<description>Central source for all your BSD needs</description>"
+ "</channel>"
+ "<item>"
+ "<title>Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95</title>"
+
"<link>http://mall.daemonnews.org/?page=shop/flypage&product_id=880</link>"
+ "</item>"
+ "<item>"
+ "<title>The Design and Implementation of the 4.4BSD Operating System
$54.95</title>"
+
"<link>http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761</link>"
+ "</item>"
+ "</rdf:RDF>")
+ (string #\newline)
+ ))
+ '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#";)
+ (RSS . "http://my.netscape.com/rdf/simple/0.9/";)
+ (ISET . "http://www.w3.org/2001/02/infoset#";))
+ `(*TOP* (@ (*NAMESPACES*
+ (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#";)
+ (RSS "http://my.netscape.com/rdf/simple/0.9/";)
+ (ISET "http://www.w3.org/2001/02/infoset#";)))
+ (*PI* xml "version='1.0'")
+ (RDF:RDF ,nl
+ (RSS:channel ,nl
+ (RSS:title "Daemon News Mall") ,nl
+ (RSS:link "http://mall.daemonnews.org/";) ,nl
+ (RSS:description "Central source for all your BSD needs")
,nl) ,nl
+ (RSS:item ,nl
+ (RSS:title
+ "Daemon News Jan/Feb Issue NOW Available! Subscribe
$24.95") ,nl
+ (RSS:link
+
"http://mall.daemonnews.org/?page=shop/flypage&product_id=880";) ,nl) ,nl
+ (RSS:item ,nl
+ (RSS:title
+ "The Design and Implementation of the 4.4BSD Operating
System $54.95") ,nl
+ (RSS:link
+
"http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761";)
,nl) ,nl)))
+
+ (test (string-concatenate/shared
+ '("<Forecasts TStamp='958082142'>"
+ "<TAF TStamp='958066200' LatLon='36.583, -121.850' BId='724915'"
+ " SName='KMRY, MONTEREY PENINSULA'>"
+ "<VALID TRange='958068000, 958154400'>111730Z 111818</VALID>"
+ "<PERIOD TRange='958068000, 958078800'>"
+ "<PREVAILING>31010KT P6SM FEW030</PREVAILING>"
+ "</PERIOD>"
+ "<PERIOD TRange='958078800, 958104000' Title='FM2100'>"
+ "<PREVAILING>29016KT P6SM FEW040</PREVAILING>"
+ "</PERIOD>"
+ "<PERIOD TRange='958104000, 958154400' Title='FM0400'>"
+ "<PREVAILING>29010KT P6SM SCT200</PREVAILING>"
+ "<VAR Title='BECMG 0708' TRange='958114800, 958118400'>VRB05KT</VAR>"
+ "</PERIOD></TAF>"
+ "</Forecasts>"))
+ '()
+ '(*TOP* (Forecasts
+ (@ (TStamp "958082142"))
+ (TAF (@ (TStamp "958066200")
+ (SName "KMRY, MONTEREY PENINSULA")
+ (LatLon "36.583, -121.850")
+ (BId "724915"))
+ (VALID (@ (TRange "958068000, 958154400")) "111730Z 111818")
+ (PERIOD (@ (TRange "958068000, 958078800"))
+ (PREVAILING "31010KT P6SM FEW030"))
+ (PERIOD (@ (Title "FM2100") (TRange "958078800, 958104000"))
+ (PREVAILING "29016KT P6SM FEW040"))
+ (PERIOD (@ (Title "FM0400") (TRange "958104000, 958154400"))
+ (PREVAILING "29010KT P6SM SCT200")
+ (VAR (@ (Title "BECMG 0708")
+ (TRange "958114800, 958118400"))
+ "VRB05KT"))))))
+))
+
+(run-test
+ (newline)
+ (display "All tests passed")
+ (newline)
+)
diff --git a/module/sxml/upstream/SXML-tree-trans.scm
b/module/sxml/upstream/SXML-tree-trans.scm
new file mode 100644
index 0000000..f2c3293
--- /dev/null
+++ b/module/sxml/upstream/SXML-tree-trans.scm
@@ -0,0 +1,249 @@
+; XML/HTML processing in Scheme
+; SXML expression tree transformers
+;
+; IMPORT
+; A prelude appropriate for your Scheme system
+; (myenv-bigloo.scm, myenv-mit.scm, etc.)
+;
+; EXPORT
+; (provide SRV:send-reply
+; post-order pre-post-order replace-range)
+;
+; See vSXML-tree-trans.scm for the validation code, which also
+; serves as usage examples.
+;
+; $Id: SXML-tree-trans.scm,v 1.6 2003/04/25 19:16:15 oleg Exp $
+
+
+; Output the 'fragments'
+; The fragments are a list of strings, characters,
+; numbers, thunks, #f, #t -- and other fragments.
+; The function traverses the tree depth-first, writes out
+; strings and characters, executes thunks, and ignores
+; #f and '().
+; The function returns #t if anything was written at all;
+; otherwise the result is #f
+; If #t occurs among the fragments, it is not written out
+; but causes the result of SRV:send-reply to be #t
+
+(define (SRV:send-reply . fragments)
+ (let loop ((fragments fragments) (result #f))
+ (cond
+ ((null? fragments) result)
+ ((not (car fragments)) (loop (cdr fragments) result))
+ ((null? (car fragments)) (loop (cdr fragments) result))
+ ((eq? #t (car fragments)) (loop (cdr fragments) #t))
+ ((pair? (car fragments))
+ (loop (cdr fragments) (loop (car fragments) result)))
+ ((procedure? (car fragments))
+ ((car fragments))
+ (loop (cdr fragments) #t))
+ (else
+ (display (car fragments))
+ (loop (cdr fragments) #t)))))
+
+
+
+;------------------------------------------------------------------------
+; Traversal of an SXML tree or a grove:
+; a <Node> or a <Nodelist>
+;
+; A <Node> and a <Nodelist> are mutually-recursive datatypes that
+; underlie the SXML tree:
+; <Node> ::= (name . <Nodelist>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; <Nodelist> ::= (<Node> ...)
+; Nodelists, and Nodes other than text strings are both lists. A
+; <Nodelist> however is either an empty list, or a list whose head is
+; not a symbol (an atom in general). A symbol at the head of a node is
+; either an XML name (in which case it's a tag of an XML element), or
+; an administrative name such as '@'.
+; See SXPath.scm and SSAX.scm for more information on SXML.
+
+
+; Pre-Post-order traversal of a tree and creation of a new tree:
+; pre-post-order:: <tree> x <bindings> -> <new-tree>
+; where
+; <bindings> ::= (<binding> ...)
+; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
+; (<trigger-symbol> *macro* . <handler>) |
+; (<trigger-symbol> <new-bindings> . <handler>) |
+; (<trigger-symbol> . <handler>)
+; <trigger-symbol> ::= XMLname | *text* | *default*
+; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
+;
+; The pre-post-order function visits the nodes and nodelists
+; pre-post-order (depth-first). For each <Node> of the form (name
+; <Node> ...) it looks up an association with the given 'name' among
+; its <bindings>. If failed, pre-post-order tries to locate a
+; *default* binding. It's an error if the latter attempt fails as
+; well. Having found a binding, the pre-post-order function first
+; checks to see if the binding is of the form
+; (<trigger-symbol> *preorder* . <handler>)
+; If it is, the handler is 'applied' to the current node. Otherwise,
+; the pre-post-order function first calls itself recursively for each
+; child of the current node, with <new-bindings> prepended to the
+; <bindings> in effect. The result of these calls is passed to the
+; <handler> (along with the head of the current <Node>). To be more
+; precise, the handler is _applied_ to the head of the current node
+; and its processed children. The result of the handler, which should
+; also be a <tree>, replaces the current <Node>. If the current <Node>
+; is a text string or other atom, a special binding with a symbol
+; *text* is looked up.
+;
+; A binding can also be of a form
+; (<trigger-symbol> *macro* . <handler>)
+; This is equivalent to *preorder* described above. However, the result
+; is re-processed again, with the current stylesheet.
+
+(define (pre-post-order tree bindings)
+ (let* ((default-binding (assq '*default* bindings))
+ (text-binding (or (assq '*text* bindings) default-binding))
+ (text-handler ; Cache default and text bindings
+ (and text-binding
+ (if (procedure? (cdr text-binding))
+ (cdr text-binding) (cddr text-binding)))))
+ (let loop ((tree tree))
+ (cond
+ ((null? tree) '())
+ ((not (pair? tree))
+ (let ((trigger '*text*))
+ (if text-handler (text-handler trigger tree)
+ (error "Unknown binding for " trigger " and no default"))))
+ ((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
+ (else ; tree is an SXML node
+ (let* ((trigger (car tree))
+ (binding (or (assq trigger bindings) default-binding)))
+ (cond
+ ((not binding)
+ (error "Unknown binding for " trigger " and no default"))
+ ((not (pair? (cdr binding))) ; must be a procedure: handler
+ (apply (cdr binding) trigger (map loop (cdr tree))))
+ ((eq? '*preorder* (cadr binding))
+ (apply (cddr binding) tree))
+ ((eq? '*macro* (cadr binding))
+ (loop (apply (cddr binding) tree)))
+ (else ; (cadr binding) is a local binding
+ (apply (cddr binding) trigger
+ (pre-post-order (cdr tree) (append (cadr binding) bindings)))
+ ))))))))
+
+; post-order is a strict subset of pre-post-order without *preorder*
+; (let alone *macro*) traversals.
+; Now pre-post-order is actually faster than the old post-order.
+; The function post-order is deprecated and is aliased below for
+; backward compatibility.
+(define post-order pre-post-order)
+
+;------------------------------------------------------------------------
+; Extended tree fold
+; tree = atom | (node-name tree ...)
+;
+; foldts fdown fup fhere seed (Leaf str) = fhere seed str
+; foldts fdown fup fhere seed (Nd kids) =
+; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
+
+; procedure fhere: seed -> atom -> seed
+; procedure fdown: seed -> node -> seed
+; procedure fup: parent-seed -> last-kid-seed -> node -> seed
+; foldts returns the final seed
+
+(define (foldts fdown fup fhere seed tree)
+ (cond
+ ((null? tree) seed)
+ ((not (pair? tree)) ; An atom
+ (fhere seed tree))
+ (else
+ (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
+ (if (null? kids)
+ (fup seed kid-seed tree)
+ (loop (foldts fdown fup fhere kid-seed (car kids))
+ (cdr kids)))))))
+
+;------------------------------------------------------------------------
+; Traverse a forest depth-first and cut/replace ranges of nodes.
+;
+; The nodes that define a range don't have to have the same immediate
+; parent, don't have to be on the same level, and the end node of a
+; range doesn't even have to exist. A replace-range procedure removes
+; nodes from the beginning node of the range up to (but not including)
+; the end node of the range. In addition, the beginning node of the
+; range can be replaced by a node or a list of nodes. The range of
+; nodes is cut while depth-first traversing the forest. If all
+; branches of the node are cut a node is cut as well. The procedure
+; can cut several non-overlapping ranges from a forest.
+
+; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+; where
+; type FOREST = (NODE ...)
+; type NODE = Atom | (Name . FOREST) | FOREST
+;
+; The range of nodes is specified by two predicates, beg-pred and end-pred.
+; beg-pred:: NODE -> #f | FOREST
+; end-pred:: NODE -> #f | FOREST
+; The beg-pred predicate decides on the beginning of the range. The node
+; for which the predicate yields non-#f marks the beginning of the range
+; The non-#f value of the predicate replaces the node. The value can be a
+; list of nodes. The replace-range procedure then traverses the tree and skips
+; all the nodes, until the end-pred yields non-#f. The value of the end-pred
+; replaces the end-range node. The new end node and its brothers will be
+; re-scanned.
+; The predicates are evaluated pre-order. We do not descend into a node that
+; is marked as the beginning of the range.
+
+(define (replace-range beg-pred end-pred forest)
+
+ ; loop forest keep? new-forest
+ ; forest is the forest to traverse
+ ; new-forest accumulates the nodes we will keep, in the reverse
+ ; order
+ ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
+ ; traverse its children and keep those that are not in the skip range.
+ ; If keep? is #f, skip the current node if atomic. Otherwise,
+ ; traverse its children. If all children are skipped, skip the node
+ ; as well.
+
+ (define (loop forest keep? new-forest)
+ (if (null? forest) (values (reverse new-forest) keep?)
+ (let ((node (car forest)))
+ (if keep?
+ (cond ; accumulate mode
+ ((beg-pred node) => ; see if the node starts the skip range
+ (lambda (repl-branches) ; if so, skip/replace the node
+ (loop (cdr forest) #f
+ (append (reverse repl-branches) new-forest))))
+ ((not (pair? node)) ; it's an atom, keep it
+ (loop (cdr forest) keep? (cons node new-forest)))
+ (else
+ (let*-values
+ (((node?) (symbol? (car node))) ; or is it a nodelist?
+ ((new-kids keep?) ; traverse its children
+ (loop (if node? (cdr node) node) #t '())))
+ (loop (cdr forest) keep?
+ (cons
+ (if node? (cons (car node) new-kids) new-kids)
+ new-forest)))))
+ ; skip mode
+ (cond
+ ((end-pred node) => ; end the skip range
+ (lambda (repl-branches) ; repl-branches will be re-scanned
+ (loop (append repl-branches (cdr forest)) #t
+ new-forest)))
+ ((not (pair? node)) ; it's an atom, skip it
+ (loop (cdr forest) keep? new-forest))
+ (else
+ (let*-values
+ (((node?) (symbol? (car node))) ; or is it a nodelist?
+ ((new-kids keep?) ; traverse its children
+ (loop (if node? (cdr node) node) #f '())))
+ (loop (cdr forest) keep?
+ (if (or keep? (pair? new-kids))
+ (cons
+ (if node? (cons (car node) new-kids) new-kids)
+ new-forest)
+ new-forest) ; if all kids are skipped
+ )))))))) ; skip the node too
+
+ (let*-values (((new-forest keep?) (loop forest #t '())))
+ new-forest))
+
diff --git a/module/sxml/upstream/SXPath-old.scm
b/module/sxml/upstream/SXPath-old.scm
new file mode 100644
index 0000000..cf4526e
--- /dev/null
+++ b/module/sxml/upstream/SXPath-old.scm
@@ -0,0 +1,1216 @@
+; XML processing in Scheme
+; SXPath -- SXML Query Language
+;
+; SXPath is a query language for SXML, an instance of XML Information
+; set (Infoset) in the form of s-expressions. See SSAX.scm for the
+; definition of SXML and more details. SXPath is also a translation into
+; Scheme of an XML Path Language, XPath:
+; http://www.w3.org/TR/xpath
+; XPath and SXPath describe means of selecting a set of Infoset's items
+; or their properties.
+;
+; To facilitate queries, XPath maps the XML Infoset into an explicit
+; tree, and introduces important notions of a location path and a
+; current, context node. A location path denotes a selection of a set of
+; nodes relative to a context node. Any XPath tree has a distinguished,
+; root node -- which serves as the context node for absolute location
+; paths. Location path is recursively defined as a location step joined
+; with a location path. A location step is a simple query of the
+; database relative to a context node. A step may include expressions
+; that further filter the selected set. Each node in the resulting set
+; is used as a context node for the adjoining location path. The result
+; of the step is a union of the sets returned by the latter location
+; paths.
+;
+; The SXML representation of the XML Infoset (see SSAX.scm) is rather
+; suitable for querying as it is. Bowing to the XPath specification,
+; we will refer to SXML information items as 'Nodes':
+; <Node> ::= <Element> | <attributes-coll> | <attrib>
+; | "text string" | <PI>
+; This production can also be described as
+; <Node> ::= (name . <Nodeset>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; <Nodeset> ::= (<Node> ...)
+; Nodesets, and Nodes other than text strings are both lists. A
+; <Nodeset> however is either an empty list, or a list whose head is not
+; a symbol. A symbol at the head of a node is either an XML name (in
+; which case it's a tag of an XML element), or an administrative name
+; such as '@'. This uniform list representation makes processing rather
+; simple and elegant, while avoiding confusion. The multi-branch tree
+; structure formed by the mutually-recursive datatypes <Node> and
+; <Nodeset> lends itself well to processing by functional languages.
+;
+; A location path is in fact a composite query over an XPath tree or
+; its branch. A singe step is a combination of a projection, selection
+; or a transitive closure. Multiple steps are combined via join and
+; union operations. This insight allows us to _elegantly_ implement
+; XPath as a sequence of projection and filtering primitives --
+; converters -- joined by _combinators_. Each converter takes a node
+; and returns a nodeset which is the result of the corresponding query
+; relative to that node. A converter can also be called on a set of
+; nodes. In that case it returns a union of the corresponding queries over
+; each node in the set. The union is easily implemented as a list
+; append operation as all nodes in a SXML tree are considered
+; distinct, by XPath conventions. We also preserve the order of the
+; members in the union. Query combinators are high-order functions:
+; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
+; and compose or otherwise combine them. We will be concerned with
+; only relative location paths [XPath]: an absolute location path is a
+; relative path applied to the root node.
+;
+; Similarly to XPath, SXPath defines full and abbreviated notations
+; for location paths. In both cases, the abbreviated notation can be
+; mechanically expanded into the full form by simple rewriting
+; rules. In case of SXPath the corresponding rules are given as
+; comments to a sxpath function, below. The regression test suite at
+; the end of this file shows a representative sample of SXPaths in
+; both notations, juxtaposed with the corresponding XPath
+; expressions. Most of the samples are borrowed literally from the
+; XPath specification, while the others are adjusted for our running
+; example, tree1.
+;
+; To do:
+; Rename filter to node-filter or ns-filter
+; Use ;=== for chapters, ;--- for sections, and ;^^^ for end sections
+;
+; $Id: SXPath-old.scm,v 1.4 2004/07/07 16:02:31 sperber Exp $
+
+
+ ; See http://pobox.com/~oleg/ftp/Scheme/myenv.scm
+ ; See http://pobox.com/~oleg/ftp/Scheme/myenv-scm.scm
+ ; See http://pobox.com/~oleg/ftp/Scheme/myenv-bigloo.scm
+;(module SXPath
+; (include "myenv-bigloo.scm")) ; For use with Bigloo 2.2b
+;(load "myenv-scm.scm") ; For use with SCM v5d2
+;(include "myenv.scm") ; For use with Gambit-C 3.0
+
+
+
+(define (nodeset? x)
+ (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+
+;-------------------------
+; Basic converters and applicators
+; A converter is a function
+; type Converter = Node|Nodeset -> Nodeset
+; A converter can also play a role of a predicate: in that case, if a
+; converter, applied to a node or a nodeset, yields a non-empty
+; nodeset, the converter-predicate is deemed satisfied. Throughout
+; this file a nil nodeset is equivalent to #f in denoting a failure.
+
+; The following function implements a 'Node test' as defined in
+; Sec. 2.3 of XPath document. A node test is one of the components of a
+; location step. It is also a converter-predicate in SXPath.
+;
+; The function node-typeof? takes a type criterion and returns a function,
+; which, when applied to a node, will tell if the node satisfies
+; the test.
+; node-typeof? :: Crit -> Node -> Boolean
+;
+; The criterion 'crit' is a symbol, one of the following:
+; id - tests if the Node has the right name (id)
+; @ - tests if the Node is an <attributes-coll>
+; * - tests if the Node is an <Element>
+; *text* - tests if the Node is a text node
+; *PI* - tests if the Node is a PI node
+; *any* - #t for any type of Node
+
+(define (node-typeof? crit)
+ (lambda (node)
+ (case crit
+ ((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
+ ((*any*) #t)
+ ((*text*) (string? node))
+ (else
+ (and (pair? node) (eq? crit (car node))))
+)))
+
+
+; Curried equivalence converter-predicates
+(define (node-eq? other)
+ (lambda (node)
+ (eq? other node)))
+
+(define (node-equal? other)
+ (lambda (node)
+ (equal? other node)))
+
+; node-pos:: N -> Nodeset -> Nodeset, or
+; node-pos:: N -> Converter
+; Select the N'th element of a Nodeset and return as a singular Nodeset;
+; Return an empty nodeset if the Nth element does not exist.
+; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
+; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
+; exists.
+; N can also be a negative number: in that case the node is picked from
+; the tail of the list.
+; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
+; ((node-pos -2) Nodeset) selects the last but one node, if exists.
+
+(define (node-pos n)
+ (lambda (nodeset)
+ (cond
+ ((not (nodeset? nodeset)) '())
+ ((null? nodeset) nodeset)
+ ((eqv? n 1) (list (car nodeset)))
+ ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
+ (else
+ (assert (positive? n))
+ ((node-pos (dec n)) (cdr nodeset))))))
+
+; filter:: Converter -> Converter
+; A filter applicator, which introduces a filtering context. The argument
+; converter is considered a predicate, with either #f or nil result meaning
+; failure.
+(define (filter pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((pred-result (pred? (car lst))))
+ (loop (cdr lst)
+ (if (and pred-result (not (null? pred-result)))
+ (cons (car lst) res)
+ res)))))))
+
+; take-until:: Converter -> Converter, or
+; take-until:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have been processed
+; till that moment (that is, which fail the predicate).
+; take-until is a variation of the filter above: take-until passes
+; elements of an ordered input set till (but not including) the first
+; element that satisfies the predicate.
+; The nodeset returned by ((take-until (not pred)) nset) is a subset --
+; to be more precise, a prefix -- of the nodeset returned by
+; ((filter pred) nset)
+
+(define (take-until pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (if (nodeset? lst) lst (list lst))))
+ (if (null? lst) lst
+ (let ((pred-result (pred? (car lst))))
+ (if (and pred-result (not (null? pred-result)))
+ '()
+ (cons (car lst) (loop (cdr lst)))))
+ ))))
+
+
+; take-after:: Converter -> Converter, or
+; take-after:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have not been processed:
+; that is, return the elements of the input nodeset that follow the first
+; element that satisfied the predicate.
+; take-after along with take-until partition an input nodeset into three
+; parts: the first element that satisfies a predicate, all preceding
+; elements and all following elements.
+
+(define (take-after pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (if (nodeset? lst) lst (list lst))))
+ (if (null? lst) lst
+ (let ((pred-result (pred? (car lst))))
+ (if (and pred-result (not (null? pred-result)))
+ (cdr lst)
+ (loop (cdr lst))))
+ ))))
+
+; Apply proc to each element of lst and return the list of results.
+; if proc returns a nodeset, splice it into the result
+;
+; From another point of view, map-union is a function Converter->Converter,
+; which places an argument-converter in a joining context.
+
+(define (map-union proc lst)
+ (if (null? lst) lst
+ (let ((proc-res (proc (car lst))))
+ ((if (nodeset? proc-res) append cons)
+ proc-res (map-union proc (cdr lst))))))
+
+; node-reverse :: Converter, or
+; node-reverse:: Node|Nodeset -> Nodeset
+; Reverses the order of nodes in the nodeset
+; This basic converter is needed to implement a reverse document order
+; (see the XPath Recommendation).
+(define node-reverse
+ (lambda (node-or-nodeset)
+ (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
+ (reverse node-or-nodeset))))
+
+; node-trace:: String -> Converter
+; (node-trace title) is an identity converter. In addition it prints out
+; a node or nodeset it is applied to, prefixed with the 'title'.
+; This converter is very useful for debugging.
+
+(define (node-trace title)
+ (lambda (node-or-nodeset)
+ (cout nl "-->")
+ (display title)
+ (display " :")
+ (pretty-print node-or-nodeset)
+ node-or-nodeset))
+
+
+;-------------------------
+; Converter combinators
+;
+; Combinators are higher-order functions that transmogrify a converter
+; or glue a sequence of converters into a single, non-trivial
+; converter. The goal is to arrive at converters that correspond to
+; XPath location paths.
+;
+; From a different point of view, a combinator is a fixed, named
+; _pattern_ of applying converters. Given below is a complete set of
+; such patterns that together implement XPath location path
+; specification. As it turns out, all these combinators can be built
+; from a small number of basic blocks: regular functional composition,
+; map-union and filter applicators, and the nodeset union.
+
+
+
+; select-kids:: Pred -> Node -> Nodeset
+; Given a Node, return an (ordered) subset its children that satisfy
+; the Pred (a converter, actually)
+; select-kids:: Pred -> Nodeset -> Nodeset
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+;
+; More succinctly, the signature of this function is
+; select-kids:: Converter -> Converter
+
+(define (select-kids test-pred?)
+ (lambda (node) ; node or node-set
+ (cond
+ ((null? node) node)
+ ((not (pair? node)) '()) ; No children
+ ((symbol? (car node))
+ ((filter test-pred?) (cdr node))) ; it's a single node
+ (else (map-union (select-kids test-pred?) node)))))
+
+
+; node-self:: Pred -> Node -> Nodeset, or
+; node-self:: Converter -> Converter
+; Similar to select-kids but apply to the Node itself rather
+; than to its children. The resulting Nodeset will contain either one
+; component, or will be empty (if the Node failed the Pred).
+(define node-self filter)
+
+
+; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-join:: [Converter] -> Converter
+; join the sequence of location steps or paths as described
+; in the title comments above.
+(define (node-join . selectors)
+ (lambda (nodeset) ; Nodeset or node
+ (let loop ((nodeset nodeset) (selectors selectors))
+ (if (null? selectors) nodeset
+ (loop
+ (if (nodeset? nodeset)
+ (map-union (car selectors) nodeset)
+ ((car selectors) nodeset))
+ (cdr selectors))))))
+
+
+; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-reduce:: [Converter] -> Converter
+; A regular functional composition of converters.
+; From a different point of view,
+; ((apply node-reduce converters) nodeset)
+; is equivalent to
+; (foldl apply nodeset converters)
+; i.e., folding, or reducing, a list of converters with the nodeset
+; as a seed.
+(define (node-reduce . converters)
+ (lambda (nodeset) ; Nodeset or node
+ (let loop ((nodeset nodeset) (converters converters))
+ (if (null? converters) nodeset
+ (loop ((car converters) nodeset) (cdr converters))))))
+
+
+; node-or:: [Converter] -> Converter
+; This combinator applies all converters to a given node and
+; produces the union of their results.
+; This combinator corresponds to a union, '|' operation for XPath
+; location paths.
+; (define (node-or . converters)
+; (lambda (node-or-nodeset)
+; (if (null? converters) node-or-nodeset
+; (append
+; ((car converters) node-or-nodeset)
+; ((apply node-or (cdr converters)) node-or-nodeset)))))
+; More optimal implementation follows
+(define (node-or . converters)
+ (lambda (node-or-nodeset)
+ (let loop ((result '()) (converters converters))
+ (if (null? converters) result
+ (loop (append result (or ((car converters) node-or-nodeset) '()))
+ (cdr converters))))))
+
+
+; node-closure:: Converter -> Converter
+; Select all _descendants_ of a node that satisfy a converter-predicate.
+; This combinator is similar to select-kids but applies to
+; grand... children as well.
+; This combinator implements the "descendant::" XPath axis
+; Conceptually, this combinator can be expressed as
+; (define (node-closure f)
+; (node-or
+; (select-kids f)
+; (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
+; This definition, as written, looks somewhat like a fixpoint, and it
+; will run forever. It is obvious however that sooner or later
+; (select-kids (node-typeof? '*)) will return an empty nodeset. At
+; this point further iterations will no longer affect the result and
+; can be stopped.
+
+(define (node-closure test-pred?)
+ (lambda (node) ; Nodeset or node
+ (let loop ((parent node) (result '()))
+ (if (null? parent) result
+ (loop ((select-kids (node-typeof? '*)) parent)
+ (append result
+ ((select-kids test-pred?) parent)))
+ ))))
+
+; node-parent:: RootNode -> Converter
+; (node-parent rootnode) yields a converter that returns a parent of a
+; node it is applied to. If applied to a nodeset, it returns the list
+; of parents of nodes in the nodeset. The rootnode does not have
+; to be the root node of the whole SXML tree -- it may be a root node
+; of a branch of interest.
+; Given the notation of Philip Wadler's paper on semantics of XSLT,
+; parent(x) = { y | y=subnode*(root), x=subnode(y) }
+; Therefore, node-parent is not the fundamental converter: it can be
+; expressed through the existing ones. Yet node-parent is a rather
+; convenient converter. It corresponds to a parent:: axis of SXPath.
+; Note that the parent:: axis can be used with an attribute node as well!
+
+(define (node-parent rootnode)
+ (lambda (node) ; Nodeset or node
+ (if (nodeset? node) (map-union (node-parent rootnode) node)
+ (let ((pred
+ (node-or
+ (node-reduce
+ (node-self (node-typeof? '*))
+ (select-kids (node-eq? node)))
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-eq? node))))))
+ ((node-or
+ (node-self pred)
+ (node-closure pred))
+ rootnode)))))
+
+;-------------------------
+; Evaluate an abbreviated SXPath
+; sxpath:: AbbrPath -> Converter, or
+; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
+; AbbrPath is a list. It is translated to the full SXPath according
+; to the following rewriting rules
+; (sxpath '()) -> (node-join)
+; (sxpath '(path-component ...)) ->
+; (node-join (sxpath1 path-component) (sxpath '(...)))
+; (sxpath1 '//) -> (node-or
+; (node-self (node-typeof? '*any*))
+; (node-closure (node-typeof? '*any*)))
+; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
+; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x))
+; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol)
+; (sxpath1 procedure) -> procedure
+; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
+; (sxpath1 '(path reducer ...)) ->
+; (node-reduce (sxpath path) (sxpathr reducer) ...)
+; (sxpathr number) -> (node-pos number)
+; (sxpathr path-filter) -> (filter (sxpath path-filter))
+
+(define (sxpath path)
+ (lambda (nodeset)
+ (let loop ((nodeset nodeset) (path path))
+ (cond
+ ((null? path) nodeset)
+ ((nodeset? nodeset)
+ (map-union (sxpath path) nodeset))
+ ((procedure? (car path))
+ (loop ((car path) nodeset) (cdr path)))
+ ((eq? '// (car path))
+ (loop
+ ((if (nodeset? nodeset) append cons) nodeset
+ ((node-closure (node-typeof? '*any*)) nodeset))
+ (cdr path)))
+ ((symbol? (car path))
+ (loop ((select-kids (node-typeof? (car path))) nodeset)
+ (cdr path)))
+ ((and (pair? (car path)) (eq? 'equal? (caar path)))
+ (loop ((select-kids (apply node-equal? (cdar path))) nodeset)
+ (cdr path)))
+ ((and (pair? (car path)) (eq? 'eq? (caar path)))
+ (loop ((select-kids (apply node-eq? (cdar path))) nodeset)
+ (cdr path)))
+ ((pair? (car path))
+ (let reducer ((nodeset
+ (if (symbol? (caar path))
+ ((select-kids (node-typeof? (caar path))) nodeset)
+ (loop nodeset (caar path))))
+ (reducing-path (cdar path)))
+ (cond
+ ((null? reducing-path) (loop nodeset (cdr path)))
+ ((number? (car reducing-path))
+ (reducer ((node-pos (car reducing-path)) nodeset)
+ (cdr reducing-path)))
+ (else
+ (reducer ((filter (sxpath (car reducing-path))) nodeset)
+ (cdr reducing-path))))))
+ (else
+ (error "Invalid path step: " (car path)))
+))))
+
+;------------------------------------------------------------------------
+; Sample XPath/SXPath expressions: regression test suite for the
+; implementation above.
+
+; A running example
+
+(define tree1
+ '(html
+ (head (title "Slides"))
+ (body
+ (p (@ (align "center"))
+ (table (@ (style "font-size: x-large"))
+ (tr
+ (td (@ (align "right")) "Talks ")
+ (td (@ (align "center")) " = ")
+ (td " slides + transition"))
+ (tr (td)
+ (td (@ (align "center")) " = ")
+ (td " data + control"))
+ (tr (td)
+ (td (@ (align "center")) " = ")
+ (td " programs"))))
+ (ul
+ (li (a (@ (href "slides/slide0001.gif")) "Introduction"))
+ (li (a (@ (href "slides/slide0010.gif")) "Summary")))
+ )))
+
+
+; Example from a posting "Re: DrScheme and XML",
+; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
+; http://www.deja.com/getdoc.xp?AN=553507805
+(define tree3
+ '(poem (@ (title "The Lovesong of J. Alfred Prufrock")
+ (poet "T. S. Eliot"))
+ (stanza
+ (line "Let us go then, you and I,")
+ (line "When the evening is spread out against the sky")
+ (line "Like a patient etherized upon a table:"))
+ (stanza
+ (line "In the room the women come and go")
+ (line "Talking of Michaelangelo."))))
+
+; Validation Test harness
+
+(define-syntax run-test
+ (syntax-rules (define)
+ ((run-test "scan-exp" (define vars body))
+ (define vars (run-test "scan-exp" body)))
+ ((run-test "scan-exp" ?body)
+ (letrec-syntax
+ ((scan-exp ; (scan-exp body k)
+ (syntax-rules (quote quasiquote !)
+ ((scan-exp '() (k-head ! . args))
+ (k-head '() . args))
+ ((scan-exp (quote (hd . tl)) k)
+ (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+ ((scan-exp (quasiquote (hd . tl)) k)
+ (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+ ((scan-exp (quote x) (k-head ! . args))
+ (k-head
+ (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+ . args))
+ ((scan-exp (hd . tl) k)
+ (scan-exp hd (do-tl ! scan-exp tl k)))
+ ((scan-exp x (k-head ! . args))
+ (k-head x . args))))
+ (do-tl
+ (syntax-rules (!)
+ ((do-tl processed-hd fn () (k-head ! . args))
+ (k-head (processed-hd) . args))
+ ((do-tl processed-hd fn old-tl k)
+ (fn old-tl (do-cons ! processed-hd k)))))
+ (do-cons
+ (syntax-rules (!)
+ ((do-cons processed-tl processed-hd (k-head ! . args))
+ (k-head (processed-hd . processed-tl) . args))))
+ (do-wrap
+ (syntax-rules (!)
+ ((do-wrap val fn (k-head ! . args))
+ (k-head (fn val) . args))))
+ (do-finish
+ (syntax-rules ()
+ ((do-finish new-body) new-body)))
+
+ (scan-lit-lst ; scan literal list
+ (syntax-rules (quote unquote unquote-splicing !)
+ ((scan-lit-lst '() (k-head ! . args))
+ (k-head '() . args))
+ ((scan-lit-lst (quote (hd . tl)) k)
+ (do-tl quote scan-lit-lst ((hd . tl)) k))
+ ((scan-lit-lst (unquote x) k)
+ (scan-exp x (do-wrap ! unquote k)))
+ ((scan-lit-lst (unquote-splicing x) k)
+ (scan-exp x (do-wrap ! unquote-splicing k)))
+ ((scan-lit-lst (quote x) (k-head ! . args))
+ (k-head
+ ,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
+ . args))
+ ((scan-lit-lst (hd . tl) k)
+ (scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
+ ((scan-lit-lst x (k-head ! . args))
+ (k-head x . args))))
+ )
+ (scan-exp ?body (do-finish !))))
+ ((run-test body ...)
+ (begin
+ (run-test "scan-exp" body) ...))
+))
+
+; Overwrite the above macro to switch the tests off
+; (define-macro (run-test selector node expected-result) #f)
+
+; Location path, full form: child::para
+; Location path, abbreviated form: para
+; selects the para element children of the context node
+
+(let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
+ )
+ (expected '((para (@) "para") (para (@) "second par")))
+ )
+ (run-test (select-kids (node-typeof? 'para)) tree expected)
+ (run-test (sxpath '(para)) tree expected)
+)
+
+; Location path, full form: child::*
+; Location path, abbreviated form: *
+; selects all element children of the context node
+
+(let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected
+ '((para (@) "para") (br (@)) (para "second par")))
+ )
+ (run-test (select-kids (node-typeof? '*)) tree expected)
+ (run-test (sxpath '(*)) tree expected)
+)
+
+
+
+; Location path, full form: child::text()
+; Location path, abbreviated form: text()
+; selects all text node children of the context node
+(let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected
+ '("cdata"))
+ )
+ (run-test (select-kids (node-typeof? '*text*)) tree expected)
+ (run-test (sxpath '(*text*)) tree expected)
+)
+
+
+; Location path, full form: child::node()
+; Location path, abbreviated form: node()
+; selects all the children of the context node, whatever their node type
+(let* ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected (cdr tree))
+ )
+ (run-test (select-kids (node-typeof? '*any*)) tree expected)
+ (run-test (sxpath '(*any*)) tree expected)
+)
+
+; Location path, full form: child::*/child::para
+; Location path, abbreviated form: */para
+; selects all para grandchildren of the context node
+
+(let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para "third para")))
+ )
+ (expected
+ '((para "third para")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '*))
+ (select-kids (node-typeof? 'para)))
+ tree expected)
+ (run-test (sxpath '(* para)) tree expected)
+)
+
+
+; Location path, full form: attribute::name
+; Location path, abbreviated form: @name
+; selects the 'name' attribute of the context node
+
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para (@) "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((name "elem")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'name)))
+ tree expected)
+ (run-test (sxpath '(@ name)) tree expected)
+)
+
+; Location path, full form: attribute::*
+; Location path, abbreviated form: @*
+; selects all the attributes of the context node
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((name "elem") (id "idz")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? '*)))
+ tree expected)
+ (run-test (sxpath '(@ *)) tree expected)
+)
+
+
+; Location path, full form: descendant::para
+; Location path, abbreviated form: .//para
+; selects the para element descendants of the context node
+
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para (@) "para") (para "second par") (para (@) "third para")))
+ )
+ (run-test
+ (node-closure (node-typeof? 'para))
+ tree expected)
+ (run-test (sxpath '(// para)) tree expected)
+)
+
+; Location path, full form: self::para
+; Location path, abbreviated form: _none_
+; selects the context node if it is a para element; otherwise selects nothing
+
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ )
+ (run-test (node-self (node-typeof? 'para)) tree '())
+ (run-test (node-self (node-typeof? 'elem)) tree (list tree))
+)
+
+; Location path, full form: descendant-or-self::node()
+; Location path, abbreviated form: //
+; selects the context node, all the children (including attribute nodes)
+; of the context node, and all the children of all the (element)
+; descendants of the context node.
+; This is _almost_ a powerset of the context node.
+(let* ((tree
+ '(para (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ (cons tree
+ (append (cdr tree)
+ '((@) "para" (@) "second par"
+ (@ (name "aa")) (para (@) "third para")
+ (@) "third para"))))
+ )
+ (run-test
+ (node-or
+ (node-self (node-typeof? '*any*))
+ (node-closure (node-typeof? '*any*)))
+ tree expected)
+ (run-test (sxpath '(//)) tree expected)
+)
+
+; Location path, full form: ancestor::div
+; Location path, abbreviated form: _none_
+; selects all div ancestors of the context node
+; This Location expression is equivalent to the following:
+; /descendant-or-self::div[descendant::node() = curr_node]
+; This shows that the ancestor:: axis is actually redundant. Still,
+; it can be emulated as the following SXPath expression demonstrates.
+
+; The insight behind "ancestor::div" -- selecting all "div" ancestors
+; of the current node -- is
+; S[ancestor::div] context_node =
+; { y | y=subnode*(root), context_node=subnode(subnode*(y)),
+; isElement(y), name(y) = "div" }
+; We observe that
+; { y | y=subnode*(root), pred(y) }
+; can be expressed in SXPath as
+; ((node-or (node-self pred) (node-closure pred)) root-node)
+; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to
+; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
+; context_node=subnode(subnode*(y)) is tantamount to
+; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
+; the composition of converters-predicates in the filtering context.
+
+(let*
+ ((root
+ '(div (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para (@) "second par")
+ (div (@ (name "aa")) (para (@) "third para"))))
+ (context-node ; /descendant::any()[child::text() == "third para"]
+ (car
+ ((node-closure
+ (select-kids
+ (node-equal? "third para")))
+ root)))
+ (pred
+ (node-reduce (node-self (node-typeof? 'div))
+ (node-closure (node-eq? context-node))
+ ))
+ )
+ (run-test
+ (node-or
+ (node-self pred)
+ (node-closure pred))
+ root
+ (cons root
+ '((div (@ (name "aa")) (para (@) "third para")))))
+)
+
+
+
+; Location path, full form: child::div/descendant::para
+; Location path, abbreviated form: div//para
+; selects the para element descendants of the div element
+; children of the context node
+
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")
+ (div (para "fourth para"))))
+ )
+ (expected
+ '((para (@) "third para") (para "fourth para")))
+ )
+ (run-test
+ (node-join
+ (select-kids (node-typeof? 'div))
+ (node-closure (node-typeof? 'para)))
+ tree expected)
+ (run-test (sxpath '(div // para)) tree expected)
+)
+
+
+; Location path, full form: /descendant::olist/child::item
+; Location path, abbreviated form: //olist/item
+; selects all the item elements that have an olist parent (which is not root)
+; and that are in the same document as the context node
+; See the following test.
+
+; Location path, full form: /descendant::td/attribute::align
+; Location path, abbreviated form: //td/@align
+; Selects 'align' attributes of all 'td' elements in tree1
+(let ((tree tree1)
+ (expected
+ '((align "right") (align "center") (align "center") (align "center"))
+ ))
+ (run-test
+ (node-join
+ (node-closure (node-typeof? 'td))
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'align)))
+ tree expected)
+ (run-test (sxpath '(// td @ align)) tree expected)
+)
+
+
+; Location path, full form: /descendant::td[attribute::align]
+; Location path, abbreviated form: //address@hidden
+; Selects all td elements that have an attribute 'align' in tree1
+(let ((tree tree1)
+ (expected
+ '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
+ (td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
+ ))
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'align)))))
+ tree expected)
+ (run-test (sxpath `(// td ,(node-self (sxpath '(@ align))))) tree expected)
+ (run-test (sxpath '(// (td (@ align)))) tree expected)
+ (run-test (sxpath '(// ((td) (@ align)))) tree expected)
+ ; note! (sxpath ...) is a converter. Therefore, it can be used
+ ; as any other converter, for example, in the full-form SXPath.
+ ; Thus we can mix the full and abbreviated form SXPath's freely.
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (sxpath '(@ align))))
+ tree expected)
+)
+
+
+; Location path, full form: /descendant::td[attribute::align = "right"]
+; Location path, abbreviated form: //address@hidden = "right"]
+; Selects all td elements that have an attribute align = "right" in tree1
+(let ((tree tree1)
+ (expected
+ '((td (@ (align "right")) "Talks "))
+ ))
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(align "right"))))))
+ tree expected)
+ (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
+)
+
+; Location path, full form: child::para[position()=1]
+; Location path, abbreviated form: para[1]
+; selects the first para child of the context node
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para (@) "para"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos 1))
+ tree expected)
+ (run-test (sxpath '((para 1))) tree expected)
+)
+
+; Location path, full form: child::para[position()=last()]
+; Location path, abbreviated form: para[last()]
+; selects the last para child of the context node
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para "second par"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos -1))
+ tree expected)
+ (run-test (sxpath '((para -1))) tree expected)
+)
+
+; Illustrating the following Note of Sec 2.5 of XPath:
+; "NOTE: The location path //para[1] does not mean the same as the
+; location path /descendant::para[1]. The latter selects the first
+; descendant para element; the former selects all descendant para
+; elements that are the first para children of their parents."
+
+(let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ )
+ (run-test
+ (node-reduce ; /descendant::para[1] in SXPath
+ (node-closure (node-typeof? 'para))
+ (node-pos 1))
+ tree '((para (@) "para")))
+ (run-test (sxpath '(// (para 1))) tree
+ '((para (@) "para") (para (@) "third para")))
+)
+
+; Location path, full form: parent::node()
+; Location path, abbreviated form: ..
+; selects the parent of the context node. The context node may be
+; an attribute node!
+; For the last test:
+; Location path, full form: parent::*/attribute::name
+; Location path, abbreviated form: ../@name
+; Selects the name attribute of the parent of the context node
+
+(let* ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (para1 ; the first para node
+ (car ((sxpath '(para)) tree)))
+ (para3 ; the third para node
+ (car ((sxpath '(div para)) tree)))
+ (div ; div node
+ (car ((sxpath '(// div)) tree)))
+ )
+ (run-test
+ (node-parent tree)
+ para1 (list tree))
+ (run-test
+ (node-parent tree)
+ para3 (list div))
+ (run-test ; checking the parent of an attribute node
+ (node-parent tree)
+ ((sxpath '(@ name)) div) (list div))
+ (run-test
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'name)))
+ para3 '((name "aa")))
+ (run-test
+ (sxpath `(,(node-parent tree) @ name))
+ para3 '((name "aa")))
+)
+
+; Location path, full form: following-sibling::chapter[position()=1]
+; Location path, abbreviated form: none
+; selects the next chapter sibling of the context node
+; The path is equivalent to
+; let cnode = context-node
+; in
+; parent::* / child::chapter [take-after node_eq(self::*,cnode)]
+; [position()=1]
+(let* ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (chapter (@ (id "four")) "Chap 4 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (a-node ; to be used as a context node
+ (car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
+ (expected
+ '((chapter (@ (id "three")) "Chap 3 text")))
+ )
+ (run-test
+ (node-reduce
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? 'chapter)))
+ (take-after (node-eq? a-node))
+ (node-pos 1)
+ )
+ a-node expected)
+)
+
+; preceding-sibling::chapter[position()=1]
+; selects the previous chapter sibling of the context node
+; The path is equivalent to
+; let cnode = context-node
+; in
+; parent::* / child::chapter [take-until node_eq(self::*,cnode)]
+; [position()=-1]
+(let* ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (chapter (@ (id "four")) "Chap 4 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (a-node ; to be used as a context node
+ (car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
+ (expected
+ '((chapter (@ (id "two")) "Chap 2 text")))
+ )
+ (run-test
+ (node-reduce
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? 'chapter)))
+ (take-until (node-eq? a-node))
+ (node-pos -1)
+ )
+ a-node expected)
+)
+
+
+; /descendant::figure[position()=42]
+; selects the forty-second figure element in the document
+; See the next example, which is more general.
+
+; Location path, full form:
+; child::table/child::tr[position()=2]/child::td[position()=3]
+; Location path, abbreviated form: table/tr[2]/td[3]
+; selects the third td of the second tr of the table
+(let ((tree ((node-closure (node-typeof? 'p)) tree1))
+ (expected
+ '((td " data + control"))
+ ))
+ (run-test
+ (node-join
+ (select-kids (node-typeof? 'table))
+ (node-reduce (select-kids (node-typeof? 'tr))
+ (node-pos 2))
+ (node-reduce (select-kids (node-typeof? 'td))
+ (node-pos 3)))
+ tree expected)
+ (run-test (sxpath '(table (tr 2) (td 3))) tree expected)
+)
+
+
+; Location path, full form:
+; child::para[attribute::type='warning'][position()=5]
+; Location path, abbreviated form: address@hidden'warning'][5]
+; selects the fifth para child of the context node that has a type
+; attribute with value warning
+(let ((tree
+ '(chapter
+ (para "para1")
+ (para (@ (type "warning")) "para 2")
+ (para (@ (type "warning")) "para 3")
+ (para (@ (type "warning")) "para 4")
+ (para (@ (type "warning")) "para 5")
+ (para (@ (type "warning")) "para 6"))
+ )
+ (expected
+ '((para (@ (type "warning")) "para 6"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(type "warning")))))
+ (node-pos 5))
+ tree expected)
+ (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 ) ))
+ tree expected)
+ (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 ) ))
+ tree expected)
+)
+
+
+; Location path, full form:
+; child::para[position()=5][attribute::type='warning']
+; Location path, abbreviated form: address@hidden'warning']
+; selects the fifth para child of the context node if that child has a 'type'
+; attribute with value warning
+(let ((tree
+ '(chapter
+ (para "para1")
+ (para (@ (type "warning")) "para 2")
+ (para (@ (type "warning")) "para 3")
+ (para (@ (type "warning")) "para 4")
+ (para (@ (type "warning")) "para 5")
+ (para (@ (type "warning")) "para 6"))
+ )
+ (expected
+ '((para (@ (type "warning")) "para 5"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos 5)
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(type "warning"))))))
+ tree expected)
+ (run-test (sxpath '( (( (para 5)) (@ (equal? (type "warning"))))))
+ tree expected)
+ (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
+ tree expected)
+)
+
+; Location path, full form:
+; child::*[self::chapter or self::appendix]
+; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
+; selects the chapter and appendix children of the context node
+(let ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (expected
+ '((chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (appendix (@ (id "A")) "App A text"))
+ ))
+ (run-test
+ (node-join
+ (select-kids (node-typeof? '*))
+ (filter
+ (node-or
+ (node-self (node-typeof? 'chapter))
+ (node-self (node-typeof? 'appendix)))))
+ tree expected)
+ (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
+ (node-self (node-typeof? 'appendix)))))
+ tree expected)
+)
+
+
+; Location path, full form: child::chapter[child::title='Introduction']
+; Location path, abbreviated form: chapter[title = 'Introduction']
+; selects the chapter children of the context node that have one or more
+; title children with string-value equal to Introduction
+; See a similar example: //address@hidden = "right"] above.
+
+; Location path, full form: child::chapter[child::title]
+; Location path, abbreviated form: chapter[title]
+; selects the chapter children of the context node that have one or
+; more title children
+; See a similar example //address@hidden above.
+
+(cerr nl "Example with tree3: extracting the first lines of every stanza" nl)
+(let ((tree tree3)
+ (expected
+ '("Let us go then, you and I," "In the room the women come and go")
+ ))
+ (run-test
+ (node-join
+ (node-closure (node-typeof? 'stanza))
+ (node-reduce
+ (select-kids (node-typeof? 'line)) (node-pos 1))
+ (select-kids (node-typeof? '*text*)))
+ tree expected)
+ (run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
+)
+
diff --git a/module/sxml/upstream/assert.scm b/module/sxml/upstream/assert.scm
new file mode 100644
index 0000000..e9e983d
--- /dev/null
+++ b/module/sxml/upstream/assert.scm
@@ -0,0 +1,35 @@
+;
+; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
+;
+; If (and ?expr ?expr ...) evaluates to anything but #f, the result
+; is the value of that expression.
+; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
+; The error message will show the failed expressions, as well
+; as the values of selected variables (or expressions, in general).
+; The user may explicitly specify the expressions whose
+; values are to be printed upon assertion failure -- as ?r-exp that
+; follow the identifier 'report:'
+; Typically, ?r-exp is either a variable or a string constant.
+; If the user specified no ?r-exp, the values of variables that are
+; referenced in ?expr will be printed upon the assertion failure.
+
+(define-syntax assert
+ (syntax-rules (report:)
+ ((assert "doit" (expr ...) (r-exp ...))
+ (cond
+ ((and expr ...) => (lambda (x) x))
+ (else
+ (error "assertion failure: ~a" (list '(and expr ...) r-exp ...)))))
+ ((assert "collect" (expr ...))
+ (assert "doit" (expr ...) ()))
+ ((assert "collect" (expr ...) report: r-exp ...)
+ (assert "doit" (expr ...) (r-exp ...)))
+ ((assert "collect" (expr ...) expr1 stuff ...)
+ (assert "collect" (expr ... expr1) stuff ...))
+ ((assert stuff ...)
+ (assert "collect" () stuff ...))))
+
+(define-syntax assure
+ (syntax-rules ()
+ ((assure exp error-msg)
+ (assert exp report: error-msg))))
\ No newline at end of file
diff --git a/module/sxml/upstream/input-parse.scm
b/module/sxml/upstream/input-parse.scm
new file mode 100644
index 0000000..e0bccfd
--- /dev/null
+++ b/module/sxml/upstream/input-parse.scm
@@ -0,0 +1,326 @@
+;****************************************************************************
+; Simple Parsing of input
+;
+; The following simple functions surprisingly often suffice to parse
+; an input stream. They either skip, or build and return tokens,
+; according to inclusion or delimiting semantics. The list of
+; characters to expect, include, or to break at may vary from one
+; invocation of a function to another. This allows the functions to
+; easily parse even context-sensitive languages.
+;
+; EOF is generally frowned on, and thrown up upon if encountered.
+; Exceptions are mentioned specifically. The list of expected characters
+; (characters to skip until, or break-characters) may include an EOF
+; "character", which is to be coded as symbol *eof*
+;
+; The input stream to parse is specified as a PORT, which is usually
+; the last (and optional) argument. It defaults to the current input
+; port if omitted.
+;
+; IMPORT
+; This package relies on a function parser-error, which must be defined
+; by a user of the package. The function has the following signature:
+; parser-error PORT MESSAGE SPECIALISING-MSG*
+; Many procedures of this package call parser-error to report a parsing
+; error. The first argument is a port, which typically points to the
+; offending character or its neighborhood. Most of the Scheme systems
+; let the user query a PORT for the current position. MESSAGE is the
+; description of the error. Other arguments supply more details about
+; the problem.
+; myenv.scm, myenv-bigloo.scm or a similar prelude is assumed.
+; From SRFI-13, string-concatenate-reverse
+; If a particular implementation lacks SRFI-13 support, please
+; include the file srfi-13-local.scm
+;
+; $Id: input-parse.scm,v 1.7 2004/07/07 16:02:31 sperber Exp $
+
+;------------------------------------------------------------------------
+
+; -- procedure+: peek-next-char [PORT]
+; advances to the next character in the PORT and peeks at it.
+; This function is useful when parsing LR(1)-type languages
+; (one-char-read-ahead).
+; The optional argument PORT defaults to the current input port.
+
+(define-opt (peek-next-char (optional (port (current-input-port))))
+ (read-char port)
+ (peek-char port))
+
+
+;------------------------------------------------------------------------
+
+; -- procedure+: assert-curr-char CHAR-LIST STRING [PORT]
+; Reads a character from the PORT and looks it up
+; in the CHAR-LIST of expected characters
+; If the read character was found among expected, it is returned
+; Otherwise, the procedure writes a nasty message using STRING
+; as a comment, and quits.
+; The optional argument PORT defaults to the current input port.
+;
+(define-opt (assert-curr-char expected-chars comment
+ (optional (port (current-input-port))))
+ (let ((c (read-char port)))
+ (if (memv c expected-chars) c
+ (parser-error port "Wrong character " c
+ " (0x" (if (eof-object? c) "*eof*"
+ (number->string (char->integer c) 16)) ") "
+ comment ". " expected-chars " expected"))))
+
+
+; -- procedure+: skip-until CHAR-LIST [PORT]
+; Reads and skips characters from the PORT until one of the break
+; characters is encountered. This break character is returned.
+; The break characters are specified as the CHAR-LIST. This list
+; may include EOF, which is to be coded as a symbol *eof*
+;
+; -- procedure+: skip-until NUMBER [PORT]
+; Skips the specified NUMBER of characters from the PORT and returns #f
+;
+; The optional argument PORT defaults to the current input port.
+
+
+(define-opt (skip-until arg (optional (port (current-input-port))) )
+ (cond
+ ((number? arg) ; skip 'arg' characters
+ (do ((i arg (dec i)))
+ ((not (positive? i)) #f)
+ (if (eof-object? (read-char port))
+ (parser-error port "Unexpected EOF while skipping "
+ arg " characters"))))
+ (else ; skip until break-chars (=arg)
+ (let loop ((c (read-char port)))
+ (cond
+ ((memv c arg) c)
+ ((eof-object? c)
+ (if (memq '*eof* arg) c
+ (parser-error port "Unexpected EOF while skipping until " arg)))
+ (else (loop (read-char port))))))))
+
+
+; -- procedure+: skip-while CHAR-LIST [PORT]
+; Reads characters from the PORT and disregards them,
+; as long as they are mentioned in the CHAR-LIST.
+; The first character (which may be EOF) peeked from the stream
+; that is NOT a member of the CHAR-LIST is returned. This character
+; is left on the stream.
+; The optional argument PORT defaults to the current input port.
+
+(define-opt (skip-while skip-chars (optional (port (current-input-port))) )
+ (do ((c (peek-char port) (peek-char port)))
+ ((not (memv c skip-chars)) c)
+ (read-char port)))
+
+; whitespace const
+
+;------------------------------------------------------------------------
+; Stream tokenizers
+
+
+; -- procedure+:
+; next-token PREFIX-CHAR-LIST BREAK-CHAR-LIST [COMMENT-STRING] [PORT]
+; skips any number of the prefix characters (members of the
+; PREFIX-CHAR-LIST), if any, and reads the sequence of characters
+; up to (but not including) a break character, one of the
+; BREAK-CHAR-LIST.
+; The string of characters thus read is returned.
+; The break character is left on the input stream
+; The list of break characters may include EOF, which is to be coded as
+; a symbol *eof*. Otherwise, EOF is fatal, generating an error message
+; including a specified COMMENT-STRING (if any)
+;
+; The optional argument PORT defaults to the current input port.
+;
+; Note: since we can't tell offhand how large the token being read is
+; going to be, we make a guess, pre-allocate a string, and grow it by
+; quanta if necessary. The quantum is always the length of the string
+; before it was extended the last time. Thus the algorithm does
+; a Fibonacci-type extension, which has been proven optimal.
+; Note, explicit port specification in read-char, peek-char helps.
+
+; Procedure: input-parse:init-buffer
+; returns an initial buffer for next-token* procedures.
+; The input-parse:init-buffer may allocate a new buffer per each invocation:
+; (define (input-parse:init-buffer) (make-string 32))
+; Size 32 turns out to be fairly good, on average.
+; That policy is good only when a Scheme system is multi-threaded with
+; preemptive scheduling, or when a Scheme system supports shared substrings.
+; In all the other cases, it's better for input-parse:init-buffer to
+; return the same static buffer. next-token* functions return a copy
+; (a substring) of accumulated data, so the same buffer can be reused.
+; We shouldn't worry about an incoming token being too large:
+; next-token will use another chunk automatically. Still,
+; the best size for the static buffer is to allow most of the tokens to fit in.
+; Using a static buffer _dramatically_ reduces the amount of produced garbage
+; (e.g., during XML parsing).
+
+(define input-parse:init-buffer
+ (let ((buffer (make-string 512)))
+ (lambda () buffer)))
+
+
+ ; See a better version below
+(define-opt (next-token-old prefix-skipped-chars break-chars
+ (optional (comment "") (port (current-input-port))) )
+ (let* ((buffer (input-parse:init-buffer))
+ (curr-buf-len (string-length buffer))
+ (quantum curr-buf-len))
+ (let loop ((i 0) (c (skip-while prefix-skipped-chars port)))
+ (cond
+ ((memv c break-chars) (substring buffer 0 i))
+ ((eof-object? c)
+ (if (memq '*eof* break-chars)
+ (substring buffer 0 i) ; was EOF expected?
+ (parser-error port "EOF while reading a token " comment)))
+ (else
+ (if (>= i curr-buf-len) ; make space for i-th char in buffer
+ (begin ; -> grow the buffer by the quantum
+ (set! buffer (string-append buffer (make-string quantum)))
+ (set! quantum curr-buf-len)
+ (set! curr-buf-len (string-length buffer))))
+ (string-set! buffer i c)
+ (read-char port) ; move to the next char
+ (loop (inc i) (peek-char port))
+ )))))
+
+
+; A better version of next-token, which accumulates the characters
+; in chunks, and later on reverse-concatenates them, using
+; SRFI-13 if available.
+; The overhead of copying characters is only 100% (or even smaller: bulk
+; string copying might be well-optimised), compared to the (hypothetical)
+; circumstance if we had known the size of the token beforehand.
+; For small tokens, the code performs just as above. For large
+; tokens, we expect an improvement. Note, the code also has no
+; assignments.
+; See next-token-comp.scm
+
+(define-opt (next-token prefix-skipped-chars break-chars
+ (optional (comment "") (port (current-input-port))) )
+ (let outer ((buffer (input-parse:init-buffer)) (filled-buffer-l '())
+ (c (skip-while prefix-skipped-chars port)))
+ (let ((curr-buf-len (string-length buffer)))
+ (let loop ((i 0) (c c))
+ (cond
+ ((memv c break-chars)
+ (if (null? filled-buffer-l) (substring buffer 0 i)
+ (string-concatenate-reverse filled-buffer-l buffer i)))
+ ((eof-object? c)
+ (if (memq '*eof* break-chars) ; was EOF expected?
+ (if (null? filled-buffer-l) (substring buffer 0 i)
+ (string-concatenate-reverse filled-buffer-l buffer i))
+ (parser-error port "EOF while reading a token " comment)))
+ ((>= i curr-buf-len)
+ (outer (make-string curr-buf-len)
+ (cons buffer filled-buffer-l) c))
+ (else
+ (string-set! buffer i c)
+ (read-char port) ; move to the next char
+ (loop (inc i) (peek-char port))))))))
+
+; -- procedure+: next-token-of INC-CHARSET [PORT]
+; Reads characters from the PORT that belong to the list of characters
+; INC-CHARSET. The reading stops at the first character which is not
+; a member of the set. This character is left on the stream.
+; All the read characters are returned in a string.
+;
+; -- procedure+: next-token-of PRED [PORT]
+; Reads characters from the PORT for which PRED (a procedure of one
+; argument) returns non-#f. The reading stops at the first character
+; for which PRED returns #f. That character is left on the stream.
+; All the results of evaluating of PRED up to #f are returned in a
+; string.
+;
+; PRED is a procedure that takes one argument (a character
+; or the EOF object) and returns a character or #f. The returned
+; character does not have to be the same as the input argument
+; to the PRED. For example,
+; (next-token-of (lambda (c)
+; (cond ((eof-object? c) #f)
+; ((char-alphabetic? c) (char-downcase c))
+; (else #f))))
+; will try to read an alphabetic token from the current
+; input port, and return it in lower case.
+;
+; The optional argument PORT defaults to the current input port.
+;
+; This procedure is similar to next-token but only it implements
+; an inclusion rather than delimiting semantics.
+
+(define-opt (next-token-of incl-list/pred
+ (optional (port (current-input-port))) )
+ (let* ((buffer (input-parse:init-buffer))
+ (curr-buf-len (string-length buffer)))
+ (if (procedure? incl-list/pred)
+ (let outer ((buffer buffer) (filled-buffer-l '()))
+ (let loop ((i 0))
+ (if (>= i curr-buf-len) ; make sure we have space
+ (outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
+ (let ((c (incl-list/pred (peek-char port))))
+ (if c
+ (begin
+ (string-set! buffer i c)
+ (read-char port) ; move to the next char
+ (loop (inc i)))
+ ; incl-list/pred decided it had had enough
+ (if (null? filled-buffer-l) (substring buffer 0 i)
+ (string-concatenate-reverse filled-buffer-l buffer i)))))))
+
+ ; incl-list/pred is a list of allowed characters
+ (let outer ((buffer buffer) (filled-buffer-l '()))
+ (let loop ((i 0))
+ (if (>= i curr-buf-len) ; make sure we have space
+ (outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
+ (let ((c (peek-char port)))
+ (cond
+ ((not (memv c incl-list/pred))
+ (if (null? filled-buffer-l) (substring buffer 0 i)
+ (string-concatenate-reverse filled-buffer-l buffer i)))
+ (else
+ (string-set! buffer i c)
+ (read-char port) ; move to the next char
+ (loop (inc i))))))))
+ )))
+
+
+; -- procedure+: read-text-line [PORT]
+; Reads one line of text from the PORT, and returns it as a string.
+; A line is a (possibly empty) sequence of characters terminated
+; by CR, CRLF or LF (or even the end of file).
+; The terminating character (or CRLF combination) is removed from
+; the input stream. The terminating character(s) is not a part
+; of the return string either.
+; If EOF is encountered before any character is read, the return
+; value is EOF.
+;
+; The optional argument PORT defaults to the current input port.
+
+(define *read-line-breaks* (list char-newline char-return '*eof*))
+
+(define-opt (read-text-line (optional (port (current-input-port))) )
+ (if (eof-object? (peek-char port)) (peek-char port)
+ (let* ((line
+ (next-token '() *read-line-breaks*
+ "reading a line" port))
+ (c (read-char port))) ; must be either \n or \r or EOF
+ (and (eqv? c char-return) (eqv? (peek-char port) #\newline)
+ (read-char port)) ; skip \n that follows \r
+ line)))
+
+
+; -- procedure+: read-string N [PORT]
+; Reads N characters from the PORT, and returns them in a string.
+; If EOF is encountered before N characters are read, a shorter string
+; will be returned.
+; If N is not positive, an empty string will be returned.
+; The optional argument PORT defaults to the current input port.
+
+(define-opt (read-string n (optional (port (current-input-port))) )
+ (if (not (positive? n)) ""
+ (let ((buffer (make-string n)))
+ (let loop ((i 0) (c (read-char port)))
+ (if (eof-object? c) (substring buffer 0 i)
+ (let ((i1 (inc i)))
+ (string-set! buffer i c)
+ (if (= i1 n) buffer
+ (loop i1 (read-char port)))))))))
+
diff --git a/module/sxml/xpath.scm b/module/sxml/xpath.scm
new file mode 100644
index 0000000..bdf4ae9
--- /dev/null
+++ b/module/sxml/xpath.scm
@@ -0,0 +1,493 @@
+;;;; (sxml xpath) -- SXPath
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;; Written 2001 by Oleg Kiselyov <oleg at pobox dot com> SXPath.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;@heading SXPath: SXML Query Language
+;;
+;; SXPath is a query language for SXML, an instance of XML Information
+;; set (Infoset) in the form of s-expressions. See @code{(sxml ssax)}
+;; for the definition of SXML and more details. SXPath is also a
+;; translation into Scheme of an XML Path Language,
+;; @uref{http://www.w3.org/TR/xpath,XPath}. XPath and SXPath describe
+;; means of selecting a set of Infoset's items or their properties.
+;;
+;; To facilitate queries, XPath maps the XML Infoset into an explicit
+;; tree, and introduces important notions of a location path and a
+;; current, context node. A location path denotes a selection of a set of
+;; nodes relative to a context node. Any XPath tree has a distinguished,
+;; root node -- which serves as the context node for absolute location
+;; paths. Location path is recursively defined as a location step joined
+;; with a location path. A location step is a simple query of the
+;; database relative to a context node. A step may include expressions
+;; that further filter the selected set. Each node in the resulting set
+;; is used as a context node for the adjoining location path. The result
+;; of the step is a union of the sets returned by the latter location
+;; paths.
+;;
+;; The SXML representation of the XML Infoset (see SSAX.scm) is rather
+;; suitable for querying as it is. Bowing to the XPath specification,
+;; we will refer to SXML information items as 'Nodes':
+;;@example
+;; <Node> ::= <Element> | <attributes-coll> | <attrib>
+;; | "text string" | <PI>
+;;@end example
+;; This production can also be described as
+;;@example
+;; <Node> ::= (name . <Nodeset>) | "text string"
+;;@end example
+;; An (ordered) set of nodes is just a list of the constituent nodes:
+;;@example
+;; <Nodeset> ::= (<Node> ...)
+;;@end example
+;; Nodesets, and Nodes other than text strings are both lists. A
+;; <Nodeset> however is either an empty list, or a list whose head is not
+;; a symbol. A symbol at the head of a node is either an XML name (in
+;; which case it's a tag of an XML element), or an administrative name
+;; such as '@@'. This uniform list representation makes processing rather
+;; simple and elegant, while avoiding confusion. The multi-branch tree
+;; structure formed by the mutually-recursive datatypes <Node> and
+;; <Nodeset> lends itself well to processing by functional languages.
+;;
+;; A location path is in fact a composite query over an XPath tree or
+;; its branch. A singe step is a combination of a projection, selection
+;; or a transitive closure. Multiple steps are combined via join and
+;; union operations. This insight allows us to @emph{elegantly}
+;; implement XPath as a sequence of projection and filtering primitives
+;; -- converters -- joined by @dfn{combinators}. Each converter takes a
+;; node and returns a nodeset which is the result of the corresponding
+;; query relative to that node. A converter can also be called on a set
+;; of nodes. In that case it returns a union of the corresponding
+;; queries over each node in the set. The union is easily implemented as
+;; a list append operation as all nodes in a SXML tree are considered
+;; distinct, by XPath conventions. We also preserve the order of the
+;; members in the union. Query combinators are high-order functions:
+;; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
+;; and compose or otherwise combine them. We will be concerned with only
+;; relative location paths [XPath]: an absolute location path is a
+;; relative path applied to the root node.
+;;
+;; Similarly to XPath, SXPath defines full and abbreviated notations
+;; for location paths. In both cases, the abbreviated notation can be
+;; mechanically expanded into the full form by simple rewriting
+;; rules. In case of SXPath the corresponding rules are given as
+;; comments to a sxpath function, below. The regression test suite at
+;; the end of this file shows a representative sample of SXPaths in
+;; both notations, juxtaposed with the corresponding XPath
+;; expressions. Most of the samples are borrowed literally from the
+;; XPath specification, while the others are adjusted for our running
+;; example, tree1.
+;;
+;;; Code:
+
+(define-module (sxml xpath)
+ #:use-module (ice-9 pretty-print)
+ #:export (nodeset? node-typeof? node-eq? node-equal? node-pos
+ filter take-until take-after map-union node-reverse
+ node-trace select-kids node-self node-join node-reduce
+ node-or node-closure node-parent
+ sxpath))
+
+;; Upstream version:
+; $Id: SXPath.scm,v 3.5 2001/01/12 23:20:35 oleg Exp oleg $
+
+(define (nodeset? x)
+ (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+
+;-------------------------
+; Basic converters and applicators
+; A converter is a function
+; type Converter = Node|Nodeset -> Nodeset
+; A converter can also play a role of a predicate: in that case, if a
+; converter, applied to a node or a nodeset, yields a non-empty
+; nodeset, the converter-predicate is deemed satisfied. Throughout
+; this file a nil nodeset is equivalent to #f in denoting a failure.
+
+; The following function implements a 'Node test' as defined in
+; Sec. 2.3 of XPath document. A node test is one of the components of a
+; location step. It is also a converter-predicate in SXPath.
+;
+; The function node-typeof? takes a type criterion and returns a function,
+; which, when applied to a node, will tell if the node satisfies
+; the test.
+; node-typeof? :: Crit -> Node -> Boolean
+;
+; The criterion 'crit' is a symbol, one of the following:
+; id - tests if the Node has the right name (id)
+; @ - tests if the Node is an <attributes-coll>
+; * - tests if the Node is an <Element>
+; *text* - tests if the Node is a text node
+; *PI* - tests if the Node is a PI node
+; *any* - #t for any type of Node
+
+(define (node-typeof? crit)
+ (lambda (node)
+ (case crit
+ ((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
+ ((*any*) #t)
+ ((*text*) (string? node))
+ (else
+ (and (pair? node) (eq? crit (car node))))
+)))
+
+
+; Curried equivalence converter-predicates
+(define (node-eq? other)
+ (lambda (node)
+ (eq? other node)))
+
+(define (node-equal? other)
+ (lambda (node)
+ (equal? other node)))
+
+; node-pos:: N -> Nodeset -> Nodeset, or
+; node-pos:: N -> Converter
+; Select the N'th element of a Nodeset and return as a singular Nodeset;
+; Return an empty nodeset if the Nth element does not exist.
+; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
+; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
+; exists.
+; N can also be a negative number: in that case the node is picked from
+; the tail of the list.
+; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
+; ((node-pos -2) Nodeset) selects the last but one node, if exists.
+
+(define (node-pos n)
+ (lambda (nodeset)
+ (cond
+ ((not (nodeset? nodeset)) '())
+ ((null? nodeset) nodeset)
+ ((eqv? n 1) (list (car nodeset)))
+ ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
+ (else
+ (or (positive? n) (error "yikes!"))
+ ((node-pos (1- n)) (cdr nodeset))))))
+
+; filter:: Converter -> Converter
+; A filter applicator, which introduces a filtering context. The argument
+; converter is considered a predicate, with either #f or nil result meaning
+; failure.
+(define (filter pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((pred-result (pred? (car lst))))
+ (loop (cdr lst)
+ (if (and pred-result (not (null? pred-result)))
+ (cons (car lst) res)
+ res)))))))
+
+; take-until:: Converter -> Converter, or
+; take-until:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have been processed
+; till that moment (that is, which fail the predicate).
+; take-until is a variation of the filter above: take-until passes
+; elements of an ordered input set till (but not including) the first
+; element that satisfies the predicate.
+; The nodeset returned by ((take-until (not pred)) nset) is a subset --
+; to be more precise, a prefix -- of the nodeset returned by
+; ((filter pred) nset)
+
+(define (take-until pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (if (nodeset? lst) lst (list lst))))
+ (if (null? lst) lst
+ (let ((pred-result (pred? (car lst))))
+ (if (and pred-result (not (null? pred-result)))
+ '()
+ (cons (car lst) (loop (cdr lst)))))
+ ))))
+
+
+; take-after:: Converter -> Converter, or
+; take-after:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have not been processed:
+; that is, return the elements of the input nodeset that follow the first
+; element that satisfied the predicate.
+; take-after along with take-until partition an input nodeset into three
+; parts: the first element that satisfies a predicate, all preceding
+; elements and all following elements.
+
+(define (take-after pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (if (nodeset? lst) lst (list lst))))
+ (if (null? lst) lst
+ (let ((pred-result (pred? (car lst))))
+ (if (and pred-result (not (null? pred-result)))
+ (cdr lst)
+ (loop (cdr lst))))
+ ))))
+
+; Apply proc to each element of lst and return the list of results.
+; if proc returns a nodeset, splice it into the result
+;
+; From another point of view, map-union is a function Converter->Converter,
+; which places an argument-converter in a joining context.
+
+(define (map-union proc lst)
+ (if (null? lst) lst
+ (let ((proc-res (proc (car lst))))
+ ((if (nodeset? proc-res) append cons)
+ proc-res (map-union proc (cdr lst))))))
+
+; node-reverse :: Converter, or
+; node-reverse:: Node|Nodeset -> Nodeset
+; Reverses the order of nodes in the nodeset
+; This basic converter is needed to implement a reverse document order
+; (see the XPath Recommendation).
+(define node-reverse
+ (lambda (node-or-nodeset)
+ (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
+ (reverse node-or-nodeset))))
+
+; node-trace:: String -> Converter
+; (node-trace title) is an identity converter. In addition it prints out
+; a node or nodeset it is applied to, prefixed with the 'title'.
+; This converter is very useful for debugging.
+
+(define (node-trace title)
+ (lambda (node-or-nodeset)
+ (display "\n-->")
+ (display title)
+ (display " :")
+ (pretty-print node-or-nodeset)
+ node-or-nodeset))
+
+
+;-------------------------
+; Converter combinators
+;
+; Combinators are higher-order functions that transmogrify a converter
+; or glue a sequence of converters into a single, non-trivial
+; converter. The goal is to arrive at converters that correspond to
+; XPath location paths.
+;
+; From a different point of view, a combinator is a fixed, named
+; _pattern_ of applying converters. Given below is a complete set of
+; such patterns that together implement XPath location path
+; specification. As it turns out, all these combinators can be built
+; from a small number of basic blocks: regular functional composition,
+; map-union and filter applicators, and the nodeset union.
+
+
+
+; select-kids:: Pred -> Node -> Nodeset
+; Given a Node, return an (ordered) subset its children that satisfy
+; the Pred (a converter, actually)
+; select-kids:: Pred -> Nodeset -> Nodeset
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+;
+; More succinctly, the signature of this function is
+; select-kids:: Converter -> Converter
+
+(define (select-kids test-pred?)
+ (lambda (node) ; node or node-set
+ (cond
+ ((null? node) node)
+ ((not (pair? node)) '()) ; No children
+ ((symbol? (car node))
+ ((filter test-pred?) (cdr node))) ; it's a single node
+ (else (map-union (select-kids test-pred?) node)))))
+
+
+; node-self:: Pred -> Node -> Nodeset, or
+; node-self:: Converter -> Converter
+; Similar to select-kids but apply to the Node itself rather
+; than to its children. The resulting Nodeset will contain either one
+; component, or will be empty (if the Node failed the Pred).
+(define node-self filter)
+
+
+; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-join:: [Converter] -> Converter
+; join the sequence of location steps or paths as described
+; in the title comments above.
+(define (node-join . selectors)
+ (lambda (nodeset) ; Nodeset or node
+ (let loop ((nodeset nodeset) (selectors selectors))
+ (if (null? selectors) nodeset
+ (loop
+ (if (nodeset? nodeset)
+ (map-union (car selectors) nodeset)
+ ((car selectors) nodeset))
+ (cdr selectors))))))
+
+
+; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-reduce:: [Converter] -> Converter
+; A regular functional composition of converters.
+; From a different point of view,
+; ((apply node-reduce converters) nodeset)
+; is equivalent to
+; (foldl apply nodeset converters)
+; i.e., folding, or reducing, a list of converters with the nodeset
+; as a seed.
+(define (node-reduce . converters)
+ (lambda (nodeset) ; Nodeset or node
+ (let loop ((nodeset nodeset) (converters converters))
+ (if (null? converters) nodeset
+ (loop ((car converters) nodeset) (cdr converters))))))
+
+
+; node-or:: [Converter] -> Converter
+; This combinator applies all converters to a given node and
+; produces the union of their results.
+; This combinator corresponds to a union, '|' operation for XPath
+; location paths.
+; (define (node-or . converters)
+; (lambda (node-or-nodeset)
+; (if (null? converters) node-or-nodeset
+; (append
+; ((car converters) node-or-nodeset)
+; ((apply node-or (cdr converters)) node-or-nodeset)))))
+; More optimal implementation follows
+(define (node-or . converters)
+ (lambda (node-or-nodeset)
+ (let loop ((result '()) (converters converters))
+ (if (null? converters) result
+ (loop (append result (or ((car converters) node-or-nodeset) '()))
+ (cdr converters))))))
+
+
+; node-closure:: Converter -> Converter
+; Select all _descendants_ of a node that satisfy a converter-predicate.
+; This combinator is similar to select-kids but applies to
+; grand... children as well.
+; This combinator implements the "descendant::" XPath axis
+; Conceptually, this combinator can be expressed as
+; (define (node-closure f)
+; (node-or
+; (select-kids f)
+; (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
+; This definition, as written, looks somewhat like a fixpoint, and it
+; will run forever. It is obvious however that sooner or later
+; (select-kids (node-typeof? '*)) will return an empty nodeset. At
+; this point further iterations will no longer affect the result and
+; can be stopped.
+
+(define (node-closure test-pred?)
+ (lambda (node) ; Nodeset or node
+ (let loop ((parent node) (result '()))
+ (if (null? parent) result
+ (loop ((select-kids (node-typeof? '*)) parent)
+ (append result
+ ((select-kids test-pred?) parent)))
+ ))))
+
+; node-parent:: RootNode -> Converter
+; (node-parent rootnode) yields a converter that returns a parent of a
+; node it is applied to. If applied to a nodeset, it returns the list
+; of parents of nodes in the nodeset. The rootnode does not have
+; to be the root node of the whole SXML tree -- it may be a root node
+; of a branch of interest.
+; Given the notation of Philip Wadler's paper on semantics of XSLT,
+; parent(x) = { y | y=subnode*(root), x=subnode(y) }
+; Therefore, node-parent is not the fundamental converter: it can be
+; expressed through the existing ones. Yet node-parent is a rather
+; convenient converter. It corresponds to a parent:: axis of SXPath.
+; Note that the parent:: axis can be used with an attribute node as well!
+
+(define (node-parent rootnode)
+ (lambda (node) ; Nodeset or node
+ (if (nodeset? node) (map-union (node-parent rootnode) node)
+ (let ((pred
+ (node-or
+ (node-reduce
+ (node-self (node-typeof? '*))
+ (select-kids (node-eq? node)))
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-eq? node))))))
+ ((node-or
+ (node-self pred)
+ (node-closure pred))
+ rootnode)))))
+
+;-------------------------
+; Evaluate an abbreviated SXPath
+; sxpath:: AbbrPath -> Converter, or
+; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
+; AbbrPath is a list. It is translated to the full SXPath according
+; to the following rewriting rules
+; (sxpath '()) -> (node-join)
+; (sxpath '(path-component ...)) ->
+; (node-join (sxpath1 path-component) (sxpath '(...)))
+; (sxpath1 '//) -> (node-or
+; (node-self (node-typeof? '*any*))
+; (node-closure (node-typeof? '*any*)))
+; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
+; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x))
+; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol)
+; (sxpath1 procedure) -> procedure
+; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
+; (sxpath1 '(path reducer ...)) ->
+; (node-reduce (sxpath path) (sxpathr reducer) ...)
+; (sxpathr number) -> (node-pos number)
+; (sxpathr path-filter) -> (filter (sxpath path-filter))
+
+(define (sxpath path)
+ (lambda (nodeset)
+ (let loop ((nodeset nodeset) (path path))
+ (cond
+ ((null? path) nodeset)
+ ((nodeset? nodeset)
+ (map-union (sxpath path) nodeset))
+ ((procedure? (car path))
+ (loop ((car path) nodeset) (cdr path)))
+ ((eq? '// (car path))
+ (loop
+ ((if (nodeset? nodeset) append cons) nodeset
+ ((node-closure (node-typeof? '*any*)) nodeset))
+ (cdr path)))
+ ((symbol? (car path))
+ (loop ((select-kids (node-typeof? (car path))) nodeset)
+ (cdr path)))
+ ((and (pair? (car path)) (eq? 'equal? (caar path)))
+ (loop ((select-kids (apply node-equal? (cdar path))) nodeset)
+ (cdr path)))
+ ((and (pair? (car path)) (eq? 'eq? (caar path)))
+ (loop ((select-kids (apply node-eq? (cdar path))) nodeset)
+ (cdr path)))
+ ((pair? (car path))
+ (let reducer ((nodeset
+ (if (symbol? (caar path))
+ ((select-kids (node-typeof? (caar path))) nodeset)
+ (loop nodeset (caar path))))
+ (reducing-path (cdar path)))
+ (cond
+ ((null? reducing-path) (loop nodeset (cdr path)))
+ ((number? (car reducing-path))
+ (reducer ((node-pos (car reducing-path)) nodeset)
+ (cdr reducing-path)))
+ (else
+ (reducer ((filter (sxpath (car reducing-path))) nodeset)
+ (cdr reducing-path))))))
+ (else
+ (error "Invalid path step: " (car path)))))))
+
+;;; arch-tag: c4e57abf-6b61-4612-a6aa-d1536d440774
+;;; xpath.scm ends here
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index da3f7cd..34e097b 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -1,6 +1,6 @@
;;; High-level compiler interface
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -88,7 +88,9 @@
(close-port tmp)
(if reference
(let ((st (stat reference)))
- (utime template (stat:atime st) (stat:mtime st))))
+ (utime template
+ (stat:atime st) (stat:mtime st)
+ (stat:atimensec st) (stat:mtimensec st))))
(rename-file template filename))
(lambda args
(delete-file template)))))))
@@ -109,11 +111,6 @@
(ensure-writable-dir (dirname dir))
(mkdir dir))))
-(define (dsu-sort list key less)
- (map cdr
- (stable-sort (map (lambda (x) (cons (key x) x)) list)
- (lambda (x y) (less (car x) (car y))))))
-
;;; This function is among the trickiest I've ever written. I tried many
;;; variants. In the end, simple is best, of course.
;;;
@@ -124,6 +121,8 @@
;;; compile-file explicitly, as in the srcdir != builddir case; or you
;;; don't know, in which case this function is called, and we just put
;;; them in your own ccache dir in ~/.guile-ccache.
+;;;
+;;; See also boot-9.scm:load.
(define (compiled-file-name file)
(define (compiled-extension)
(cond ((or (null? %load-compiled-extensions)
diff --git a/module/system/base/lalr.scm b/module/system/base/lalr.scm
new file mode 100644
index 0000000..8383a6f
--- /dev/null
+++ b/module/system/base/lalr.scm
@@ -0,0 +1,45 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010 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 program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (system base lalr)
+
+ ;; XXX: In theory this import is not needed but the evaluator (not the
+ ;; compiler) complains about `lexical-token' being unbound when expanding
+ ;; `(define-record-type lexical-token ...)' if we omit it.
+ #:use-module (srfi srfi-9)
+
+ #:export (lalr-parser print-states
+
+ make-lexical-token lexical-token?
+ lexical-token-category
+ lexical-token-source
+ lexical-token-value
+
+ make-source-location source-location?
+ source-location-input
+ source-location-line
+ source-location-column
+ source-location-offset
+ source-location-length
+
+ ;; `lalr-parser' is a defmacro, which produces code that refers to
+ ;; these drivers.
+ lr-driver glr-driver))
+
+;; The LALR parser generator was written by Dominique Boucher. It's available
+;; from http://code.google.com/p/lalr-scm/ and released under the LGPLv3+.
+(include-from-path "system/base/lalr.upstream.scm")
diff --git a/module/system/base/lalr.upstream.scm
b/module/system/base/lalr.upstream.scm
new file mode 100755
index 0000000..217c439
--- /dev/null
+++ b/module/system/base/lalr.upstream.scm
@@ -0,0 +1,2077 @@
+;;;
+;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
+;;;
+;; Copyright 1993, 2010 Dominique Boucher
+;;
+;; 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 General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+(define *lalr-scm-version* "2.4.1")
+
+
+(cond-expand
+
+ ;; -- Gambit-C
+ (gambit
+
+ (define-macro (def-macro form . body)
+ `(define-macro ,form (let () ,@body)))
+
+ (def-macro (BITS-PER-WORD) 28)
+ (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+ (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+
+ (define pprint pretty-print)
+ (define lalr-keyword? keyword?))
+
+ ;; --
+ (bigloo
+ (define-macro (def-macro form . body)
+ `(define-macro ,form (let () ,@body)))
+
+ (define pprint (lambda (obj) (write obj) (newline)))
+ (define lalr-keyword? keyword?)
+ (def-macro (BITS-PER-WORD) 29)
+ (def-macro (logical-or x . y) `(bit-or ,x ,@y))
+ (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj)))
+
+ ;; -- Chicken
+ (chicken
+
+ (define-macro (def-macro form . body)
+ `(define-macro ,form (let () ,@body)))
+
+ (define pprint pretty-print)
+ (define lalr-keyword? symbol?)
+ (def-macro (BITS-PER-WORD) 30)
+ (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+ (def-macro (lalr-error msg obj) `(error ,msg ,obj)))
+
+ ;; -- STKlos
+ (stklos
+ (require "pp")
+
+ (define (pprint form) (pp form :port (current-output-port)))
+
+ (define lalr-keyword? keyword?)
+ (define-macro (BITS-PER-WORD) 30)
+ (define-macro (logical-or x . y) `(bit-or ,x ,@y))
+ (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj)))
+
+ ;; -- Guile
+ (guile
+ (use-modules (ice-9 pretty-print))
+ (use-modules (srfi srfi-9))
+
+ (define pprint pretty-print)
+ (define lalr-keyword? symbol?)
+ (define-macro (BITS-PER-WORD) 30)
+ (define-macro (logical-or x . y) `(logior ,x ,@y))
+ (define-macro (lalr-error msg obj) `(error ,msg ,obj)))
+
+ ;; -- Kawa
+ (kawa
+ (require 'pretty-print)
+ (define (BITS-PER-WORD) 30)
+ (define logical-or logior)
+ (define (lalr-keyword? obj) (keyword? obj))
+ (define (pprint obj) (pretty-print obj))
+ (define (lalr-error msg obj) (error msg obj)))
+
+ ;; -- SISC
+ (sisc
+ (import logicops)
+ (import record)
+
+ (define pprint pretty-print)
+ (define lalr-keyword? symbol?)
+ (define-macro BITS-PER-WORD (lambda () 32))
+ (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
+ (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj)))
+
+
+ (else
+ (error "Unsupported Scheme system")))
+
+
+(define-record-type lexical-token
+ (make-lexical-token category source value)
+ lexical-token?
+ (category lexical-token-category)
+ (source lexical-token-source)
+ (value lexical-token-value))
+
+
+(define-record-type source-location
+ (make-source-location input line column offset length)
+ source-location?
+ (input source-location-input)
+ (line source-location-line)
+ (column source-location-column)
+ (offset source-location-offset)
+ (length source-location-length))
+
+
+
+ ;; - Macros pour la gestion des vecteurs de bits
+
+(define-macro (lalr-parser . arguments)
+ (define (set-bit v b)
+ (let ((x (quotient b (BITS-PER-WORD)))
+ (y (expt 2 (remainder b (BITS-PER-WORD)))))
+ (vector-set! v x (logical-or (vector-ref v x) y))))
+
+ (define (bit-union v1 v2 n)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! v1 i (logical-or (vector-ref v1 i)
+ (vector-ref v2 i)))))
+
+ ;; - Macro pour les structures de donnees
+
+ (define (new-core) (make-vector 4 0))
+ (define (set-core-number! c n) (vector-set! c 0 n))
+ (define (set-core-acc-sym! c s) (vector-set! c 1 s))
+ (define (set-core-nitems! c n) (vector-set! c 2 n))
+ (define (set-core-items! c i) (vector-set! c 3 i))
+ (define (core-number c) (vector-ref c 0))
+ (define (core-acc-sym c) (vector-ref c 1))
+ (define (core-nitems c) (vector-ref c 2))
+ (define (core-items c) (vector-ref c 3))
+
+ (define (new-shift) (make-vector 3 0))
+ (define (set-shift-number! c x) (vector-set! c 0 x))
+ (define (set-shift-nshifts! c x) (vector-set! c 1 x))
+ (define (set-shift-shifts! c x) (vector-set! c 2 x))
+ (define (shift-number s) (vector-ref s 0))
+ (define (shift-nshifts s) (vector-ref s 1))
+ (define (shift-shifts s) (vector-ref s 2))
+
+ (define (new-red) (make-vector 3 0))
+ (define (set-red-number! c x) (vector-set! c 0 x))
+ (define (set-red-nreds! c x) (vector-set! c 1 x))
+ (define (set-red-rules! c x) (vector-set! c 2 x))
+ (define (red-number c) (vector-ref c 0))
+ (define (red-nreds c) (vector-ref c 1))
+ (define (red-rules c) (vector-ref c 2))
+
+
+ (define (new-set nelem)
+ (make-vector nelem 0))
+
+
+ (define (vector-map f v)
+ (let ((vm-n (- (vector-length v) 1)))
+ (let loop ((vm-low 0) (vm-high vm-n))
+ (if (= vm-low vm-high)
+ (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
+ (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
+ (loop vm-low vm-middle)
+ (loop (+ vm-middle 1) vm-high))))))
+
+
+ ;; - Constantes
+ (define STATE-TABLE-SIZE 1009)
+
+
+ ;; - Tableaux
+ (define rrhs #f)
+ (define rlhs #f)
+ (define ritem #f)
+ (define nullable #f)
+ (define derives #f)
+ (define fderives #f)
+ (define firsts #f)
+ (define kernel-base #f)
+ (define kernel-end #f)
+ (define shift-symbol #f)
+ (define shift-set #f)
+ (define red-set #f)
+ (define state-table #f)
+ (define acces-symbol #f)
+ (define reduction-table #f)
+ (define shift-table #f)
+ (define consistent #f)
+ (define lookaheads #f)
+ (define LA #f)
+ (define LAruleno #f)
+ (define lookback #f)
+ (define goto-map #f)
+ (define from-state #f)
+ (define to-state #f)
+ (define includes #f)
+ (define F #f)
+ (define action-table #f)
+
+ ;; - Variables
+ (define nitems #f)
+ (define nrules #f)
+ (define nvars #f)
+ (define nterms #f)
+ (define nsyms #f)
+ (define nstates #f)
+ (define first-state #f)
+ (define last-state #f)
+ (define final-state #f)
+ (define first-shift #f)
+ (define last-shift #f)
+ (define first-reduction #f)
+ (define last-reduction #f)
+ (define nshifts #f)
+ (define maxrhs #f)
+ (define ngotos #f)
+ (define token-set-size #f)
+
+ (define driver-name 'lr-driver)
+
+ (define (gen-tables! tokens gram )
+ (initialize-all)
+ (rewrite-grammar
+ tokens
+ gram
+ (lambda (terms terms/prec vars gram gram/actions)
+ (set! the-terminals/prec (list->vector terms/prec))
+ (set! the-terminals (list->vector terms))
+ (set! the-nonterminals (list->vector vars))
+ (set! nterms (length terms))
+ (set! nvars (length vars))
+ (set! nsyms (+ nterms nvars))
+ (let ((no-of-rules (length gram/actions))
+ (no-of-items (let loop ((l gram/actions) (count 0))
+ (if (null? l)
+ count
+ (loop (cdr l) (+ count (length (caar l))))))))
+ (pack-grammar no-of-rules no-of-items gram)
+ (set-derives)
+ (set-nullable)
+ (generate-states)
+ (lalr)
+ (build-tables)
+ (compact-action-table terms)
+ gram/actions))))
+
+
+ (define (initialize-all)
+ (set! rrhs #f)
+ (set! rlhs #f)
+ (set! ritem #f)
+ (set! nullable #f)
+ (set! derives #f)
+ (set! fderives #f)
+ (set! firsts #f)
+ (set! kernel-base #f)
+ (set! kernel-end #f)
+ (set! shift-symbol #f)
+ (set! shift-set #f)
+ (set! red-set #f)
+ (set! state-table (make-vector STATE-TABLE-SIZE '()))
+ (set! acces-symbol #f)
+ (set! reduction-table #f)
+ (set! shift-table #f)
+ (set! consistent #f)
+ (set! lookaheads #f)
+ (set! LA #f)
+ (set! LAruleno #f)
+ (set! lookback #f)
+ (set! goto-map #f)
+ (set! from-state #f)
+ (set! to-state #f)
+ (set! includes #f)
+ (set! F #f)
+ (set! action-table #f)
+ (set! nstates #f)
+ (set! first-state #f)
+ (set! last-state #f)
+ (set! final-state #f)
+ (set! first-shift #f)
+ (set! last-shift #f)
+ (set! first-reduction #f)
+ (set! last-reduction #f)
+ (set! nshifts #f)
+ (set! maxrhs #f)
+ (set! ngotos #f)
+ (set! token-set-size #f)
+ (set! rule-precedences '()))
+
+
+ (define (pack-grammar no-of-rules no-of-items gram)
+ (set! nrules (+ no-of-rules 1))
+ (set! nitems no-of-items)
+ (set! rlhs (make-vector nrules #f))
+ (set! rrhs (make-vector nrules #f))
+ (set! ritem (make-vector (+ 1 nitems) #f))
+
+ (let loop ((p gram) (item-no 0) (rule-no 1))
+ (if (not (null? p))
+ (let ((nt (caar p)))
+ (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
+ (if (null? prods)
+ (loop (cdr p) it-no2 rl-no2)
+ (begin
+ (vector-set! rlhs rl-no2 nt)
+ (vector-set! rrhs rl-no2 it-no2)
+ (let loop3 ((rhs (car prods)) (it-no3 it-no2))
+ (if (null? rhs)
+ (begin
+ (vector-set! ritem it-no3 (- rl-no2))
+ (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
+ (begin
+ (vector-set! ritem it-no3 (car rhs))
+ (loop3 (cdr rhs) (+ it-no3 1))))))))))))
+
+
+ (define (set-derives)
+ (define delts (make-vector (+ nrules 1) 0))
+ (define dset (make-vector nvars -1))
+
+ (let loop ((i 1) (j 0)) ; i = 0
+ (if (< i nrules)
+ (let ((lhs (vector-ref rlhs i)))
+ (if (>= lhs 0)
+ (begin
+ (vector-set! delts j (cons i (vector-ref dset lhs)))
+ (vector-set! dset lhs j)
+ (loop (+ i 1) (+ j 1)))
+ (loop (+ i 1) j)))))
+
+ (set! derives (make-vector nvars 0))
+
+ (let loop ((i 0))
+ (if (< i nvars)
+ (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
+ (if (< j 0)
+ s
+ (let ((x (vector-ref delts j)))
+ (loop2 (cdr x) (cons (car x) s)))))))
+ (vector-set! derives i q)
+ (loop (+ i 1))))))
+
+
+
+ (define (set-nullable)
+ (set! nullable (make-vector nvars #f))
+ (let ((squeue (make-vector nvars #f))
+ (rcount (make-vector (+ nrules 1) 0))
+ (rsets (make-vector nvars #f))
+ (relts (make-vector (+ nitems nvars 1) #f)))
+ (let loop ((r 0) (s2 0) (p 0))
+ (let ((*r (vector-ref ritem r)))
+ (if *r
+ (if (< *r 0)
+ (let ((symbol (vector-ref rlhs (- *r))))
+ (if (and (>= symbol 0)
+ (not (vector-ref nullable symbol)))
+ (begin
+ (vector-set! nullable symbol #t)
+ (vector-set! squeue s2 symbol)
+ (loop (+ r 1) (+ s2 1) p))))
+ (let loop2 ((r1 r) (any-tokens #f))
+ (let* ((symbol (vector-ref ritem r1)))
+ (if (> symbol 0)
+ (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
+ (if (not any-tokens)
+ (let ((ruleno (- symbol)))
+ (let loop3 ((r2 r) (p2 p))
+ (let ((symbol (vector-ref ritem r2)))
+ (if (> symbol 0)
+ (begin
+ (vector-set! rcount ruleno
+ (+ (vector-ref rcount
ruleno) 1))
+ (vector-set! relts p2
+ (cons (vector-ref rsets
symbol)
+ ruleno))
+ (vector-set! rsets symbol p2)
+ (loop3 (+ r2 1) (+ p2 1)))
+ (loop (+ r2 1) s2 p2)))))
+ (loop (+ r1 1) s2 p))))))
+ (let loop ((s1 0) (s3 s2))
+ (if (< s1 s3)
+ (let loop2 ((p (vector-ref rsets (vector-ref squeue s1)))
(s4 s3))
+ (if p
+ (let* ((x (vector-ref relts p))
+ (ruleno (cdr x))
+ (y (- (vector-ref rcount ruleno) 1)))
+ (vector-set! rcount ruleno y)
+ (if (= y 0)
+ (let ((symbol (vector-ref rlhs ruleno)))
+ (if (and (>= symbol 0)
+ (not (vector-ref nullable symbol)))
+ (begin
+ (vector-set! nullable symbol #t)
+ (vector-set! squeue s4 symbol)
+ (loop2 (car x) (+ s4 1)))
+ (loop2 (car x) s4)))
+ (loop2 (car x) s4))))
+ (loop (+ s1 1) s4)))))))))
+
+
+
+ (define (set-firsts)
+ (set! firsts (make-vector nvars '()))
+
+ ;; -- initialization
+ (let loop ((i 0))
+ (if (< i nvars)
+ (let loop2 ((sp (vector-ref derives i)))
+ (if (null? sp)
+ (loop (+ i 1))
+ (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
+ (if (< -1 sym nvars)
+ (vector-set! firsts i (sinsert sym (vector-ref firsts
i))))
+ (loop2 (cdr sp)))))))
+
+ ;; -- reflexive and transitive closure
+ (let loop ((continue #t))
+ (if continue
+ (let loop2 ((i 0) (cont #f))
+ (if (>= i nvars)
+ (loop cont)
+ (let* ((x (vector-ref firsts i))
+ (y (let loop3 ((l x) (z x))
+ (if (null? l)
+ z
+ (loop3 (cdr l)
+ (sunion (vector-ref firsts (car l))
z))))))
+ (if (equal? x y)
+ (loop2 (+ i 1) cont)
+ (begin
+ (vector-set! firsts i y)
+ (loop2 (+ i 1) #t))))))))
+
+ (let loop ((i 0))
+ (if (< i nvars)
+ (begin
+ (vector-set! firsts i (sinsert i (vector-ref firsts i)))
+ (loop (+ i 1))))))
+
+
+
+
+ (define (set-fderives)
+ (set! fderives (make-vector nvars #f))
+
+ (set-firsts)
+
+ (let loop ((i 0))
+ (if (< i nvars)
+ (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
+ (if (null? l)
+ fd
+ (loop2 (cdr l)
+ (sunion (vector-ref derives (car l)) fd))))))
+ (vector-set! fderives i x)
+ (loop (+ i 1))))))
+
+
+ (define (closure core)
+ ;; Initialization
+ (define ruleset (make-vector nrules #f))
+
+ (let loop ((csp core))
+ (if (not (null? csp))
+ (let ((sym (vector-ref ritem (car csp))))
+ (if (< -1 sym nvars)
+ (let loop2 ((dsp (vector-ref fderives sym)))
+ (if (not (null? dsp))
+ (begin
+ (vector-set! ruleset (car dsp) #t)
+ (loop2 (cdr dsp))))))
+ (loop (cdr csp)))))
+
+ (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
+ (if (< ruleno nrules)
+ (if (vector-ref ruleset ruleno)
+ (let ((itemno (vector-ref rrhs ruleno)))
+ (let loop2 ((c csp) (itemsetv2 itemsetv))
+ (if (and (pair? c)
+ (< (car c) itemno))
+ (loop2 (cdr c) (cons (car c) itemsetv2))
+ (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
+ (loop (+ ruleno 1) csp itemsetv))
+ (let loop2 ((c csp) (itemsetv2 itemsetv))
+ (if (pair? c)
+ (loop2 (cdr c) (cons (car c) itemsetv2))
+ (reverse itemsetv2))))))
+
+
+
+ (define (allocate-item-sets)
+ (set! kernel-base (make-vector nsyms 0))
+ (set! kernel-end (make-vector nsyms #f)))
+
+
+ (define (allocate-storage)
+ (allocate-item-sets)
+ (set! red-set (make-vector (+ nrules 1) 0)))
+
+ ; --
+
+
+ (define (initialize-states)
+ (let ((p (new-core)))
+ (set-core-number! p 0)
+ (set-core-acc-sym! p #f)
+ (set-core-nitems! p 1)
+ (set-core-items! p '(0))
+
+ (set! first-state (list p))
+ (set! last-state first-state)
+ (set! nstates 1)))
+
+
+
+ (define (generate-states)
+ (allocate-storage)
+ (set-fderives)
+ (initialize-states)
+ (let loop ((this-state first-state))
+ (if (pair? this-state)
+ (let* ((x (car this-state))
+ (is (closure (core-items x))))
+ (save-reductions x is)
+ (new-itemsets is)
+ (append-states)
+ (if (> nshifts 0)
+ (save-shifts x))
+ (loop (cdr this-state))))))
+
+
+ (define (new-itemsets itemset)
+ ;; - Initialization
+ (set! shift-symbol '())
+ (let loop ((i 0))
+ (if (< i nsyms)
+ (begin
+ (vector-set! kernel-end i '())
+ (loop (+ i 1)))))
+
+ (let loop ((isp itemset))
+ (if (pair? isp)
+ (let* ((i (car isp))
+ (sym (vector-ref ritem i)))
+ (if (>= sym 0)
+ (begin
+ (set! shift-symbol (sinsert sym shift-symbol))
+ (let ((x (vector-ref kernel-end sym)))
+ (if (null? x)
+ (begin
+ (vector-set! kernel-base sym (cons (+ i 1) x))
+ (vector-set! kernel-end sym (vector-ref kernel-base
sym)))
+ (begin
+ (set-cdr! x (list (+ i 1)))
+ (vector-set! kernel-end sym (cdr x)))))))
+ (loop (cdr isp)))))
+
+ (set! nshifts (length shift-symbol)))
+
+
+
+ (define (get-state sym)
+ (let* ((isp (vector-ref kernel-base sym))
+ (n (length isp))
+ (key (let loop ((isp1 isp) (k 0))
+ (if (null? isp1)
+ (modulo k STATE-TABLE-SIZE)
+ (loop (cdr isp1) (+ k (car isp1))))))
+ (sp (vector-ref state-table key)))
+ (if (null? sp)
+ (let ((x (new-state sym)))
+ (vector-set! state-table key (list x))
+ (core-number x))
+ (let loop ((sp1 sp))
+ (if (and (= n (core-nitems (car sp1)))
+ (let loop2 ((i1 isp) (t (core-items (car sp1))))
+ (if (and (pair? i1)
+ (= (car i1)
+ (car t)))
+ (loop2 (cdr i1) (cdr t))
+ (null? i1))))
+ (core-number (car sp1))
+ (if (null? (cdr sp1))
+ (let ((x (new-state sym)))
+ (set-cdr! sp1 (list x))
+ (core-number x))
+ (loop (cdr sp1))))))))
+
+
+ (define (new-state sym)
+ (let* ((isp (vector-ref kernel-base sym))
+ (n (length isp))
+ (p (new-core)))
+ (set-core-number! p nstates)
+ (set-core-acc-sym! p sym)
+ (if (= sym nvars) (set! final-state nstates))
+ (set-core-nitems! p n)
+ (set-core-items! p isp)
+ (set-cdr! last-state (list p))
+ (set! last-state (cdr last-state))
+ (set! nstates (+ nstates 1))
+ p))
+
+
+ ; --
+
+ (define (append-states)
+ (set! shift-set
+ (let loop ((l (reverse shift-symbol)))
+ (if (null? l)
+ '()
+ (cons (get-state (car l)) (loop (cdr l)))))))
+
+ ; --
+
+ (define (save-shifts core)
+ (let ((p (new-shift)))
+ (set-shift-number! p (core-number core))
+ (set-shift-nshifts! p nshifts)
+ (set-shift-shifts! p shift-set)
+ (if last-shift
+ (begin
+ (set-cdr! last-shift (list p))
+ (set! last-shift (cdr last-shift)))
+ (begin
+ (set! first-shift (list p))
+ (set! last-shift first-shift)))))
+
+ (define (save-reductions core itemset)
+ (let ((rs (let loop ((l itemset))
+ (if (null? l)
+ '()
+ (let ((item (vector-ref ritem (car l))))
+ (if (< item 0)
+ (cons (- item) (loop (cdr l)))
+ (loop (cdr l))))))))
+ (if (pair? rs)
+ (let ((p (new-red)))
+ (set-red-number! p (core-number core))
+ (set-red-nreds! p (length rs))
+ (set-red-rules! p rs)
+ (if last-reduction
+ (begin
+ (set-cdr! last-reduction (list p))
+ (set! last-reduction (cdr last-reduction)))
+ (begin
+ (set! first-reduction (list p))
+ (set! last-reduction first-reduction)))))))
+
+
+ ; --
+
+ (define (lalr)
+ (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
+ (set-accessing-symbol)
+ (set-shift-table)
+ (set-reduction-table)
+ (set-max-rhs)
+ (initialize-LA)
+ (set-goto-map)
+ (initialize-F)
+ (build-relations)
+ (digraph includes)
+ (compute-lookaheads))
+
+ (define (set-accessing-symbol)
+ (set! acces-symbol (make-vector nstates #f))
+ (let loop ((l first-state))
+ (if (pair? l)
+ (let ((x (car l)))
+ (vector-set! acces-symbol (core-number x) (core-acc-sym x))
+ (loop (cdr l))))))
+
+ (define (set-shift-table)
+ (set! shift-table (make-vector nstates #f))
+ (let loop ((l first-shift))
+ (if (pair? l)
+ (let ((x (car l)))
+ (vector-set! shift-table (shift-number x) x)
+ (loop (cdr l))))))
+
+ (define (set-reduction-table)
+ (set! reduction-table (make-vector nstates #f))
+ (let loop ((l first-reduction))
+ (if (pair? l)
+ (let ((x (car l)))
+ (vector-set! reduction-table (red-number x) x)
+ (loop (cdr l))))))
+
+ (define (set-max-rhs)
+ (let loop ((p 0) (curmax 0) (length 0))
+ (let ((x (vector-ref ritem p)))
+ (if x
+ (if (>= x 0)
+ (loop (+ p 1) curmax (+ length 1))
+ (loop (+ p 1) (max curmax length) 0))
+ (set! maxrhs curmax)))))
+
+ (define (initialize-LA)
+ (define (last l)
+ (if (null? (cdr l))
+ (car l)
+ (last (cdr l))))
+
+ (set! consistent (make-vector nstates #f))
+ (set! lookaheads (make-vector (+ nstates 1) #f))
+
+ (let loop ((count 0) (i 0))
+ (if (< i nstates)
+ (begin
+ (vector-set! lookaheads i count)
+ (let ((rp (vector-ref reduction-table i))
+ (sp (vector-ref shift-table i)))
+ (if (and rp
+ (or (> (red-nreds rp) 1)
+ (and sp
+ (not
+ (< (vector-ref acces-symbol
+ (last (shift-shifts sp)))
+ nvars)))))
+ (loop (+ count (red-nreds rp)) (+ i 1))
+ (begin
+ (vector-set! consistent i #t)
+ (loop count (+ i 1))))))
+
+ (begin
+ (vector-set! lookaheads nstates count)
+ (let ((c (max count 1)))
+ (set! LA (make-vector c #f))
+ (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set
token-set-size)))
+ (set! LAruleno (make-vector c -1))
+ (set! lookback (make-vector c #f)))
+ (let loop ((i 0) (np 0))
+ (if (< i nstates)
+ (if (vector-ref consistent i)
+ (loop (+ i 1) np)
+ (let ((rp (vector-ref reduction-table i)))
+ (if rp
+ (let loop2 ((j (red-rules rp)) (np2 np))
+ (if (null? j)
+ (loop (+ i 1) np2)
+ (begin
+ (vector-set! LAruleno np2 (car j))
+ (loop2 (cdr j) (+ np2 1)))))
+ (loop (+ i 1) np))))))))))
+
+
+ (define (set-goto-map)
+ (set! goto-map (make-vector (+ nvars 1) 0))
+ (let ((temp-map (make-vector (+ nvars 1) 0)))
+ (let loop ((ng 0) (sp first-shift))
+ (if (pair? sp)
+ (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
+ (if (pair? i)
+ (let ((symbol (vector-ref acces-symbol (car i))))
+ (if (< symbol nvars)
+ (begin
+ (vector-set! goto-map symbol
+ (+ 1 (vector-ref goto-map symbol)))
+ (loop2 (cdr i) (+ ng2 1)))
+ (loop2 (cdr i) ng2)))
+ (loop ng2 (cdr sp))))
+
+ (let loop ((k 0) (i 0))
+ (if (< i nvars)
+ (begin
+ (vector-set! temp-map i k)
+ (loop (+ k (vector-ref goto-map i)) (+ i 1)))
+
+ (begin
+ (do ((i 0 (+ i 1)))
+ ((>= i nvars))
+ (vector-set! goto-map i (vector-ref temp-map i)))
+
+ (set! ngotos ng)
+ (vector-set! goto-map nvars ngotos)
+ (vector-set! temp-map nvars ngotos)
+ (set! from-state (make-vector ngotos #f))
+ (set! to-state (make-vector ngotos #f))
+
+ (do ((sp first-shift (cdr sp)))
+ ((null? sp))
+ (let* ((x (car sp))
+ (state1 (shift-number x)))
+ (do ((i (shift-shifts x) (cdr i)))
+ ((null? i))
+ (let* ((state2 (car i))
+ (symbol (vector-ref acces-symbol state2)))
+ (if (< symbol nvars)
+ (let ((k (vector-ref temp-map symbol)))
+ (vector-set! temp-map symbol (+ k 1))
+ (vector-set! from-state k state1)
+ (vector-set! to-state k state2))))))))))))))
+
+
+ (define (map-goto state symbol)
+ (let loop ((low (vector-ref goto-map symbol))
+ (high (- (vector-ref goto-map (+ symbol 1)) 1)))
+ (if (> low high)
+ (begin
+ (display (list "Error in map-goto" state symbol)) (newline)
+ 0)
+ (let* ((middle (quotient (+ low high) 2))
+ (s (vector-ref from-state middle)))
+ (cond
+ ((= s state)
+ middle)
+ ((< s state)
+ (loop (+ middle 1) high))
+ (else
+ (loop low (- middle 1))))))))
+
+
+ (define (initialize-F)
+ (set! F (make-vector ngotos #f))
+ (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set
token-set-size)))
+
+ (let ((reads (make-vector ngotos #f)))
+
+ (let loop ((i 0) (rowp 0))
+ (if (< i ngotos)
+ (let* ((rowf (vector-ref F rowp))
+ (stateno (vector-ref to-state i))
+ (sp (vector-ref shift-table stateno)))
+ (if sp
+ (let loop2 ((j (shift-shifts sp)) (edges '()))
+ (if (pair? j)
+ (let ((symbol (vector-ref acces-symbol (car j))))
+ (if (< symbol nvars)
+ (if (vector-ref nullable symbol)
+ (loop2 (cdr j) (cons (map-goto stateno symbol)
+ edges))
+ (loop2 (cdr j) edges))
+ (begin
+ (set-bit rowf (- symbol nvars))
+ (loop2 (cdr j) edges))))
+ (if (pair? edges)
+ (vector-set! reads i (reverse edges))))))
+ (loop (+ i 1) (+ rowp 1)))))
+ (digraph reads)))
+
+ (define (add-lookback-edge stateno ruleno gotono)
+ (let ((k (vector-ref lookaheads (+ stateno 1))))
+ (let loop ((found #f) (i (vector-ref lookaheads stateno)))
+ (if (and (not found) (< i k))
+ (if (= (vector-ref LAruleno i) ruleno)
+ (loop #t i)
+ (loop found (+ i 1)))
+
+ (if (not found)
+ (begin (display "Error in add-lookback-edge : ")
+ (display (list stateno ruleno gotono)) (newline))
+ (vector-set! lookback i
+ (cons gotono (vector-ref lookback i))))))))
+
+
+ (define (transpose r-arg n)
+ (let ((new-end (make-vector n #f))
+ (new-R (make-vector n #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (let ((x (list 'bidon)))
+ (vector-set! new-R i x)
+ (vector-set! new-end i x)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (let ((sp (vector-ref r-arg i)))
+ (if (pair? sp)
+ (let loop ((sp2 sp))
+ (if (pair? sp2)
+ (let* ((x (car sp2))
+ (y (vector-ref new-end x)))
+ (set-cdr! y (cons i (cdr y)))
+ (vector-set! new-end x (cdr y))
+ (loop (cdr sp2))))))))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! new-R i (cdr (vector-ref new-R i))))
+
+ new-R))
+
+
+
+ (define (build-relations)
+
+ (define (get-state stateno symbol)
+ (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
+ (stno stateno))
+ (if (null? j)
+ stno
+ (let ((st2 (car j)))
+ (if (= (vector-ref acces-symbol st2) symbol)
+ st2
+ (loop (cdr j) st2))))))
+
+ (set! includes (make-vector ngotos #f))
+ (do ((i 0 (+ i 1)))
+ ((= i ngotos))
+ (let ((state1 (vector-ref from-state i))
+ (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
+ (let loop ((rulep (vector-ref derives symbol1))
+ (edges '()))
+ (if (pair? rulep)
+ (let ((*rulep (car rulep)))
+ (let loop2 ((rp (vector-ref rrhs *rulep))
+ (stateno state1)
+ (states (list state1)))
+ (let ((*rp (vector-ref ritem rp)))
+ (if (> *rp 0)
+ (let ((st (get-state stateno *rp)))
+ (loop2 (+ rp 1) st (cons st states)))
+ (begin
+
+ (if (not (vector-ref consistent stateno))
+ (add-lookback-edge stateno *rulep i))
+
+ (let loop2 ((done #f)
+ (stp (cdr states))
+ (rp2 (- rp 1))
+ (edgp edges))
+ (if (not done)
+ (let ((*rp (vector-ref ritem rp2)))
+ (if (< -1 *rp nvars)
+ (loop2 (not (vector-ref nullable *rp))
+ (cdr stp)
+ (- rp2 1)
+ (cons (map-goto (car stp) *rp)
edgp))
+ (loop2 #t stp rp2 edgp)))
+
+ (loop (cdr rulep) edgp))))))))
+ (vector-set! includes i edges)))))
+ (set! includes (transpose includes ngotos)))
+
+
+
+ (define (compute-lookaheads)
+ (let ((n (vector-ref lookaheads nstates)))
+ (let loop ((i 0))
+ (if (< i n)
+ (let loop2 ((sp (vector-ref lookback i)))
+ (if (pair? sp)
+ (let ((LA-i (vector-ref LA i))
+ (F-j (vector-ref F (car sp))))
+ (bit-union LA-i F-j token-set-size)
+ (loop2 (cdr sp)))
+ (loop (+ i 1))))))))
+
+
+
+ (define (digraph relation)
+ (define infinity (+ ngotos 2))
+ (define INDEX (make-vector (+ ngotos 1) 0))
+ (define VERTICES (make-vector (+ ngotos 1) 0))
+ (define top 0)
+ (define R relation)
+
+ (define (traverse i)
+ (set! top (+ 1 top))
+ (vector-set! VERTICES top i)
+ (let ((height top))
+ (vector-set! INDEX i height)
+ (let ((rp (vector-ref R i)))
+ (if (pair? rp)
+ (let loop ((rp2 rp))
+ (if (pair? rp2)
+ (let ((j (car rp2)))
+ (if (= 0 (vector-ref INDEX j))
+ (traverse j))
+ (if (> (vector-ref INDEX i)
+ (vector-ref INDEX j))
+ (vector-set! INDEX i (vector-ref INDEX j)))
+ (let ((F-i (vector-ref F i))
+ (F-j (vector-ref F j)))
+ (bit-union F-i F-j token-set-size))
+ (loop (cdr rp2))))))
+ (if (= (vector-ref INDEX i) height)
+ (let loop ()
+ (let ((j (vector-ref VERTICES top)))
+ (set! top (- top 1))
+ (vector-set! INDEX j infinity)
+ (if (not (= i j))
+ (begin
+ (bit-union (vector-ref F i)
+ (vector-ref F j)
+ token-set-size)
+ (loop)))))))))
+
+ (let loop ((i 0))
+ (if (< i ngotos)
+ (begin
+ (if (and (= 0 (vector-ref INDEX i))
+ (pair? (vector-ref R i)))
+ (traverse i))
+ (loop (+ i 1))))))
+
+
+ ;; ----------------------------------------------------------------------
+ ;; operator precedence management
+ ;; ----------------------------------------------------------------------
+
+ ;; a vector of precedence descriptors where each element
+ ;; is of the form (terminal type precedence)
+ (define the-terminals/prec #f) ; terminal symbols with precedence
+ ; the precedence is an integer >= 0
+ (define (get-symbol-precedence sym)
+ (caddr (vector-ref the-terminals/prec sym)))
+ ; the operator type is either 'none,
'left, 'right, or 'nonassoc
+ (define (get-symbol-assoc sym)
+ (cadr (vector-ref the-terminals/prec sym)))
+
+ (define rule-precedences '())
+ (define (add-rule-precedence! rule sym)
+ (set! rule-precedences
+ (cons (cons rule sym) rule-precedences)))
+
+ (define (get-rule-precedence ruleno)
+ (cond
+ ((assq ruleno rule-precedences)
+ => (lambda (p)
+ (get-symbol-precedence (cdr p))))
+ (else
+ ;; process the rule symbols from left to right
+ (let loop ((i (vector-ref rrhs ruleno))
+ (prec 0))
+ (let ((item (vector-ref ritem i)))
+ ;; end of rule
+ (if (< item 0)
+ prec
+ (let ((i1 (+ i 1)))
+ (if (>= item nvars)
+ ;; it's a terminal symbol
+ (loop i1 (get-symbol-precedence (- item nvars)))
+ (loop i1 prec)))))))))
+
+ ;; ----------------------------------------------------------------------
+ ;; Build the various tables
+ ;; ----------------------------------------------------------------------
+
+ (define expected-conflicts 0)
+
+ (define (build-tables)
+
+ (define (resolve-conflict sym rule)
+ (let ((sym-prec (get-symbol-precedence sym))
+ (sym-assoc (get-symbol-assoc sym))
+ (rule-prec (get-rule-precedence rule)))
+ (cond
+ ((> sym-prec rule-prec) 'shift)
+ ((< sym-prec rule-prec) 'reduce)
+ ((eq? sym-assoc 'left) 'reduce)
+ ((eq? sym-assoc 'right) 'shift)
+ (else 'none))))
+
+ (define conflict-messages '())
+
+ (define (add-conflict-message . l)
+ (set! conflict-messages (cons l conflict-messages)))
+
+ (define (log-conflicts)
+ (if (> (length conflict-messages) expected-conflicts)
+ (for-each
+ (lambda (message)
+ (for-each display message)
+ (newline))
+ conflict-messages)))
+
+ ;; --- Add an action to the action table
+ (define (add-action state symbol new-action)
+ (let* ((state-actions (vector-ref action-table state))
+ (actions (assv symbol state-actions)))
+ (if (pair? actions)
+ (let ((current-action (cadr actions)))
+ (if (not (= new-action current-action))
+ ;; -- there is a conflict
+ (begin
+ (if (and (<= current-action 0) (<= new-action 0))
+ ;; --- reduce/reduce conflict
+ (begin
+ (add-conflict-message
+ "%% Reduce/Reduce conflict (reduce " (- new-action)
", reduce " (- current-action)
+ ") on '" (get-symbol (+ symbol nvars)) "' in state "
state)
+ (if (eq? driver-name 'glr-driver)
+ (set-cdr! (cdr actions) (cons new-action (cddr
actions)))
+ (set-car! (cdr actions) (max current-action
new-action))))
+ ;; --- shift/reduce conflict
+ ;; can we resolve the conflict using precedences?
+ (case (resolve-conflict symbol (- current-action))
+ ;; -- shift
+ ((shift) (if (eq? driver-name 'glr-driver)
+ (set-cdr! (cdr actions) (cons
new-action (cddr actions)))
+ (set-car! (cdr actions) new-action)))
+ ;; -- reduce
+ ((reduce) #f) ; well, nothing to do...
+ ;; -- signal a conflict!
+ (else (add-conflict-message
+ "%% Shift/Reduce conflict (shift "
new-action ", reduce " (- current-action)
+ ") on '" (get-symbol (+ symbol nvars)) "'
in state " state)
+ (if (eq? driver-name 'glr-driver)
+ (set-cdr! (cdr actions) (cons
new-action (cddr actions)))
+ (set-car! (cdr actions)
new-action))))))))
+
+ (vector-set! action-table state (cons (list symbol new-action)
state-actions)))))
+
+ (define (add-action-for-all-terminals state action)
+ (do ((i 1 (+ i 1)))
+ ((= i nterms))
+ (add-action state i action)))
+
+ (set! action-table (make-vector nstates '()))
+
+ (do ((i 0 (+ i 1))) ; i = state
+ ((= i nstates))
+ (let ((red (vector-ref reduction-table i)))
+ (if (and red (>= (red-nreds red) 1))
+ (if (and (= (red-nreds red) 1) (vector-ref consistent i))
+ (add-action-for-all-terminals i (- (car (red-rules red))))
+ (let ((k (vector-ref lookaheads (+ i 1))))
+ (let loop ((j (vector-ref lookaheads i)))
+ (if (< j k)
+ (let ((rule (- (vector-ref LAruleno j)))
+ (lav (vector-ref LA j)))
+ (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z
0))
+ (if (< token nterms)
+ (begin
+ (let ((in-la-set? (modulo x 2)))
+ (if (= in-la-set? 1)
+ (add-action i token rule)))
+ (if (= y (BITS-PER-WORD))
+ (loop2 (+ token 1)
+ (vector-ref lav (+ z 1))
+ 1
+ (+ z 1))
+ (loop2 (+ token 1) (quotient x 2) (+ y 1)
z)))))
+ (loop (+ j 1)))))))))
+
+ (let ((shiftp (vector-ref shift-table i)))
+ (if shiftp
+ (let loop ((k (shift-shifts shiftp)))
+ (if (pair? k)
+ (let* ((state (car k))
+ (symbol (vector-ref acces-symbol state)))
+ (if (>= symbol nvars)
+ (add-action i (- symbol nvars) state))
+ (loop (cdr k))))))))
+
+ (add-action final-state 0 'accept)
+ (log-conflicts))
+
+ (define (compact-action-table terms)
+ (define (most-common-action acts)
+ (let ((accums '()))
+ (let loop ((l acts))
+ (if (pair? l)
+ (let* ((x (cadar l))
+ (y (assv x accums)))
+ (if (and (number? x) (< x 0))
+ (if y
+ (set-cdr! y (+ 1 (cdr y)))
+ (set! accums (cons `(,x . 1) accums))))
+ (loop (cdr l)))))
+
+ (let loop ((l accums) (max 0) (sym #f))
+ (if (null? l)
+ sym
+ (let ((x (car l)))
+ (if (> (cdr x) max)
+ (loop (cdr l) (cdr x) (car x))
+ (loop (cdr l) max sym)))))))
+
+ (define (translate-terms acts)
+ (map (lambda (act)
+ (cons (list-ref terms (car act))
+ (cdr act)))
+ acts))
+
+ (do ((i 0 (+ i 1)))
+ ((= i nstates))
+ (let ((acts (vector-ref action-table i)))
+ (if (vector? (vector-ref reduction-table i))
+ (let ((act (most-common-action acts)))
+ (vector-set! action-table i
+ (cons `(*default* ,(if act act '*error*))
+ (translate-terms
+ (lalr-filter (lambda (x)
+ (not (and (= (length x) 2)
+ (eq? (cadr x) act))))
+ acts)))))
+ (vector-set! action-table i
+ (cons `(*default* *error*)
+ (translate-terms acts)))))))
+
+
+
+ ;; --
+
+ (define (rewrite-grammar tokens grammar k)
+
+ (define eoi '*eoi*)
+
+ (define (check-terminal term terms)
+ (cond
+ ((not (valid-terminal? term))
+ (lalr-error "invalid terminal: " term))
+ ((member term terms)
+ (lalr-error "duplicate definition of terminal: " term))))
+
+ (define (prec->type prec)
+ (cdr (assq prec '((left: . left)
+ (right: . right)
+ (nonassoc: . nonassoc)))))
+
+ (cond
+ ;; --- a few error conditions
+ ((not (list? tokens))
+ (lalr-error "Invalid token list: " tokens))
+ ((not (pair? grammar))
+ (lalr-error "Grammar definition must have a non-empty list of
productions" '()))
+
+ (else
+ ;; --- check the terminals
+ (let loop1 ((lst tokens)
+ (rev-terms '())
+ (rev-terms/prec '())
+ (prec-level 0))
+ (if (pair? lst)
+ (let ((term (car lst)))
+ (cond
+ ((pair? term)
+ (if (and (memq (car term) '(left: right: nonassoc:))
+ (not (null? (cdr term))))
+ (let ((prec (+ prec-level 1))
+ (optype (prec->type (car term))))
+ (let loop-toks ((l (cdr term))
+ (rev-terms rev-terms)
+ (rev-terms/prec rev-terms/prec))
+ (if (null? l)
+ (loop1 (cdr lst) rev-terms rev-terms/prec prec)
+ (let ((term (car l)))
+ (check-terminal term rev-terms)
+ (loop-toks
+ (cdr l)
+ (cons term rev-terms)
+ (cons (list term optype prec)
rev-terms/prec))))))
+
+ (lalr-error "invalid operator precedence specification: "
term)))
+
+ (else
+ (check-terminal term rev-terms)
+ (loop1 (cdr lst)
+ (cons term rev-terms)
+ (cons (list term 'none 0) rev-terms/prec)
+ prec-level))))
+
+ ;; --- check the grammar rules
+ (let loop2 ((lst grammar) (rev-nonterm-defs '()))
+ (if (pair? lst)
+ (let ((def (car lst)))
+ (if (not (pair? def))
+ (lalr-error "Nonterminal definition must be a non-empty
list" '())
+ (let ((nonterm (car def)))
+ (cond ((not (valid-nonterminal? nonterm))
+ (lalr-error "Invalid nonterminal:" nonterm))
+ ((or (member nonterm rev-terms)
+ (assoc nonterm rev-nonterm-defs))
+ (lalr-error "Nonterminal previously defined:"
nonterm))
+ (else
+ (loop2 (cdr lst)
+ (cons def rev-nonterm-defs)))))))
+ (let* ((terms (cons eoi (cons 'error
(reverse rev-terms))))
+ (terms/prec (cons '(eoi none 0) (cons '(error none
0) (reverse rev-terms/prec))))
+ (nonterm-defs (reverse rev-nonterm-defs))
+ (nonterms (cons '*start* (map car nonterm-defs))))
+ (if (= (length nonterms) 1)
+ (lalr-error "Grammar must contain at least one
nonterminal" '())
+ (let loop-defs ((defs (cons `(*start* (,(cadr
nonterms) ,eoi) : $1)
+ nonterm-defs))
+ (ruleno 0)
+ (comp-defs '()))
+ (if (pair? defs)
+ (let* ((nonterm-def (car defs))
+ (compiled-def (rewrite-nonterm-def
+ nonterm-def
+ ruleno
+ terms nonterms)))
+ (loop-defs (cdr defs)
+ (+ ruleno (length compiled-def))
+ (cons compiled-def comp-defs)))
+
+ (let ((compiled-nonterm-defs (reverse comp-defs)))
+ (k terms
+ terms/prec
+ nonterms
+ (map (lambda (x) (cons (caaar x) (map cdar
x)))
+ compiled-nonterm-defs)
+ (apply append
compiled-nonterm-defs))))))))))))))
+
+
+ (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
+
+ (define No-NT (length nonterms))
+
+ (define (encode x)
+ (let ((PosInNT (pos-in-list x nonterms)))
+ (if PosInNT
+ PosInNT
+ (let ((PosInT (pos-in-list x terms)))
+ (if PosInT
+ (+ No-NT PosInT)
+ (lalr-error "undefined symbol : " x))))))
+
+ (define (process-prec-directive rhs ruleno)
+ (let loop ((l rhs))
+ (if (null? l)
+ '()
+ (let ((first (car l))
+ (rest (cdr l)))
+ (cond
+ ((or (member first terms) (member first nonterms))
+ (cons first (loop rest)))
+ ((and (pair? first)
+ (eq? (car first) 'prec:))
+ (if (and (pair? (cdr first))
+ (null? (cddr first))
+ (member (cadr first) terms))
+ (if (null? rest)
+ (begin
+ (add-rule-precedence! ruleno (pos-in-list (cadr
first) terms))
+ (loop rest))
+ (lalr-error "prec: directive should be at end of rule:
" rhs))
+ (lalr-error "Invalid prec: directive: " first)))
+ (else
+ (lalr-error "Invalid terminal or nonterminal: " first)))))))
+
+ (define (check-error-production rhs)
+ (let loop ((rhs rhs))
+ (if (pair? rhs)
+ (begin
+ (if (and (eq? (car rhs) 'error)
+ (or (null? (cdr rhs))
+ (not (member (cadr rhs) terms))
+ (not (null? (cddr rhs)))))
+ (lalr-error "Invalid 'error' production. A single terminal
symbol must follow the 'error' token.:" rhs))
+ (loop (cdr rhs))))))
+
+
+ (if (not (pair? (cdr nonterm-def)))
+ (lalr-error "At least one production needed for nonterminal:" (car
nonterm-def))
+ (let ((name (symbol->string (car nonterm-def))))
+ (let loop1 ((lst (cdr nonterm-def))
+ (i 1)
+ (rev-productions-and-actions '()))
+ (if (not (pair? lst))
+ (reverse rev-productions-and-actions)
+ (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1)))
+ (rest (cdr lst))
+ (prod (map encode (cons (car nonterm-def) rhs))))
+ ;; -- check for undefined tokens
+ (for-each (lambda (x)
+ (if (not (or (member x terms) (member x
nonterms)))
+ (lalr-error "Invalid terminal or
nonterminal:" x)))
+ rhs)
+ ;; -- check 'error' productions
+ (check-error-production rhs)
+
+ (if (and (pair? rest)
+ (eq? (car rest) ':)
+ (pair? (cdr rest)))
+ (loop1 (cddr rest)
+ (+ i 1)
+ (cons (cons prod (cadr rest))
+ rev-productions-and-actions))
+ (let* ((rhs-length (length rhs))
+ (action
+ (cons 'vector
+ (cons (list 'quote (string->symbol
+ (string-append
+ name
+ "-"
+ (number->string i))))
+ (let loop-j ((j 1))
+ (if (> j rhs-length)
+ '()
+ (cons (string->symbol
+ (string-append
+ "$"
+ (number->string j)))
+ (loop-j (+ j 1)))))))))
+ (loop1 rest
+ (+ i 1)
+ (cons (cons prod action)
+ rev-productions-and-actions))))))))))
+
+ (define (valid-nonterminal? x)
+ (symbol? x))
+
+ (define (valid-terminal? x)
+ (symbol? x)) ; DB
+
+ ;; ----------------------------------------------------------------------
+ ;; Miscellaneous
+ ;; ----------------------------------------------------------------------
+ (define (pos-in-list x lst)
+ (let loop ((lst lst) (i 0))
+ (cond ((not (pair? lst)) #f)
+ ((equal? (car lst) x) i)
+ (else (loop (cdr lst) (+ i 1))))))
+
+ (define (sunion lst1 lst2) ; union of sorted lists
+ (let loop ((L1 lst1)
+ (L2 lst2))
+ (cond ((null? L1) L2)
+ ((null? L2) L1)
+ (else
+ (let ((x (car L1)) (y (car L2)))
+ (cond
+ ((> x y)
+ (cons y (loop L1 (cdr L2))))
+ ((< x y)
+ (cons x (loop (cdr L1) L2)))
+ (else
+ (loop (cdr L1) L2))
+ ))))))
+
+ (define (sinsert elem lst)
+ (let loop ((l1 lst))
+ (if (null? l1)
+ (cons elem l1)
+ (let ((x (car l1)))
+ (cond ((< elem x)
+ (cons elem l1))
+ ((> elem x)
+ (cons x (loop (cdr l1))))
+ (else
+ l1))))))
+
+ (define (lalr-filter p lst)
+ (let loop ((l lst))
+ (if (null? l)
+ '()
+ (let ((x (car l)) (y (cdr l)))
+ (if (p x)
+ (cons x (loop y))
+ (loop y))))))
+
+ ;; ----------------------------------------------------------------------
+ ;; Debugging tools ...
+ ;; ----------------------------------------------------------------------
+ (define the-terminals #f) ; names of terminal symbols
+ (define the-nonterminals #f) ; non-terminals
+
+ (define (print-item item-no)
+ (let loop ((i item-no))
+ (let ((v (vector-ref ritem i)))
+ (if (>= v 0)
+ (loop (+ i 1))
+ (let* ((rlno (- v))
+ (nt (vector-ref rlhs rlno)))
+ (display (vector-ref the-nonterminals nt)) (display " --> ")
+ (let loop ((i (vector-ref rrhs rlno)))
+ (let ((v (vector-ref ritem i)))
+ (if (= i item-no)
+ (display ". "))
+ (if (>= v 0)
+ (begin
+ (display (get-symbol v))
+ (display " ")
+ (loop (+ i 1)))
+ (begin
+ (display " (rule ")
+ (display (- v))
+ (display ")")
+ (newline))))))))))
+
+ (define (get-symbol n)
+ (if (>= n nvars)
+ (vector-ref the-terminals (- n nvars))
+ (vector-ref the-nonterminals n)))
+
+
+ (define (print-states)
+ (define (print-action act)
+ (cond
+ ((eq? act '*error*)
+ (display " : Error"))
+ ((eq? act 'accept)
+ (display " : Accept input"))
+ ((< act 0)
+ (display " : reduce using rule ")
+ (display (- act)))
+ (else
+ (display " : shift and goto state ")
+ (display act)))
+ (newline)
+ #t)
+
+ (define (print-actions acts)
+ (let loop ((l acts))
+ (if (null? l)
+ #t
+ (let ((sym (caar l))
+ (act (cadar l)))
+ (display " ")
+ (cond
+ ((eq? sym 'default)
+ (display "default action"))
+ (else
+ (if (number? sym)
+ (display (get-symbol (+ sym nvars)))
+ (display sym))))
+ (print-action act)
+ (loop (cdr l))))))
+
+ (if (not action-table)
+ (begin
+ (display "No generated parser available!")
+ (newline)
+ #f)
+ (begin
+ (display "State table") (newline)
+ (display "-----------") (newline) (newline)
+
+ (let loop ((l first-state))
+ (if (null? l)
+ #t
+ (let* ((core (car l))
+ (i (core-number core))
+ (items (core-items core))
+ (actions (vector-ref action-table i)))
+ (display "state ") (display i) (newline)
+ (newline)
+ (for-each (lambda (x) (display " ") (print-item x))
+ items)
+ (newline)
+ (print-actions actions)
+ (newline)
+ (loop (cdr l))))))))
+
+
+
+ ;; ----------------------------------------------------------------------
+
+ (define build-goto-table
+ (lambda ()
+ `(vector
+ ,@(map
+ (lambda (shifts)
+ (list 'quote
+ (if shifts
+ (let loop ((l (shift-shifts shifts)))
+ (if (null? l)
+ '()
+ (let* ((state (car l))
+ (symbol (vector-ref acces-symbol state)))
+ (if (< symbol nvars)
+ (cons `(,symbol . ,state)
+ (loop (cdr l)))
+ (loop (cdr l))))))
+ '())))
+ (vector->list shift-table)))))
+
+
+ (define build-reduction-table
+ (lambda (gram/actions)
+ `(vector
+ '()
+ ,@(map
+ (lambda (p)
+ (let ((act (cdr p)))
+ `(lambda ,(if (eq? driver-name 'lr-driver)
+ '(___stack ___sp ___goto-table ___push yypushback)
+ '(___sp ___goto-table ___push))
+ ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
+ `(let* (,@(if act
+ (let loop ((i 1) (l rhs))
+ (if (pair? l)
+ (let ((rest (cdr l)))
+ (cons
+ `(,(string->symbol
+ (string-append
+ "$"
+ (number->string
+ (+ (- n i) 1))))
+ ,(if (eq? driver-name 'lr-driver)
+ `(vector-ref ___stack (-
___sp ,(- (* i 2) 1)))
+ `(list-ref ___sp ,(+ (* (- i
1) 2) 1))))
+ (loop (+ i 1) rest)))
+ '()))
+ '()))
+ ,(if (= nt 0)
+ '$1
+ `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name
'lr-driver) '() '(___sp)))))))))
+
+ gram/actions))))
+
+
+
+ ;; Options
+
+ (define *valid-options*
+ (list
+ (cons 'out-table:
+ (lambda (option)
+ (and (list? option)
+ (= (length option) 2)
+ (string? (cadr option)))))
+ (cons 'output:
+ (lambda (option)
+ (and (list? option)
+ (= (length option) 3)
+ (symbol? (cadr option))
+ (string? (caddr option)))))
+ (cons 'expect:
+ (lambda (option)
+ (and (list? option)
+ (= (length option) 2)
+ (integer? (cadr option))
+ (>= (cadr option) 0))))
+
+ (cons 'driver:
+ (lambda (option)
+ (and (list? option)
+ (= (length option) 2)
+ (symbol? (cadr option))
+ (memq (cadr option) '(lr glr)))))))
+
+
+ (define (validate-options options)
+ (for-each
+ (lambda (option)
+ (let ((p (assoc (car option) *valid-options*)))
+ (if (or (not p)
+ (not ((cdr p) option)))
+ (lalr-error "Invalid option:" option))))
+ options))
+
+
+ (define (output-parser! options code)
+ (let ((option (assq 'output: options)))
+ (if option
+ (let ((parser-name (cadr option))
+ (file-name (caddr option)))
+ (with-output-to-file file-name
+ (lambda ()
+ (pprint `(define ,parser-name ,code))
+ (newline)))))))
+
+
+ (define (output-table! options)
+ (let ((option (assq 'out-table: options)))
+ (if option
+ (let ((file-name (cadr option)))
+ (with-output-to-file file-name print-states)))))
+
+
+ (define (set-expected-conflicts! options)
+ (let ((option (assq 'expect: options)))
+ (set! expected-conflicts (if option (cadr option) 0))))
+
+ (define (set-driver-name! options)
+ (let ((option (assq 'driver: options)))
+ (if option
+ (let ((driver-type (cadr option)))
+ (set! driver-name (if (eq? driver-type 'glr) 'glr-driver
'lr-driver))))))
+
+
+ ;; -- arguments
+
+ (define (extract-arguments lst proc)
+ (let loop ((options '())
+ (tokens '())
+ (rules '())
+ (lst lst))
+ (if (pair? lst)
+ (let ((p (car lst)))
+ (cond
+ ((and (pair? p)
+ (lalr-keyword? (car p))
+ (assq (car p) *valid-options*))
+ (loop (cons p options) tokens rules (cdr lst)))
+ (else
+ (proc options p (cdr lst)))))
+ (lalr-error "Malformed lalr-parser form" lst))))
+
+
+ (define (build-driver options tokens rules)
+ (validate-options options)
+ (set-expected-conflicts! options)
+ (set-driver-name! options)
+ (let* ((gram/actions (gen-tables! tokens rules))
+ (code `(,driver-name ',action-table ,(build-goto-table)
,(build-reduction-table gram/actions))))
+
+ (output-table! options)
+ (output-parser! options code)
+ code))
+
+ (extract-arguments arguments build-driver))
+
+
+
+;;;
+;;;; --
+;;;; Implementation of the lr-driver
+;;;
+
+
+(cond-expand
+ (gambit
+ (declare
+ (standard-bindings)
+ (fixnum)
+ (block)
+ (not safe)))
+ (chicken
+ (declare
+ (uses extras)
+ (usual-integrations)
+ (fixnum)
+ (not safe)))
+ (else))
+
+
+;;;
+;;;; Source location utilities
+;;;
+
+
+;; This function assumes that src-location-1 and src-location-2 are
source-locations
+;; Returns #f if they are not locations for the same input
+(define (combine-locations src-location-1 src-location-2)
+ (let ((offset-1 (source-location-offset src-location-1))
+ (offset-2 (source-location-offset src-location-2))
+ (length-1 (source-location-length src-location-1))
+ (length-2 (source-location-length src-location-2)))
+
+ (cond ((not (equal? (source-location-input src-location-1)
+ (source-location-input src-location-2)))
+ #f)
+ ((or (not (number? offset-1)) (not (number? offset-2))
+ (not (number? length-1)) (not (number? length-2))
+ (< offset-1 0) (< offset-2 0)
+ (< length-1 0) (< length-2 0))
+ (make-source-location (source-location-input src-location-1)
+ (source-location-line src-location-1)
+ (source-location-column src-location-1)
+ -1 -1))
+ ((<= offset-1 offset-2)
+ (make-source-location (source-location-input src-location-1)
+ (source-location-line src-location-1)
+ (source-location-column src-location-1)
+ offset-1
+ (- (+ offset-2 length-2) offset-1)))
+ (else
+ (make-source-location (source-location-input src-location-1)
+ (source-location-line src-location-1)
+ (source-location-column src-location-1)
+ offset-2
+ (- (+ offset-1 length-1) offset-2))))))
+
+
+;;;
+;;;; LR-driver
+;;;
+
+
+(define *max-stack-size* 500)
+
+(define (lr-driver action-table goto-table reduction-table)
+ (define ___atable action-table)
+ (define ___gtable goto-table)
+ (define ___rtable reduction-table)
+
+ (define ___lexerp #f)
+ (define ___errorp #f)
+
+ (define ___stack #f)
+ (define ___sp 0)
+
+ (define ___curr-input #f)
+ (define ___reuse-input #f)
+
+ (define ___input #f)
+ (define (___consume)
+ (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
+ (set! ___reuse-input #f)
+ (set! ___curr-input ___input))
+
+ (define (___pushback)
+ (set! ___reuse-input #t))
+
+ (define (___initstack)
+ (set! ___stack (make-vector *max-stack-size* 0))
+ (set! ___sp 0))
+
+ (define (___growstack)
+ (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
+ (let loop ((i (- (vector-length ___stack) 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! new-stack i (vector-ref ___stack i))
+ (loop (- i 1)))))
+ (set! ___stack new-stack)))
+
+ (define (___checkstack)
+ (if (>= ___sp (vector-length ___stack))
+ (___growstack)))
+
+ (define (___push delta new-category lvalue)
+ (set! ___sp (- ___sp (* delta 2)))
+ (let* ((state (vector-ref ___stack ___sp))
+ (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
+ (set! ___sp (+ ___sp 2))
+ (___checkstack)
+ (vector-set! ___stack ___sp new-state)
+ (vector-set! ___stack (- ___sp 1) lvalue)))
+
+ (define (___reduce st)
+ ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
+
+ (define (___shift token attribute)
+ (set! ___sp (+ ___sp 2))
+ (___checkstack)
+ (vector-set! ___stack (- ___sp 1) attribute)
+ (vector-set! ___stack ___sp token))
+
+ (define (___action x l)
+ (let ((y (assoc x l)))
+ (if y (cadr y) (cadar l))))
+
+ (define (___recover tok)
+ (let find-state ((sp ___sp))
+ (if (< sp 0)
+ (set! ___sp sp)
+ (let* ((state (vector-ref ___stack sp))
+ (act (assoc 'error (vector-ref ___atable state))))
+ (if act
+ (begin
+ (set! ___sp sp)
+ (___sync (cadr act) tok))
+ (find-state (- sp 2)))))))
+
+ (define (___sync state tok)
+ (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
+ (set! ___sp (+ ___sp 4))
+ (___checkstack)
+ (vector-set! ___stack (- ___sp 3) #f)
+ (vector-set! ___stack (- ___sp 2) state)
+ (let skip ()
+ (let ((i (___category ___input)))
+ (if (eq? i '*eoi*)
+ (set! ___sp -1)
+ (if (memq i sync-set)
+ (let ((act (assoc i (vector-ref ___atable state))))
+ (vector-set! ___stack (- ___sp 1) #f)
+ (vector-set! ___stack ___sp (cadr act)))
+ (begin
+ (___consume)
+ (skip))))))))
+
+ (define (___category tok)
+ (if (lexical-token? tok)
+ (lexical-token-category tok)
+ tok))
+
+ (define (___value tok)
+ (if (lexical-token? tok)
+ (lexical-token-value tok)
+ tok))
+
+ (define (___run)
+ (let loop ()
+ (if ___input
+ (let* ((state (vector-ref ___stack ___sp))
+ (i (___category ___input))
+ (attr (___value ___input))
+ (act (___action i (vector-ref ___atable state))))
+
+ (cond ((not (symbol? i))
+ (___errorp "Syntax error: invalid token: " ___input)
+ #f)
+
+ ;; Input succesfully parsed
+ ((eq? act 'accept)
+ (vector-ref ___stack 1))
+
+ ;; Syntax error in input
+ ((eq? act '*error*)
+ (if (eq? i '*eoi*)
+ (begin
+ (___errorp "Syntax error: unexpected end of input")
+ #f)
+ (begin
+ (___errorp "Syntax error: unexpected token : "
___input)
+ (___recover i)
+ (if (>= ___sp 0)
+ (set! ___input #f)
+ (begin
+ (set! ___sp 0)
+ (set! ___input '*eoi*)))
+ (loop))))
+
+ ;; Shift current token on top of the stack
+ ((>= act 0)
+ (___shift act attr)
+ (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
+ (loop))
+
+ ;; Reduce by rule (- act)
+ (else
+ (___reduce (- act))
+ (loop))))
+
+ ;; no lookahead, so check if there is a default action
+ ;; that does not require the lookahead
+ (let* ((state (vector-ref ___stack ___sp))
+ (acts (vector-ref ___atable state))
+ (defact (if (pair? acts) (cadar acts) #f)))
+ (if (and (= 1 (length acts)) (< defact 0))
+ (___reduce (- defact))
+ (___consume))
+ (loop)))))
+
+
+ (lambda (lexerp errorp)
+ (set! ___errorp errorp)
+ (set! ___lexerp lexerp)
+ (___initstack)
+ (___run)))
+
+
+;;;
+;;;; Simple-minded GLR-driver
+;;;
+
+
+(define (glr-driver action-table goto-table reduction-table)
+ (define ___atable action-table)
+ (define ___gtable goto-table)
+ (define ___rtable reduction-table)
+
+ (define ___lexerp #f)
+ (define ___errorp #f)
+
+ ;; -- Input handling
+
+ (define *input* #f)
+ (define (initialize-lexer lexer)
+ (set! ___lexerp lexer)
+ (set! *input* #f))
+ (define (consume)
+ (set! *input* (___lexerp)))
+
+ (define (token-category tok)
+ (if (lexical-token? tok)
+ (lexical-token-category tok)
+ tok))
+
+ (define (token-attribute tok)
+ (if (lexical-token? tok)
+ (lexical-token-value tok)
+ tok))
+
+ ;; -- Processes (stacks) handling
+
+ (define *processes* '())
+
+ (define (initialize-processes)
+ (set! *processes* '()))
+ (define (add-process process)
+ (set! *processes* (cons process *processes*)))
+ (define (get-processes)
+ (reverse *processes*))
+
+ (define (for-all-processes proc)
+ (let ((processes (get-processes)))
+ (initialize-processes)
+ (for-each proc processes)))
+
+ ;; -- parses
+ (define *parses* '())
+ (define (get-parses)
+ *parses*)
+ (define (initialize-parses)
+ (set! *parses* '()))
+ (define (add-parse parse)
+ (set! *parses* (cons parse *parses*)))
+
+
+ (define (push delta new-category lvalue stack)
+ (let* ((stack (drop stack (* delta 2)))
+ (state (car stack))
+ (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
+ (cons new-state (cons lvalue stack))))
+
+ (define (reduce state stack)
+ ((vector-ref ___rtable state) stack ___gtable push))
+
+ (define (shift state symbol stack)
+ (cons state (cons symbol stack)))
+
+ (define (get-actions token action-list)
+ (let ((pair (assoc token action-list)))
+ (if pair
+ (cdr pair)
+ (cdar action-list)))) ;; get the default action
+
+
+ (define (run)
+ (let loop-tokens ()
+ (consume)
+ (let ((symbol (token-category *input*))
+ (attr (token-attribute *input*)))
+ (for-all-processes
+ (lambda (process)
+ (let loop ((stacks (list process)) (active-stacks '()))
+ (cond ((pair? stacks)
+ (let* ((stack (car stacks))
+ (state (car stack)))
+ (let actions-loop ((actions (get-actions symbol
(vector-ref ___atable state)))
+ (active-stacks active-stacks))
+ (if (pair? actions)
+ (let ((action (car actions))
+ (other-actions (cdr actions)))
+ (cond ((eq? action '*error*)
+ (actions-loop other-actions
active-stacks))
+ ((eq? action 'accept)
+ (add-parse (car (take-right stack 2)))
+ (actions-loop other-actions
active-stacks))
+ ((>= action 0)
+ (let ((new-stack (shift action attr
stack)))
+ (add-process new-stack))
+ (actions-loop other-actions
active-stacks))
+ (else
+ (let ((new-stack (reduce (- action)
stack)))
+ (actions-loop other-actions (cons
new-stack active-stacks))))))
+ (loop (cdr stacks) active-stacks)))))
+ ((pair? active-stacks)
+ (loop (reverse active-stacks) '())))))))
+ (if (pair? (get-processes))
+ (loop-tokens))))
+
+
+ (lambda (lexerp errorp)
+ (set! ___errorp errorp)
+ (initialize-lexer lexerp)
+ (initialize-processes)
+ (initialize-parses)
+ (add-process '(0))
+ (run)
+ (get-parses)))
+
+
+(define (drop l n)
+ (cond ((and (> n 0) (pair? l))
+ (drop (cdr l) (- n 1)))
+ (else
+ l)))
+
+(define (take-right l n)
+ (drop l (- (length l) n)))
\ No newline at end of file
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index bacf041..98bf5cf 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -1,6 +1,6 @@
;;; User interface messages
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -81,6 +81,12 @@
(format port "~A: warning: unused variable `~A'~%"
loc name)))
+ (unused-toplevel
+ "report unused local top-level variables"
+ ,(lambda (port loc name)
+ (format port "~A: warning: possibly unused local top-level
variable `~A'~%"
+ loc name)))
+
(unbound-variable
"report possibly unbound variables"
,(lambda (port loc name)
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index 4777431..00563f6 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -1,14 +1,41 @@
-(define-module (system base pmatch)
- #:export (pmatch))
-;; FIXME: shouldn't have to export ppat...
+;;; pmatch, a simple matcher
+
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc
+;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
+;;; Copyright (C) 2007 Daniel P. Friedman
+;;;
+;;; This library is free software; you can redistribute 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
+
+;;; Originally written by Oleg Kiselyov for LeanTAP in Kanren, which is
+;;; available under the MIT license.
+;;;
+;;;
http://kanren.cvs.sourceforge.net/viewvc/kanren/kanren/mini/leanTAP.scm?view=log
+;;;
+;;; This version taken from:
+;;; αKanren: A Fresh Name in Nominal Logic Programming
+;;; by William E. Byrd and Daniel P. Friedman
+;;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
+;;; Université Laval Technical Report DIUL-RT-0701
-;; Originally written by Oleg Kiselyov. Taken from:
-;; αKanren: A Fresh Name in Nominal Logic Programming
-;; by William E. Byrd and Daniel P. Friedman
-;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
-;; Université Laval Technical Report DIUL-RT-0701
+;;; To be clear: the original code is MIT-licensed, and the modifications
+;;; made to it by Guile are under Guile's license (currently LGPL v3+).
-;; Licensing unclear. Probably need to ask Oleg for a disclaimer.
+;;; Code:
+
+(define-module (system base pmatch)
+ #:export (pmatch))
(define-syntax pmatch
(syntax-rules (else guard)
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
new file mode 100644
index 0000000..9f389f2
--- /dev/null
+++ b/module/system/foreign.scm
@@ -0,0 +1,106 @@
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+
+(define-module (system foreign)
+ #:use-module (rnrs bytevector)
+ #:export (void
+ float double
+ int unsigned-int long unsigned-long size_t
+ int8 uint8
+ uint16 int16
+ uint32 int32
+ uint64 int64
+ %null-pointer
+
+ sizeof alignof
+
+ foreign-ref foreign-set!
+ foreign->bytevector bytevector->foreign
+ foreign-set-finalizer!
+ make-foreign-function
+ make-c-struct parse-c-struct))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_foreign")
+
+(define *writers*
+ `((,float . ,bytevector-ieee-single-native-set!)
+ (,double . ,bytevector-ieee-double-native-set!)
+ (,int8 . ,bytevector-s8-set!)
+ (,uint8 . ,bytevector-u8-set!)
+ (,int16 . ,bytevector-s16-native-set!)
+ (,uint16 . ,bytevector-u16-native-set!)
+ (,int32 . ,bytevector-s32-native-set!)
+ (,uint32 . ,bytevector-u32-native-set!)
+ (,int64 . ,bytevector-s64-native-set!)
+ (,uint64 . ,bytevector-u64-native-set!)))
+
+(define *readers*
+ `((,float . ,bytevector-ieee-single-native-ref)
+ (,double . ,bytevector-ieee-double-native-ref)
+ (,int8 . ,bytevector-s8-ref)
+ (,uint8 . ,bytevector-u8-ref)
+ (,int16 . ,bytevector-s16-native-ref)
+ (,uint16 . ,bytevector-u16-native-ref)
+ (,int32 . ,bytevector-s32-native-ref)
+ (,uint32 . ,bytevector-u32-native-ref)
+ (,int64 . ,bytevector-s64-native-ref)
+ (,uint64 . ,bytevector-u64-native-ref)))
+
+(define (align off alignment)
+ (1+ (logior (1- off) (1- alignment))))
+
+(define (write-c-struct bv offset types vals)
+ (let lp ((offset offset) (types types) (vals vals))
+ (cond
+ ((not (pair? types))
+ (or (null? vals)
+ (error "too many values" vals)))
+ ((not (pair? vals))
+ (error "too few values" types))
+ (else
+ ;; alignof will error-check
+ (let* ((type (car types))
+ (offset (align offset (alignof type))))
+ (if (pair? type)
+ (write-c-struct bv offset (car types) (car vals))
+ ((assv-ref *writers* type) bv offset (car vals)))
+ (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
+
+(define (read-c-struct bv offset types)
+ (let lp ((offset offset) (types types) (vals '()))
+ (cond
+ ((not (pair? types))
+ (reverse vals))
+ (else
+ ;; alignof will error-check
+ (let* ((type (car types))
+ (offset (align offset (alignof type))))
+ (lp (+ offset (sizeof type)) (cdr types)
+ (cons (if (pair? type)
+ (read-c-struct bv offset (car types))
+ ((assv-ref *readers* type) bv offset))
+ vals)))))))
+
+(define (make-c-struct types vals)
+ (let ((bv (make-bytevector (sizeof types) 0)))
+ (write-c-struct bv 0 types vals)
+ (bytevector->foreign bv)))
+
+(define (parse-c-struct foreign types)
+ (read-c-struct (foreign->bytevector foreign) 0 types))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 0b1434c..f3b0d1b 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
;;; Repl commands
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -28,14 +28,14 @@
#:use-module (system vm program)
#:use-module (system vm vm)
#:autoload (system base language) (lookup-language language-reader)
- #:autoload (system vm debug) (vm-debugger vm-backtrace)
- #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
+ #:autoload (system vm trace) (vm-trace)
#:autoload (system vm profile) (vm-profile)
#:use-module (ice-9 format)
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
#:use-module (ice-9 and-let-star)
#:use-module (ice-9 rdelim)
+ #:use-module (statprof)
#:export (meta-command))
@@ -44,26 +44,21 @@
;;;
(define *command-table*
- '((help (help h) (apropos a) (describe d) (option o) (quit q))
+ '((help (help h) (show s) (apropos a) (describe d) (option o) (quit q))
(module (module m) (import i) (load l) (binding b))
(language (language L))
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
(profile (time t) (profile pr))
- (debug (backtrace bt) (debugger db) (trace tr) (step st))
+ (debug (trace tr))
(system (gc) (statistics stat))))
+(define *show-table*
+ '((show (warranty w) (copying c) (version v))))
+
(define (group-name g) (car g))
(define (group-commands g) (cdr g))
-;; Hack, until core can be extended.
-(define procedure-documentation
- (let ((old-definition procedure-documentation))
- (lambda (p)
- (if (program? p)
- (program-documentation p)
- (old-definition p)))))
-
(define *command-module* (current-module))
(define (command-name c) (car c))
(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
@@ -84,19 +79,19 @@
(define (lookup-group name)
(assq name *command-table*))
-(define (lookup-command key)
- (let loop ((groups *command-table*) (commands '()))
+(define* (lookup-command key #:optional (table *command-table*))
+ (let loop ((groups table) (commands '()))
(cond ((and (null? groups) (null? commands)) #f)
((null? commands)
(loop (cdr groups) (cdar groups)))
((memq key (car commands)) (car commands))
(else (loop groups (cdr commands))))))
-(define (display-group group . opts)
+(define* (display-group group #:optional (abbrev? #t))
(format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
(for-each (lambda (c)
(display-summary (command-usage c)
- (command-abbrev c)
+ (and abbrev? (command-abbrev c))
(command-summary c)))
(group-commands group))
(newline))
@@ -203,6 +198,47 @@ are displayed."
(else
(user-error "Bad arguments: ~A" args))))
+(define-meta-command (show repl . args)
+ "show
+show TOPIC
+
+Gives information about Guile.
+
+With one argument, tries to show a particular piece of information;
+
+currently supported topics are `warranty' (or `w'), `copying' (or `c'),
+and `version' (or `v').
+
+Without any argument, a list of topics is displayed."
+ (pmatch args
+ (()
+ (display-group (car *show-table*) #f)
+ (newline))
+ ((,topic) (guard (lookup-command topic *show-table*))
+ ((command-procedure (lookup-command topic *show-table*)) repl))
+ ((,command)
+ (user-error "Unknown topic: ~A" command))
+ (else
+ (user-error "Bad arguments: ~A" args))))
+
+(define (warranty repl)
+ "show warranty
+Details on the lack of warranty."
+ (display *warranty*)
+ (newline))
+
+(define (copying repl)
+ "show copying
+Show the LGPLv3."
+ (display *copying*)
+ (newline))
+
+(define (version repl)
+ "show version
+Version information."
+ (display *version*)
+ (newline))
+
(define guile:apropos apropos)
(define-meta-command (apropos repl regexp)
"apropos REGEXP
@@ -227,13 +263,7 @@ List/show/set options."
(display (repl-option-ref repl key))
(newline))
((,key ,val)
- (repl-option-set! repl key val)
- (case key
- ((trace)
- (let ((vm (repl-vm repl)))
- (if val
- (apply vm-trace-on vm val)
- (vm-trace-off vm))))))))
+ (repl-option-set! repl key val))))
(define-meta-command (quit repl)
"quit
@@ -292,8 +322,11 @@ List current bindings."
(define-meta-command (language repl name)
"language LANGUAGE
Change languages."
- (set! (repl-language repl) (lookup-language name))
- (repl-welcome repl))
+ (let ((lang (lookup-language name))
+ (cur (repl-language repl)))
+ (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n"
+ (language-title lang) (language-name cur))
+ (set! (repl-language repl) lang)))
;;;
@@ -359,44 +392,29 @@ Time execution."
(get identity gc-start gc-end))
result))
-(define-meta-command (profile repl form . opts)
+(define-meta-command (profile repl (form) . opts)
"profile FORM
Profile execution."
- (apply vm-profile
- (repl-vm repl)
- (repl-compile repl (repl-parse repl form))
+ ;; FIXME opts
+ (apply statprof
+ (make-program (repl-compile repl (repl-parse repl form)))
opts))
+
;;;
;;; Debug commands
;;;
-(define-meta-command (backtrace repl)
- "backtrace
-Display backtrace."
- (vm-backtrace (repl-vm repl)))
-
-(define-meta-command (debugger repl)
- "debugger
-Start debugger."
- (vm-debugger (repl-vm repl)))
-
-(define-meta-command (trace repl form . opts)
+(define-meta-command (trace repl (form) . opts)
"trace FORM
-Trace execution.
-
- -s Display stack
- -l Display local variables
- -b Bytecode level trace"
- (apply vm-trace (repl-vm repl)
- (repl-compile repl (repl-parse repl form))
+Trace execution."
+ ;; FIXME: doc options, or somehow deal with them better
+ (apply vm-trace
+ (the-vm)
+ (make-program (repl-compile repl (repl-parse repl form)))
opts))
-(define-meta-command (step repl)
- "step FORM
-Step execution."
- (display "Not implemented yet\n"))
;;;
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 9570d1d..a106145 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,6 +1,6 @@
;;; Repl common routines
-;; Copyright (C) 2001, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010 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,19 +22,83 @@
#:use-module (system base syntax)
#:use-module (system base compile)
#:use-module (system base language)
- #:use-module (system vm vm)
- #:export (<repl> make-repl repl-vm repl-language repl-options
+ #:use-module (system vm program)
+ #:use-module (ice-9 control)
+ #:export (<repl> make-repl repl-language repl-options
repl-tm-stats repl-gc-stats
repl-welcome repl-prompt repl-read repl-compile repl-eval
repl-parse repl-print repl-option-ref repl-option-set!
- puts ->string user-error))
+ puts ->string user-error
+ *warranty* *copying* *version*))
+
+(define *version*
+ (format #f "GNU Guile ~A
+Copyright (C) 1995-2010 Free Software Foundation, Inc.
+
+Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
+This program is free software, and you are welcome to redistribute it
+under certain conditions; type `,show c' for details." (version)))
+
+(define *copying*
+"Guile is free software: you can redistribute it and/or modify
+it under the terms of the GNU Lesser General Public License as
+published by the Free Software Foundation, either version 3 of
+the License, or (at your option) any later version.
+
+Guile is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this program. If not, see
+<http://www.gnu.org/licenses/lgpl.html>.")
+
+(define *warranty*
+"Guile is distributed WITHOUT ANY WARRANTY. The following
+sections from the GNU General Public License, version 3, should
+make that clear.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
;;;
;;; Repl type
;;;
-(define-record/keywords <repl> vm language options tm-stats gc-stats)
+(define-record/keywords <repl> language options tm-stats gc-stats)
(define repl-default-options
'((trace . #f)
@@ -42,17 +106,15 @@
(define %make-repl make-repl)
(define (make-repl lang)
- (%make-repl #:vm (the-vm)
- #:language (lookup-language lang)
+ (%make-repl #:language (lookup-language lang)
#:options repl-default-options
#:tm-stats (times)
#:gc-stats (gc-stats)))
(define (repl-welcome repl)
- (let ((language (repl-language repl)))
- (format #t "~A interpreter ~A on Guile ~A\n"
- (language-title language) (language-version language) (version)))
- (display "Copyright (C) 2001-2008 Free Software Foundation, Inc.\n\n")
+ (display *version*)
+ (newline)
+ (newline)
(display "Enter `,help' for help.\n"))
(define (repl-prompt repl)
@@ -76,12 +138,13 @@
(if parser (parser form) form)))
(define (repl-eval repl form)
- (let ((eval (language-evaluator (repl-language repl))))
- (if (and eval
- (or (null? (language-compilers (repl-language repl)))
- (assq-ref (repl-options repl) 'interp)))
- (eval form (current-module))
- (vm-load (repl-vm repl) (repl-compile repl form '())))))
+ (let* ((eval (language-evaluator (repl-language repl)))
+ (thunk (if (and eval
+ (or (null? (language-compilers (repl-language repl)))
+ (assq-ref (repl-options repl) 'interp)))
+ (lambda () (eval form (current-module)))
+ (make-program (repl-compile repl form '())))))
+ (% (thunk))))
(define (repl-print repl val)
(if (not (eq? val *unspecified*))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index a3496f3..8c54345 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -87,7 +87,7 @@
(catch #t
(lambda () (%start-stack #t thunk))
default-catch-handler
- default-pre-unwind-handler))
+ debug-pre-unwind-handler))
(define-macro (with-backtrace form)
`(call-with-backtrace (lambda () ,form)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 04e3d64..d5a4ac7 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -19,43 +19,421 @@
;;; Code:
(define-module (system vm debug)
+ #:use-module (system base pmatch)
#:use-module (system base syntax)
#:use-module (system vm vm)
#:use-module (system vm frame)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
- #:export (vm-debugger vm-backtrace))
+ #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
+ #:use-module (system vm program)
+ #:export (*debug-input-port*
+ *debug-output-port*
+ debug run-debugger debug-pre-unwind-handler))
-;;;
-;;; Debugger
-;;;
-(define-record/keywords <debugger> vm chain index)
-
-(define (vm-debugger vm)
- (let ((chain (vm-last-frame-chain vm)))
- (if (null? chain)
- (display "Nothing to debug\n")
- (debugger-repl (make-debugger
- #:vm vm #:chain chain #:index (length chain))))))
-
-(define (debugger-repl db)
- (let loop ()
- (display "debug> ")
- (let ((cmd (read)))
- (case cmd
- ((bt) (vm-backtrace (debugger-vm db)))
- ((stack)
- (write (vm-fetch-stack (debugger-vm db)))
- (newline))
- (else
- (format #t "Unknown command: ~A" cmd))))))
+(define *debug-input-port* (make-fluid))
+(define *debug-output-port* (make-fluid))
+
+(define (debug-input-port)
+ (or (fluid-ref *debug-input-port*)
+ (current-input-port)))
+(define (debug-output-port)
+ (or (fluid-ref *debug-output-port*)
+ (current-error-port)))
+(define (reverse-hashq h)
+ (let ((ret (make-hash-table)))
+ (hash-for-each
+ (lambda (k v)
+ (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+ h)
+ ret))
+
+(define (catch-bad-arguments thunk bad-args-thunk)
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (catch 'keyword-argument-error
+ thunk
+ (lambda (k . args)
+ (bad-args-thunk))))
+ (lambda (k . args)
+ (bad-args-thunk))))
+
+(define (read-args prompt)
+ (define (read* reader)
+ (repl-reader prompt reader))
+ (define (next)
+ (read* read-char))
+ (define (cmd chr)
+ (cond
+ ((eof-object? chr) (list chr))
+ ((char=? chr #\newline) (cmd (next)))
+ ((char-whitespace? chr) (cmd (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (list tok) (next))))))
+ (define (args out chr)
+ (cond
+ ((eof-object? chr) (reverse out))
+ ((char=? chr #\newline) (reverse out))
+ ((char-whitespace? chr) (args out (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (cons tok out) (next))))))
+ (cmd (next)))
+
+(define* (print-locals frame #:optional (port (current-output-port))
+ #:key (width 72) (per-line-prefix ""))
+ (let ((bindings (frame-bindings frame)))
+ (cond
+ ((null? bindings)
+ (format port "~aNo local variables.~%" per-line-prefix))
+ (else
+ (format port "~aLocal variables:~%" per-line-prefix)
+ (for-each
+ (lambda (binding)
+ (format port "~a~4d ~a~:[~; (boxed)~] = ~v:@y\n"
+ per-line-prefix
+ (binding:index binding)
+ (binding:name binding)
+ (binding:boxed? binding)
+ width
+ (let ((x (frame-local-ref frame (binding:index binding))))
+ (if (binding:boxed? binding)
+ (variable-ref x)
+ x))))
+ (frame-bindings frame))))))
+
+(define* (print-frames frames
+ #:optional (port (current-output-port))
+ #:key (width 72) (full? #f) (forward? #f) count)
+ (let* ((len (vector-length frames))
+ (lower-idx (if (or (not count) (positive? count))
+ 0
+ (max 0 (+ len count))))
+ (upper-idx (if (and count (negative? count))
+ (1- len)
+ (1- (if count (min count len) len))))
+ (inc (if forward? 1 -1)))
+ (let lp ((i (if forward? lower-idx upper-idx))
+ (last-file ""))
+ (if (<= lower-idx i upper-idx)
+ (let* ((frame (vector-ref frames i))
+ (source (frame-source frame))
+ (file (and source
+ (or (source:file source)
+ "current input")))
+ (line (and=> source source:line)))
+ (if (and file (not (equal? file last-file)))
+ (format port "~&In ~a:~&" file))
+ (format port "~:[~*~6_~;~5d:~]~3d ~v:@y~%" line line
+ i width (frame-call-representation frame))
+ (if full?
+ (print-locals frame #:width width
+ #:per-line-prefix " "))
+ (lp (+ i inc) (or file last-file)))))))
+
+
;;;
-;;; Backtrace
+;;; Debugger
;;;
-(define (vm-backtrace vm)
- (print-frame-chain-as-backtrace
- (reverse (vm-last-frame-chain vm))))
+(define-record <debugger> vm level breakpoints module)
+
+(define (make-debugger-module)
+ (let ((m (make-fresh-user-module)))
+ m))
+
+(define vm-debugger
+ (let ((prop (make-object-property)))
+ (lambda (vm)
+ (or (prop vm)
+ (let ((debugger (make-debugger vm 0 '() (make-debugger-module))))
+ (set! (prop vm) debugger)
+ debugger)))))
+
+;; FIXME: Instead of dynamically binding the input and output ports in the
+;; context of the error, the debugger should really be a kind of coroutine,
+;; having its own dynamic input and output bindings. Delimited continuations
can
+;; do this.
+(define* (run-debugger stack frames #:optional (vm (the-vm)) #:key
+ (input (debug-input-port)) (output (debug-output-port)))
+ (let* ((db (vm-debugger vm))
+ (level (debugger-level db)))
+ (dynamic-wind
+ (lambda ()
+ (set! (debugger-level db) (1+ level))
+ (set! input (set-current-input-port input)))
+ (lambda ()
+ (dynamic-wind
+ (lambda () (set! output (set-current-output-port output)))
+ (lambda () (debugger-repl db stack frames))
+ (lambda () (set! output (set-current-output-port output)))))
+ (lambda ()
+ (set! input (set-current-input-port input))
+ (set! (debugger-level db) level)))))
+
+(define (debugger-repl db stack frames)
+ (let* ((index 0)
+ (top (vector-ref frames index))
+ (cur top)
+ (level (debugger-level db))
+ (last #f))
+ (define (frame-at-index idx)
+ (and (< idx (vector-length frames))
+ (vector-ref frames idx)))
+ (define (show-frame)
+ ;; #2 0x009600e0 in do_std_select (args=0xbfffd9e0) at
threads.c:1668
+ ;; 1668 select (select_args->nfds,
+ (format #t "#~2a 0x~8,'0x in address@hidden"
+ index
+ (frame-instruction-pointer cur)
+ (frame-call-representation cur)))
+
+ (define-syntax define-command
+ (syntax-rules ()
+ ((_ ((mod cname alias ...) . args) body ...)
+ (define cname
+ (let ((c (lambda* args body ...)))
+ (set-procedure-property! c 'name 'cname)
+ (module-define! mod 'cname c)
+ (module-add! mod 'alias (module-local-variable mod 'cname))
+ ...
+ c)))))
+
+ (let ((commands (make-module)))
+ (define (prompt)
+ (format #f "~a~a debug> "
+ (if (= level 1)
+ ""
+ (format #f "~a:" level))
+ index))
+
+ (define (print* . vals)
+ (define (print x)
+ (run-hook before-print-hook x)
+ (set! last x)
+ (pretty-print x))
+ (if (and (pair? vals)
+ (not (and (null? (cdr vals))
+ (unspecified? (car vals)))))
+ (for-each print vals)))
+
+ (define-command ((commands backtrace bt) #:optional count
+ #:key (width 72) full?)
+ "Print a backtrace of all stack frames, or innermost COUNT frames.
+If COUNT is negative, the last COUNT frames will be shown."
+ (print-frames frames
+ #:count count
+ #:width width
+ #:full? full?))
+
+ (define-command ((commands up) #:optional (count 1))
+ "Select and print stack frames that called this one.
+An argument says how many frames up to go"
+ (cond
+ ((or (not (integer? count)) (<= count 0))
+ (format #t "Invalid argument to `up': expected a positive integer
for COUNT.~%"))
+ ((>= (+ count index) (vector-length frames))
+ (cond
+ ((= index (1- (vector-length frames)))
+ (format #t "Already at outermost frame.\n"))
+ (else
+ (set! index (1- (vector-length frames)))
+ (set! cur (vector-ref frames index))
+ (show-frame))))
+ (else
+ (set! index (+ count index))
+ (set! cur (vector-ref frames index))
+ (show-frame))))
+
+ (define-command ((commands down) #:optional (count 1))
+ "Select and print stack frames called by this one.
+An argument says how many frames down to go"
+ (cond
+ ((or (not (integer? count)) (<= count 0))
+ (format #t "Invalid argument to `down': expected a positive integer
for COUNT.~%"))
+ ((< (- index count) 0)
+ (cond
+ ((zero? index)
+ (format #t "Already at innermost frame.\n"))
+ (else
+ (set! index 0)
+ (set! cur (vector-ref frames index))
+ (show-frame))))
+ (else
+ (set! index (- index count))
+ (set! cur (vector-ref frames index))
+ (show-frame))))
+
+ (define-command ((commands frame f) #:optional idx)
+ "Show the selected frame.
+With an argument, select a frame by index, then show it."
+ (cond
+ (idx
+ (cond
+ ((or (not (integer? idx)) (< idx 0))
+ (format #t "Invalid argument to `frame': expected a non-negative
integer for IDX.~%"))
+ ((frame-at-index idx)
+ => (lambda (f)
+ (set! cur f)
+ (set! index idx)
+ (show-frame)))
+ (else
+ (format #t "No such frame.~%"))))
+ (else (show-frame))))
+
+ (define-command ((commands procedure proc))
+ "Print the procedure for the selected frame."
+ (print* (frame-procedure cur)))
+
+ (define-command ((commands inspect i))
+ "Launch the inspector on the last-printed object."
+ (%inspect last))
+
+ (define-command ((commands locals))
+ "Show locally-bound variables in the selected frame."
+ (print-locals cur))
+
+ (define-command ((commands quit q continue cont c))
+ "Quit the debugger and let the program continue executing."
+ (throw 'quit))
+
+ (define-command ((commands help h ?) #:optional cmd)
+ "Show this help message."
+ (let ((rhash (reverse-hashq (module-obarray commands))))
+ (define (help-cmd cmd)
+ (let* ((v (module-local-variable commands cmd))
+ (p (variable-ref v))
+ (canonical-name (procedure-name p)))
+ ;; la la la
+ (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
+ canonical-name (program-lambda-list p)
+ "~#[~:;~40t(aliases: address@hidden, ~})~]"
+ (delq canonical-name (hashq-ref rhash v))
+ (procedure-documentation p))))
+ (cond
+ (cmd
+ (cond
+ ((and (symbol? cmd) (module-local-variable commands cmd))
+ (help-cmd cmd))
+ (else
+ (format #t "Invalid command ~s.~%" cmd)
+ (format #t "Try `help' for a list of commands~%"))))
+ (else
+ (let ((names (sort
+ (hash-map->list
+ (lambda (k v)
+ (procedure-name (variable-ref k)))
+ rhash)
+ (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y))))))
+ (format #t "Available commands:~%~%")
+ (for-each help-cmd names))))))
+
+ (define (handle cmd . args)
+ (cond
+ ((and (symbol? cmd)
+ (module-local-variable commands cmd))
+ => (lambda (var)
+ (let ((proc (variable-ref var)))
+ (catch-bad-arguments
+ (lambda ()
+ (apply (variable-ref var) args))
+ (lambda ()
+ (format (current-error-port)
+ "Invalid arguments to ~a. Try `help ~a'.~%"
+ (procedure-name proc) (procedure-name proc)))))))
+ ((and (integer? cmd) (exact? cmd))
+ (frame cmd))
+ ((eof-object? cmd)
+ (newline)
+ (throw 'quit))
+ (else
+ (format (current-error-port)
+ "~&Unknown command: ~a. Try `help'.~%" cmd)
+ *unspecified*)))
+
+ (catch 'quit
+ (lambda ()
+ (let loop ()
+ (apply
+ handle
+ (save-module-excursion
+ (lambda ()
+ (set-current-module commands)
+ (read-args prompt))))
+ (loop)))
+ (lambda (k . args)
+ (apply values args))))))
+
+
+;; TODO:
+;;
+;; eval expression in context of frame
+;; set local variable in frame
+;; step until next instruction
+;; step until next function call/return
+;; step until return from frame
+;; step until different source line
+;; step until greater source line
+;; watch expression
+;; break on a function
+;; remove breakpoints
+;; set printing width
+;; display a truncated backtrace
+;; go to a frame by index
+;; (reuse gdb commands perhaps)
+;; disassemble a function
+;; disassemble the current function
+;; inspect any object
+;; hm, trace via reassigning global vars. tricksy.
+;; (state associated with vm ?)
+
+(define (stack->vector stack)
+ (let* ((len (stack-length stack))
+ (v (make-vector len)))
+ (if (positive? len)
+ (let lp ((i 0) (frame (stack-ref stack 0)))
+ (if (< i len)
+ (begin
+ (vector-set! v i frame)
+ (lp (1+ i) (frame-previous frame))))))
+ v))
+
+(define (debug-pre-unwind-handler key . args)
+ ;; Narrow the stack by three frames: make-stack, this one, and the throw
+ ;; handler.
+ (cond
+ ((make-stack #t 3) =>
+ (lambda (stack)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format (debug-output-port) "Throw to key `~a':\n" key)
+ (display-error stack (debug-output-port) subr msg args rest))
+ (else
+ (format (debug-output-port) "Throw to key `~a' with args `~s'." key
args)))
+ (format (debug-output-port)
+ "Entering the debugger. Type `bt' for a backtrace or `c' to
continue.\n")
+ (run-debugger stack
+ (stack->vector
+ ;; by default, narrow to the most recent start-stack
+ (make-stack (stack-ref stack 0) 0
+ (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks)))))
+ 0))))
+ (save-stack debug-pre-unwind-handler)
+ (apply throw key args))
+
+(define (debug)
+ (let ((stack (fluid-ref the-last-stack)))
+ (if stack
+ (run-debugger stack (stack->vector stack))
+ (display "Nothing to debug.\n" (debug-output-port)))))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 5aa5962..ff002b2 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 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010 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,45 +24,55 @@
#:use-module (system vm instruction)
#:use-module (system vm objcode)
#:use-module ((srfi srfi-1) #:select (fold))
- #:export (frame-local-ref frame-local-set!
- frame-instruction-pointer
- frame-return-address frame-mv-return-address
- frame-dynamic-link
- frame-num-locals
-
- frame-bindings frame-binding-ref frame-binding-set!
- ; frame-arguments
-
- frame-number frame-address
- make-frame-chain
- print-frame print-frame-chain-as-backtrace
- frame-local-variables
+ #:export (frame-bindings
+ frame-lookup-binding
+ frame-binding-ref frame-binding-set!
+ frame-source frame-call-representation
frame-environment
- frame-variable-exists? frame-variable-ref frame-variable-set!
- frame-object-name
- frame-local-ref frame-local-set!
- frame-return-address frame-program
- frame-dynamic-link heap-frame?))
-
-(load-extension "libguile" "scm_init_frames")
+ frame-object-binding frame-object-name))
(define (frame-bindings frame)
- (map (lambda (b)
- (cons (binding:name b) (binding:index b)))
- (program-bindings-for-ip (frame-procedure frame)
- (frame-instruction-pointer frame))))
+ (program-bindings-for-ip (frame-procedure frame)
+ (frame-instruction-pointer frame)))
+
+(define (frame-lookup-binding frame var)
+ (let lp ((bindings (frame-bindings frame)))
+ (cond ((null? bindings)
+ #f)
+ ((eq? (binding:name (car bindings)) var)
+ (car bindings))
+ (else
+ (lp (cdr bindings))))))
(define (frame-binding-set! frame var val)
- (let ((i (assq-ref (frame-bindings frame) var)))
- (if i
- (frame-local-set! frame i val)
- (error "variable not bound in frame" var frame))))
+ (frame-local-set! frame
+ (binding:index
+ (or (frame-lookup-binding frame var)
+ (error "variable not bound in frame" var frame)))
+ val))
(define (frame-binding-ref frame var)
- (let ((i (assq-ref (frame-bindings frame) var)))
- (if i
- (frame-local-ref frame i)
- (error "variable not bound in frame" var frame))))
+ (frame-local-ref frame
+ (binding:index
+ (or (frame-lookup-binding frame var)
+ (error "variable not bound in frame" var frame)))))
+
+
+;; This function is always called to get some sort of representation of the
+;; frame to present to the user, so let's do the logical thing and dispatch to
+;; frame-call-representation.
+(define (frame-arguments frame)
+ (cdr (frame-call-representation frame)))
+
+
+
+;;;
+;;; Pretty printing
+;;;
+
+(define (frame-source frame)
+ (program-source (frame-procedure frame)
+ (frame-instruction-pointer frame)))
;; Basically there are two cases to deal with here:
;;
@@ -78,163 +88,65 @@
;; number of arguments, or perhaps we're doing a typed dispatch and
;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack.
-(define (frame-arguments frame)
- (cond
- ((program-lambda-list (frame-procedure frame)
- (frame-instruction-pointer frame))
- ;; case 1
- => (lambda (formals)
- (let lp ((formals formals))
- (pmatch formals
- (() '())
- ((,x . ,rest) (guard (symbol? x))
- (cons (frame-binding-ref frame x) (lp rest)))
- ((,x . ,rest)
- ;; could be a keyword
- (cons x (lp rest)))
- (,rest (guard (symbol? rest))
- (frame-binding-ref frame rest))
- ;; let's not error here, as we are called during
- ;; backtraces...
- (else '???)))))
- (else
- ;; case 2
- (map (lambda (i)
- (frame-local-ref frame i))
- (iota (frame-num-locals frame))))))
-
-;;;
-;;; Frame chain
-;;;
-
-(define frame-number (make-object-property))
-(define frame-address (make-object-property))
-
-;; FIXME: the header.
-(define (bootstrap-frame? frame)
- (let ((code (objcode->bytecode (program-objcode (frame-program frame)))))
- (and (= (uniform-vector-ref code (1- (uniform-vector-length code)))
- (instruction->opcode 'halt)))))
-
-(define (make-frame-chain frame addr)
- (define (make-rest)
- (make-frame-chain (frame-dynamic-link frame)
- (frame-return-address frame)))
- (cond
- ((or (eq? frame #t) (eq? frame #f))
- ;; handle #f or #t dynamic links
- '())
- ((bootstrap-frame? frame)
- (make-rest))
- (else
- (let ((chain (make-rest)))
- (set! (frame-number frame) (length chain))
- (set! (frame-address frame)
- (- addr (program-base (frame-program frame))))
- (cons frame chain)))))
-
-
-;;;
-;;; Pretty printing
-;;;
-
-(define (frame-line-number frame)
- (let ((addr (frame-address frame)))
- (cond ((assv addr (program-sources (frame-program frame)))
- => source:line)
- (else (format #f "@~a" addr)))))
-
-(define (frame-file frame prev)
- (let ((sources (program-sources (frame-program frame))))
- (if (null? sources)
- prev
- (or (source:file (car sources))
- "current input"))))
-
-(define (print-frame frame)
- (format #t "address@hidden: ~a ~s\n" (frame-line-number frame)
(frame-number frame)
- (frame-call-representation frame)))
-
(define (frame-call-representation frame)
- (define (abbrev x)
- (cond ((list? x)
- (if (> (length x) 4)
- (list (abbrev (car x)) (abbrev (cadr x)) '...)
- (map abbrev x)))
- ((pair? x)
- (cons (abbrev (car x)) (abbrev (cdr x))))
- ((vector? x)
- (case (vector-length x)
- ((0) x)
- ((1) (vector (abbrev (vector-ref x 0))))
- (else (vector (abbrev (vector-ref x 0)) '...))))
- (else x)))
- (abbrev (cons (frame-program-name frame) (frame-arguments frame))))
-
-(define (print-frame-chain-as-backtrace frames)
- (if (null? frames)
- (format #t "No backtrace available.\n")
- (begin
- (format #t "VM backtrace:\n")
- (fold (lambda (frame file)
- (let ((new-file (frame-file frame file)))
- (if (not (equal? new-file file))
- (format #t "In ~a:\n" new-file))
- (print-frame frame)
- new-file))
- 'no-file
- frames))))
-
-(define (frame-program-name frame)
- (let ((prog (frame-program frame))
- (link (frame-dynamic-link frame)))
- (or (program-name prog)
- (object-property prog 'name)
- (and (heap-frame? link) (frame-address link)
- (frame-object-name link (1- (frame-address link)) prog))
- (hash-fold (lambda (s v d) (if (and (variable-bound? v)
- (eq? prog (variable-ref v)))
- s d))
- prog (module-obarray (current-module))))))
+ (let ((p (frame-procedure frame)))
+ (cons
+ (or (procedure-name p) p)
+ (cond
+ ((program-arguments-alist p (frame-instruction-pointer frame))
+ ;; case 1
+ => (lambda (arguments)
+ (define (binding-ref sym i)
+ (cond
+ ((frame-lookup-binding frame sym)
+ => (lambda (b) (frame-local-ref frame (binding:index b))))
+ ((< i (frame-num-locals frame))
+ (frame-local-ref frame i))
+ (else
+ ;; let's not error here, as we are called during backtraces...
+ '???)))
+ (let lp ((req (or (assq-ref arguments 'required) '()))
+ (opt (or (assq-ref arguments 'optional) '()))
+ (key (or (assq-ref arguments 'keyword) '()))
+ (rest (or (assq-ref arguments 'rest) #f))
+ (i 0))
+ (cond
+ ((pair? req)
+ (cons (binding-ref (car req) i)
+ (lp (cdr req) opt key rest (1+ i))))
+ ((pair? opt)
+ (cons (binding-ref (car opt) i)
+ (lp req (cdr opt) key rest (1+ i))))
+ ((pair? key)
+ (cons* (caar key)
+ (frame-local-ref frame (cdar key))
+ (lp req opt (cdr key) rest (1+ i))))
+ (rest
+ (binding-ref rest i))
+ (else
+ '())))))
+ (else
+ ;; case 2
+ (map (lambda (i)
+ (frame-local-ref frame i))
+ (iota (frame-num-locals frame))))))))
+
-;;; Frames
+;;; Misc
;;;
-(define (frame-local-variables frame)
- (let* ((prog (frame-program frame))
- (arity (program-arity prog)))
- (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
- (l '() (cons (frame-local-ref frame n) l)))
- ((< n 0) l))))
-
-(define (frame-lookup-binding frame addr sym)
- (assq sym (reverse (frame-bindings frame addr))))
-
-(define (frame-object-binding frame addr obj)
- (do ((bs (frame-bindings frame addr) (cdr bs)))
- ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
- (and (pair? bs) (car bs)))))
-
-(define (frame-environment frame addr)
+(define (frame-environment frame)
(map (lambda (binding)
(cons (binding:name binding) (frame-binding-ref frame binding)))
- (frame-bindings frame addr)))
+ (frame-bindings frame)))
-(define (frame-variable-exists? frame addr sym)
- (if (frame-lookup-binding frame addr sym) #t #f))
-
-(define (frame-variable-ref frame addr sym)
- (cond ((frame-lookup-binding frame addr sym) =>
- (lambda (binding) (frame-binding-ref frame binding)))
- (else (error "Unknown variable:" sym))))
-
-(define (frame-variable-set! frame addr sym val)
- (cond ((frame-lookup-binding frame addr sym) =>
- (lambda (binding) (frame-binding-set! frame binding val)))
- (else (error "Unknown variable:" sym))))
+(define (frame-object-binding frame obj)
+ (do ((bs (frame-bindings frame) (cdr bs)))
+ ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+ (and (pair? bs) (car bs)))))
-(define (frame-object-name frame addr obj)
- (cond ((frame-object-binding frame addr obj) => binding:name)
+(define (frame-object-name frame obj)
+ (cond ((frame-object-binding frame obj) => binding:name)
(else #f)))
diff --git a/module/system/vm/inspect.scm b/module/system/vm/inspect.scm
new file mode 100644
index 0000000..aebf50d
--- /dev/null
+++ b/module/system/vm/inspect.scm
@@ -0,0 +1,190 @@
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Code:
+
+(define-module (system vm inspect)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module ((language assembly disassemble)
+ #:select ((disassemble . %disassemble)))
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 format)
+ #:use-module (system vm program)
+ #:export (inspect))
+
+
+(define (reverse-hashq h)
+ (let ((ret (make-hash-table)))
+ (hash-for-each
+ (lambda (k v)
+ (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+ h)
+ ret))
+
+(define (catch-bad-arguments thunk bad-args-thunk)
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (catch 'keyword-argument-error
+ thunk
+ (lambda (k . args)
+ (bad-args-thunk))))
+ (lambda (k . args)
+ (bad-args-thunk))))
+
+(define (read-args prompt)
+ (define (read* reader)
+ (repl-reader prompt reader))
+ (define (next)
+ (read* read-char))
+ (define (cmd chr)
+ (cond
+ ((eof-object? chr) (list chr))
+ ((char=? chr #\newline) (cmd (next)))
+ ((char-whitespace? chr) (cmd (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (list tok) (next))))))
+ (define (args out chr)
+ (cond
+ ((eof-object? chr) (reverse out))
+ ((char=? chr #\newline) (reverse out))
+ ((char-whitespace? chr) (args out (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (cons tok out) (next))))))
+ (cmd (next)))
+
+
+;;;
+;;; Inspector
+;;;
+
+(define (inspect x)
+ (define-syntax define-command
+ (syntax-rules ()
+ ((_ ((mod cname alias ...) . args) body ...)
+ (define cname
+ (let ((c (lambda* args body ...)))
+ (set-procedure-property! c 'name 'cname)
+ (module-define! mod 'cname c)
+ (module-add! mod 'alias (module-local-variable mod 'cname))
+ ...
+ c)))))
+
+ (let ((commands (make-module)))
+ (define (prompt)
+ (format #f "address@hidden inspect> " x))
+
+ (define-command ((commands quit q continue cont c))
+ "Quit the inspector."
+ (throw 'quit))
+
+ (define-command ((commands print p))
+ "Print the current object using `pretty-print'."
+ (pretty-print x))
+
+ (define-command ((commands write w))
+ "Print the current object using `write'."
+ (write x))
+
+ (define-command ((commands display d))
+ "Print the current object using `display'."
+ (display x))
+
+ (define-command ((commands disassemble x))
+ "Disassemble the current object, which should be objcode or a procedure."
+ (catch #t
+ (lambda ()
+ (%disassemble x))
+ (lambda args
+ (format #t "Error disassembling object: ~a\n" args))))
+
+ (define-command ((commands help h ?) #:optional cmd)
+ "Show this help message."
+ (let ((rhash (reverse-hashq (module-obarray commands))))
+ (define (help-cmd cmd)
+ (let* ((v (module-local-variable commands cmd))
+ (p (variable-ref v))
+ (canonical-name (procedure-name p)))
+ ;; la la la
+ (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
+ canonical-name (program-lambda-list p)
+ "~#[~:;~40t(aliases: address@hidden, ~})~]"
+ (delq canonical-name (hashq-ref rhash v))
+ (procedure-documentation p))))
+ (cond
+ (cmd
+ (cond
+ ((and (symbol? cmd) (module-local-variable commands cmd))
+ (help-cmd cmd))
+ (else
+ (format #t "Invalid command ~s.~%" cmd)
+ (format #t "Try `help' for a list of commands~%"))))
+ (else
+ (let ((names (sort
+ (hash-map->list
+ (lambda (k v)
+ (procedure-name (variable-ref k)))
+ rhash)
+ (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y))))))
+ (format #t "Available commands:~%~%")
+ (for-each help-cmd names))))))
+
+ (define (handle cmd . args)
+ (cond
+ ((and (symbol? cmd)
+ (module-local-variable commands cmd))
+ => (lambda (var)
+ (let ((proc (variable-ref var)))
+ (catch-bad-arguments
+ (lambda ()
+ (apply (variable-ref var) args))
+ (lambda ()
+ (format (current-error-port)
+ "Invalid arguments to ~a. Try `help ~a'.~%"
+ (procedure-name proc) (procedure-name proc)))))))
+ ; ((and (integer? cmd) (exact? cmd))
+ ; (nth cmd))
+ ((eof-object? cmd)
+ (newline)
+ (throw 'quit))
+ (else
+ (format (current-error-port)
+ "~&Unknown command: ~a. Try `help'.~%" cmd)
+ *unspecified*)))
+
+ (catch 'quit
+ (lambda ()
+ (let loop ()
+ (apply
+ handle
+ (save-module-excursion
+ (lambda ()
+ (set-current-module commands)
+ (read-args prompt))))
+ (loop)))
+ (lambda (k . args)
+ (apply values args)))))
diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm
index 403e9cd..287e472 100644
--- a/module/system/vm/instruction.scm
+++ b/module/system/vm/instruction.scm
@@ -1,6 +1,6 @@
;;; Guile VM instructions
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010 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,4 +24,5 @@
instruction-pops instruction-pushes
instruction->opcode opcode->instruction))
-(load-extension "libguile" "scm_init_instructions")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_instructions")
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index 7c0490d..966f345 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -1,6 +1,6 @@
;;; Guile VM object code
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010 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,4 +24,5 @@
load-objcode write-objcode
word-size byte-order))
-(load-extension "libguile" "scm_init_objcodes")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_objcodes")
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 31b667b..6c59566 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -1,6 +1,6 @@
;;; Guile VM program functions
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010 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
@@ -36,13 +36,16 @@
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
- program-arguments program-lambda-list
+ program-arguments-alist program-lambda-list
program-meta
program-objcode program? program-objects
- program-module program-base program-free-variables))
+ program-module program-base
+ program-num-free-variables
+ program-free-variable-ref program-free-variable-set!))
-(load-extension "libguile" "scm_init_programs")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_programs")
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
@@ -127,7 +130,7 @@
(car arities))
(else (lp (cdr arities))))))))
-(define (arglist->arguments arglist)
+(define (arglist->arguments-alist arglist)
(pmatch arglist
((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
`((required . ,req)
@@ -138,14 +141,19 @@
(extents . ,extents)))
(else #f)))
-(define (arity->arguments prog arity)
+(define* (arity->arguments-alist prog arity
+ #:optional
+ (make-placeholder
+ (lambda (i) (string->symbol "_"))))
(define var-by-index
(let ((rbinds (map (lambda (x)
(cons (binding:index x) (binding:name x)))
(program-bindings-for-ip prog
(arity:start arity)))))
(lambda (i)
- (assv-ref rbinds i))))
+ (or (assv-ref rbinds i)
+ ;; if we don't know the name, return a placeholder
+ (make-placeholder i)))))
(let lp ((nreq (arity:nreq arity)) (req '())
(nopt (arity:nopt arity)) (opt '())
@@ -170,33 +178,35 @@
(allow-other-keys? . ,(arity:allow-other-keys? arity))
(rest . ,rest))))))
-(define* (program-arguments prog #:optional ip)
+;; the name "program-arguments" is taken by features.c...
+(define* (program-arguments-alist prog #:optional ip)
(let ((arity (program-arity prog ip)))
(and arity
- (arity->arguments prog arity))))
+ (arity->arguments-alist prog arity))))
(define* (program-lambda-list prog #:optional ip)
- (and=> (program-arguments prog ip) arguments->lambda-list))
+ (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
-(define (arguments->lambda-list arguments)
- (let ((req (or (assq-ref arguments 'required) '()))
- (opt (or (assq-ref arguments 'optional) '()))
+(define (arguments-alist->lambda-list arguments-alist)
+ (let ((req (or (assq-ref arguments-alist 'required) '()))
+ (opt (or (assq-ref arguments-alist 'optional) '()))
(key (map keyword->symbol
- (map car (or (assq-ref arguments 'keyword) '()))))
- (rest (or (assq-ref arguments 'rest) '())))
+ (map car (or (assq-ref arguments-alist 'keyword) '()))))
+ (rest (or (assq-ref arguments-alist 'rest) '())))
`(,@req
,@(if (pair? opt) (cons #:optional opt) '())
,@(if (pair? key) (cons #:key key) '())
. ,rest)))
(define (write-program prog port)
- (format port "#<program ~a~a>"
+ (format port "#<procedure ~a~a>"
(or (program-name prog)
(and=> (program-source prog 0)
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
- (or (source:file s) "<unknown port>")
+ (or (source:file s)
+ (if s "<current input>" "<unknown port>"))
(source:line s) (source:column s))))
(number->string (object-address prog) 16))
(let ((arities (program-arities prog)))
@@ -205,8 +215,8 @@
(string-append
" " (string-join (map (lambda (a)
(object->string
- (arguments->lambda-list
- (arity->arguments prog a))))
+ (arguments-alist->lambda-list
+ (arity->arguments-alist prog a))))
arities)
" | "))))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index d8165f2..dca516c 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -1,6 +1,6 @@
;;; Guile VM tracer
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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,54 +23,99 @@
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (ice-9 format)
- #:export (vm-trace vm-trace-on vm-trace-off))
+ #:export (vm-trace))
-(define (vm-trace vm objcode . opts)
- (dynamic-wind
- (lambda () (apply vm-trace-on vm opts))
- (lambda () (vm-load vm objcode))
- (lambda () (apply vm-trace-off vm opts))))
+(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
+ (define *call-depth* #f)
+ (define *saved-call-depth* #f)
+
+ (define (trace-enter frame)
+ (cond
+ (*call-depth*
+ (set! *call-depth* (1+ *call-depth*)))))
-(define (vm-trace-on vm . opts)
- (set-vm-option! vm 'trace-first #t)
- (if (memq #:b opts) (add-hook! (vm-next-hook vm) trace-next))
- (set-vm-option! vm 'trace-options opts)
- (add-hook! (vm-apply-hook vm) trace-apply)
- (add-hook! (vm-return-hook vm) trace-return))
+ (define (trace-exit frame)
+ (cond
+ ((not *call-depth*))
+ (else
+ (set! *call-depth* (1- *call-depth*)))))
+
+ (define (trace-apply frame)
+ (cond
+ (*call-depth*
+ (format (current-error-port) "~a~v:@y\n"
+ (make-string (1- *call-depth*) #\|)
+ (max (- width *call-depth* 1) 1)
+ (frame-call-representation frame)))
+ ((eq? (frame-procedure frame) thunk)
+ (set! *call-depth* 1))))
-(define (vm-trace-off vm . opts)
- (if (memq #:b opts) (remove-hook! (vm-next-hook vm) trace-next))
- (remove-hook! (vm-apply-hook vm) trace-apply)
- (remove-hook! (vm-return-hook vm) trace-return))
+ (define (trace-return frame)
+ ;; nop, though we could print the return i guess
+ (cond
+ ((and *call-depth* (< *call-depth* 0))
+ ;; leaving the thunk
+ (set! *call-depth* #f))
+ (*call-depth*
+ (let* ((len (frame-num-locals frame))
+ (nvalues (frame-local-ref frame (1- len))))
+ (cond
+ ((= nvalues 1)
+ (format (current-error-port) "~a~v:@y\n"
+ (make-string *call-depth* #\|)
+ width (frame-local-ref frame (- len 2))))
+ (else
+ ;; this should work, but there appears to be a bug
+ ;; "~a~d values:~:{ ~v:@y~}\n"
+ (format (current-error-port) "~a~d values:~{ ~a~}\n"
+ (make-string *call-depth* #\|)
+ nvalues
+ (let lp ((vals '()) (i 0))
+ (if (= i nvalues)
+ vals
+ (lp (cons (format #f "~v:@y" width
+ (frame-local-ref frame (- len 2 i)))
+ vals)
+ (1+ i)))))))))))
+
+ (define (trace-next frame)
+ (format #t "0x~8X" (frame-instruction-pointer frame))
+ ;; should disassemble the thingy; could print stack, or stack trace,
+ ;; ...
+ )
-(define (trace-next vm)
- (define (puts x) (display #\tab) (write x))
- (define (truncate! x n)
- (if (> (length x) n)
- (list-cdr-set! x (1- n) '(...))) x)
- ;; main
- (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm))
- (do ((opts (vm-option vm 'trace-options) (cdr opts)))
- ((null? opts) (newline))
- (case (car opts)
- ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
- ((:l) (puts (vm-fetch-locals vm))))))
+ (define (vm-trace-on!)
+ (if calls?
+ (begin
+ (add-hook! (vm-exit-hook vm) trace-exit)
+ (add-hook! (vm-enter-hook vm) trace-enter)
+ (add-hook! (vm-apply-hook vm) trace-apply)
+ (add-hook! (vm-return-hook vm) trace-return)))
+
+ (if instructions?
+ (add-hook! (vm-next-hook vm) trace-next))
-(define (trace-apply vm)
- (if (vm-option vm 'trace-first)
- (set-vm-option! vm 'trace-first #f)
- (let ((chain (vm-current-frame-chain vm)))
- (print-indent chain)
- (print-frame-call (car chain))
- (newline))))
+ ;; boot, halt, and break are the other ones
-(define (trace-return vm)
- (let ((chain (vm-current-frame-chain vm)))
- (print-indent chain)
- (write (vm-return-value vm))
- (newline)))
+ (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
+ (set! *call-depth* *saved-call-depth*))
+
+ (define (vm-trace-off!)
+ (set! *saved-call-depth* *call-depth*)
+ (set! *call-depth* #f)
+ (set-vm-trace-level! vm (1- (vm-trace-level vm)))
-(define (print-indent chain)
- (cond ((pair? (cdr chain))
- (display "| ")
- (print-indent (cdr chain)))))
+ (if calls?
+ (begin
+ (remove-hook! (vm-exit-hook vm) trace-exit)
+ (remove-hook! (vm-enter-hook vm) trace-enter)
+ (remove-hook! (vm-apply-hook vm) trace-apply)
+ (remove-hook! (vm-return-hook vm) trace-return)))
+
+ (if instructions?
+ (remove-hook! (vm-next-hook vm) trace-next)))
+
+ (dynamic-wind
+ vm-trace-on!
+ (lambda () (vm-apply vm thunk '()))
+ vm-trace-off!))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 9d8f977..c50959b 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -1,6 +1,6 @@
;;; Guile VM core
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010 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,20 +21,21 @@
(define-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:export (vm? the-vm make-vm vm-version
+ #:export (vm? the-vm make-vm vm-version vm-apply
vm:ip vm:sp vm:fp vm:last-ip
vm-load vm-option set-vm-option! vm-version
vms:time vms:clock
- vm-trace-frame
+ vm-trace-level set-vm-trace-level!
vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
-(load-extension "libguile" "scm_init_vm")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_vm")
(define (vms:time stat) (vector-ref stat 0))
(define (vms:clock stat) (vector-ref stat 1))
(define (vm-load vm objcode)
- (vm (make-program objcode)))
+ (vm-apply vm (make-program objcode) '()))
diff --git a/module/texinfo.scm b/module/texinfo.scm
new file mode 100644
index 0000000..0b8285e
--- /dev/null
+++ b/module/texinfo.scm
@@ -0,0 +1,1215 @@
+;;;; (texinfo) -- parsing of texinfo into SXML
+;;;;
+;;;; Copyright (C) 2009, 2010 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>
+;;;;
+;;;; This file is based on SSAX's SSAX.scm.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; @subheading Texinfo processing in scheme
+;;
+;; This module parses texinfo into SXML. TeX will always be the
+;; processor of choice for print output, of course. However, although
+;; @code{makeinfo} works well for info, its output in other formats is
+;; not very customizable, and the program is not extensible as a whole.
+;; This module aims to provide an extensible framework for texinfo
+;; processing that integrates texinfo into the constellation of SXML
+;; processing tools.
+;;
+;; @subheading Notes on the SXML vocabulary
+;;
+;; Consider the following texinfo fragment:
+;;
+;;@example
+;; @@deffn Primitive set-car! pair value
+;; This function...
+;; @@end deffn
+;;@end example
+;;
+;; Logically, the category (Primitive), name (set-car!), and arguments
+;; (pair value) are ``attributes'' of the deffn, with the description as
+;; the content. However, texinfo allows for @@-commands within the
+;; arguments to an environment, like @code{@@deffn}, which means that
+;; texinfo ``attributes'' are PCDATA. XML attributes, on the other hand,
+;; are CDATA. For this reason, ``attributes'' of texinfo @@-commands are
+;; called ``arguments'', and are grouped under the special element, `%'.
+;;
+;; Because `%' is not a valid NCName, stexinfo is a superset of SXML. In
+;; the interests of interoperability, this module provides a conversion
+;; function to replace the `%' with `texinfo-arguments'.
+;;
+;;; Code:
+
+;; Comparison to xml output of texinfo (which is rather undocumented):
+;; Doesn't conform to texinfo dtd
+;; No DTD at all, in fact :-/
+;; Actually outputs valid xml, after transforming %
+;; Slower (although with caching the SXML that problem can go away)
+;; Doesn't parse menus (although menus are shite)
+;; Args go in a dedicated element, FBOFW
+;; Definitions are handled a lot better
+;; Does parse comments
+;; Outputs only significant line breaks (a biggie!)
+;; Nodes are treated as anchors, rather than content organizers (a biggie)
+;; (more book-like, less info-like)
+
+;; TODO
+;; Integration: help, indexing, plain text
+
+(define-module (texinfo)
+ #:use-module (sxml simple)
+ #:use-module (sxml transform)
+ #:use-module (sxml ssax input-parse)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (call-with-file-and-dir
+ texi-command-specs
+ texi-command-depth
+ texi-fragment->stexi
+ texi->stexi
+ stexi->sxml))
+
+;; Some utilities
+
+(define (parser-error port message . rest)
+ (apply throw 'parser-error port message rest))
+
+(define (call-with-file-and-dir filename proc)
+ "Call the one-argument procedure @var{proc} with an input port that
+reads from @var{filename}. During the dynamic extent of @var{proc}'s
+execution, the current directory will be @code{(dirname
address@hidden)}. This is useful for parsing documents that can include
+files by relative path name."
+ (let ((current-dir (getcwd)))
+ (dynamic-wind
+ (lambda () (chdir (dirname filename)))
+ (lambda ()
+ (call-with-input-file (basename filename) proc))
+ (lambda () (chdir current-dir)))))
+
+;; Define this version here, because (srfi srfi-11)'s definition uses
+;; syntax-rules, which is really damn slow
+(define-macro (let*-values bindings . body)
+ (if (null? bindings) (cons 'begin body)
+ (apply
+ (lambda (vars initializer)
+ (let ((cont
+ (cons 'let*-values
+ (cons (cdr bindings) body))))
+ (cond
+ ((not (pair? vars)) ; regular let case, a single var
+ `(let ((,vars ,initializer)) ,cont))
+ ((null? (cdr vars)) ; single var, see the prev case
+ `(let ((,(car vars) ,initializer)) ,cont))
+ (else ; the most generic case
+ `(call-with-values (lambda () ,initializer)
+ (lambda ,vars ,cont))))))
+ (car bindings))))
+
+;;========================================================================
+;; Reflection on the XML vocabulary
+
+(define texi-command-specs
+ #;
+"A list of (@var{name} @var{content-model} . @var{args})
+
address@hidden @var
address@hidden name
+The name of an @@-command, as a symbol.
+
address@hidden content-model
+A symbol indicating the syntactic type of the @@-command:
address@hidden @code
address@hidden EMPTY-COMMAND
+No content, and no @code{@@end} is coming
address@hidden EOL-ARGS
+Unparsed arguments until end of line
address@hidden EOL-TEXT
+Parsed arguments until end of line
address@hidden INLINE-ARGS
+Unparsed arguments ending with @address@hidden
address@hidden INLINE-TEXT
+Parsed arguments ending with @address@hidden
address@hidden ENVIRON
+The tag is an environment tag, expect @code{@@end foo}.
address@hidden TABLE-ENVIRON
+Like ENVIRON, but with special parsing rules for its arguments.
address@hidden FRAGMENT
+For @code{*fragment*}, the command used for parsing fragments of
+texinfo documents.
address@hidden table
+
address@hidden commands will receive their arguments within their
+bodies, whereas the @code{-ARGS} commands will receive them in their
+attribute list.
+
address@hidden receives its arguments in its body.
+
address@hidden commands have both: parsed arguments until the end of
+line, received through their attribute list, and parsed text until the
address@hidden@@end}, received in their bodies.
+
address@hidden receives its arguments in its attribute list, as in
address@hidden
+
+There are four @@-commands that are treated specially. @code{@@include}
+is a low-level token that will not be seen by higher-level parsers, so
+it has no content-model. @code{@@para} is the paragraph command, which
+is only implicit in the texinfo source. @code{@@item} has special
+syntax, as noted above, and @code{@@entry} is how this parser treats
address@hidden@@item} commands within @code{@@table}, @code{@@ftable}, and
address@hidden@@vtable}.
+
+Also, indexing commands (@code{@@cindex}, etc.) are treated specially.
+Their arguments are parsed, but they are needed before entering the
+element so that an anchor can be inserted into the text before the index
+entry.
+
address@hidden 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 table"
+ '(;; Special commands
+ (include #f) ;; this is a low-level token
+ (para PARAGRAPH)
+ (item ITEM)
+ (entry ENTRY . heading)
+ (noindent EMPTY-COMMAND)
+ (*fragment* FRAGMENT)
+
+ ;; Inline text commands
+ (*braces* INLINE-TEXT) ;; FIXME: make me irrelevant
+ (bold INLINE-TEXT)
+ (sample INLINE-TEXT)
+ (samp INLINE-TEXT)
+ (code INLINE-TEXT)
+ (kbd INLINE-TEXT)
+ (key INLINE-TEXT)
+ (var INLINE-TEXT)
+ (env INLINE-TEXT)
+ (file INLINE-TEXT)
+ (command INLINE-TEXT)
+ (option INLINE-TEXT)
+ (dfn INLINE-TEXT)
+ (cite INLINE-TEXT)
+ (acro INLINE-TEXT)
+ (url INLINE-TEXT)
+ (email INLINE-TEXT)
+ (emph INLINE-TEXT)
+ (strong INLINE-TEXT)
+ (sample INLINE-TEXT)
+ (sc INLINE-TEXT)
+ (titlefont INLINE-TEXT)
+ (asis INLINE-TEXT)
+ (b INLINE-TEXT)
+ (i INLINE-TEXT)
+ (r INLINE-TEXT)
+ (sansserif INLINE-TEXT)
+ (slanted INLINE-TEXT)
+ (t INLINE-TEXT)
+
+ ;; Inline args commands
+ (value INLINE-ARGS . (key))
+ (ref INLINE-ARGS . (node #:opt name section info-file
manual))
+ (xref INLINE-ARGS . (node #:opt name section info-file
manual))
+ (pxref INLINE-ARGS . (node #:opt name section info-file
manual))
+ (uref INLINE-ARGS . (url #:opt title replacement))
+ (anchor INLINE-ARGS . (name))
+ (dots INLINE-ARGS . ())
+ (result INLINE-ARGS . ())
+ (bullet INLINE-ARGS . ())
+ (copyright INLINE-ARGS . ())
+ (tie INLINE-ARGS . ())
+ (image INLINE-ARGS . (file #:opt width height alt-text
extension))
+
+ ;; EOL args elements
+ (node EOL-ARGS . (name #:opt next previous up))
+ (c EOL-ARGS . all)
+ (comment EOL-ARGS . all)
+ (setchapternewpage EOL-ARGS . all)
+ (sp EOL-ARGS . all)
+ (page EOL-ARGS . ())
+ (vskip EOL-ARGS . all)
+ (syncodeindex EOL-ARGS . all)
+ (contents EOL-ARGS . ())
+ (shortcontents EOL-ARGS . ())
+ (summarycontents EOL-ARGS . ())
+ (insertcopying EOL-ARGS . ())
+ (dircategory EOL-ARGS . (category))
+ (top EOL-ARGS . (title))
+ (printindex EOL-ARGS . (type))
+
+ ;; EOL text commands
+ (*ENVIRON-ARGS* EOL-TEXT)
+ (itemx EOL-TEXT)
+ (set EOL-TEXT)
+ (center EOL-TEXT)
+ (title EOL-TEXT)
+ (subtitle EOL-TEXT)
+ (author EOL-TEXT)
+ (chapter EOL-TEXT)
+ (section EOL-TEXT)
+ (appendix EOL-TEXT)
+ (appendixsec EOL-TEXT)
+ (unnumbered EOL-TEXT)
+ (unnumberedsec EOL-TEXT)
+ (subsection EOL-TEXT)
+ (subsubsection EOL-TEXT)
+ (appendixsubsec EOL-TEXT)
+ (appendixsubsubsec EOL-TEXT)
+ (unnumberedsubsec EOL-TEXT)
+ (unnumberedsubsubsec EOL-TEXT)
+ (chapheading EOL-TEXT)
+ (majorheading EOL-TEXT)
+ (heading EOL-TEXT)
+ (subheading EOL-TEXT)
+ (subsubheading EOL-TEXT)
+
+ (deftpx EOL-TEXT-ARGS . (category name . attributes))
+ (defcvx EOL-TEXT-ARGS . (category class name))
+ (defivarx EOL-TEXT-ARGS . (class name))
+ (deftypeivarx EOL-TEXT-ARGS . (class data-type name))
+ (defopx EOL-TEXT-ARGS . (category class name . arguments))
+ (deftypeopx EOL-TEXT-ARGS . (category class data-type name .
arguments))
+ (defmethodx EOL-TEXT-ARGS . (class name . arguments))
+ (deftypemethodx EOL-TEXT-ARGS . (class data-type name . arguments))
+ (defoptx EOL-TEXT-ARGS . (name))
+ (defvrx EOL-TEXT-ARGS . (category name))
+ (defvarx EOL-TEXT-ARGS . (name))
+ (deftypevrx EOL-TEXT-ARGS . (category data-type name))
+ (deftypevarx EOL-TEXT-ARGS . (data-type name))
+ (deffnx EOL-TEXT-ARGS . (category name . arguments))
+ (deftypefnx EOL-TEXT-ARGS . (category data-type name . arguments))
+ (defspecx EOL-TEXT-ARGS . (name . arguments))
+ (defmacx EOL-TEXT-ARGS . (name . arguments))
+ (defunx EOL-TEXT-ARGS . (name . arguments))
+ (deftypefunx EOL-TEXT-ARGS . (data-type name . arguments))
+
+ ;; Indexing commands
+ (cindex INDEX . entry)
+ (findex INDEX . entry)
+ (vindex INDEX . entry)
+ (kindex INDEX . entry)
+ (pindex INDEX . entry)
+ (tindex INDEX . entry)
+
+ ;; Environment commands (those that need @end)
+ (texinfo ENVIRON . title)
+ (ignore ENVIRON . ())
+ (ifinfo ENVIRON . ())
+ (iftex ENVIRON . ())
+ (ifhtml ENVIRON . ())
+ (ifxml ENVIRON . ())
+ (ifplaintext ENVIRON . ())
+ (ifnotinfo ENVIRON . ())
+ (ifnottex ENVIRON . ())
+ (ifnothtml ENVIRON . ())
+ (ifnotxml ENVIRON . ())
+ (ifnotplaintext ENVIRON . ())
+ (titlepage ENVIRON . ())
+ (menu ENVIRON . ())
+ (direntry ENVIRON . ())
+ (copying ENVIRON . ())
+ (example ENVIRON . ())
+ (smallexample ENVIRON . ())
+ (display ENVIRON . ())
+ (smalldisplay ENVIRON . ())
+ (verbatim ENVIRON . ())
+ (format ENVIRON . ())
+ (smallformat ENVIRON . ())
+ (lisp ENVIRON . ())
+ (smalllisp ENVIRON . ())
+ (cartouche ENVIRON . ())
+ (quotation ENVIRON . ())
+
+ (deftp ENVIRON . (category name . attributes))
+ (defcv ENVIRON . (category class name))
+ (defivar ENVIRON . (class name))
+ (deftypeivar ENVIRON . (class data-type name))
+ (defop ENVIRON . (category class name . arguments))
+ (deftypeop ENVIRON . (category class data-type name . arguments))
+ (defmethod ENVIRON . (class name . arguments))
+ (deftypemethod ENVIRON . (class data-type name . arguments))
+ (defopt ENVIRON . (name))
+ (defvr ENVIRON . (category name))
+ (defvar ENVIRON . (name))
+ (deftypevr ENVIRON . (category data-type name))
+ (deftypevar ENVIRON . (data-type name))
+ (deffn ENVIRON . (category name . arguments))
+ (deftypefn ENVIRON . (category data-type name . arguments))
+ (defspec ENVIRON . (name . arguments))
+ (defmac ENVIRON . (name . arguments))
+ (defun ENVIRON . (name . arguments))
+ (deftypefun ENVIRON . (data-type name . arguments))
+
+ (table TABLE-ENVIRON . (formatter))
+ (itemize TABLE-ENVIRON . (formatter))
+ (enumerate TABLE-ENVIRON . (start))
+ (ftable TABLE-ENVIRON . (formatter))
+ (vtable TABLE-ENVIRON . (formatter))))
+
+(define command-depths
+ '((chapter . 1) (section . 2) (subsection . 3) (subsubsection . 4)
+ (top . 0) (unnumbered . 1) (unnumberedsec . 2)
+ (unnumberedsubsec . 3) (unnumberedsubsubsec . 4)
+ (appendix . 1) (appendixsec . 2) (appendixsection . 2)
+ (appendixsubsec . 3) (appendixsubsubsec . 4)))
+(define (texi-command-depth command max-depth)
+ "Given the texinfo command @var{command}, return its nesting level, or
address@hidden if it nests too deep for @var{max-depth}.
+
+Examples:
address@hidden
+ (texi-command-depth 'chapter 4) @result{} 1
+ (texi-command-depth 'top 4) @result{} 0
+ (texi-command-depth 'subsection 4) @result{} 3
+ (texi-command-depth 'appendixsubsec 4) @result{} 3
+ (texi-command-depth 'subsection 2) @result{} #f
address@hidden example"
+ (let ((depth (and=> (assq command command-depths) cdr)))
+ (and depth (<= depth max-depth) depth)))
+
+;; The % is for arguments
+(define (space-significant? command)
+ (memq command
+ '(example smallexample verbatim lisp smalllisp menu %)))
+
+;; Like a DTD for texinfo
+(define (command-spec command)
+ (or (assq command texi-command-specs)
+ (parser-error #f "Unknown command" command)))
+
+(define (inline-content? content)
+ (or (eq? content 'INLINE-TEXT) (eq? content 'INLINE-ARGS)))
+
+
+;;========================================================================
+;; Lower-level parsers and scanners
+;;
+;; They deal with primitive lexical units (Names, whitespaces, tags) and
+;; with pieces of more generic productions. Most of these parsers must
+;; be called in appropriate context. For example, complete-start-command
+;; must be called only when the @-command start has been detected and
+;; its name token has been read.
+
+;; Test if a string is made of only whitespace
+;; An empty string is considered made of whitespace as well
+(define (string-whitespace? str)
+ (or (string-null? str)
+ (string-every char-whitespace? str)))
+
+;; Like read-text-line, but allows EOF.
+(define read-eof-breaks '(*eof* #\return #\newline))
+(define (read-eof-line port)
+ (if (eof-object? (peek-char port))
+ (peek-char port)
+ (let* ((line (next-token '() read-eof-breaks
+ "reading a line" port))
+ (c (read-char port))) ; must be either \n or \r or EOF
+ (if (and (eq? c #\return) (eq? (peek-char port) #\newline))
+ (read-char port)) ; skip \n that follows \r
+ line)))
+
+(define (skip-whitespace port)
+ (skip-while '(#\space #\tab #\return #\newline) port))
+
+(define (skip-horizontal-whitespace port)
+ (skip-while '(#\space #\tab) port))
+
+;; command ::= Letter+
+
+;; procedure: read-command PORT
+;;
+;; Read a command starting from the current position in the PORT and
+;; return it as a symbol.
+(define (read-command port)
+ (let ((first-char (peek-char port)))
+ (or (char-alphabetic? first-char)
+ (parser-error port "Nonalphabetic @-command char: '" first-char "'")))
+ (string->symbol
+ (next-token-of
+ (lambda (c)
+ (cond
+ ((eof-object? c) #f)
+ ((char-alphabetic? c) c)
+ (else #f)))
+ port)))
+
+;; A token is a primitive lexical unit. It is a record with two fields,
+;; token-head and token-kind.
+;;
+;; Token types:
+;; END The end of a texinfo command. If the command is ended by },
+;; token-head will be #f. Otherwise if the command is ended by
+;; @end COMMAND, token-head will be COMMAND. As a special case,
+;; @bye is the end of a special @texinfo command.
+;; START The start of a texinfo command. The token-head will be a
+;; symbol of the @-command name.
+;; INCLUDE An @include directive. The token-head will be empty -- the
+;; caller is responsible for reading the include file name.
+;; ITEM @item commands have an irregular syntax. They end at the
+;; next @item, or at the end of the environment. For that
+;; read-command-token treats them specially.
+
+(define (make-token kind head) (cons kind head))
+(define token? pair?)
+(define token-kind car)
+(define token-head cdr)
+
+;; procedure: read-command-token PORT
+;;
+;; This procedure starts parsing of a command token. The current
+;; position in the stream must be address@hidden This procedure scans enough of
+;; the input stream to figure out what kind of a command token it is
+;; seeing. The procedure returns a token structure describing the token.
+
+(define (read-command-token port)
+ (assert-curr-char '(#\@) "start of the command" port)
+ (let ((peeked (peek-char port)))
+ (cond
+ ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\}))
+ ;; @-commands that escape characters
+ (make-token 'STRING (string (read-char port))))
+ (else
+ (let ((name (read-command port)))
+ (case name
+ ((end)
+ ;; got an ending tag
+ (let ((command (string-trim-both
+ (read-eof-line port))))
+ (or (and (not (string-null? command))
+ (string-every char-alphabetic? command))
+ (parser-error port "malformed @end" command))
+ (make-token 'END (string->symbol command))))
+ ((bye)
+ ;; the end of the top
+ (make-token 'END 'texinfo))
+ ((item)
+ (make-token 'ITEM 'item))
+ ((include)
+ (make-token 'INCLUDE #f))
+ (else
+ (make-token 'START name))))))))
+
+;; procedure+: read-verbatim-body PORT STR-HANDLER SEED
+;;
+;; This procedure must be called after we have read a string
+;; "@verbatim\n" that begins a verbatim section. The current position
+;; must be the first position of the verbatim body. This function reads
+;; _lines_ of the verbatim body and passes them to a STR-HANDLER, a
+;; character data consumer.
+;;
+;; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
+;; The first STRING1 argument to STR-HANDLER never contains a newline.
+;; The second STRING2 argument often will. On the first invocation of the
+;; STR-HANDLER, the seed is the one passed to read-verbatim-body
+;; as the third argument. The result of this first invocation will be
+;; passed as the seed argument to the second invocation of the line
+;; consumer, and so on. The result of the last invocation of the
+;; STR-HANDLER is returned by the read-verbatim-body. Note a
+;; similarity to the fundamental 'fold' iterator.
+;;
+;; Within a verbatim section all characters are taken at their face
+;; value. It ends with "address@hidden verbatim(\r)?\n".
+
+;; Must be called right after the newline after @verbatim.
+(define (read-verbatim-body port str-handler seed)
+ (let loop ((seed seed))
+ (let ((fragment (next-token '() '(#\newline)
+ "reading verbatim" port)))
+ ;; We're reading the char after the 'fragment', which is
+ ;; #\newline.
+ (read-char port)
+ (if (string=? fragment "@end verbatim")
+ seed
+ (loop (str-handler fragment "\n" seed))))))
+
+;; procedure+: read-arguments PORT
+;;
+;; This procedure reads and parses a production ArgumentList.
+;; ArgumentList ::= S* Argument (S* , S* Argument)* S*
+;; Argument ::= (address@hidden,])*
+;;
+;; Arguments are the things in braces, i.e @ref{my node} has one
+;; argument, "my node". Most commands taking braces actually don't have
+;; arguments, they process text. For example, in
+;; @address@hidden, the emph takes text, because the parse
+;; continues into the braces.
+;;
+;; Any whitespace within Argument is replaced with a single space.
+;; Whitespace around an Argument is trimmed.
+;;
+;; The procedure returns a list of arguments. Afterwards the current
+;; character will be after the final #\}.
+
+(define (read-arguments port stop-char)
+ (define (split str)
+ (read-char port) ;; eat the delimiter
+ (let ((ret (map (lambda (x) (if (string-null? x) #f x))
+ (map string-trim-both (string-split str #\,)))))
+ (if (and (pair? ret) (eq? (car ret) #f) (null? (cdr ret)))
+ '()
+ ret)))
+ (split (next-token '() (list stop-char)
+ "arguments of @-command" port)))
+
+;; procedure+: complete-start-command COMMAND PORT
+;;
+;; This procedure is to complete parsing of an @-command. The procedure
+;; must be called after the command token has been read. COMMAND is a
+;; TAG-NAME.
+;;
+;; This procedure returns several values:
+;; COMMAND: a symbol.
+;; ARGUMENTS: command's arguments, as an alist.
+;; CONTENT-MODEL: the content model of the command.
+;;
+;; On exit, the current position in PORT will depend on the CONTENT-MODEL.
+;;
+;; Content model Port position
+;; ============= =============
+;; INLINE-TEXT 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
+;; The first character on the next line.
+;; PARAGRAPH, ITEM, EMPTY-COMMAND
+;; The first character after the command.
+
+(define (arguments->attlist port args arg-names)
+ (let loop ((in args) (names arg-names) (opt? #f) (out '()))
+ (cond
+ ((symbol? names) ;; a rest arg
+ (reverse (if (null? in) out (acons names in out))))
+ ((and (not (null? names)) (eq? (car names) #:opt))
+ (loop in (cdr names) #t out))
+ ((null? in)
+ (if (or (null? names) opt?)
+ (reverse out)
+ (parser-error port "@-command expected more arguments:"
+ args arg-names names)))
+ ((null? names)
+ (parser-error port "@-command didn't expect more arguments:" in))
+ ((not (car in))
+ (or (and opt? (loop (cdr in) (cdr names) opt? out))
+ (parser-error "@-command missing required argument"
+ (car names))))
+ (else
+ (loop (cdr in) (cdr names) opt?
+ (cons (list (car names) (car in)) out))))))
+
+(define (parse-table-args command port)
+ (let* ((line (string-trim-both (read-text-line port)))
+ (length (string-length line)))
+ (define (get-formatter)
+ (or (and (not (zero? length))
+ (eq? (string-ref line 0) #\@)
+ (let ((f (string->symbol (substring line 1))))
+ (or (inline-content? (cadr (command-spec f)))
+ (parser-error
+ port "@item formatter must be INLINE" f))
+ f))
+ (parser-error port "Invalid @item formatter" line)))
+ (case command
+ ((enumerate)
+ (if (zero? length)
+ '()
+ `((start
+ ,(if (or (and (eq? length 1)
+ (char-alphabetic? (string-ref line 0)))
+ (string-every char-numeric? line))
+ line
+ (parser-error
+ port "Invalid enumerate start" line))))))
+ ((itemize)
+ `((bullet
+ ,(or (and (eq? length 1) line)
+ (and (string-null? line) '(bullet))
+ (list (get-formatter))))))
+ (else ;; tables of various varieties
+ `((formatter (,(get-formatter))))))))
+
+(define (complete-start-command command port)
+ (define (get-arguments type arg-names stop-char)
+ (arguments->attlist port (read-arguments port stop-char) arg-names))
+
+ (let* ((spec (command-spec command))
+ (type (cadr spec))
+ (arg-names (cddr spec)))
+ (case type
+ ((INLINE-TEXT)
+ (assert-curr-char '(#\{) "Inline element lacks {" port)
+ (values command '() type))
+ ((INLINE-ARGS)
+ (assert-curr-char '(#\{) "Inline element lacks {" port)
+ (values command (get-arguments type arg-names #\}) type))
+ ((EOL-ARGS)
+ (values command (get-arguments type arg-names #\newline) type))
+ ((ENVIRON ENTRY INDEX)
+ (skip-horizontal-whitespace port)
+ (values command (parse-environment-args command port) type))
+ ((TABLE-ENVIRON)
+ (skip-horizontal-whitespace port)
+ (values command (parse-table-args command port) type))
+ ((EOL-TEXT)
+ (skip-horizontal-whitespace port)
+ (values command '() type))
+ ((EOL-TEXT-ARGS)
+ (skip-horizontal-whitespace port)
+ (values command (parse-eol-text-args command port) type))
+ ((PARAGRAPH EMPTY-COMMAND ITEM FRAGMENT)
+ (values command '() type))
+ (else ;; INCLUDE shouldn't get here
+ (parser-error port "can't happen")))))
+
+;;-----------------------------------------------------------------------------
+;; Higher-level parsers and scanners
+;;
+;; They parse productions corresponding entire @-commands.
+
+;; Only reads @settitle, leaves it to the command parser to finish
+;; reading the title.
+(define (take-until-settitle port)
+ (or (find-string-from-port? "address@hidden " port)
+ (parser-error port "No address@hidden found"))
+ (skip-horizontal-whitespace port)
+ (and (eq? (peek-char port) #\newline)
+ (parser-error port "You have a @settitle, but no title")))
+
+;; procedure+: read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
+;;
+;; This procedure is to read the CharData of a texinfo document.
+;;
+;; text ::= (CharData | Command)*
+;;
+;; The procedure reads CharData and stops at @-commands (or
+;; environments). It also stops at an open or close brace.
+;;
+;; port
+;; a PORT to read
+;; expect-eof?
+;; a boolean indicating if EOF is normal, i.e., the character
+;; data may be terminated by the EOF. EOF is normal
+;; while processing the main document.
+;; preserve-ws?
+;; a boolean indicating if we are within a whitespace-preserving
+;; environment. If #t, suppress paragraph detection.
+;; str-handler
+;; a STR-HANDLER, see read-verbatim-body
+;; seed
+;; an argument passed to the first invocation of STR-HANDLER.
+;;
+;; The procedure returns two results: SEED and TOKEN. The SEED is the
+;; result of the last invocation of STR-HANDLER, or the original seed if
+;; STR-HANDLER was never called.
+;;
+;; TOKEN can be either an eof-object (this can happen only if expect-eof?
+;; was #t), or a texinfo token denoting the start or end of a tag.
+
+;; read-char-data port expect-eof? preserve-ws? str-handler seed
+(define read-char-data
+ (let* ((end-chars-eof '(*eof* #\{ #\} #\@ #\newline)))
+ (define (handle str-handler str1 str2 seed)
+ (if (and (string-null? str1) (string-null? str2))
+ seed
+ (str-handler str1 str2 seed)))
+
+ (lambda (port expect-eof? preserve-ws? str-handler seed)
+ (let ((end-chars ((if expect-eof? identity cdr) end-chars-eof)))
+ (let loop ((seed seed))
+ (let* ((fragment (next-token '() end-chars "reading char data" port))
+ (term-char (peek-char port))) ; one of end-chars
+ (cond
+ ((eof-object? term-char) ; only if expect-eof?
+ (values (handle str-handler fragment "" seed) term-char))
+ ((memq term-char '(#\@ #\{ #\}))
+ (values (handle str-handler fragment "" seed)
+ (case term-char
+ ((#\@) (read-command-token port))
+ ((#\{) (make-token 'START '*braces*))
+ ((#\}) (read-char port) (make-token 'END #f)))))
+ ((eq? term-char #\newline)
+ ;; Always significant, unless directly before an end token.
+ (let ((c (peek-next-char port)))
+ (cond
+ ((eof-object? c)
+ (or expect-eof?
+ (parser-error port "EOF while reading char data"))
+ (values (handle str-handler fragment "" seed) c))
+ ((eq? c #\@)
+ (let* ((token (read-command-token port))
+ (end? (eq? (token-kind token) 'END)))
+ (values
+ (handle str-handler fragment (if end? "" " ") seed)
+ token)))
+ ((and (not preserve-ws?) (eq? c #\newline))
+ ;; paragraph-separator ::= #\newline #\newline+
+ (skip-while '(#\newline) port)
+ (skip-horizontal-whitespace port)
+ (values (handle str-handler fragment "" seed)
+ (make-token 'PARA 'para)))
+ (else
+ (loop (handle str-handler fragment
+ (if preserve-ws? "\n" " ") seed)))))))))))))
+
+; procedure+: assert-token TOKEN KIND NAME
+; Make sure that TOKEN is of anticipated KIND and has anticipated NAME
+(define (assert-token token kind name)
+ (or (and (token? token)
+ (eq? kind (token-kind token))
+ (equal? name (token-head token)))
+ (parser-error #f "Expecting @end for " name ", got " token)))
+
+;;========================================================================
+;; Highest-level parsers: Texinfo to SXML
+
+;; These parsers are a set of syntactic forms to instantiate a SSAX
+;; parser. The user tells what to do with the parsed character and
+;; element data. These latter handlers determine if the parsing follows a
+;; SAX or a DOM model.
+
+;; syntax: make-command-parser fdown fup str-handler
+
+;; Create a parser to parse and process one element, including its
+;; character content or children elements. The parser is typically
+;; applied to the root element of a document.
+
+;; fdown
+;; procedure COMMAND ARGUMENTS EXPECTED-CONTENT SEED
+;;
+;; This procedure is to generate the seed to be passed to handlers
+;; that process the content of the element. This is the function
+;; identified as 'fdown' in the denotational semantics of the XML
+;; parser given in the title comments to (sxml ssax).
+;;
+;; fup
+;; procedure COMMAND ARGUMENTS PARENT-SEED SEED
+;;
+;; This procedure is called when parsing of COMMAND is finished.
+;; The SEED is the result from the last content parser (or from
+;; fdown if the element has the empty content). PARENT-SEED is the
+;; same seed as was passed to fdown. The procedure is to generate a
+;; seed that will be the result of the element parser. This is the
+;; function identified as 'fup' in the denotational semantics of
+;; the XML parser given in the title comments to (sxml ssax).
+;;
+;; str-handler
+;; A STR-HANDLER, see read-verbatim-body
+;;
+
+;; The generated parser is a
+;; procedure COMMAND PORT SEED
+;;
+;; The procedure must be called *after* the command token has been read.
+
+(define (read-include-file-name port)
+ (let ((x (string-trim-both (read-eof-line port))))
+ (if (string-null? x)
+ (error "no file listed")
+ x))) ;; fixme: should expand @value{} references
+
+(define (sxml->node-name sxml)
+ "Turn some sxml string into a valid node name."
+ (let loop ((in (string->list (sxml->string sxml))) (out '()))
+ (if (null? in)
+ (apply string (reverse out))
+ (if (memq (car in) '(#\{ #\} #\@ #\,))
+ (loop (cdr in) out)
+ (loop (cdr in) (cons (car in) out))))))
+
+(define (index command arguments fdown fup parent-seed)
+ (case command
+ ((deftp defcv defivar deftypeivar defop deftypeop defmethod
+ deftypemethod defopt defvr defvar deftypevr deftypevar deffn
+ deftypefn defspec defmac defun deftypefun)
+ (let ((args `((name ,(string-append (symbol->string command) "-"
+ (cadr (assq 'name arguments)))))))
+ (fup 'anchor args parent-seed
+ (fdown 'anchor args 'INLINE-ARGS '()))))
+ ((cindex findex vindex kindex pindex tindex)
+ (let ((args `((name ,(string-append (symbol->string command) "-"
+ (sxml->node-name
+ (assq 'entry arguments)))))))
+ (fup 'anchor args parent-seed
+ (fdown 'anchor args 'INLINE-ARGS '()))))
+ (else parent-seed)))
+
+(define (make-command-parser fdown fup str-handler)
+ (lambda (command port seed)
+ (let visit ((command command) (port port) (sig-ws? #f) (parent-seed seed))
+ (let*-values (((command arguments expected-content)
+ (complete-start-command command port)))
+ (let* ((parent-seed (index command arguments fdown fup parent-seed))
+ (seed (fdown command arguments expected-content parent-seed))
+ (eof-closes? (or (memq command '(texinfo para *fragment*))
+ (eq? expected-content 'EOL-TEXT)))
+ (sig-ws? (or sig-ws? (space-significant? command)))
+ (up (lambda (s) (fup command arguments parent-seed s)))
+ (new-para (lambda (s) (fdown 'para '() 'PARAGRAPH s)))
+ (make-end-para (lambda (p) (lambda (s) (fup 'para '() p s)))))
+
+ (define (port-for-content)
+ (if (eq? expected-content 'EOL-TEXT)
+ (call-with-input-string (read-text-line port) identity)
+ port))
+
+ (cond
+ ((memq expected-content '(EMPTY-COMMAND INLINE-ARGS EOL-ARGS INDEX
+ EOL-TEXT-ARGS))
+ ;; empty or finished by complete-start-command
+ (up seed))
+ ((eq? command 'verbatim)
+ (up (read-verbatim-body port str-handler seed)))
+ (else
+ (let loop ((port (port-for-content))
+ (expect-eof? eof-closes?)
+ (end-para identity)
+ (need-break? (and (not sig-ws?)
+ (memq expected-content
+ '(ENVIRON TABLE-ENVIRON
+ ENTRY ITEM FRAGMENT))))
+ (seed seed))
+ (cond
+ ((and need-break? (or sig-ws? (skip-whitespace port))
+ (not (memq (peek-char port) '(#\@ #\})))
+ (not (eof-object? (peek-char port))))
+ ;; Even if we have an @, it might be inline -- check
+ ;; that later
+ (let ((seed (end-para seed)))
+ (loop port expect-eof? (make-end-para seed) #f
+ (new-para seed))))
+ (else
+ (let*-values (((seed token)
+ (read-char-data
+ port expect-eof? sig-ws? str-handler seed)))
+ (cond
+ ((eof-object? token)
+ (case expect-eof?
+ ((include #f) (end-para seed))
+ (else (up (end-para seed)))))
+ (else
+ (case (token-kind token)
+ ((STRING)
+ ;; this is only @-commands that escape
+ ;; characters: @}, @@, @{ -- new para if need-break
+ (let ((seed ((if need-break? end-para identity) seed)))
+ (loop port expect-eof?
+ (if need-break? (make-end-para seed) end-para)
#f
+ (str-handler (token-head token) ""
+ ((if need-break? new-para identity)
+ seed)))))
+ ((END)
+ ;; The end will only have a name if it's for an
+ ;; environment
+ (cond
+ ((memq command '(item entry))
+ (let ((spec (command-spec (token-head token))))
+ (or (eq? (cadr spec) 'TABLE-ENVIRON)
+ (parser-error
+ port "@item not ended by @end
table/enumerate/itemize"
+ token))))
+ ((eq? expected-content 'ENVIRON)
+ (assert-token token 'END command)))
+ (up (end-para seed)))
+ ((ITEM)
+ (cond
+ ((memq command '(enumerate itemize))
+ (up (visit 'item port sig-ws? (end-para seed))))
+ ((eq? expected-content 'TABLE-ENVIRON)
+ (up (visit 'entry port sig-ws? (end-para seed))))
+ ((memq command '(item entry))
+ (visit command port sig-ws? (up (end-para seed))))
+ (else
+ (parser-error
+ port "@item must be within a table environment"
+ command))))
+ ((PARA)
+ ;; examine valid paragraphs?
+ (loop port expect-eof? end-para (not sig-ws?) seed))
+ ((INCLUDE)
+ ;; Recurse for include files
+ (let ((seed (call-with-file-and-dir
+ (read-include-file-name port)
+ (lambda (port)
+ (loop port 'include end-para
+ need-break? seed)))))
+ (loop port expect-eof? end-para need-break? seed)))
+ ((START) ; Start of an @-command
+ (let* ((head (token-head token))
+ (type (cadr (command-spec head)))
+ (inline? (inline-content? type))
+ (seed ((if (and inline? (not need-break?))
+ identity end-para) seed))
+ (end-para (if inline?
+ (if need-break? (make-end-para
seed)
+ end-para)
+ identity))
+ (new-para (if (and inline? need-break?)
+ new-para identity)))
+ (loop port expect-eof? end-para (not inline?)
+ (visit head port sig-ws? (new-para seed)))))
+ (else
+ (parser-error port "Unknown token type"
token))))))))))))))))
+
+;; procedure: reverse-collect-str-drop-ws fragments
+;;
+;; Given the list of fragments (some of which are text strings), reverse
+;; the list and concatenate adjacent text strings. We also drop
+;; "unsignificant" whitespace, that is, whitespace in front, behind and
+;; between elements. The whitespace that is included in character data
+;; is not affected.
+(define (reverse-collect-str-drop-ws fragments)
+ (cond
+ ((null? fragments) ; a shortcut
+ '())
+ ((and (string? (car fragments)) ; another shortcut
+ (null? (cdr fragments)) ; remove single ws-only string
+ (string-whitespace? (car fragments)))
+ '())
+ (else
+ (let loop ((fragments fragments) (result '()) (strs '())
+ (all-whitespace? #t))
+ (cond
+ ((null? fragments)
+ (if all-whitespace?
+ result ; remove leading ws
+ (cons (apply string-append strs) result)))
+ ((string? (car fragments))
+ (loop (cdr fragments) result (cons (car fragments) strs)
+ (and all-whitespace?
+ (string-whitespace? (car fragments)))))
+ (else
+ (loop (cdr fragments)
+ (cons
+ (car fragments)
+ (cond
+ ((null? strs) result)
+ (all-whitespace?
+ (if (null? result)
+ result ; remove trailing whitespace
+ (cons " " result))); replace interstitial ws with
+ ; one space
+ (else
+ (cons (apply string-append strs) result))))
+ '() #t)))))))
+
+(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)))
+ (lambda (string1 string2 seed) ; str-handler
+ (if (string-null? string2)
+ (cons string1 seed)
+ (cons* string2 string1 seed)))))
+
+(define parse-environment-args
+ (let ((parser (make-dom-parser)))
+ ;; duplicate arguments->attlist to avoid unnecessary splitting
+ (lambda (command port)
+ (let ((args (cdar (parser '*ENVIRON-ARGS* port '())))
+ (arg-names (cddr (command-spec command))))
+ (cond
+ ((not arg-names)
+ (if (null? args) '()
+ (parser-error port "@-command doesn't take args" command)))
+ ((eq? arg-names #t)
+ (list (cons 'arguments args)))
+ (else
+ (let loop ((args args) (arg-names arg-names) (out '()))
+ (cond
+ ((null? arg-names)
+ (if (null? args) (reverse! out)
+ (parser-error port "@-command didn't expect more args"
+ command args)))
+ ((symbol? arg-names)
+ (reverse! (acons arg-names args out)))
+ ((null? args)
+ (parser-error port "@-command expects more args"
+ command arg-names))
+ ((and (string? (car args)) (string-index (car args) #\space))
+ => (lambda (i)
+ (let ((rest (substring/shared (car args) (1+ i))))
+ (if (zero? i)
+ (loop (cons rest (cdr args)) arg-names out)
+ (loop (cons rest (cdr args)) (cdr arg-names)
+ (cons (list (car arg-names)
+ (substring (car args) 0 i))
+ out))))))
+ (else
+ (loop (cdr args) (cdr arg-names)
+ (if (and (pair? (car args)) (eq? (caar args) '*braces*))
+ (acons (car arg-names) (cdar args) out)
+ (cons (list (car arg-names) (car args)) out))))))))))))
+
+(define (parse-eol-text-args command port)
+ ;; perhaps parse-environment-args should be named more
+ ;; generically.
+ (parse-environment-args command port))
+
+;; procedure: texi-fragment->stexi STRING
+;;
+;; A DOM parser for a texinfo fragment STRING.
+;;
+;; The procedure returns an SXML tree headed by the special tag,
+;; *fragment*.
+
+(define (texi-fragment->stexi string-or-port)
+ "Parse the texinfo commands in @var{string-or-port}, and return the
+resultant stexi tree. The head of the tree will be the special command,
address@hidden"
+ (define (parse port)
+ (postprocess (car ((make-dom-parser) '*fragment* port '()))))
+ (if (input-port? string-or-port)
+ (parse string-or-port)
+ (call-with-input-string string-or-port parse)))
+
+;; procedure: texi->stexi PORT
+;;
+;; This is an instance of a SSAX parser above that returns an SXML
+;; representation of the texinfo document ready to be read at PORT.
+;;
+;; The procedure returns an SXML tree. The port points to the
+;; first character after the @bye, or to the end of the file.
+
+(define (texi->stexi port)
+ "Read a full texinfo document from @var{port} and return the parsed
+stexi tree. The parsing will start at the @code{@@settitle} and end at
address@hidden@@bye} or EOF."
+ (let ((parser (make-dom-parser)))
+ (take-until-settitle port)
+ (postprocess (car (parser 'texinfo port '())))))
+
+(define (car-eq? x y) (and (pair? x) (eq? (car x) y)))
+(define (make-contents tree)
+ (define (lp in out depth)
+ (cond
+ ((null? in) (values in (cons 'enumerate (reverse! out))))
+ ((and (pair? (cdr in)) (texi-command-depth (caadr in) 4))
+ => (lambda (new-depth)
+ (let ((node-name (and (car-eq? (car in) 'node)
+ (cadr (assq 'name (cdadar in))))))
+ (cond
+ ((< new-depth depth)
+ (values in (cons 'enumerate (reverse! out))))
+ ((> new-depth depth)
+ (let ((out-cdr (if (null? out) '() (cdr out)))
+ (out-car (if (null? out) (list 'item) (car out))))
+ (let*-values (((new-in new-out) (lp in '() (1+ depth))))
+ (lp new-in
+ (cons (append out-car (list new-out)) out-cdr)
+ depth))))
+ (else ;; same depth
+ (lp (cddr in)
+ (cons
+ `(item (para
+ ,@(if node-name
+ `((ref (% (node ,node-name))))
+ (cdadr in))))
+ out)
+ depth))))))
+ (else (lp (cdr in) out depth))))
+ (let*-values (((_ contents) (lp tree '() 1)))
+ `((chapheading "Table of Contents") ,contents)))
+
+(define (trim-whitespace str trim-left? trim-right?)
+ (let* ((left-space? (and (not trim-left?)
+ (string-prefix? " " str)))
+ (right-space? (and (not trim-right?)
+ (string-suffix? " " str)))
+ (tail (append! (string-tokenize str)
+ (if right-space? '("") '()))))
+ (string-join (if left-space? (cons "" tail) tail))))
+
+(define (postprocess tree)
+ (define (loop in out state first? sig-ws?)
+ (cond
+ ((null? in)
+ (values (reverse! out) state))
+ ((string? (car in))
+ (loop (cdr in)
+ (cons (if sig-ws? (car in)
+ (trim-whitespace (car in) first? (null? (cdr in))))
+ out)
+ state #f sig-ws?))
+ ((pair? (car in))
+ (case (caar in)
+ ((set)
+ (if (null? (cdar in)) (error "@set missing arguments" in))
+ (if (string? (cadar in))
+ (let ((i (string-index (cadar in) #\space)))
+ (if i
+ (loop (cdr in) out
+ (acons (substring (cadar in) 0 i)
+ (cons (substring (cadar in) (1+ i)) (cddar in))
+ state)
+ #f sig-ws?)
+ (loop (cdr in) out (acons (cadar in) (cddar in) state)
+ #f sig-ws?)))
+ (error "expected a constant to define for @set" in)))
+ ((value)
+ (loop (fold-right cons (cdr in)
+ (or (and=>
+ (assoc (cadr (assq 'key (cdadar in))) state)
cdr)
+ (error "unknown value" (cdadar in) state)))
+ out
+ state #f sig-ws?))
+ ((copying)
+ (loop (cdr in) out (cons (car in) state) #f sig-ws?))
+ ((insertcopying)
+ (loop (fold-right cons (cdr in)
+ (or (cdr (assoc 'copying state))
+ (error "copying isn't set yet")))
+ out
+ state #f sig-ws?))
+ ((contents)
+ (loop (cdr in) (fold cons out (make-contents tree)) state #f sig-ws?))
+ (else
+ (let*-values (((kid-out state)
+ (loop (car in) '() state #t
+ (or sig-ws? (space-significant? (caar in))))))
+ (loop (cdr in) (cons kid-out out) state #f sig-ws?)))))
+ (else ; a symbol
+ (loop (cdr in) (cons (car in) out) state #t sig-ws?))))
+
+ (call-with-values
+ (lambda () (loop tree '() '() #t #f))
+ (lambda (out state) out)))
+
+;; Replace % with texinfo-arguments.
+(define (stexi->sxml tree)
+ "Transform the stexi tree @var{tree} into sxml. This involves
+replacing the @code{%} element that keeps the texinfo arguments with an
+element for each argument.
+
+FIXME: right now it just changes % to @code{texinfo-arguments} -- that
+doesn't hang with the idea of making a dtd at some point"
+ (pre-post-order
+ tree
+ `((% . ,(lambda (x . t) (cons 'texinfo-arguments t)))
+ (*text* . ,(lambda (x t) t))
+ (*default* . ,(lambda (x . t) (cons x t))))))
+
+;;; arch-tag: 73890afa-597c-4264-ae70-46fe7756ffb5
+;;; texinfo.scm ends here
diff --git a/module/texinfo/docbook.scm b/module/texinfo/docbook.scm
new file mode 100644
index 0000000..f760e5b
--- /dev/null
+++ b/module/texinfo/docbook.scm
@@ -0,0 +1,233 @@
+;;;; (texinfo docbook) -- translating sdocbook into stexinfo
+;;;;
+;;;; Copyright (C) 2009 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;; @c
+;; This module exports procedures for transforming a limited subset of
+;; the SXML representation of docbook into stexi. It is not complete by
+;; any means. The intention is to gather a number of routines and
+;; stylesheets so that external modules can parse specific subsets of
+;; docbook, for example that set generated by certain tools.
+;;
+;;; Code:
+
+(define-module (texinfo docbook)
+ :use-module (sxml fold)
+ :export (*sdocbook->stexi-rules*
+ *sdocbook-block-commands*
+ sdocbook-flatten
+ filter-empty-elements
+ replace-titles))
+
+(define (identity . args)
+ args)
+
+(define (identity-deattr tag . body)
+ `(,tag ,@(if (and (pair? body) (pair? (car body))
+ (eq? (caar body) '@))
+ (cdr body)
+ body)))
+
+(define (detag-one tag body)
+ body)
+
+(define tag-replacements
+ '((parameter var)
+ (replaceable var)
+ (type code)
+ (function code)
+ (literal samp)
+ (emphasis emph)
+ (simpara para)
+ (programlisting example)
+ (firstterm dfn)
+ (filename file)
+ (quote cite)
+ (application cite)
+ (symbol code)
+ (note cartouche)
+ (envar env)))
+
+(define ignore-list '())
+
+(define (stringify exp)
+ (with-output-to-string (lambda () (write exp))))
+
+(define *sdocbook->stexi-rules*
+ #;
+ "A stylesheet for use with SSAX's @code{pre-post-order}, which defines
+a number of generic rules for transforming docbook into texinfo."
+ `((@ *preorder* . ,identity)
+ (% *preorder* . ,identity)
+ (para . ,identity-deattr)
+ (orderedlist ((listitem
+ . ,(lambda (tag . body)
+ `(item ,@body))))
+ . ,(lambda (tag . body)
+ `(enumerate ,@body)))
+ (itemizedlist ((listitem
+ . ,(lambda (tag . body)
+ `(item ,@body))))
+ . ,(lambda (tag . body)
+ `(itemize ,@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)))))
+ (*text* . ,detag-one)
+ (*default* . ,(lambda (tag . body)
+ (let ((subst (assq tag tag-replacements)))
+ (cond
+ (subst
+ (if (and (pair? body) (pair? (car body)) (eq? (caar
body) '@))
+ (begin
+ (warn "Ignoring" tag "attributes" (car body))
+ (append (cdr subst) (cdr body)))
+ (append (cdr subst) body)))
+ ((memq tag ignore-list) #f)
+ (else
+ (warn "Don't know how to convert" tag "to stexi")
+ `(c (% (all ,(stringify (cons tag body))))))))))))
+
+;; (variablelist
+;; ((varlistentry
+;; . ,(lambda (tag term . body)
+;; `(entry (% (heading ,@(cdr term))) ,@body)))
+;; (listitem
+;; . ,(lambda (tag simpara)
+;; simpara)))
+;; . ,(lambda (tag attrs . body)
+;; `(table (% (formatter (var))) ,@body)))
+
+(define *sdocbook-block-commands*
+ #;
+ "The set of sdocbook element tags that should not be nested inside
+each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten},
+for more information."
+ '(para programlisting informalexample indexterm variablelist
+ orderedlist refsect1 refsect2 refsect3 refsect4 title example
+ note itemizedlist))
+
+(define (inline-command? command)
+ (not (memq command *sdocbook-block-commands*)))
+
+(define (sdocbook-flatten sdocbook)
+ "\"Flatten\" a fragment of sdocbook so that block elements do not nest
+inside each other.
+
+Docbook is a nested format, where e.g. a @code{refsect2} normally
+appears inside a @code{refsect1}. Logical divisions in the document are
+represented via the tree topology; a @code{refsect2} element
address@hidden all of the elements in its section.
+
+On the contrary, texinfo is a flat format, in which sections are marked
+off by standalone section headers like @code{@@chapter}, and block
+elements do not nest inside each other.
+
+This function takes a nested sdocbook fragment @var{sdocbook} and
+flattens all of the sections, such that e.g.
address@hidden
+ (refsect1 (refsect2 (para \"Hello\")))
address@hidden example
+becomes
address@hidden
+ ((refsect1) (refsect2) (para \"Hello\"))
address@hidden example
+
+Oftentimes (always?) sectioning elements have @code{<title>} as their
+first element child; users interested in processing the @code{refsect*}
+elements into proper sectioning elements like @code{chapter} might be
+interested in @code{replace-titles} and @code{filter-empty-elements}.
address@hidden docbook replace-titles,,replace-titles}, and @ref{texinfo
+docbook filter-empty-elements,,filter-empty-elements}.
+
+Returns a nodeset, as described in @ref{sxml xpath}. That is to say,
+this function returns an untagged list of stexi elements."
+ (define (fhere str accum block cont)
+ (values (cons str accum)
+ block
+ cont))
+ (define (fdown node accum block cont)
+ (let ((command (car node))
+ (attrs (and (pair? (cdr node)) (pair? (cadr node))
+ (eq? (caadr node) '%)
+ (cadr node))))
+ (values (if attrs (cddr node) (cdr node))
+ '()
+ '()
+ (lambda (accum block)
+ (values
+ `(,command ,@(if attrs (list attrs) '())
+ ,@(reverse accum))
+ block)))))
+ (define (fup node paccum pblock pcont kaccum kblock kcont)
+ (call-with-values (lambda () (kcont kaccum kblock))
+ (lambda (ret block)
+ (if (inline-command? (car ret))
+ (values (cons ret paccum) (append kblock pblock) pcont)
+ (values paccum (append kblock (cons ret pblock)) pcont)))))
+ (call-with-values
+ (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
+ (lambda (accum block cont)
+ (reverse block))))
+
+(define (filter-empty-elements sdocbook)
+ "Filters out empty elements in an sdocbook nodeset. Mostly useful
+after running @code{sdocbook-flatten}."
+ (reverse
+ (fold
+ (lambda (x rest)
+ (if (and (pair? x) (null? (cdr x)))
+ rest
+ (cons x rest)))
+ '()
+ sdocbook)))
+
+(define (replace-titles sdocbook-fragment)
+ "Iterate over the sdocbook nodeset @var{sdocbook-fragment},
+transforming contiguous @code{refsect} and @code{title} elements into
+the appropriate texinfo sectioning command. Most useful after having run
address@hidden
+
+For example:
address@hidden
+ (replace-titles '((refsect1) (title \"Foo\") (para \"Bar.\")))
+ @result{} '((chapter \"Foo\") (para \"Bar.\"))
address@hidden example
+"
+ (define sections '((refsect1 . chapter)
+ (refsect2 . section)
+ (refsect3 . subsection)
+ (refsect4 . subsubsection)))
+ (let lp ((in sdocbook-fragment) (out '()))
+ (cond
+ ((null? in)
+ (reverse out))
+ ((and (pair? (car in)) (assq (caar in) sections))
+ ;; pull out the title
+ => (lambda (pair)
+ (lp (cddr in) (cons `(,(cdr pair) ,@(cdadr in)) out))))
+ (else
+ (lp (cdr in) (cons (car in) out))))))
diff --git a/module/texinfo/html.scm b/module/texinfo/html.scm
new file mode 100644
index 0000000..1e37fdc
--- /dev/null
+++ b/module/texinfo/html.scm
@@ -0,0 +1,257 @@
+;;;; (texinfo html) -- translating stexinfo into shtml
+;;;;
+;;;; Copyright (C) 2009, 2010 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;This module implements transformation from @code{stexi} to HTML. Note
+;;that the output of @code{stexi->shtml} is actually SXML with the HTML
+;;vocabulary. This means that the output can be further processed, and
+;;that it must eventually be serialized by
+;;@ref{sxml simple sxml->xml,sxml->xml}.
+;;
+;;References (i.e., the @code{@@ref} family of commands) are resolved by
+;;a @dfn{ref-resolver}.
+;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more
+;;information.
+;;
+;;; Code:
+
+;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove
+;; margin-top on dd > p)
+
+(define-module (texinfo html)
+ :use-module (texinfo)
+ :use-module (sxml transform)
+ :use-module (srfi srfi-13)
+ :export (stexi->shtml add-ref-resolver! urlify))
+
+;; The caller is responsible for carring the returned list.
+(define (arg-ref key %-args)
+ (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x)))))
+(define (arg-req key %-args)
+ (or (arg-ref key %-args)
+ (error "Missing argument:" key %-args)))
+(define (car* x) (and x (car x)))
+
+(define (urlify str)
+ (string-downcase
+ (string-map
+ (lambda (c)
+ (case c
+ ((#\space #\/ #\:) #\-)
+ (else c)))
+ str)))
+
+(define ref-resolvers
+ (list
+ (lambda (node-name manual-name) ;; the default
+ (urlify (string-append (or manual-name "") "#" node-name)))))
+
+(define (add-ref-resolver! proc)
+ "Add @var{proc} to the head of the list of ref-resolvers. @var{proc}
+will be expected to take the name of a node and the name of a manual and
+return the URL of the referent, or @code{#f} to pass control to the next
+ref-resolver in the list.
+
+The default ref-resolver will return the concatenation of the manual
+name, @code{#}, and the node name."
+ (set! ref-resolvers (cons proc ref-resolvers)))
+
+(define (resolve-ref node manual)
+ (or (or-map (lambda (x) (x node manual)) ref-resolvers)
+ (error "Could not resolve reference" node manual)))
+
+(define (ref tag args)
+ (let* ((node (car (arg-req 'node args)))
+ (section (or (car* (arg-ref 'section args)) node))
+ (manual (car* (arg-ref 'manual args)))
+ (target (resolve-ref node manual)))
+ `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr)
+ (a (@ (href ,target)) ,section))))
+
+(define (uref tag args)
+ (let ((url (car (arg-req 'url args))))
+ `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url))))
+
+;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an
+;; empty string here to placate the reptile.
+(define (node tag args)
+ `(a (@ (name ,(urlify (car (arg-req 'name args))))) ""))
+
+(define (def tag args . body)
+ (define (code x) (and x (cons 'code x)))
+ (define (var x) (and x (cons 'var x)))
+ (define (b x) (and x (cons 'b x)))
+ (define (list/spaces . elts)
+ (let lp ((in elts) (out '()))
+ (cond ((null? in) (reverse! out))
+ ((null? (car in)) (lp (cdr in) out))
+ (else (lp (cdr in)
+ (cons (car in)
+ (if (null? out) out (cons " " out))))))))
+ (define (left-td-contents)
+ (list/spaces (code (arg-ref 'data-type args))
+ (b (list (code (arg-ref 'class args)))) ;; is this right?
+ (b (list (code (arg-ref 'name args))))
+ (if (memq tag '(deftypeop deftypefn deftypefun))
+ (code (arg-ref 'arguments args))
+ (var (list (code (arg-ref 'arguments args)))))))
+
+ (let* ((category (case tag
+ ((defun) "Function")
+ ((defspec) "Special Form")
+ ((defvar) "Variable")
+ (else (car (arg-req 'category args))))))
+ `(div
+ (table
+ (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def"))
+ (tr (td ,@(left-td-contents))
+ (td (div (@ (class "right")) "[" ,category "]"))))
+ (div (@ (class "description")) ,@body))))
+
+(define (enumerate tag . elts)
+ (define (tonumber start)
+ (let ((c (string-ref start 0)))
+ (cond ((number? c) (string->number start))
+ (else (1+ (- (char->integer c)
+ (char->integer (if (char-upper-case? c) #\A
#\a))))))))
+ `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))
+ (cons `(@ (start ,@(tonumber (arg-req 'start (car elts)))))
+ ;; (type ,(type (arg-ref 'start (car elts)))))
+ (cdr elts))
+ elts)))
+
+(define (table tag args . body)
+ (let ((formatter (caar (arg-req 'formatter args))))
+ (cons 'dl
+ (map (lambda (x)
+ (cond ((and (pair? x) (eq? (car x) 'dt))
+ (list (car x) (cons formatter (cdr x))))
+ (else x)))
+ (apply append body)))))
+
+(define (entry tag args . body)
+ `((dt ,@(arg-req 'heading args))
+ (dd ,@body)))
+
+(define tag-replacements
+ '((titlepage div (@ (class "titlepage")))
+ (title h2 (@ (class "title")))
+ (subtitle h3 (@ (class "subtitle")))
+ (author h3 (@ (class "author")))
+ (example pre)
+ (lisp pre)
+ (smallexample pre (@ (class "smaller")))
+ (smalllisp pre (@ (class "smaller")))
+ (cartouche div (@ (class "cartouche")))
+ (verbatim pre (@ (class "verbatim")))
+ (chapter h2)
+ (section h3)
+ (subsection h4)
+ (subsubsection h5)
+ (appendix h2)
+ (appendixsec h3)
+ (appendixsubsec h4)
+ (appendixsubsubsec h5)
+ (unnumbered h2)
+ (unnumberedsec h3)
+ (unnumberedsubsec h4)
+ (unnumberedsubsubsec h5)
+ (majorheading h2)
+ (chapheading h2)
+ (heading h3)
+ (subheading h4)
+ (subsubheading h5)
+ (quotation blockquote)
+ (itemize ul)
+ (item li) ;; itemx ?
+ (para p)
+ (*fragment* div) ;; should be ok
+
+ (asis span)
+ (bold b)
+ (sample samp)
+ (samp samp)
+ (code code)
+ (kbd kbd)
+ (key code (@ (class "key")))
+ (var var)
+ (env code (@ (class "env")))
+ (file code (@ (class "file")))
+ (command code (@ (class "command")))
+ (option code (@ (class "option")))
+ (url code (@ (class "url")))
+ (dfn dfn)
+ (cite cite)
+ (acro acronym)
+ (email code (@ (class "email")))
+ (emph em)
+ (strong strong)
+ (sc span (@ (class "small-caps")))))
+
+(define ignore-list
+ '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
+ menu ignore syncodeindex comment c dircategory direntry top shortcontents
+ cindex printindex))
+
+(define rules
+ `((% *preorder* . ,(lambda args args)) ;; Keep these around...
+ (texinfo . ,(lambda (tag args . body)
+ (pre-post-order
+ `(html
+ (@ (xmlns "http://www.w3.org/1999/xhtml";))
+ (head (title ,(car (arg-req 'title args))))
+ (body ,@body))
+ `((% *preorder* . ,(lambda args #f)) ;; ... filter out.
+ (*text* . ,(lambda (tag x) x))
+ (*default* . ,(lambda (tag . body)
+ (cons tag body)))))))
+ (copyright . ,(lambda args '(*ENTITY* "copy")))
+ (result . ,(lambda args '(*ENTITY* "rArr")))
+ (xref . ,ref) (ref . ,ref) (pxref . ,ref)
+ (uref . ,uref)
+ (node . ,node) (anchor . ,node)
+ (table . ,table)
+ (enumerate . ,enumerate)
+ (entry . ,entry)
+
+ (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def)
+ (defop . ,def) (deftypeop . ,def) (defmethod . ,def)
+ (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def)
+ (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def)
+ (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def)
+ (deftypefun . ,def)
+ (ifnottex . ,(lambda (tag . body) body))
+ (*text* . ,(lambda (tag x) x))
+ (*default* . ,(lambda (tag . body)
+ (let ((subst (assq tag tag-replacements)))
+ (cond
+ (subst (append (cdr subst) body))
+ ((memq tag ignore-list) #f)
+ (else
+ (warn "Don't know how to convert" tag "to HTML")
+ body)))))))
+
+(define (stexi->shtml tree)
+ "Transform the stexi @var{tree} into shtml, resolving references via
+ref-resolvers. See the module commentary for more details."
+ (pre-post-order tree rules))
+
+;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6
diff --git a/module/texinfo/indexing.scm b/module/texinfo/indexing.scm
new file mode 100644
index 0000000..d7d10cd
--- /dev/null
+++ b/module/texinfo/indexing.scm
@@ -0,0 +1,75 @@
+;;;; (texinfo indexing) -- indexing stexinfo
+;;;;
+;;;; Copyright (C) 2009, 2010 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;@c texinfo formatting
+;;Given a piece of stexi, return an index of a specified variety.
+;;
+;;Note that currently, @code{stexi-extract-index} doesn't differentiate
+;;between different kinds of index entries. That's a bug ;)
+;;; Code:
+
+(define-module (texinfo indexing)
+ #:use-module (sxml simple)
+ #:use-module (srfi srfi-13)
+ #:export (stexi-extract-index))
+
+(define defines
+ '(deftp defcv defivar deftypeivar defop deftypeop defmethod
+ deftypemethod defopt defvr defvar deftypevr deftypevar deffn
+ deftypefn defspec defmac defun deftypefun))
+
+(define indices
+ '(cindex findex vindex kindex pindex tindex))
+
+(define (stexi-extract-index tree manual-name kind)
+ "Given an stexi tree @var{tree}, index all of the entries of type
address@hidden @var{kind} can be one of the predefined texinfo indices
+(@code{concept}, @code{variable}, @code{function}, @code{key},
address@hidden, @code{type}) or one of the special symbols @code{auto}
+or @code{all}. @code{auto} will scan the stext for a @code{(printindex)}
+statement, and @code{all} will generate an index from all entries,
+regardless of type.
+
+The returned index is a list of pairs, the @sc{car} of which is the
+entry (a string) and the @sc{cdr} of which is a node name (a string)."
+ (let loop ((in tree) (entries '()))
+ (cond
+ ((null? in)
+ entries)
+ ((pair? (car in))
+ (cond
+ ((and (pair? (cdr in)) (pair? (cadr in))
+ (eq? (caar in) 'anchor) (memq (caadr in) defines))
+ (loop (cddr in) (acons (cadr (assq 'name (cdr (cadadr in))))
+ (cadr (assq 'name (cdadar in)))
+ entries)))
+ ((and (pair? (cdr in)) (pair? (cadr in))
+ (eq? (caar in) 'anchor) (memq (caadr in) indices))
+ (loop (cddr in) (acons (sxml->string (cadr in))
+ (cadr (assq 'name (cdadar in)))
+ entries)))
+ (else
+ (loop (cdr in) (loop (car in) entries)))))
+ (else
+ (loop (cdr in) entries)))))
+
+;;; arch-tag: 216d29d3-1ed9-433f-9c19-0dc4d6b439b6
diff --git a/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm
new file mode 100644
index 0000000..93a7c1d
--- /dev/null
+++ b/module/texinfo/plain-text.scm
@@ -0,0 +1,316 @@
+;;;; (texinfo plain-text) -- rendering stexinfo as plain text
+;;;;
+;;;; Copyright (C) 2009, 2010 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;Transformation from stexi to plain-text. Strives to re-create the
+;;output from @code{info}; comes pretty damn close.
+;;
+;;; Code:
+
+(define-module (texinfo plain-text)
+ #:use-module (texinfo)
+ #:use-module (texinfo string-utils)
+ #:use-module (sxml transform)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (stexi->plain-text))
+
+;; The return value is a string.
+(define (arg-ref key %-args)
+ (and=> (and=> (assq key (cdr %-args)) cdr)
+ stexi->plain-text))
+(define (arg-req key %-args)
+ (or (arg-ref key %-args)
+ (error "Missing argument:" key %-args)))
+
+(define *indent* (make-fluid))
+(define *itemizer* (make-fluid))
+
+(define (make-ticker str)
+ (lambda () str))
+(define (make-enumerator n)
+ (lambda ()
+ (let ((last n))
+ (set! n (1+ n))
+ (format #f "~A. " last))))
+
+(fluid-set! *indent* "")
+;; Shouldn't be necessary to do this, but just in case.
+(fluid-set! *itemizer* (make-ticker "* "))
+
+(define-macro (with-indent n . body)
+ `(with-fluids ((*indent* (string-append (fluid-ref *indent*)
+ (make-string ,n #\space))))
+ ,@body))
+
+(define (make-indenter n proc)
+ (lambda args (with-indent n (apply proc args))))
+
+(define (string-indent str)
+ (string-append (fluid-ref *indent*) str "\n"))
+
+(define-macro (with-itemizer itemizer . body)
+ `(with-fluids ((*itemizer* ,itemizer))
+ ,@body))
+
+(define (wrap* . strings)
+ (let ((indent (fluid-ref *indent*)))
+ (fill-string (string-concatenate strings)
+ #:line-width 72 #:initial-indent indent
+ #:subsequent-indent indent)))
+(define (wrap . strings)
+ (string-append (apply wrap* strings) "\n\n"))
+(define (wrap-heading . strings)
+ (string-append (apply wrap* strings) "\n"))
+
+(define (ref tag args)
+ (let* ((node (arg-req 'node args))
+ (name (or (arg-ref 'name args) node))
+ (manual (arg-ref 'manual args)))
+ (string-concatenate
+ (cons*
+ (or (and=> (assq tag '((xref "See ") (pxref "see "))) cadr) "")
+ name
+ (if manual `(" in manual " ,manual) '())))))
+
+(define (uref tag args)
+ (let ((url (arg-req 'url args))
+ (title (arg-ref 'title args)))
+ (if title
+ (string-append title " (" url ")")
+ (string-append "`" url "'"))))
+
+(define (def tag args . body)
+ (define (list/spaces . elts)
+ (let lp ((in elts) (out '()))
+ (cond ((null? in) (reverse! out))
+ ((null? (car in)) (lp (cdr in) out))
+ (else (lp (cdr in)
+ (cons (car in)
+ (if (null? out) out (cons " " out))))))))
+ (define (first-line)
+ (string-join
+ (filter identity
+ (map (lambda (x) (arg-ref x args))
+ '(data-type class name arguments)))
+ " "))
+
+ (let* ((category (case tag
+ ((defun) "Function")
+ ((defspec) "Special Form")
+ ((defvar) "Variable")
+ (else (arg-req 'category args)))))
+ (string-append
+ (wrap-heading (string-append " - " category ": " (first-line)))
+ (with-indent 5 (stexi->plain-text body)))))
+
+(define (enumerate tag . elts)
+ (define (tonumber start)
+ (let ((c (string-ref start 0)))
+ (cond ((number? c) (string->number start))
+ (else (1+ (- (char->integer c)
+ (char->integer (if (char-upper-case? c) #\A
#\a))))))))
+ (let* ((args? (and (pair? elts) (pair? (car elts))
+ (eq? (caar elts) '%)))
+ (start (and args? (arg-ref 'start (car elts)))))
+ (with-itemizer (make-enumerator (if start (tonumber start) 1))
+ (with-indent 5
+ (stexi->plain-text (if start (cdr elts) elts))))))
+
+(define (itemize tag args . elts)
+ (with-itemizer (make-ticker "* ")
+ (with-indent 5
+ (stexi->plain-text elts))))
+
+(define (item tag . elts)
+ (let* ((ret (stexi->plain-text elts))
+ (tick ((fluid-ref *itemizer*)))
+ (tick-pos (- (string-length (fluid-ref *indent*))
+ (string-length tick))))
+ (if (and (not (string-null? ret)) (not (negative? tick-pos)))
+ (string-copy! ret tick-pos tick))
+ ret))
+
+(define (table tag args . body)
+ (stexi->plain-text body))
+
+(define (entry tag args . body)
+ (let ((heading (wrap-heading
+ (stexi->plain-text (arg-req 'heading args)))))
+ (string-append heading
+ (with-indent 5 (stexi->plain-text body)))))
+
+(define (make-underliner char)
+ (lambda (tag . body)
+ (let ((str (stexi->plain-text body)))
+ (string-append
+ "\n"
+ (string-indent str)
+ (string-indent (make-string (string-length str) char))
+ "\n"))))
+
+(define chapter (make-underliner #\*))
+(define section (make-underliner #\=))
+(define subsection (make-underliner #\-))
+(define subsubsection (make-underliner #\.))
+
+(define (example tag . body)
+ (let ((ret (stexi->plain-text body)))
+ (string-append
+ (string-concatenate
+ (with-indent 5 (map string-indent (string-split ret #\newline))))
+ "\n")))
+
+(define (verbatim tag . body)
+ (let ((ret (stexi->plain-text body)))
+ (string-append
+ (string-concatenate
+ (map string-indent (string-split ret #\newline)))
+ "\n")))
+
+(define (fragment tag . body)
+ (string-concatenate (map-in-order stexi->plain-text body)))
+
+(define (para tag . body)
+ (wrap (stexi->plain-text body)))
+
+(define (make-surrounder str)
+ (lambda (tag . body)
+ (string-append str (stexi->plain-text body) str)))
+
+(define (code tag . body)
+ (string-append "`" (stexi->plain-text body) "'"))
+
+(define (key tag . body)
+ (string-append "<" (stexi->plain-text body) ">"))
+
+(define (var tag . body)
+ (string-upcase (stexi->plain-text body)))
+
+(define (passthrough tag . body)
+ (stexi->plain-text body))
+
+(define (texinfo tag args . body)
+ (let ((title (chapter 'foo (arg-req 'title args))))
+ (string-append title (stexi->plain-text body))))
+
+(define ignore-list
+ '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
+ menu ignore syncodeindex comment c % node anchor))
+(define (ignored? tag)
+ (memq tag ignore-list))
+
+(define tag-handlers
+ `((title ,chapter)
+ (chapter ,chapter)
+ (section ,section)
+ (subsection ,subsection)
+ (subsubsection ,subsubsection)
+ (appendix ,chapter)
+ (appendixsec ,section)
+ (appendixsubsec ,subsection)
+ (appendixsubsubsec ,subsubsection)
+ (unnumbered ,chapter)
+ (unnumberedsec ,section)
+ (unnumberedsubsec ,subsection)
+ (unnumberedsubsubsec ,subsubsection)
+ (majorheading ,chapter)
+ (chapheading ,chapter)
+ (heading ,section)
+ (subheading ,subsection)
+ (subsubheading ,subsubsection)
+
+ (strong ,(make-surrounder "*"))
+ (sample ,code)
+ (samp ,code)
+ (code ,code)
+ (kbd ,code)
+ (key ,key)
+ (var ,var)
+ (env ,code)
+ (file ,code)
+ (command ,code)
+ (option ,code)
+ (url ,code)
+ (dfn ,(make-surrounder "\""))
+ (cite ,(make-surrounder "\""))
+ (acro ,passthrough)
+ (email ,key)
+ (emph ,(make-surrounder "_"))
+ (sc ,var)
+ (copyright ,(lambda args "(C)"))
+ (result ,(lambda args "==>"))
+ (xref ,ref)
+ (ref ,ref)
+ (pxref ,ref)
+ (uref ,uref)
+
+ (texinfo ,texinfo)
+ (quotation ,(make-indenter 5 para))
+ (itemize ,itemize)
+ (enumerate ,enumerate)
+ (item ,item)
+ (table ,table)
+ (entry ,entry)
+ (example ,example)
+ (lisp ,example)
+ (smallexample ,example)
+ (smalllisp ,example)
+ (verbatim ,verbatim)
+ (*fragment* ,fragment)
+
+ (deftp ,def)
+ (defcv ,def)
+ (defivar ,def)
+ (deftypeivar ,def)
+ (defop ,def)
+ (deftypeop ,def)
+ (defmethod ,def)
+ (deftypemethod ,def)
+ (defopt ,def)
+ (defvr ,def)
+ (defvar ,def)
+ (deftypevr ,def)
+ (deftypevar ,def)
+ (deffn ,def)
+ (deftypefn ,def)
+ (defmac ,def)
+ (defspec ,def)
+ (defun ,def)
+ (deftypefun ,def)))
+
+(define (stexi->plain-text tree)
+ "Transform @var{tree} into plain text. Returns a string."
+ (cond
+ ((null? tree) "")
+ ((string? tree) tree)
+ ((pair? tree)
+ (cond
+ ((symbol? (car tree))
+ (let ((handler (and (not (ignored? (car tree)))
+ (or (and=> (assq (car tree) tag-handlers) cadr)
+ para))))
+ (if handler (apply handler tree) "")))
+ (else
+ (string-concatenate (map-in-order stexi->plain-text tree)))))
+ (else "")))
+
+;;; arch-tag: f966c3f6-3b46-4790-bbf9-3ad27e4917c2
diff --git a/module/texinfo/reflection.scm b/module/texinfo/reflection.scm
new file mode 100644
index 0000000..1e0d9bd
--- /dev/null
+++ b/module/texinfo/reflection.scm
@@ -0,0 +1,581 @@
+;;;; (texinfo reflection) -- documenting Scheme as stexinfo
+;;;;
+;;;; Copyright (C) 2009, 2010 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;Routines to generare @code{stexi} documentation for objects and
+;;modules.
+;;
+;;Note that in this context, an @dfn{object} is just a value associated
+;;with a location. It has nothing to do with GOOPS.
+;;
+;;; Code:
+
+(define-module (texinfo reflection)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (oop goops)
+ #:use-module (texinfo)
+ #:use-module (texinfo plain-text)
+ #:use-module (srfi srfi-13)
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 documentation)
+ #:use-module (ice-9 optargs)
+ #:use-module (system vm program)
+ #:use-module ((sxml transform) #:select (pre-post-order))
+ #:export (module-stexi-documentation
+ script-stexi-documentation
+ object-stexi-documentation
+ package-stexi-standard-copying
+ package-stexi-standard-titlepage
+ package-stexi-generic-menu
+ package-stexi-standard-menu
+ package-stexi-extended-menu
+ package-stexi-standard-prologue
+ package-stexi-documentation
+ package-stexi-documentation-for-include))
+
+;; List for sorting the definitions in a module
+(define defs
+ '(deftp defcv defivar deftypeivar defop deftypeop defmethod
+ deftypemethod defopt defvr defvar deftypevr deftypevar deffn
+ deftypefn defmac defspec defun deftypefun))
+
+(define (sort-defs ordering a b)
+ (define (def x)
+ ;; a and b are lists of the form ((anchor ...) (def* ...)...)
+ (cadr x))
+ (define (name x)
+ (cadr (assq 'name (cdadr (def x)))))
+ (define (priority x)
+ (list-index defs (car (def x))))
+ (define (order x)
+ (or (list-index ordering (string->symbol (name x)))
+ ;; if the def is not in the list, a big number
+ 1234567890))
+ (define (compare-in-order proc eq? < . args)
+ (if (not (eq? (proc a) (proc b)))
+ (< (proc a) (proc b))
+ (or (null? args)
+ (apply compare-in-order args))))
+ (compare-in-order order = <
+ priority = <
+ name string=? string<=?))
+
+(define (list*-join l infix restfix)
+ (let lp ((in l) (out '()))
+ (cond ((null? in) (reverse! out))
+ ((symbol? in) (reverse! (cons* in restfix out)))
+ (else (lp (cdr in) (if (null? out)
+ (list (car in))
+ (cons* (car in) infix out)))))))
+
+(define (process-args args)
+ (map (lambda (x) (if (symbol? x) (symbol->string x) x))
+ (list*-join (or args '())
+ " " " . ")))
+
+(define (get-proc-args proc)
+ (cond
+ ((procedure-arguments proc)
+ => (lambda (args)
+ (let ((required-args (assq-ref args 'required))
+ (optional-args (assq-ref args 'optional))
+ (keyword-args (assq-ref args 'keyword))
+ (rest-arg (assq-ref args 'rest)))
+ (process-args
+ (append
+ ;; start with the required args...
+ (map symbol->string required-args)
+
+ ;; add any optional args if needed...
+ (map (lambda (a)
+ (if (list? a)
+ (format #f "[~a = ~s]" (car a) (cadr a))
+ (format #f "[~a]" a)))
+ optional-args)
+
+ ;; now the keyword args..
+ (map (lambda (a)
+ (if (pair? a)
+ (format #f "[~a]" (car a))
+ (format #f "[#:~a]" a)))
+ keyword-args)
+
+ ;; now the rest arg...
+ (if rest-arg
+ (list "." (symbol->string rest-arg))
+ '()))))))))
+
+(define (macro-arguments name type transformer)
+ (process-args
+ (case type
+ ((syntax-rules)
+ (let ((patterns (program-property transformer 'patterns)))
+ (if (pair? patterns)
+ (car patterns)
+ '())))
+ ((identifier-syntax)
+ '())
+ ((defmacro)
+ (or (program-property transformer 'defmacro-args)
+ '()))
+ (else
+ ;; a procedural (syntax-case) macro. how to document these?
+ '()))))
+
+(define (macro-additional-stexi name type transformer)
+ (case type
+ ((syntax-rules)
+ (let ((patterns (program-property transformer 'patterns)))
+ (if (pair? patterns)
+ (map (lambda (x)
+ `(defspecx (% (name ,name)
+ (arguments ,@(process-args x)))))
+ (cdr patterns))
+ '())))
+ (else
+ '())))
+
+(define many-space? (make-regexp "[[:space:]][[:space:]][[:space:]]"))
+(define initial-space? (make-regexp "^[[:space:]]"))
+(define (string->stexi str)
+ (or (and (or (not str) (string-null? str))
+ '(*fragment*))
+ (and (or (string-index str #\@)
+ (and (not (regexp-exec many-space? str))
+ (not (regexp-exec initial-space? str))))
+ (false-if-exception
+ (texi-fragment->stexi str)))
+ `(*fragment* (verbatim ,str))))
+
+(define method-formals
+ (and (defined? 'method-formals) method-formals))
+
+(define (method-stexi-arguments method)
+ (cond
+ (method-formals
+ (let lp ((formals (method-formals method))
+ (specializers (method-specializers method))
+ (out '()))
+ (define (arg-texinfo formal specializer)
+ `(" (" (var ,(symbol->string formal)) " "
+ (code ,(symbol->string (class-name specializer))) ")"))
+ (cond
+ ((null? formals) (reverse out))
+ ((pair? formals)
+ (lp (cdr formals) (cdr specializers)
+ (append (reverse (arg-texinfo (car formals) (car specializers)))
+ out)))
+ (else
+ (append (reverse out) (arg-texinfo formals specializers)
+ (list "..."))))))
+ ((method-source method)
+ (let lp ((bindings (cadr (method-source method))) (out '()))
+ (define (arg-texinfo arg)
+ `(" (" (var ,(symbol->string (car arg))) " "
+ (code ,(symbol->string (cadr arg))) ")"))
+ (cond
+ ((null? bindings)
+ (reverse out))
+ ((not (pair? (car bindings)))
+ (append (reverse out) (arg-texinfo bindings) (list "...")))
+ (else
+ (lp (cdr bindings)
+ (append (reverse (arg-texinfo (car bindings))) out))))))
+ (else (warn method) '())))
+
+(define* (object-stexi-documentation object #:optional (name "[unknown]")
+ #:key (force #f))
+ (if (symbol? name)
+ (set! name (symbol->string name)))
+ (let ((stexi ((lambda (x)
+ (cond ((string? x) (string->stexi x))
+ ((and (pair? x) (eq? (car x) '*fragment*)) x)
+ (force `(*fragment*))
+ (else #f)))
+ (object-documentation
+ (if (is-a? object <method>)
+ (method-procedure object)
+ object)))))
+ (define (make-def type args)
+ `(,type (% ,@args) ,@(cdr stexi)))
+ (cond
+ ((not stexi) #f)
+ ;; stexi is now a list, headed by *fragment*.
+ ((and (pair? (cdr stexi)) (pair? (cadr stexi))
+ (memq (caadr stexi) defs))
+ ;; it's already a deffoo.
+ stexi)
+ ((is-a? object <class>)
+ (make-def 'deftp `((name ,name)
+ (category "Class"))))
+ ((is-a? object <macro>)
+ (let* ((proc (macro-transformer object))
+ (type (and proc (program-property proc 'macro-type))))
+ `(defspec (% (name ,name)
+ (arguments ,@(macro-arguments name type proc)))
+ ,@(macro-additional-stexi name type proc)
+ ,@(cdr stexi))))
+
+ ((is-a? object <procedure>)
+ (make-def 'defun `((name ,name)
+ (arguments ,@(get-proc-args object)))))
+ ((is-a? object <method>)
+ (make-def 'deffn `((category "Method")
+ (name ,name)
+ (arguments ,@(method-stexi-arguments object)))))
+ ((is-a? object <generic>)
+ `(*fragment*
+ ,(make-def 'deffn `((name ,name)
+ (category "Generic")))
+ ,@(map
+ (lambda (method)
+ (object-stexi-documentation method name #:force force))
+ (generic-function-methods object))))
+ (else
+ (make-def 'defvar `((name ,name)))))))
+
+(define (module-name->node-name sym-name)
+ (string-join (map symbol->string sym-name) " "))
+
+;; this copied from (ice-9 session); need to find a better way
+(define (module-filename name)
+ (let* ((name (map symbol->string name))
+ (reverse-name (reverse name))
+ (leaf (car reverse-name))
+ (dir-hint-module-name (reverse (cdr reverse-name)))
+ (dir-hint (apply string-append
+ (map (lambda (elt)
+ (string-append elt "/"))
+ dir-hint-module-name))))
+ (%search-load-path (in-vicinity dir-hint leaf))))
+
+(define (read-module name)
+ (let ((filename (module-filename name)))
+ (if filename
+ (let ((port (open-input-file filename)))
+ (let lp ((out '()) (form (read port)))
+ (if (eof-object? form)
+ (reverse out)
+ (lp (cons form out) (read port)))))
+ '())))
+
+(define (module-export-list sym-name)
+ (define (module-form-export-list form)
+ (and (pair? form)
+ (eq? (car form) 'define-module)
+ (equal? (cadr form) sym-name)
+ (and=> (memq #:export (cddr form)) cadr)))
+ (let lp ((forms (read-module sym-name)))
+ (cond ((null? forms) '())
+ ((module-form-export-list (car forms)) => identity)
+ (else (lp (cdr forms))))))
+
+(define* (module-stexi-documentation sym-name
+ #:optional (docs-resolver
+ (lambda (name def) def)))
+ "Return documentation for the module named @var{sym-name}. The
+documentation will be formatted as @code{stexi}
+ (@pxref{texinfo,texinfo})."
+ (let* ((commentary (and=> (module-commentary sym-name)
+ (lambda (x) (string-trim-both x #\newline))))
+ (stexi (string->stexi commentary))
+ (node-name (module-name->node-name sym-name))
+ (name-str (with-output-to-string
+ (lambda () (display sym-name))))
+ (module (resolve-interface sym-name))
+ (export-list (module-export-list sym-name)))
+ (define (anchor-name sym)
+ (string-append node-name " " (symbol->string sym)))
+ (define (make-defs)
+ (sort!
+ (module-map
+ (lambda (sym var)
+ `((anchor (% (name ,(anchor-name sym))))
+ ,@((lambda (x)
+ (if (eq? (car x) '*fragment*)
+ (cdr x)
+ (list x)))
+ (if (variable-bound? var)
+ (docs-resolver
+ sym
+ (object-stexi-documentation (variable-ref var) sym
+ #:force #t))
+ (begin
+ (warn "variable unbound!" sym)
+ `(defvar (% (name ,(symbol->string sym)))
+ "[unbound!]"))))))
+ module)
+ (lambda (a b) (sort-defs export-list a b))))
+
+ `(texinfo (% (title ,name-str))
+ (node (% (name ,node-name)))
+ (section "Overview")
+ ,@(cdr stexi)
+ (section "Usage")
+ ,@(apply append! (make-defs)))))
+
+(define (script-stexi-documentation scriptpath)
+ "Return documentation for given script. The documentation will be
+taken from the script's commentary, and will be returned in the
address@hidden format (@pxref{texinfo,texinfo})."
+ (let ((commentary (file-commentary scriptpath)))
+ `(texinfo (% (title ,(basename scriptpath)))
+ (node (% (name ,(basename scriptpath))))
+ ,@(if commentary
+ (cdr
+ (string->stexi
+ (string-trim-both commentary #\newline)))
+ '()))))
+
+(cond
+ ((defined? 'add-value-help-handler!)
+ (add-value-help-handler!
+ (lambda (name value)
+ (stexi->plain-text
+ (object-stexi-documentation value name #:force #t))))
+ (add-name-help-handler!
+ (lambda (name)
+ (and (list? name)
+ (and-map symbol? name)
+ (stexi->plain-text (module-stexi-documentation name)))))))
+
+;; we could be dealing with an old (ice-9 session); fondle it to get
+;; module-commentary
+(define module-commentary (@@ (ice-9 session) module-commentary))
+
+(define (package-stexi-standard-copying name version updated years
+ copyright-holder permissions)
+ "Create a standard texinfo @code{copying} section.
+
address@hidden is a list of years (as integers) in which the modules
+being documented were released. All other arguments are strings."
+ `(copying
+ (para "This manual is for " ,name
+ " (version " ,version ", updated " ,updated ")")
+ (para "Copyright " ,(string-join (map number->string years) ",")
+ " " ,copyright-holder)
+ (quotation
+ (para ,permissions))))
+
+(define (package-stexi-standard-titlepage name version updated authors)
+ "Create a standard GNU title page.
+
address@hidden is a list of @code{(@var{name} . @var{email})}
+pairs. All other arguments are strings.
+
+Here is an example of the usage of this procedure:
+
address@hidden
+ (package-stexi-standard-titlepage
+ \"Foolib\"
+ \"3.2\"
+ \"26 September 2006\"
+ '((\"Alyssa P Hacker\" . \"alyssa@@example.com\"))
+ '(2004 2005 2006)
+ \"Free Software Foundation, Inc.\"
+ \"Standard GPL permissions blurb goes here\")
address@hidden smallexample
+"
+ `(;(setchapternewpage (% (all "odd"))) makes manuals too long
+ (titlepage
+ (title ,name)
+ (subtitle "version " ,version ", updated " ,updated)
+ ,@(map (lambda (pair)
+ `(author ,(car pair)
+ " (" (email ,(cdr pair)) ")"))
+ authors)
+ (page)
+ (vskip (% (all "0pt plus 1filll")))
+ (insertcopying))))
+
+(define (package-stexi-generic-menu name entries)
+ "Create a menu from a generic alist of entries, the car of which
+should be the node name, and the cdr the description. As an exception,
+an entry of @code{#f} will produce a separator."
+ (define (make-entry node description)
+ `("* " ,node "::"
+ ,(make-string (max (- 21 (string-length node)) 2) #\space)
+ ,@description "\n"))
+ `((ifnottex
+ (node (% (name "Top")))
+ (top (% (title ,name)))
+ (insertcopying)
+ (menu
+ ,@(apply
+ append
+ (map
+ (lambda (entry)
+ (if entry
+ (make-entry (car entry) (cdr entry))
+ '("\n")))
+ entries))))
+ (iftex
+ (shortcontents))))
+
+
+(define (package-stexi-standard-menu name modules module-descriptions
+ extra-entries)
+ "Create a standard top node and menu, suitable for processing
+by makeinfo."
+ (package-stexi-generic-menu
+ name
+ (let ((module-entries (map cons
+ (map module-name->node-name modules)
+ module-descriptions))
+ (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
+ `(,@module-entries
+ ,@(separate-sections extra-entries)))))
+
+(define (package-stexi-extended-menu name module-pairs script-pairs
+ extra-entries)
+ "Create an \"extended\" menu, like the standard menu but with a
+section for scripts."
+ (package-stexi-generic-menu
+ name
+ (let ((module-entries (map cons
+ (map module-name->node-name
+ (map car module-pairs))
+ (map cdr module-pairs)))
+ (script-entries (map cons
+ (map basename (map car script-pairs))
+ (map cdr script-pairs)))
+ (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
+ `(,@module-entries
+ ,@(separate-sections script-entries)
+ ,@(separate-sections extra-entries)))))
+
+(define (package-stexi-standard-prologue name filename category
+ description copying titlepage
+ menu)
+ "Create a standard prologue, suitable for later serialization
+to texinfo and .info creation with makeinfo.
+
+Returns a list of stexinfo forms suitable for passing to
address@hidden as the prologue. @xref{texinfo
+reflection package-stexi-documentation}, @ref{texinfo reflection
+package-stexi-standard-titlepage,package-stexi-standard-titlepage},
address@hidden reflection
+package-stexi-standard-copying,package-stexi-standard-copying},
+and @ref{texinfo reflection
+package-stexi-standard-menu,package-stexi-standard-menu}."
+ `(,copying
+ (dircategory (% (category ,category)))
+ (direntry
+ "* " ,name ": (" ,filename "). " ,description ".")
+ ,@titlepage
+ ,@menu))
+
+(define (stexi->chapter stexi)
+ (pre-post-order
+ stexi
+ `((texinfo . ,(lambda (tag attrs node . body)
+ `(,node
+ (chapter ,@(assq-ref (cdr attrs) 'title))
+ ,@body)))
+ (*text* . ,(lambda (tag text) text))
+ (*default* . ,(lambda args args)))))
+
+(define* (package-stexi-documentation modules name filename
+ prologue epilogue
+ #:key
+ (module-stexi-documentation-args
+ '())
+ (scripts '()))
+ "Create stexi documentation for a @dfn{package}, where a
+package is a set of modules that is released together.
+
address@hidden is expected to be a list of module names, where a
+module name is a list of symbols. The stexi that is returned will
+be titled @var{name} and a texinfo filename of @var{filename}.
+
address@hidden and @var{epilogue} are lists of stexi forms that
+will be spliced into the output document before and after the
+generated modules documentation, respectively.
address@hidden reflection package-stexi-standard-prologue}, to
+create a conventional GNU texinfo prologue.
+
address@hidden is an optional argument that, if
+given, will be added to the argument list when
address@hidden is called. For example, it might be
+useful to define a @code{#:docs-resolver} argument."
+ (define (verify-modules-list l)
+ (define (all pred l)
+ (and (pred (car l))
+ (or (null? (cdr l)) (all pred (cdr l)))))
+ (false-if-exception
+ (all (lambda (x) (all symbol? x)) modules)))
+ (if (not (verify-modules-list modules))
+ (error "expected modules to be a list of a list of symbols"
+ modules))
+
+ `(texinfo
+ (% (title ,name)
+ (filename ,filename))
+ ,@prologue
+ ,@(append-map (lambda (mod)
+ (stexi->chapter
+ (apply module-stexi-documentation
+ mod module-stexi-documentation-args)))
+ modules)
+ ,@(append-map (lambda (script)
+ (stexi->chapter
+ (script-stexi-documentation script)))
+ scripts)
+ ,@epilogue))
+
+(define* (package-stexi-documentation-for-include modules module-descriptions
+ #:key
+
(module-stexi-documentation-args '()))
+ "Create stexi documentation for a @dfn{package}, where a
+package is a set of modules that is released together.
+
address@hidden is expected to be a list of module names, where a
+module name is a list of symbols. Returns an stexinfo fragment.
+
+Unlike @code{package-stexi-documentation}, this function simply produces
+a menu and the module documentations instead of producing a full texinfo
+document. This can be useful if you write part of your manual by hand,
+and just use @code{@@include} to pull in the automatically generated
+parts.
+
address@hidden is an optional argument that, if
+given, will be added to the argument list when
address@hidden is called. For example, it might be
+useful to define a @code{#:docs-resolver} argument."
+ (define (make-entry node description)
+ `("* " ,node "::"
+ ,(make-string (max (- 21 (string-length node)) 2) #\space)
+ ,@description "\n"))
+ `(*fragment*
+ (menu
+ ,@(append-map (lambda (modname desc)
+ (make-entry (module-name->node-name modname)
+ desc))
+ modules
+ module-descriptions))
+ ,@(append-map (lambda (modname)
+ (stexi->chapter
+ (apply module-stexi-documentation
+ modname
+ module-stexi-documentation-args)))
+ modules)))
+
+;;; arch-tag: bbe2bc03-e16d-4a9e-87b9-55225dc9836c
diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm
new file mode 100644
index 0000000..6a32d23
--- /dev/null
+++ b/module/texinfo/serialize.scm
@@ -0,0 +1,263 @@
+;;;; (texinfo serialize) -- rendering stexinfo as texinfo
+;;;;
+;;;; Copyright (C) 2009 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;;
+;;Serialization of @code{stexi} to plain texinfo.
+;;
+;;; Code:
+
+(define-module (texinfo serialize)
+ #:use-module (texinfo)
+ #:use-module (texinfo string-utils)
+ #:use-module (sxml transform)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (stexi->texi))
+
+(define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+;; converts improper lists to proper lists.
+(define (filter* pred l)
+ (let lp ((in l) (out '()))
+ (cond ((null? in)
+ (reverse! out))
+ ((pair? in)
+ (lp (cdr in) (if (pred (car in)) (cons (car in) out) out)))
+ (else
+ (lp '() (if (pred in) (cons in out) out))))))
+
+;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g)
+(define (list* . args)
+ (let* ((args (reverse args))
+ (tail (car args)))
+ (let lp ((in (cdr args)) (out tail))
+ (cond ((null? in) out)
+ ((pair? (car in)) (lp (cdr in) (append (car in) out)))
+ ((null? (car in)) (lp (cdr in) out))
+ (else (lp (cdr in) (cons (car in) out)))))))
+
+;; Why? Well, because syntax-case defines `include', and carps about its
+;; wrong usage below...
+(eval-when (eval load compile)
+ (define (include exp lp command type formals args accum)
+ (list* "\n"
+ (list-intersperse
+ args
+ " ")
+ " " command "@" accum)))
+
+(define (empty-command exp lp command type formals args accum)
+ (list* " " command "@" accum))
+
+(define (inline-text exp lp command type formals args accum)
+ (if (not (string=? command "*braces*")) ;; fixme :(
+ (list* "}"
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "{" command "@" accum)
+ (list* "@}"
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "@{" accum)))
+
+(define (inline-args exp lp command type formals args accum)
+ (list* "}"
+ (if (not args) ""
+ (list-intersperse
+ (map
+ (lambda (x)
+ (cond ((not x) "")
+ ((pair? x)
+ (if (pair? (cdr x))
+ (warn "Strange inline-args!" args))
+ (car x))
+ (else (error "Invalid inline-args" args))))
+ (drop-while not
+ (map (lambda (x) (assq-ref args x))
+ (reverse formals))))
+ ","))
+ "{" command "@" accum))
+
+(define (serialize-text-args lp formals args)
+ (apply
+ append
+ (list-intersperse
+ (map (lambda (arg) (append-map (lambda (x) (lp x '())) arg))
+ (map
+ reverse
+ (drop-while
+ not (map (lambda (x) (assq-ref args x))
+ (reverse formals)))))
+ '(" "))))
+
+(define (eol-text-args exp lp command type formals args accum)
+ (list* "\n"
+ (serialize-text-args lp formals args)
+ " " command "@" accum))
+
+(define (eol-text exp lp command type formals args accum)
+ (list* "\n"
+ (append-map (lambda (x) (lp x '()))
+ (reverse (if args (cddr exp) (cdr exp))))
+ " " command "@" accum))
+
+(define (eol-args exp lp command type formals args accum)
+ (list* "\n"
+ (list-intersperse
+ (apply append
+ (drop-while not
+ (map (lambda (x) (assq-ref args x))
+ (reverse formals))))
+ ", ")
+ " " command "@" accum))
+
+(define (environ exp lp command type formals args accum)
+ (case (car exp)
+ ((texinfo)
+ (list* "@bye\n"
+ (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
+ "address@hidden %**end of header\n\n"
+ (reverse (assq-ref args 'title)) "@settitle "
+ (or (and=> (assq-ref args 'filename)
+ (lambda (filename)
+ (cons "\n" (reverse (cons "@setfilename "
filename)))))
+ "")
+ "\\input texinfo @c address@hidden %**start of header\n"
+ accum))
+ (else
+ (list* "\n\n" command "@end "
+ (let ((body (append-map (lambda (x) (lp x '()))
+ (reverse (if args (cddr exp) (cdr exp))))))
+ (if (or (null? body)
+ (eqv? (string-ref (car body)
+ (1- (string-length (car body))))
+ #\newline))
+ body
+ (cons "\n" body)))
+ "\n"
+ (serialize-text-args lp formals args)
+ " " command "@" accum))))
+
+(define (table-environ exp lp command type formals args accum)
+ (list* "\n\n" command "@end "
+ (append-map (lambda (x) (lp x '()))
+ (reverse (if args (cddr exp) (cdr exp))))
+ "\n"
+ (let* ((arg (if args (cadar args) ""))) ;; zero or one args
+ (if (pair? arg)
+ (list (symbol->string (car arg)) "@")
+ arg))
+ " " command "@" accum))
+
+(define (wrap strings)
+ (fill-string (string-concatenate strings)
+ #:line-width 72))
+
+(define (paragraph exp lp command type formals args accum)
+ (list* "\n\n"
+ (wrap
+ (reverse
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
+ accum))
+
+(define (item exp lp command type formals args accum)
+ (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "@item\n"
+ accum))
+
+(define (entry exp lp command type formals args accum)
+ (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
+ "\n"
+ (append-map (lambda (x) (lp x '())) (reverse (cdar args)))
+ "@item "
+ accum))
+
+(define (fragment exp lp command type formals args accum)
+ (list* "address@hidden %end of fragment\n"
+ (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+ "address@hidden %start of fragment\n\n"
+ accum))
+
+(define serializers
+ `((EMPTY-COMMAND . ,empty-command)
+ (INLINE-TEXT . ,inline-text)
+ (INLINE-ARGS . ,inline-args)
+ (EOL-TEXT . ,eol-text)
+ (EOL-TEXT-ARGS . ,eol-text-args)
+ (INDEX . ,eol-text-args)
+ (EOL-ARGS . ,eol-args)
+ (ENVIRON . ,environ)
+ (TABLE-ENVIRON . ,table-environ)
+ (ENTRY . ,entry)
+ (ITEM . ,item)
+ (PARAGRAPH . ,paragraph)
+ (FRAGMENT . ,fragment)
+ (#f . ,include))) ; support writing include statements
+
+(define (serialize exp lp command type formals args accum)
+ ((or (assq-ref serializers type)
+ (error "Unknown command type" exp type))
+ exp lp command type formals args accum))
+
+(define escaped-chars '(#\} #\{ #\@))
+(define (escape str)
+ "Escapes any illegal texinfo characters (currently @{, @}, and @@)."
+ (let loop ((in (string->list str)) (out '()))
+ (if (null? in)
+ (apply string (reverse out))
+ (if (memq (car in) escaped-chars)
+ (loop (cdr in) (cons* (car in) #\@ out))
+ (loop (cdr in) (cons (car in) out))))))
+
+(define (stexi->texi tree)
+ "Serialize the stexi @var{tree} into plain texinfo."
+ (string-concatenate-reverse
+ (let lp ((in tree) (out '()))
+ (cond
+ ((or (not in) (null? in)) out)
+ ((string? in) (cons (escape in) out))
+ ((pair? in)
+ (let ((command-spec (assq (car in) texi-command-specs)))
+ (if (not command-spec)
+ (begin
+ (warn "Unknown stexi command, not rendering" in)
+ out)
+ (serialize in
+ lp
+ (symbol->string (car in))
+ (cadr command-spec)
+ (filter* symbol? (cddr command-spec))
+ (cond
+ ((and (pair? (cdr in)) (pair? (cadr in))
+ (eq? (caadr in) '%))
+ (cdadr in))
+ ((not (cadr command-spec))
+ ;; include
+ (cdr in))
+ (else
+ #f))
+ out))))
+ (else
+ (error "Invalid stexi" in))))))
+
+;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5
diff --git a/module/texinfo/string-utils.scm b/module/texinfo/string-utils.scm
new file mode 100644
index 0000000..eff9143
--- /dev/null
+++ b/module/texinfo/string-utils.scm
@@ -0,0 +1,400 @@
+;;;; (texinfo string-utils) -- text filling and wrapping
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003 Richard Todd
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+;;; Commentary:
+;; Module @samp{(texinfo string-utils)} provides various string-related
+;; functions useful to Guile's texinfo support.
+;;; Code:
+
+(define-module (texinfo string-utils)
+ #:use-module (srfi srfi-13)
+ #:use-module (srfi srfi-14)
+ #:use-module (oop goops)
+ #:export (escape-special-chars
+ transform-string
+ expand-tabs
+ center-string
+ left-justify-string
+ right-justify-string
+ collapse-repeated-chars
+ make-text-wrapper
+ fill-string
+ string->wrapped-lines))
+
+(define* (transform-string str match? replace #:optional (start #f) (end #f))
+"Uses @var{match?} against each character in @var{str}, and performs a
+replacement on each character for which matches are found.
+
address@hidden may either be a function, a character, a string, or
address@hidden If @var{match?} is a function, then it takes a single
+character as input, and should return @samp{#t} for matches.
address@hidden is a character, it is compared to each string character
+using @code{char=?}. If @var{match?} is a string, then any character
+in that string will be considered a match. @code{#t} will cause
+every character to be a match.
+
+If @var{replace} is a function, it is called with the matched
+character as an argument, and the returned value is sent to the output
+string via @samp{display}. If @var{replace} is anything else, it is
+sent through the output string via @samp{display}.
+
+Note that te replacement for the matched characters does not need to
+be a single character. That is what differentiates this function from
address@hidden, and what makes it useful for applications such as
+converting @samp{#\\&} to @samp{\"&\"} in web page text. Some other
+functions in this module are just wrappers around common uses of
address@hidden Transformations not possible with this
+function should probably be done with regular expressions.
+
+If @var{start} and @var{end} are given, they control which portion
+of the string undergoes transformation. The entire input string
+is still output, though. So, if @var{start} is @samp{5}, then the
+first five characters of @var{str} will still appear in the returned
+string.
+
address@hidden
+; these two are equivalent...
+ (transform-string str #\\space #\\-) ; change all spaces to -'s
+ (transform-string str (lambda (c) (char=? #\\space c)) #\\-)
address@hidden lisp"
+ ;; I had implemented this with string-fold, but it was
+ ;; slower...
+ (let* ((os (open-output-string))
+ (matcher (cond ((char? match?)
+ (lambda (c) (char=? match? c)))
+ ((procedure? match?)
+ match?)
+ ((string? match?)
+ (lambda (c) (string-index match? c)))
+ ((boolean? match?)
+ (lambda (c) match?))
+ (else (throw 'bad-type "expected #t, char, string, or
procedure"))))
+ (replacer (if (procedure? replace)
+ (lambda (c) (display (replace c) os))
+ (lambda (c) (display replace os)))))
+
+ ;; put the first part in, un-transformed if they asked for it...
+ (if (and start (<= start (string-length str)))
+ (display (substring str 0 start) os))
+
+ ;; process the portion they want processed....
+ (string-for-each
+ (lambda (c)
+ (if (matcher c)
+ ;; we have a match! replace the char as directed...
+ (replacer c)
+
+ ;; not a match, just insert the character itself...
+ (write-char c os)))
+ str
+ (or start 0)
+ (or end (string-length str)))
+
+ ;; if there was any at the end, tack it on...
+ (if (and end (< end (string-length str)))
+ (display (substring str end) os))
+
+ (get-output-string os)))
+
+(define* (expand-tabs str #:optional (tab-size 8))
+"Returns a copy of @var{str} with all tabs expanded to spaces. @var{tab-size}
defaults to 8.
+
+Assuming tab size of 8, this is equivalent to: @lisp
+ (transform-string str #\\tab \" \")
address@hidden lisp"
+ (transform-string str
+ #\tab
+ (make-string tab-size #\space)))
+
+(define (escape-special-chars str special-chars escape-char)
+"Returns a copy of @var{str} with all given special characters preceded
+by the given @var{escape-char}.
+
address@hidden can either be a single character, or a string consisting
+of all the special characters.
+
address@hidden
+;; make a string regexp-safe...
+ (escape-special-chars \"***(Example String)***\"
+ \"[]()/*.\"
+ #\\\\)
+=> \"\\\\*\\\\*\\\\*\\\\(Example String\\\\)\\\\*\\\\*\\\\*\"
+
+;; also can escape a singe char...
+ (escape-special-chars \"richardt@@vzavenue.net\"
+ #\\@@
+ #\\@@)
+=> \"richardt@@@@vzavenue.net\"
address@hidden lisp"
+ (transform-string str
+ (if (char? special-chars)
+ ;; if they gave us a char, use char=?
+ (lambda (c) (char=? c special-chars))
+
+ ;; if they gave us a string, see if our character is
in it
+ (lambda (c) (string-index special-chars c)))
+
+ ;; replace matches with the character preceded by the
escape character
+ (lambda (c) (string escape-char c))))
+
+(define* (center-string str #:optional (width 80) (chr #\space) (rchr #f))
+"Returns a copy of @var{str} centered in a field of @var{width}
+characters. Any needed padding is done by character @var{chr}, which
+defaults to @samp{#\\space}. If @var{rchr} is provided, then the
+padding to the right will use it instead. See the examples below.
+left and @var{rchr} on the right. The default @var{width} is 80. The
+default @var{lchr} and @var{rchr} is @samp{#\\space}. The string is
+never truncated.
address@hidden
+ (center-string \"Richard Todd\" 24)
+=> \" Richard Todd \"
+
+ (center-string \" Richard Todd \" 24 #\\=)
+=> \"===== Richard Todd =====\"
+
+ (center-string \" Richard Todd \" 24 #\\< #\\>)
+=> \"<<<<< Richard Todd >>>>>\"
address@hidden lisp"
+ (let* ((len (string-length str))
+ (lpad (make-string (max (quotient (- width len) 2) 0) chr))
+ ;; right-char == char unless it has been provided by the user
+ (right-chr (or rchr chr))
+ (rpad (if (char=? right-chr chr)
+ lpad
+ (make-string (max (quotient (- width len) 2) 0)
right-chr))))
+ (if (>= len width)
+ str
+ (string-append lpad str rpad (if (odd? (- width len)) (string
right-chr) "")))))
+
+(define* (left-justify-string str #:optional (width 80) (chr #\space))
+"@code{left-justify-string str [width chr]}.
+Returns a copy of @var{str} padded with @var{chr} such that it is left
+justified in a field of @var{width} characters. The default
address@hidden is 80. Unlike @samp{string-pad} from srfi-13, the string
+is never truncated."
+ (let* ((len (string-length str))
+ (pad (make-string (max (- width len) 0) chr)))
+ (if (>= len width)
+ str
+ (string-append str pad))))
+
+(define* (right-justify-string str #:optional (width 80) (chr #\space))
+"Returns a copy of @var{str} padded with @var{chr} such that it is
+right justified in a field of @var{width} characters. The default
address@hidden is 80. The default @var{chr} is @samp{#\\space}. Unlike
address@hidden from srfi-13, the string is never truncated."
+ (let* ((len (string-length str))
+ (pad (make-string (max (- width len) 0) chr)))
+ (if (>= len width)
+ str
+ (string-append pad str))))
+
+ (define* (collapse-repeated-chars str #:optional (chr #\space) (num 1))
+"Returns a copy of @var{str} with all repeated instances of
address@hidden collapsed down to at most @var{num} instances.
+The default value for @var{chr} is @samp{#\\space}, and
+the default value for @var{num} is 1.
+
address@hidden
+ (collapse-repeated-chars \"H e l l o\")
+=> \"H e l l o\"
+ (collapse-repeated-chars \"H--e--l--l--o\" #\\-)
+=> \"H-e-l-l-o\"
+ (collapse-repeated-chars \"H-e--l---l----o\" #\\- 2)
+=> \"H-e--l--l--o\"
address@hidden lisp"
+ ;; define repeat-locator as a stateful match? function which remembers
+ ;; the last character it had seen.
+ (let ((repeat-locator
+ ;; initialize prev-chr to something other than what we're seeking...
+ (let ((prev-chr (if (char=? chr #\space) #\A #\space))
+ (match-count 0))
+ (lambda (c)
+ (if (and (char=? c prev-chr)
+ (char=? prev-chr chr))
+ ;; found enough duplicates if the match-count is high enough
+ (begin
+ (set! match-count (+ 1 match-count))
+ (>= match-count num))
+
+ ;; did not find a duplicate
+ (begin (set! match-count 0)
+ (set! prev-chr c)
+ #f))))))
+
+ ;; transform the string with our stateful matcher...
+ ;; deleting matches...
+ (transform-string str repeat-locator "")))
+
+;; split a text string into segments that have the form...
+;; <ws non-ws> <ws non-ws> etc..
+(define (split-by-single-words str)
+ (let ((non-wschars (char-set-complement char-set:whitespace)))
+ (let loop ((ans '())
+ (index 0))
+ (let ((next-non-ws (string-index str non-wschars index)))
+ (if next-non-ws
+ ;; found non-ws...look for ws following...
+ (let ((next-ws (string-index str char-set:whitespace next-non-ws)))
+ (if next-ws
+ ;; found the ws following...
+ (loop (cons (substring str index next-ws) ans)
+ next-ws)
+ ;; did not find ws...must be the end...
+ (reverse (cons (substring str index) ans))))
+ ;; did not find non-ws... only ws at end of the string...
+ (reverse ans))))))
+
+(define* (make-text-wrapper #:key
+ (line-width 80)
+ (expand-tabs? #t)
+ (tab-width 8)
+ (collapse-whitespace? #t)
+ (subsequent-indent "")
+ (initial-indent "")
+ (break-long-words? #t))
+ "Returns a procedure that will split a string into lines according to the
+given parameters.
+
address@hidden @code
address@hidden #:line-width
+This is the target length used when deciding where to wrap lines.
+Default is 80.
+
address@hidden #:expand-tabs?
+Boolean describing whether tabs in the input should be expanded. Default
+is #t.
+
address@hidden #:tab-width
+If tabs are expanded, this will be the number of spaces to which they
+expand. Default is 8.
+
address@hidden #:collapse-whitespace?
+Boolean describing whether the whitespace inside the existing text
+should be removed or not. Default is #t.
+
+If text is already well-formatted, and is just being wrapped to fit in a
+different width, then set this to @samp{#f}. This way, many common text
+conventions (such as two spaces between sentences) can be preserved if
+in the original text. If the input text spacing cannot be trusted, then
+leave this setting at the default, and all repeated whitespace will be
+collapsed down to a single space.
+
address@hidden #:initial-indent
+Defines a string that will be put in front of the first line of wrapped
+text. Default is the empty string, ``''.
+
address@hidden #:subsequent-indent
+Defines a string that will be put in front of all lines of wrapped
+text, except the first one. Default is the empty string, ``''.
+
address@hidden #:break-long-words?
+If a single word is too big to fit on a line, this setting tells the
+wrapper what to do. Defaults to #t, which will break up long words.
+When set to #f, the line will be allowed, even though it is longer
+than the defined @code{#:line-width}.
address@hidden table
+
+The return value is a procedure of one argument, the input string, which
+returns a list of strings, where each element of the list is one line."
+ (lambda (str)
+ ;; replace newlines with spaces
+ (set! str (transform-string str (lambda (c) (char=? c #\nl)) #\space))
+
+ ;; expand tabs if they wanted us to...
+ (if expand-tabs?
+ (set! str (expand-tabs str tab-width)))
+
+ ;; collapse whitespace if they wanted us to...
+ (if collapse-whitespace?
+ (set! str (collapse-repeated-chars str)))
+
+ ;; drop any whitespace from the front...
+ (set! str (string-trim str))
+
+ ;; now start breaking the text into lines...
+ (let loop ((ans '())
+ (words (split-by-single-words str))
+ (line initial-indent)
+ (count 0))
+ (if (null? words)
+ ;; out of words? ...done!
+ (reverse (if (> count 0)
+ (cons line ans)
+ ans))
+
+ ;; not out of words...keep going...
+ (let ((length-left (- line-width
+ (string-length line)))
+ (next-word (if (= count 0)
+ (string-trim (car words))
+ (car words))))
+ (cond
+ ;; does the next entry fit?
+ ((<= (string-length next-word)
+ length-left)
+ (loop ans
+ (cdr words)
+ (string-append line next-word)
+ (+ count 1)))
+
+ ;; ok, it didn't fit...is there already at least one word on the
line?
+ ((> count 0)
+ ;; try to use it for the next line, then...
+ (loop (cons line ans)
+ words
+ subsequent-indent
+ 0))
+
+ ;; ok, it didn't fit...and it's the first word.
+ ;; were we told to break up long words?
+ (break-long-words?
+ ;; break the like at the limit, since the user wants us to...
+ (loop (cons (string-append line (substring next-word 0
length-left))
+ ans)
+ (cons (substring next-word length-left)
+ (cdr words))
+ subsequent-indent
+ 0))
+
+ ;; well, then is it the first word and we *shouldn't* break long
words, then...
+ (else
+ (loop (cons (string-append line next-word)
+ ans)
+ (cdr words)
+ subsequent-indent
+ 0))))))))
+
+(define (string->wrapped-lines str . kwargs)
+ "@code{string->wrapped-lines str keywds ...}. Wraps the text given in
+string @var{str} according to the parameters provided in @var{keywds},
+or the default setting if they are not given. Returns a list of strings
+representing the formatted lines. Valid keyword arguments are discussed
+in @code{make-text-wrapper}."
+ ((apply make-text-wrapper kwargs) str))
+
+(define (fill-string str . kwargs)
+ "Wraps the text given in string @var{str} according to the parameters
+provided in @var{keywds}, or the default setting if they are not
+given. Returns a single string with the wrapped text. Valid keyword
+arguments are discussed in @code{make-text-wrapper}."
+ (string-join (apply string->wrapped-lines str kwargs)
+ "\n"
+ 'infix))
diff --git a/srfi/Makefile.am b/srfi/Makefile.am
index 459d606..bb91268 100644
--- a/srfi/Makefile.am
+++ b/srfi/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free
Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -32,7 +32,8 @@ AM_CPPFLAGS = -I.. -I$(srcdir)/..
\
AM_CFLAGS = $(GCC_CFLAGS)
AM_LDFLAGS = $(GNU_LD_FLAGS)
-srfiincludedir = $(pkgincludedir)/srfi
+# FIXME: should be libguile/srfi
+srfiincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)/srfi
# These headers are visible as <guile/srfi/mumble.h>
srfiinclude_HEADERS = srfi-1.h srfi-4.h srfi-13.h srfi-14.h srfi-60.h
@@ -47,22 +48,22 @@ BUILT_SOURCES = srfi-1.x srfi-4.x srfi-13.x srfi-14.x
srfi-60.x
address@hidden@_la_SOURCES = srfi-1.x srfi-1.c
address@hidden@_la_LIBADD = \
- $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
+ $(top_builddir)/libguile/address@hidden@.la $(top_builddir)/lib/libgnu.la
address@hidden@_la_LDFLAGS = -no-undefined -export-dynamic -version-info
@LIBGUILE_SRFI_SRFI_1_INTERFACE@
address@hidden@_la_SOURCES = srfi-4.x srfi-4.c
address@hidden@_la_LIBADD = \
- $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
+ $(top_builddir)/libguile/address@hidden@.la $(top_builddir)/lib/libgnu.la
address@hidden@_la_LDFLAGS = -no-undefined -export-dynamic -version-info
@LIBGUILE_SRFI_SRFI_4_INTERFACE@
address@hidden@_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c
address@hidden@_la_LIBADD = \
- $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
+ $(top_builddir)/libguile/address@hidden@.la $(top_builddir)/lib/libgnu.la
address@hidden@_la_LDFLAGS = -no-undefined -export-dynamic -version-info
@LIBGUILE_SRFI_SRFI_13_14_INTERFACE@
address@hidden@_la_SOURCES = srfi-60.x srfi-60.c
address@hidden@_la_LIBADD = \
- $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la
+ $(top_builddir)/libguile/address@hidden@.la $(top_builddir)/lib/libgnu.la
address@hidden@_la_LDFLAGS = -no-undefined -export-dynamic -version-info
@LIBGUILE_SRFI_SRFI_60_INTERFACE@
EXTRA_DIST = ChangeLog-2008
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index a0e9803..537c2b3 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -1,6 +1,6 @@
/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
2008, 2009
+ * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
2008, 2009, 2010
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -24,7 +24,6 @@
#endif
#include <libguile.h>
-#include <libguile/lang.h>
#include "srfi-1.h"
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 94bc2e9..be66dea 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Software
Foundation, Inc.
+## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -21,9 +21,11 @@
SUBDIRS = standalone
-SCM_TESTS = tests/alist.test \
+SCM_TESTS = tests/00-initial-env.test \
+ tests/alist.test \
tests/and-let-star.test \
tests/arbiters.test \
+ tests/arrays.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
tests/brainfuck.test \
@@ -31,13 +33,18 @@ SCM_TESTS = tests/alist.test \
tests/c-api.test \
tests/chars.test \
tests/common-list.test \
+ tests/control.test \
tests/continuations.test \
+ tests/curried-definitions.test \
+ tests/ecmascript.test \
tests/elisp.test \
tests/elisp-compiler.test \
tests/elisp-reader.test \
tests/eval.test \
tests/exceptions.test \
tests/filesys.test \
+ tests/fluids.test \
+ tests/foreign.test \
tests/format.test \
tests/fractions.test \
tests/ftw.test \
@@ -55,9 +62,11 @@ SCM_TESTS = tests/alist.test \
tests/load.test \
tests/modules.test \
tests/multilingual.nottest \
+ tests/net-db.test \
tests/numbers.test \
tests/optargs.test \
tests/options.test \
+ tests/print.test \
tests/procprop.test \
tests/poe.test \
tests/popen.test \
@@ -92,16 +101,68 @@ SCM_TESTS = tests/alist.test \
tests/srfi-88.test \
tests/srfi-4.test \
tests/srfi-9.test \
+ tests/statprof.test \
tests/strings.test \
tests/structs.test \
+ tests/sxml.fold.test \
+ tests/sxml.ssax.test \
+ tests/sxml.transform.test \
+ tests/sxml.xpath.test \
tests/symbols.test \
tests/syncase.test \
tests/syntax.test \
+ tests/texinfo.test \
+ tests/texinfo.docbook.test \
+ tests/texinfo.serialize.test \
+ tests/texinfo.string-utils.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
- tests/unif.test \
tests/version.test \
+ tests/vlist.test \
tests/weaks.test
EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) ChangeLog-2008
+
+
+# Test suite of Dominique Boucher's `lalr-scm'.
+# From http://code.google.com/p/lalr-scm/.
+
+LALR_TESTS = \
+ lalr/test-glr-associativity.scm \
+ lalr/test-glr-basics-01.scm \
+ lalr/test-glr-basics-02.scm \
+ lalr/test-glr-basics-03.scm \
+ lalr/test-glr-basics-04.scm \
+ lalr/test-glr-basics-05.scm \
+ lalr/test-glr-script-expression.scm \
+ lalr/test-glr-single-expressions.scm \
+ \
+ lalr/test-lr-associativity-01.scm \
+ lalr/test-lr-basics-01.scm \
+ lalr/test-lr-basics-02.scm \
+ lalr/test-lr-basics-03.scm \
+ lalr/test-lr-basics-04.scm \
+ lalr/test-lr-basics-05.scm \
+ lalr/test-lr-error-recovery-01.scm \
+ lalr/test-lr-error-recovery-02.scm \
+ lalr/test-lr-no-clause.scm \
+ lalr/test-lr-script-expression.scm \
+ lalr/test-lr-single-expressions.scm
+
+# Tests not listed in `run-guile-test.sh' and which should not be run.
+LALR_EXTRA = \
+ lalr/test-lr-associativity-02.scm \
+ lalr/test-lr-associativity-03.scm \
+ lalr/test-lr-associativity-04.scm
+
+# Test framework.
+LALR_EXTRA += \
+ lalr/common-test.scm \
+ lalr/glr-test.scm \
+ lalr/run-guile-test.sh
+
+TESTS = $(LALR_TESTS)
+TESTS_ENVIRONMENT = $(top_builddir)/meta/guile --no-autocompile
+
+EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS)
diff --git a/test-suite/guile-test b/test-suite/guile-test
index 65b0533..0031bbf 100755
--- a/test-suite/guile-test
+++ b/test-suite/guile-test
@@ -5,7 +5,7 @@
;;;; guile-test --- run the Guile test suite
;;;; Jim Blandy <address@hidden> --- May 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2010 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
@@ -205,6 +205,13 @@
;; Open the log file.
(let ((log-port (open-output-file log-file)))
+ ;; Allow for arbitrary Unicode characters in the log file.
+ (set-port-encoding! log-port "UTF-8")
+
+ ;; Don't fail if we can't display a test name to stdout/stderr.
+ (set-port-conversion-strategy! (current-output-port) 'escape)
+ (set-port-conversion-strategy! (current-error-port) 'escape)
+
;; Register some reporters.
(let ((global-pass #t)
(counter (make-count-reporter)))
diff --git a/test-suite/lalr/common-test.scm b/test-suite/lalr/common-test.scm
new file mode 100644
index 0000000..8563029
--- /dev/null
+++ b/test-suite/lalr/common-test.scm
@@ -0,0 +1,63 @@
+;;; common-test.scm --
+;;;
+
+;; Slightly modified for Guile by Ludovic Courtès <address@hidden>, 2010.
+
+(use-modules (system base lalr)
+ (ice-9 pretty-print))
+
+(define *error* '())
+
+(define-syntax when
+ (syntax-rules ()
+ ((_ ?expr ?body ...)
+ (if ?expr
+ (let () ?body ...)
+ #f))))
+
+(define-syntax check
+ (syntax-rules (=>)
+ ((_ ?expr => ?expected-result)
+ (check ?expr (=> equal?) ?expected-result))
+
+ ((_ ?expr (=> ?equal) ?expected-result)
+ (let ((result ?expr)
+ (expected ?expected-result))
+ (set! *error* '())
+ (when (not (?equal result expected))
+ (display "Failed test: \n")
+ (pretty-print (quote ?expr))(newline)
+ (display "\tresult was: ")
+ (pretty-print result)(newline)
+ (display "\texpected: ")
+ (pretty-print expected)(newline)
+ (exit 1))))))
+
+;;; --------------------------------------------------------------------
+
+(define (display-result v)
+ (if v
+ (begin
+ (display "==> ")
+ (display v)
+ (newline))))
+
+(define eoi-token
+ (make-lexical-token '*eoi* #f #f))
+
+(define (make-lexer tokens)
+ (lambda ()
+ (if (null? tokens)
+ eoi-token
+ (let ((t (car tokens)))
+ (set! tokens (cdr tokens))
+ t))))
+
+(define (error-handler message . args)
+ (set! *error* (cons `(error-handler ,message . ,(if (pair? args)
+ (lexical-token-category
(car args))
+ '()))
+ *error*))
+ (cons message args))
+
+;;; end of file
diff --git a/test-suite/lalr/glr-test.scm b/test-suite/lalr/glr-test.scm
new file mode 100644
index 0000000..18b8e86
--- /dev/null
+++ b/test-suite/lalr/glr-test.scm
@@ -0,0 +1,88 @@
+":";exec snow -- "$0" "$@"
+;;;
+;;;; Tests for the GLR parser generator
+;;;
+;;
+;; @created "Fri Aug 19 11:23:48 EDT 2005"
+;;
+
+(package* glr-test/v1.0.0
+ (require: lalr/v2.4.0))
+
+
+(define (syntax-error msg . args)
+ (display msg (current-error-port))
+ (for-each (cut format (current-error-port) " ~A" <>) args)
+ (newline (current-error-port))
+ (throw 'misc-error))
+
+
+(define (make-lexer words)
+ (let ((phrase words))
+ (lambda ()
+ (if (null? phrase)
+ '*eoi*
+ (let ((word (car phrase)))
+ (set! phrase (cdr phrase))
+ word)))))
+
+
+;;;
+;;;; Test 1
+;;;
+
+
+(define parser-1
+ ;; Grammar taken from Tomita's "An Efficient Augmented-Context-Free Parsing
Algorithm"
+ (lalr-parser
+ (driver: glr)
+ (expect: 2)
+ (*n *v *d *p)
+ (<s> (<np> <vp>)
+ (<s> <pp>))
+ (<np> (*n)
+ (*d *n)
+ (<np> <pp>))
+ (<pp> (*p <np>))
+ (<vp> (*v <np>))))
+
+
+(define *phrase-1* '(*n *v *d *n *p *d *n *p *d *n *p *d *n))
+
+(define (test-1)
+ (parser-1 (make-lexer *phrase-1*) syntax-error))
+
+
+;;;
+;;;; Test 2
+;;;
+
+
+(define parser-2
+ ;; The dangling-else problem
+ (lalr-parser
+ (driver: glr)
+ (expect: 1)
+ ((nonassoc: if then else e s))
+ (<s> (s)
+ (if e then <s>)
+ (if e then <s> else <s>))))
+
+
+(define *phrase-2* '(if e then if e then s else s))
+
+(define (test-2)
+ (parser-2 (make-lexer *phrase-2*) syntax-error))
+
+
+
+
+(define (assert-length l n test-name)
+ (display "Test '")
+ (display test-name)
+ (display (if (not (= (length l) n)) "' failed!" "' passed!"))
+ (newline))
+
+(assert-length (test-1) 14 1)
+(assert-length (test-2) 2 2)
+
diff --git a/test-suite/lalr/run-guile-test.sh
b/test-suite/lalr/run-guile-test.sh
new file mode 100644
index 0000000..ab29b83
--- /dev/null
+++ b/test-suite/lalr/run-guile-test.sh
@@ -0,0 +1,30 @@
+# guile-test.sh --
+#
+
+for item in \
+ test-glr-basics-01.scm \
+ test-glr-basics-02.scm \
+ test-glr-basics-03.scm \
+ test-glr-basics-04.scm \
+ test-glr-basics-05.scm \
+ test-glr-associativity.scm \
+ test-glr-script-expression.scm \
+ test-glr-single-expressions.scm \
+ \
+ test-lr-basics-01.scm \
+ test-lr-basics-02.scm \
+ test-lr-basics-03.scm \
+ test-lr-basics-04.scm \
+ test-lr-basics-05.scm \
+ test-lr-error-recovery-01.scm \
+ test-lr-error-recovery-02.scm \
+ test-lr-no-clause.scm \
+ test-lr-associativity-01.scm \
+ test-lr-script-expression.scm \
+ test-lr-single-expressions.scm
+ do
+printf "\n\n*** Running $item\n"
+guile $item
+done
+
+### end of file
diff --git a/test-suite/lalr/test-glr-associativity.scm
b/test-suite/lalr/test-glr-associativity.scm
new file mode 100644
index 0000000..6a5a5e2
--- /dev/null
+++ b/test-suite/lalr/test-glr-associativity.scm
@@ -0,0 +1,102 @@
+;;; test-glr-associativity.scm
+;;
+;;With the GLR parser both the terminal precedence and the non-terminal
+;;associativity are not respected; rather they generate two child
+;;processes.
+;;
+
+(load "common-test.scm")
+
+(define parser
+ (lalr-parser
+ (driver: glr)
+ (expect: 0)
+
+ (N LPAREN RPAREN
+ (left: + -)
+ (right: * /)
+ (nonassoc: uminus))
+
+ (output (expr) : $1)
+ (expr (expr + expr) : (list $1 '+ $3)
+ (expr - expr) : (list $1 '- $3)
+ (expr * expr) : (list $1 '* $3)
+ (expr / expr) : (list $1 '/ $3)
+ (- expr (prec: uminus)) : (list '- $2)
+ (N) : $1
+ (LPAREN expr RPAREN) : $2)))
+
+(define (doit . tokens)
+ (parser (make-lexer tokens) error-handler))
+
+;;; --------------------------------------------------------------------
+
+;;Remember that the result of the GLR driver is a list of parses, not a
+;;single parse.
+
+(check
+ (doit (make-lexical-token 'N #f 1))
+ => '(1))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token '+ #f '+)
+ (make-lexical-token 'N #f 2))
+ => '((1 + 2)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token '* #f '*)
+ (make-lexical-token 'N #f 2))
+ => '((1 * 2)))
+
+(check
+ (doit (make-lexical-token '- #f '-)
+ (make-lexical-token 'N #f 1))
+ => '((- 1)))
+
+(check
+ (doit (make-lexical-token '- #f '-)
+ (make-lexical-token '- #f '-)
+ (make-lexical-token 'N #f 1))
+ => '((- (- 1))))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token '+ #f '+)
+ (make-lexical-token '- #f '-)
+ (make-lexical-token 'N #f 2))
+ => '((1 + (- 2))))
+
+;;; --------------------------------------------------------------------
+
+(check
+ ;;left-associativity
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token '+ #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token '+ #f '+)
+ (make-lexical-token 'N #f 3))
+ => '(((1 + 2) + 3)))
+
+(check
+ ;;right-associativity
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token '* #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token '* #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(((1 * 2) * 3)
+ (1 * (2 * 3))))
+
+(check
+ ;;precedence
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token '+ #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token '* #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(((1 + 2) * 3)
+ (1 + (2 * 3))))
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-basics-01.scm
b/test-suite/lalr/test-glr-basics-01.scm
new file mode 100644
index 0000000..8cac63c
--- /dev/null
+++ b/test-suite/lalr/test-glr-basics-01.scm
@@ -0,0 +1,35 @@
+;;; test-lr-basics-01.scm --
+;;
+;;A grammar that only accept a single terminal as input. It refuses the
+;;end-of-input as first token.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let* ((lexer (make-lexer tokens))
+ (parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (A)
+ (e (A) : $1))))
+ (parser lexer error-handler)))
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => '(1))
+
+(check
+ (doit)
+ => '())
+
+(check
+ ;;Parse correctly the first A and reduce it. The second A triggers
+ ;;an error which empties the stack and consumes all the input
+ ;;tokens. Finally, an unexpected end-of-input error is returned
+ ;;because EOI is invalid as first token after the start.
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '())
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-basics-02.scm
b/test-suite/lalr/test-glr-basics-02.scm
new file mode 100644
index 0000000..a4e24ad
--- /dev/null
+++ b/test-suite/lalr/test-glr-basics-02.scm
@@ -0,0 +1,30 @@
+;;; test-lr-basics-02.scm --
+;;
+;;A grammar that only accept a single terminal or the EOI.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (A)
+ (e (A) : $1
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit)
+ => '(0))
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => '(1))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '())
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-basics-03.scm
b/test-suite/lalr/test-glr-basics-03.scm
new file mode 100644
index 0000000..ec80ed5
--- /dev/null
+++ b/test-suite/lalr/test-glr-basics-03.scm
@@ -0,0 +1,37 @@
+;;; test-lr-basics-03.scm --
+;;
+;;A grammar that accepts fixed sequences of a single terminal or the
+;;EOI.
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (A)
+ (e (A) : (list $1)
+ (A A) : (list $1 $2)
+ (A A A) : (list $1 $2 $3)
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => '((1)))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2))
+ => '((1 2)))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '((1 2 3)))
+
+(check
+ (doit)
+ => '(0))
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-basics-04.scm
b/test-suite/lalr/test-glr-basics-04.scm
new file mode 100644
index 0000000..00d2871
--- /dev/null
+++ b/test-suite/lalr/test-glr-basics-04.scm
@@ -0,0 +1,43 @@
+;;; test-lr-basics-04.scm --
+;;
+;;A grammar accepting a sequence of equal tokens of arbitrary length.
+;;The return value is the value of the last parsed token.
+
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (A)
+ (e (e A) : $2
+ (A) : $1
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit)
+ => '(0))
+
+(check
+ ;;Two results because there is a shift/reduce conflict, so two
+ ;;processes are generated.
+ (doit (make-lexical-token 'A #f 1))
+ => '(1 1))
+
+(check
+ ;;Two results because there is a shift/reduce conflict, so two
+ ;;processes are generated. Notice that the rules:
+ ;;
+ ;; (e A) (A)
+ ;;
+ ;;generate only one conflict when the second "A" comes. The third
+ ;;"A" comes when the state is inside the rule "(e A)", so there is
+ ;;no conflict.
+ ;;
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '(3 3))
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-basics-05.scm
b/test-suite/lalr/test-glr-basics-05.scm
new file mode 100644
index 0000000..ca48fd7
--- /dev/null
+++ b/test-suite/lalr/test-glr-basics-05.scm
@@ -0,0 +1,40 @@
+;;; test-lr-basics-05.scm --
+;;
+;;A grammar accepting a sequence of equal tokens of arbitrary length.
+;;The return value is the list of values.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (A)
+ (e (e A) : (cons $2 $1)
+ (A) : (list $1)
+ () : (list 0)))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit)
+ => '((0)))
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => '((1 0)
+ (1)))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2))
+ => '((2 1 0)
+ (2 1)))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '((3 2 1 0)
+ (3 2 1)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-script-expression.scm
b/test-suite/lalr/test-glr-script-expression.scm
new file mode 100644
index 0000000..5d6d426
--- /dev/null
+++ b/test-suite/lalr/test-glr-script-expression.scm
@@ -0,0 +1,125 @@
+;;; test-lr-script-expression.scm --
+;;
+;;Parse scripts, each line an expression.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (N O C T (left: A) (left: M) (nonassoc: U))
+
+ (script (lines) : (reverse $1))
+
+ (lines (lines line) : (cons $2 $1)
+ (line) : (list $1))
+
+ (line (T) : #\newline
+ (E T) : $1
+ (error T) : (list 'error-clause
$2))
+
+ (E (N) : $1
+ (E A E) : ($2 $1 $3)
+ (E M E) : ($2 $1 $3)
+ (A E (prec: U)) : ($1 $2)
+ (O E C) : $2))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Correct input
+
+(check
+ (doit (make-lexical-token 'T #f #\newline))
+ => '((#\newline)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'T #f #\newline))
+ => '((1)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'T #f #\newline))
+ => '((3)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline))
+ => '((9) (7)))
+
+(check
+ (doit (make-lexical-token 'N #f 10)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline))
+ => '((23)))
+
+(check
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'C #f #\))
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline))
+ => '((9)))
+
+(check
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'C #f #\))
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline)
+
+ (make-lexical-token 'N #f 4)
+ (make-lexical-token 'M #f /)
+ (make-lexical-token 'N #f 5)
+ (make-lexical-token 'T #f #\newline))
+ => '((9 4/5)))
+
+;;; --------------------------------------------------------------------
+
+(check
+ ;;Successful error recovery.
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline)
+
+ (make-lexical-token 'N #f 4)
+ (make-lexical-token 'M #f /)
+ (make-lexical-token 'N #f 5)
+ (make-lexical-token 'T #f #\newline))
+ => '())
+
+(check
+ ;;Unexpected end of input.
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2))
+ => '())
+
+(check
+ ;;Unexpected end of input.
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'T #f #\newline))
+ => '())
+
+;;; end of file
diff --git a/test-suite/lalr/test-glr-single-expressions.scm
b/test-suite/lalr/test-glr-single-expressions.scm
new file mode 100644
index 0000000..9415262
--- /dev/null
+++ b/test-suite/lalr/test-glr-single-expressions.scm
@@ -0,0 +1,60 @@
+;;; test-lr-single-expressions.scm --
+;;
+;;Grammar accepting single expressions.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (driver: glr)
+ (N O C (left: A) (left: M) (nonassoc: U))
+
+ (E (N) : $1
+ (E A E) : ($2 $1 $3)
+ (E M E) : ($2 $1 $3)
+ (A E (prec: U)) : ($1 $2)
+ (O E C) : $2))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+
+(check ;correct input
+ (doit (make-lexical-token 'N #f 1))
+ => '(1))
+
+(check ;correct input
+ (doit (make-lexical-token 'A #f -)
+ (make-lexical-token 'N #f 1))
+ => '(-1))
+
+(check ;correct input
+ (doit (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 1))
+ => '(1))
+
+(check ;correct input
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2))
+ => '(3))
+
+(check ;correct input
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3))
+ => '(9 7))
+
+(check ;correct input
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'C #f #\))
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3))
+ => '(9))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-associativity-01.scm
b/test-suite/lalr/test-lr-associativity-01.scm
new file mode 100644
index 0000000..8519dee
--- /dev/null
+++ b/test-suite/lalr/test-lr-associativity-01.scm
@@ -0,0 +1,91 @@
+;;; test-lr-associativity-01.scm --
+;;
+;;Show how to use left and right associativity. Notice that the
+;;terminal M is declared as right associative; this influences the
+;;binding of values to the $n symbols in the semantic clauses. The
+;;semantic clause in the rule:
+;;
+;; (E M E M E) : (list $1 $2 (list $3 $4 $5))
+;;
+;;looks like it is right-associated, and it is because we have declared
+;;M as "right:".
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser
+ (expect: 0)
+ (N (left: A)
+ (right: M)
+ (nonassoc: U))
+ (E (N) : $1
+ (E A E) : (list $1 $2 $3)
+ (E M E) : (list $1 $2 $3)
+ (E M E M E) : (list $1 $2 (list $3 $4 $5))
+ (A E (prec: U)) : (list '- $2)))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+ (doit (make-lexical-token 'N #f 1))
+ => 1)
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2))
+ => '(1 + 2))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2))
+ => '(1 * 2))
+
+(check
+ (doit (make-lexical-token 'A #f '-)
+ (make-lexical-token 'N #f 1))
+ => '(- 1))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(1 + (2 * 3)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 + 2) + 3))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(1 * (2 * 3)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-associativity-02.scm
b/test-suite/lalr/test-lr-associativity-02.scm
new file mode 100644
index 0000000..6fb62e7
--- /dev/null
+++ b/test-suite/lalr/test-lr-associativity-02.scm
@@ -0,0 +1,91 @@
+;;; test-lr-associativity-02.scm --
+;;
+;;Show how to use left and right associativity. Notice that the
+;;terminal M is declared as left associative; this influences the
+;;binding of values to the $n symbols in the semantic clauses. The
+;;semantic clause in the rule:
+;;
+;; (E M E M E) : (list $1 $2 (list $3 $4 $5))
+;;
+;;looks like it is right-associated, but the result is left-associated
+;;because we have declared M as "left:".
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser
+ (expect: 0)
+ (N (left: A)
+ (left: M)
+ (nonassoc: U))
+ (E (N) : $1
+ (E A E) : (list $1 $2 $3)
+ (E M E) : (list $1 $2 $3)
+ (E M E M E) : (list $1 $2 (list $3 $4 $5))
+ (A E (prec: U)) : (list '- $2)))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+ (doit (make-lexical-token 'N #f 1))
+ => 1)
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2))
+ => '(1 + 2))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2))
+ => '(1 * 2))
+
+(check
+ (doit (make-lexical-token 'A #f '-)
+ (make-lexical-token 'N #f 1))
+ => '(- 1))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(1 + (2 * 3)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 + 2) + 3))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '((1 * 2) * 3))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-associativity-03.scm
b/test-suite/lalr/test-lr-associativity-03.scm
new file mode 100644
index 0000000..4c35b82
--- /dev/null
+++ b/test-suite/lalr/test-lr-associativity-03.scm
@@ -0,0 +1,85 @@
+;;; test-lr-associativity-01.scm --
+;;
+;;Show how to use left and right associativity. Notice that the
+;;terminal M is declared as non-associative; this influences the binding
+;;of values to the $n symbols in the semantic clauses. The semantic
+;;clause in the rule:
+;;
+;; (E M E M E) : (list $1 $2 (list $3 $4 $5))
+;;
+;;looks like it is right-associated, and it is because we have declared
+;;M as "right:".
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser
+ (expect: 0)
+ (N (nonassoc: A)
+ (nonassoc: M))
+ (E (N) : $1
+ (E A E) : (list $1 $2 $3)
+ (E A E A E) : (list (list $1 $2 $3) $4 $5)
+ (E M E) : (list $1 $2 $3)
+ (E M E M E) : (list $1 $2 (list $3 $4 $5))))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+ (doit (make-lexical-token 'N #f 1))
+ => 1)
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2))
+ => '(1 + 2))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2))
+ => '(1 * 2))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(1 + (2 * 3)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 + 2) + 3))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(1 * (2 * 3)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-associativity-04.scm
b/test-suite/lalr/test-lr-associativity-04.scm
new file mode 100644
index 0000000..0aea3f0
--- /dev/null
+++ b/test-suite/lalr/test-lr-associativity-04.scm
@@ -0,0 +1,83 @@
+;;; test-lr-associativity-04.scm --
+;;
+;;Show how to use associativity.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser
+ (expect: 0)
+ (N (left: A)
+ (left: M))
+ (E (N) : $1
+
+ (E A E) : (list $1 $2 $3)
+ (E A E A E) : (list (list $1 $2 $3) $4 $5)
+
+ (E M E) : (list $1 $2 $3)
+ (E M E M E) : (list $1 $2 (list $3 $4 $5))
+
+ (E A E M E) : (list $1 $2 $3 $4 $5)
+ (E M E A E) : (list $1 $2 $3 $4 $5)
+ ))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+ (doit (make-lexical-token 'N #f 1))
+ => 1)
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2))
+ => '(1 + 2))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2))
+ => '(1 * 2))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '(1 + (2 * 3)))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'A #f '+)
+ (make-lexical-token 'N #f 3))
+ => '((1 + 2) + 3))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f '*)
+ (make-lexical-token 'N #f 3))
+ => '((1 * 2) * 3))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-basics-01.scm
b/test-suite/lalr/test-lr-basics-01.scm
new file mode 100644
index 0000000..0176fe6
--- /dev/null
+++ b/test-suite/lalr/test-lr-basics-01.scm
@@ -0,0 +1,38 @@
+;;; test-lr-basics-01.scm --
+;;
+;;A grammar that only accept a single terminal as input. It refuses the
+;;end-of-input as first token.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let* ((lexer (make-lexer tokens))
+ (parser (lalr-parser (expect: 0)
+ (A)
+ (e (A) : $1))))
+ (parser lexer error-handler)))
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => 1)
+
+(check
+ (let ((r (doit)))
+ (cons r *error*))
+ => '(#f (error-handler "Syntax error: unexpected end of input")))
+
+(check
+ ;;Parse correctly the first A and reduce it. The second A triggers
+ ;;an error which empties the stack and consumes all the input
+ ;;tokens. Finally, an unexpected end-of-input error is returned
+ ;;because EOI is invalid as first token after the start.
+ (let ((r (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))))
+ (cons r *error*))
+ => '(#f
+ (error-handler "Syntax error: unexpected end of input")
+ (error-handler "Syntax error: unexpected token : " . A)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-basics-02.scm
b/test-suite/lalr/test-lr-basics-02.scm
new file mode 100644
index 0000000..4a5abc1
--- /dev/null
+++ b/test-suite/lalr/test-lr-basics-02.scm
@@ -0,0 +1,33 @@
+;;; test-lr-basics-02.scm --
+;;
+;;A grammar that only accept a single terminal or the EOI.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (A)
+ (e (A) : $1
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit)
+ => 0)
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => 1)
+
+(check
+ ;;Parse correctly the first A and reduce it. The second A triggers
+ ;;an error which empties the stack and consumes all the input
+ ;;tokens. Finally, the end-of-input token is correctly parsed.
+ (let ((r (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))))
+ (cons r *error*))
+ => '(0 (error-handler "Syntax error: unexpected token : " . A)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-basics-03.scm
b/test-suite/lalr/test-lr-basics-03.scm
new file mode 100644
index 0000000..156de36
--- /dev/null
+++ b/test-suite/lalr/test-lr-basics-03.scm
@@ -0,0 +1,36 @@
+;;; test-lr-basics-03.scm --
+;;
+;;A grammar that accepts fixed sequences of a single terminal or the
+;;EOI.
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (A)
+ (e (A) : (list $1)
+ (A A) : (list $1 $2)
+ (A A A) : (list $1 $2 $3)
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => '(1))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2))
+ => '(1 2))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '(1 2 3))
+
+(check
+ (doit)
+ => 0)
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-basics-04.scm
b/test-suite/lalr/test-lr-basics-04.scm
new file mode 100644
index 0000000..34b8eda
--- /dev/null
+++ b/test-suite/lalr/test-lr-basics-04.scm
@@ -0,0 +1,31 @@
+;;; test-lr-basics-04.scm --
+;;
+;;A grammar accepting a sequence of equal tokens of arbitrary length.
+;;The return value is the value of the last parsed token.
+
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (A)
+ (e (e A) : $2
+ (A) : $1
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit)
+ => 0)
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => 1)
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => 3)
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-basics-05.scm
b/test-suite/lalr/test-lr-basics-05.scm
new file mode 100644
index 0000000..ffb91d4
--- /dev/null
+++ b/test-suite/lalr/test-lr-basics-05.scm
@@ -0,0 +1,36 @@
+;;; test-lr-basics-05.scm --
+;;
+;;A grammar accepting a sequence of equal tokens of arbitrary length.
+;;The return value is the list of values.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (A)
+ (e (e A) : (cons $2 $1)
+ (A) : (list $1)
+ () : 0))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ (doit)
+ => 0)
+
+(check
+ (doit (make-lexical-token 'A #f 1))
+ => '(1))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2))
+ => '(2 1))
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'A #f 2)
+ (make-lexical-token 'A #f 3))
+ => '(3 2 1))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-error-recovery-01.scm
b/test-suite/lalr/test-lr-error-recovery-01.scm
new file mode 100644
index 0000000..7ad756b
--- /dev/null
+++ b/test-suite/lalr/test-lr-error-recovery-01.scm
@@ -0,0 +1,145 @@
+;;; test-lr-error-recovery-01.scm --
+;;
+;;Test error recovery with a terminator terminal.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser
+ (expect: 0)
+ (NUMBER BAD NEWLINE)
+
+ (script (lines) : (reverse $1)
+ () : 0)
+ (lines (lines line) : (cons $2 $1)
+ (line) : (list $1))
+ (line (NEWLINE) : (list 'line $1)
+ (NUMBER NEWLINE) : (list 'line $1 $2)
+ (NUMBER NUMBER NEWLINE) : (list 'line $1 $2 $3)
+
+ ;;This semantic action will cause "(recover $1
+ ;;$2)" to be the result of the offending line.
+ (error NEWLINE) : (list 'recover $1 $2)))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; No errors, grammar tests.
+
+(check
+ (doit)
+ => 0)
+
+(check
+ (doit (make-lexical-token 'NEWLINE #f #\newline))
+ => '((line #\newline)))
+
+(check
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '((line 1 #\newline)))
+
+(check
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '((line 1 2 #\newline)))
+
+(check
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '((line 1 #\newline)
+ (line 2 #\newline)))
+
+(check
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 3)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '((line 1 #\newline)
+ (line 2 #\newline)
+ (line 3 #\newline)))
+
+(check
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 3)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 41)
+ (make-lexical-token 'NUMBER #f 42)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '((line 1 #\newline)
+ (line 2 #\newline)
+ (line 3 #\newline)
+ (line 41 42 #\newline)))
+
+;;; --------------------------------------------------------------------
+;;; Successful error recovery.
+
+(check
+ ;;The BAD triggers an error, recovery happens, the first NEWLINE is
+ ;;correctly parsed as recovery token; the second line is correct.
+ (let ((r (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'BAD #f 'alpha)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline))))
+ (cons r *error*))
+ => '(((recover #f #f)
+ (line 2 #\newline))
+ (error-handler "Syntax error: unexpected token : " . BAD)))
+
+
+(check
+ ;;The first BAD triggers an error, recovery happens skipping the
+ ;;second and third BADs, the first NEWLINE is detected as
+ ;;synchronisation token; the second line is correct.
+ (let ((r (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'BAD #f 'alpha)
+ (make-lexical-token 'BAD #f 'beta)
+ (make-lexical-token 'BAD #f 'delta)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline))))
+ (cons r *error*))
+ => '(((recover #f #f)
+ (line 2 #\newline))
+ (error-handler "Syntax error: unexpected token : " . BAD)))
+
+;;; --------------------------------------------------------------------
+;;; Failed error recovery.
+
+(check
+ ;;End-of-input is found after NUMBER.
+ (let ((r (doit (make-lexical-token 'NUMBER #f 1))))
+ (cons r *error*))
+ => '(#f (error-handler "Syntax error: unexpected end of input")))
+
+(check
+ ;;The BAD triggers the error, the stack is rewind up to the start,
+ ;;then end-of-input happens while trying to skip tokens until the
+ ;;synchronisation one is found. End-of-input is an acceptable token
+ ;;after the start.
+ (let ((r (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'BAD #f 'alpha)
+ (make-lexical-token 'BAD #f 'beta)
+ (make-lexical-token 'BAD #f 'delta))))
+ (cons r *error*))
+ => '(0 (error-handler "Syntax error: unexpected token : " . BAD)))
+
+(check
+ ;;The BAD triggers the error, the stack is rewind up to the start,
+ ;;then end-of-input happens while trying to skip tokens until the
+ ;;synchronisation one is found. End-of-input is an acceptable token
+ ;;after the start.
+ (let ((r (doit (make-lexical-token 'BAD #f 'alpha))))
+ (cons r *error*))
+ => '(0 (error-handler "Syntax error: unexpected token : " . BAD)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-error-recovery-02.scm
b/test-suite/lalr/test-lr-error-recovery-02.scm
new file mode 100644
index 0000000..a82498b
--- /dev/null
+++ b/test-suite/lalr/test-lr-error-recovery-02.scm
@@ -0,0 +1,51 @@
+;;; test-lr-error-recovery-02.scm --
+;;
+;;Test error recovery policy when the synchronisation terminal has the
+;;same category of the lookahead that raises the error.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (A B C)
+ (alphas (alpha) : $1
+ (alphas alpha) : $2)
+ (alpha (A B) : (list $1 $2)
+ (C) : $1
+ (error C) : 'error-form))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; No error, just grammar tests.
+
+(check
+ (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'B #f 2))
+ => '(1 2))
+
+(check
+ (doit (make-lexical-token 'C #f 3))
+ => '3)
+
+;;; --------------------------------------------------------------------
+;;; Successful error recovery.
+
+(check
+ ;;Error, recovery, end-of-input.
+ (let ((r (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'C #f 3))))
+ (cons r *error*))
+ => '(error-form (error-handler "Syntax error: unexpected token : " . C)))
+
+(check
+ ;;Error, recovery, correct parse of "A B".
+ (let ((r (doit (make-lexical-token 'A #f 1)
+ (make-lexical-token 'C #f 3)
+ (make-lexical-token 'A #f 1)
+ (make-lexical-token 'B #f 2))))
+ (cons r *error*))
+ => '((1 2)
+ (error-handler "Syntax error: unexpected token : " . C)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-no-clause.scm
b/test-suite/lalr/test-lr-no-clause.scm
new file mode 100644
index 0000000..fb98da6
--- /dev/null
+++ b/test-suite/lalr/test-lr-no-clause.scm
@@ -0,0 +1,40 @@
+;;; test-lr-no-clause.scm --
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (NUMBER COMMA NEWLINE)
+
+ (lines (lines line) : (list $2)
+ (line) : (list $1))
+ (line (NEWLINE) : #\newline
+ (NUMBER NEWLINE) : $1
+ ;;this is a rule with no semantic action
+ (COMMA NUMBER NEWLINE)))))
+ (parser (make-lexer tokens) error-handler)))
+
+(check
+ ;;correct input
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '(1))
+
+(check
+ ;;correct input with comma, which is a rule with no client form
+ (doit (make-lexical-token 'COMMA #f #\,)
+ (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '(#(line-3 #\, 1 #\newline)))
+
+(check
+ ;;correct input with comma, which is a rule with no client form
+ (doit (make-lexical-token 'NUMBER #f 1)
+ (make-lexical-token 'NEWLINE #f #\newline)
+ (make-lexical-token 'COMMA #f #\,)
+ (make-lexical-token 'NUMBER #f 2)
+ (make-lexical-token 'NEWLINE #f #\newline))
+ => '(#(line-3 #\, 2 #\newline)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-script-expression.scm
b/test-suite/lalr/test-lr-script-expression.scm
new file mode 100644
index 0000000..8cf1a9b
--- /dev/null
+++ b/test-suite/lalr/test-lr-script-expression.scm
@@ -0,0 +1,119 @@
+;;; test-lr-script-expression.scm --
+;;
+;;Parse scripts, each line an expression.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (N O C T (left: A) (left: M) (nonassoc: U))
+
+ (script (lines) : (reverse $1))
+
+ (lines (lines line) : (cons $2 $1)
+ (line) : (list $1))
+
+ (line (T) : #\newline
+ (E T) : $1
+ (error T) : (list 'error-clause
$2))
+
+ (E (N) : $1
+ (E A E) : ($2 $1 $3)
+ (E M E) : ($2 $1 $3)
+ (A E (prec: U)) : ($1 $2)
+ (O E C) : $2))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Correct input
+
+(check
+ (doit (make-lexical-token 'T #f #\newline))
+ => '(#\newline))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'T #f #\newline))
+ => '(1))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'T #f #\newline))
+ => '(3))
+
+(check
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline))
+ => '(7))
+
+(check
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'C #f #\))
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline))
+ => '(9))
+
+(check
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'C #f #\))
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline)
+
+ (make-lexical-token 'N #f 4)
+ (make-lexical-token 'M #f /)
+ (make-lexical-token 'N #f 5)
+ (make-lexical-token 'T #f #\newline))
+ => '(9 4/5))
+
+;;; --------------------------------------------------------------------
+
+(check
+ ;;Successful error recovery.
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3)
+ (make-lexical-token 'T #f #\newline)
+
+ (make-lexical-token 'N #f 4)
+ (make-lexical-token 'M #f /)
+ (make-lexical-token 'N #f 5)
+ (make-lexical-token 'T #f #\newline))
+ => '((error-clause #f)
+ 4/5))
+
+(check
+ ;;Unexpected end of input.
+ (let ((r (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2))))
+ (cons r *error*))
+ => '(#f (error-handler "Syntax error: unexpected end of input")))
+
+(check
+ ;;Unexpected end of input.
+ (let ((r (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'T #f #\newline))))
+ (cons r *error*))
+ => '(((error-clause #f))
+ (error-handler "Syntax error: unexpected token : " . T)))
+
+;;; end of file
diff --git a/test-suite/lalr/test-lr-single-expressions.scm
b/test-suite/lalr/test-lr-single-expressions.scm
new file mode 100644
index 0000000..5fcd9f3
--- /dev/null
+++ b/test-suite/lalr/test-lr-single-expressions.scm
@@ -0,0 +1,59 @@
+;;; test-lr-single-expressions.scm --
+;;
+;;Grammar accepting single expressions.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+ (let ((parser (lalr-parser (expect: 0)
+ (N O C (left: A) (left: M) (nonassoc: U))
+
+ (E (N) : $1
+ (E A E) : ($2 $1 $3)
+ (E M E) : ($2 $1 $3)
+ (A E (prec: U)) : ($1 $2)
+ (O E C) : $2))))
+ (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+
+(check ;correct input
+ (doit (make-lexical-token 'N #f 1))
+ => 1)
+
+(check ;correct input
+ (doit (make-lexical-token 'A #f -)
+ (make-lexical-token 'N #f 1))
+ => -1)
+
+(check ;correct input
+ (doit (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 1))
+ => 1)
+
+(check ;correct input
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2))
+ => 3)
+
+(check ;correct input
+ (doit (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3))
+ => 7)
+
+(check ;correct input
+ (doit (make-lexical-token 'O #f #\()
+ (make-lexical-token 'N #f 1)
+ (make-lexical-token 'A #f +)
+ (make-lexical-token 'N #f 2)
+ (make-lexical-token 'C #f #\))
+ (make-lexical-token 'M #f *)
+ (make-lexical-token 'N #f 3))
+ => 9)
+
+;;; end of file
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index e5b7a08..f32c7c3 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -1,5 +1,5 @@
;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010 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
@@ -19,9 +19,11 @@
(define-module (test-suite lib)
:use-module (ice-9 stack-catch)
:use-module (ice-9 regex)
+ :autoload (srfi srfi-1) (append-map)
:export (
;; Exceptions which are commonly being tested for.
+ exception:syntax-pattern-unmatched
exception:bad-variable
exception:missing-expression
exception:out-of-range exception:unbound-var
@@ -30,9 +32,11 @@
exception:numerical-overflow
exception:struct-set!-denied
exception:system-error
+ exception:encoding-error
exception:miscellaneous-error
exception:string-contains-nul
exception:read-error
+ exception:null-pointer-error
;; Reporting passes and failures.
run-test
@@ -46,8 +50,8 @@
;; Using the debugging evaluator.
with-debugging-evaluator with-debugging-evaluator*
-;; Using a given locale
-with-locale with-locale*
+ ;; Using a given locale
+ with-locale with-locale* with-latin1-locale with-latin1-locale*
;; Reporting results in various ways.
register-reporter unregister-reporter reporter-registered?
@@ -247,6 +251,8 @@ with-locale with-locale*
;;;;
;;; Define some exceptions which are commonly being tested for.
+(define exception:syntax-pattern-unmatched
+ (cons 'syntax-error "source expression failed to match any pattern"))
(define exception:bad-variable
(cons 'syntax-error "Bad variable"))
(define exception:missing-expression
@@ -267,10 +273,14 @@ with-locale with-locale*
(cons 'misc-error "^set! denied for field"))
(define exception:system-error
(cons 'system-error ".*"))
+(define exception:encoding-error
+ (cons 'encoding-error "(cannot convert to output locale|input locale
conversion error)"))
(define exception:miscellaneous-error
(cons 'misc-error "^.*"))
(define exception:read-error
(cons 'read-error "^.*$"))
+(define exception:null-pointer-error
+ (cons 'null-pointer-error "^.*$"))
;; as per throw in scm_to_locale_stringn()
(define exception:string-contains-nul
@@ -389,15 +399,18 @@ with-locale with-locale*
;;;; Turn a test name into a nice human-readable string.
(define (format-test-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) ": ")))))))
+ ;; Choose a Unicode-capable encoding so that the string port can contain any
+ ;; valid Unicode character.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (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) ": "))))))))
;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
@@ -447,19 +460,48 @@ with-locale with-locale*
(lambda ()
(if (defined? 'setlocale)
(begin
- (set! loc
- (false-if-exception (setlocale LC_ALL nloc)))
- (if (not loc)
+ (set! loc (false-if-exception (setlocale LC_ALL)))
+ (if (or (not loc)
+ (not (false-if-exception (setlocale LC_ALL nloc))))
(throw 'unresolved)))
(throw 'unresolved)))
thunk
(lambda ()
- (if (defined? 'setlocale)
+ (if (and (defined? 'setlocale) loc)
(setlocale LC_ALL loc))))))
;;; Evaluate BODY... using the given locale.
-(define-macro (with-locale loc . body)
- `(with-locale* ,loc (lambda () ,@body)))
+(define-syntax with-locale
+ (syntax-rules ()
+ ((_ loc body ...)
+ (with-locale* loc (lambda () body ...)))))
+
+;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
+;;; (if any).
+(define (with-latin1-locale* thunk)
+ (define %locales
+ (append-map (lambda (name)
+ (list (string-append name ".ISO-8859-1")
+ (string-append name ".iso88591")
+ (string-append name ".ISO8859-1")))
+ '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
+ "fr_FR" "pt_PT" "nl_NL" "sv_SE")))
+
+ (let loop ((locales %locales))
+ (if (null? locales)
+ (throw 'unresolved)
+ (catch 'unresolved
+ (lambda ()
+ (with-locale* (car locales) thunk))
+ (lambda (key . args)
+ (loop (cdr locales)))))))
+
+;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
+;;; was found.
+(define-syntax with-latin1-locale
+ (syntax-rules ()
+ ((_ body ...)
+ (with-latin1-locale* (lambda () body ...)))))
;;;; REPORTERS
diff --git a/test-suite/standalone/Makefile.am
b/test-suite/standalone/Makefile.am
index 27fe3c1..806245c 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009 Software Foundation, Inc.
+## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Software
Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -67,13 +67,13 @@ TESTS += test-require-extension
# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
-test_num2integral_LDADD = ${top_builddir}/libguile/libguile.la
+test_num2integral_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-num2integral
TESTS += test-num2integral
# test-round
test_round_CFLAGS = ${test_cflags}
-test_round_LDADD = ${top_builddir}/libguile/libguile.la
+test_round_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-round
TESTS += test-round
@@ -82,36 +82,46 @@ noinst_LTLIBRARIES += libtest-asmobs.la
libtest_asmobs_la_SOURCES = test-asmobs-lib.c test-asmobs-lib.x
libtest_asmobs_la_CFLAGS = ${test_cflags}
libtest_asmobs_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will
really build an .so
-libtest_asmobs_la_LIBADD = ${top_builddir}/libguile/libguile.la
+libtest_asmobs_la_LIBADD = ${top_builddir}/libguile/address@hidden@.la
BUILT_SOURCES += test-asmobs-lib.x
check_SCRIPTS += test-asmobs
TESTS += test-asmobs
+# test-ffi
+noinst_LTLIBRARIES += libtest-ffi.la
+libtest_ffi_la_SOURCES = test-ffi-lib.c test-ffi-lib.x
+libtest_ffi_la_CFLAGS = ${test_cflags}
+libtest_ffi_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really
build an .so
+libtest_ffi_la_LIBADD = ${top_builddir}/libguile/address@hidden@.la
+BUILT_SOURCES += test-ffi-lib.x
+check_SCRIPTS += test-ffi
+TESTS += test-ffi
+
# test-list
test_list_SOURCES = test-list.c
test_list_CFLAGS = ${test_cflags}
-test_list_LDADD = ${top_builddir}/libguile/libguile.la
+test_list_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-list
TESTS += test-list
# test-unwind
test_unwind_SOURCES = test-unwind.c
test_unwind_CFLAGS = ${test_cflags}
-test_unwind_LDADD = ${top_builddir}/libguile/libguile.la
+test_unwind_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-unwind
TESTS += test-unwind
# test-conversion
test_conversion_SOURCES = test-conversion.c
test_conversion_CFLAGS = ${test_cflags}
-test_conversion_LDADD = ${top_builddir}/libguile/libguile.la
+test_conversion_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-conversion
TESTS += test-conversion
# test-loose-ends
test_loose_ends_SOURCES = test-loose-ends.c
test_loose_ends_CFLAGS = ${test_cflags}
-test_loose_ends_LDADD = ${top_builddir}/libguile/libguile.la
+test_loose_ends_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-loose-ends
TESTS += test-loose-ends
@@ -126,21 +136,21 @@ TESTS += test-use-srfi
# test-scm-c-read
test_scm_c_read_SOURCES = test-scm-c-read.c
test_scm_c_read_CFLAGS = ${test_cflags}
-test_scm_c_read_LDADD = ${top_builddir}/libguile/libguile.la
+test_scm_c_read_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-scm-c-read
TESTS += test-scm-c-read
# test-scm-take-locale-symbol
test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c
test_scm_take_locale_symbol_CFLAGS = ${test_cflags}
-test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile.la
+test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-scm-take-locale-symbol
TESTS += test-scm-take-locale-symbol
# test-scm-take-u8vector
test_scm_take_u8vector_SOURCES = test-scm-take-u8vector.c
test_scm_take_u8vector_CFLAGS = ${test_cflags}
-test_scm_take_u8vector_LDADD = ${top_builddir}/libguile/libguile.la
+test_scm_take_u8vector_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-scm-take-u8vector
TESTS += test-scm-take-u8vector
@@ -149,7 +159,7 @@ noinst_LTLIBRARIES += libtest-extensions.la
libtest_extensions_la_SOURCES = test-extensions-lib.c
libtest_extensions_la_CFLAGS = ${test_cflags}
libtest_extensions_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will
really build an .so
-libtest_extensions_la_LIBADD = ${top_builddir}/libguile/libguile.la
+libtest_extensions_la_LIBADD = ${top_builddir}/libguile/address@hidden@.la
check_SCRIPTS += test-extensions
TESTS += test-extensions
@@ -158,12 +168,12 @@ if BUILD_PTHREAD_SUPPORT
# test-with-guile-module
test_with_guile_module_CFLAGS = ${test_cflags}
-test_with_guile_module_LDADD = ${top_builddir}/libguile/libguile.la
+test_with_guile_module_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-with-guile-module
TESTS += test-with-guile-module
test_scm_with_guile_CFLAGS = ${test_cflags}
-test_scm_with_guile_LDADD = ${top_builddir}/libguile/libguile.la
+test_scm_with_guile_LDADD = ${top_builddir}/libguile/address@hidden@.la
check_PROGRAMS += test-scm-with-guile
TESTS += test-scm-with-guile
diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi
new file mode 100755
index 0000000..19c1c15
--- /dev/null
+++ b/test-suite/standalone/test-ffi
@@ -0,0 +1,199 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+(use-modules (system foreign)
+ (rnrs bytevector))
+
+(define lib
+ (dynamic-link (string-append (getenv "builddir") "/libtest-ffi")))
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ exp res)
+ (let ((expected res)
+ (actual exp))
+ (if (not (equal? actual expected))
+ (error "Bad return from expression" 'exp actual expected))))))
+
+;;;
+;;; No args
+;;;
+(define f-v-
+ (make-foreign-function void (dynamic-func "test_ffi_v_" lib) '()))
+(test (f-v-) *unspecified*)
+
+(define f-s8-
+ (make-foreign-function int8 (dynamic-func "test_ffi_s8_" lib) '()))
+(test (f-s8-) -100)
+
+(define f-u8-
+ (make-foreign-function uint8 (dynamic-func "test_ffi_u8_" lib) '()))
+(test (f-u8-) 200)
+
+(define f-s16-
+ (make-foreign-function int16 (dynamic-func "test_ffi_s16_" lib) '()))
+(test (f-s16-) -20000)
+
+(define f-u16-
+ (make-foreign-function uint16 (dynamic-func "test_ffi_u16_" lib) '()))
+(test (f-u16-) 40000)
+
+(define f-s32-
+ (make-foreign-function int32 (dynamic-func "test_ffi_s32_" lib) '()))
+(test (f-s32-) -2000000000)
+
+(define f-u32-
+ (make-foreign-function uint32 (dynamic-func "test_ffi_u32_" lib) '()))
+(test (f-u32-) 4000000000)
+
+(define f-s64-
+ (make-foreign-function int64 (dynamic-func "test_ffi_s64_" lib) '()))
+(test (f-s64-) -2000000000)
+
+(define f-u64-
+ (make-foreign-function uint64 (dynamic-func "test_ffi_u64_" lib) '()))
+(test (f-u64-) 4000000000)
+
+;;;
+;;; One u8 arg
+;;;
+(define f-v-u8
+ (make-foreign-function void (dynamic-func "test_ffi_v_u8" lib) (list uint8)))
+(test (f-v-u8 10) *unspecified*)
+
+(define f-s8-u8
+ (make-foreign-function int8 (dynamic-func "test_ffi_s8_u8" lib) (list
uint8)))
+(test (f-s8-u8 10) -90)
+
+(define f-u8-u8
+ (make-foreign-function uint8 (dynamic-func "test_ffi_u8_u8" lib) (list
uint8)))
+(test (f-u8-u8 10) 210)
+
+(define f-s16-u8
+ (make-foreign-function int16 (dynamic-func "test_ffi_s16_u8" lib) (list
uint8)))
+(test (f-s16-u8 10) -19990)
+
+(define f-u16-u8
+ (make-foreign-function uint16 (dynamic-func "test_ffi_u16_u8" lib) (list
uint8)))
+(test (f-u16-u8 10) 40010)
+
+(define f-s32-u8
+ (make-foreign-function int32 (dynamic-func "test_ffi_s32_u8" lib) (list
uint8)))
+(test (f-s32-u8 10) -1999999990)
+
+(define f-u32-u8
+ (make-foreign-function uint32 (dynamic-func "test_ffi_u32_u8" lib) (list
uint8)))
+(test (f-u32-u8 10) 4000000010)
+
+(define f-s64-u8
+ (make-foreign-function int64 (dynamic-func "test_ffi_s64_u8" lib) (list
uint8)))
+(test (f-s64-u8 10) -1999999990)
+
+(define f-u64-u8
+ (make-foreign-function uint64 (dynamic-func "test_ffi_u64_u8" lib) (list
uint8)))
+(test (f-u64-u8 10) 4000000010)
+
+
+;;;
+;;; One s64 arg
+;;;
+(define f-v-s64
+ (make-foreign-function void (dynamic-func "test_ffi_v_s64" lib) (list
int64)))
+(test (f-v-s64 10) *unspecified*)
+
+(define f-s8-s64
+ (make-foreign-function int8 (dynamic-func "test_ffi_s8_s64" lib) (list
int64)))
+(test (f-s8-s64 10) -90)
+
+(define f-u8-s64
+ (make-foreign-function uint8 (dynamic-func "test_ffi_u8_s64" lib) (list
int64)))
+(test (f-u8-s64 10) 210)
+
+(define f-s16-s64
+ (make-foreign-function int16 (dynamic-func "test_ffi_s16_s64" lib) (list
int64)))
+(test (f-s16-s64 10) -19990)
+
+(define f-u16-s64
+ (make-foreign-function uint16 (dynamic-func "test_ffi_u16_s64" lib) (list
int64)))
+(test (f-u16-s64 10) 40010)
+
+(define f-s32-s64
+ (make-foreign-function int32 (dynamic-func "test_ffi_s32_s64" lib) (list
int64)))
+(test (f-s32-s64 10) -1999999990)
+
+(define f-u32-s64
+ (make-foreign-function uint32 (dynamic-func "test_ffi_u32_s64" lib) (list
int64)))
+(test (f-u32-s64 10) 4000000010)
+
+(define f-s64-s64
+ (make-foreign-function int64 (dynamic-func "test_ffi_s64_s64" lib) (list
int64)))
+(test (f-s64-s64 10) -1999999990)
+
+(define f-u64-s64
+ (make-foreign-function uint64 (dynamic-func "test_ffi_u64_s64" lib) (list
int64)))
+(test (f-u64-s64 10) 4000000010)
+
+
+;;
+;; Multiple int args of differing types
+;;
+(define f-sum
+ (make-foreign-function int64 (dynamic-func "test_ffi_sum" lib)
+ (list int8 int16 int32 int64)))
+(test (f-sum -1 2000 -30000 40000000000)
+ (+ -1 2000 -30000 40000000000))
+
+;;
+;; Structs
+;;
+(define f-sum-struct
+ (make-foreign-function int64 (dynamic-func "test_ffi_sum_struct" lib)
+ (list (list int8 int16 int32 int64))))
+(test (f-sum-struct (make-c-struct (list int8 int16 int32 int64)
+ (list -1 2000 -30000 40000000000)))
+ (+ -1 2000 -30000 40000000000))
+;;
+;; Structs
+;;
+(define f-memcpy
+ (make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
+ (list '* '* int32)))
+(let* ((src (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7))))
+ (dest (bytevector->foreign (make-bytevector 16 0)))
+ (res (f-memcpy dest src (bytevector-length (foreign->bytevector src)))))
+ (or (= (foreign-ref dest) (foreign-ref res))
+ (error "memcpy res not equal to dest"))
+ (or (equal? (bytevector->u8-list (foreign->bytevector dest))
+ '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
+ (error "unexpected dest")))
+
+
+;;;
+;;; Global symbols.
+;;;
+
+(use-modules ((rnrs bytevector) #:select (utf8->string)))
+
+(if (defined? 'setlocale)
+ (setlocale LC_ALL "C"))
+
+(define global (dynamic-link))
+
+(define strerror
+ (make-foreign-function '* (dynamic-func "strerror" global)
+ (list int)))
+
+(define strlen
+ (make-foreign-function size_t (dynamic-func "strlen" global)
+ (list '*)))
+
+(let* ((ptr (strerror ENOENT))
+ (len (strlen ptr))
+ (bv (foreign->bytevector ptr 'u8 0 len))
+ (str (utf8->string bv)))
+ (test #t (not (not (string-contains str "file")))))
+
+;; Local Variables:
+;; mode: scheme
+;; End:
\ No newline at end of file
diff --git a/test-suite/standalone/test-ffi-lib.c
b/test-suite/standalone/test-ffi-lib.c
new file mode 100644
index 0000000..8dec3d3
--- /dev/null
+++ b/test-suite/standalone/test-ffi-lib.c
@@ -0,0 +1,215 @@
+/* Copyright (C) 2010 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
+ */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+void test_ffi_v_ (void);
+void test_ffi_v_ (void)
+{
+ return;
+}
+
+void test_ffi_v_u8 (scm_t_uint8 a);
+void test_ffi_v_u8 (scm_t_uint8 a)
+{
+ return;
+}
+
+void test_ffi_v_s64 (scm_t_int64 a);
+void test_ffi_v_s64 (scm_t_int64 a)
+{
+ return;
+}
+
+scm_t_int8 test_ffi_s8_ (void);
+scm_t_int8 test_ffi_s8_ (void)
+{
+ return -100;
+}
+scm_t_int8 test_ffi_s8_u8 (scm_t_uint8 a);
+scm_t_int8 test_ffi_s8_u8 (scm_t_uint8 a)
+{
+ return -100 + a;
+}
+
+scm_t_int8 test_ffi_s8_s64 (scm_t_int64 a);
+scm_t_int8 test_ffi_s8_s64 (scm_t_int64 a)
+{
+ return -100 + a;
+}
+
+scm_t_uint8 test_ffi_u8_ (void);
+scm_t_uint8 test_ffi_u8_ (void)
+{
+ return 200;
+}
+
+scm_t_uint8 test_ffi_u8_u8 (scm_t_uint8 a);
+scm_t_uint8 test_ffi_u8_u8 (scm_t_uint8 a)
+{
+ return 200 + a;
+}
+
+scm_t_uint8 test_ffi_u8_s64 (scm_t_int64 a);
+scm_t_uint8 test_ffi_u8_s64 (scm_t_int64 a)
+{
+ return 200 + a;
+}
+
+scm_t_int16 test_ffi_s16_ (void);
+scm_t_int16 test_ffi_s16_ (void)
+{
+ return -20000;
+}
+
+scm_t_int16 test_ffi_s16_u8 (scm_t_uint8 a);
+scm_t_int16 test_ffi_s16_u8 (scm_t_uint8 a)
+{
+ return -20000 + a;
+}
+
+scm_t_int16 test_ffi_s16_s64 (scm_t_int64 a);
+scm_t_int16 test_ffi_s16_s64 (scm_t_int64 a)
+{
+ return -20000 + a;
+}
+
+scm_t_uint16 test_ffi_u16_ (void);
+scm_t_uint16 test_ffi_u16_ (void)
+{
+ return 40000;
+}
+
+scm_t_uint16 test_ffi_u16_u8 (scm_t_uint8 a);
+scm_t_uint16 test_ffi_u16_u8 (scm_t_uint8 a)
+{
+ return 40000 + a;
+}
+
+scm_t_uint16 test_ffi_u16_s64 (scm_t_int64 a);
+scm_t_uint16 test_ffi_u16_s64 (scm_t_int64 a)
+{
+ return 40000 + a;
+}
+
+scm_t_int32 test_ffi_s32_ (void);
+scm_t_int32 test_ffi_s32_ (void)
+{
+ return -2000000000;
+}
+
+scm_t_int32 test_ffi_s32_u8 (scm_t_uint8 a);
+scm_t_int32 test_ffi_s32_u8 (scm_t_uint8 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_int32 test_ffi_s32_s64 (scm_t_int64 a);
+scm_t_int32 test_ffi_s32_s64 (scm_t_int64 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_uint32 test_ffi_u32_ (void);
+scm_t_uint32 test_ffi_u32_ (void)
+{
+ return 4000000000;
+}
+
+scm_t_uint32 test_ffi_u32_u8 (scm_t_uint8 a);
+scm_t_uint32 test_ffi_u32_u8 (scm_t_uint8 a)
+{
+ return 4000000000 + a;
+}
+
+scm_t_uint32 test_ffi_u32_s64 (scm_t_int64 a);
+scm_t_uint32 test_ffi_u32_s64 (scm_t_int64 a)
+{
+ return 4000000000 + a;
+}
+
+/* FIXME: use 64-bit literals */
+scm_t_int64 test_ffi_s64_ (void);
+scm_t_int64 test_ffi_s64_ (void)
+{
+ return -2000000000;
+}
+
+scm_t_int64 test_ffi_s64_u8 (scm_t_uint8 a);
+scm_t_int64 test_ffi_s64_u8 (scm_t_uint8 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_int64 test_ffi_s64_s64 (scm_t_int64 a);
+scm_t_int64 test_ffi_s64_s64 (scm_t_int64 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_uint64 test_ffi_u64_ (void);
+scm_t_uint64 test_ffi_u64_ (void)
+{
+ return 4000000000;
+}
+
+scm_t_uint64 test_ffi_u64_u8 (scm_t_uint8 a);
+scm_t_uint64 test_ffi_u64_u8 (scm_t_uint8 a)
+{
+ return 4000000000 + a;
+}
+
+scm_t_uint64 test_ffi_u64_s64 (scm_t_int64 a);
+scm_t_uint64 test_ffi_u64_s64 (scm_t_int64 a)
+{
+ return 4000000000 + a;
+}
+
+
+scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
+ scm_t_int32 c, scm_t_int64 d);
+scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
+ scm_t_int32 c, scm_t_int64 d)
+{
+ return d + c + b + a;
+}
+
+
+struct foo
+{
+ scm_t_int8 a;
+ scm_t_int16 b;
+ scm_t_int32 c;
+ scm_t_int64 d;
+};
+scm_t_int64 test_ffi_sum_struct (struct foo foo);
+scm_t_int64 test_ffi_sum_struct (struct foo foo)
+{
+ return foo.d + foo.c + foo.b + foo.a;
+}
+
+
+void* test_ffi_memcpy (void *dest, void *src, scm_t_int32 n);
+void* test_ffi_memcpy (void *dest, void *src, scm_t_int32 n)
+{
+ return memcpy (dest, src, n);
+}
diff --git a/test-suite/standalone/test-unwind.c
b/test-suite/standalone/test-unwind.c
index f9820cc..2d6894d 100644
--- a/test-suite/standalone/test-unwind.c
+++ b/test-suite/standalone/test-unwind.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2004, 2005, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2004, 2005, 2008, 2009, 2010 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
@@ -137,12 +137,10 @@ SCM
check_cont_body (void *data)
{
scm_t_dynwind_flags flags = (data? SCM_F_DYNWIND_REWINDABLE : 0);
- int first;
SCM val;
scm_dynwind_begin (flags);
-
- val = scm_make_continuation (&first);
+ val = scm_c_eval_string ("(call/cc (lambda (k) k))");
scm_dynwind_end ();
return val;
}
@@ -210,7 +208,9 @@ check_ports ()
strcpy (filename, tmpdir);
strcat (filename, FILENAME_TEMPLATE);
- if (mktemp (filename) == NULL)
+ /* Sanity check: Make sure that `filename' is actually writeable.
+ We used to use mktemp(3), but that is now considered a security risk. */
+ if (0 > mkstemp (filename))
exit (1);
scm_dynwind_begin (0);
diff --git a/test-suite/tests/00-initial-env.test
b/test-suite/tests/00-initial-env.test
new file mode 100644
index 0000000..3b3fe3a
--- /dev/null
+++ b/test-suite/tests/00-initial-env.test
@@ -0,0 +1,48 @@
+;;;; 00-initial-env.test --- Roots. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010 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 (the-initial-env)
+ #:use-module (test-suite lib))
+
+;;; A set of tests to run early. The file name is to have `check-guile' pick
+;;; this test file first.
+
+
+;;;
+;;; Tests to be run when GOOPS is not loaded.
+;;;
+
+(with-test-prefix "goopsless"
+
+ (with-test-prefix "+ wrong type argument"
+
+ ;; The following tests assume that `+' hasn't been turned into a generic
+ ;; and extended. Since the ECMAScript run-time library does exactly
+ ;; that, they must be run before `ecmascript.test'.
+
+ (pass-if-exception "1st argument string"
+ exception:wrong-type-arg
+ (+ "1" 2))
+
+ (pass-if-exception "2nd argument bool"
+ exception:wrong-type-arg
+ (+ 1 #f))
+
+ (pass-if-exception "implicit forcing is not supported"
+ exception:wrong-type-arg
+ (+ (delay (* 3 7)) 13))))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
new file mode 100644
index 0000000..b762f20
--- /dev/null
+++ b/test-suite/tests/arrays.test
@@ -0,0 +1,608 @@
+;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
+;;;;
+;;;; Copyright 2004, 2006, 2009, 2010 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 test-arrays)
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu))
+
+;;;
+;;; array?
+;;;
+
+(define exception:wrong-num-indices
+ (cons 'misc-error "^wrong number of indices.*"))
+
+(define exception:length-non-negative
+ (cons 'read-error ".*array length must be non-negative.*"))
+
+
+(with-test-prefix "sanity"
+ ;; At the current time of writing, bignums have a tc7 that is one bit
+ ;; away from strings. It used to be that the vector implementation
+ ;; registered for strings had the TYP7S mask, not the TYP7 mask,
+ ;; making the system think that bignums were vectors. Doh!
+ (pass-if (not (uniform-vector? 12345678901234567890123456789))))
+
+(with-test-prefix "array?"
+
+ (let ((bool (make-typed-array 'b #t '(5 6)))
+ (char (make-typed-array 'a #\a '(5 6)))
+ (byte (make-typed-array 'u8 0 '(5 6)))
+ (short (make-typed-array 's16 0 '(5 6)))
+ (ulong (make-typed-array 'u32 0 '(5 6)))
+ (long (make-typed-array 's32 0 '(5 6)))
+ (longlong (make-typed-array 's64 0 '(5 6)))
+ (float (make-typed-array 'f32 0 '(5 6)))
+ (double (make-typed-array 'f64 0 '(5 6)))
+ (complex (make-typed-array 'c64 0 '(5 6)))
+ (scm (make-typed-array #t 0 '(5 6))))
+
+ (with-test-prefix "is bool"
+ (pass-if (eq? #t (typed-array? bool 'b)))
+ (pass-if (eq? #f (typed-array? char 'b)))
+ (pass-if (eq? #f (typed-array? byte 'b)))
+ (pass-if (eq? #f (typed-array? short 'b)))
+ (pass-if (eq? #f (typed-array? ulong 'b)))
+ (pass-if (eq? #f (typed-array? long 'b)))
+ (pass-if (eq? #f (typed-array? longlong 'b)))
+ (pass-if (eq? #f (typed-array? float 'b)))
+ (pass-if (eq? #f (typed-array? double 'b)))
+ (pass-if (eq? #f (typed-array? complex 'b)))
+ (pass-if (eq? #f (typed-array? scm 'b))))
+
+ (with-test-prefix "is char"
+ (pass-if (eq? #f (typed-array? bool 'a)))
+ (pass-if (eq? #t (typed-array? char 'a)))
+ (pass-if (eq? #f (typed-array? byte 'a)))
+ (pass-if (eq? #f (typed-array? short 'a)))
+ (pass-if (eq? #f (typed-array? ulong 'a)))
+ (pass-if (eq? #f (typed-array? long 'a)))
+ (pass-if (eq? #f (typed-array? longlong 'a)))
+ (pass-if (eq? #f (typed-array? float 'a)))
+ (pass-if (eq? #f (typed-array? double 'a)))
+ (pass-if (eq? #f (typed-array? complex 'a)))
+ (pass-if (eq? #f (typed-array? scm 'a))))
+
+ (with-test-prefix "is byte"
+ (pass-if (eq? #f (typed-array? bool 'u8)))
+ (pass-if (eq? #f (typed-array? char 'u8)))
+ (pass-if (eq? #t (typed-array? byte 'u8)))
+ (pass-if (eq? #f (typed-array? short 'u8)))
+ (pass-if (eq? #f (typed-array? ulong 'u8)))
+ (pass-if (eq? #f (typed-array? long 'u8)))
+ (pass-if (eq? #f (typed-array? longlong 'u8)))
+ (pass-if (eq? #f (typed-array? float 'u8)))
+ (pass-if (eq? #f (typed-array? double 'u8)))
+ (pass-if (eq? #f (typed-array? complex 'u8)))
+ (pass-if (eq? #f (typed-array? scm 'u8))))
+
+ (with-test-prefix "is short"
+ (pass-if (eq? #f (typed-array? bool 's16)))
+ (pass-if (eq? #f (typed-array? char 's16)))
+ (pass-if (eq? #f (typed-array? byte 's16)))
+ (pass-if (eq? #t (typed-array? short 's16)))
+ (pass-if (eq? #f (typed-array? ulong 's16)))
+ (pass-if (eq? #f (typed-array? long 's16)))
+ (pass-if (eq? #f (typed-array? longlong 's16)))
+ (pass-if (eq? #f (typed-array? float 's16)))
+ (pass-if (eq? #f (typed-array? double 's16)))
+ (pass-if (eq? #f (typed-array? complex 's16)))
+ (pass-if (eq? #f (typed-array? scm 's16))))
+
+ (with-test-prefix "is ulong"
+ (pass-if (eq? #f (typed-array? bool 'u32)))
+ (pass-if (eq? #f (typed-array? char 'u32)))
+ (pass-if (eq? #f (typed-array? byte 'u32)))
+ (pass-if (eq? #f (typed-array? short 'u32)))
+ (pass-if (eq? #t (typed-array? ulong 'u32)))
+ (pass-if (eq? #f (typed-array? long 'u32)))
+ (pass-if (eq? #f (typed-array? longlong 'u32)))
+ (pass-if (eq? #f (typed-array? float 'u32)))
+ (pass-if (eq? #f (typed-array? double 'u32)))
+ (pass-if (eq? #f (typed-array? complex 'u32)))
+ (pass-if (eq? #f (typed-array? scm 'u32))))
+
+ (with-test-prefix "is long"
+ (pass-if (eq? #f (typed-array? bool 's32)))
+ (pass-if (eq? #f (typed-array? char 's32)))
+ (pass-if (eq? #f (typed-array? byte 's32)))
+ (pass-if (eq? #f (typed-array? short 's32)))
+ (pass-if (eq? #f (typed-array? ulong 's32)))
+ (pass-if (eq? #t (typed-array? long 's32)))
+ (pass-if (eq? #f (typed-array? longlong 's32)))
+ (pass-if (eq? #f (typed-array? float 's32)))
+ (pass-if (eq? #f (typed-array? double 's32)))
+ (pass-if (eq? #f (typed-array? complex 's32)))
+ (pass-if (eq? #f (typed-array? scm 's32))))
+
+ (with-test-prefix "is long long"
+ (pass-if (eq? #f (typed-array? bool 's64)))
+ (pass-if (eq? #f (typed-array? char 's64)))
+ (pass-if (eq? #f (typed-array? byte 's64)))
+ (pass-if (eq? #f (typed-array? short 's64)))
+ (pass-if (eq? #f (typed-array? ulong 's64)))
+ (pass-if (eq? #f (typed-array? long 's64)))
+ (pass-if (eq? #t (typed-array? longlong 's64)))
+ (pass-if (eq? #f (typed-array? float 's64)))
+ (pass-if (eq? #f (typed-array? double 's64)))
+ (pass-if (eq? #f (typed-array? complex 's64)))
+ (pass-if (eq? #f (typed-array? scm 's64))))
+
+ (with-test-prefix "is float"
+ (pass-if (eq? #f (typed-array? bool 'f32)))
+ (pass-if (eq? #f (typed-array? char 'f32)))
+ (pass-if (eq? #f (typed-array? byte 'f32)))
+ (pass-if (eq? #f (typed-array? short 'f32)))
+ (pass-if (eq? #f (typed-array? ulong 'f32)))
+ (pass-if (eq? #f (typed-array? long 'f32)))
+ (pass-if (eq? #f (typed-array? longlong 'f32)))
+ (pass-if (eq? #t (typed-array? float 'f32)))
+ (pass-if (eq? #f (typed-array? double 'f32)))
+ (pass-if (eq? #f (typed-array? complex 'f32)))
+ (pass-if (eq? #f (typed-array? scm 'f32))))
+
+ (with-test-prefix "is double"
+ (pass-if (eq? #f (typed-array? bool 'f64)))
+ (pass-if (eq? #f (typed-array? char 'f64)))
+ (pass-if (eq? #f (typed-array? byte 'f64)))
+ (pass-if (eq? #f (typed-array? short 'f64)))
+ (pass-if (eq? #f (typed-array? ulong 'f64)))
+ (pass-if (eq? #f (typed-array? long 'f64)))
+ (pass-if (eq? #f (typed-array? longlong 'f64)))
+ (pass-if (eq? #f (typed-array? float 'f64)))
+ (pass-if (eq? #t (typed-array? double 'f64)))
+ (pass-if (eq? #f (typed-array? complex 'f64)))
+ (pass-if (eq? #f (typed-array? scm 'f64))))
+
+ (with-test-prefix "is complex"
+ (pass-if (eq? #f (typed-array? bool 'c64)))
+ (pass-if (eq? #f (typed-array? char 'c64)))
+ (pass-if (eq? #f (typed-array? byte 'c64)))
+ (pass-if (eq? #f (typed-array? short 'c64)))
+ (pass-if (eq? #f (typed-array? ulong 'c64)))
+ (pass-if (eq? #f (typed-array? long 'c64)))
+ (pass-if (eq? #f (typed-array? longlong 'c64)))
+ (pass-if (eq? #f (typed-array? float 'c64)))
+ (pass-if (eq? #f (typed-array? double 'c64)))
+ (pass-if (eq? #t (typed-array? complex 'c64)))
+ (pass-if (eq? #f (typed-array? scm 'c64))))
+
+ (with-test-prefix "is scm"
+ (pass-if (eq? #f (typed-array? bool #t)))
+ (pass-if (eq? #f (typed-array? char #t)))
+ (pass-if (eq? #f (typed-array? byte #t)))
+ (pass-if (eq? #f (typed-array? short #t)))
+ (pass-if (eq? #f (typed-array? ulong #t)))
+ (pass-if (eq? #f (typed-array? long #t)))
+ (pass-if (eq? #f (typed-array? longlong #t)))
+ (pass-if (eq? #f (typed-array? float #t)))
+ (pass-if (eq? #f (typed-array? double #t)))
+ (pass-if (eq? #f (typed-array? complex #t)))
+ (pass-if (eq? #t (typed-array? scm #t))))))
+
+;;;
+;;; array-equal?
+;;;
+
+(with-test-prefix "array-equal?"
+
+ (pass-if "#s16(...)"
+ (array-equal? #s16(1 2 3) #s16(1 2 3))))
+
+;;;
+;;; array->list
+;;;
+
+(with-test-prefix "array->list"
+ (pass-if (equal? (array->list #s16(1 2 3)) '(1 2 3)))
+ (pass-if (equal? (array->list #(1 2 3)) '(1 2 3)))
+ (pass-if (equal? (array->list #2((1 2) (3 4) (5 6))) '((1 2) (3 4) (5 6))))
+ (pass-if (equal? (array->list #()) '())))
+
+
+;;;
+;;; array-fill!
+;;;
+
+(with-test-prefix "array-fill!"
+
+ (with-test-prefix "bool"
+ (let ((a (make-bitvector 1 #t)))
+ (pass-if "#f" (array-fill! a #f) #t)
+ (pass-if "#t" (array-fill! a #t) #t)))
+
+ (with-test-prefix "char"
+ (let ((a (make-string 1 #\a)))
+ (pass-if "x" (array-fill! a #\x) #t)))
+
+ (with-test-prefix "byte"
+ (let ((a (make-s8vector 1 0)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "127" (array-fill! a 127) #t)
+ (pass-if "-128" (array-fill! a -128) #t)
+ (pass-if-exception "128" exception:out-of-range
+ (array-fill! a 128))
+ (pass-if-exception "-129" exception:out-of-range
+ (array-fill! a -129))
+ (pass-if-exception "symbol" exception:wrong-type-arg
+ (array-fill! a 'symbol))))
+
+ (with-test-prefix "short"
+ (let ((a (make-s16vector 1 0)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)))
+
+ (with-test-prefix "ulong"
+ (let ((a (make-u32vector 1 1)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if-exception "-123" exception:out-of-range
+ (array-fill! a -123) #t)))
+
+ (with-test-prefix "long"
+ (let ((a (make-s32vector 1 -1)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)))
+
+ (with-test-prefix "float"
+ (let ((a (make-f32vector 1 1.0)))
+ (pass-if "0.0" (array-fill! a 0) #t)
+ (pass-if "123.0" (array-fill! a 123.0) #t)
+ (pass-if "-123.0" (array-fill! a -123.0) #t)
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)
+ (pass-if "5/8" (array-fill! a 5/8) #t)))
+
+ (with-test-prefix "double"
+ (let ((a (make-f64vector 1 1/3)))
+ (pass-if "0.0" (array-fill! a 0) #t)
+ (pass-if "123.0" (array-fill! a 123.0) #t)
+ (pass-if "-123.0" (array-fill! a -123.0) #t)
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)
+ (pass-if "5/8" (array-fill! a 5/8) #t))))
+
+;;;
+;;; array-in-bounds?
+;;;
+
+(with-test-prefix "array-in-bounds?"
+
+ (pass-if (let ((a (make-array #f '(425 425))))
+ (eq? #f (array-in-bounds? a 0)))))
+
+;;;
+;;; array-prototype
+;;;
+
+(with-test-prefix "array-type"
+
+ (with-test-prefix "on make-foo-vector"
+
+ (pass-if "bool"
+ (eq? 'b (array-type (make-bitvector 1))))
+
+ (pass-if "char"
+ (eq? 'a (array-type (make-string 1))))
+
+ (pass-if "byte"
+ (eq? 'u8 (array-type (make-u8vector 1))))
+
+ (pass-if "short"
+ (eq? 's16 (array-type (make-s16vector 1))))
+
+ (pass-if "ulong"
+ (eq? 'u32 (array-type (make-u32vector 1))))
+
+ (pass-if "long"
+ (eq? 's32 (array-type (make-s32vector 1))))
+
+ (pass-if "long long"
+ (eq? 's64 (array-type (make-s64vector 1))))
+
+ (pass-if "float"
+ (eq? 'f32 (array-type (make-f32vector 1))))
+
+ (pass-if "double"
+ (eq? 'f64 (array-type (make-f64vector 1))))
+
+ (pass-if "complex"
+ (eq? 'c64 (array-type (make-c64vector 1))))
+
+ (pass-if "scm"
+ (eq? #t (array-type (make-vector 1)))))
+
+ (with-test-prefix "on make-typed-array"
+
+ (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
+ (for-each (lambda (type)
+ (pass-if (symbol->string type)
+ (eq? type
+ (array-type (make-typed-array type
+ *unspecified*
+ '(5 6))))))
+ types))))
+
+;;;
+;;; array-set!
+;;;
+
+(with-test-prefix "array-set!"
+
+ (with-test-prefix "bitvector"
+
+ ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
+ ;; on a bitvector like the following
+ (let ((a (make-bitvector 1)))
+ (pass-if "one elem set #t"
+ (begin
+ (array-set! a #t 0)
+ (eq? #t (array-ref a 0))))
+ (pass-if "one elem set #f"
+ (begin
+ (array-set! a #f 0)
+ (eq? #f (array-ref a 0))))))
+
+ (with-test-prefix "byte"
+
+ (let ((a (make-s8vector 1)))
+
+ (pass-if "-128"
+ (begin (array-set! a -128 0) #t))
+ (pass-if "0"
+ (begin (array-set! a 0 0) #t))
+ (pass-if "127"
+ (begin (array-set! a 127 0) #t))
+ (pass-if-exception "-129" exception:out-of-range
+ (begin (array-set! a -129 0) #t))
+ (pass-if-exception "128" exception:out-of-range
+ (begin (array-set! a 128 0) #t))))
+
+ (with-test-prefix "short"
+
+ (let ((a (make-s16vector 1)))
+ ;; true if n can be array-set! into a
+ (define (fits? n)
+ (false-if-exception (begin (array-set! a n 0) #t)))
+
+ (with-test-prefix "store/fetch"
+ ;; Check array-ref gives back what was put with array-set!.
+ ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
+ ;; would silently truncate to a short.
+
+ (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1
+ ((not (fits? n)))
+ (array-set! a n 0)
+ (pass-if n
+ (= n (array-ref a 0))))
+
+ (do ((n -1 (* 2 n))) ;; -n=2^k
+ ((not (fits? n)))
+ (array-set! a n 0)
+ (pass-if n
+ (= n (array-ref a 0))))))))
+
+;;;
+;;; array-set!
+;;;
+
+(with-test-prefix "array-set!"
+
+ (with-test-prefix "one dim"
+ (let ((a (make-array #f '(3 5))))
+ (pass-if "start"
+ (array-set! a 'y 3)
+ #t)
+ (pass-if "end"
+ (array-set! a 'y 5)
+ #t)
+ (pass-if-exception "start-1" exception:out-of-range
+ (array-set! a 'y 2))
+ (pass-if-exception "end+1" exception:out-of-range
+ (array-set! a 'y 6))
+ (pass-if-exception "two indexes" exception:out-of-range
+ (array-set! a 'y 6 7))))
+
+ (with-test-prefix "two dim"
+ (let ((a (make-array #f '(3 5) '(7 9))))
+ (pass-if "start"
+ (array-set! a 'y 3 7)
+ #t)
+ (pass-if "end"
+ (array-set! a 'y 5 9)
+ #t)
+ (pass-if-exception "start i-1" exception:out-of-range
+ (array-set! a 'y 2 7))
+ (pass-if-exception "end i+1" exception:out-of-range
+ (array-set! a 'y 6 9))
+ (pass-if-exception "one index" exception:wrong-num-indices
+ (array-set! a 'y 4))
+ (pass-if-exception "three indexes" exception:wrong-num-indices
+ (array-set! a 'y 4 8 0)))))
+
+;;;
+;;; make-shared-array
+;;;
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+(with-test-prefix "make-shared-array"
+
+ ;; this failed in guile 1.8.0
+ (pass-if "vector unchanged"
+ (let* ((a (make-array #f '(0 7)))
+ (s (make-shared-array a list '(0 7))))
+ (array-equal? a s)))
+
+ (pass-if-exception "vector, high too big" exception:mapping-out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(0 8))))
+
+ (pass-if-exception "vector, low too big" exception:out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(-1 7))))
+
+ (pass-if "truncate columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+ #2((a b) (d e) (g h))))
+
+ (pass-if "pick one column"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i 2))
+ '(0 2))
+ #(c f i)))
+
+ (pass-if "diagonal"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i)))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "2 dims from 1 dim"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i j) (list (+ (* i 3) j)))
+ 4 3)
+ #2((a b c) (d e f) (g h i) (j k l))))
+
+ (pass-if "reverse columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i j) (list i (- 2 j)))
+ 3 3)
+ #2((c b a) (f e d) (i h g))))
+
+ (pass-if "fixed offset, 0 based becomes 1 based"
+ (let* ((x #2((a b c) (d e f) (g h i)))
+ (y (make-shared-array x
+ (lambda (i j) (list (1- i) (1- j)))
+ '(1 3) '(1 3))))
+ (and (eq? (array-ref x 0 0) 'a)
+ (eq? (array-ref y 1 1) 'a))))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "stride every third element"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i) (list (* i 3)))
+ 4)
+ #1(a d g j)))
+
+ (pass-if "shared of shared"
+ (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
+ (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
+ (s2 (make-shared-array s1 list '(1 2))))
+ (and (eqv? 5 (array-ref s2 1))
+ (eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; uniform-vector-ref
+;;;
+
+(with-test-prefix "uniform-vector-ref"
+
+ (with-test-prefix "byte"
+
+ (let ((a (make-s8vector 1)))
+
+ (pass-if "0"
+ (begin
+ (array-set! a 0 0)
+ (= 0 (uniform-vector-ref a 0))))
+ (pass-if "127"
+ (begin
+ (array-set! a 127 0)
+ (= 127 (uniform-vector-ref a 0))))
+ (pass-if "-128"
+ (begin
+ (array-set! a -128 0)
+ (= -128 (uniform-vector-ref a 0)))))))
+
+;;;
+;;; syntax
+;;;
+
+(with-test-prefix "syntax"
+
+ (pass-if "rank and lower bounds"
+ ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
+ (let ((a 'address@hidden@7((1 2) (3 4))))
+ (and (array? a)
+ (typed-array? a 'u32)
+ (= (array-rank a) 2)
+ (let loop ((bounds '((2 7) (2 8) (3 7) (3 8)))
+ (result #t))
+ (if (null? bounds)
+ result
+ (and result
+ (loop (cdr bounds)
+ (apply array-in-bounds? a (car bounds)))))))))
+
+ (pass-if "negative lower bound"
+ (let ((a 'address@hidden(a b)))
+ (and (array? a)
+ (= (array-rank a) 1)
+ (array-in-bounds? a -3) (array-in-bounds? a -2)
+ (eq? 'a (array-ref a -3))
+ (eq? 'b (array-ref a -2)))))
+
+ (pass-if-exception "negative length" exception:length-non-negative
+ (with-input-from-string "'#1:-3(#t #t)" read))
+
+ (pass-if "bitvector is self-evaluating"
+ (equal? (compile (bitvector)) (bitvector))))
+
+;;;
+;;; equal? with vector and one-dimensional array
+;;;
+
+(with-test-prefix "equal?"
+ (pass-if "array and non-array"
+ (not (equal? #2f64((0 1) (2 3)) 100)))
+
+ (pass-if "empty vectors of different types"
+ (not (equal? #s32() #f64())))
+
+ (pass-if "empty arrays of different types"
+ (not (equal? #2s32() #2f64())))
+
+ (pass-if "empty arrays of the same type"
+ (equal? #s32() #s32()))
+
+ (pass-if "identical uniform vectors of the same type"
+ (equal? #s32(1) #s32(1)))
+
+ (pass-if "nonidentical uniform vectors of the same type"
+ (not (equal? #s32(1) #s32(-1))))
+
+ (pass-if "identical uniform vectors of different types"
+ (not (equal? #s32(1) #s64(1))))
+
+ (pass-if "nonidentical uniform vectors of different types"
+ (not (equal? #s32(1) #s64(-1))))
+
+ (pass-if "vector and one-dimensional array"
+ (equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i))))
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index 304a84d..29505a8 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -1,4 +1,4 @@
-;;;; test assembly to bytecode compilation -*- scheme -*-
+;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -16,10 +16,14 @@
(define-module (test-suite tests asm-to-bytecode)
#:use-module (rnrs bytevector)
+ #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
#:use-module (language assembly compile-bytecode))
+(define write-bytecode
+ (@@ (language assembly compile-bytecode) write-bytecode))
+
(define (->u8-list sym val)
(let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
(uint32 4 ,bytevector-u32-native-set!))
@@ -32,7 +36,7 @@
(define (munge-bytecode v)
(let lp ((i 0) (out '()))
(if (= i (vector-length v))
- (list->u8vector (reverse out))
+ (u8-list->bytevector (reverse out))
(let ((x (vector-ref v i)))
(cond
((symbol? x)
@@ -44,16 +48,17 @@
(else (error "bad test bytecode" x)))))))
(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (u8vector-length y))
- (v (make-u8vector len))
- (i 0))
- (define (write-byte b) (u8vector-set! v i b) (set! i (1+ i)))
- (define (get-addr) i)
+ (let* ((y (munge-bytecode y))
+ (len (bytevector-length y))
+ (v #f))
+
(run-test `(length ,x) #t
(lambda ()
- (write-bytecode x write-byte get-addr '())
- (= i len)))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ (write-bytecode x port '() 0 #t)
+ (set! v (get-bytevector))
+ (= (bytevector-length v) len)))))
(run-test `(compile-equal? ,x ,y) #t
(lambda ()
(equal? v y)))))
@@ -76,7 +81,16 @@
(comp-test '(load-symbol "foo")
(vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer
#\o)
(char->integer #\o)))
-
+
+ (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
+ (vector 'load-string 0 0 1 230))
+
+ (comp-test '(load-wide-string "λ")
+ (apply vector 'load-wide-string 0 0 4
+ (if (eq? (native-endianness) (endianness little))
+ '(187 3 0 0)
+ '(0 0 3 187))))
+
(comp-test '(load-program () 3 #f (make-int8 3) (return))
#(load-program
(uint32 3) ;; len
diff --git a/test-suite/tests/bit-operations.test
b/test-suite/tests/bit-operations.test
index 0e9df7d..e7da571 100644
--- a/test-suite/tests/bit-operations.test
+++ b/test-suite/tests/bit-operations.test
@@ -1,5 +1,5 @@
;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009, 2010 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
@@ -362,3 +362,7 @@
(+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1))
(list (- fixnum-min 1) (+ fixnum-bit 1)
(+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1))))))
+
+(with-test-prefix "bitshifts on word boundaries"
+ (pass-if (= (ash 1 32) 4294967296))
+ (pass-if (= (ash 1 64) 18446744073709551616)))
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
index fe54b02..3a7cc2d 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,7 +1,7 @@
-;;;; bytevectors.test --- Exercise the R6RS bytevector API.
+;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;; Ludovic Courtès
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -377,39 +377,6 @@
(bytevector-ieee-double-ref b 8 (endianness big))))))
-(define (with-locale locale thunk)
- ;; Run THUNK under LOCALE.
- (let ((original-locale (setlocale LC_ALL)))
- (catch 'system-error
- (lambda ()
- (setlocale LC_ALL locale))
- (lambda (key . args)
- (throw 'unresolved)))
-
- (dynamic-wind
- (lambda ()
- #t)
- thunk
- (lambda ()
- (setlocale LC_ALL original-locale)))))
-
-(define (with-latin1-locale thunk)
- ;; Try out several ISO-8859-1 locales and run THUNK under the one that
- ;; works (if any).
- (define %locales
- (map (lambda (name)
- (string-append name ".ISO-8859-1"))
- '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT")))
-
- (let loop ((locales %locales))
- (if (null? locales)
- (throw 'unresolved)
- (catch 'unresolved
- (lambda ()
- (with-locale (car locales) thunk))
- (lambda (key . args)
- (loop (cdr locales)))))))
-
;; Default to the C locale for the following tests.
(setlocale LC_ALL "C")
@@ -427,13 +394,11 @@
(map integer->char (bytevector->u8-list utf8))))))
(pass-if "string->utf8 [latin-1]"
- (with-latin1-locale
- (lambda ()
- (let* ((str "hé, ça va bien ?")
- (utf8 (string->utf8 str)))
- (and (bytevector? utf8)
- (= (bytevector-length utf8)
- (+ 2 (string-length str))))))))
+ (let* ((str "hé, ça va bien ?")
+ (utf8 (string->utf8 str)))
+ (and (bytevector? utf8)
+ (= (bytevector-length utf8)
+ (+ 2 (string-length str))))))
(pass-if "string->utf16"
(let* ((str "hello, world")
@@ -469,6 +434,13 @@
(bytevector->uint-list utf32
(endianness big) 4))))))
+ (pass-if "string->utf32 [Greek]"
+ (let* ((str "á¼Î½ÎµÎ¼Î¿Î¹")
+ (utf32 (string->utf32 str)))
+ (and (bytevector? utf32)
+ (equal? (bytevector->uint-list utf32 (endianness big) 4)
+ '(#x1f0c #x3bd #x3b5 #x3bc #x3bf #x3b9)))))
+
(pass-if "string->utf32 [little]"
(let* ((str "hello, world")
(utf32 (string->utf32 str (endianness little))))
@@ -491,13 +463,11 @@
(map integer->char (bytevector->u8-list utf8))))))
(pass-if "utf8->string [latin-1]"
- (with-latin1-locale
- (lambda ()
- (let* ((utf8 (string->utf8 "hé, ça va bien ?"))
- (str (utf8->string utf8)))
- (and (string? str)
- (= (string-length str)
- (- (bytevector-length utf8) 2)))))))
+ (let* ((utf8 (string->utf8 "hé, ça va bien ?"))
+ (str (utf8->string utf8)))
+ (and (string? str)
+ (= (string-length str)
+ (- (bytevector-length utf8) 2)))))
(pass-if "utf16->string"
(let* ((utf16 (uint-list->bytevector (map char->integer
@@ -696,9 +666,3 @@
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
(= (bytevector-length bv) 2))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; mode: scheme
-;;; End:
diff --git a/test-suite/tests/c-api/Makefile b/test-suite/tests/c-api/Makefile
deleted file mode 100644
index 44488af..0000000
--- a/test-suite/tests/c-api/Makefile
+++ /dev/null
@@ -1,16 +0,0 @@
-CC = gcc
-CFLAGS = -g `guile-config compile`
-
-all: strings
-
-strings: strings.o testlib.o
- ${CC} ${CFLAGS} ${LDFLAGS} -o strings strings.o testlib.o \
- `guile-config link`
-
-strings.o: strings.c testlib.h
-testlib.o: testlib.c testlib.h
-
-
-clean:
- rm -f strings
- rm -f *.o
diff --git a/test-suite/tests/c-api/README b/test-suite/tests/c-api/README
deleted file mode 100644
index da13fde..0000000
--- a/test-suite/tests/c-api/README
+++ /dev/null
@@ -1,11 +0,0 @@
-[NOTE: this code is no longer used -- for now these tests are in the
- standalone directory. What'll happen longer-term is uncertain...]
-
-
-This directory contains tests for Guile's C API. At the moment, the
-test suite doesn't have any way to run these automatically --- we need
-to 1) figure out how to run the compiler, and 2) figure out how to
-integrate results from C tests into the test suite statistics.
-
-Nonetheless, it's better to have this code accumulating here than
-someplace else where nobody can find it.
diff --git a/test-suite/tests/c-api/strings.c b/test-suite/tests/c-api/strings.c
deleted file mode 100644
index 68eb83e..0000000
--- a/test-suite/tests/c-api/strings.c
+++ /dev/null
@@ -1,74 +0,0 @@
-
-/* NOTE: this code was never being run. The same tests have been
- migrated to standalone/test-gh.c */
-
-/* strings.c --- test the Guile C API's string handling functions
- Jim Blandy <address@hidden> --- August 1999 */
-
-#include <guile/gh.h>
-
-#include "testlib.h"
-
-static int
-string_equal (SCM str, char *lit)
-{
- int len = strlen (lit);
-
- return (SCM_LENGTH (str) == len
- && ! memcmp (SCM_ROCHARS (str), lit, len));
-}
-
-void
-test_gh_set_substr ()
-{
- test_context_t cx = test_enter_context ("gh_set_substr");
- SCM string;
-
- string = gh_str02scm ("Free, darnit!");
- test_pass_if ("make a string", gh_string_p (string));
-
- gh_set_substr ("dammit", string, 6, 6);
- test_pass_if ("gh_set_substr from literal",
- string_equal (string, "Free, dammit!"));
-
- /* Make sure that we can use the string itself as a source.
-
- I guess this behavior isn't really visible, since the GH API
- doesn't provide any direct access to the string contents. But I
- think it should, eventually. You can't write efficient string
- code if you have to copy the string just to look at it. */
-
- /* Copy a substring to an overlapping region to its right. */
- gh_set_substr (SCM_CHARS (string), string, 4, 6);
- test_pass_if ("gh_set_substr shifting right",
- string_equal (string, "FreeFree, it!"));
-
- string = gh_str02scm ("Free, darnit!");
- test_pass_if ("make another string", gh_string_p (string));
-
- /* Copy a substring to an overlapping region to its left. */
- gh_set_substr (SCM_CHARS (string) + 6, string, 2, 6);
- test_pass_if ("gh_set_substr shifting right",
- string_equal (string, "Frdarnitrnit!"));
-
- test_restore_context (cx);
-}
-
-void
-main_prog (int argc, char *argv[])
-{
- test_context_t strings = test_enter_context ("strings.c");
-
- test_gh_set_substr ();
-
- test_restore_context (strings);
-
- exit (test_summarize ());
-}
-
-int
-main (int argc, char *argv[])
-{
- gh_enter (argc, argv, main_prog);
- return 0;
-}
diff --git a/test-suite/tests/c-api/testlib.c b/test-suite/tests/c-api/testlib.c
deleted file mode 100644
index 21fff24..0000000
--- a/test-suite/tests/c-api/testlib.c
+++ /dev/null
@@ -1,121 +0,0 @@
-/* testlib.c --- reporting test results
- Jim Blandy <address@hidden> --- August 1999 */
-
-#include <stdlib.h>
-#include <stdio.h>
-
-#include "testlib.h"
-
-
-
-/* Dying. */
-
-static void
-fatal (char *message)
-{
- fprintf (stderr, "%s\n", message);
- exit (1);
-}
-
-
-/* Contexts. */
-
-/* If it gets deeper than this, that's probably an error, right? */
-#define MAX_NESTING 10
-
-int depth = 0;
-char *context_name_stack[MAX_NESTING];
-int marker;
-int context_marker_stack[MAX_NESTING];
-
-test_context_t
-test_enter_context (char *name)
-{
- if (depth >= MAX_NESTING)
- fatal ("test contexts nested too deeply");
-
- /* Generate a unique marker value for this context. */
- marker++;
-
- context_name_stack[depth] = name;
- context_marker_stack[depth] = marker;
-
- depth++;
-
- return marker;
-}
-
-void
-test_restore_context (test_context_t context)
-{
- if (depth <= 0)
- fatal ("attempt to leave outermost context");
-
- depth--;
-
- /* Make sure that we're exiting the same context we last entered. */
- if (context_marker_stack[depth] != context)
- fatal ("contexts not nested properly");
-}
-
-
-/* Reporting results. */
-
-int count_passes, count_fails;
-
-static void
-print_test_name (char *name)
-{
- int i;
-
- for (i = 0; i < depth; i++)
- printf ("%s: ", context_name_stack[i]);
-
- printf ("%s", name);
-}
-
-static void
-print_result (char *result, char *name)
-{
- printf ("%s: ", result);
- print_test_name (name);
- putchar ('\n');
-}
-
-void
-test_pass (char *name)
-{
- print_result ("PASS", name);
- count_passes++;
-}
-
-void
-test_fail (char *name)
-{
- print_result ("FAIL", name);
- count_fails++;
-}
-
-void
-test_pass_if (char *name, int condition)
-{
- (condition ? test_pass : test_fail) (name);
-}
-
-
-/* Printing a summary. */
-
-/* Print a summary of the reported test results. Return zero if
- no failures occurred, one otherwise. */
-
-int
-test_summarize ()
-{
- putchar ('\n');
-
- printf ("passes: %d\n", count_passes);
- printf ("failures: %d\n", count_fails);
- printf ("total tests: %d\n", count_passes + count_fails);
-
- return (count_fails != 0);
-}
diff --git a/test-suite/tests/c-api/testlib.h b/test-suite/tests/c-api/testlib.h
deleted file mode 100644
index 3adaf7f..0000000
--- a/test-suite/tests/c-api/testlib.h
+++ /dev/null
@@ -1,28 +0,0 @@
-/* testlib.h --- reporting test results
- Jim Blandy <address@hidden> --- August 1999 */
-
-#ifndef TESTLIB_H
-#define TESTLIB_H
-
-extern void test_pass (char *name);
-extern void test_fail (char *name);
-extern void test_pass_if (char *name, int condition);
-
-/* We need a way to keep track of what groups of tests we're currently
- within. A call to test_enter_context assures that future tests
- will be reported with a name prefixed by NAME, until we call
- test_restore_context with the value it returned.
-
- Calls to test_enter_context and test_restore_context should be
- properly nested; passing the context around allows them to detect
- mismatches.
-
- It is the caller's responsibility to free NAME after exiting the
- context. (This is trivial if you're passing string literals to
- test_enter_context.) */
-
-typedef int test_context_t;
-extern test_context_t test_enter_context (char *name);
-extern void test_restore_context (test_context_t context);
-
-#endif /* TESTLIB_H */
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index 67e72a6..509f070 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -210,7 +210,12 @@
(not (char-is-both? #\newline))
(char-is-both? #\a)
(char-is-both? #\Z)
- (not (char-is-both? #\1)))))
+ (not (char-is-both? #\1))))
+
+ (pass-if "char-general-category"
+ (and (eq? (char-general-category #\a) 'Ll)
+ (eq? (char-general-category #\A) 'Lu)
+ (eq? (char-general-category #\762) 'Lt))))
(with-test-prefix "integer"
@@ -245,10 +250,32 @@
(eqv? (char-upcase #\a) #\A))
(pass-if "char-downcase"
- (eqv? (char-downcase #\A) #\a)))
+ (eqv? (char-downcase #\A) #\a))
+
+ (pass-if "char-titlecase"
+ (and (eqv? (char-titlecase #\a) #\A)
+ (eqv? (char-titlecase #\763) #\762))))
(with-test-prefix "charnames"
+ (pass-if "R5RS character names"
+ (and (eqv? #\space (integer->char #x20))
+ (eqv? #\newline (integer->char #x0A))))
+
+ (pass-if "R6RS character names"
+ (and (eqv? #\nul (integer->char #x00))
+ (eqv? #\alarm (integer->char #x07))
+ (eqv? #\backspace (integer->char #x08))
+ (eqv? #\tab (integer->char #x09))
+ (eqv? #\linefeed (integer->char #x0A))
+ (eqv? #\newline (integer->char #x0A))
+ (eqv? #\vtab (integer->char #x0B))
+ (eqv? #\page (integer->char #x0C))
+ (eqv? #\return (integer->char #x0D))
+ (eqv? #\esc (integer->char #x1B))
+ (eqv? #\space (integer->char #x20))
+ (eqv? #\delete (integer->char #x7F))))
+
(pass-if "R5RS character names are case insensitive"
(and (eqv? #\space #\ )
(eqv? #\SPACE #\ )
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
new file mode 100644
index 0000000..b3ab707
--- /dev/null
+++ b/test-suite/tests/control.test
@@ -0,0 +1,227 @@
+;;;; -*- scheme -*-
+;;;; control.test --- test suite for delimited continuations
+;;;;
+;;;; Copyright (C) 2010 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 test-control)
+ #:use-module (ice-9 control)
+ #:use-module (srfi srfi-11)
+ #:use-module (test-suite lib))
+
+
+;; For these, the compiler should be able to prove that "k" is not referenced,
+;; so it avoids reifying the continuation. Since that's a slightly different
+;; codepath, we test them both.
+(with-test-prefix "escape-only continuations"
+ (pass-if "no values, normal exit"
+ (equal? '()
+ (call-with-values
+ (lambda ()
+ (% (values)
+ (lambda (k . args)
+ (error "unexpected exit" args))))
+ list)))
+
+ (pass-if "no values, abnormal exit"
+ (equal? '()
+ (% (begin
+ (abort)
+ (error "unexpected exit"))
+ (lambda (k . args)
+ args))))
+
+ (pass-if "single value, normal exit"
+ (equal? '(foo)
+ (call-with-values
+ (lambda ()
+ (% 'foo
+ (lambda (k . args)
+ (error "unexpected exit" args))))
+ list)))
+
+ (pass-if "single value, abnormal exit"
+ (equal? '(foo)
+ (% (begin
+ (abort 'foo)
+ (error "unexpected exit"))
+ (lambda (k . args)
+ args))))
+
+ (pass-if "multiple values, normal exit"
+ (equal? '(foo bar baz)
+ (call-with-values
+ (lambda ()
+ (% (values 'foo 'bar 'baz)
+ (lambda (k . args)
+ (error "unexpected exit" args))))
+ list)))
+
+ (pass-if "multiple values, abnormal exit"
+ (equal? '(foo bar baz)
+ (% (begin
+ (abort 'foo 'bar 'baz)
+ (error "unexpected exit"))
+ (lambda (k . args)
+ args)))))
+
+;;; And the case in which the compiler has to reify the continuation.
+(with-test-prefix "reified continuations"
+ (pass-if "no values, normal exit"
+ (equal? '()
+ (call-with-values
+ (lambda ()
+ (% (values)
+ (lambda (k . args)
+ (error "unexpected exit" k args))))
+ list)))
+
+ (pass-if "no values, abnormal exit"
+ (equal? '()
+ (cdr
+ (% (begin
+ (abort)
+ (error "unexpected exit"))
+ (lambda args
+ args)))))
+
+ (pass-if "single value, normal exit"
+ (equal? '(foo)
+ (call-with-values
+ (lambda ()
+ (% 'foo
+ (lambda (k . args)
+ (error "unexpected exit" k args))))
+ list)))
+
+ (pass-if "single value, abnormal exit"
+ (equal? '(foo)
+ (cdr
+ (% (begin
+ (abort 'foo)
+ (error "unexpected exit"))
+ (lambda args
+ args)))))
+
+ (pass-if "multiple values, normal exit"
+ (equal? '(foo bar baz)
+ (call-with-values
+ (lambda ()
+ (% (values 'foo 'bar 'baz)
+ (lambda (k . args)
+ (error "unexpected exit" k args))))
+ list)))
+
+ (pass-if "multiple values, abnormal exit"
+ (equal? '(foo bar baz)
+ (cdr
+ (% (begin
+ (abort 'foo 'bar 'baz)
+ (error "unexpected exit"))
+ (lambda args
+ args))))))
+
+;; The variants check different cases in the compiler.
+(with-test-prefix "restarting partial continuations"
+ (pass-if "in side-effect position"
+ (let ((k (% (begin (abort) 'foo)
+ (lambda (k) k))))
+ (eq? (k)
+ 'foo)))
+
+ (pass-if "passing values to side-effect abort"
+ (let ((k (% (begin (abort) 'foo)
+ (lambda (k) k))))
+ (eq? (k 'qux 'baz 'hello)
+ 'foo)))
+
+ (pass-if "called for one value"
+ (let ((k (% (+ (abort) 3)
+ (lambda (k) k))))
+ (eqv? (k 39)
+ 42)))
+
+ (pass-if "called for multiple values"
+ (let ((k (% (let-values (((a b . c) (abort)))
+ (list a b c))
+ (lambda (k) k))))
+ (equal? (k 1 2 3 4)
+ '(1 2 (3 4)))))
+
+ (pass-if "in tail position"
+ (let ((k (% (abort)
+ (lambda (k) k))))
+ (eq? (k 'xyzzy)
+ 'xyzzy))))
+
+(define fl (make-fluid))
+(fluid-set! fl 0)
+
+(with-test-prefix "suspend/resume with fluids"
+ (pass-if "normal"
+ (zero? (% (fluid-ref fl)
+ error)))
+ (pass-if "with-fluids normal"
+ (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (fluid-ref fl))
+ error)
+ 1))
+ (pass-if "normal (post)"
+ (zero? (fluid-ref fl)))
+ (pass-if "with-fluids and fluid-set!"
+ (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (fluid-set! fl (1+ (fluid-ref fl)))
+ (fluid-ref fl))
+ error)
+ 2))
+ (pass-if "normal (post2)"
+ (zero? (fluid-ref fl)))
+ (pass-if "normal fluid-set!"
+ (equal? (begin
+ (fluid-set! fl (1+ (fluid-ref fl)))
+ (fluid-ref fl))
+ 1))
+ (pass-if "reset fluid-set!"
+ (equal? (begin
+ (fluid-set! fl (1- (fluid-ref fl)))
+ (fluid-ref fl))
+ 0))
+
+ (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (abort)
+ (fluid-ref fl))
+ (lambda (k) k))))
+ (pass-if "pre"
+ (equal? (fluid-ref fl) 0))
+ (pass-if "res"
+ (equal? (k) 1))
+ (pass-if "post"
+ (equal? (fluid-ref fl) 0))))
+
+(with-test-prefix "rewinding prompts"
+ (pass-if "nested prompts"
+ (let ((k (% 'a
+ (% 'b
+ (begin
+ (abort-to-prompt 'a)
+ (abort-to-prompt 'b #t))
+ (lambda (k x) x))
+ (lambda (k) k))))
+ (k))))
+
+(with-test-prefix "abort to unknown prompt"
+ (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
+ (abort-to-prompt 'does-not-exist)))
diff --git a/test-suite/tests/curried-definitions.test
b/test-suite/tests/curried-definitions.test
new file mode 100644
index 0000000..b4a1f65
--- /dev/null
+++ b/test-suite/tests/curried-definitions.test
@@ -0,0 +1,84 @@
+;;;; curried-definitions.test -*- scheme -*-
+;;;; Copyright (C) 2010 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 test-curried-definitions)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 curried-definitions))
+
+(with-test-prefix "define"
+ (pass-if "define works as usual"
+ (equal? 34
+ (primitive-eval '(let ()
+ (define (foo)
+ 34)
+ (foo)))))
+ (pass-if "define works as usual (2)"
+ (equal? 134
+ (primitive-eval '(let ()
+ (define (foo x)
+ (+ x 34))
+ (foo 100)))))
+ (pass-if "currying once"
+ (equal? 234
+ (primitive-eval '(let ()
+ (define ((foo) x)
+ (+ x 34))
+ ((foo) 200)))))
+ (pass-if "currying twice"
+ (equal? 334
+ (primitive-eval '(let ()
+ (define (((foo)) x)
+ (+ x 34))
+ (((foo)) 300)))))
+
+ (pass-if "just a value"
+ (equal? 444
+ (primitive-eval '(let ()
+ (define foo 444)
+ foo)))))
+
+(with-test-prefix "define*"
+ (pass-if "define* works as usual"
+ (equal? 34
+ (primitive-eval '(let ()
+ (define* (foo)
+ 34)
+ (foo)))))
+ (pass-if "define* works as usual (2)"
+ (equal? 134
+ (primitive-eval '(let ()
+ (define* (foo x)
+ (+ x 34))
+ (foo 100)))))
+ (pass-if "currying once"
+ (equal? 234
+ (primitive-eval '(let ()
+ (define* ((foo) x)
+ (+ x 34))
+ ((foo) 200)))))
+ (pass-if "currying twice"
+ (equal? 334
+ (primitive-eval '(let ()
+ (define* (((foo)) x)
+ (+ x 34))
+ (((foo)) 300)))))
+
+ (pass-if "just a value"
+ (equal? 444
+ (primitive-eval '(let ()
+ (define* foo 444)
+ foo)))))
diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test
new file mode 100644
index 0000000..c5ef344
--- /dev/null
+++ b/test-suite/tests/ecmascript.test
@@ -0,0 +1,74 @@
+;;;; ecmascript.test --- ECMAScript. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010 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-ecmascript)
+ #:use-module (test-suite lib)
+ #:use-module (language ecmascript parse)
+ #:use-module ((system base compile) #:select (compile)))
+
+
+(define (eread str)
+ (call-with-input-string str read-ecmascript))
+
+(define-syntax parse
+ (syntax-rules ()
+ ((_ expression expected)
+ (pass-if expression
+ (equal? expected (eread expression))))))
+
+(with-test-prefix "parser"
+
+ (parse "true;" 'true)
+ (parse "2 + 2;" '(+ (number 2) (number 2)))
+ (parse "\"hello\";" '(string "hello"))
+ (parse "function square(x) { return x * x; }"
+ '(var (square (lambda (x) (return (* (ref x) (ref x)))))))
+ (parse "document.write('Hello, world!');"
+ '(call (pref (ref document) write) ((string "Hello, world!"))))
+ (parse "var x = { foo: 12, bar: \"hello\" };"
+ '(begin (var (x (object (foo (number 12))
+ (bar (string "hello")))))
+ (begin))))
+
+
+(define-syntax ecompile
+ (syntax-rules ()
+ ((_ expression expected)
+ (pass-if expression
+ (equal? expected
+ (compile (call-with-input-string expression read-ecmascript)
+ #:from 'ecmascript
+ #:to 'value))))))
+
+(with-test-prefix "compiler"
+
+ (ecompile "true;" #t)
+ (ecompile "2 + 2;" 4)
+ (ecompile "\"hello\";" "hello")
+
+ ;; FIXME: Broken!
+ ;; (ecompile "[1,2,3,4].map(function(x) { return x * x; });"
+ ;; '(1 4 9 16))
+
+ ;; Examples from
+ ;; <http://wingolog.org/archives/2009/02/22/ecmascript-for-guile>.
+
+ (ecompile "42 + \" good times!\";"
+ "42 good times!")
+ (ecompile "[0,1,2,3,4,5].length * 7;"
+ 42))
diff --git a/test-suite/tests/elisp-compiler.test
b/test-suite/tests/elisp-compiler.test
index 3d3bb1d..61f0acd 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -1,6 +1,6 @@
-;;;; elisp-compiler.test --- Test the compiler for Elisp.
+;;;; elisp-compiler.test --- Test the compiler for Elisp. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Daniel Kraft
;;;;
;;;; This library is free software; you can redistribute it and/or
diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test
index f75b34f..41800fd 100644
--- a/test-suite/tests/elisp.test
+++ b/test-suite/tests/elisp.test
@@ -1,5 +1,5 @@
;;;; elisp.test --- tests guile's elisp support -*- scheme -*-
-;;;; Copyright (C) 2002, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2002, 2003, 2006, 2009, 2010 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
@@ -16,349 +16,337 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-elisp)
- :use-module (test-suite lib)
- :use-module (ice-9 weak-vector))
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (ice-9 weak-vector))
-;; FIXME: the test suite is good, but it uses the old lang elisp module
-;; instead of the new code. Disable for now.
-'(
+(with-test-prefix "scheme"
-(define *old-stack-level* (and=> (memq 'stack (debug-options)) cadr))
-(if *old-stack-level*
- (debug-set! stack (* 2 *old-stack-level*)))
+ (with-test-prefix "nil value is a boolean"
-(define *old-%load-should-autocompile* %load-should-autocompile)
-(set! %load-should-autocompile #f)
+ (pass-if "boolean?"
+ (boolean? #nil)))
+
-;;;
-;;; elisp
-;;;
-
-(if (defined? '%nil)
-
- (with-test-prefix "scheme"
-
- (with-test-prefix "nil value is a boolean"
-
- (pass-if "boolean?"
- (boolean? %nil))
-
- )
-
- (with-test-prefix "nil value is false"
-
- (pass-if "not"
- (eq? (not %nil) #t))
-
- (pass-if "if"
- (if %nil #f #t))
-
- (pass-if "and"
- (eq? (and %nil #t) #f))
-
- (pass-if "or"
- (eq? (or %nil #f) #f))
-
- (pass-if "cond"
- (cond (%nil #f) (else #t)))
-
- (pass-if "do"
- (call-with-current-continuation
- (lambda (exit)
- (do ((i 0 (+ i 1)))
- (%nil (exit #f))
- (if (> i 10)
- (exit #t))))))
-
- )
-
- (with-test-prefix "nil value as an empty list"
-
- (pass-if "list?"
- (list? %nil))
-
- (pass-if "null?"
- (null? %nil))
-
- (pass-if "sort"
- (eq? (sort %nil <) %nil))
+ (with-test-prefix "nil value is false"
- )
+ (pass-if "not"
+ (eq? (not #nil) #t))
+
+ (pass-if "if"
+ (if #nil #f #t))
+
+ (pass-if "and"
+ (eq? (and #nil #t) #f))
- (with-test-prefix "lists formed using nil value"
-
- (pass-if "list?"
- (list? (cons 'a %nil)))
-
- (pass-if "length of %nil"
- (= (length %nil) 0))
-
- (pass-if "length"
- (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3))
-
- (pass-if "length (with backquoted list)"
- (= (length `(a b c . ,%nil)) 3))
-
- (pass-if "write (%nil)"
- (string=? (with-output-to-string
- (lambda () (write %nil)))
- "#nil")) ; Hmmm... should be "()" ?
-
- (pass-if "display (%nil)"
- (string=? (with-output-to-string
- (lambda () (display %nil)))
- "#nil")) ; Ditto.
-
- (pass-if "write (list)"
- (string=? (with-output-to-string
- (lambda () (write (cons 'a %nil))))
- "(a)"))
-
- (pass-if "display (list)"
- (string=? (with-output-to-string
- (lambda () (display (cons 'a %nil))))
- "(a)"))
-
- (pass-if "assq"
- (and (equal? (assq 1 `((1 one) (2 two) . ,%nil))
- '(1 one))
- (equal? (assq 3 `((1 one) (2 two) . ,%nil))
- #f)))
-
- (pass-if "assv"
- (and (equal? (assv 1 `((1 one) (2 two) . ,%nil))
- '(1 one))
- (equal? (assv 3 `((1 one) (2 two) . ,%nil))
- #f)))
-
- (pass-if "assoc"
- (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil))
- '(1 one))
- (equal? (assoc 3 `((1 one) (2 two) . ,%nil))
- #f)))
-
- (pass-if "with-fluids*"
- (let ((f (make-fluid))
- (g (make-fluid)))
- (with-fluids* (cons f (cons g %nil))
- '(3 4)
- (lambda ()
- (and (eq? (fluid-ref f) 3)
- (eq? (fluid-ref g) 4))))))
-
- (pass-if "append!"
- (let ((a (copy-tree '(1 2 3)))
- (b (copy-tree `(4 5 6 . ,%nil)))
- (c (copy-tree '(7 8 9)))
- (d (copy-tree `(a b c . ,%nil))))
- (equal? (append! a b c d)
- `(1 2 3 4 5 6 7 8 9 a b c . ,%nil))))
-
- (pass-if "last-pair"
- (equal? (last-pair `(1 2 3 4 5 . ,%nil))
- (cons 5 %nil)))
-
- (pass-if "reverse"
- (equal? (reverse `(1 2 3 4 5 . ,%nil))
- '(5 4 3 2 1))) ; Hmmm... is this OK, or
+ (pass-if "or"
+ (eq? (or #nil #f) #f))
+
+ (pass-if "cond"
+ (cond (#nil #f) (else #t)))
+
+ (pass-if "do"
+ (call-with-current-continuation
+ (lambda (exit)
+ (do ((i 0 (+ i 1)))
+ (#nil (exit #f))
+ (if (> i 10)
+ (exit #t)))))))
+
+
+ (with-test-prefix "nil value as an empty list"
+
+ (pass-if "list?"
+ (list? #nil))
+
+ (pass-if "null?"
+ (null? #nil))
+
+ (pass-if "sort"
+ (eq? (sort #nil <) #nil)))
+
+
+ (with-test-prefix "lists formed using nil value"
+
+ (pass-if "list?"
+ (list? (cons 'a #nil)))
+
+ (pass-if "length of #nil"
+ (= (length #nil) 0))
+
+ (pass-if "length"
+ (= (length (cons 'a (cons 'b (cons 'c #nil)))) 3))
+
+ (pass-if "length (with backquoted list)"
+ (= (length '(a b c . #nil)) 3))
+
+ (pass-if "write (#nil)"
+ (string=? (with-output-to-string
+ (lambda () (write #nil)))
+ "#nil")) ; Hmmm... should be "()" ?
+
+ (pass-if "display (#nil)"
+ (string=? (with-output-to-string
+ (lambda () (display #nil)))
+ "#nil")) ; Ditto.
+
+ (pass-if "write (list)"
+ (string=? (with-output-to-string
+ (lambda () (write (cons 'a #nil))))
+ "(a)"))
+
+ (pass-if "display (list)"
+ (string=? (with-output-to-string
+ (lambda () (display (cons 'a #nil))))
+ "(a)"))
+
+ (pass-if "assq"
+ (and (equal? (assq 1 '((1 one) (2 two) . #nil))
+ '(1 one))
+ (equal? (assq 3 '((1 one) (2 two) . #nil))
+ #f)))
+
+ (pass-if "assv"
+ (and (equal? (assv 1 '((1 one) (2 two) . #nil))
+ '(1 one))
+ (equal? (assv 3 '((1 one) (2 two) . #nil))
+ #f)))
+
+ (pass-if "assoc"
+ (and (equal? (assoc 1 '((1 one) (2 two) . #nil))
+ '(1 one))
+ (equal? (assoc 3 '((1 one) (2 two) . #nil))
+ #f)))
+
+ (pass-if "with-fluids*"
+ (let ((f (make-fluid))
+ (g (make-fluid)))
+ (with-fluids* (cons f (cons g #nil))
+ '(3 4)
+ (lambda ()
+ (and (eq? (fluid-ref f) 3)
+ (eq? (fluid-ref g) 4))))))
+
+ (pass-if "append!"
+ (let ((a (copy-tree '(1 2 3)))
+ (b (copy-tree '(4 5 6 . #nil)))
+ (c (copy-tree '(7 8 9)))
+ (d (copy-tree '(a b c . #nil))))
+ (equal? (append! a b c d)
+ '(1 2 3 4 5 6 7 8 9 a b c . #nil))))
+
+ (pass-if "last-pair"
+ (equal? (last-pair '(1 2 3 4 5 . #nil))
+ (cons 5 #nil)))
+
+ (pass-if "reverse"
+ (equal? (reverse '(1 2 3 4 5 . #nil))
+ '(5 4 3 2 1))) ; Hmmm... is this OK, or
; should it be
- ; `(5 4 3 2 1 . ,%nil) ?
-
- (pass-if "reverse!"
- (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil)))
- '(5 4 3 2 1))) ; Ditto.
-
- (pass-if "list-ref"
- (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4))
-
- (pass-if-exception "list-ref"
- exception:out-of-range
- (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6))
+ ; '(5 4 3 2 1 . #nil) ?
- (pass-if "list-set!"
- (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
- (list-set! l 4 44)
- (= (list-ref l 4) 44)))
+ (pass-if "reverse!"
+ (equal? (reverse! (copy-tree '(1 2 3 4 5 . #nil)))
+ '(5 4 3 2 1))) ; Ditto.
- (pass-if-exception "list-set!"
- exception:out-of-range
- (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
- (list-set! l 6 44)
- (= (list-ref l 6) 44)))
+ (pass-if "list-ref"
+ (eq? (list-ref '(0 1 2 3 4 . #nil) 4) 4))
- (pass-if "list-cdr-set!"
- (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
- (and (begin
- (list-cdr-set! l 4 44)
- (equal? l '(0 1 2 3 4 . 44)))
- (begin
- (list-cdr-set! l 3 `(new . ,%nil))
- (equal? l `(0 1 2 3 new . ,%nil))))))
+ (pass-if-exception "list-ref"
+ exception:out-of-range
+ (eq? (list-ref '(0 1 2 3 4 . #nil) 6) 6))
- (pass-if-exception "list-cdr-set!"
- exception:out-of-range
- (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
- (list-cdr-set! l 6 44)))
+ (pass-if "list-set!"
+ (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
+ (list-set! l 4 44)
+ (= (list-ref l 4) 44)))
- (pass-if "memq"
- (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
+ (pass-if-exception "list-set!"
+ exception:out-of-range
+ (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
+ (list-set! l 6 44)
+ (= (list-ref l 6) 44)))
- (pass-if "memv"
- (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
+ (pass-if "list-cdr-set!"
+ (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
+ (and (begin
+ (list-cdr-set! l 4 44)
+ (equal? l '(0 1 2 3 4 . 44)))
+ (begin
+ (list-cdr-set! l 3 '(new . #nil))
+ (equal? l '(0 1 2 3 new . #nil))))))
- (pass-if "member"
- (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil)))
+ (pass-if-exception "list-cdr-set!"
+ exception:out-of-range
+ (let ((l (copy-tree '(0 1 2 3 4 . #nil))))
+ (list-cdr-set! l 6 44)))
- (pass-if "list->vector"
- (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil))))
+ (pass-if "memq"
+ (equal? (memq 'c '(a b c d . #nil)) '(c d . #nil)))
- (pass-if "list->vector"
- (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil))))
+ (pass-if "memv"
+ (equal? (memv 'c '(a b c d . #nil)) '(c d . #nil)))
- (pass-if "list->weak-vector"
- (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil))))
+ (pass-if "member"
+ (equal? (member "c" '("a" "b" "c" "d" . #nil)) '("c" "d" . #nil)))
- (pass-if "sorted?"
- (and (sorted? `(1 2 3 . ,%nil) <)
- (not (sorted? `(1 6 3 . ,%nil) <))))
+ (pass-if "list->vector"
+ (equal? '#(1 2 3) (list->vector '(1 2 3 . #nil))))
- (pass-if "merge"
- (equal? (merge '(1 4 7 10)
- (merge `(2 5 8 11 . ,%nil)
- `(3 6 9 12 . ,%nil)
- <)
- <)
- `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
+ (pass-if "list->vector"
+ (equal? '#(1 2 3) (list->vector '(1 2 3 . #nil))))
- (pass-if "merge!"
- (equal? (merge! (copy-tree '(1 4 7 10))
- (merge! (copy-tree `(2 5 8 11 . ,%nil))
- (copy-tree `(3 6 9 12 . ,%nil))
- <)
- <)
- `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
+ (pass-if "list->weak-vector"
+ (equal? (weak-vector 1 2 3) (list->weak-vector '(1 2 3 . #nil))))
- (pass-if "sort"
- (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
+ (pass-if "sorted?"
+ (and (sorted? '(1 2 3 . #nil) <)
+ (not (sorted? '(1 6 3 . #nil) <))))
- (pass-if "stable-sort"
- (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
+ (pass-if "merge"
+ (equal? (merge '(1 4 7 10)
+ (merge '(2 5 8 11 . #nil)
+ '(3 6 9 12 . #nil)
+ <)
+ <)
+ '(1 2 3 4 5 6 7 8 9 10 11 12 . #nil)))
- (pass-if "sort!"
- (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
- '(1 3 4 5 8)))
+ (pass-if "merge!"
+ (equal? (merge! (copy-tree '(1 4 7 10))
+ (merge! (copy-tree '(2 5 8 11 . #nil))
+ (copy-tree '(3 6 9 12 . #nil))
+ <)
+ <)
+ '(1 2 3 4 5 6 7 8 9 10 11 12 . #nil)))
- (pass-if "stable-sort!"
- (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
- '(1 3 4 5 8)))
+ (pass-if "sort"
+ (equal? (sort '(1 5 3 8 4 . #nil) <) '(1 3 4 5 8)))
- )
+ (pass-if "stable-sort"
+ (equal? (stable-sort '(1 5 3 8 4 . #nil) <) '(1 3 4 5 8)))
- (with-test-prefix "value preservation"
+ (pass-if "sort!"
+ (equal? (sort! (copy-tree '(1 5 3 8 4 . #nil)) <)
+ '(1 3 4 5 8)))
- (pass-if "car"
- (eq? (car (cons %nil 'a)) %nil))
+ (pass-if "stable-sort!"
+ (equal? (stable-sort! (copy-tree '(1 5 3 8 4 . #nil)) <)
+ '(1 3 4 5 8))))
+
- (pass-if "cdr"
- (eq? (cdr (cons 'a %nil)) %nil))
+ (with-test-prefix "value preservation"
- (pass-if "vector-ref"
- (eq? (vector-ref (vector %nil) 0) %nil))
+ (pass-if "car"
+ (eq? (car (cons #nil 'a)) #nil))
- )
+ (pass-if "cdr"
+ (eq? (cdr (cons 'a #nil)) #nil))
- ))
+ (pass-if "vector-ref"
+ (eq? (vector-ref (vector #nil) 0) #nil))))
-(if (defined? '%nil)
- (use-modules (lang elisp interface)))
-(if (defined? '%nil)
+;;;
+;;; elisp
+;;;
- (with-test-prefix "elisp"
+(with-test-prefix "elisp"
- (define (elisp-pass-if expr expected)
- (pass-if (with-output-to-string
- (lambda ()
- (write expr)))
- (let ((calc (with-output-to-string
- (lambda ()
- (write (eval-elisp expr))))))
- (string=? calc expected))))
+ (define (elisp-pass-if expr expected)
+ (pass-if (with-output-to-string
+ (lambda ()
+ (write expr)))
+ (let ((calc (with-output-to-string
+ (lambda ()
+ (write (compile expr #:from 'elisp #:to 'value))))))
+ (string=? calc expected))))
- (define (elisp-pass-if/maybe-error key expr expected)
- (pass-if (with-output-to-string (lambda () (write expr)))
- (string=?
- (catch key
- (lambda ()
- (with-output-to-string
- (lambda () (write (eval-elisp expr)))))
- (lambda (k . args)
- (format (current-error-port)
- "warning: caught ~a: ~a\n" k args)
- (throw 'unresolved)))
- expected)))
-
- (elisp-pass-if '(and #f) "#f")
- (elisp-pass-if '(and #t) "#t")
- (elisp-pass-if '(and nil) "#nil")
- (elisp-pass-if '(and t) "#t")
- (elisp-pass-if '(and) "#t")
- (elisp-pass-if '(cond (nil t) (t 3)) "3")
- (elisp-pass-if '(cond (nil t) (t)) "#t")
- (elisp-pass-if '(cond (nil)) "#nil")
- (elisp-pass-if '(cond) "#nil")
- (elisp-pass-if '(if #f 'a 'b) "b")
- (elisp-pass-if '(if #t 'a 'b) "a")
- (elisp-pass-if '(if '() 'a 'b) "b")
- (elisp-pass-if '(if nil 'a 'b) "b")
- (elisp-pass-if '(if nil 1 2 3 4) "4")
- (elisp-pass-if '(if nil 1 2) "2")
- (elisp-pass-if '(if nil 1) "#nil")
- (elisp-pass-if '(if t 1 2) "1")
- (elisp-pass-if '(if t 1) "1")
- (elisp-pass-if '(let (a) a) "#nil")
- (elisp-pass-if '(let* (a) a) "#nil")
- (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2")
- (elisp-pass-if '(memq '() '(())) "(())")
- (elisp-pass-if '(memq '() '(nil)) "(#nil)")
- (elisp-pass-if '(memq '() '(t)) "#nil")
- (elisp-pass-if '(memq nil '(())) "(())")
- (elisp-pass-if '(memq nil '(nil)) "(#nil)")
- (elisp-pass-if '(memq nil (list nil)) "(#nil)")
- (elisp-pass-if '(null '#f) "#t")
- (elisp-pass-if '(null '()) "#t")
- (elisp-pass-if '(null 'nil) "#t")
- (elisp-pass-if '(null nil) "#t")
- (elisp-pass-if '(or 1 2 3) "1")
- (elisp-pass-if '(or nil t nil) "#t")
- (elisp-pass-if '(or nil) "#nil")
- (elisp-pass-if '(or t nil t) "#t")
- (elisp-pass-if '(or t) "#t")
- (elisp-pass-if '(or) "#nil")
- (elisp-pass-if '(prog1 1 2 3) "1")
- (elisp-pass-if '(prog2 1 2 3) "2")
- (elisp-pass-if '(progn 1 2 3) "3")
- (elisp-pass-if '(while nil 1) "#nil")
+ (define (elisp-pass-if/maybe-error key expr expected)
+ (pass-if (with-output-to-string (lambda () (write expr)))
+ (string=?
+ (catch key
+ (lambda ()
+ (with-output-to-string
+ (lambda () (write (eval-elisp expr)))))
+ (lambda (k . args)
+ (format (current-error-port)
+ "warning: caught ~a: ~a\n" k args)
+ (throw 'unresolved)))
+ expected)))
+
+ (elisp-pass-if '(and #f) "#f")
+ (elisp-pass-if '(and #t) "#t")
+ (elisp-pass-if '(and nil) "#nil")
+ (elisp-pass-if '(and t) "#t")
+ (elisp-pass-if '(and) "#t")
+ (elisp-pass-if '(cond (nil t) (t 3)) "3")
+ (elisp-pass-if '(cond (nil t) (t)) "#t")
+ (elisp-pass-if '(cond (nil)) "#nil")
+ (elisp-pass-if '(cond) "#nil")
+ (elisp-pass-if '(if #f 'a 'b) "b")
+ (elisp-pass-if '(if #t 'a 'b) "a")
+ (elisp-pass-if '(if nil 'a 'b) "b")
+ (elisp-pass-if '(if nil 1 2 3 4) "4")
+ (elisp-pass-if '(if nil 1 2) "2")
+ (elisp-pass-if '(if nil 1) "#nil")
+ (elisp-pass-if '(if t 1 2) "1")
+ (elisp-pass-if '(if t 1) "1")
+ (elisp-pass-if '(let (a) a) "#nil")
+ (elisp-pass-if '(let* (a) a) "#nil")
+ (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2")
+ (elisp-pass-if '(null nil) "#t")
+ (elisp-pass-if '(or 1 2 3) "1")
+ (elisp-pass-if '(or nil t nil) "#t")
+ (elisp-pass-if '(or nil) "#nil")
+ (elisp-pass-if '(or t nil t) "#t")
+ (elisp-pass-if '(or t) "#t")
+ (elisp-pass-if '(or) "#nil")
+ (elisp-pass-if '(prog1 1 2 3) "1")
+ (elisp-pass-if '(prog2 1 2 3) "2")
+ (elisp-pass-if '(progn 1 2 3) "3")
+ (elisp-pass-if '(while nil 1) "#nil")
- (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r))
"testf")
- (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)")
- (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))")
- ;; NB `lambda' in Emacs is self-quoting, but that's only after
- ;; loading the macro definition of lambda in subr.el.
- (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o
r))) "(lambda (x y &optional o &rest r) (list x y o r))")
- (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o
r)) 1 2 3 4) "(1 2 3 (4))")
-
- (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r))
1 2 3 nil)
- "(1 2 3 #nil)")
+ (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r))
"testf")
+ (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)")
+ (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))")
+ ;; NB `lambda' in Emacs is self-quoting, but that's only after
+ ;; loading the macro definition of lambda in subr.el.
+ (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1
2 3 4) "(1 2 3 (4))")
+
+ (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2
3 nil)
+ "(1 2 3 #nil)")
- (elisp-pass-if '(setq x 3) "3")
- (elisp-pass-if '(defvar x 4) "x")
- (elisp-pass-if 'x "3")
-
- ))
+ (elisp-pass-if '(setq x 3) "3")
+ (elisp-pass-if '(defvar x 4) "x")
+ (elisp-pass-if 'x "3")
+
+ ;; wingo 9 april 2010: the following 10 tests are currently failing. the if &
+ ;; null tests are good, but I think some of the memq tests are bogus, given
+ ;; our current thoughts on equalty and nil; though they should succeed with
+ ;; memv and member in the elisp case. Also I think the function test is
bogus.
+ #;
+ (elisp-pass-if '(if '() 'a 'b) "b")
+ #;
+ (elisp-pass-if '(null '#f) "#t")
+ #;
+ (elisp-pass-if '(null '()) "#t")
+ #;
+ (elisp-pass-if '(null 'nil) "#t")
+ #;
+ (elisp-pass-if '(memq '() '(())) "(())")
+ #;
+ (elisp-pass-if '(memq '() '(nil)) "(#nil)")
+ #;
+ (elisp-pass-if '(memq '() '(t)) "#nil")
+ #;
+ (elisp-pass-if '(memq nil '(())) "(())")
+ #;
+ (elisp-pass-if '(memq nil '(nil)) "(#nil)")
+ #;
+ (elisp-pass-if '(memq nil (list nil)) "(#nil)")
+ #;
+ (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r)))
"(lambda (x y &optional o &rest r) (list x y o r))")
+ )
-(set! %load-should-autocompile *old-%load-should-autocompile*)
-(debug-set! stack *old-stack-level*)
-)
;;; elisp.test ends here
diff --git a/test-suite/tests/encoding-escapes.test
b/test-suite/tests/encoding-escapes.test
index 85f613f..01b2e20 100644
--- a/test-suite/tests/encoding-escapes.test
+++ b/test-suite/tests/encoding-escapes.test
@@ -1,6 +1,6 @@
;;;; encoding-escapes.test --- test suite for Guile's string encodings -*-
mode: scheme; coding: utf-8 -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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,9 +20,6 @@
#:use-module (test-suite lib)
#:use-module (srfi srfi-1))
-(define exception:conversion
- (cons 'misc-error "^cannot convert to output locale"))
-
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
(apply string (map integer->char args)))
@@ -71,14 +68,14 @@
(with-test-prefix "display output errors"
(pass-if-exception "ultima"
- exception:conversion
+ exception:encoding-error
(let ((pt (open-output-string)))
(set-port-encoding! pt "ASCII")
(set-port-conversion-strategy! pt 'error)
(display s1 pt)))
(pass-if-exception "Rashomon"
- exception:conversion
+ exception:encoding-error
(let ((pt (open-output-string)))
(set-port-encoding! pt "ASCII")
(set-port-conversion-strategy! pt 'error)
diff --git a/test-suite/tests/encoding-iso88591.test
b/test-suite/tests/encoding-iso88591.test
index 32d2ed5..bcc8aa7 100644
--- a/test-suite/tests/encoding-iso88591.test
+++ b/test-suite/tests/encoding-iso88591.test
@@ -1,6 +1,6 @@
;;;; encoding-iso88591.test --- test suite for Guile's string encodings -*-
mode: scheme; coding: iso-8859-1 -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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,9 +20,6 @@
#:use-module (test-suite lib)
#:use-module (srfi srfi-1))
-(define exception:conversion
- (cons 'misc-error "^cannot convert to output locale"))
-
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
(apply string (map integer->char args)))
@@ -167,7 +164,7 @@
(with-test-prefix "output errors"
- (pass-if-exception "char 256" exception:conversion
+ (pass-if-exception "char 256" exception:encoding-error
(let ((pt (open-output-string)))
(set-port-encoding! pt "ISO-8859-1")
(set-port-conversion-strategy! pt 'error)
diff --git a/test-suite/tests/encoding-iso88597.test
b/test-suite/tests/encoding-iso88597.test
index eae3fab..f116194 100644
--- a/test-suite/tests/encoding-iso88597.test
+++ b/test-suite/tests/encoding-iso88597.test
@@ -1,6 +1,6 @@
;;;; encoding-iso88697.test --- test suite for Guile's string encodings -*-
mode: scheme; coding: iso-8859-7 -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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,9 +20,6 @@
#:use-module (test-suite lib)
#:use-module (srfi srfi-1))
-(define exception:conversion
- (cons 'misc-error "^cannot convert to output locale"))
-
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
(apply string (map integer->char args)))
@@ -165,7 +162,7 @@
(with-test-prefix "output errors"
(pass-if-exception "char #x0400"
- exception:conversion
+ exception:encoding-error
(let ((pt (open-output-string)))
(set-port-encoding! pt "ISO-8859-7")
(set-port-conversion-strategy! pt 'error)
diff --git a/test-suite/tests/encoding-utf8.test
b/test-suite/tests/encoding-utf8.test
index d5e6370..b82994c 100644
--- a/test-suite/tests/encoding-utf8.test
+++ b/test-suite/tests/encoding-utf8.test
@@ -1,6 +1,6 @@
;;;; encoding-utf8.test --- test suite for Guile's string encodings -*-
mode: scheme; coding: utf-8 -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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,9 +20,6 @@
#:use-module (test-suite lib)
#:use-module (srfi srfi-1))
-(define exception:conversion
- (cons 'misc-error "^cannot convert to output locale"))
-
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
(apply string (map integer->char args)))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index c253b2d..8c06522 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010 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
@@ -302,25 +302,19 @@
exception:wrong-type-arg
(force 1))
- (pass-if-exception "implicit forcing is not supported"
- exception:wrong-type-arg
- (+ (delay (* 3 7)) 13))
-
- ;; Tests that require the debugging evaluator...
- (with-debugging-evaluator
-
- (pass-if "unmemoizing a promise"
- (display-backtrace
- (let ((stack #f))
- (false-if-exception (lazy-catch #t
- (lambda ()
- (let ((f (lambda (g) (delay (g)))))
- (force (f error))))
- (lambda _
- (set! stack (make-stack #t)))))
- stack)
- (%make-void-port "w"))
- #t))))
+ (pass-if "unmemoizing a promise"
+ (display-backtrace
+ (let ((stack #f))
+ (false-if-exception
+ (with-throw-handler #t
+ (lambda ()
+ (let ((f (lambda (g) (delay (g)))))
+ (force (f error))))
+ (lambda _
+ (set! stack (make-stack #t)))))
+ stack)
+ (%make-void-port "w"))
+ #t)))
;;;
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index c2ec5f4..bcaa282 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -1,5 +1,5 @@
;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*-
-;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 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
@@ -75,9 +75,9 @@
(lambda () (throw 'a))
(lambda (x y . rest) #f))))
- (with-test-prefix "with lazy handler"
+ (with-test-prefix "with pre-unwind handler"
- (pass-if "lazy fluid state"
+ (pass-if "pre-unwind fluid state"
(equal? '(inner outer arg)
(let ((fluid-parm (make-fluid))
(inner-val #f))
@@ -102,32 +102,34 @@
(lambda (key . args)
(push 2))))
- (throw-test "catch and lazy catch"
+ (throw-test "catch and with-throw-handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (throw 'a))
- (lambda (key . args)
- (push 3))))
+ (with-throw-handler
+ 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3))))
(lambda (key . args)
(push 4))))
- (throw-test "catch with rethrowing lazy catch handler"
+ (throw-test "catch with rethrowing throw-handler"
'(1 2 3 4)
(catch 'a
(lambda ()
(push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (throw 'a))
- (lambda (key . args)
- (push 3)
- (apply throw key args))))
+ (with-throw-handler
+ 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3)
+ (apply throw key args))))
(lambda (key . args)
(push 4))))
@@ -183,27 +185,6 @@
(lambda (key . args)
(push 4))))
- (throw-test "effect of lazy-catch unwinding on throw to another key"
- '(1 2 3 5 7)
- (catch 'a
- (lambda ()
- (push 1)
- (lazy-catch 'b
- (lambda ()
- (push 2)
- (catch 'a
- (lambda ()
- (push 3)
- (throw 'b))
- (lambda (key . args)
- (push 4))))
- (lambda (key . args)
- (push 5)
- (throw 'a)))
- (push 6))
- (lambda (key . args)
- (push 7))))
-
(throw-test "effect of with-throw-handler not-unwinding on throw to another
key"
'(1 2 3 5 4 6)
(catch 'a
@@ -225,27 +206,6 @@
(lambda (key . args)
(push 7))))
- (throw-test "lazy-catch chaining"
- '(1 2 3 4 6 8)
- (catch 'a
- (lambda ()
- (push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (lazy-catch 'a
- (lambda ()
- (push 3)
- (throw 'a))
- (lambda (key . args)
- (push 4)))
- (push 5))
- (lambda (key . args)
- (push 6)))
- (push 7))
- (lambda (key . args)
- (push 8))))
-
(throw-test "with-throw-handler chaining"
'(1 2 3 4 6 8)
(catch 'a
@@ -267,48 +227,6 @@
(lambda (key . args)
(push 8))))
- (throw-test "with-throw-handler inside lazy-catch"
- '(1 2 3 4 6 8)
- (catch 'a
- (lambda ()
- (push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (with-throw-handler 'a
- (lambda ()
- (push 3)
- (throw 'a))
- (lambda (key . args)
- (push 4)))
- (push 5))
- (lambda (key . args)
- (push 6)))
- (push 7))
- (lambda (key . args)
- (push 8))))
-
- (throw-test "lazy-catch inside with-throw-handler"
- '(1 2 3 4 6 8)
- (catch 'a
- (lambda ()
- (push 1)
- (with-throw-handler 'a
- (lambda ()
- (push 2)
- (lazy-catch 'a
- (lambda ()
- (push 3)
- (throw 'a))
- (lambda (key . args)
- (push 4)))
- (push 5))
- (lambda (key . args)
- (push 6)))
- (push 7))
- (lambda (key . args)
- (push 8))))
-
(throw-test "throw handlers throwing to each other recursively"
'(1 2 3 4 8 6 10 12)
(catch #t
@@ -340,37 +258,6 @@
(lambda (key . args)
(push 12))))
- (throw-test "repeat of previous test but with lazy-catch"
- '(1 2 3 4 8 12)
- (catch #t
- (lambda ()
- (push 1)
- (lazy-catch 'a
- (lambda ()
- (push 2)
- (lazy-catch 'b
- (lambda ()
- (push 3)
- (lazy-catch 'c
- (lambda ()
- (push 4)
- (throw 'b)
- (push 5))
- (lambda (key . args)
- (push 6)
- (throw 'a)))
- (push 7))
- (lambda (key . args)
- (push 8)
- (throw 'c)))
- (push 9))
- (lambda (key . args)
- (push 10)
- (throw 'b)))
- (push 11))
- (lambda (key . args)
- (push 12))))
-
(throw-test "throw handler throwing to lexically inside catch"
'(1 2 7 5 4 6 9)
(with-throw-handler 'a
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
new file mode 100644
index 0000000..3784e54
--- /dev/null
+++ b/test-suite/tests/fluids.test
@@ -0,0 +1,93 @@
+;;;; -*- scheme -*-
+;;;; fluids.test --- test suite for fluid values
+;;;;
+;;;; Copyright (C) 2010 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 test-fluids)
+ :use-module (test-suite lib))
+
+
+(define a (make-fluid))
+(define b (make-fluid))
+(define c #f)
+
+(with-test-prefix "initial fluid values"
+ (pass-if "fluid-ref uninitialized fluid is #f"
+ (not (fluid-ref a)))
+
+ (pass-if "initial value is inherited from parent thread"
+ (if (provided? 'threads)
+ (let ((f (make-fluid)))
+ (fluid-set! f 'initial)
+ (let ((child (call-with-new-thread
+ (lambda ()
+ (let ((init (fluid-ref f)))
+ (fluid-set! f 'new)
+ (list init (fluid-ref f)))))))
+ (equal? '(initial new) (join-thread child))))
+ (throw 'unresolved))))
+
+(with-test-prefix "with-fluids with non-fluid"
+ (pass-if-exception "exception raised if nonfluid passed to with-fluids"
+ exception:wrong-type-arg
+ (with-fluids ((c #t))
+ c))
+
+ (pass-if "fluids not modified if nonfluid passed to with-fluids"
+ (catch 'wrong-type-arg
+ (lambda ()
+ (with-fluids ((a #t)
+ (c #t))
+ #f))
+ (lambda _
+ (not (fluid-ref a))))))
+
+(with-test-prefix "with-fluids with duplicate fluid"
+ (pass-if "last value wins"
+ (with-fluids ((a 1)
+ (a 2))
+ (eqv? (fluid-ref a) 2)))
+
+ (pass-if "original value restored"
+ (and (with-fluids ((a 1)
+ (a 2))
+ (eqv? (fluid-ref a) 2))
+ (eqv? (fluid-ref a) #f))))
+
+(pass-if "fluid values are thread-local"
+ (if (provided? 'threads)
+ (let ((f (make-fluid)))
+ (fluid-set! f 'parent)
+ (let ((child (call-with-new-thread
+ (lambda ()
+ (fluid-set! f 'child)
+ (fluid-ref f)))))
+ (and (eq? (join-thread child) 'child)
+ (eq? (fluid-ref f) 'parent))))
+ (throw 'unresolved)))
+
+(pass-if "fluids are GC'd"
+
+ (let ((g (make-guardian)))
+ (g (make-fluid))
+ (let loop ((i 1000))
+ (and (> i 0)
+ (begin
+ (make-fluid)
+ (loop (1- i)))))
+ (gc)
+ (fluid? (g))))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
new file mode 100644
index 0000000..b1add53
--- /dev/null
+++ b/test-suite/tests/foreign.test
@@ -0,0 +1,57 @@
+;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010 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
+
+;;;
+;;; See also ../standalone/test-ffi for FFI tests.
+;;;
+
+(define-module (test-foreign)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevector)
+ #:use-module (test-suite lib))
+
+
+(with-test-prefix "null pointer"
+
+ (pass-if "zero"
+ (= 0 (foreign-ref %null-pointer)))
+
+ (pass-if-exception "foreign-set! %null-pointer"
+ exception:null-pointer-error
+ (foreign-set! %null-pointer 2))
+
+ (pass-if "foreign-set! other-null-pointer"
+ (let ((f (bytevector->foreign (make-bytevector 2))))
+ (and (not (= 0 (foreign-ref f)))
+ (begin
+ (foreign-set! f 0)
+ (= 0 (foreign-ref f)))
+ (begin
+ ;; Here changing the pointer value of F is perfectly valid.
+ (foreign-set! f 777)
+ (= 777 (foreign-ref f))))))
+
+ (pass-if-exception "foreign->bytevector %null-pointer"
+ exception:null-pointer-error
+ (foreign->bytevector %null-pointer))
+
+ (pass-if-exception "foreign->bytevector other-null-pointer"
+ exception:null-pointer-error
+ (let ((f (bytevector->foreign (make-bytevector 2))))
+ (foreign-set! f 0)
+ (foreign->bytevector f))))
diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test
index 0987f8c..e6beb49 100644
--- a/test-suite/tests/hooks.test
+++ b/test-suite/tests/hooks.test
@@ -1,5 +1,5 @@
;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2009, 2010 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,6 +15,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+(define-module (test-suite test-hooks)
+ #:use-module (test-suite lib))
+
;;;
;;; miscellaneous
;;;
diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test
index 89924b6..1cb48e7 100644
--- a/test-suite/tests/i18n.test
+++ b/test-suite/tests/i18n.test
@@ -202,6 +202,14 @@
(and (eq? #\Z (char-locale-upcase #\z))
(eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
+ (pass-if "char-locale-titlecase"
+ (and (eq? #\T (char-locale-titlecase #\t))
+ (eq? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
+
+ (pass-if "char-locale-titlecase Dž"
+ (and (eq? #\762 (char-locale-titlecase #\763))
+ (eq? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
+
(pass-if "char-locale-upcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
@@ -229,6 +237,11 @@
(and (string=? "Z" (string-locale-upcase "z"))
(string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
+ (pass-if "string-locale-titlecase"
+ (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
+ (string=? "Hello, World" (string-locale-titlecase
+ "hello, world" (make-locale LC_ALL "C")))))
+
(pass-if "string-locale-upcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
diff --git a/test-suite/tests/keywords.test b/test-suite/tests/keywords.test
index 78053ad..42bb379 100644
--- a/test-suite/tests/keywords.test
+++ b/test-suite/tests/keywords.test
@@ -1,6 +1,6 @@
-;;;; keywords.test --- Keywords -*- Scheme -*-
+;;;; keywords.test --- Keywords. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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,7 +24,3 @@
(pass-if "printing"
(string=? (with-output-to-string (lambda () (write #:this)))
"#:this")))
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test
index 59f9dbb..50e5fa7 100644
--- a/test-suite/tests/load.test
+++ b/test-suite/tests/load.test
@@ -1,7 +1,7 @@
;;;; load.test --- test LOAD and path searching functions -*- scheme -*-
;;;; Jim Blandy <address@hidden> --- September 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2010 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
@@ -115,13 +115,13 @@
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
(try-search-with-extensions path "ugly.ss" extensions #f)
-(if (defined? '%nil)
- ;; Check that search-path accepts Elisp nil-terminated lists for
- ;; PATH and EXTENSIONS.
- (with-test-prefix "elisp-nil"
- (set-cdr! (last-pair path) %nil)
- (set-cdr! (last-pair extensions) %nil)
- (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
- (try-search-with-extensions path "ugly.ss" extensions #f)))
+;; Check that search-path accepts Elisp nil-terminated lists for
+;; PATH and EXTENSIONS.
+(with-test-prefix "elisp-nil"
+ (set-cdr! (last-pair path)
+#nil)
+ (set-cdr! (last-pair extensions) #nil)
+ (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
+ (try-search-with-extensions path "ugly.ss" extensions #f))
(delete-tree temp-dir)
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index f22cfe9..ebcafe3 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
-;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010 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
@@ -125,7 +125,15 @@
(map module-variable
(map resolve-interface mods)
syms)
- locals))))
+ locals)))
+
+ (pass-if "module-reverse-lookup [pre-module-obarray]"
+ (let ((var (module-variable (current-module) 'string?)))
+ (eq? 'string? (module-reverse-lookup #f var))))
+
+ (pass-if-exception "module-reverse-lookup [wrong-type-arg]"
+ exception:wrong-type-arg
+ (module-reverse-lookup (current-module) 'foo)))
diff --git a/test-suite/tests/net-db.test b/test-suite/tests/net-db.test
new file mode 100644
index 0000000..47d12a9
--- /dev/null
+++ b/test-suite/tests/net-db.test
@@ -0,0 +1,98 @@
+;;;; net-db.test --- Test suite for `net-db' -*- mode: scheme; coding: utf-8;
-*-
+;;;; Ludovic Courtès <address@hidden>
+;;;;
+;;;; Copyright (C) 2010 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 test-net-db)
+ #:use-module (srfi srfi-1)
+ #:use-module (test-suite lib))
+
+(if (provided? 'net-db)
+ (with-test-prefix "getaddrinfo"
+
+ (pass-if "127.0.0.1, any service"
+ (let ((ai (getaddrinfo "127.0.0.1" #f AI_NUMERICHOST)))
+ (and (> (length ai) 0)
+ (fold (lambda (sa ok?)
+ (and ok?
+ (= (sockaddr:addr sa) INADDR_LOOPBACK)))
+ #t
+ (map addrinfo:addr ai)))))
+
+ (pass-if "127.0.0.1:80"
+ (let ((ai (getaddrinfo "127.0.0.1" "80"
+ (logior AI_NUMERICHOST AI_NUMERICSERV))))
+ (and (> (length ai) 0)
+ (fold (lambda (sa ok?)
+ (and ok?
+ (= (sockaddr:addr sa) INADDR_LOOPBACK)
+ (= (sockaddr:port sa) 80)))
+ #t
+ (map addrinfo:addr ai)))))
+
+ (pass-if "port 80"
+ (let ((ai (getaddrinfo #f "80" (logior AI_ADDRCONFIG AI_NUMERICSERV))))
+ (and (> (length ai) 0)
+ (fold (lambda (ai ok?)
+ (let ((sa (addrinfo:addr ai)))
+ (and ok?
+ (= (sockaddr:port sa) 80))))
+ #t
+ ai))))
+
+ (pass-if "port 80 with family and socket type"
+ (let ((ai (getaddrinfo #f "80" (logior AI_ADDRCONFIG AI_NUMERICSERV)
+ AF_UNSPEC SOCK_STREAM)))
+ (and (> (length ai) 0)
+ (fold (lambda (ai ok?)
+ (let ((sa (addrinfo:addr ai)))
+ (and ok?
+ (= (sockaddr:port sa) 80))))
+ #t
+ ai))))
+
+ (pass-if "no name"
+ (catch 'getaddrinfo-error
+ (lambda ()
+ (getaddrinfo "does-not-exist")
+ #f)
+ (lambda (key errcode)
+ ;; In some cases (e.g., in a chroot without
+ ;; /etc/{hosts,resolv.conf}), this can result in `EAI_EAGAIN'.
+ (and (or (= errcode EAI_NONAME)
+ (= errcode EAI_AGAIN))
+ (string? (gai-strerror errcode))))))
+
+ (pass-if "wrong service name"
+ (catch 'getaddrinfo-error
+ (lambda ()
+ (getaddrinfo "127.0.0.1" "does-not-exist" AI_NUMERICHOST)
+
+ ;; XXX: The call above unexpectedly suceeds on
+ ;; `i386-apple-darwin9.2.2', but not on `i386-apple-darwin9.6.0'.
+ ;; For now we just skip it until a better solution is found. See
+ ;;
http://lists.gnu.org/archive/html/bug-gnulib/2010-02/msg00061.html
+ ;; for details.
+ (if (string-contains %host-type "darwin9.2")
+ (throw 'unresolved)
+ #f))
+ (lambda (key errcode)
+ ;; According to POSIX, both error codes are valid (glibc 2.11
+ ;; chooses `EAI_SERVICE'; Darwin chooses `EAI_NONAME'.)
+ (and (or (= errcode EAI_SERVICE)
+ (= errcode EAI_NONAME))
+ (string? (gai-strerror errcode))))))))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 0c75d71..3f26712 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1,5 +1,5 @@
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010 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
@@ -2436,17 +2436,8 @@
(with-test-prefix "+"
(pass-if "documented?"
- (documented? +))
+ (documented? +)))
- (with-test-prefix "wrong type argument"
-
- (pass-if-exception "1st argument string"
- exception:wrong-type-arg
- (+ "1" 2))
-
- (pass-if-exception "2nd argument bool"
- exception:wrong-type-arg
- (+ 1 #f))))
;;;
;;; -
;;;
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 05b67e5..1f9313b 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -23,18 +23,13 @@
#:use-module (ice-9 optargs))
(define exception:unrecognized-keyword
- ;; Can be `vm-error' or `misc-error' depending on whether we use the
- ;; interpreter or VM:
- ;; (vm-error vm-run "Bad keyword argument list: unrecognized keyword" ())
- ;; (misc-error #f "~A ~S" ("unrecognized keyword" (#:y 2)) #f)
- (cons #t ".*"))
+ '(keyword-argument-error . "Unrecognized keyword"))
(define exception:extraneous-arguments
- ;; Can be `vm-error' or `misc-error' depending on whether we use the
- ;; interpreter or VM, and depending on the evenness of the number of extra
- ;; arguments (!).
- (cons #t ".*"))
-
+ ;; Message depends on whether we use the interpreter or VM, and on the
+ ;; evenness of the number of extra arguments (!).
+ ;'(keyword-argument-error . ".*")
+ '(#t . ".*"))
(define-syntax c&e
(syntax-rules (pass-if pass-if-exception)
@@ -178,3 +173,30 @@
(let ((f (lambda* (#:key x y z #:rest r) (list x y z r))))
(equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (1 2 3 #:x x #:z z))))))
+
+(with-test-prefix/c&e "lambda* inits"
+ (pass-if "can bind lexicals within inits"
+ (begin
+ (define* (qux #:optional a
+ #:key (b (or a 13) #:a))
+ b)
+ #t))
+ (pass-if "testing qux"
+ (and (equal? (qux) 13)
+ (equal? (qux 1) 1)
+ (equal? (qux #:a 2) 2))))
+
+(with-test-prefix/c&e "defmacro*"
+ (pass-if "definition"
+ (begin
+ (defmacro* transmogrify (a #:optional (b 10))
+ `(,a ,b))
+ #t))
+
+ (pass-if "explicit arg"
+ (equal? (transmogrify quote 5)
+ 5))
+
+ (pass-if "default arg"
+ (equal? (transmogrify quote)
+ 10)))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 312467d..1d8bd50 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -1,7 +1,7 @@
-;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
+;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*-
;;;; Jim Blandy <address@hidden> --- May 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010 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
@@ -307,7 +307,48 @@
(string-set! text 0 #\a)
(string-set! text (- len 1) #\b)
(pass-if "output check"
- (string=? text result))))
+ (string=? text result)))
+
+ (pass-if "%default-port-encoding is honored"
+ (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
+ (equal? (map (lambda (e)
+ (with-fluids ((%default-port-encoding e))
+ (call-with-output-string
+ (lambda (p)
+ (display (port-encoding p) p)))))
+ encodings)
+ encodings)))
+
+ (pass-if "suitable encoding [latin-1]"
+ (let ((str "hello, world"))
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (equal? str
+ (with-output-to-string
+ (lambda ()
+ (display str)))))))
+
+ (pass-if "suitable encoding [latin-3]"
+ (let ((str "Äu bone?"))
+ (with-fluids ((%default-port-encoding "ISO-8859-3"))
+ (equal? str
+ (with-output-to-string
+ (lambda ()
+ (display str)))))))
+
+ (pass-if "wrong encoding"
+ (let ((str "Äu bone?"))
+ (catch 'encoding-error
+ (lambda ()
+ ;; Latin-1 cannot represent âÄâ.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (with-output-to-string
+ (lambda ()
+ (display str)))))
+ (lambda (key subr message errno from to faulty-str)
+ (and (eq? faulty-str str)
+ (string=? from "UTF-32")
+ (string=? to "ISO-8859-1")
+ (string? (strerror errno))))))))
(with-test-prefix "call-with-output-string"
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index 06b70ba..6cfecee 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -1,6 +1,6 @@
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2006, 2007, 2010 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
@@ -160,4 +160,23 @@
(throw 'unsupported)
(ttyname file)))))
+;;
+;; utimes
+;;
+
+(with-test-prefix "utime"
+ (pass-if "valid argument (second resolution)"
+ (let ((file "posix.test-utime"))
+ (dynamic-wind
+ (lambda ()
+ (close-port (open-output-file file)))
+ (lambda ()
+ (let* ((accessed (+ (current-time) 3600))
+ (modified (- accessed 1000)))
+ (utime file accessed modified)
+ (let ((info (stat file)))
+ (and (= (stat:atime info) accessed)
+ (= (stat:mtime info) modified)))))
+ (lambda ()
+ (delete-file file))))))
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
new file mode 100644
index 0000000..f8c9edc
--- /dev/null
+++ b/test-suite/tests/print.test
@@ -0,0 +1,54 @@
+;;;; -*- coding: utf-8; mode: scheme; -*-
+;;;;
+;;;; Copyright (C) 2010 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 test-print)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (test-suite lib))
+
+(with-test-prefix "truncated-print"
+ (define exp '(a b #(c d e) f . g))
+
+ (define (tprint x width encoding)
+ (with-fluids ((%default-port-encoding encoding))
+ (with-output-to-string
+ (lambda ()
+ (truncated-print x #:width width)))))
+
+ (pass-if (equal? (tprint exp 10 "ISO-8859-1")
+ "(a b . #)"))
+
+ (pass-if (equal? (tprint exp 15 "ISO-8859-1")
+ "(a b # f . g)"))
+
+ (pass-if (equal? (tprint exp 18 "ISO-8859-1")
+ "(a b #(c ...) . #)"))
+
+ (pass-if (equal? (tprint exp 20 "ISO-8859-1")
+ "(a b #(c d e) f . g)"))
+
+ (pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
+ "\"The quick brown...\""))
+
+ (pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
+ "\"The quick brown fâ¦\""))
+
+ (pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
+ "#<directory (tes...>"))
+
+ (pass-if (equal? (tprint (current-module) 20 "UTF-8")
+ "#<directory (test-â¦>")))
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 6af73f6..c009f88 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -1,7 +1,7 @@
-;;;; procprop.test --- Procedure properties -*- Scheme -*-
-;;;; Ludovic Courtès <address@hidden>
+;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8;
-*-
+;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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
@@ -53,8 +53,3 @@
(pass-if "list"
(equal? (procedure-property list 'arity)
'(0 0 #t))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index eb60cf3..e41d18a 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
-;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
+;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: iso-8859-1; -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -219,7 +219,30 @@
(port (%make-void-port "w")))
(close-port port)
- (put-bytevector port bv))))
+ (put-bytevector port bv)))
+
+ (pass-if "put-bytevector with UTF-16 string port"
+ (let* ((str "hello, world")
+ (bv (string->utf16 str)))
+ (equal? str
+ (with-fluids ((%default-port-encoding "UTF-16BE"))
+ (call-with-output-string
+ (lambda (port)
+ (put-bytevector port bv)))))))
+
+ (pass-if "put-bytevector with wrong-encoding string port"
+ (let* ((str "hello, world")
+ (bv (string->utf16 str)))
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-encoding "UTF-32"))
+ (call-with-output-string
+ (lambda (port)
+ (put-bytevector port bv)))))
+ (lambda (key subr message errno from to faulty-bv)
+ (and (bytevector=? faulty-bv bv)
+ (string=? to "UTF-32")
+ (string? (strerror errno))))))))
(with-test-prefix "7.2.7 Input Ports"
@@ -452,8 +475,6 @@
(not eof?)
(bytevector=? sink source)))))
-
;;; Local Variables:
-;;; coding: latin-1
;;; mode: scheme
;;; End:
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 2ee21c1..84c20b2 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,18 +1,18 @@
-;;;; reader.test --- Exercise the reader. -*- Scheme -*-
+;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010 Free
Software Foundation, Inc.
;;;; Jim Blandy <address@hidden>
;;;;
;;;; This library is free software; you can redistribute 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
@@ -41,7 +41,8 @@
(define (read-string s)
- (with-input-from-string s (lambda () (read))))
+ (with-fluids ((%default-port-encoding #f))
+ (with-input-from-string s (lambda () (read)))))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
@@ -110,8 +111,8 @@
(pass-if "unprintable symbol"
;; The reader tolerates unprintable characters for symbols.
- (equal? (string->symbol "\001\002\003")
- (read-string "\001\002\003")))
+ (equal? (string->symbol "\x01\x02\x03")
+ (read-string "\x01\x02\x03")))
(pass-if "CR recognized as a token delimiter"
;; In 1.8.3, character 0x0d was not recognized as a delimiter.
@@ -219,10 +220,130 @@
(equal? (source-property sexp 'column) 0))))
(pass-if "positions on quote"
(let ((sexp (with-read-options '(positions)
- (lambda ()
+ (lambda ()
(read-string "'abcde")))))
(and (equal? (source-property sexp 'line) 0)
- (equal? (source-property sexp 'column) 0)))))
+ (equal? (source-property sexp 'column) 0))))
+ (with-test-prefix "r6rs-hex-escapes"
+ (pass-if-exception "non-hex char in two-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x0g;\"" read))))
+
+ (pass-if-exception "non-hex char in four-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x000g;\"" read))))
+
+ (pass-if-exception "non-hex char in six-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x00000g;\"" read))))
+
+ (pass-if-exception "no semicolon at termination of one-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x0\"" read))))
+
+ (pass-if-exception "no semicolon at termination of three-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x000\"" read))))
+
+ (pass-if "two-digit hex escape"
+ (eqv?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (string-ref (with-input-from-string "\"--\\xff;--\"" read) 2)))
+ (integer->char #xff)))
+
+ (pass-if "four-digit hex escape"
+ (eqv?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (string-ref (with-input-from-string "\"--\\x0100;--\"" read) 2)))
+ (integer->char #x0100)))
+
+ (pass-if "six-digit hex escape"
+ (eqv?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (string-ref (with-input-from-string "\"--\\x010300;--\"" read) 2)))
+ (integer->char #x010300)))
+
+ (pass-if "escaped characters match non-escaped ASCII characters"
+ (string=?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x41;\\x0042;\\x000043;\"" read)))
+ "ABC"))
+
+ (pass-if "write R6RS string escapes"
+ (let* ((s1 (apply string
+ (map integer->char '(#x8 ; backspace
+ #x20 ; space
+ #x30 ; zero
+ #x40 ; at sign
+ ))))
+ (s2 (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-output-to-string
+ (lambda () (write s1)))))))
+ (lset= eqv?
+ (string->list s2)
+ (list #\" #\\ #\x #\8 #\; #\space #\0 #\@ #\"))))
+
+ (pass-if "display R6RS string escapes"
+ (string=?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (let ((pt (open-output-string))
+ (s1 (apply string (map integer->char
+ '(#xFF #x100 #xFFF #x1000 #xFFFF
#x10000)))))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'escape)
+ (display s1 pt)
+ (get-output-string pt))))
+ "\\xff;\\x100;\\xfff;\\x1000;\\xffff;\\x10000;"))
+
+ (pass-if "one-digit hex escape"
+ (eqv? (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "#\\xA" read)))
+ (integer->char #x0A)))
+
+ (pass-if "two-digit hex escape"
+ (eqv? (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "#\\xFF" read)))
+ (integer->char #xFF)))
+
+ (pass-if "four-digit hex escape"
+ (eqv? (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "#\\x00FF" read)))
+ (integer->char #xFF)))
+
+ (pass-if "eight-digit hex escape"
+ (eqv? (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "#\\x00006587" read)))
+ (integer->char #x6587)))
+ (pass-if "write R6RS escapes"
+ (string=?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-output-to-string
+ (lambda ()
+ (write (integer->char #x80))))))
+ "#\\x80"))))
+
+
(with-test-prefix "#;"
(for-each
@@ -234,10 +355,10 @@
("#;(10 20 30) foo" . foo)
("#; (10 20 30) foo" . foo)
("#;\n10\n20" . 20)))
-
+
(pass-if "#;foo"
(eof-object? (with-input-from-string "#;foo" read)))
-
+
(pass-if-exception "#;"
exception:missing-expression
(with-input-from-string "#;" read))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index 422d8f3..a6844ca 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -1,7 +1,7 @@
;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
;;;; Jim Blandy <address@hidden> --- September 1999
;;;;
-;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010 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,53 +22,12 @@
#:use-module (srfi srfi-1)
#:use-module (ice-9 regex))
-;; Set the locale to LOC, if possible. Failing that, set the locale
-;; to C. If that fails, force the port encoding to ASCII.
-(define (mysetlocale loc)
- (or
- (and (defined? 'setlocale)
- (false-if-exception (setlocale LC_ALL loc)))
- (and (defined? 'setlocale)
- (false-if-exception (setlocale LC_ALL "C")))
- (begin
- (false-if-exception (set-port-encoding! (current-input-port)
- "ASCII"))
- (false-if-exception (set-port-encoding! (current-output-port)
- "ASCII"))
- #f)))
-
-;; Set the locale to a Latin-1 friendly locale. Failing that, force
-;; the port encoding to Latin-1. Returns the encoding used.
-(define (set-latin-1)
- (set-port-conversion-strategy! (current-output-port) 'escape)
- (or
- (any
- (lambda (loc)
- (if (defined? 'setlocale)
- (let ((ret (false-if-exception (setlocale LC_ALL loc))))
- (if ret
- loc
- #f))
- #f))
- (append
- (map (lambda (name)
- (string-append name ".ISO-8859-1"))
- '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
- (map (lambda (name)
- (string-append name ".iso88591"))
- '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
- (map (lambda (name)
- (string-append name ".ISO8859-1"))
- '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
- ))
- (begin
- (false-if-exception (set-port-encoding! (current-input-port)
- "ISO-8859-1"))
- (false-if-exception (set-port-encoding! (current-output-port)
- "ISO-8859-1"))
- #f)))
-
-(mysetlocale "C")
+(if (defined? 'setlocale)
+ (setlocale LC_ALL "C"))
+
+;; Don't fail if we can't display a test name to stdout/stderr.
+(set-port-conversion-strategy! (current-output-port) 'escape)
+(set-port-conversion-strategy! (current-error-port) 'escape)
;;; Run a regexp-substitute or regexp-substitute/global test, once
@@ -204,15 +163,13 @@
(do ((i 1 (1+ i)))
((>= i char-code-limit))
(let* ((c (integer->char i))
- (s (string c))
- (q (regexp-quote s)))
- (pass-if (list "char" i (format #f "~s ~s ~s" c s q))
- (set-latin-1) ; set locale for regexp processing
- ; on binary data
- (let ((m (regexp-exec (make-regexp q flag) s)))
- (mysetlocale "") ; restore locale
- (and (= 0 (match:start m))
- (= 1 (match:end m)))))))
+ (s (string c)))
+ (pass-if (list "char" i (format #f "~s ~s" c s))
+ (with-latin1-locale
+ (let* ((q (regexp-quote s))
+ (m (regexp-exec (make-regexp q flag) s)))
+ (and (= 0 (match:start m))
+ (= 1 (match:end m))))))))
;; try on pattern "aX" where X is each character, except #\nul
;; this exposes things like "?" which are special only when they
@@ -223,24 +180,22 @@
(s (string #\a c))
(q (regexp-quote s)))
(pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
- (set-latin-1)
+ (with-latin1-locale
(let* ((m (regexp-exec (make-regexp q flag) s)))
- (mysetlocale "")
(and (= 0 (match:start m))
- (= 2 (match:end m)))))))
+ (= 2 (match:end m))))))))
(pass-if "string of all chars"
- (set-latin-1)
- (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
- flag) allchars)))
- (and (= 0 (match:start m))
- (= (string-length allchars) (match:end m))))))))
+ (with-latin1-locale
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag) allchars)))
+ (and (= 0 (match:start m))
+ (= (string-length allchars) (match:end m)))))))))
lst)))
;;;
;;; regexp-substitute
;;;
-(mysetlocale "C")
(with-test-prefix "regexp-substitute"
(let ((match
diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test
index cc512bf..7389cee 100644
--- a/test-suite/tests/socket.test
+++ b/test-suite/tests/socket.test
@@ -1,6 +1,6 @@
;;;; socket.test --- test socket functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 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
@@ -343,7 +343,9 @@
;; testing `bind', `listen' and `connect' on stream-oriented sockets
- (let ((server-socket (socket AF_INET6 SOCK_STREAM 0))
+ (let ((server-socket
+ ;; Some platforms don't support this protocol/family combination.
+ (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
(server-bound? #f)
(server-listening? #f)
(server-pid #f)
@@ -352,6 +354,8 @@
(client-port 9998))
(pass-if "bind"
+ (if (not server-socket)
+ (throw 'unresolved))
(catch 'system-error
(lambda ()
(bind server-socket AF_INET6 ipv6-addr server-port)
@@ -363,8 +367,10 @@
(else (apply throw args)))))))
(pass-if "bind/sockaddr"
- (let* ((sock (socket AF_INET6 SOCK_STREAM 0))
+ (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
(sockaddr (make-socket-address AF_INET6 ipv6-addr
client-port)))
+ (if (not sock)
+ (throw 'unresolved))
(catch 'system-error
(lambda ()
(bind sock sockaddr)
diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test
index 0d2ff59..6864287 100644
--- a/test-suite/tests/srfi-13.test
+++ b/test-suite/tests/srfi-13.test
@@ -148,6 +148,25 @@
(string-any char-upper-case? "abCDE" 1 4))))
;;;
+;;; string-titlecase
+;;;
+
+(with-test-prefix "string-titlecase"
+
+ (pass-if "all-lower"
+ (string=? "Foo" (string-titlecase "foo")))
+
+ (pass-if "all-upper"
+ (string=? "Foo" (string-titlecase "FOO")))
+
+ (pass-if "two-words"
+ (string=? "Hello, World!" (string-titlecase "hello, world!")))
+
+ (pass-if "titlecase-characters"
+ (string=? (list->string '(#\762))
+ (string-titlecase (list->string '(#\763))))))
+
+;;;
;;; string-append/shared
;;;
diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test
index f12a255..959612c 100644
--- a/test-suite/tests/srfi-14.test
+++ b/test-suite/tests/srfi-14.test
@@ -2,18 +2,18 @@
;;;; --- Test suite for Guile's SRFI-14 functions.
;;;; Martin Grabmueller, 2001-07-16
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 2001, 2006, 2009, 2010 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
@@ -721,10 +721,14 @@
(integer->char #x20))))
char-set:printing))
+ (pass-if "char-set:ASCII"
+ (char-set= (ucs-range->char-set 0 128)
+ char-set:ascii))
+
(pass-if "char-set:iso-control"
- (char-set<= (string->char-set
- (apply string
- (map integer->char (append
+ (char-set<= (string->char-set
+ (apply string
+ (map integer->char (append
;; U+0000 to U+001F
(iota #x20)
(list #x7f)))))
diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test
index 6d65ce2..8537d49 100644
--- a/test-suite/tests/srfi-31.test
+++ b/test-suite/tests/srfi-31.test
@@ -1,6 +1,6 @@
;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2006, 2010 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,8 +23,8 @@
(with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*")
- (sc-expand '(rec #:foo)))
-
+ (eval '(rec #:foo) (current-module)))
+
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))
(and (= 1 (car ones-list))
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 849d1de..6d725dc 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -1,7 +1,7 @@
-;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
-;;;; Ludovic Courtès <address@hidden>
+;;;; srfi-35.test --- SRFI-35. -*- mode: scheme; coding: utf-8; -*-
+;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2009, 2010 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
@@ -316,8 +316,3 @@
(pass-if "(c2-b v5)"
(equal? (c2-b v5) "b2")))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 8a9d53a..d7e5b1a 100644
--- a/test-suite/tests/srfi-4.test
+++ b/test-suite/tests/srfi-4.test
@@ -1,7 +1,7 @@
;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-06-26
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2010 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
@@ -47,7 +47,15 @@
(pass-if "u8vector->list/list->u8vector"
(equal? (u8vector->list (u8vector 1 2 3 4))
- (u8vector->list (list->u8vector '(1 2 3 4))))))
+ (u8vector->list (list->u8vector '(1 2 3 4)))))
+
+ (pass-if "u8vector->list/uniform-vector->list"
+ (equal? (u8vector->list (u8vector 1 2 3 4))
+ (uniform-vector->list (u8vector 1 2 3 4))))
+
+ (pass-if "make-u8vector"
+ (equal? (list->u8vector '(7 7 7 7))
+ (make-u8vector 4 7))))
(with-test-prefix "s8 vectors"
@@ -76,7 +84,15 @@
(pass-if "s8vector->list/list->s8vector"
(equal? (s8vector->list (s8vector 1 2 3 4))
- (s8vector->list (list->s8vector '(1 2 3 4))))))
+ (s8vector->list (list->s8vector '(1 2 3 4)))))
+
+ (pass-if "s8vector->list/uniform-vector->list"
+ (equal? (s8vector->list (s8vector 1 2 3 4))
+ (uniform-vector->list (s8vector 1 2 3 4))))
+
+ (pass-if "make-s8vector"
+ (equal? (list->s8vector '(7 7 7 7))
+ (make-s8vector 4 7))))
(with-test-prefix "u16 vectors"
@@ -106,7 +122,15 @@
(pass-if "u16vector->list/list->u16vector"
(equal? (u16vector->list (u16vector 1 2 3 4))
- (u16vector->list (list->u16vector '(1 2 3 4))))))
+ (u16vector->list (list->u16vector '(1 2 3 4)))))
+
+ (pass-if "u16vector->list/uniform-vector->list"
+ (equal? (u16vector->list (u16vector 1 2 3 4))
+ (uniform-vector->list (u16vector 1 2 3 4))))
+
+ (pass-if "make-u16vector"
+ (equal? (list->u16vector '(7 7 7 7))
+ (make-u16vector 4 7))))
(with-test-prefix "s16 vectors"
@@ -135,7 +159,15 @@
(pass-if "s16vector->list/list->s16vector"
(equal? (s16vector->list (s16vector 1 2 3 4))
- (s16vector->list (list->s16vector '(1 2 3 4))))))
+ (s16vector->list (list->s16vector '(1 2 3 4)))))
+
+ (pass-if "s16vector->list/uniform-vector->list"
+ (equal? (s16vector->list (s16vector 1 2 3 4))
+ (uniform-vector->list (s16vector 1 2 3 4))))
+
+ (pass-if "make-s16vector"
+ (equal? (list->s16vector '(7 7 7 7))
+ (make-s16vector 4 7))))
(with-test-prefix "u32 vectors"
@@ -164,7 +196,15 @@
(pass-if "u32vector->list/list->u32vector"
(equal? (u32vector->list (u32vector 1 2 3 4))
- (u32vector->list (list->u32vector '(1 2 3 4))))))
+ (u32vector->list (list->u32vector '(1 2 3 4)))))
+
+ (pass-if "u32vector->list/uniform-vector->list"
+ (equal? (u32vector->list (u32vector 1 2 3 4))
+ (uniform-vector->list (u32vector 1 2 3 4))))
+
+ (pass-if "make-u32vector"
+ (equal? (list->u32vector '(7 7 7 7))
+ (make-u32vector 4 7))))
(with-test-prefix "s32 vectors"
@@ -193,7 +233,15 @@
(pass-if "s32vector->list/list->s32vector"
(equal? (s32vector->list (s32vector 1 2 3 4))
- (s32vector->list (list->s32vector '(1 2 3 4))))))
+ (s32vector->list (list->s32vector '(1 2 3 4)))))
+
+ (pass-if "s32vector->list/uniform-vector->list"
+ (equal? (s32vector->list (s32vector 1 2 3 4))
+ (uniform-vector->list (s32vector 1 2 3 4))))
+
+ (pass-if "make-s32vector"
+ (equal? (list->s32vector '(7 7 7 7))
+ (make-s32vector 4 7))))
(with-test-prefix "u64 vectors"
@@ -222,7 +270,15 @@
(pass-if "u64vector->list/list->u64vector"
(equal? (u64vector->list (u64vector 1 2 3 4))
- (u64vector->list (list->u64vector '(1 2 3 4))))))
+ (u64vector->list (list->u64vector '(1 2 3 4)))))
+
+ (pass-if "u64vector->list/uniform-vector->list"
+ (equal? (u64vector->list (u64vector 1 2 3 4))
+ (uniform-vector->list (u64vector 1 2 3 4))))
+
+ (pass-if "make-u64vector"
+ (equal? (list->u64vector '(7 7 7 7))
+ (make-u64vector 4 7))))
(with-test-prefix "s64 vectors"
@@ -251,7 +307,15 @@
(pass-if "s64vector->list/list->s64vector"
(equal? (s64vector->list (s64vector 1 2 3 4))
- (s64vector->list (list->s64vector '(1 2 3 4))))))
+ (s64vector->list (list->s64vector '(1 2 3 4)))))
+
+ (pass-if "s64vector->list/uniform-vector->list"
+ (equal? (s64vector->list (s64vector 1 2 3 4))
+ (uniform-vector->list (s64vector 1 2 3 4))))
+
+ (pass-if "make-s64vector"
+ (equal? (list->s64vector '(7 7 7 7))
+ (make-s64vector 4 7))))
(with-test-prefix "f32 vectors"
@@ -280,7 +344,15 @@
(pass-if "f32vector->list/list->f32vector"
(equal? (f32vector->list (f32vector 1 2 3 4))
- (f32vector->list (list->f32vector '(1 2 3 4))))))
+ (f32vector->list (list->f32vector '(1 2 3 4)))))
+
+ (pass-if "f32vector->list/uniform-vector->list"
+ (equal? (f32vector->list (f32vector 1 2 3 4))
+ (uniform-vector->list (f32vector 1 2 3 4))))
+
+ (pass-if "make-f32vector"
+ (equal? (list->f32vector '(7 7 7 7))
+ (make-f32vector 4 7))))
(with-test-prefix "f64 vectors"
@@ -309,4 +381,12 @@
(pass-if "f64vector->list/list->f64vector"
(equal? (f64vector->list (f64vector 1 2 3 4))
- (f64vector->list (list->f64vector '(1 2 3 4))))))
+ (f64vector->list (list->f64vector '(1 2 3 4)))))
+
+ (pass-if "f64vector->list/uniform-vector->list"
+ (equal? (f64vector->list (f64vector 1 2 3 4))
+ (uniform-vector->list (f64vector 1 2 3 4))))
+
+ (pass-if "make-f64vector"
+ (equal? (list->f64vector '(7 7 7 7))
+ (make-f64vector 4 7))))
diff --git a/test-suite/tests/srfi-88.test b/test-suite/tests/srfi-88.test
index b879941..07b9e43 100644
--- a/test-suite/tests/srfi-88.test
+++ b/test-suite/tests/srfi-88.test
@@ -1,7 +1,7 @@
-;;;; srfi-88.test --- Test suite for SRFI-88 -*- Scheme -*-
-;;;; Ludovic Courtès <address@hidden>
+;;;; srfi-88.test --- SRFI-88. -*- mode: scheme; coding: utf-8; -*-
+;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2010 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
@@ -51,8 +51,3 @@
;; `#{extended symbol}#:'.
(string=? ""
(keyword->string (string->keyword "")))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index f8cb0b4..a645ddc 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 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,6 +19,7 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
+ #:use-module ((system base compile) #:select (compile))
#:use-module (srfi srfi-9))
@@ -35,10 +36,21 @@
(with-test-prefix "constructor"
+ ;; Constructors are defined using `define-integrable', meaning that direct
+ ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the
+ ;; distinction below.
+
+ (pass-if-exception "foo 0 args (inline)" exception:syntax-pattern-unmatched
+ (compile '(make-foo) #:env (current-module)))
+ (pass-if-exception "foo 2 args (inline)" exception:syntax-pattern-unmatched
+ (compile '(make-foo 1 2) #:env (current-module)))
+
(pass-if-exception "foo 0 args" exception:wrong-num-args
- (make-foo))
+ (let ((make-foo make-foo))
+ (make-foo)))
(pass-if-exception "foo 2 args" exception:wrong-num-args
- (make-foo 1 2)))
+ (let ((make-foo make-foo))
+ (make-foo 1 2))))
(with-test-prefix "predicate"
diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test
new file mode 100644
index 0000000..22fce32
--- /dev/null
+++ b/test-suite/tests/statprof.test
@@ -0,0 +1,111 @@
+;; guile-lib -*- scheme -*-
+;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, contact:
+;;
+;; Free Software Foundation Voice: +1-617-542-5942
+;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
+;; Boston, MA 02111-1307, USA address@hidden
+
+;;; Commentary:
+;;
+;; Unit tests for (debugging statprof).
+;;
+;;; Code:
+
+(define-module (test-suite test-statprof)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (srfi srfi-1)
+ #:use-module (statprof))
+
+;; FIXME
+(debug-enable 'debug)
+(trap-enable 'traps)
+
+(pass-if "statistical sample counts within expected range"
+ (let ()
+ ;; test to see that if we call 3 identical functions equally, they
+ ;; show up equally in the call count, +/- 30%. it's a big range, and
+ ;; I tried to do something more statistically valid, but failed (for
+ ;; the moment).
+
+ ;; make sure these are compiled so we're not swamped in `eval'
+ (define (make-func)
+ (compile '(lambda (n)
+ (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))))
+ (define run-test
+ (compile '(lambda (num-calls funcs)
+ (let loop ((x num-calls) (funcs funcs))
+ (cond
+ ((positive? x)
+ ((car funcs) x)
+ (loop (- x 1) (cdr funcs))))))))
+
+ (let ((num-calls 40000)
+ (funcs (circular-list (make-func) (make-func) (make-func))))
+
+ ;; Run test. 10000 us == 100 Hz.
+ (statprof-reset 0 10000 #f #f)
+ (statprof-start)
+ (run-test num-calls funcs)
+ (statprof-stop)
+
+ (let* ((a-data (statprof-proc-call-data (car funcs)))
+ (b-data (statprof-proc-call-data (cadr funcs)))
+ (c-data (statprof-proc-call-data (caddr funcs)))
+ (samples (map statprof-call-data-cum-samples
+ (list a-data b-data c-data)))
+ (average (/ (apply + samples) 3))
+ (max-allowed-drift 0.30) ; 30%
+ (diffs (map (lambda (x) (abs (- x average)))
+ samples))
+ (max-diff (apply max diffs)))
+
+ (let ((drift-fraction (/ max-diff average)))
+ (or (< drift-fraction max-allowed-drift)
+ ;; don't stop the the test suite for what statistically is
+ ;; bound to happen.
+ (throw 'unresolved (pk average drift-fraction))))))))
+
+(pass-if "accurate call counting"
+ (let ()
+ ;; Test to see that if we call a function N times while the profiler
+ ;; is active, it shows up N times.
+ (let ((num-calls 200))
+
+ (define (do-nothing n)
+ (simple-format #f "FOO ~A\n" (+ n n)))
+
+ (throw 'unresolved) ;; need to fix VM tracing.
+
+ ;; Run test.
+ (statprof-reset 0 50000 #t #f)
+ (statprof-start)
+ (let loop ((x num-calls))
+ (cond
+ ((positive? x)
+ (do-nothing x)
+ (loop (- x 1))
+ #t)))
+ (statprof-stop)
+
+ ;;(statprof-display)
+
+ ;; Check result.
+ (let ((proc-data (statprof-proc-call-data do-nothing)))
+ (and proc-data
+ (= (statprof-call-data-calls proc-data)
+ num-calls))))))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index 013c1a8..e04c026 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -221,9 +221,13 @@
(pass-if "R5RS backslash escapes"
(string=? "\"\\" (string #\" #\\)))
+ (pass-if "R6RS backslash escapes"
+ (string=? "\a\b\t\n\v\f\r"
+ (string #\alarm #\backspace #\tab #\newline #\vtab
+ #\page #\return)))
+
(pass-if "Guile extensions backslash escapes"
- (string=? "\0\a\f\n\r\t\v"
- (apply string (map integer->char '(0 7 12 10 13 9 11))))))
+ (string=? "\0" (string #\nul))))
;;
;; string?
@@ -386,6 +390,46 @@
(string-ci>=? (string-ints 0) (string-ints 255)))))
;;
+;; Unicode string normalization forms
+;;
+
+;;
+;; string-normalize-nfd
+;;
+
+(with-test-prefix "string-normalize-nfd"
+
+ (pass-if "canonical decomposition is equal?"
+ (equal? (string-normalize-nfd "\xe9") "\x65\u0301")))
+
+;;
+;; string-normalize-nfkd
+;;
+
+(with-test-prefix "string-normalize-nfkd"
+
+ (pass-if "compatibility decomposition is equal?"
+ (equal? (string-normalize-nfkd "\u1e9b\u0323") "s\u0323\u0307")))
+
+;;
+;; string-normalize-nfc
+;;
+
+(with-test-prefix "string-normalize-nfc"
+
+ (pass-if "canonical composition is equal?"
+ (equal? (string-normalize-nfc "\x65\u0301") "\xe9")))
+
+;;
+;; string-normalize-nfkc
+;;
+
+(with-test-prefix "string-normalize-nfkc"
+
+ (pass-if "compatibility composition is equal?"
+ (equal? (string-normalize-nfkc "\u1e9b\u0323") "\u1e69")))
+
+;;
;; string-ref
;;
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 2c2ca0c..55e0807 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -1,7 +1,7 @@
-;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
-;;;; Ludovic Courtès <address@hidden>, 2006-06-12.
+;;;; structs.test --- Structures. -*- mode: scheme; coding: utf-8; -*-
+;;;; Ludovic Courtès <address@hidden>, 2006-06-12.
;;;;
-;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010 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
@@ -80,9 +80,33 @@
(pass-if "struct-set!"
(let ((ball (make-ball green "Bob")))
(set-owner! ball "Bill")
- (string=? (owner ball) "Bill"))))
+ (string=? (owner ball) "Bill")))
+ (pass-if "struct-ref"
+ (let ((ball (make-ball red "Alice")))
+ (equal? (struct-ref ball 0) "Alice")))
+ (pass-if "struct-set!"
+ (let* ((v (make-vtable "pw"))
+ (s (make-struct v 0))
+ (r (struct-set! s 0 'a)))
+ (eq? r
+ (struct-ref s 0)
+ 'a)))
+
+ (pass-if-exception "struct-ref out-of-range"
+ exception:out-of-range
+ (let* ((v (make-vtable "prpr"))
+ (s (make-struct v 0 'a 'b)))
+ (struct-ref s 2)))
+
+ (pass-if-exception "struct-set! out-of-range"
+ exception:out-of-range
+ (let* ((v (make-vtable "pwpw"))
+ (s (make-struct v 0 'a 'b)))
+ (struct-set! s 2 'c))))
+
+
(with-test-prefix "equal?"
(pass-if "simple structs"
@@ -153,8 +177,3 @@
(lambda (port)
(display struct port)))))
(equal? str "hello")))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
diff --git a/test-suite/tests/sxml.fold.test b/test-suite/tests/sxml.fold.test
new file mode 100644
index 0000000..6daa649
--- /dev/null
+++ b/test-suite/tests/sxml.fold.test
@@ -0,0 +1,210 @@
+;;;; sxml.fold.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml fold).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-fold)
+ #:use-module (test-suite lib)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (sxml fold))
+
+(define atom? (@@ (sxml fold) atom?))
+(define (id x) x)
+(define-syntax accept
+ (syntax-rules ()
+ ((_ expr)
+ (call-with-values (lambda () expr) list))))
+
+(with-test-prefix "test-fold"
+ (define test-doc
+ '(presentation
+ (@ (width 1024)
+ (height 768)
+ (title-style "font-family:Georgia")
+ (title-height 72)
+ (title-baseline-y 96)
+ (title-x 48)
+ (text-height 64)
+ (text-style "font-family:Georgia")
+ (text-upper-left-x 96)
+ (text-upper-left-y 216))
+ (slide
+ (@ (title "Declarative interface"))
+ (p "The declarative interface"
+ "lets you be more concise"
+ "when making the slides."))
+ (slide
+ (@ (title "Still cumbersome"))
+ (p "Parentheses are still"
+ "cumbersome."))))
+
+ (pass-if (atom? 'foo))
+ (pass-if (atom? '()))
+ (pass-if (not (atom? '(1 2 3))))
+
+ (pass-if "foldt identity"
+ (equal? (foldt id id test-doc) test-doc))
+
+ (pass-if "fold cons == reverse"
+ (equal? (fold cons '() test-doc)
+ (reverse test-doc)))
+
+ (pass-if "foldts identity"
+ (equal? (foldts (lambda (seed tree) '())
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)
+ (cons test-doc '())))
+
+ (pass-if "foldts* identity"
+ (equal? (foldts* (lambda (seed tree) (values '() tree))
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)
+ (cons test-doc '())))
+
+ (pass-if "fold-values == fold"
+ (equal? (fold-values cons test-doc '())
+ (fold cons '() test-doc)))
+
+ (pass-if "foldts*-values == foldts*"
+ (equal? (foldts*-values
+ (lambda (tree seed) (values tree '()))
+ (lambda (tree seed kid-seed)
+ (cons (reverse kid-seed) seed))
+ (lambda (tree seed)
+ (cons tree seed))
+ test-doc
+ '())
+ (foldts* (lambda (seed tree) (values '() tree))
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)))
+
+ (let ()
+ (define (replace pred val list)
+ (reverse
+ (fold
+ (lambda (x xs)
+ (cons (if (pred x) val x) xs))
+ '()
+ list)))
+
+ (define (car-eq? x what)
+ (and (pair? x) (eq? (car x) what)))
+
+ ;; avoid entering <slide>
+ (pass-if "foldts* *pre* behaviour"
+ (equal? (foldts*-values
+ (lambda (tree seed)
+ (values (if (car-eq? tree 'slide) '() tree) '()))
+ (lambda (tree seed kid-seed)
+ (cons (reverse kid-seed) seed))
+ (lambda (tree seed)
+ (cons tree seed))
+ test-doc
+ '())
+ (cons
+ (replace (lambda (x) (car-eq? x 'slide))
+ '()
+ test-doc)
+ '()))))
+
+ (let ()
+ (define (all-elts tree)
+ (reverse!
+ (foldts*-values
+ (lambda (tree seed)
+ (values tree seed))
+ (lambda (tree seed kid-seed)
+ kid-seed)
+ (lambda (tree seed)
+ (cons tree seed))
+ tree
+ '())))
+
+ (define (len tree)
+ (foldts*-values
+ (lambda (tree seed)
+ (values tree seed))
+ (lambda (tree seed kid-seed)
+ kid-seed)
+ (lambda (tree seed)
+ (1+ seed))
+ tree
+ 0))
+
+ (pass-if "foldts length"
+ (equal? (length (all-elts test-doc))
+ (len test-doc)))))
+
+(with-test-prefix "test-fold-layout"
+ (define test-doc
+ '(presentation
+ (@ (width 1024)
+ (height 768)
+ (title-style "font-family:Georgia")
+ (title-height 72)
+ (title-baseline-y 96)
+ (title-x 48)
+ (text-height 64)
+ (text-style "font-family:Georgia")
+ (text-upper-left-x 96)
+ (text-upper-left-y 216))
+ (slide
+ (@ (title "Declarative interface"))
+ (p "The declarative interface"
+ "lets you be more concise"
+ "when making the slides."))
+ (slide
+ (@ (title "Still cumbersome"))
+ (p "Parentheses are still"
+ "cumbersome."))))
+
+ (define (identity-layout tree)
+ (fold-layout
+ tree
+ `((*default*
+ . ,(lambda (tag params old-layout layout kids)
+ (values layout
+ (if (null? (car params))
+ (cons tag kids)
+ (cons* tag (cons '@ (car params)) kids)))))
+ (*text*
+ . ,(lambda (text params layout)
+ (values layout text))))
+ '()
+ (cons 0 0)
+ '()))
+
+ (pass-if "fold-layout"
+ (equal? (accept (identity-layout test-doc))
+ (list test-doc (cons 0 0)))))
diff --git a/test-suite/tests/sxml.ssax.test b/test-suite/tests/sxml.ssax.test
new file mode 100644
index 0000000..63984b8
--- /dev/null
+++ b/test-suite/tests/sxml.ssax.test
@@ -0,0 +1,140 @@
+;;;; sxml.ssax.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2002,2003,2004 Oleg Kiselyov <oleg at pobox dot com>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml ssax). You can tweak this harness to get more
+;; debugging information, but in the end I just wanted to keep Oleg's
+;; tests in the file and see if we could work with them directly.
+;;
+;;; Code:
+
+(define-module (test-suite sxml-ssax)
+ #:use-module (sxml ssax input-parse)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:use-module (sxml ssax)
+ #:use-module (ice-9 pretty-print))
+
+(define pp pretty-print)
+
+(define-macro (import module . symbols)
+ `(begin
+ ,@(map (lambda (sym)
+ `(module-define! (current-module) ',sym (module-ref
(resolve-module ',module) ',sym)))
+ symbols)))
+
+;; This list was arrived at over time. See the problem is that SSAX's
+;; test cases are inline with its text, and written in the private
+;; language of SSAX. That is to say, they use procedures that (sxml
+;; ssax) doesn't export. So here we test that the procedures from (sxml
+;; ssax) actually work, but in order to do so we have to pull in private
+;; definitions. It's not the greatest solution, but it's what we got.
+(import (sxml ssax)
+ ssax:read-NCName
+ ssax:read-QName
+ ssax:largest-unres-name
+ ssax:Prefix-XML
+ ssax:resolve-name
+ ssax:scan-Misc
+ ssax:assert-token
+ ssax:handle-parsed-entity
+ ssax:warn
+ ssax:skip-pi
+ ssax:S-chars
+ ssax:skip-S
+ ssax:ncname-starting-char?
+ ssax:define-labeled-arg-macro
+ let*-values
+ ssax:make-parser/positional-args
+ when
+ make-xml-token
+ nl
+ ;unesc-string
+ parser-error
+ ascii->char
+ char->ascii
+ char-newline
+ char-return
+ char-tab
+ name-compare)
+
+(define (cout . args)
+ "Similar to @code{cout << arguments << args}, where @var{argument} can
+be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
+called without args rather than printed."
+ (for-each (lambda (x)
+ (if (procedure? x) (x) (display x)))
+ args))
+
+(define (cerr . args)
+ "Similar to @code{cerr << arguments << args}, where @var{argument} can
+be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
+called without args rather than printed."
+ (format (current-ssax-error-port)
+ ";;; SSAX warning: ~a\n" args))
+
+(define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+(define-syntax failed?
+ (syntax-rules ()
+ ((_ e ...)
+ (not (false-if-exception (begin e ... #t))))))
+
+(define *saved-port* (current-output-port))
+
+(define-syntax assert
+ (syntax-rules ()
+ ((assert expr ...)
+ (with-output-to-port *saved-port*
+ (lambda ()
+ (pass-if '(and expr ...)
+ (let* ((out (open-output-string))
+ (res (with-output-to-port out
+ (lambda ()
+ (with-ssax-error-to-port (current-output-port)
+ (lambda ()
+ (and expr ...)))))))
+ ;; (get-output-string out)
+ res)))))))
+
+(define (load-tests file)
+ (with-input-from-file (%search-load-path file)
+ (lambda ()
+ (let loop ((sexp (read)))
+ (cond
+ ((eof-object? sexp))
+ ((and (pair? sexp) (pair? (cdr sexp))
+ (eq? (cadr sexp) 'run-test))
+ (primitive-eval sexp)
+ (loop (read)))
+ ((and (pair? sexp) (eq? (car sexp) 'run-test))
+ (primitive-eval sexp)
+ (loop (read)))
+ (else
+ (loop (read))))))))
+
+(with-output-to-string
+ (lambda ()
+ (load-tests "sxml/upstream/SSAX.scm")))
diff --git a/test-suite/tests/sxml.transform.test
b/test-suite/tests/sxml.transform.test
new file mode 100644
index 0000000..72c7abf
--- /dev/null
+++ b/test-suite/tests/sxml.transform.test
@@ -0,0 +1,99 @@
+;;;; sxml.transform.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2002,2003,2004 Oleg Kiselyov <oleg at pobox dot com>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml transform).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-transform)
+ #:use-module (test-suite lib)
+ #:use-module (sxml transform))
+
+(let* ((tree '(root (n1 (n11) "s12" (n13))
+ "s2"
+ (n2 (n21) "s22")
+ (n3 (n31 (n311))
+ "s32"
+ (n33 (n331) "s332" (n333))
+ "s34"))))
+ (define (test pred-begin pred-end expected)
+ (pass-if expected
+ (equal? expected (car (replace-range pred-begin pred-end (list tree))))))
+
+ ;; Remove one node, "s2"
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '()))
+ (lambda (node) (list node))
+ '(root (n1 (n11) "s12" (n13))
+ (n2 (n21) "s22")
+ (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))
+
+ ;; Replace one node, "s2" with "s2-new"
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '("s2-new")))
+ (lambda (node) (list node))
+ '(root (n1 (n11) "s12" (n13))
+ "s2-new"
+ (n2 (n21) "s22")
+ (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))
+
+ ;; Replace one node, "s2" with "s2-new" and its brother (n-new "s")
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '("s2-new" (n-new "s"))))
+ (lambda (node) (list node))
+ '(root (n1 (n11) "s12" (n13))
+ "s2-new" (n-new "s")
+ (n2 (n21) "s22")
+ (n3 (n31 (n311)) "s32" (n33 (n331) "s332" (n333)) "s34")))
+
+ ;; Remove everything from "s2" onward
+ (test
+ (lambda (node)
+ (and (equal? node "s2") '()))
+ (lambda (node) #f)
+ '(root (n1 (n11) "s12" (n13))))
+
+ ;; Remove everything from "n1" onward
+ (test
+ (lambda (node)
+ (and (pair? node) (eq? 'n1 (car node)) '()))
+ (lambda (node) #f)
+ '(root))
+
+ ;; Replace from n1 through n33
+ (test
+ (lambda (node)
+ (and (pair? node)
+ (eq? 'n1 (car node))
+ (list node '(n1* "s12*"))))
+ (lambda (node)
+ (and (pair? node)
+ (eq? 'n33 (car node))
+ (list node)))
+ '(root
+ (n1 (n11) "s12" (n13))
+ (n1* "s12*")
+ (n3
+ (n33 (n331) "s332" (n333))
+ "s34"))))
diff --git a/test-suite/tests/sxml.xpath.test b/test-suite/tests/sxml.xpath.test
new file mode 100644
index 0000000..0d64539
--- /dev/null
+++ b/test-suite/tests/sxml.xpath.test
@@ -0,0 +1,698 @@
+;;;; sxml.xpath.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2002,2003,2004 Oleg Kiselyov <oleg at pobox dot com>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml xpath).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-xpath)
+ #:use-module (test-suite lib)
+ #:use-module (sxml xpath))
+
+(define tree1
+ '(html
+ (head (title "Slides"))
+ (body
+ (p (@ (align "center"))
+ (table (@ (style "font-size: x-large"))
+ (tr
+ (td (@ (align "right")) "Talks ")
+ (td (@ (align "center")) " = ")
+ (td " slides + transition"))
+ (tr (td)
+ (td (@ (align "center")) " = ")
+ (td " data + control"))
+ (tr (td)
+ (td (@ (align "center")) " = ")
+ (td " programs"))))
+ (ul
+ (li (a (@ (href "slides/slide0001.gif")) "Introduction"))
+ (li (a (@ (href "slides/slide0010.gif")) "Summary")))
+ )))
+
+
+;; Example from a posting "Re: DrScheme and XML",
+;; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
+;; http://www.deja.com/getdoc.xp?AN=553507805
+(define tree3
+ '(poem (@ (title "The Lovesong of J. Alfred Prufrock")
+ (poet "T. S. Eliot"))
+ (stanza
+ (line "Let us go then, you and I,")
+ (line "When the evening is spread out against the sky")
+ (line "Like a patient etherized upon a table:"))
+ (stanza
+ (line "In the room the women come and go")
+ (line "Talking of Michaelangelo."))))
+
+(define (run-test selector node expected)
+ (pass-if expected
+ (equal? expected (selector node))))
+
+(with-test-prefix "test-all"
+
+
+ ;; Location path, full form: child::para
+ ;; Location path, abbreviated form: para
+ ;; selects the para element children of the context node
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
+ )
+ (expected '((para (@) "para") (para (@) "second par")))
+ )
+ (run-test (select-kids (node-typeof? 'para)) tree expected)
+ (run-test (sxpath '(para)) tree expected))
+
+ ;; Location path, full form: child::*
+ ;; Location path, abbreviated form: *
+ ;; selects all element children of the context node
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected
+ '((para (@) "para") (br (@)) (para "second par")))
+ )
+ (run-test (select-kids (node-typeof? '*)) tree expected)
+ (run-test (sxpath '(*)) tree expected))
+
+ ;; Location path, full form: child::text()
+ ;; Location path, abbreviated form: text()
+ ;; selects all text node children of the context node
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected
+ '("cdata"))
+ )
+ (run-test (select-kids (node-typeof? '*text*)) tree expected)
+ (run-test (sxpath '(*text*)) tree expected))
+
+ ;; Location path, full form: child::node()
+ ;; Location path, abbreviated form: node()
+ ;; selects all the children of the context node, whatever their node type
+ (let* ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+ )
+ (expected (cdr tree))
+ )
+ (run-test (select-kids (node-typeof? '*any*)) tree expected)
+ (run-test (sxpath '(*any*)) tree expected)
+ )
+
+ ;; Location path, full form: child::*/child::para
+ ;; Location path, abbreviated form: */para
+ ;; selects all para grandchildren of the context node
+
+ (let ((tree
+ '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para "third para")))
+ )
+ (expected
+ '((para "third para")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '*))
+ (select-kids (node-typeof? 'para)))
+ tree expected)
+ (run-test (sxpath '(* para)) tree expected)
+ )
+
+
+ ;; Location path, full form: attribute::name
+ ;; Location path, abbreviated form: @name
+ ;; selects the 'name' attribute of the context node
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para (@) "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((name "elem")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'name)))
+ tree expected)
+ (run-test (sxpath '(@ name)) tree expected)
+ )
+
+ ;; Location path, full form: attribute::*
+ ;; Location path, abbreviated form: @*
+ ;; selects all the attributes of the context node
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((name "elem") (id "idz")))
+ )
+ (run-test
+ (node-join (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? '*)))
+ tree expected)
+ (run-test (sxpath '(@ *)) tree expected)
+ )
+
+
+ ;; Location path, full form: descendant::para
+ ;; Location path, abbreviated form: .//para
+ ;; selects the para element descendants of the context node
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para (@) "para") (para "second par") (para (@) "third para")))
+ )
+ (run-test
+ (node-closure (node-typeof? 'para))
+ tree expected)
+ (run-test (sxpath '(// para)) tree expected)
+ )
+
+ ;; Location path, full form: self::para
+ ;; Location path, abbreviated form: _none_
+ ;; selects the context node if it is a para element; otherwise selects
nothing
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ )
+ (run-test (node-self (node-typeof? 'para)) tree '())
+ (run-test (node-self (node-typeof? 'elem)) tree (list tree))
+ )
+
+ ;; Location path, full form: descendant-or-self::node()
+ ;; Location path, abbreviated form: //
+ ;; selects the context node, all the children (including attribute nodes)
+ ;; of the context node, and all the children of all the (element)
+ ;; descendants of the context node.
+ ;; This is _almost_ a powerset of the context node.
+ (let* ((tree
+ '(para (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ (cons tree
+ (append (cdr tree)
+ '((@) "para" (@) "second par"
+ (@ (name "aa")) (para (@) "third para")
+ (@) "third para"))))
+ )
+ (run-test
+ (node-or
+ (node-self (node-typeof? '*any*))
+ (node-closure (node-typeof? '*any*)))
+ tree expected)
+ (run-test (sxpath '(//)) tree expected)
+ )
+
+ ;; Location path, full form: ancestor::div
+ ;; Location path, abbreviated form: _none_
+ ;; selects all div ancestors of the context node
+ ;; This Location expression is equivalent to the following:
+ ;
/descendant-or-self::div[descendant::node() = curr_node]
+ ;; This shows that the ancestor:: axis is actually redundant. Still,
+ ;; it can be emulated as the following SXPath expression demonstrates.
+
+ ;; The insight behind "ancestor::div" -- selecting all "div" ancestors
+ ;; of the current node -- is
+ ;; S[ancestor::div] context_node =
+ ;; { y | y=subnode*(root), context_node=subnode(subnode*(y)),
+ ;; isElement(y), name(y) = "div" }
+ ;; We observe that
+ ;; { y | y=subnode*(root), pred(y) }
+ ;; can be expressed in SXPath as
+ ;; ((node-or (node-self pred) (node-closure pred)) root-node)
+ ;; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to
+ ;; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
+ ;; context_node=subnode(subnode*(y)) is tantamount to
+ ;; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
+ ;; the composition of converters-predicates in the filtering context.
+
+ (let*
+ ((root
+ '(div (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para (@) "second par")
+ (div (@ (name "aa")) (para (@) "third para"))))
+ (context-node ; /descendant::any()[child::text() == "third para"]
+ (car
+ ((node-closure
+ (select-kids
+ (node-equal? "third para")))
+ root)))
+ (pred
+ (node-reduce (node-self (node-typeof? 'div))
+ (node-closure (node-eq? context-node))
+ ))
+ )
+ (run-test
+ (node-or
+ (node-self pred)
+ (node-closure pred))
+ root
+ (cons root
+ '((div (@ (name "aa")) (para (@) "third para")))))
+ )
+
+
+
+ ;; Location path, full form: child::div/descendant::para
+ ;; Location path, abbreviated form: div//para
+ ;; selects the para element descendants of the div element
+ ;; children of the context node
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")
+ (div (para "fourth para"))))
+ )
+ (expected
+ '((para (@) "third para") (para "fourth para")))
+ )
+ (run-test
+ (node-join
+ (select-kids (node-typeof? 'div))
+ (node-closure (node-typeof? 'para)))
+ tree expected)
+ (run-test (sxpath '(div // para)) tree expected)
+ )
+
+
+ ;; Location path, full form: /descendant::olist/child::item
+ ;; Location path, abbreviated form: //olist/item
+ ;; selects all the item elements that have an olist parent (which is not
root)
+ ;; and that are in the same document as the context node
+ ;; See the following test.
+
+ ;; Location path, full form: /descendant::td/attribute::align
+ ;; Location path, abbreviated form: //td/@align
+ ;; Selects 'align' attributes of all 'td' elements in tree1
+ (let ((tree tree1)
+ (expected
+ '((align "right") (align "center") (align "center") (align "center"))
+ ))
+ (run-test
+ (node-join
+ (node-closure (node-typeof? 'td))
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'align)))
+ tree expected)
+ (run-test (sxpath '(// td @ align)) tree expected)
+ )
+
+
+ ;; Location path, full form: /descendant::td[attribute::align]
+ ;; Location path, abbreviated form: //address@hidden
+ ;; Selects all td elements that have an attribute 'align' in tree1
+ (let ((tree tree1)
+ (expected
+ '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
+ (td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
+ ))
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'align)))))
+ tree expected)
+ (run-test (sxpath `(// td ,(node-self (sxpath '(@ align))))) tree
expected)
+ (run-test (sxpath '(// (td (@ align)))) tree expected)
+ (run-test (sxpath '(// ((td) (@ align)))) tree expected)
+ ;; note! (sxpath ...) is a converter. Therefore, it can be used
+ ;; as any other converter, for example, in the full-form SXPath.
+ ;; Thus we can mix the full and abbreviated form SXPath's freely.
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (sxpath '(@ align))))
+ tree expected)
+ )
+
+
+ ;; Location path, full form: /descendant::td[attribute::align = "right"]
+ ;; Location path, abbreviated form: //address@hidden = "right"]
+ ;; Selects all td elements that have an attribute align = "right" in tree1
+ (let ((tree tree1)
+ (expected
+ '((td (@ (align "right")) "Talks "))
+ ))
+ (run-test
+ (node-reduce
+ (node-closure (node-typeof? 'td))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(align "right"))))))
+ tree expected)
+ (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
+ )
+
+ ;; Location path, full form: child::para[position()=1]
+ ;; Location path, abbreviated form: para[1]
+ ;; selects the first para child of the context node
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para (@) "para"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos 1))
+ tree expected)
+ (run-test (sxpath '((para 1))) tree expected)
+ )
+
+ ;; Location path, full form: child::para[position()=last()]
+ ;; Location path, abbreviated form: para[last()]
+ ;; selects the last para child of the context node
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (expected
+ '((para "second par"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos -1))
+ tree expected)
+ (run-test (sxpath '((para -1))) tree expected)
+ )
+
+ ;; Illustrating the following Note of Sec 2.5 of XPath:
+ ;; "NOTE: The location path //para[1] does not mean the same as the
+ ;; location path /descendant::para[1]. The latter selects the first
+ ;; descendant para element; the former selects all descendant para
+ ;; elements that are the first para children of their parents."
+
+ (let ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ )
+ (run-test
+ (node-reduce ; /descendant::para[1] in SXPath
+ (node-closure (node-typeof? 'para))
+ (node-pos 1))
+ tree '((para (@) "para")))
+ (run-test (sxpath '(// (para 1))) tree
+ '((para (@) "para") (para (@) "third para")))
+ )
+
+ ;; Location path, full form: parent::node()
+ ;; Location path, abbreviated form: ..
+ ;; selects the parent of the context node. The context node may be
+ ;; an attribute node!
+ ;; For the last test:
+ ;; Location path, full form: parent::*/attribute::name
+ ;; Location path, abbreviated form: ../@name
+ ;; Selects the name attribute of the parent of the context node
+
+ (let* ((tree
+ '(elem (@ (name "elem") (id "idz"))
+ (para (@) "para") (br (@)) "cdata" (para "second par")
+ (div (@ (name "aa")) (para (@) "third para")))
+ )
+ (para1 ; the first para node
+ (car ((sxpath '(para)) tree)))
+ (para3 ; the third para node
+ (car ((sxpath '(div para)) tree)))
+ (div ; div node
+ (car ((sxpath '(// div)) tree)))
+ )
+ (run-test
+ (node-parent tree)
+ para1 (list tree))
+ (run-test
+ (node-parent tree)
+ para3 (list div))
+ (run-test ; checking the parent of an attribute node
+ (node-parent tree)
+ ((sxpath '(@ name)) div) (list div))
+ (run-test
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? '@))
+ (select-kids (node-typeof? 'name)))
+ para3 '((name "aa")))
+ (run-test
+ (sxpath `(,(node-parent tree) @ name))
+ para3 '((name "aa")))
+ )
+
+ ;; Location path, full form: following-sibling::chapter[position()=1]
+ ;; Location path, abbreviated form: none
+ ;; selects the next chapter sibling of the context node
+ ;; The path is equivalent to
+ ;; let cnode = context-node
+ ;; in
+ ;; parent::* / child::chapter [take-after node_eq(self::*,cnode)]
+ ;; [position()=1]
+ (let* ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (chapter (@ (id "four")) "Chap 4 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (a-node ; to be used as a context node
+ (car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
+ (expected
+ '((chapter (@ (id "three")) "Chap 3 text")))
+ )
+ (run-test
+ (node-reduce
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? 'chapter)))
+ (take-after (node-eq? a-node))
+ (node-pos 1)
+ )
+ a-node expected)
+ )
+
+ ;; preceding-sibling::chapter[position()=1]
+ ;; selects the previous chapter sibling of the context node
+ ;; The path is equivalent to
+ ;; let cnode = context-node
+ ;; in
+ ;; parent::* / child::chapter [take-until node_eq(self::*,cnode)]
+ ;; [position()=-1]
+ (let* ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (chapter (@ (id "four")) "Chap 4 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (a-node ; to be used as a context node
+ (car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
+ (expected
+ '((chapter (@ (id "two")) "Chap 2 text")))
+ )
+ (run-test
+ (node-reduce
+ (node-join
+ (node-parent tree)
+ (select-kids (node-typeof? 'chapter)))
+ (take-until (node-eq? a-node))
+ (node-pos -1)
+ )
+ a-node expected)
+ )
+
+
+ ;; /descendant::figure[position()=42]
+ ;; selects the forty-second figure element in the document
+ ;; See the next example, which is more general.
+
+ ;; Location path, full form:
+ ;; child::table/child::tr[position()=2]/child::td[position()=3]
+ ;; Location path, abbreviated form: table/tr[2]/td[3]
+ ;; selects the third td of the second tr of the table
+ (let ((tree ((node-closure (node-typeof? 'p)) tree1))
+ (expected
+ '((td " data + control"))
+ ))
+ (run-test
+ (node-join
+ (select-kids (node-typeof? 'table))
+ (node-reduce (select-kids (node-typeof? 'tr))
+ (node-pos 2))
+ (node-reduce (select-kids (node-typeof? 'td))
+ (node-pos 3)))
+ tree expected)
+ (run-test (sxpath '(table (tr 2) (td 3))) tree expected)
+ )
+
+
+ ;; Location path, full form:
+ ;; child::para[attribute::type='warning'][position()=5]
+ ;; Location path, abbreviated form: address@hidden'warning'][5]
+ ;; selects the fifth para child of the context node that has a type
+ ;; attribute with value warning
+ (let ((tree
+ '(chapter
+ (para "para1")
+ (para (@ (type "warning")) "para 2")
+ (para (@ (type "warning")) "para 3")
+ (para (@ (type "warning")) "para 4")
+ (para (@ (type "warning")) "para 5")
+ (para (@ (type "warning")) "para 6"))
+ )
+ (expected
+ '((para (@ (type "warning")) "para 6"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(type "warning")))))
+ (node-pos 5))
+ tree expected)
+ (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 ) ))
+ tree expected)
+ (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 ) ))
+ tree expected)
+ )
+
+
+ ;; Location path, full form:
+ ;; child::para[position()=5][attribute::type='warning']
+ ;; Location path, abbreviated form: address@hidden'warning']
+ ;; selects the fifth para child of the context node if that child has a
'type'
+ ;; attribute with value warning
+ (let ((tree
+ '(chapter
+ (para "para1")
+ (para (@ (type "warning")) "para 2")
+ (para (@ (type "warning")) "para 3")
+ (para (@ (type "warning")) "para 4")
+ (para (@ (type "warning")) "para 5")
+ (para (@ (type "warning")) "para 6"))
+ )
+ (expected
+ '((para (@ (type "warning")) "para 5"))
+ ))
+ (run-test
+ (node-reduce
+ (select-kids (node-typeof? 'para))
+ (node-pos 5)
+ (filter
+ (node-join
+ (select-kids (node-typeof? '@))
+ (select-kids (node-equal? '(type "warning"))))))
+ tree expected)
+ (run-test (sxpath '( (( (para 5)) (@ (equal? (type "warning"))))))
+ tree expected)
+ (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
+ tree expected)
+ )
+
+ ;; Location path, full form:
+ ;; child::*[self::chapter or self::appendix]
+ ;; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
+ ;; selects the chapter and appendix children of the context node
+ (let ((tree
+ '(document
+ (preface "preface")
+ (chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (epilogue "Epilogue text")
+ (appendix (@ (id "A")) "App A text")
+ (References "References"))
+ )
+ (expected
+ '((chapter (@ (id "one")) "Chap 1 text")
+ (chapter (@ (id "two")) "Chap 2 text")
+ (chapter (@ (id "three")) "Chap 3 text")
+ (appendix (@ (id "A")) "App A text"))
+ ))
+ (run-test
+ (node-join
+ (select-kids (node-typeof? '*))
+ (filter
+ (node-or
+ (node-self (node-typeof? 'chapter))
+ (node-self (node-typeof? 'appendix)))))
+ tree expected)
+ (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
+ (node-self (node-typeof? 'appendix)))))
+ tree expected)
+ )
+
+
+ ;; Location path, full form: child::chapter[child::title='Introduction']
+ ;; Location path, abbreviated form: chapter[title = 'Introduction']
+ ;; selects the chapter children of the context node that have one or more
+ ;; title children with string-value equal to Introduction
+ ;; See a similar example: //address@hidden = "right"] above.
+
+ ;; Location path, full form: child::chapter[child::title]
+ ;; Location path, abbreviated form: chapter[title]
+ ;; selects the chapter children of the context node that have one or
+ ;; more title children
+ ;; See a similar example //address@hidden above.
+
+ (let ((tree tree3)
+ (expected
+ '("Let us go then, you and I," "In the room the women come and go")
+ ))
+ (run-test
+ (node-join
+ (node-closure (node-typeof? 'stanza))
+ (node-reduce
+ (select-kids (node-typeof? 'line)) (node-pos 1))
+ (select-kids (node-typeof? '*text*)))
+ tree expected)
+ (run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
+ )
+ )
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index f21000e..f3bb73b 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -1,6 +1,6 @@
;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009, 2010 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,8 +20,9 @@
;; affect code outside of this file.
;;
(define-module (test-suite test-syncase)
- :use-module (test-suite lib)
- :use-module ((srfi srfi-1) :select (member)))
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module ((srfi srfi-1) :select (member)))
(define-syntax plus
(syntax-rules ()
@@ -82,3 +83,37 @@
(pass-if "tail invocation"
(equal? (alist ((foo 42) (tail '((bar . 66)))))
'((foo . 42) (bar . 66))))))
+
+(with-test-prefix "serializable labels and marks"
+ (compile '(begin
+ (define-syntax duplicate-macro
+ (syntax-rules ()
+ ((_ new-name old-name)
+ (define-syntax new-name
+ (syntax-rules ()
+ ((_ . vals)
+ (letrec-syntax ((apply (syntax-rules ()
+ ((_ macro args)
+ (macro . args)))))
+ (apply old-name vals))))))))
+
+ (define-syntax kwote
+ (syntax-rules ()
+ ((_ arg1) 'arg1)))
+
+ (duplicate-macro kwote* kwote))
+ #:env (current-module))
+ (pass-if "compiled macro-generating macro works"
+ (eq? (eval '(kwote* foo) (current-module))
+ 'foo)))
+
+(with-test-prefix "changes to expansion environment"
+ (pass-if "expander detects changes to current-module"
+ (compile '(begin
+ (define-module (new-module))
+ (define-syntax new-module-macro
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ arg) (syntax arg)))))
+ (new-module-macro #t))
+ #:env (current-module))))
diff --git a/test-suite/tests/texinfo.docbook.test
b/test-suite/tests/texinfo.docbook.test
new file mode 100644
index 0000000..9fb03bb
--- /dev/null
+++ b/test-suite/tests/texinfo.docbook.test
@@ -0,0 +1,32 @@
+;;;; texinfo.docbook.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (texinfo docbook).
+;;
+;;; Code:
+
+(define-module (test-suite texinfo-docbook)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo docbook))
+
+(with-test-prefix "test-flatten"
+ (pass-if (equal?
+ (sdocbook-flatten '(refsect1 (refsect2 (para "foo"))))
+ '((refsect1) (refsect2) (para "foo")))))
diff --git a/test-suite/tests/texinfo.serialize.test
b/test-suite/tests/texinfo.serialize.test
new file mode 100644
index 0000000..95e26b8
--- /dev/null
+++ b/test-suite/tests/texinfo.serialize.test
@@ -0,0 +1,185 @@
+;;;; texinfo.serialize.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (texinfo serialize).
+;;
+;;; Code:
+
+(define-module (test-suite texinfo-serialize)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo serialize))
+
+(with-test-prefix "test-serialize"
+ (define (assert-serialize stexi str)
+ (pass-if str (equal? str (stexi->texi stexi))))
+
+ (assert-serialize '(para)
+ "
+
+")
+
+ (assert-serialize '(para "foo")
+ "foo
+
+")
+
+ (assert-serialize '(var "foo")
+ "@var{foo}")
+
+
+ ;; i don't remember why braces exists, but as long as it does, a test
+ ;; is in order
+ (assert-serialize '(*braces* "foo")
+ "@address@hidden")
+
+ (assert-serialize '(value (% (key "foo")))
+ "@value{foo}")
+
+ (assert-serialize '(ref (% (node "foo")))
+ "@ref{foo}")
+ (assert-serialize '(ref (% (node "foo") (name "bar")))
+ "@ref{foo,bar}")
+ (assert-serialize '(ref (% (node "foo") (name "bar")
+ (section "qux") (info-file "xyzzy")
+ (manual "zarg")))
+ "@ref{foo,bar,qux,xyzzy,zarg}")
+ (assert-serialize '(ref (% (section "qux") (info-file "xyzzy")
+ (node "foo") (name "bar")
+ (manual "zarg")))
+ "@ref{foo,bar,qux,xyzzy,zarg}")
+ (assert-serialize '(ref (% (node "foo")
+ (manual "zarg")))
+ "@ref{foo,,,,zarg}")
+
+ (assert-serialize '(dots) "@dots{}")
+
+ (assert-serialize '(node (% (name "foo")))
+ "@node foo
+")
+
+ (assert-serialize '(node (% (name "foo bar")))
+ "@node foo bar
+")
+ (assert-serialize '(node (% (name "foo bar") (next "baz")))
+ "@node foo bar, baz
+")
+
+ (assert-serialize '(title "Foo")
+ "@title Foo
+")
+ (assert-serialize '(title "Foo is a " (var "bar"))
+ "@title Foo is a @var{bar}
+")
+
+ (assert-serialize '(title "Foo is a " (var "bar") " baz")
+ "@title Foo is a @var{bar} baz
+")
+
+ (assert-serialize '(cindex (% (entry "Bar baz, foo")))
+ "@cindex Bar baz, foo
+")
+
+ ;; there is a space after @iftex, doesn't matter tho
+ (assert-serialize '(iftex
+ (para "This is only for tex.")
+ (para "Note. Foo."))
+ "@iftex
+This is only for tex.
+
+Note. Foo.
+
address@hidden iftex
+
+")
+
+ (assert-serialize '(defun (% (name "frob"))
+ (para "foo?"))
+ "@defun frob
+foo?
+
address@hidden defun
+
+")
+
+ (assert-serialize '(defun (% (name "frob") (arguments "bar"))
+ (para "foo?"))
+ "@defun frob bar
+foo?
+
address@hidden defun
+
+")
+
+ (assert-serialize '(defun (% (name "frob") (arguments "bar" " " "baz"))
+ (para "foo?"))
+ "@defun frob bar baz
+foo?
+
address@hidden defun
+
+")
+
+ (assert-serialize '(defun (% (name "frob") (arguments (var "bar")))
+ (para "foo?"))
+ "@defun frob @var{bar}
+foo?
+
address@hidden defun
+
+")
+
+ (assert-serialize '(defunx (% (name "frob") (arguments (var "bar"))))
+ "@defunx frob @var{bar}
+")
+
+ (assert-serialize '(table (% (formatter (var)))
+ (entry (% (heading "Foo bar " (code "baz")))
+ (para "Frobate")
+ (para "zzzzz")))
+ "@table @var
address@hidden Foo bar @code{baz}
+Frobate
+
+zzzzz
+
address@hidden table
+
+")
+
+ (assert-serialize '(verbatim "foo")
+ "@verbatim
+foo
address@hidden verbatim
+
+")
+
+ (assert-serialize '(deffnx (% (name "foo") (category "bar")))
+ "@deffnx bar foo
+")
+
+ (assert-serialize '(deffnx (% (name "foo") (category "bar") (arguments "x" "
" "y")))
+ "@deffnx bar foo x y
+")
+
+ (assert-serialize '(deffnx (% (name "foo") (category "bar") (arguments "("
"x" " " (code "int") ")")))
+ "@deffnx bar foo (x @code{int})
+")
+
+ )
diff --git a/test-suite/tests/texinfo.string-utils.test
b/test-suite/tests/texinfo.string-utils.test
new file mode 100644
index 0000000..ad19df8
--- /dev/null
+++ b/test-suite/tests/texinfo.string-utils.test
@@ -0,0 +1,118 @@
+;;;; texinfo.string-utils.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2003, 2009, 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 3 of the
+;;;; License, or (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;;;; 02110-1301 USA
+
+(define-module (test-suite test-string-utils)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo string-utils))
+
+
+;; **********************************************************************
+;; Test for expand-tabs
+;; **********************************************************************
+(with-test-prefix "test-beginning-expansion"
+ (pass-if (equal? " Hello"
+ (expand-tabs "\tHello")))
+ (pass-if (equal? " Hello"
+ (expand-tabs "\t\tHello"))))
+
+(with-test-prefix "test-ending-expansion"
+ (pass-if (equal? "Hello "
+ (expand-tabs "Hello\t")))
+ (pass-if (equal? "Hello "
+ (expand-tabs "Hello\t\t"))))
+
+(with-test-prefix "test-middle-expansion"
+ (pass-if (equal? "Hello there" (expand-tabs "Hello\tthere")))
+ (pass-if (equal? "Hello there" (expand-tabs
"Hello\t\tthere"))))
+
+(with-test-prefix "test-alternate-tab-size"
+ (pass-if (equal? "Hello there"
+ (expand-tabs "Hello\tthere" 3)))
+ (pass-if (equal? "Hello there"
+ (expand-tabs "Hello\tthere" 4)))
+ (pass-if (equal? "Hello there"
+ (expand-tabs "Hello\tthere" 5))))
+
+;; **********************************************************************
+;; tests for escape-special-chars
+;; **********************************************************************
+(with-test-prefix "test-single-escape-char"
+ (pass-if (equal? "HeElElo"
+ (escape-special-chars "Hello" #\l #\E))))
+
+(with-test-prefix "test-multiple-escape-chars"
+ (pass-if (equal? "HEeElElo"
+ (escape-special-chars "Hello" "el" #\E))))
+
+
+;; **********************************************************************
+;; tests for collapsing-multiple-chars
+;; **********************************************************************
+(with-test-prefix "collapse-repeated-chars"
+ (define test-string
+ "H e l l o t h e r e")
+
+ (with-test-prefix "test-basic-collapse"
+ (pass-if (equal? "H e l l o t h e r e"
+ (collapse-repeated-chars test-string))))
+
+ (with-test-prefix "test-choose-other-char"
+ (pass-if (equal? "H-e-l-l-o-t-h-e-r-e"
+ (collapse-repeated-chars (transform-string test-string
#\space #\-)
+ #\-))))
+
+ (with-test-prefix "test-choose-maximum-repeats"
+ (pass-if (equal? "H e l l o t h e r e"
+ (collapse-repeated-chars test-string #\space 2)))
+ (pass-if (equal? "H e l l o t h e r e"
+ (collapse-repeated-chars test-string #\space 3)))))
+
+;; **********************************************************************
+;; Test of the object itself...
+;; **********************************************************************
+(with-test-prefix "text wrapping"
+ (define test-string "
+The last language environment specified with
+`set-language-environment'. This variable should be
+set only with M-x customize, which is equivalent
+to using the function `set-language-environment'.
+")
+
+ (with-test-prefix "runs-without-exception"
+ (pass-if (->bool (fill-string test-string)))
+ (pass-if (->bool (fill-string test-string #:line-width 20)))
+ (pass-if (->bool (fill-string test-string #:initial-indent " * "
#:tab-width 3))))
+
+ (with-test-prefix "test-fill-equivalent-to-joined-lines"
+ (pass-if (equal? (fill-string test-string)
+ (string-join (string->wrapped-lines test-string) "\n"
'infix))))
+
+ (with-test-prefix "test-no-collapse-ws"
+ (pass-if (equal? (fill-string test-string #:collapse-whitespace? #f)
+ "The last language environment specified with
`set-language-environment'. This
+variable should be set only with M-x customize, which is equivalent to using
+the function `set-language-environment'.")))
+
+ (with-test-prefix "test-no-word-break"
+ (pass-if (equal? "thisisalongword
+blah
+blah"
+ (fill-string "thisisalongword blah blah"
+ #:line-width 8
+ #:break-long-words? #f)))))
diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test
new file mode 100644
index 0000000..273227b
--- /dev/null
+++ b/test-suite/tests/texinfo.test
@@ -0,0 +1,404 @@
+;;;; texinfo.test -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2010 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
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml texinfo). Adapted from xml.ssax.scm.
+;;
+;;; Code:
+
+(define-module (test-suite texinfo)
+ #:use-module (test-suite lib)
+ #:use-module (texinfo))
+
+(define exception:eof-while-reading-token
+ '(parser-error . "^EOF while reading a token"))
+(define exception:wrong-character
+ '(parser-error . "^Wrong character"))
+(define exception:eof-while-reading-char-data
+ '(parser-error . "^EOF while reading char data"))
+(define exception:no-settitle
+ '(parser-error . "^No address@hidden found"))
+(define exception:unexpected-arg
+ '(parser-error . "address@hidden didn't expect more arguments"))
+(define exception:bad-enumerate
+ '(parser-error . "^Invalid"))
+
+(define nl (string #\newline))
+
+(define texinfo:read-verbatim-body
+ (@@ (texinfo) read-verbatim-body))
+(with-test-prefix "test-read-verbatim-body"
+ (define (read-verbatim-body-from-string str)
+ (define (consumer fragment foll-fragment seed)
+ (cons* (if (equal? foll-fragment (string #\newline))
+ (string-append " NL" nl)
+ foll-fragment)
+ fragment seed))
+ (reverse
+ (call-with-input-string
+ str
+ (lambda (port) (texinfo:read-verbatim-body port consumer '())))))
+
+ (pass-if (equal? '()
+ (read-verbatim-body-from-string "@end verbatim\n")))
+
+ ;; after @verbatim, the current position will always directly after
+ ;; the newline.
+ (pass-if-exception "@end verbatim needs a newline"
+ exception:eof-while-reading-token
+ (read-verbatim-body-from-string "@end verbatim"))
+
+ (pass-if (equal? '("@@end verbatim" " NL\n")
+ (read-verbatim-body-from-string "@@end address@hidden
verbatim\n")))
+
+ (pass-if (equal? '("@@@@faosfasf adsfas " " NL\n" " asf @foo{asdf}" " NL\n")
+ (read-verbatim-body-from-string
+ "@@@@faosfasf adsfas \n asf @address@hidden verbatim\n")))
+
+ (pass-if (equal? '("@end verbatim " " NL\n")
+ (read-verbatim-body-from-string "@end verbatim
address@hidden verbatim\n"))))
+
+(define texinfo:read-arguments
+ (@@ (texinfo) read-arguments))
+(with-test-prefix "test-read-arguments"
+ (define (read-arguments-from-string str)
+ (call-with-input-string
+ str
+ (lambda (port) (texinfo:read-arguments port #\}))))
+
+ (define (test str expected-res)
+ (pass-if (equal? expected-res
+ (read-arguments-from-string str))))
+
+ (test "}" '())
+ (test "foo}" '("foo"))
+ (test "foo,bar}" '("foo" "bar"))
+ (test " foo , bar }" '("foo" "bar"))
+ (test " foo , , bar }" '("foo" #f "bar"))
+ (test "foo,,bar}" '("foo" #f "bar"))
+ (pass-if-exception "need a } when reading arguments"
+ exception:eof-while-reading-token
+ (call-with-input-string
+ "foo,,bar"
+ (lambda (port) (texinfo:read-arguments port #\})))))
+
+(define texinfo:complete-start-command
+ (@@ (texinfo) complete-start-command))
+(with-test-prefix "test-complete-start-command"
+ (define (test command str)
+ (call-with-input-string
+ str
+ (lambda (port)
+ (call-with-values
+ (lambda ()
+ (texinfo:complete-start-command command port))
+ list))))
+
+ (pass-if (equal? '(section () EOL-TEXT)
+ (test 'section "foo bar baz bonzerts")))
+ (pass-if (equal? '(deffnx ((category "Function") (name "foo") (arguments))
EOL-TEXT-ARGS)
+ (test 'deffnx "Function foo")))
+ (pass-if-exception "@emph missing a start brace"
+ exception:wrong-character
+ (test 'emph "no brace here"))
+ (pass-if (equal? '(emph () INLINE-TEXT)
+ (test 'emph "{foo bar baz bonzerts")))
+ (pass-if (equal? '(ref ((node "foo bar") (section "baz") (info-file
"bonzerts"))
+ INLINE-ARGS)
+ (test 'ref "{ foo bar ,, baz, bonzerts}")))
+ (pass-if (equal? '(node ((name "referenced node")) EOL-ARGS)
+ (test 'node " referenced node\n"))))
+
+(define texinfo:read-char-data
+ (@@ (texinfo) read-char-data))
+(define make-texinfo-token cons)
+(with-test-prefix "test-read-char-data"
+ (let* ((code (make-texinfo-token 'START 'code))
+ (ref (make-texinfo-token 'EMPTY 'ref))
+ (title (make-texinfo-token 'LINE 'title))
+ (node (make-texinfo-token 'EMPTY 'node))
+ (eof-object (with-input-from-string "" read))
+ (str-handler (lambda (fragment foll-fragment seed)
+ (if (string-null? foll-fragment)
+ (cons fragment seed)
+ (cons* foll-fragment fragment seed)))))
+ (define (test str expect-eof? preserve-ws? expected-data expected-token)
+ (call-with-values
+ (lambda ()
+ (call-with-input-string
+ str
+ (lambda (port)
+ (texinfo:read-char-data
+ port expect-eof? preserve-ws? str-handler '()))))
+ (lambda (seed token)
+ (let ((result (reverse seed)))
+ (pass-if (equal? expected-data result))
+ (pass-if (equal? expected-token token))))))
+
+ ;; add some newline-related tests here
+ (test "" #t #f '() eof-object)
+ (test "foo bar baz" #t #f '("foo bar baz") eof-object)
+ (pass-if-exception "eof reading char data"
+ exception:eof-while-reading-token
+ (test "" #f #f '() eof-object))
+ (test " " #t #f '(" ") eof-object)
+ (test " @code{foo} " #f #f '(" ") code)
+ (test " @code" #f #f '(" ") code)
+ (test " {text here} asda" #f #f '(" ") (make-texinfo-token 'START
'*braces*))
+ (test " blah blah} asda" #f #f '(" blah blah") (make-texinfo-token 'END
#f))))
+
+
+(with-test-prefix "test-texinfo->stexinfo"
+ (define (test str expected-res)
+ (pass-if (equal? expected-res
+ (call-with-input-string str texi->stexi))))
+ (define (try-with-title title str)
+ (call-with-input-string
+ (string-append "foo bar address@hidden " title "\n" str)
+ texi->stexi))
+ (define (test-with-title title str expected-res)
+ (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)))))
+
+ (define (list-intersperse src-l elem)
+ (if (null? src-l) src-l
+ (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+ (if (null? l) (reverse dest)
+ (loop (cdr l) (cons (car l) (cons elem dest)))))))
+ (define (join-lines . lines)
+ (apply string-append (list-intersperse lines "\n")))
+
+ (pass-if-exception "missing @settitle"
+ exception:no-settitle
+ (call-with-input-string "@dots{}\n" texi->stexi))
+
+ (test "\\input address@hidden my address@hidden"
+ '(texinfo (% (title "my title")) (para (dots))))
+ (test-with-title "my title" "@dots{}\n"
+ '(texinfo (% (title "my title")) (para (dots))))
+ (test-with-title "my title" "@dots{}"
+ '(texinfo (% (title "my title")) (para (dots))))
+
+ (pass-if-exception "arg to @dots{}"
+ exception:unexpected-arg
+ (call-with-input-string
+ "foo bar address@hidden my address@hidden"
+ texi->stexi))
+
+ (test-body "@code{arg}"
+ '((para (code "arg"))))
+ (test-body "@code{ }"
+ '((para (code))))
+ (test-body "@code{ @code{} }"
+ '((para (code (code)))))
+ (test-body "@code{ abc @code{} }"
+ '((para (code "abc " (code)))))
+ (test-body "@code{ arg }"
+ '((para (code "arg"))))
+ (test-body "@example\n foo asdf asd sadf asd address@hidden example\n"
+ '((example " foo asdf asd sadf asd ")))
+ (test-body (join-lines
+ "@quotation"
+ "@example"
+ " foo asdf asd sadf asd "
+ "@end example"
+ "@end quotation"
+ "")
+ '((quotation (example " foo asdf asd sadf asd "))))
+ (test-body (join-lines
+ "@quotation"
+ "@example"
+ " foo asdf @var{asd} sadf asd "
+ "@end example"
+ "@end quotation"
+ "")
+ '((quotation (example " foo asdf " (var "asd") " sadf asd "))))
+ (test-body (join-lines
+ "@quotation"
+ "@example"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "not in new para, this is an example"
+ "@end example"
+ "@end quotation"
+ "")
+ '((quotation
+ (example
+ " foo asdf " (var "asd")
+ " sadf asd \n\nnot in new para, this is an example"))))
+ (test-body (join-lines
+ "@titlepage"
+ "@quotation"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "should be in new para"
+ "@end quotation"
+ "@end titlepage"
+ "")
+ '((titlepage
+ (quotation (para "foo asdf " (var "asd") " sadf asd")
+ (para "should be in new para")))))
+ (test-body (join-lines
+ ""
+ "@titlepage"
+ ""
+ "@quotation"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "should be in new para"
+ ""
+ ""
+ "@end quotation"
+ "@end titlepage"
+ ""
+ "@bye"
+ ""
+ "@foo random crap at the end"
+ "")
+ '((titlepage
+ (quotation (para "foo asdf " (var "asd") " sadf asd")
+ (para "should be in new para")))))
+ (test-body (join-lines
+ ""
+ "random notes"
+ "@quotation"
+ " foo asdf @var{asd} sadf asd "
+ ""
+ "should be in new para"
+ ""
+ ""
+ "@end quotation"
+ ""
+ " hi mom"
+ "")
+ '((para "random notes")
+ (quotation (para "foo asdf " (var "asd") " sadf asd")
+ (para "should be in new para"))
+ (para "hi mom")))
+ (test-body (join-lines
+ "@enumerate"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end enumerate"
+ )
+ '((enumerate (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@enumerate 44"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end enumerate"
+ )
+ '((enumerate (% (start "44"))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (pass-if-exception "bad enumerate formatter"
+ exception:bad-enumerate
+ (try-with-title "foo" (join-lines
+ "@enumerate string"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end enumerate"
+ )))
+ (pass-if-exception "bad itemize formatter"
+ exception:bad-enumerate
+ (try-with-title "foo" (join-lines
+ "@itemize string"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )))
+ (test-body (join-lines
+ "@itemize" ;; no formatter, should default to bullet
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )
+ '((itemize (% (bullet (bullet)))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@itemize @bullet"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )
+ '((itemize (% (bullet (bullet)))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@itemize -"
+ "@item one"
+ "@item two"
+ "@item three"
+ "@end itemize"
+ )
+ '((itemize (% (bullet "-"))
+ (item (para "one"))
+ (item (para "two"))
+ (item (para "three")))))
+ (test-body (join-lines
+ "@table @code"
+ "preliminary text -- should go in a pre-item para"
+ "@item one"
+ "item one text"
+ "@item two"
+ "item two text"
+ ""
+ "includes a paragraph"
+ "@item three"
+ "@end itemize"
+ )
+ '((table (% (formatter (code)))
+ (para "preliminary text -- should go in a pre-item para")
+ (entry (% (heading "one"))
+ (para "item one text"))
+ (entry (% (heading "two"))
+ (para "item two text")
+ (para "includes a paragraph"))
+ (entry (% (heading "three"))))))
+ (test-body (join-lines
+ "@chapter @code{foo} bar"
+ "text that should be in a para"
+ )
+ '((chapter (code "foo") " bar")
+ (para "text that should be in a para")))
+ (test-body (join-lines
+ "@deffnx Method foo bar @code{baz}"
+ "text that should be in a para"
+ )
+ '((deffnx (% (category "Method")
+ (name "foo")
+ (arguments "bar " (code "baz"))))
+ (para "text that should be in a para")))
+ )
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 3fe6865..a3023f3 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <address@hidden> --- May 2009
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 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,19 +69,19 @@
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1)
(call goto/args 1)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1)
(call tail-call 1)))
(assert-tree-il->glil
(begin (apply (toplevel foo) (const 1)) (void))
(program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref
foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
- (label ,l3) (mv-bind () #f) (unbind)
+ (label ,l3) (mv-bind 0 #f)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call
new-frame 0) (toplevel ref bar) (call call 0)
- (call goto/args 1))))
+ (call tail-call 1))))
(with-test-prefix "conditional"
(assert-tree-il->glil
@@ -401,8 +401,7 @@
(lexical #f #f ref 0) (call return 1)
(unbind))
(lexical #t #f ref 0)
- (call vector 1)
- (call make-closure 2)
+ (call make-closure 1)
(call return 1)
(unbind))
(call return 1))))
@@ -457,12 +456,12 @@
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref
bar) (call goto/apply 2)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref
bar) (call tail-apply 2)))
(assert-tree-il->glil
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo)
(toplevel ref bar) (mv-call 2 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+ (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
@@ -471,17 +470,17 @@
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call
apply 2)
- (call goto/args 1))))
+ (call tail-call 1))))
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc
1)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call
tail-call/cc 1)))
(assert-tree-il->glil
(begin (apply (primitive @call-with-current-continuation) (toplevel foo))
(void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation)
(toplevel ref foo) (mv-call 1 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+ (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
@@ -491,7 +490,7 @@
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
- (call goto/args 1))))
+ (call tail-call 1))))
(with-test-prefix "tree-il-fold"
@@ -555,6 +554,9 @@
(define %opts-w-unused
'(#:warnings (unused-variable)))
+(define %opts-w-unused-toplevel
+ '(#:warnings (unused-toplevel)))
+
(define %opts-w-unbound
'(#:warnings (unbound-variable)))
@@ -616,6 +618,107 @@
(compile '(lambda (x y z) #t)
#:opts %opts-w-unused))))))
+ (with-test-prefix "unused-toplevel"
+
+ (pass-if "used after definition"
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define foo 2) foo")))
+ (read-and-compile in
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel))))))
+
+ (pass-if "used before definition"
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define (bar) foo) (define foo 2) (bar)")))
+ (read-and-compile in
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel))))))
+
+ (pass-if "unused but public"
+ (let ((in (open-input-string
+ "(define-module (test-suite tree-il x) #:export (bar))
+ (define (bar) #t)")))
+ (null? (call-with-warnings
+ (lambda ()
+ (read-and-compile in
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel))))))
+
+ (pass-if "unused but public (more)"
+ (let ((in (open-input-string
+ "(define-module (test-suite tree-il x) #:export (bar))
+ (define (bar) (baz))
+ (define (baz) (foo))
+ (define (foo) #t)")))
+ (null? (call-with-warnings
+ (lambda ()
+ (read-and-compile in
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel))))))
+
+ (pass-if "unused but define-public"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(define-public foo 2)
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel)))))
+
+ (pass-if "used by macro"
+ ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
+ (throw 'unresolved)
+
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define (bar) 'foo)
+ (define-syntax baz
+ (syntax-rules () ((_) (bar))))")))
+ (read-and-compile in
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel))))))
+
+ (pass-if "unused"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(define foo 2)
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ (format #f "top-level variable `~A'"
+ 'foo))))))
+
+ (pass-if "unused recursive"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(define (foo) (foo))
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ (format #f "top-level variable `~A'"
+ 'foo))))))
+
+ (pass-if "unused mutually recursive"
+ (let* ((in (open-input-string
+ "(define (foo) (bar)) (define (bar) (foo))"))
+ (w (call-with-warnings
+ (lambda ()
+ (read-and-compile in
+ #:to 'assembly
+ #:opts %opts-w-unused-toplevel)))))
+ (and (= (length w) 2)
+ (number? (string-contains (car w)
+ (format #f "top-level variable `~A'"
+ 'foo)))
+ (number? (string-contains (cadr w)
+ (format #f "top-level variable `~A'"
+ 'bar)))))))
+
(with-test-prefix "unbound variable"
(pass-if "quiet"
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
deleted file mode 100644
index 092f7aa..0000000
--- a/test-suite/tests/unif.test
+++ /dev/null
@@ -1,563 +0,0 @@
-;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
-;;;;
-;;;; Copyright 2004, 2006, 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 test-unif)
- #:use-module ((system base compile) #:select (compile))
- #:use-module (test-suite lib))
-
-;;;
-;;; array?
-;;;
-
-(define exception:wrong-num-indices
- (cons 'misc-error "^wrong number of indices.*"))
-
-(define exception:length-non-negative
- (cons 'read-error ".*array length must be non-negative.*"))
-
-
-(with-test-prefix "array?"
-
- (let ((bool (make-typed-array 'b #t '(5 6)))
- (char (make-typed-array 'a #\a '(5 6)))
- (byte (make-typed-array 'u8 0 '(5 6)))
- (short (make-typed-array 's16 0 '(5 6)))
- (ulong (make-typed-array 'u32 0 '(5 6)))
- (long (make-typed-array 's32 0 '(5 6)))
- (longlong (make-typed-array 's64 0 '(5 6)))
- (float (make-typed-array 'f32 0 '(5 6)))
- (double (make-typed-array 'f64 0 '(5 6)))
- (complex (make-typed-array 'c64 0 '(5 6)))
- (scm (make-typed-array #t 0 '(5 6))))
-
- (with-test-prefix "is bool"
- (pass-if (eq? #t (typed-array? bool 'b)))
- (pass-if (eq? #f (typed-array? char 'b)))
- (pass-if (eq? #f (typed-array? byte 'b)))
- (pass-if (eq? #f (typed-array? short 'b)))
- (pass-if (eq? #f (typed-array? ulong 'b)))
- (pass-if (eq? #f (typed-array? long 'b)))
- (pass-if (eq? #f (typed-array? longlong 'b)))
- (pass-if (eq? #f (typed-array? float 'b)))
- (pass-if (eq? #f (typed-array? double 'b)))
- (pass-if (eq? #f (typed-array? complex 'b)))
- (pass-if (eq? #f (typed-array? scm 'b))))
-
- (with-test-prefix "is char"
- (pass-if (eq? #f (typed-array? bool 'a)))
- (pass-if (eq? #t (typed-array? char 'a)))
- (pass-if (eq? #f (typed-array? byte 'a)))
- (pass-if (eq? #f (typed-array? short 'a)))
- (pass-if (eq? #f (typed-array? ulong 'a)))
- (pass-if (eq? #f (typed-array? long 'a)))
- (pass-if (eq? #f (typed-array? longlong 'a)))
- (pass-if (eq? #f (typed-array? float 'a)))
- (pass-if (eq? #f (typed-array? double 'a)))
- (pass-if (eq? #f (typed-array? complex 'a)))
- (pass-if (eq? #f (typed-array? scm 'a))))
-
- (with-test-prefix "is byte"
- (pass-if (eq? #f (typed-array? bool 'u8)))
- (pass-if (eq? #f (typed-array? char 'u8)))
- (pass-if (eq? #t (typed-array? byte 'u8)))
- (pass-if (eq? #f (typed-array? short 'u8)))
- (pass-if (eq? #f (typed-array? ulong 'u8)))
- (pass-if (eq? #f (typed-array? long 'u8)))
- (pass-if (eq? #f (typed-array? longlong 'u8)))
- (pass-if (eq? #f (typed-array? float 'u8)))
- (pass-if (eq? #f (typed-array? double 'u8)))
- (pass-if (eq? #f (typed-array? complex 'u8)))
- (pass-if (eq? #f (typed-array? scm 'u8))))
-
- (with-test-prefix "is short"
- (pass-if (eq? #f (typed-array? bool 's16)))
- (pass-if (eq? #f (typed-array? char 's16)))
- (pass-if (eq? #f (typed-array? byte 's16)))
- (pass-if (eq? #t (typed-array? short 's16)))
- (pass-if (eq? #f (typed-array? ulong 's16)))
- (pass-if (eq? #f (typed-array? long 's16)))
- (pass-if (eq? #f (typed-array? longlong 's16)))
- (pass-if (eq? #f (typed-array? float 's16)))
- (pass-if (eq? #f (typed-array? double 's16)))
- (pass-if (eq? #f (typed-array? complex 's16)))
- (pass-if (eq? #f (typed-array? scm 's16))))
-
- (with-test-prefix "is ulong"
- (pass-if (eq? #f (typed-array? bool 'u32)))
- (pass-if (eq? #f (typed-array? char 'u32)))
- (pass-if (eq? #f (typed-array? byte 'u32)))
- (pass-if (eq? #f (typed-array? short 'u32)))
- (pass-if (eq? #t (typed-array? ulong 'u32)))
- (pass-if (eq? #f (typed-array? long 'u32)))
- (pass-if (eq? #f (typed-array? longlong 'u32)))
- (pass-if (eq? #f (typed-array? float 'u32)))
- (pass-if (eq? #f (typed-array? double 'u32)))
- (pass-if (eq? #f (typed-array? complex 'u32)))
- (pass-if (eq? #f (typed-array? scm 'u32))))
-
- (with-test-prefix "is long"
- (pass-if (eq? #f (typed-array? bool 's32)))
- (pass-if (eq? #f (typed-array? char 's32)))
- (pass-if (eq? #f (typed-array? byte 's32)))
- (pass-if (eq? #f (typed-array? short 's32)))
- (pass-if (eq? #f (typed-array? ulong 's32)))
- (pass-if (eq? #t (typed-array? long 's32)))
- (pass-if (eq? #f (typed-array? longlong 's32)))
- (pass-if (eq? #f (typed-array? float 's32)))
- (pass-if (eq? #f (typed-array? double 's32)))
- (pass-if (eq? #f (typed-array? complex 's32)))
- (pass-if (eq? #f (typed-array? scm 's32))))
-
- (with-test-prefix "is long long"
- (pass-if (eq? #f (typed-array? bool 's64)))
- (pass-if (eq? #f (typed-array? char 's64)))
- (pass-if (eq? #f (typed-array? byte 's64)))
- (pass-if (eq? #f (typed-array? short 's64)))
- (pass-if (eq? #f (typed-array? ulong 's64)))
- (pass-if (eq? #f (typed-array? long 's64)))
- (pass-if (eq? #t (typed-array? longlong 's64)))
- (pass-if (eq? #f (typed-array? float 's64)))
- (pass-if (eq? #f (typed-array? double 's64)))
- (pass-if (eq? #f (typed-array? complex 's64)))
- (pass-if (eq? #f (typed-array? scm 's64))))
-
- (with-test-prefix "is float"
- (pass-if (eq? #f (typed-array? bool 'f32)))
- (pass-if (eq? #f (typed-array? char 'f32)))
- (pass-if (eq? #f (typed-array? byte 'f32)))
- (pass-if (eq? #f (typed-array? short 'f32)))
- (pass-if (eq? #f (typed-array? ulong 'f32)))
- (pass-if (eq? #f (typed-array? long 'f32)))
- (pass-if (eq? #f (typed-array? longlong 'f32)))
- (pass-if (eq? #t (typed-array? float 'f32)))
- (pass-if (eq? #f (typed-array? double 'f32)))
- (pass-if (eq? #f (typed-array? complex 'f32)))
- (pass-if (eq? #f (typed-array? scm 'f32))))
-
- (with-test-prefix "is double"
- (pass-if (eq? #f (typed-array? bool 'f64)))
- (pass-if (eq? #f (typed-array? char 'f64)))
- (pass-if (eq? #f (typed-array? byte 'f64)))
- (pass-if (eq? #f (typed-array? short 'f64)))
- (pass-if (eq? #f (typed-array? ulong 'f64)))
- (pass-if (eq? #f (typed-array? long 'f64)))
- (pass-if (eq? #f (typed-array? longlong 'f64)))
- (pass-if (eq? #f (typed-array? float 'f64)))
- (pass-if (eq? #t (typed-array? double 'f64)))
- (pass-if (eq? #f (typed-array? complex 'f64)))
- (pass-if (eq? #f (typed-array? scm 'f64))))
-
- (with-test-prefix "is complex"
- (pass-if (eq? #f (typed-array? bool 'c64)))
- (pass-if (eq? #f (typed-array? char 'c64)))
- (pass-if (eq? #f (typed-array? byte 'c64)))
- (pass-if (eq? #f (typed-array? short 'c64)))
- (pass-if (eq? #f (typed-array? ulong 'c64)))
- (pass-if (eq? #f (typed-array? long 'c64)))
- (pass-if (eq? #f (typed-array? longlong 'c64)))
- (pass-if (eq? #f (typed-array? float 'c64)))
- (pass-if (eq? #f (typed-array? double 'c64)))
- (pass-if (eq? #t (typed-array? complex 'c64)))
- (pass-if (eq? #f (typed-array? scm 'c64))))
-
- (with-test-prefix "is scm"
- (pass-if (eq? #f (typed-array? bool #t)))
- (pass-if (eq? #f (typed-array? char #t)))
- (pass-if (eq? #f (typed-array? byte #t)))
- (pass-if (eq? #f (typed-array? short #t)))
- (pass-if (eq? #f (typed-array? ulong #t)))
- (pass-if (eq? #f (typed-array? long #t)))
- (pass-if (eq? #f (typed-array? longlong #t)))
- (pass-if (eq? #f (typed-array? float #t)))
- (pass-if (eq? #f (typed-array? double #t)))
- (pass-if (eq? #f (typed-array? complex #t)))
- (pass-if (eq? #t (typed-array? scm #t))))))
-
-;;;
-;;; array-equal?
-;;;
-
-(with-test-prefix "array-equal?"
-
- (pass-if "#s16(...)"
- (array-equal? #s16(1 2 3) #s16(1 2 3))))
-
-;;;
-;;; array-fill!
-;;;
-
-(with-test-prefix "array-fill!"
-
- (with-test-prefix "bool"
- (let ((a (make-bitvector 1 #t)))
- (pass-if "#f" (array-fill! a #f) #t)
- (pass-if "#t" (array-fill! a #t) #t)))
-
- (with-test-prefix "char"
- (let ((a (make-string 1 #\a)))
- (pass-if "x" (array-fill! a #\x) #t)))
-
- (with-test-prefix "byte"
- (let ((a (make-s8vector 1 0)))
- (pass-if "0" (array-fill! a 0) #t)
- (pass-if "127" (array-fill! a 127) #t)
- (pass-if "-128" (array-fill! a -128) #t)
- (pass-if-exception "128" exception:out-of-range
- (array-fill! a 128))
- (pass-if-exception "-129" exception:out-of-range
- (array-fill! a -129))
- (pass-if-exception "symbol" exception:wrong-type-arg
- (array-fill! a 'symbol))))
-
- (with-test-prefix "short"
- (let ((a (make-s16vector 1 0)))
- (pass-if "0" (array-fill! a 0) #t)
- (pass-if "123" (array-fill! a 123) #t)
- (pass-if "-123" (array-fill! a -123) #t)))
-
- (with-test-prefix "ulong"
- (let ((a (make-u32vector 1 1)))
- (pass-if "0" (array-fill! a 0) #t)
- (pass-if "123" (array-fill! a 123) #t)
- (pass-if-exception "-123" exception:out-of-range
- (array-fill! a -123) #t)))
-
- (with-test-prefix "long"
- (let ((a (make-s32vector 1 -1)))
- (pass-if "0" (array-fill! a 0) #t)
- (pass-if "123" (array-fill! a 123) #t)
- (pass-if "-123" (array-fill! a -123) #t)))
-
- (with-test-prefix "float"
- (let ((a (make-f32vector 1 1.0)))
- (pass-if "0.0" (array-fill! a 0) #t)
- (pass-if "123.0" (array-fill! a 123.0) #t)
- (pass-if "-123.0" (array-fill! a -123.0) #t)
- (pass-if "0" (array-fill! a 0) #t)
- (pass-if "123" (array-fill! a 123) #t)
- (pass-if "-123" (array-fill! a -123) #t)
- (pass-if "5/8" (array-fill! a 5/8) #t)))
-
- (with-test-prefix "double"
- (let ((a (make-f64vector 1 1/3)))
- (pass-if "0.0" (array-fill! a 0) #t)
- (pass-if "123.0" (array-fill! a 123.0) #t)
- (pass-if "-123.0" (array-fill! a -123.0) #t)
- (pass-if "0" (array-fill! a 0) #t)
- (pass-if "123" (array-fill! a 123) #t)
- (pass-if "-123" (array-fill! a -123) #t)
- (pass-if "5/8" (array-fill! a 5/8) #t))))
-
-;;;
-;;; array-in-bounds?
-;;;
-
-(with-test-prefix "array-in-bounds?"
-
- (pass-if (let ((a (make-array #f '(425 425))))
- (eq? #f (array-in-bounds? a 0)))))
-
-;;;
-;;; array-prototype
-;;;
-
-(with-test-prefix "array-type"
-
- (with-test-prefix "on make-foo-vector"
-
- (pass-if "bool"
- (eq? 'b (array-type (make-bitvector 1))))
-
- (pass-if "char"
- (eq? 'a (array-type (make-string 1))))
-
- (pass-if "byte"
- (eq? 'u8 (array-type (make-u8vector 1))))
-
- (pass-if "short"
- (eq? 's16 (array-type (make-s16vector 1))))
-
- (pass-if "ulong"
- (eq? 'u32 (array-type (make-u32vector 1))))
-
- (pass-if "long"
- (eq? 's32 (array-type (make-s32vector 1))))
-
- (pass-if "long long"
- (eq? 's64 (array-type (make-s64vector 1))))
-
- (pass-if "float"
- (eq? 'f32 (array-type (make-f32vector 1))))
-
- (pass-if "double"
- (eq? 'f64 (array-type (make-f64vector 1))))
-
- (pass-if "complex"
- (eq? 'c64 (array-type (make-c64vector 1))))
-
- (pass-if "scm"
- (eq? #t (array-type (make-vector 1)))))
-
- (with-test-prefix "on make-typed-array"
-
- (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
- (for-each (lambda (type)
- (pass-if (symbol->string type)
- (eq? type
- (array-type (make-typed-array type
- *unspecified*
- '(5 6))))))
- types))))
-
-;;;
-;;; array-set!
-;;;
-
-(with-test-prefix "array-set!"
-
- (with-test-prefix "bitvector"
-
- ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
- ;; on a bitvector like the following
- (let ((a (make-bitvector 1)))
- (pass-if "one elem set #t"
- (begin
- (array-set! a #t 0)
- (eq? #t (array-ref a 0))))
- (pass-if "one elem set #f"
- (begin
- (array-set! a #f 0)
- (eq? #f (array-ref a 0))))))
-
- (with-test-prefix "byte"
-
- (let ((a (make-s8vector 1)))
-
- (pass-if "-128"
- (begin (array-set! a -128 0) #t))
- (pass-if "0"
- (begin (array-set! a 0 0) #t))
- (pass-if "127"
- (begin (array-set! a 127 0) #t))
- (pass-if-exception "-129" exception:out-of-range
- (begin (array-set! a -129 0) #t))
- (pass-if-exception "128" exception:out-of-range
- (begin (array-set! a 128 0) #t))))
-
- (with-test-prefix "short"
-
- (let ((a (make-s16vector 1)))
- ;; true if n can be array-set! into a
- (define (fits? n)
- (false-if-exception (begin (array-set! a n 0) #t)))
-
- (with-test-prefix "store/fetch"
- ;; Check array-ref gives back what was put with array-set!.
- ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
- ;; would silently truncate to a short.
-
- (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1
- ((not (fits? n)))
- (array-set! a n 0)
- (pass-if n
- (= n (array-ref a 0))))
-
- (do ((n -1 (* 2 n))) ;; -n=2^k
- ((not (fits? n)))
- (array-set! a n 0)
- (pass-if n
- (= n (array-ref a 0))))))))
-
-;;;
-;;; array-set!
-;;;
-
-(with-test-prefix "array-set!"
-
- (with-test-prefix "one dim"
- (let ((a (make-array #f '(3 5))))
- (pass-if "start"
- (array-set! a 'y 3)
- #t)
- (pass-if "end"
- (array-set! a 'y 5)
- #t)
- (pass-if-exception "start-1" exception:out-of-range
- (array-set! a 'y 2))
- (pass-if-exception "end+1" exception:out-of-range
- (array-set! a 'y 6))
- (pass-if-exception "two indexes" exception:out-of-range
- (array-set! a 'y 6 7))))
-
- (with-test-prefix "two dim"
- (let ((a (make-array #f '(3 5) '(7 9))))
- (pass-if "start"
- (array-set! a 'y 3 7)
- #t)
- (pass-if "end"
- (array-set! a 'y 5 9)
- #t)
- (pass-if-exception "start i-1" exception:out-of-range
- (array-set! a 'y 2 7))
- (pass-if-exception "end i+1" exception:out-of-range
- (array-set! a 'y 6 9))
- (pass-if-exception "one index" exception:wrong-num-indices
- (array-set! a 'y 4))
- (pass-if-exception "three indexes" exception:wrong-num-indices
- (array-set! a 'y 4 8 0)))))
-
-;;;
-;;; make-shared-array
-;;;
-
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
-(with-test-prefix "make-shared-array"
-
- ;; this failed in guile 1.8.0
- (pass-if "vector unchanged"
- (let* ((a (make-array #f '(0 7)))
- (s (make-shared-array a list '(0 7))))
- (array-equal? a s)))
-
- (pass-if-exception "vector, high too big" exception:mapping-out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(0 8))))
-
- (pass-if-exception "vector, low too big" exception:out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(-1 7))))
-
- (pass-if "truncate columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
- #2((a b) (d e) (g h))))
-
- (pass-if "pick one column"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i 2))
- '(0 2))
- #(c f i)))
-
- (pass-if "diagonal"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i i))
- '(0 2))
- #(a e i)))
-
- ;; this failed in guile 1.8.0
- (pass-if "2 dims from 1 dim"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i j) (list (+ (* i 3) j)))
- 4 3)
- #2((a b c) (d e f) (g h i) (j k l))))
-
- (pass-if "reverse columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i j) (list i (- 2 j)))
- 3 3)
- #2((c b a) (f e d) (i h g))))
-
- (pass-if "fixed offset, 0 based becomes 1 based"
- (let* ((x #2((a b c) (d e f) (g h i)))
- (y (make-shared-array x
- (lambda (i j) (list (1- i) (1- j)))
- '(1 3) '(1 3))))
- (and (eq? (array-ref x 0 0) 'a)
- (eq? (array-ref y 1 1) 'a))))
-
- ;; this failed in guile 1.8.0
- (pass-if "stride every third element"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i) (list (* i 3)))
- 4)
- #1(a d g j)))
-
- (pass-if "shared of shared"
- (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
- (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
- (s2 (make-shared-array s1 list '(1 2))))
- (and (eqv? 5 (array-ref s2 1))
- (eqv? 8 (array-ref s2 2))))))
-
-;;;
-;;; uniform-vector-ref
-;;;
-
-(with-test-prefix "uniform-vector-ref"
-
- (with-test-prefix "byte"
-
- (let ((a (make-s8vector 1)))
-
- (pass-if "0"
- (begin
- (array-set! a 0 0)
- (= 0 (uniform-vector-ref a 0))))
- (pass-if "127"
- (begin
- (array-set! a 127 0)
- (= 127 (uniform-vector-ref a 0))))
- (pass-if "-128"
- (begin
- (array-set! a -128 0)
- (= -128 (uniform-vector-ref a 0)))))))
-
-;;;
-;;; syntax
-;;;
-
-(with-test-prefix "syntax"
-
- (pass-if "rank and lower bounds"
- ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
- (let ((a 'address@hidden@7((1 2) (3 4))))
- (and (array? a)
- (typed-array? a 'u32)
- (= (array-rank a) 2)
- (let loop ((bounds '((2 7) (2 8) (3 7) (3 8)))
- (result #t))
- (if (null? bounds)
- result
- (and result
- (loop (cdr bounds)
- (apply array-in-bounds? a (car bounds)))))))))
-
- (pass-if "negative lower bound"
- (let ((a 'address@hidden(a b)))
- (and (array? a)
- (= (array-rank a) 1)
- (array-in-bounds? a -3) (array-in-bounds? a -2)
- (eq? 'a (array-ref a -3))
- (eq? 'b (array-ref a -2)))))
-
- (pass-if-exception "negative length" exception:length-non-negative
- (with-input-from-string "'#1:-3(#t #t)" read))
-
- (pass-if "bitvector is self-evaluating"
- (equal? (compile (bitvector)) (bitvector))))
-
-;;;
-;;; equal? with vector and one-dimensional array
-;;;
-
-(pass-if "vector equal? one-dimensional array"
- (equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i i))
- '(0 2))
- #(a e i)))
diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test
index 5b7acc9..1789287 100644
--- a/test-suite/tests/version.test
+++ b/test-suite/tests/version.test
@@ -1,7 +1,7 @@
;;;; versions.test --- test suite for Guile's version functions -*- scheme -*-
;;;; Greg J. Badros <address@hidden>
;;;;
-;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2010 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
@@ -26,7 +26,4 @@
(string=? (version)
(string-append (major-version) "."
(minor-version) "."
- (micro-version)))
- (string=? (effective-version)
- (string-append (major-version) "."
- (minor-version)))))
+ (micro-version)))))
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
new file mode 100644
index 0000000..47e386e
--- /dev/null
+++ b/test-suite/tests/vlist.test
@@ -0,0 +1,303 @@
+;;;; vlist.test --- VLists. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Ludovic Courtès <address@hidden>
+;;;;
+;;;; Copyright (C) 2009, 2010 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-vlist)
+ :use-module (test-suite lib)
+ :use-module (ice-9 vlist)
+ :use-module (srfi srfi-1))
+
+
+;;;
+;;; VLists.
+;;;
+
+(with-test-prefix "vlist"
+
+ (pass-if "vlist?"
+ (and (vlist? vlist-null)
+ (vlist? (vlist-cons 'a vlist-null))))
+
+ (pass-if "vlist-null?"
+ (vlist-null? vlist-null))
+
+ (pass-if "vlist-cons"
+ (let* ((v1 (vlist-cons 1 vlist-null))
+ (v2 (vlist-cons 2 v1))
+ (v3 (vlist-cons 3 v2))
+ (v4 (vlist-cons 4 v3)))
+ (every vlist? (list v1 v2 v3 v4))))
+
+ (pass-if "vlist-head"
+ (let* ((v1 (vlist-cons 1 vlist-null))
+ (v2 (vlist-cons 2 v1))
+ (v3 (vlist-cons 3 v2))
+ (v4 (vlist-cons 4 v3)))
+ (equal? (map vlist-head (list v1 v2 v3 v4))
+ '(1 2 3 4))))
+
+ (pass-if "vlist-tail"
+ (let* ((v1 (vlist-cons 1 vlist-null))
+ (v2 (vlist-cons 2 v1))
+ (v3 (vlist-cons 3 v2))
+ (v4 (vlist-cons 4 v3)))
+ (equal? (map vlist-head
+ (map vlist-tail (list v2 v3 v4)))
+ '(1 2 3))))
+
+ (pass-if "vlist->list"
+ (let* ((v1 (vlist-cons 1 vlist-null))
+ (v2 (vlist-cons 2 v1))
+ (v3 (vlist-cons 3 v2))
+ (v4 (vlist-cons 4 v3)))
+ (equal? '(4 3 2 1)
+ (vlist->list v4))))
+
+ (pass-if "list->vlist"
+ (equal? (vlist->list (list->vlist '(1 2 3 4 5)))
+ '(1 2 3 4 5)))
+
+ (pass-if "vlist-drop"
+ (equal? (vlist->list (vlist-drop (list->vlist (iota 77)) 7))
+ (drop (iota 77) 7)))
+
+ (pass-if "vlist-cons2"
+ ;; Example from Bagwell's paper, Figure 2.
+ (let* ((top (list->vlist '(8 7 6 5 4 3)))
+ (part (vlist-tail (vlist-tail top)))
+ (test (vlist-cons 9 part)))
+ (equal? (vlist->list test)
+ '(9 6 5 4 3))))
+
+ (pass-if "vlist-cons3"
+ (let ((vlst (vlist-cons 'a
+ (vlist-cons 'b
+ (vlist-drop (list->vlist (iota 5))
+ 3)))))
+ (equal? (vlist->list vlst)
+ '(a b 3 4))))
+
+ (pass-if "vlist-map"
+ (equal? (vlist->list (vlist-map 1+ (list->vlist '(1 2 3 4 5))))
+ '(2 3 4 5 6)))
+
+ (pass-if "vlist-length"
+ (= (vlist-length (list->vlist (iota 77)))
+ 77))
+
+ (pass-if "vlist-length complex"
+ (= (vlist-length (fold vlist-cons
+ (vlist-drop (list->vlist (iota 77)) 33)
+ (iota (- 33 7))))
+ 70))
+
+ (pass-if "vlist-ref"
+ (let* ((indices (iota 111))
+ (vlst (list->vlist indices)))
+ (equal? (map (lambda (i)
+ (vlist-ref vlst i))
+ indices)
+ indices)))
+
+ (pass-if "vlist-ref degenerate"
+ ;; Degenerate case where VLST contains only 1-element blocks.
+ (let* ((indices (iota 111))
+ (vlst (fold (lambda (i vl)
+ (let ((vl (vlist-cons 'x vl)))
+ (vlist-cons i (vlist-tail vl))))
+ vlist-null
+ indices)))
+ (equal? (map (lambda (i)
+ (vlist-ref vlst i))
+ (reverse indices))
+ indices)))
+
+ (pass-if "vlist-filter"
+ (let* ((lst (iota 33))
+ (vlst (fold-right vlist-cons vlist-null lst)))
+ (equal? (vlist->list (vlist-filter even? vlst))
+ (filter even? lst))))
+
+ (pass-if "vlist-delete"
+ (let* ((lst '(a b c d e))
+ (vlst (fold-right vlist-cons vlist-null lst)))
+ (equal? (vlist->list (vlist-delete 'c vlst))
+ (delete 'c lst))))
+
+ (pass-if "vlist-take"
+ (let* ((lst (iota 77))
+ (vlst (fold-right vlist-cons vlist-null lst)))
+ (equal? (vlist->list (vlist-take vlst 44))
+ (take lst 44))))
+
+ (pass-if "vlist-unfold"
+ (let ((results (map (lambda (unfold)
+ (unfold (lambda (i) (> i 100))
+ (lambda (i) i)
+ (lambda (i) (+ i 1))
+ 0))
+ (list unfold vlist-unfold))))
+ (equal? (car results)
+ (vlist->list (cadr results)))))
+
+ (pass-if "vlist-append"
+ (let* ((lists '((a) (b c) (d e f) (g)))
+ (vlst (apply vlist-append (map list->vlist lists)))
+ (lst (apply append lists)))
+ (equal? lst (vlist->list vlst)))))
+
+
+;;;
+;;; VHash.
+;;;
+
+(with-test-prefix "vhash"
+
+ (pass-if "vhash?"
+ (vhash? (vhash-cons "hello" "world" vlist-null)))
+
+ (pass-if "vhash-assoc vlist-null"
+ (not (vhash-assq 'a vlist-null)))
+
+ (pass-if "vhash-assoc simple"
+ (let ((vh (vhash-cons "hello" "world" vlist-null)))
+ (equal? (cons "hello" "world")
+ (vhash-assoc "hello" vh))))
+
+ (pass-if "vhash-assoc regular"
+ (let* ((keys '(a b c d e f g h i))
+ (values '(1 2 3 4 5 6 7 8 9))
+ (vh (fold vhash-cons vlist-null keys values)))
+ (fold (lambda (k v result)
+ (and result
+ (equal? (cons k v)
+ (vhash-assoc k vh eq?))))
+ #t
+ keys
+ values)))
+
+ (pass-if "vhash-assoc tail"
+ (let* ((keys '(a b c d e f g h i))
+ (values '(1 2 3 4 5 6 7 8 9))
+ (vh1 (fold vhash-consq vlist-null keys values))
+ (vh2 (vhash-consq 'x 'x (vlist-tail vh1))))
+ (and (fold (lambda (k v result)
+ (and result
+ (equal? (cons k v)
+ (vhash-assq k vh2))))
+ #t
+ (cons 'x (delq 'i keys))
+ (cons 'x (delv 9 values)))
+ (not (vhash-assq 'i vh2)))))
+
+ (pass-if "vhash-assoc degenerate"
+ (let* ((keys '(a b c d e f g h i))
+ (values '(1 2 3 4 5 6 7 8 9))
+ (vh (fold (lambda (k v vh)
+ ;; Degenerate case where VH2 contains only
+ ;; 1-element blocks.
+ (let* ((vh1 (vhash-cons 'x 'x vh))
+ (vh2 (vlist-tail vh1)))
+ (vhash-cons k v vh2)))
+ vlist-null keys values)))
+ (and (fold (lambda (k v result)
+ (and result
+ (equal? (cons k v)
+ (vhash-assq k vh))))
+ #t
+ keys
+ values)
+ (not (vhash-assq 'x vh)))))
+
+ (pass-if "vhash as vlist"
+ (let* ((keys '(a b c d e f g h i))
+ (values '(1 2 3 4 5 6 7 8 9))
+ (vh (fold vhash-cons vlist-null keys values))
+ (alist (fold alist-cons '() keys values)))
+ (and (equal? (vlist->list vh) alist)
+ (= (length alist) (vlist-length vh))
+ (fold (lambda (i result)
+ (and result
+ (equal? (list-ref alist i)
+ (vlist-ref vh i))))
+ #t
+ (iota (vlist-length vh))))))
+
+ (pass-if "vhash entry shadowed"
+ (let* ((a (vhash-consq 'a 1 vlist-null))
+ (b (vhash-consq 'a 2 a)))
+ (and (= 1 (cdr (vhash-assq 'a a)))
+ (= 2 (cdr (vhash-assq 'a b)))
+ (= 1 (cdr (vhash-assq 'a (vlist-tail b)))))))
+
+ (pass-if "vlist-filter"
+ (let* ((keys '(a b c d e f g h i))
+ (values '(1 2 3 4 5 6 7 8 9))
+ (vh (fold vhash-cons vlist-null keys values))
+ (alist (fold alist-cons '() keys values))
+ (pred (lambda (k+v)
+ (case (car k+v)
+ ((c f) #f)
+ (else #t)))))
+ (let ((vh (vlist-filter pred vh))
+ (alist (filter pred alist)))
+ (and (equal? (vlist->list vh) alist)
+ (= (length alist) (vlist-length vh))
+ (fold (lambda (i result)
+ (and result
+ (equal? (list-ref alist i)
+ (vlist-ref vh i))))
+ #t
+ (iota (vlist-length vh)))))))
+
+ (pass-if "vhash-delete"
+ (let* ((keys '(a b c d e f g d h i))
+ (values '(1 2 3 4 5 6 7 0 8 9))
+ (vh (fold vhash-cons vlist-null keys values))
+ (alist (fold alist-cons '() keys values)))
+ (let ((vh (vhash-delete 'd vh))
+ (alist (alist-delete 'd alist)))
+ (and (= (length alist) (vlist-length vh))
+ (fold (lambda (k result)
+ (and result
+ (equal? (assq k alist)
+ (vhash-assoc k vh eq?))))
+ #t
+ keys)))))
+
+ (pass-if "vhash-fold"
+ (let* ((keys '(a b c d e f g d h i))
+ (values '(1 2 3 4 5 6 7 0 8 9))
+ (vh (fold vhash-cons vlist-null keys values))
+ (alist (fold alist-cons '() keys values)))
+ (equal? alist (reverse (vhash-fold alist-cons '() vh)))))
+
+ (pass-if "alist->vhash"
+ (let* ((keys '(a b c d e f g d h i))
+ (values '(1 2 3 4 5 6 7 0 8 9))
+ (alist (fold alist-cons '() keys values))
+ (vh (alist->vhash alist))
+ (alist2 (vlist-fold cons '() vh)))
+ (and (equal? alist (reverse alist2))
+ (fold (lambda (k result)
+ (and result
+ (equal? (assq k alist)
+ (vhash-assoc k vh eq?))))
+ #t
+ keys)))))
diff --git a/testsuite/t-records.scm b/testsuite/t-records.scm
index 0cb320d..9aa4daa 100644
--- a/testsuite/t-records.scm
+++ b/testsuite/t-records.scm
@@ -11,5 +11,4 @@
(and (stuff? (%make-stuff 12))
(= 7 (stuff:chbouib (%make-stuff 7)))
- (not (stuff? 12))
- (not (false-if-exception (%make-stuff))))
+ (not (stuff? 12)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-manual-2, updated. release_1-9-9-84-g26b9f90,
Neil Jerram <=