[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-114-g69e6
|
From: |
Noah Lavine |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-114-g69e653e |
|
Date: |
Thu, 23 May 2013 04:03:46 +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=69e653ef032205ea2dd96e0b86ab8785f933348c
The branch, wip-rtl-cps has been updated
discards 3f7a14a4c6518230774c0df14dde33db15dfb253 (commit)
discards af5463addbda9c54a89edcf71ea13608e3749e9e (commit)
discards d371575dc32a4f7c8c1c0453c24684916791fc17 (commit)
discards be665ec0fe9f28f13d904a96ee32e691f52b1b01 (commit)
discards b07be59260bf66dbb762c1660717231d4be3483a (commit)
discards f0c06dab524e91c0126a9d222df586de3cd2e020 (commit)
discards e49b8f6e09ac7ce81db79f3ad1ab78ee60d738fc (commit)
discards 847c835017954da66375909d15c9266e0d927abf (commit)
discards 20b2833f65cd20044aea40ce547873f453eb29ea (commit)
discards fb339dacf27d2da3a22d20502f14cffe9dc9431a (commit)
discards 3a03f6a66c156b712c439cfd93bc18171d7e3793 (commit)
discards 2463a0c94028fa573f8b7be8b21827b54f5ba191 (commit)
discards 967985e0cf0fdf7e7aa1061955ed0a21a527333d (commit)
discards 627636130d246c3953c150067a0f1def34e45a34 (commit)
discards c4b9e1845834e866f9ab540cbe8be20f09d33eae (commit)
discards 680c4ee2172cf97dd40a05df467014f3a86e08c3 (commit)
discards 0d0808ae3f7390ffb250b9deb6706ad4158cce0e (commit)
discards eebd889baa1d7f762e144ad7f9af005946d75273 (commit)
discards c6540722c35720d664dd3c294440700746bb6eb1 (commit)
discards 9be266c32e468e81c72b0affc88da81e6cb9ee1c (commit)
discards 2aeb4f87c345c709e59f5fe402a9379d15587f1a (commit)
discards 7e1bb2eabee8417a7d487db3fbf32f5c678e1093 (commit)
discards f49400707ce911a6bcaa0d041fa0be131c15e59c (commit)
discards d959dae4ee8daca7ee3353865473dc841833433b (commit)
discards d01c9173735d87713f9eb66aec1f13d04f9aa32e (commit)
discards 602113a3cf7f8cc739e3cd9db058d1b4a4b7bfd3 (commit)
discards c417e582b6dd48a5704ec18348a05b5b1f2203e6 (commit)
discards 38ad3632f861e0d8a62d83506ca8f7b8f21d3bf6 (commit)
discards 58044df2b4309da8c86e32856733acbfbbe1cad5 (commit)
discards a7a634a6eb116549268afe22015af16c72fa9f42 (commit)
discards a73cfb0f0420e0bba309b1134ee4e6661be36fe6 (commit)
discards 9b4150779820016deb434136b8ebe9b2fabbf39e (commit)
discards 37383294d8fcb32cdab21b33b886175e6f018ce3 (commit)
discards e2bb02e54fa6e98ab97f30863ccf09cd3fd7254e (commit)
discards 8f46174e29551dc6755782732f0b11a0a3352a2a (commit)
discards b411a8d7f918d9b89502928fdf37b18894ee7aff (commit)
discards 9c4515c8651ce64ba91cf28da770e938c59a8808 (commit)
discards 9cc45ec0cd4268d14db11ffd4840a6561fc43c35 (commit)
discards d46dcbd600b62d6e57a8bb1ac4907f4443f62e37 (commit)
discards ca159cd799998979463d95c16a7a2b3c6df6815d (commit)
discards e08e3776d44305668cb882b25e6ee28e23da04b0 (commit)
discards eef6081243532bec75c87d66cee09c3306183933 (commit)
discards 103ccc996ff56d2464c4f643895a2057edbd7c63 (commit)
discards bbb9cdd5382df79962ce4d3bb25771331d7890d6 (commit)
discards bf51d129e7e557b629ea6568b581e43a261d5c7d (commit)
discards 03cedbac1b77aae1c9df4f615d1f2dce07ac0bda (commit)
discards dd02f3bd546f6a41d75785e8096b31b78e94167f (commit)
discards fe0dbf1b0a5227fcd2e2aaa2b2095aeca9d46052 (commit)
discards 75b2cc9a56d9de6a5ad39db1493813cb917bdc6f (commit)
discards e33e246fcf1992811b733da996f7df57a3dc1aa4 (commit)
discards d900ea5ee8f55d844191ec5f678101c4c1c64962 (commit)
discards a70ffd7d13d62c75e84ecc47cf1962f4f9673ecd (commit)
discards b06bfd5104b92dfd0fbfe78efc24e68a9467eb61 (commit)
discards ab44a67328af6f77149b5b0a4bfb195ef15a6e34 (commit)
discards c1494c22bd5f3ee121c5ee78ab462eecc8ea8964 (commit)
discards d537993369918e47d5e7d3eb787f9a85cb4ba0fb (commit)
discards fc16925e20c0754e7d823ea5d1809aeb486697fe (commit)
discards b4bd81b82001839083dc176b362d620addccd056 (commit)
discards 690f43d546b37e6572eb926d8c93ba39efd539f4 (commit)
discards f05d113a20fdc1b9a5db89103e62d156883f4095 (commit)
discards 01588507c854cfa89dabd94760cdc25ba4f5978f (commit)
discards d559fbdf7e0969c3b43a5c36d539640a4aa8ecec (commit)
discards f4c066e9fd8e8f569306567bfa857275355628d8 (commit)
discards b8f24db188debc484f1a6ba944461be74bb22a4d (commit)
discards edef0333e7e2b5dc2e821d789da1b21503a436bf (commit)
via 69e653ef032205ea2dd96e0b86ab8785f933348c (commit)
via b7a0e32510d294783547af92ac01d07f41d67c64 (commit)
via 565160d0b906a5deedb75ed65fb55fd69a25d931 (commit)
via 3b9cb3fced6d4e6370aca357ffbcd04b34cbecbc (commit)
via faabd2c9fd64f17fde4e5795ab64ac1f53b6146d (commit)
via 65e2887f02983c8846d5fbc38c6823dc5db10ac0 (commit)
via 71e0b716e6bf9e9c034073c01a002ffc2b03a14f (commit)
via 376611dafdf2d93b296d69a0c904832e75248627 (commit)
via bd56dba661850843e85d03bcda7dae2582200659 (commit)
via fa3567bd6818a9fe794e8b68242fb0f182285039 (commit)
via 2a50320c24a8290f6262a69dbc6465989f377df3 (commit)
via 0c8f13d559e8ad379d0b6fc1ff26fe43f243e013 (commit)
via 71a43ae7ea77acbad5b75d82098349c8d24e8e83 (commit)
via 22823ad400b6f6e6469c152f2908bd96ad52e63c (commit)
via 518f03a79d0383a24d9af9399ffc662a8ebb96bc (commit)
via a240d1edf1b314bdda9bdaf2da0ee4a1c7bf8567 (commit)
via a451fc92d75ca6691e9682a71f77163a4379fc9f (commit)
via cb1859ed3c97146a0e9797532dc950a5c79ab068 (commit)
via b57621e62ae2b5c5224b6334785855f1bb349c0c (commit)
via 1b50c36edef2d8fd0e04fa0bed890546203ddc54 (commit)
via 14922acd705d62932e095675a2407d7fcd5db1c4 (commit)
via 169ed53f82bb9d6c5b518a9d6b2ed538f500b240 (commit)
via e2eea905032dbd57356154fd6942394fac770c1b (commit)
via 4f4c8b9a3460a0da22b325fe3b9125e17903688d (commit)
via d4fa79fc07edb78eada294c739a5077581c9c832 (commit)
via 8250248a8aba3b799d096d6cccc07489f8401fcc (commit)
via f06f9f9a670d062238da7a1096274d909322993d (commit)
via 7e653a14720c9d538285e47f3ee1c59f261469c6 (commit)
via 3388b2909f97eeb2d51116f03c235fedb5ef048c (commit)
via 9c7ac4455102cde2a5cab4ec47a7034c36e78048 (commit)
via a4659be4915160527994bbce6c51f2175f22902a (commit)
via e518855430bea39fa784ea0128f976b651dea0a4 (commit)
via ebf6f50e82e86da2710bec076e4dfc3f2a7b77a0 (commit)
via 2724a1bedae60795c409d0c992db4b76902b227c (commit)
via 9db0d53c8076d2c64fe7ea0c37f1ea7ca7485fe2 (commit)
via 42cce87a63b1530d1613edb4807777d66e2564e3 (commit)
via cc9f2d2ea16b078f16b19a5db48beb19e2a64e03 (commit)
via b45297eb7184abcf4abc2bbd285ca694448f5d11 (commit)
via d46ac9f5e805f3bb2e924d50293fbd891103af05 (commit)
via 0d0fef29963519cf3bc77a65525dc227ac9a8423 (commit)
via 27a81805c441a77f0218ed5e3445995e6c740e5b (commit)
via 6b5679e39a65f38e025c9eab58faf3f45cf0e374 (commit)
via 3bfb859e9fd08f168062985c870f2d424bc114cf (commit)
via 2bb1ab70e29c7d74b596cc7c36d622de681f996c (commit)
via 23e20c4ef6ad2bc0214f6d0c473256f741c4f399 (commit)
via 2dca054650731e6de1b9a5e397c7bd681be1813d (commit)
via 1b38955510fb5a4669d00f80042882887c6302ef (commit)
via 793d210958308a2373acfba462b4b77a8a48af02 (commit)
via dbe241fcce7b6b411755ed54dad400ba5f070dd0 (commit)
via 9eb1082917db07fcf460c0a9b94d4b62421cd048 (commit)
via 908aa266c4335807f804a789633b79610a0565e8 (commit)
via 018b17b0d7004cc03b7760a471dc7ab91930639b (commit)
via 6f6fa2f9e5625264a7dc24bc83f7f3574dc25a50 (commit)
via c8c72d779ce244473edfa7917ac1dc5badd24f0b (commit)
via 0dc7dc27fdbb0079f9d36336965f85231b5bcb42 (commit)
via 7e1770fcf1e6cc1d72e02d22f558fdd44a909ed1 (commit)
via 296ba392fde0b3c3e9eb68168beadb5157fe3206 (commit)
via 552110a1f239925bd481067dfd02fb5bc06d859a (commit)
via d14e903c59862cd4dab6a96fd8963387986f5276 (commit)
via fe4589b54f9b116d589f35972e093a3de9c5e802 (commit)
via 36192fad0d6dffd29a8f7757f9491a85e477f67c (commit)
via 17bf887174a43b35c28e157f1db281ade964f05e (commit)
via 67759d2f98d7ca1aedb8e73ab6958ae9687c2767 (commit)
via d273a31b957eeef14b1e68e93aec45e78449e125 (commit)
via ca1bc7ea9d5b24755365e01a7b8beeca565e0e7b (commit)
via bf2321bfd43cbe49d481f1b3c40f26156375a3ae (commit)
via f1de620f2ca81adca9f9d3cce5b8497cd81e5360 (commit)
via bc7e981d1f63c93ad6cabeb5a555c95612fb8632 (commit)
via 424b2a5f27dbd072f5820c4da27a6c99ca8b7fd3 (commit)
via 035baf41e24fb106e26af22ca30b36bc9c91f38a (commit)
via d9da66f0d9442f7e0d1b50dac798f7e4df4fa4e4 (commit)
via 9a3b644be9b567c40b3a0bfe07c41554ad439f47 (commit)
via 76bbaf2fc0f28a187fc5127033ac259d427b6797 (commit)
via 8a3e07c371538eefd066bb6d6d884a1d50782e0c (commit)
via fd899af33d84a1263f68c066c2bbb612cdba9606 (commit)
via 825ca5201fa5584a8912d790ce9d0b9183e4756f (commit)
via 907e5d36940e457cf3f62e60b453252a4a9b24eb (commit)
via 96e97fb222a7abf5e655e4139ca828b8cc5c2cb0 (commit)
via 82dde214166de8a1d58d2f48c324978136cf7abe (commit)
via 49460b177e6bf2b7cd301c3542d99122e96afac9 (commit)
via 4c5969aa9f0257e6d7901e107ffd63afe89aef31 (commit)
via 21ce20e5f809c021567ff0c86243b1e3a35209c3 (commit)
via 40c122fe9f45267fd8258b98fef961fee4753ebf (commit)
via 320f390856fc155f5efc343aac2b9ad9e6fe4f3c (commit)
via e770d89c839f321efc819ac925f6807623cbbceb (commit)
via e82ce87fb95ff3c26f5906b68b732afbe71ff4fd (commit)
via db6e47794757ce055ea80c35f027cd9928868b56 (commit)
via 44e5b0b6764b9eb4300e27c6d41065783504772e (commit)
via bf70050bec92f8e3e24bc21b6d399618a4d06521 (commit)
via 49f90dd01649b356014fed0bdc3d9d5028a0f218 (commit)
via 70c4e6787b19fbf130706f90614a164780c70feb (commit)
via a8d4671006ad6627ef92194054c51e28183f791c (commit)
via a24e55fdd0ecc4ee3a31b8236d6fa66b868c6d04 (commit)
via 41d7621ab541a7977e15401fcbc441c624b0eff6 (commit)
via be75c01efe6f11015db65c5aeb0a71681b496100 (commit)
via e6f107f5ae5be11b619762b8e008313f51a33f90 (commit)
via e865524c6a37fcfd01f10290741a85dffd16c83f (commit)
via 175b2c42b18bf510377df4d42c8ccfa629d54aee (commit)
via a000b510a9c4b6943930b1e30ad22513671981c1 (commit)
via bed8e4bcfe1ea4665e0bc19a20d7e4c3523111f0 (commit)
via 9c18030fb0974c618c0a24a98b3cabae206387c9 (commit)
via ac86a0da65fa06fce462301a20c94fbba360f5fb (commit)
via 1102f1da7bf47fbee9671a40e6d947fcece327d3 (commit)
via c10992a55450f4ea60bd54bf4b205ca9495ecf26 (commit)
via a580a843111a5785f7936a8198eebfb1ce854b8c (commit)
via ae10f67435c9cb513e0fa2afa83b00380a6ed793 (commit)
via 1b891621c7a18c658a03eba0213845cbdb50ffee (commit)
via 511e94c56fbef422ed8ea4984461a06dbb676d0c (commit)
via a2a2bf7e2c0d840bf84d1edc8e81fe30df795f6b (commit)
via ed094734e59d1b2bbf30f2ab17b21377b5dd15fe (commit)
via 8ba3df917b47c33161de1c225757636ddb6ba7ba (commit)
via c072e1bc8bed5f2dba94a1ee640a875d49e2febb (commit)
via 099eb548ad27bb8b54adaf1116e72c45130122ee (commit)
via 60827e5df16151f2ca77b2dfd4617e23604da6f1 (commit)
via f6f4feb0a2222efcb297e634603621126542e63f (commit)
via f5b2eea6a39507ecf6a8ecc62cc1c796c45c2d1d (commit)
via 3f315b64332a61535846dc87284e091bada747e5 (commit)
via f480a98e9ac784e24e418ff307b67c22568a682e (commit)
via dac5e6491b215f8d70bc8328639b4c72cb7cd565 (commit)
via 7f74dcb4a5439bb2247875f458b5f0a20710af07 (commit)
via 800c094382c2e506c46c6e98e7b867d3df2e066f (commit)
via 039300a1ebee116082d50d61e6b3aeafc8a741ec (commit)
via cfeb9130bb5d1b512279bbdce0e9211f85d359f6 (commit)
via 3e78acd978a437c0aa5f5405daca59f1fb648516 (commit)
via fff92ff309075ed599a07a2e9378a0ed587ce073 (commit)
via 486a456d4d456f712ca9bb7b63cd58aadbaef536 (commit)
via 47ad34fad6d79c93e1d1a213641c747ba05a3ef6 (commit)
via 9a5b6f6edaf33282c29add729a9d55527abd5517 (commit)
via 11f80955e8a218ba0bfddc206b79a6916705eae8 (commit)
via 4e7d48a04bb9500afff4d44e9bc9e03c536f12f8 (commit)
via 14f2e4706863b4dafc55c7b7ff8682634f77a96e (commit)
via 40e2a31d8710eddbf564fa11d14a6af57e504448 (commit)
via 32cec09d136060e02dfa28d65f2cb19028706652 (commit)
via e67cea4214959663ff103b19cea0db9d6c869a9e (commit)
via b1b1cbcb78a7b4e2777ab596ae24d10d28aef8fb (commit)
via 82352e01ff33dfe4d554f1f8d3ec55940ed2bc43 (commit)
via f841b26d847edf2d8196c3c21c090f50cf3a614f (commit)
via 51607806ec2f2fbe4e4739c3ed599a36121e5d42 (commit)
via 3c8f2ae958f96f16ffcbb74e0b022bd9999ecb03 (commit)
via 22c76fd82288fee2cb0bb744c2e28d1be42204de (commit)
via 7ca88a403f1a81e7ab48f2b5a6d5d07ed4b5ef9b (commit)
via 7520a9b95d2661cf40f6c1bf8be79f38ca632516 (commit)
via 7f3be1db9949b0566d3a2cb6bd9d0e84287bbb0a (commit)
via eed0d26cc0668a309b610113554be5df8dfb32e9 (commit)
via e0886e0780fc1f3ce1c80d0692c11adf3b68f682 (commit)
via 254d313a21f06739930032062678ff5360d248fd (commit)
via 7099eec4fb93d74beace4cef20a93c1e4f0aee5f (commit)
via 3ace9a8e4e1de7082ceec4aea0813a6adaa913bf (commit)
via b6e374e535597448cb09588300d76b5d270d5d3a (commit)
via 3ed8d953f8d0da8ed82fe939ce48a563d7abe19b (commit)
via 7f6c3f8f0012e916469fa6c50b44c621ebdc89ac (commit)
via e1966d0e214b0967c19da71b235196adb057d2b5 (commit)
via 9a334eb3ab6bbb250d9c0f559b82d1c97f5eb21a (commit)
via bc3901092dc777d832862862e606ae2ddeb6f2f8 (commit)
via 7d39b48875475b2d206789cb9b6486b79c7be55d (commit)
via 48ffc52cc96fc0665183d9a9e3f68e7e031487f4 (commit)
via a71e79c3e5a5c366bb9ec218ee537441b8e5949a (commit)
via 3e5a164ac3d93a1a43c0e81842d0583fe0031b84 (commit)
via a16d4e82e949954805bf2cd42cfbb519fcf4012d (commit)
via c608e1aafae347dc52cda70aa9379e9b6803b5e6 (commit)
via 9c90a81bb5beafdf4e15847a59a967c70f00c400 (commit)
via 4ad329cbcaeef603d047df5dd226fb17f0b81483 (commit)
via 47ed3ca43aa32acf1550c0ff9696b1b51f43e236 (commit)
via 004094d378182d8343398c0bec817114c06ea933 (commit)
via 66750b78c7f67e91d1e01a4926e2e85a12f2b16a (commit)
via 3f1362adb5203b95079200520357bff36c3a6672 (commit)
via a24cda1d26e09ddddb2cfe6633d7fee7a1b66d35 (commit)
via d09b201d59f55f692323f82866512cba2cb29c76 (commit)
via ab1ca17986ee758b7ec4088bf3f6a596872b1677 (commit)
via b5159a471a1acbe1ad08ee5365d123912fcc607d (commit)
via 55e26a49dbc5fa7ccbf218305d88b0b37db4db3f (commit)
via d888b531681c8528a2daafe0bea70c0a42313da6 (commit)
via 96965a6ecb04b5380fd6d618e70d64dec3ac37be (commit)
via e501f2111e0d5a8bc037cfe3df4e6ba0655285d5 (commit)
via 4b76acfa38d6939241e0b4cfdbbc46e8aac13e1a (commit)
via 4a1cdc9d5d643d05fa7a18febc7c12070f3ef6d9 (commit)
via cdd3d6c9f423d5b95f05193fe3c27d50b56957e9 (commit)
via 45c0878b8665182f06a917e391169031c1dc7db6 (commit)
via 0426b3f8f8036364aca13c24ef769283937faa3d (commit)
via 71539c1cd3bf16dfdb87dc6c0c5f4238ebf8dcd9 (commit)
via 412053922501e2e9cac7fc0c1b91de8fc3aa375a (commit)
via c3e3ef6eb6d1487d342389b202b0b00f9385de6a (commit)
via 3220b080498580586726313ec63db9eaf68334d8 (commit)
via 0d7f3a6d957a3129dc0aa203abc1b6adc82db295 (commit)
via 51a1763f6596d594ebd774e7c3fd9138e6f4d507 (commit)
via 9a68d7b388c610cdbc5689ae9cbadb70ee311f67 (commit)
via 75a1b26c5d06e791afce10be9b1ab4e5272e45b4 (commit)
via 7290de89fb5bf755e2520bd01e977dc132c50c4b (commit)
via 72e2b5923a15f49fd7f7706fe35dfc1157a41bb5 (commit)
via 9a31a54561b859dfbaca4f4523252a76adb56386 (commit)
via e00793d7a986053976c088f4aa4088c4d648825d (commit)
via 1fa89aaf6191dfe24e7494726ce37b698736103f (commit)
via 1ee237d9a159e0e9a995ecb9fea24e1d39a7c5e1 (commit)
via 8a2b596579185cd0f4d35da478f447e529d81a80 (commit)
via 187fa0b9e7ff9b2d6204517a9daa9009245c7511 (commit)
via 05d7f76296dc9fa21e0abd1ce6105a042905f48e (commit)
via 21bbe22a14a75fab54a5a8563fad63851a18fee3 (commit)
via 337edc591ffd8f8ec4176b0112ad10da29818141 (commit)
via e459855936262b4bddaebd87a75abdc065799be2 (commit)
via 663780bb1c881947b6e4f00c456b2b367701982d (commit)
via 369294866dd7ee01ebf821df2a119ea55b1e68fd (commit)
via 1e051065628a7f1bd4398fcc11cd181f86084629 (commit)
via de2bc673bba931a70e3b96336cab6512a47541fe (commit)
via 786ab4258fbf605f46287da5e7550d3ab4b68589 (commit)
via 2f13a46672a347be0f7bb1b360a213f6d6ce0288 (commit)
via 3b80c3585221a899c9a6b87e742d267655bb0abc (commit)
via 47f2bce5ae332c274270882c259776b8e4ea12f7 (commit)
via 86cf4773ff94a128247d484e6d69786869f41ebc (commit)
via b05257b9232e2ee631c28b15cace5981c4927446 (commit)
via beac49b8e129b28902f4b600e15aa3b92c9ce7fd (commit)
via df3d365a99311ecfe921d1dfd1848ff65112e572 (commit)
via 7e7c6f6a937005b08fffd5aeccdf992459b07137 (commit)
via 7bfbd2935fa812a0581df5b78c1a3b9836065f39 (commit)
via 0ddf484d3eeff9238cb4bf6f89d461748f42cb1c (commit)
via c33ecf96a41979be0af1d56a7e12ad7c1196f12b (commit)
via 4702deb424633ad02c495c01d950b973c0ead8ea (commit)
via 465ff50245e0f5deb26612ac7401b51c415deeb0 (commit)
via 2a7d614cc0bc902895cdb873590e8a24cf680368 (commit)
via 8d6e3dd83a09f35a18774baa696ba443aa379cbb (commit)
via 07b390d5827da2f46f57e4650167920fb792ebc9 (commit)
via 06589f5c229c3ce4dd2cb627c90ef4372dd0a571 (commit)
via 4a0821a8d5cfff50fef8c119a0d76355b6126009 (commit)
via 10d278fde5dcd8033fe1209657aa58ce792b9b83 (commit)
via 26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0 (commit)
via 579127cce488ce208d62e68e679e34fbbdc17367 (commit)
via 10b8cf1ebdba6989e8c9b23838d2f20d6cb7d60b (commit)
via 82ab673ceafa3174d9e5f8dfec08221ba69addba (commit)
via 80b809f114e9f3978aa6571affd343f34732fb94 (commit)
via 50d08cd8943dd54762d76746d5eec53af178eeae (commit)
via ed4aa26489d33c22bcdbce2bb037a87df41bef16 (commit)
via 8a177d316c0062afe74f9a761ef460e297435e59 (commit)
via 8cd109bf0a10e37c26bf476fed81a0d4282d13c6 (commit)
via ffc8eca636a8e9311d35c9adba2fc80476ab11ca (commit)
via c548da6949fef565dd1267afa5bbf2c21edda366 (commit)
via 41502bd00f12a6bce97484d33f5519e97a04cf2a (commit)
via d291d7990d72b5cb8a18b20e524e1c8324297e92 (commit)
via 65ad02b96d4118970406b1474aa00bbe801aa61a (commit)
via 59b0f9d7635ea7e272e2976ab69764a570d7f6ff (commit)
via 5bb40f9df02c3395b198f254fdd43e7468b5ceee (commit)
via 570fdeceacaad7f6e928123f40e8bb5f72677dcb (commit)
via 11ed42771dec06626457eae58f2f334df1397f72 (commit)
via f28885f4957882c4d96bdfee11d26cd265539aac (commit)
via 45417ab1066b3f7f65ff4ff4f6ca2733c75bd521 (commit)
via 86fafc440220b0ab1d76439e89ac8114a9c7660d (commit)
via fbac7c6113056bc6ee85996b10bdc08325c742a5 (commit)
via e8a57fb052c4d9c27681183bd0cf2be31142d58a (commit)
via 43c2a48323803e9aae41ba896ce6b6a0067343ad (commit)
via c5c7c1146f2488f92b11b1edbe36fa99ffdf2771 (commit)
via 6cfdc6b87881a592b7ad99db8d9ea0ee13a4101b (commit)
via 2bb7a730137013d2cc931e3b5932f6235d76e1e1 (commit)
via 8fe4c4eccbd6fcd5e26d955cc3b59aef60f561ee (commit)
via 4215ea75a525a848ce9d73fad9c03983e8b3cd0d (commit)
via 797b2aa69aeb7db607250bad83d31a31f8f4d1c7 (commit)
via c52ce75a1f87e72d675fc5a6ad95ef26dd517e10 (commit)
via 14ae4725ab5cdfc334786012c0b4fdacc2851be2 (commit)
via edb6de0becea3a52a4e5e3fa73a090928f0cbd61 (commit)
via 8edab37f17cd60cf6986da822dfbdad6067aef66 (commit)
via ddb717423619cb2c36fb798dc12552b70cd9b0ad (commit)
via 687a87bf012f0c0afa79dd9bebf7d173d1243880 (commit)
via 4400266478b4a477c6747f9eed38f7c6021491d8 (commit)
via c8248c8ed5459991e7d2d6d8f20f652295c19514 (commit)
via 1d64b4edb9da4011ad06c0fab1c6225ec20b0876 (commit)
via 8150dfa1f2f84d151ced5f723dc69ce0cae1cd32 (commit)
via a9ea4f909b9970c755b0a7c4cd9da907e66496fc (commit)
via e5029c585382471f81717f8e1539854d90579512 (commit)
via 5f24f1b53ed2c1746670ae8828a05cc7b63354e8 (commit)
via 1ea37620c2c1794f7685b312d2530676a078ada7 (commit)
via 982377849029f2840ebb105cda49390fecca4fe4 (commit)
via b1c46fd30a4615b4ab534d6bd824a81e3f536660 (commit)
via 2e08ff38b735020e8ed5403acb637e6041d3d743 (commit)
via dc8712611597c6d5be918a69b0ce719e0675f6fe (commit)
via 01b83dbd1a11735519b7d6ca7b02006b45861c9c (commit)
via f361bb937aed7b26a18580c78e66657ed44be294 (commit)
via 912f5f34458fd6998b129e65685adbaf44356860 (commit)
via de2811cc41e86f8f558cfe99172a1987cbcad47a (commit)
via 8ae26afefee947c71314733c419519fb616bf36d (commit)
via dbab8aaacaa7ce4d1d3db09d422615b6fcd6724f (commit)
via dfd1d3b144d97522b2a4e82dc583a43e0b4f8b93 (commit)
via 24475b860b02880b1cfdf4e03f9659a8af09eb72 (commit)
via 7f34acd8a48198c7fec2daf8d2f4161eaa9963ec (commit)
via 1eb6a33a30ea27f97fc401a25a3014e10e3c6f98 (commit)
via e08a12b5356c20ed0418bcaee136eb3632c5616f (commit)
via a285b18ca820e089e2e5d02f8ed07a1e341dffc3 (commit)
via d2df3950a905f7acab70633717beddfd90455b68 (commit)
via b5870f25ad70dc70df99f69ff2652d73ec07343c (commit)
via 428f9e95fccb7105f00d22e80312e9f5a7a263a4 (commit)
via ccd0ae1fbb1c8c942a89bf84272377b341739e0f (commit)
via 988ca6b212fce6d9419d1ffce8f115425ade3a9f (commit)
via a4b4fbbdaa3542e35ea436179200d071b57ff1ca (commit)
via e9381f58d1b0c9d8882328efecf938b45817e3dd (commit)
via cfe24bc4deef6f52ad3e07ffc513160890db4ff3 (commit)
via 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 (commit)
via 94c53e0601c3fb4a4dcd6d3bd602347a8253c167 (commit)
via aa59904eaec70c95fa95960f98ba9cbc62010e8d (commit)
via b7548cd2dc4ead3c0ad3d2fb5c9fc43d54e6ce8d (commit)
via 6ab4de612510b7c8668f0b50388258392f25b157 (commit)
via d3c88f18261b78f1ca9903f2f179b7f812288e1c (commit)
via 7dfcaf2616f6a6a712aa8cbb454aca00419db08f (commit)
via 3baf6e8b0577c32610cc6ba97af209185c16845a (commit)
via b0dbbacbe40fc8aa0b057101f84aed96ac4bea07 (commit)
via ce09e6bd0f2903566c14b4edf2659c19f2eb95b1 (commit)
via 14b59d61028c94c8072f2f171fbc987102ad714d (commit)
via 629987edfb1d03bcbdb6bf7f15d1ec0ff928e6f8 (commit)
via ba59471eeeeb6738f87e1c9c4050ce4698a7c9d8 (commit)
via eac7a5d03909291e62c671ead3d1c6a0ff84d4f0 (commit)
via 44e30ef241e342406d69c7d9c480c630d6106612 (commit)
via cdd125e8d475a6d02606322fb4c54dc76bbc8072 (commit)
via 4fd38267bca2987c6340c019a498ea6bacc6c5ec (commit)
via 1adba49ab20ac283ca62963f115910f1cf7b63ad (commit)
via 09b204d38756f0fa9ab4319874c8ce2838488dd0 (commit)
via 7e369c38993cc7cf4063a6cadc8496552abf323d (commit)
via 4c187d46d40aff1601f38675c11f92a73a13a7c9 (commit)
via 19113f1ca7a747de06d7b43c6c1eca4cd58d05e5 (commit)
via 9ddf06dceee3a2bf5480a3e261ec01aaa91a1f67 (commit)
via 929d11b2c1e1060a51bf7e395ab0ddd48e599144 (commit)
via aab9d46c83c2ad03abb0a2dc000167e552de2c29 (commit)
via d0ecf8eb9e154dcc253b1ea302d67d41bcc4ee36 (commit)
via 8d48877d2cacebeb1352404b0e2514a60416c8a4 (commit)
via 83dce818ec912def820808c059ee6f9c3801585e (commit)
via 7f893030abaf49711f948d76f124e18bfa9e4181 (commit)
via 1b787ef9ec3a08f12d7b46403f4d508e583499a2 (commit)
via e20cec744fad8299afd9bbb6ac49505b15437618 (commit)
via 6db7ee7b3ae8a7dbd6dc194921024287bed40a0a (commit)
via e6a7a86d7ec9fe1dcb77686ca549766e1641a961 (commit)
via 0c8a2c380d705a5113f01d5f8e042897969ca844 (commit)
via cba521fe42484b6689769a484408de56545d8678 (commit)
via a2dead1b0fb6523598e3acbbe91127eaf47fe98c (commit)
via f57ea23ac8e1436f37ceeda3ea8625243c20e645 (commit)
via 29ace173b170a5d77e6becb30fb1d9f253a373d5 (commit)
via 69b6da07c386446d16a11cc41cb64b486199413c (commit)
via 994d87be35769480b04c9f96085a7a0b41040c9d (commit)
via 183d2ace576710079a2bcf2a8bfcbc39b7d9becc (commit)
via 01b69e79f617db3c68b117512b6fe29978ba0ebb (commit)
via 0f595d7d1d57b12036bef801538163d3773567c3 (commit)
via 764246cfbbfff21b3127fff500e972e1dc4314e3 (commit)
via 8dd01861a9a0331b912a1ae6310e64eb6b47c29c (commit)
via b8d8f8b9292a4755d2c63bc7a955d75d96eb05e0 (commit)
via 5ccc3764b3e17a328dad515d9a74123653f1fef9 (commit)
via aacc689677316ebb1ea45bb8fb22f921ebaf97d5 (commit)
via a5d8f98c60344548f0b6a70828b95f2b2e1f7553 (commit)
via b946e08a6ae6e73bda1f76017fcb75f41cd4b288 (commit)
via 9130ec74cf55a2531a364ef16b6608489b583f16 (commit)
via cc2948aa3189b7bd29c23e7a93ccb1217a1b4eff (commit)
via 4124994771e8fe54557a7af85e2af9c68e6ea2a3 (commit)
via 94a7029acf5ca59615bb486b1e9e196e572df6f0 (commit)
via be6a36a05d79662243c384212032783cffab5316 (commit)
via 587f4edd3947880fb0235f84cc18b62f133a9255 (commit)
via 3ec19a7884ba789a9b4f91f61415aa4b84642690 (commit)
via 444b26f739d88ab410d561f1abda67b3d6c0f491 (commit)
via 08904661a2b1c6d461b2f5abfe3226a4023453fb (commit)
via c085589b1c34fa88d28c23cb5e3659fecdb09f33 (commit)
via 72ad03fcbddb3b87de5577b7225f6dc6f892ac93 (commit)
via 1746b8ffdba174fde4a8e293309a18d112750588 (commit)
via 7a17979ea4ae769c60ca4ca291cca877701c08e1 (commit)
via c21939bc247e2e36a5d698c60ba4a03cd3bbaf38 (commit)
via 4bab7f01be8a1ce321f1e30235e1077f1ea0804c (commit)
via 65fa3923060dd66b166fd858bcd6f462f37ee8c0 (commit)
via eaf21539d4afb8df5d1b549215fd397b23004947 (commit)
via 99d1843e2a06f422cbe349804a67d2972c4dedd9 (commit)
via f5ea559aa04186534ea6771e3c15d5201fe85c67 (commit)
via 0e4288608896eeda4ad6f18cfe91d45be7c87c35 (commit)
via 90f51aba0d2b28ac4819f8800f2dcf8d67edbd28 (commit)
via e716f4410fb3f6c614def5a9b33a39185f637002 (commit)
via 5a4a4454c5302ed511eafde5a7759ebf00fbee17 (commit)
via 854ada4f1af8d72859b77e8764729f3cca45460a (commit)
via 0725031fe3a95d4e61e76ffa7aa1c79d4bebb00f (commit)
via 9b6316eabcd3438ca01d1bf7269702af24c3ec5f (commit)
via 90a162323251bfda86d82b2a3c0c7b12ce8a0bb7 (commit)
via 6f160a6e99a68347d11864d4a9bf15da851c9202 (commit)
via 84ebfef4e69130288d68d68c9e872402aa91363d (commit)
via 3dac6181c18508a194f240d633c8c3f7304adb3f (commit)
via af07e10429c1513c2348289888b240926264b32b (commit)
via 9b977c836bf147d386944c401113aba32776fa68 (commit)
via 739941679c2c7dc36c29c30aff7d4c1b436ba773 (commit)
via 118ff892be199f0af359d1b027645d4783a364ec (commit)
via 336c921146957a7416bc1717289a01f1b556ad82 (commit)
via 18cd9aff9429c99ffae34448507f9b468e20e06f (commit)
via 3330f00f54649cdd0914b6ff03c7b7bbc38ffa8d (commit)
via 3d2b2676e3fc0a5b243b8a4188d07bba1b4b40a4 (commit)
via 91c763ee3f195dc0e26339608da01250d6924009 (commit)
via 85edd670f5674bd4c25547936b1faf61e2d7a397 (commit)
via 8598dd8d28d16fe1ec92dfc49f6517992f1598ec (commit)
via d21537efb4a0edea30a7ab801909207d4bb69030 (commit)
via 564f5e70543f771e1e7c5aa57cee6f8b8d20c9ed (commit)
via 30c3dac7a671cfdfadf8452c4ff9117fc0a5b8c0 (commit)
via 5ad85ba15f901163190b365ddd744db22bbbfc42 (commit)
via 10a467f39887b722cb4cffa1a22c94a7b1e37bbc (commit)
via 1d14478ffb2e7b2f9790d34f8c03376abc0675f8 (commit)
via ff95e1022586f40276ea37c0d5b05a370b327be6 (commit)
via 9cdc5cdbe6c3cdc4ae649016b8673cf038b5294e (commit)
via d4cab459d3a479af12ad2bb37ebbead0d6806802 (commit)
via d4124ac5cecb017f949ecfc10095645c3e79d989 (commit)
via 3a3bea729fa25d1351d070160a65db5e9445ebc1 (commit)
via 7facc08a80149bae4f973c07b30b56e3ae945be7 (commit)
via bcc7e238c9c88221752ebfe09c62a149d40cbe08 (commit)
via e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f (commit)
via 8364ae3fac3645ad3e8b53a2c4faeeed162ea0ea (commit)
via 180ac9d7b0bac97bdead2813a1b0b23d19002c3e (commit)
via ceb7f9cc126f50e0cc8956b80ac5d111580b23c8 (commit)
via 32e3c505c37ede7f096239574c3ac46206bf0cef (commit)
via 419c8736243e78a60020f5215ab223af6e9b7bb1 (commit)
via e10c250928bc6c4116d6344616d39f3c52edc36b (commit)
via 1260fd0b2c4ce1d0d7e7b17df924c245f67f9058 (commit)
via 7e0f26eb0d5a9316daad680f62168beffd050632 (commit)
via b2cb557d75e4daf8c7c8cd43313f4cc51d9a3f1b (commit)
via a8fa310b0493cd2e88a7d7f08b1ee3183a81b455 (commit)
via ac28db6db12dbb7c43e3e2207d9607989d65bc6b (commit)
via aac01de63dfb44a442df8ae6920ee431ba81780e (commit)
via 90baf8cdfe8ce356ee4720a012e0deb5a2cb5818 (commit)
via a14b6e18259bcc860ecc7bd3bf320d3adca9ea47 (commit)
via 1488753a66d499cab55edee8ee7e2b2ea5a64717 (commit)
via bb0615d0157facb67ee1489a9764866dcd97eb20 (commit)
via 3e31e75a462fc05f425b887105ccd6607a56ca3b (commit)
via 2b6fcf5b1f6f3cf8d94cada4f00885b275f1a7c5 (commit)
via 25645a0ac9158916667588b76cd541ee9dc05132 (commit)
via b34e25359aad4a08e15de8c5a150ebcff55ff7c1 (commit)
via 13ff681c33a0ff6ff6004d44126697f6dea3ec73 (commit)
via ed7c4a5d777bcff78512f1f1f9f2847ade90af11 (commit)
via 4ff2133aa16a29347149ff04225fb4649256e9c9 (commit)
via e70b663c24420093f98ce6147178be5ef92655ba (commit)
via a3df9ad9e6be7d5fbc566a10bc9ba035a2e38f31 (commit)
This update added new revisions after undoing existing revisions. That is
to say, the old revision is not a strict subset of the new revision. This
situation occurs when you --force push a change and generate a repository
containing something like this:
* -- * -- B -- O -- O -- O (3f7a14a4c6518230774c0df14dde33db15dfb253)
\
N -- N -- N (69e653ef032205ea2dd96e0b86ab8785f933348c)
When this happens we assume that you've already had alert emails for all
of the O revisions, and so we here report only the revisions in the N
branch from the common base, B.
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 69e653ef032205ea2dd96e0b86ab8785f933348c
Author: Noah Lavine <address@hidden>
Date: Thu May 23 00:00:01 2013 -0400
Adjust to RTL Change
* module/language/cps/compile-rtl.scm (generate-rtl): add argument to
call to `begin-program'.
commit b7a0e32510d294783547af92ac01d07f41d67c64
Author: Noah Lavine <address@hidden>
Date: Sun May 5 01:11:25 2013 -0400
Module References in CPS
* module/language/cps.scm: new CPS data type 'module-var' lets us
describe references to module variables; replaces old 'toplevel-var'.
* module/language/tree-il/compile-cps.scm: generate module-vars.
* module/language/cps/compile-rtl.scm: generate code for module-vars.
* test-suite/tests/cps.test: test module-refs.
* module/language/cps/annotate.scm: adjust.
commit 565160d0b906a5deedb75ed65fb55fd69a25d931
Author: Noah Lavine <address@hidden>
Date: Thu Apr 4 13:00:04 2013 -0400
More CPS Tests
* test-suite/tests/cps.test: test calls better, and closure sets.
commit 3b9cb3fced6d4e6370aca357ffbcd04b34cbecbc
Author: Noah Lavine <address@hidden>
Date: Wed Apr 3 18:08:05 2013 -0400
Clean-ups in CPS compiler
* module/language/cps/compile-rtl.scm: merge some if statements into the
surrounding (match ...).
commit faabd2c9fd64f17fde4e5795ab64ac1f53b6146d
Author: Noah Lavine <address@hidden(none)>
Date: Fri Mar 8 17:50:22 2013 -0500
CPS Annotator Handles Letrec
* module/language/cps/annotate.scm: handle letrec and allow #f
as an annotator.
commit 65e2887f02983c8846d5fbc38c6823dc5db10ac0
Author: Noah Lavine <address@hidden(none)>
Date: Fri Mar 8 17:48:58 2013 -0500
Closure Conversion in CPS
* module/language/cps/closure-conversion.scm: implement closure
conversion.
* module/language/cps.scm: comment about closure conversion.
* module/language/cps/compile-rtl.scm: compile closures.
* test-suite/tests/cps.test: test closures.
commit 71e0b716e6bf9e9c034073c01a002ffc2b03a14f
Author: Noah Lavine <address@hidden(none)>
Date: Thu Mar 7 17:10:47 2013 -0500
Handle lambdas in tree-il->cps
* module/language/tree-il/compile-cps.scm: turn a lambda form into a
letrec, except for the outermost lambda.
* test-suite/tests/cps.test: adjust.
commit 376611dafdf2d93b296d69a0c904832e75248627
Author: Noah Lavine <address@hidden>
Date: Sat Feb 23 11:53:46 2013 -0500
Allocate Registers and Labels Separately
* module/language/cps/allocate.scm: split allocate-registers-and-labels
into allocate-registers and allocate-labels.
* module/language/cps/compile-rtl.scm: adjust.
commit bd56dba661850843e85d03bcda7dae2582200659
Author: Noah Lavine <address@hidden>
Date: Wed Feb 20 22:03:27 2013 -0500
CPS Annotator Infrastructure
* module/language/cps/annotate.scm: new function for annotating CPS for
easy viewing.
* module/language/cps/allocate.scm: use annotation infrastructure.
commit fa3567bd6818a9fe794e8b68242fb0f182285039
Author: Noah Lavine <address@hidden>
Date: Wed Feb 20 13:12:37 2013 -0500
Split (language cps compile-rtl)
* module/language/cps/compile-rtl.scm: move
allocate-registers-and-labels to a new module.
* module/language/cps/allocate.scm: new module for allocation.
* module/language/cps/spec.scm: removed for redundancy.
* test-suite/tests/cps.test: adjust.
commit 2a50320c24a8290f6262a69dbc6465989f377df3
Author: Noah Lavine <address@hidden>
Date: Wed Feb 20 11:16:32 2013 -0500
Compile let to CPS
* module/language/tree-il/compile-cps.scm: support 'let'.
* test-suite/tests/cps.test: test 'let'.
commit 0c8f13d559e8ad379d0b6fc1ff26fe43f243e013
Author: Noah Lavine <address@hidden>
Date: Wed Feb 20 11:14:06 2013 -0500
Bugfix in CPS Printer
* module/language/cps.scm: CPS printer will now work.
commit 71a43ae7ea77acbad5b75d82098349c8d24e8e83
Author: Noah Lavine <address@hidden>
Date: Tue Feb 19 23:43:47 2013 -0500
Add CPS Printer
* module/language/cps.scm: add CPS printer, using unparse-cps.
commit 22823ad400b6f6e6469c152f2908bd96ad52e63c
Author: Noah Lavine <address@hidden>
Date: Tue Feb 19 23:30:31 2013 -0500
Sequences in CPS
* module/language/cps.scm: let continuations take rest arguments.
* module/language/tree-il/compile-cps.scm: compile sequences.
* module/language/cps/compile-rtl.scm: handle rest arguments.
* test-suite/tests/cps.test: test sequences.
Note: sequences and rest arguments are grouped together because rest
arguments are needed for sequences, and sequences are used to test rest
arguments.
commit 518f03a79d0383a24d9af9399ffc662a8ebb96bc
Author: Noah Lavine <address@hidden>
Date: Tue Feb 19 21:51:10 2013 -0500
Lexical Sets in CPS
* module/language/tree-il/compile-cps.scm: compile lexical-sets to CPS.
* module/language/cps/compile-rtl.scm: fix bug in lexical set
implementation.
* test-suite/tests/cps.test: test lexical sets.
commit a240d1edf1b314bdda9bdaf2da0ee4a1c7bf8567
Author: Noah Lavine <address@hidden>
Date: Tue Feb 19 11:47:47 2013 -0500
CPS Compiler Function
* module/language/cps/spec.scm: add module. Has 'cps-compile', like
regular 'compile' but using CPS.
* module/language/cps/compile-rtl.scm: remove duplicate functionality.
* test-suite/tests/cps.test: use 'cps-compile'.
commit a451fc92d75ca6691e9682a71f77163a4379fc9f
Author: Noah Lavine <address@hidden>
Date: Tue Feb 19 11:32:53 2013 -0500
Adopt Naming Convention
* module/language/cps.scm: add note on using "value" and "variable"
consistently.
* module/language/tree-il/compile-cps.scm: adjust.
* module/language/cps/compile-rtl.scm: adjust.
commit cb1859ed3c97146a0e9797532dc950a5c79ab068
Author: Noah Lavine <address@hidden>
Date: Mon Feb 18 14:10:58 2013 -0500
Make Lambda Arguments Mutable
* module/language/cps.scm: let variable objects come with an
initialization value.
* module/language/tree-il/compile-cps.scm: put all lambda arguments in
variable boxes, so they are mutable.
commit b57621e62ae2b5c5224b6334785855f1bb349c0c
Author: Noah Lavine <address@hidden>
Date: Mon Feb 18 14:09:33 2013 -0500
Allocate Call Frames Explicitly
* module/language/cps/compile-rtl.scm: have the allocator explicitly say
where to put the frame for a procedure call, instead of inferring it
from the argument destinations.
commit 1b50c36edef2d8fd0e04fa0bed890546203ddc54
Author: Noah Lavine <address@hidden>
Date: Sat Feb 16 12:08:45 2013 -0500
Support N-ary Primitive Outputs
* module/language/cps/primitives.scm: add new data table for output
arity.
* module/language/cps/compile-rtl.scm: adjust.
commit 14922acd705d62932e095675a2407d7fcd5db1c4
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 23:10:58 2013 -0500
Clean Up the Register Allocator
* module/language/cps/compile-rtl.scm: code clean-ups in the register
allocator.
commit 169ed53f82bb9d6c5b518a9d6b2ed538f500b240
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 19:16:58 2013 -0500
Rename 'name-value' to 'name-defn'
* module/language/cps/compile-rtl.scm: change 'name-value' to
'name-defn' for clarity.
commit e2eea905032dbd57356154fd6942394fac770c1b
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 19:07:39 2013 -0500
Test + Function
* test-suite/tests/cps.test: since we can now access top-level
variables, test that the + function works (instead of the CPS
primitive +).
commit 4f4c8b9a3460a0da22b325fe3b9125e17903688d
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 17:25:17 2013 -0500
Separate CPS and CPS-Data
* module/language/cps.scm: split 'cps' declaration into 'cps' and
'cps-data', to make the use of the cps-data types more clear. also add
a 'const' type for completeness.
* module/language/tree-il/compile-cps.scm: adjust.
* module/language/cps/compile-rtl.scm: adjust.
* test-suite/tests/cps.test: adjust.
commit d4fa79fc07edb78eada294c739a5077581c9c832
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 16:10:07 2013 -0500
Toplevel Sets in CPS
* module/language/tree-il/compile-cps.scm: compile toplevel sets to
a new CPS primitive called 'set'.
* module/language/cps/compile-rtl.scm: compile 'set' to toplevel set
instructions.
* test-suite/tests/cps.test: test toplevel sets.
commit 8250248a8aba3b799d096d6cccc07489f8401fcc
Author: Noah Lavine <address@hidden>
Date: Thu Feb 7 23:27:27 2013 -0500
Toplevel Refs in CPS
* module/language/cps.scm: new CPS forms to represent mutable variables.
* module/language/tree-il/compile-cps.scm: generate CPS for top-level
references.
* module/language/cps/compile-rtl.scm: generate RTL code for top-level
references.
* test-suite/tests/cps.test: test top-level references.
commit f06f9f9a670d062238da7a1096274d909322993d
Author: Noah Lavine <address@hidden>
Date: Fri Jan 25 09:52:36 2013 -0500
More CPS Primitives
* module/language/cps/primitives.scm: add more primitives to our
tables.
commit 7e653a14720c9d538285e47f3ee1c59f261469c6
Author: Noah Lavine <address@hidden>
Date: Thu Jan 24 23:25:53 2013 -0500
Begin Tree-IL->CPS Compiler
* module/language/tree-il/compile-cps.scm: add (partial) Tree-IL->CPS
compiler.
* test-suite/tests/cps.test: test Tree-IL->CPS compiler by using it in
CPS tests.
commit 3388b2909f97eeb2d51116f03c235fedb5ef048c
Author: Noah Lavine <address@hidden>
Date: Thu Jan 24 23:23:03 2013 -0500
Simplify CPS If
* module/language/cps.scm: simplify CPS `if'.
* module/language/cps/compile-rtl.scm: compile simpler `if'.
* test-suite/tests/cps.test: test new, simpler form of `if'.
commit 9c7ac4455102cde2a5cab4ec47a7034c36e78048
Author: Noah Lavine <address@hidden>
Date: Sat Nov 17 09:35:15 2012 -0500
Bugfix in compiling CPS 'if'
* module/language/cps/compile-rtl.scm: generate a br instruction to skip
the alternate branch in an <if> if the test is true.
commit a4659be4915160527994bbce6c51f2175f22902a
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 23:00:01 2012 -0500
Compile CPS primitive '+'
* module/language/cps/primitives.scm: new files holds information on
primitives. currently only '+'.
* module/language/cps/compile-rtl.scm: compile simple primitives.
commit e518855430bea39fa784ea0128f976b651dea0a4
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 22:03:21 2012 -0500
Compile CPS 'if'
* module/language/cps/compile-rtl.scm: compile the <if> form.
* test-suite/tests/cps.test: test that the <if> form compiles correctly.
commit ebf6f50e82e86da2710bec076e4dfc3f2a7b77a0
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 21:40:02 2012 -0500
Primitive and if in CPS
* module/language/cps.scm: add <primitive> and <if> CPS types.
commit 2724a1bedae60795c409d0c992db4b76902b227c
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 20:57:49 2012 -0500
Parser and unparser for CPS
* module/language/cps.scm: add parse-cps and unparse-cps.
* test-suite/tests/cps.test: use parse-cps.
commit 9db0d53c8076d2c64fe7ea0c37f1ea7ca7485fe2
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 20:31:01 2012 -0500
Factor CPS Code
* module/language/cps.scm: remove RTL compilation functions and tests.
* module/language/cps/compile-rtl.scm: new location for CPS->RTL
compiler.
* test-suite/tests/cps.test: new location for CPS->RTL compiler tests.
commit 42cce87a63b1530d1613edb4807777d66e2564e3
Author: Noah Lavine <address@hidden>
Date: Sun Nov 4 23:19:19 2012 -0500
Record-based CPS Representation
* module/language/cps.scm: use records to represent all CPS
constructs, instead of most of them. Make dispatches more
uniform by using record-case and match on the new records.
commit cc9f2d2ea16b078f16b19a5db48beb19e2a64e03
Author: Noah Lavine <address@hidden>
Date: Fri Nov 2 21:30:53 2012 -0400
Add Identity Test
* module/language/cps.scm: make sure we can compile the identity
function.
commit b45297eb7184abcf4abc2bbd285ca694448f5d11
Author: Noah Lavine <address@hidden>
Date: Fri Nov 2 21:08:13 2012 -0400
Make Allocation Automatic
* module/language/cps.scm: cps->rtl automatically calls
allocate-registers-and-labels!
commit d46ac9f5e805f3bb2e924d50293fbd891103af05
Author: Noah Lavine <address@hidden>
Date: Thu Nov 1 11:37:42 2012 -0400
Support Non-tail Calls
* module/language/cps.scm: add new test case 'compose'. Add support
for non-tail calls so it works correctly.
commit 0d0fef29963519cf3bc77a65525dc227ac9a8423
Author: Noah Lavine <address@hidden>
Date: Sat Oct 27 11:51:38 2012 -0400
Better register allocation
* module/language/cps.scm: finish register allocator. It should now
handle all cases.
commit 27a81805c441a77f0218ed5e3445995e6c740e5b
Author: Noah Lavine <address@hidden>
Date: Sat Oct 27 11:36:57 2012 -0400
First work on CPS
* module/language/cps.scm: add bare-bones CPS. Can only compile a
few things.
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 6 +
GNUmakefile | 2 +-
Makefile.am | 19 +-
NEWS | 409 +++++-
README | 4 +-
THANKS | 18 +-
build-aux/announce-gen | 2 +-
build-aux/config.rpath | 2 +-
build-aux/gendocs.sh | 160 ++-
build-aux/git-version-gen | 38 +-
build-aux/gitlog-to-changelog | 2 +-
build-aux/gnu-web-doc-update | 33 +-
build-aux/gnupload | 19 +-
build-aux/snippet/arg-nonnull.h | 2 +-
build-aux/snippet/c++defs.h | 2 +-
build-aux/snippet/unused-parameter.h | 2 +-
build-aux/snippet/warn-on-use.h | 4 +-
build-aux/useless-if-before-free | 2 +-
build-aux/vc-list-files | 2 +-
configure.ac | 70 +-
doc/gendocs_template | 2 +-
doc/guile-api.alist | 1 -
doc/r5rs/r5rs.texi | 3 +-
doc/ref/Makefile.am | 7 +
doc/ref/api-binding.texi | 4 +-
doc/ref/api-compound.texi | 169 +--
doc/ref/api-control.texi | 64 +-
doc/ref/api-data.texi | 206 ++-
doc/ref/api-debug.texi | 6 +-
doc/ref/api-evaluation.texi | 104 +-
doc/ref/api-foreign.texi | 6 +-
doc/ref/api-io.texi | 192 ++-
doc/ref/api-macros.texi | 28 +-
doc/ref/api-modules.texi | 155 +--
doc/ref/api-options.texi | 15 +-
doc/ref/api-procedures.texi | 18 +-
doc/ref/api-scheduling.texi | 19 +-
doc/ref/api-smobs.texi | 6 +-
doc/ref/api-undocumented.texi | 6 +-
doc/ref/api-utility.texi | 6 +-
doc/ref/compiler.texi | 16 +-
doc/ref/guile-invoke.texi | 60 +-
doc/ref/guile.texi | 2 +-
doc/ref/intro.texi | 21 +-
doc/ref/misc-modules.texi | 3 +
doc/ref/posix.texi | 90 +-
doc/ref/r6rs.texi | 18 +-
doc/ref/scheme-using.texi | 20 +-
doc/ref/srfi-modules.texi | 757 +++++++++-
doc/ref/sxml-match.texi | 10 +-
doc/ref/sxml.texi | 1075 ++++++++------
doc/ref/texinfo.texi | 22 +-
doc/ref/web.texi | 102 +-
doc/release.org | 17 +-
gnulib-local/build-aux/git-version-gen.diff | 47 +-
guile-readline/readline.c | 32 +-
lib/Makefile.am | 171 ++-
lib/accept.c | 2 +-
lib/alignof.h | 2 +-
lib/alloca.c | 478 ++++++
lib/alloca.in.h | 2 +-
lib/arpa_inet.in.h | 2 +-
lib/asnprintf.c | 2 +-
lib/basename-lgpl.c | 2 +-
lib/binary-io.h | 2 +-
lib/bind.c | 2 +-
lib/btowc.c | 2 +-
lib/byteswap.in.h | 2 +-
lib/c-ctype.c | 2 +-
lib/c-ctype.h | 2 +-
lib/c-strcase.h | 2 +-
lib/c-strcasecmp.c | 2 +-
lib/c-strcaseeq.h | 2 +-
lib/c-strncasecmp.c | 2 +-
lib/canonicalize-lgpl.c | 78 +-
lib/ceil.c | 2 +-
lib/close.c | 2 +-
lib/config.charset | 2 +-
lib/connect.c | 2 +-
lib/dirent.in.h | 2 +-
lib/dirfd.c | 2 +-
lib/dirname-lgpl.c | 2 +-
lib/dirname.h | 2 +-
lib/dosname.h | 2 +-
lib/dup2.c | 160 ++
lib/duplocale.c | 2 +-
lib/errno.in.h | 2 +-
lib/fcntl.in.h | 2 +-
lib/fd-hook.c | 2 +-
lib/fd-hook.h | 2 +-
lib/float+.h | 2 +-
lib/float.c | 2 +-
lib/float.in.h | 2 +-
lib/flock.c | 2 +-
lib/floor.c | 2 +-
lib/frexp.c | 2 +-
lib/fstat.c | 6 +-
lib/full-read.c | 2 +-
lib/full-read.h | 2 +-
lib/full-write.c | 2 +-
lib/full-write.h | 2 +-
lib/gai_strerror.c | 2 +-
lib/getaddrinfo.c | 8 +-
lib/getlogin.c | 41 +
lib/getpeername.c | 2 +-
lib/getsockname.c | 2 +-
lib/getsockopt.c | 2 +-
lib/gettext.h | 2 +-
lib/iconv.c | 2 +-
lib/iconv.in.h | 2 +-
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/isinf.c | 2 +-
lib/isnan.c | 2 +-
lib/isnand-nolibm.h | 2 +-
lib/isnand.c | 2 +-
lib/isnanf.c | 2 +-
lib/isnanl.c | 2 +-
lib/itold.c | 2 +-
lib/langinfo.in.h | 2 +-
lib/listen.c | 2 +-
lib/localcharset.c | 2 +-
lib/localcharset.h | 2 +-
lib/locale.in.h | 21 +-
lib/localeconv.c | 2 +-
lib/log.c | 2 +-
lib/log1p.c | 2 +-
lib/lstat.c | 4 +-
lib/malloc.c | 2 +-
lib/malloca.c | 2 +-
lib/malloca.h | 2 +-
lib/math.c | 3 +
lib/math.in.h | 15 +-
lib/mbrtowc.c | 2 +-
lib/mbsinit.c | 2 +-
lib/mbtowc-impl.h | 2 +-
lib/mbtowc.c | 2 +-
lib/memchr.c | 2 +-
lib/msvc-inval.c | 2 +-
lib/msvc-inval.h | 2 +-
lib/msvc-nothrow.c | 2 +-
lib/msvc-nothrow.h | 2 +-
lib/netdb.in.h | 2 +-
lib/netinet_in.in.h | 2 +-
lib/nl_langinfo.c | 2 +-
lib/nproc.c | 2 +-
lib/nproc.h | 2 +-
lib/open.c | 4 +-
lib/pathmax.h | 2 +-
lib/pipe.c | 50 +
lib/pipe2.c | 2 +-
lib/poll.c | 611 +++++++
lib/poll.in.h | 103 ++
lib/printf-args.c | 2 +-
lib/printf-args.h | 2 +-
lib/printf-parse.c | 2 +-
lib/printf-parse.h | 2 +-
lib/putenv.c | 34 +-
lib/raise.c | 4 +-
lib/read.c | 4 +-
lib/readlink.c | 2 +-
lib/recv.c | 2 +-
lib/recvfrom.c | 2 +-
lib/ref-add.sin | 2 +-
lib/ref-del.sin | 2 +-
lib/regcomp.c | 64 +-
lib/regex.c | 21 +-
lib/regex.h | 23 +-
lib/regex_internal.c | 31 +-
lib/regex_internal.h | 70 +-
lib/regexec.c | 49 +-
lib/rename.c | 2 +-
lib/rmdir.c | 2 +-
lib/round.c | 2 +-
lib/safe-read.c | 2 +-
lib/safe-read.h | 2 +-
lib/safe-write.c | 2 +-
lib/safe-write.h | 2 +-
lib/same-inode.h | 2 +-
lib/select.c | 547 +++++++
lib/send.c | 2 +-
lib/sendto.c | 2 +-
lib/setenv.c | 10 +-
lib/setsockopt.c | 2 +-
lib/shutdown.c | 2 +-
lib/signal.in.h | 2 +-
lib/size_max.h | 2 +-
lib/snprintf.c | 2 +-
lib/socket.c | 2 +-
lib/sockets.c | 2 +-
lib/sockets.h | 2 +-
lib/stat-time.h | 2 +-
lib/stat.c | 4 +-
lib/stdalign.in.h | 2 +-
lib/stdbool.in.h | 2 +-
lib/stddef.in.h | 2 +-
lib/stdint.in.h | 4 +-
lib/stdio.in.h | 23 +-
lib/stdlib.in.h | 23 +-
lib/streq.h | 2 +-
lib/strftime.c | 16 +-
lib/strftime.h | 2 +-
lib/striconveh.c | 2 +-
lib/striconveh.h | 2 +-
lib/string.in.h | 2 +-
lib/stripslash.c | 2 +-
lib/sys_file.in.h | 2 +-
lib/sys_select.in.h | 309 ++++
lib/sys_socket.c | 3 +
lib/sys_socket.in.h | 11 +-
lib/sys_stat.in.h | 8 +-
lib/sys_time.in.h | 190 ++--
lib/sys_times.in.h | 80 +
lib/sys_types.in.h | 2 +-
lib/sys_uio.in.h | 2 +-
lib/time.in.h | 2 +-
lib/time_r.c | 2 +-
lib/times.c | 66 +
lib/trunc.c | 2 +-
lib/unistd.c | 3 +
lib/unistd.in.h | 35 +-
lib/unistr.in.h | 2 +-
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.in.h | 2 +-
lib/vasnprintf.c | 4 +-
lib/vasnprintf.h | 2 +-
lib/verify.h | 2 +-
lib/vsnprintf.c | 2 +-
lib/w32sock.h | 2 +-
lib/wchar.in.h | 2 +-
lib/wcrtomb.c | 2 +-
lib/wctype-h.c | 4 +
lib/wctype.in.h | 40 +-
lib/write.c | 4 +-
lib/xsize.h | 2 +-
libguile/Makefile.am | 31 +-
libguile/__scm.h | 2 +-
libguile/array-handle.c | 44 +-
libguile/array-handle.h | 36 +-
libguile/array-map.c | 196 ++-
libguile/array-map.h | 29 +-
libguile/bdw-gc.h | 7 +-
libguile/c-tokenize.lex | 3 +-
libguile/debug.c | 49 +-
libguile/debug.h | 4 +-
libguile/deprecated.c | 84 +-
libguile/error.c | 17 +-
libguile/filesys.c | 279 ++--
libguile/filesys.h | 4 +-
libguile/fluids.c | 11 +-
libguile/foreign.c | 139 ++-
libguile/fports.c | 349 ++---
libguile/fports.h | 3 +
libguile/gc.c | 16 +-
libguile/gc.h | 3 +-
libguile/gen-scmconfig.c | 21 +-
libguile/generalized-arrays.c | 143 ++-
libguile/generalized-arrays.h | 11 +-
libguile/generalized-vectors.c | 68 +-
libguile/generalized-vectors.h | 8 +-
libguile/guardians.c | 8 +-
libguile/guile.c | 36 +-
libguile/hashtab.c | 28 +
libguile/hashtab.h | 1 +
libguile/i18n.c | 4 +-
libguile/init.c | 4 +-
libguile/inline.c | 3 +-
libguile/inline.h | 25 +-
libguile/instructions.c | 6 +-
libguile/iselect.h | 34 +-
libguile/keywords.c | 67 +
libguile/keywords.h | 12 +
libguile/list.c | 2 -
libguile/load.c | 127 ++-
libguile/load.h | 3 +-
libguile/memoize.c | 28 +-
libguile/mkstemp.c | 4 +-
libguile/net_db.c | 56 +-
libguile/numbers.c | 1675 +++++++++++++-------
libguile/numbers.h | 18 +-
libguile/objcodes.c | 548 ++++---
libguile/poll.c | 15 +-
libguile/ports-internal.h | 66 +
libguile/ports.c | 558 +++++--
libguile/ports.h | 80 +-
libguile/posix.c | 113 +-
libguile/print.c | 31 +-
libguile/procprop.c | 105 ++-
libguile/procprop.h | 6 +-
libguile/procs.c | 15 -
libguile/procs.h | 5 +-
libguile/programs.c | 111 ++-
libguile/programs.h | 10 +-
libguile/r6rs-ports.c | 143 +-
libguile/random.c | 14 +-
libguile/read.c | 42 +-
libguile/scmsigs.c | 34 +-
libguile/smob.c | 49 +-
libguile/socket.c | 51 +-
libguile/srfi-13.c | 124 +-
libguile/srfi-14.i.c | 8 +-
libguile/stime.c | 31 +-
libguile/strings.c | 42 +-
libguile/strports.c | 9 +-
libguile/struct.c | 10 +-
libguile/struct.h | 6 +-
libguile/texi-fragments-to-docstrings | 55 +
libguile/threads.c | 34 +-
libguile/threads.h | 7 +-
libguile/uniform.c | 4 +-
libguile/vm-engine.c | 388 +++---
libguile/vm.c | 18 +-
libguile/vports.c | 8 +-
libguile/win32-socket.c | 632 --------
libguile/win32-socket.h | 42 -
m4/00gnulib.m4 | 2 +-
m4/absolute-header.m4 | 2 +-
m4/alloca.m4 | 2 +-
m4/arpa_inet_h.m4 | 2 +-
m4/autobuild.m4 | 2 +-
m4/btowc.m4 | 2 +-
m4/byteswap.m4 | 2 +-
m4/canonicalize.m4 | 2 +-
m4/ceil.m4 | 2 +-
m4/check-math-lib.m4 | 2 +-
m4/clock_time.m4 | 2 +-
m4/close.m4 | 2 +-
m4/codeset.m4 | 2 +-
m4/configmake.m4 | 2 +-
m4/dirent_h.m4 | 2 +-
m4/dirfd.m4 | 2 +-
m4/dirname.m4 | 2 +-
m4/double-slash-root.m4 | 2 +-
m4/dup2.m4 | 84 +
m4/duplocale.m4 | 2 +-
m4/eealloc.m4 | 2 +-
m4/environ.m4 | 2 +-
m4/errno_h.m4 | 2 +-
m4/exponentd.m4 | 2 +-
m4/exponentf.m4 | 2 +-
m4/exponentl.m4 | 2 +-
m4/extensions.m4 | 49 +-
m4/extern-inline.m4 | 23 +-
m4/fcntl-o.m4 | 2 +-
m4/fcntl_h.m4 | 2 +-
m4/float_h.m4 | 2 +-
m4/flock.m4 | 2 +-
m4/floor.m4 | 2 +-
m4/fpieee.m4 | 2 +-
m4/frexp.m4 | 2 +-
m4/fstat.m4 | 9 +-
m4/func.m4 | 2 +-
m4/getaddrinfo.m4 | 5 +-
m4/getlogin.m4 | 14 +
m4/glibc21.m4 | 2 +-
m4/gnulib-cache.m4 | 12 +-
m4/gnulib-common.m4 | 8 +-
m4/gnulib-comp.m4 | 77 +-
m4/gnulib-tool.m4 | 2 +-
m4/hostent.m4 | 2 +-
m4/iconv.m4 | 2 +-
m4/iconv_h.m4 | 2 +-
m4/iconv_open-utf.m4 | 2 +-
m4/iconv_open.m4 | 2 +-
m4/include_next.m4 | 2 +-
m4/inet_ntop.m4 | 2 +-
m4/inet_pton.m4 | 2 +-
m4/inline.m4 | 2 +-
m4/intmax_t.m4 | 2 +-
m4/inttypes_h.m4 | 2 +-
m4/isinf.m4 | 2 +-
m4/isnan.m4 | 2 +-
m4/isnand.m4 | 2 +-
m4/isnanf.m4 | 2 +-
m4/isnanl.m4 | 2 +-
m4/langinfo_h.m4 | 2 +-
m4/largefile.m4 | 25 +-
m4/ld-version-script.m4 | 2 +-
m4/ldexp.m4 | 2 +-
m4/lib-ld.m4 | 2 +-
m4/lib-link.m4 | 2 +-
m4/lib-prefix.m4 | 2 +-
m4/libunistring-base.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 | 2 +-
m4/localeconv.m4 | 2 +-
m4/log.m4 | 2 +-
m4/log1p.m4 | 2 +-
m4/longlong.m4 | 2 +-
m4/lstat.m4 | 10 +-
m4/malloc.m4 | 2 +-
m4/malloca.m4 | 2 +-
m4/math_h.m4 | 5 +-
m4/mathfunc.m4 | 2 +-
m4/mbrtowc.m4 | 2 +-
m4/mbsinit.m4 | 2 +-
m4/mbstate_t.m4 | 2 +-
m4/mbtowc.m4 | 2 +-
m4/memchr.m4 | 2 +-
m4/mmap-anon.m4 | 2 +-
m4/mode_t.m4 | 2 +-
m4/msvc-inval.m4 | 2 +-
m4/msvc-nothrow.m4 | 2 +-
m4/multiarch.m4 | 2 +-
m4/netdb_h.m4 | 2 +-
m4/netinet_in_h.m4 | 2 +-
m4/nl_langinfo.m4 | 2 +-
m4/nocrash.m4 | 2 +-
m4/nproc.m4 | 2 +-
m4/off_t.m4 | 2 +-
m4/open.m4 | 5 +-
m4/pathmax.m4 | 2 +-
m4/pipe.m4 | 15 +
m4/pipe2.m4 | 2 +-
m4/poll.m4 | 103 ++
m4/poll_h.m4 | 47 +
m4/printf.m4 | 2 +-
m4/putenv.m4 | 8 +-
m4/raise.m4 | 8 +-
m4/read.m4 | 9 +-
m4/readlink.m4 | 2 +-
m4/regex.m4 | 85 +-
m4/rename.m4 | 2 +-
m4/rmdir.m4 | 2 +-
m4/round.m4 | 2 +-
m4/safe-read.m4 | 2 +-
m4/safe-write.m4 | 2 +-
m4/select.m4 | 113 ++
m4/servent.m4 | 2 +-
m4/setenv.m4 | 2 +-
m4/signal_h.m4 | 2 +-
m4/size_max.m4 | 2 +-
m4/snprintf.m4 | 2 +-
m4/socketlib.m4 | 2 +-
m4/sockets.m4 | 2 +-
m4/socklen.m4 | 2 +-
m4/sockpfaf.m4 | 2 +-
m4/ssize_t.m4 | 2 +-
m4/stat-time.m4 | 2 +-
m4/stat.m4 | 10 +-
m4/stdalign.m4 | 2 +-
m4/stdbool.m4 | 2 +-
m4/stddef_h.m4 | 2 +-
m4/stdint.m4 | 2 +-
m4/stdint_h.m4 | 2 +-
m4/stdio_h.m4 | 5 +-
m4/stdlib_h.m4 | 8 +-
m4/strftime.m4 | 2 +-
m4/string_h.m4 | 2 +-
m4/sys_file_h.m4 | 2 +-
m4/sys_select_h.m4 | 95 ++
m4/sys_socket_h.m4 | 5 +-
m4/sys_stat_h.m4 | 7 +-
m4/sys_time_h.m4 | 2 +-
m4/sys_times_h.m4 | 51 +
m4/sys_types_h.m4 | 2 +-
m4/sys_uio_h.m4 | 2 +-
m4/time_h.m4 | 2 +-
m4/time_r.m4 | 2 +-
m4/times.m4 | 14 +
m4/tm_gmtoff.m4 | 2 +-
m4/trunc.m4 | 2 +-
m4/unistd_h.m4 | 5 +-
m4/vasnprintf.m4 | 5 +-
m4/visibility.m4 | 2 +-
m4/vsnprintf.m4 | 2 +-
m4/warn-on-use.m4 | 2 +-
m4/warnings.m4 | 2 +-
m4/wchar_h.m4 | 2 +-
m4/wchar_t.m4 | 2 +-
m4/wcrtomb.m4 | 2 +-
m4/wctype_h.m4 | 6 +-
m4/wint_t.m4 | 2 +-
m4/write.m4 | 9 +-
m4/xsize.m4 | 2 +-
maint.mk | 17 +-
meta/Makefile.am | 14 +-
meta/guild.in | 10 +-
meta/guile.in | 4 +-
meta/guile.m4 | 171 ++-
module/Makefile.am | 20 +-
module/ice-9/binary-ports.scm | 3 +-
module/ice-9/boot-9.scm | 424 ++++--
module/ice-9/command-line.scm | 18 +-
module/ice-9/control.scm | 32 +-
module/ice-9/futures.scm | 34 +-
module/ice-9/mapping.scm | 82 +-
module/ice-9/psyntax-pp.scm | 225 ++--
module/ice-9/psyntax.scm | 132 +-
module/language/assembly/spec.scm | 3 +-
module/language/bytecode/spec.scm | 3 +-
module/language/cps/compile-rtl.scm | 4 +-
module/language/ecmascript/base.scm | 5 +-
module/language/glil/compile-assembly.scm | 53 +-
module/language/glil/decompile-assembly.scm | 191 ---
module/language/glil/spec.scm | 6 +-
module/language/objcode/elf.scm | 40 +-
module/language/objcode/spec.scm | 3 +-
module/language/scheme/decompile-tree-il.scm | 35 +-
module/language/tree-il.scm | 22 +-
module/language/tree-il/analyze.scm | 13 +-
module/language/tree-il/canonicalize.scm | 17 +-
module/language/tree-il/compile-glil.scm | 17 +-
module/language/tree-il/cse.scm | 8 +-
module/language/tree-il/debug.scm | 7 +-
module/language/tree-il/effects.scm | 9 +-
module/language/tree-il/peval.scm | 246 ++-
module/language/tree-il/spec.scm | 3 +-
module/language/value/spec.scm | 3 +-
module/oop/goops.scm | 15 +-
module/oop/goops/active-slot.scm | 19 +-
module/oop/goops/composite-slot.scm | 17 +-
module/oop/goops/describe.scm | 17 +-
module/oop/goops/save.scm | 41 +-
module/srfi/srfi-27.scm | 2 +
module/srfi/srfi-31.scm | 2 +
module/srfi/srfi-37.scm | 5 +-
module/srfi/srfi-38.scm | 1 +
module/srfi/srfi-39.scm | 2 +
module/srfi/srfi-4.scm | 1 +
module/srfi/srfi-4/gnu.scm | 8 +-
module/srfi/srfi-41.scm | 505 ++++++
module/srfi/srfi-42.scm | 2 +
module/srfi/srfi-45.scm | 30 +-
module/srfi/srfi-67.scm | 2 +
module/srfi/srfi-69.scm | 2 +-
module/sxml/match.scm | 19 +-
module/sxml/simple.scm | 188 +++-
module/sxml/ssax.scm | 21 +-
module/sxml/upstream/SSAX.scm | 31 +-
module/system/base/compile.scm | 7 +-
module/system/base/language.scm | 4 +-
module/system/base/target.scm | 38 +-
module/system/foreign.scm | 4 +-
module/system/repl/command.scm | 27 +-
module/system/repl/common.scm | 5 +-
module/system/repl/repl.scm | 7 +-
module/system/vm/assembler.scm | 1309 +++++++++++++++
module/system/vm/debug.scm | 386 +++++
module/system/vm/disassembler.scm | 341 ++++
module/system/vm/dwarf.scm | 48 +-
module/system/vm/elf.scm | 658 +++------
module/system/vm/linker.scm | 537 +++++++
module/system/vm/objcode.scm | 5 +-
module/system/vm/program.scm | 74 +-
module/system/vm/rtl.scm | 979 ------------
module/texinfo.scm | 8 +-
module/texinfo/docbook.scm | 2 +-
module/texinfo/plain-text.scm | 38 +-
module/texinfo/serialize.scm | 5 +-
module/texinfo/string-utils.scm | 15 +-
module/web/client.scm | 6 +-
module/web/http.scm | 93 +-
module/web/response.scm | 33 +-
module/web/uri.scm | 28 +-
test-suite/Makefile.am | 1 +
test-suite/standalone/Makefile.am | 22 +-
test-suite/standalone/test-ffi | 15 +
test-suite/standalone/test-ffi-lib.c | 17 +
test-suite/standalone/test-language | 25 +
test-suite/standalone/test-language.el | 11 +
test-suite/standalone/test-language.js | 12 +
.../standalone/test-pthread-create-secondary.c | 19 +-
test-suite/standalone/test-round.c | 11 +-
.../standalone/test-scm-c-bind-keyword-arguments.c | 201 +++
test-suite/standalone/test-smob-mark.c | 133 ++
test-suite/test-suite/lib.scm | 9 +-
test-suite/tests/00-socket.test | 17 +-
test-suite/tests/alist.test | 4 +-
test-suite/tests/arrays.test | 76 +-
test-suite/tests/asm-to-bytecode.test | 15 +-
test-suite/tests/bitvectors.test | 3 +-
test-suite/tests/bytevectors.test | 36 +-
test-suite/tests/coding.test | 116 +-
test-suite/tests/control.test | 30 +-
test-suite/tests/ecmascript.test | 1 +
test-suite/tests/elisp.test | 8 +-
test-suite/tests/encoding-iso88591.test | 10 +-
test-suite/tests/encoding-iso88597.test | 10 +-
test-suite/tests/encoding-utf8.test | 10 +-
test-suite/tests/filesys.test | 100 ++-
test-suite/tests/fluids.test | 32 +-
test-suite/tests/foreign.test | 21 +-
test-suite/tests/future.test | 18 +-
test-suite/tests/gc.test | 4 +-
test-suite/tests/hash.test | 28 +-
test-suite/tests/i18n.test | 20 +-
test-suite/tests/modules.test | 2 +-
test-suite/tests/numbers.test | 578 ++++++--
test-suite/tests/optargs.test | 29 +
test-suite/tests/peval.test | 150 ++-
test-suite/tests/popen.test | 354 ++--
test-suite/tests/ports.test | 719 ++++++++-
test-suite/tests/r6rs-ports.test | 24 -
test-suite/tests/ramap.test | 58 +-
test-suite/tests/rtl.test | 214 ++-
test-suite/tests/srfi-35.test | 16 +-
test-suite/tests/srfi-37.test | 24 +-
test-suite/tests/srfi-4.test | 38 +-
test-suite/tests/srfi-41.test | 680 ++++++++
test-suite/tests/srfi-45.test | 10 +-
test-suite/tests/sxml.simple.test | 85 +-
test-suite/tests/syncase.test | 37 +-
test-suite/tests/texinfo.serialize.test | 4 +-
test-suite/tests/texinfo.string-utils.test | 9 +-
test-suite/tests/texinfo.test | 66 +-
test-suite/tests/threads.test | 9 +-
test-suite/tests/tree-il.test | 47 +-
test-suite/tests/vlist.test | 8 +-
test-suite/tests/web-http.test | 114 ++
624 files changed, 19703 insertions(+), 8210 deletions(-)
create mode 100644 lib/alloca.c
create mode 100644 lib/dup2.c
create mode 100644 lib/getlogin.c
create mode 100644 lib/math.c
create mode 100644 lib/pipe.c
create mode 100644 lib/poll.c
create mode 100644 lib/poll.in.h
create mode 100644 lib/select.c
create mode 100644 lib/sys_select.in.h
create mode 100644 lib/sys_socket.c
create mode 100644 lib/sys_times.in.h
create mode 100644 lib/times.c
create mode 100644 lib/unistd.c
create mode 100644 lib/wctype-h.c
create mode 100644 libguile/ports-internal.h
create mode 100644 libguile/texi-fragments-to-docstrings
delete mode 100644 libguile/win32-socket.c
delete mode 100644 libguile/win32-socket.h
create mode 100644 m4/dup2.m4
create mode 100644 m4/getlogin.m4
create mode 100644 m4/pipe.m4
create mode 100644 m4/poll.m4
create mode 100644 m4/poll_h.m4
create mode 100644 m4/select.m4
create mode 100644 m4/sys_select_h.m4
create mode 100644 m4/sys_times_h.m4
create mode 100644 m4/times.m4
delete mode 100644 module/language/glil/decompile-assembly.scm
create mode 100644 module/srfi/srfi-41.scm
create mode 100644 module/system/vm/assembler.scm
create mode 100644 module/system/vm/debug.scm
create mode 100644 module/system/vm/disassembler.scm
create mode 100644 module/system/vm/linker.scm
delete mode 100644 module/system/vm/rtl.scm
create mode 100755 test-suite/standalone/test-language
create mode 100644 test-suite/standalone/test-language.el
create mode 100644 test-suite/standalone/test-language.js
create mode 100644 test-suite/standalone/test-scm-c-bind-keyword-arguments.c
create mode 100644 test-suite/standalone/test-smob-mark.c
create mode 100644 test-suite/tests/srfi-41.test
diff --git a/.gitignore b/.gitignore
index fca51df..b136c7a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -150,4 +150,10 @@ INSTALL
/lib/dirent.h
/lib/langinfo.h
/lib/wctype.h
+/build-aux/ar-lib
+/build-aux/test-driver
+*.trs
+/test-suite/standalone/test-smob-mark
+/test-suite/standalone/test-scm-values
+/test-suite/standalone/test-scm-to-latin1-string
/libguile/vm-operations.h
diff --git a/GNUmakefile b/GNUmakefile
index 58f2ead..8759034 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-2012 Free Software Foundation, Inc.
+# Copyright (C) 2001, 2003, 2006-2013 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/Makefile.am b/Makefile.am
index 3aa5ddd..8cdcc7e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007,
-## 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -42,6 +42,19 @@ SUBDIRS = \
libguileincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)
libguileinclude_HEADERS = libguile.h
+schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
+schemelib_DATA = libguile/guile-procedures.txt
+
+# Build it from here so that all the modules are compiled by the time we
+# build it.
+libguile/guile-procedures.txt: libguile/guile-procedures.texi
+ $(AM_V_GEN) \
+ $(top_builddir)/meta/guile --no-auto-compile \
+ "$(srcdir)/libguile/texi-fragments-to-docstrings" \
+ "$(builddir)/libguile/guile-procedures.texi" \
+ > address@hidden
+ @mv address@hidden $@
+
EXTRA_DIST = LICENSE HACKING GUILE-VERSION \
m4/ChangeLog-2008 \
m4/gnulib-cache.m4 \
@@ -50,13 +63,15 @@ EXTRA_DIST = LICENSE HACKING GUILE-VERSION
\
gnulib-local/lib/localcharset.h.diff \
gnulib-local/lib/localcharset.c.diff \
gnulib-local/m4/clock_time.m4.diff \
- gnulib-local/build-aux/git-version-gen.diff
+ gnulib-local/build-aux/git-version-gen.diff \
+ libguile/texi-fragments-to-docstrings
TESTS = check-guile
TESTS_ENVIRONMENT = @LOCALCHARSET_TESTS_ENVIRONMENT@
ACLOCAL_AMFLAGS = -I m4
+CLEANFILES = libguile/guile-procedures.txt
DISTCLEANFILES = check-guile.log
DISTCHECK_CONFIGURE_FLAGS = --enable-error-on-warning
diff --git a/NEWS b/NEWS
index ebf5d61..5913301 100644
--- a/NEWS
+++ b/NEWS
@@ -1,10 +1,417 @@
Guile NEWS --- history of user-visible changes.
-Copyright (C) 1996-2012 Free Software Foundation, Inc.
+Copyright (C) 1996-2013 Free Software Foundation, Inc.
See the end for copying conditions.
Please send Guile bug reports to address@hidden
+Changes in 2.0.9 (since 2.0.7):
+
+Note: 2.0.8 was a brown paper bag release that was never announced, but
+some mirrors may have picked it up. Please do not use it.
+
+* Notable changes
+
+** New keyword arguments for procedures that open files
+
+The following procedures that open files now support keyword arguments
+to request binary I/O or to specify the character encoding for text
+files: `open-file', `open-input-file', `open-output-file',
+`call-with-input-file', `call-with-output-file', `with-input-from-file',
+`with-output-to-file', and `with-error-to-file'.
+
+It is also now possible to specify whether Guile should scan files for
+Emacs-style coding declarations. This scan was done by default in
+versions 2.0.0 through 2.0.7, but now must be explicitly requested.
+
+See "File Ports" in the manual for details.
+
+** Rewritten guile.m4
+
+The `guile.m4' autoconf macros have been rewritten to use `guild' and
+`pkg-config' instead of the deprecated `guile-config' (which itself
+calls pkg-config).
+
+There is also a new macro, `GUILE_PKG', which allows packages to select
+the version of Guile that they want to compile against. See "Autoconf
+Macros" in the manual, for more information.
+
+** Better Windows support
+
+Guile now correctly identifies absolute paths on Windows (MinGW), and
+creates files on that platform according to its path conventions. See
+"File System" in the manual, for all details.
+
+In addition, the new Gnulib imports provide `select' and `poll' on
+Windows builds.
+
+As an incompatible change, systems that are missing <sys/select.h> were
+previously provided a public `scm_std_select' C function that defined a
+version of `select', but unhappily it also provided its own incompatible
+definitions for FD_SET, FD_ZERO, and other system interfaces. Guile
+should not be setting these macros in public API, so this interface was
+removed on those plaforms (basically only MinGW).
+
+** Numerics improvements
+
+`number->string' now reliably outputs enough digits to produce the same
+number when read back in. Previously, it mishandled subnormal numbers
+(printing them as "#.#"), and failed to distinguish between some
+distinct inexact numbers, e.g. 1.0 and (+ 1.0 (expt 2.0 -52)). These
+problems had far-reaching implications, since the compiler uses
+`number->string' to serialize numeric constants into .go files.
+
+`sqrt' now produces exact rational results when possible, and handles
+very large or very small numbers more robustly.
+
+A number (ahem) of operations involving exact rationals have been
+optimized, most notably `integer-expt' and `expt'.
+
+`exact->inexact' now performs correct IEEE rounding.
+
+** New optimizations
+
+There were a number of improvements to the partial evaluator, allowing
+complete reduction of forms such as:
+
+ ((let ((_ 10)) (lambda () _)))
+
+ ((lambda _ _))
+
+ (apply (lambda _ _) 1 2 3 '(4))
+
+ (call-with-values (lambda () (values 1 2)) (lambda _ _))
+
+`string-join' now handles huge lists efficiently.
+
+`get-bytevector-some' now uses buffered input, which is much faster.
+
+Finally, `array-ref', `array-set!' on arrays of rank 1 or 2 is now
+faster, because it avoids building a rest list. Similarly, the
+one-argument case of `array-for-each' and `array-map!' has been
+optimized, and `array-copy!' and `array-fill!' are faster.
+
+** `peek-char' no longer consumes EOF
+
+As required by the R5RS, if `peek-char' returns EOF, then the next read
+will also return EOF. Previously `peek-char' would consume the EOF.
+This makes a difference for terminal devices where it is possible to
+read past an EOF.
+
+** Gnulib update
+
+Guile's copy of Gnulib was updated to v0.0-7865-ga828bb2. The following
+modules were imported from Gnulib: select, times, pipe-posix, fstat,
+getlogin, poll, and c-strcase.
+
+** `include' resolves relative file names relative to including file
+
+Given a relative file name, `include' will look for it relative to the
+directory of the including file. This harmonizes the behavior of
+`include' with that of `load'.
+
+** SLIB compatibility restored
+
+Guile 2.0.8 is now compatible with SLIB. You will have to use a
+development version of SLIB, however, until a new version of SLIB is
+released.
+
+** Better ,trace REPL command
+
+Sometimes the ,trace output for nested function calls could overflow the
+terminal width, which wasn't useful. Now there is a limit to the amount
+of space the prefix will take. See the documentation for ",trace" for
+more information.
+
+** Better docstring syntax supported for `case-lambda'
+
+Docstrings can now be placed immediately after the `case-lambda' or
+`case-lambda*' keyword. See "Case-lambda" in the manual.
+
+** Improved handling of Unicode byte order marks
+
+See "BOM Handling" in the manual for details.
+
+** Update predefined character sets to Unicode 6.2
+
+** GMP 4.2 or later required
+
+Guile used to require GMP at least version 4.1 (released in May 2002),
+and now requires at least version 4.2 (released in March 2006).
+
+* Manual updates
+
+** Better SXML documentation
+
+The documentation for SXML modules was much improved, though there is
+still far to go. See "SXML" in manual.
+
+** Style updates
+
+Use of "iff" was replaced with standard English. Keyword arguments are
+now documented consistently, along with their default values.
+
+** An end to the generated-documentation experiment
+
+When Guile 2.0 imported some modules from Guile-Lib, they came with a
+system that generated documentation from docstrings and module
+commentaries. This produced terrible documentation. We finally bit the
+bullet and incorporated these modules into the main text, and will be
+improving them manually over time, as is the case with SXML. Help is
+appreciated.
+
+** New documentation
+
+There is now documentation for `scm_array_type', and `scm_array_ref', as
+well as for the new `array-length' / 'scm_c_array_length' /
+`scm_array_length' functions. `array-in-bounds?' has better
+documentation as well. The `program-arguments-alist' and
+`program-lambda-list' functions are now documented, as well as `and=>',
+`exit', and `quit'. The (system repl server) module is now documented
+(see REPL Servers). Finally, the GOOPS class hierarchy diagram has been
+regenerated for the web and print output formats.
+
+* New deprecations
+
+** Deprecate generalized vector interface
+
+The generalized vector interface, introduced in 1.8.0, is simply a
+redundant, verbose interface to arrays of rank 1. `array-ref' and
+similar functions are entirely sufficient. Thus,
+`scm_generalized_vector_p', `scm_generalized_vector_length',
+`scm_generalized_vector_ref', `scm_generalized_vector_set_x', and
+`scm_generalized_vector_to_list' are now deprecated.
+
+** Deprecate SCM_CHAR_CODE_LIMIT and char-code-limit
+
+These constants were defined to 256, which is not the highest codepoint
+supported by Guile. Given that they were useless and incorrect, they
+have been deprecated.
+
+** Deprecate `http-get*'
+
+The new `#:streaming?' argument to `http-get' subsumes the functionality
+of `http-get*' (introduced in 2.0.7). Also, the `#:extra-headers'
+argument is deprecated in favor of `#:headers'.
+
+** Deprecate (ice-9 mapping)
+
+This module, present in Guile since 1996 but never used or documented,
+has never worked in Guile 2.0. It has now been deprecated and will be
+removed in Guile 2.2.
+
+** Deprecate undocumented array-related C functions
+
+These are `scm_array_fill_int', `scm_ra_eqp', `scm_ra_lessp',
+`scm_ra_leqp', `scm_ra_grp', `scm_ra_greqp', `scm_ra_sum',
+`scm_ra_product', `scm_ra_difference', `scm_ra_divide', and
+`scm_array_identity'.
+
+* New interfaces
+
+** SRFI-41 Streams
+
+See "SRFI-41" in the manual.
+
+** SRFI-45 exports `promise?'
+
+SRFI-45 now exports a `promise?' procedure that works with its promises.
+Also, its promises now print more nicely.
+
+** New HTTP client procedures
+
+See "Web Client" for documentation on the new `http-head', `http-post',
+`http-put', `http-delete', `http-trace', and `http-options' procedures,
+and also for more options to `http-get'.
+
+** Much more capable `xml->sxml'
+
+See "Reading and Writing XML" for information on how the `xml->sxml'
+parser deals with namespaces, processed entities, doctypes, and literal
+strings. Incidentally, `current-ssax-error-port' is now a parameter
+object.
+
+** New procedures for converting strings to and from bytevectors
+
+See "Representing Strings as Bytes" for documention on the new `(ice-9
+iconv)' module and its `bytevector->string' and `string->bytevector'
+procedures.
+
+** Escape continuations with `call/ec' and `let/ec'
+
+See "Prompt Primitives".
+
+** New procedures to read all characters from a port
+
+See "Line/Delimited" in the manual for documentation on `read-string'
+ and `read-string!'.
+
+** New procedure `sendfile'
+
+See "File System".
+
+** New procedure `unget-bytevector'
+
+See "R6RS Binary Input".
+
+** New C helper: `scm_c_bind_keyword_arguments'
+
+See "Keyword Procedures".
+
+** New command-line arguments: `--language' and `-C'
+
+See "Command-line Options" in the manual.
+
+** New environment variables: `GUILE_STACK_SIZE', `GUILE_INSTALL_LOCALE'
+
+See "Environment Variables".
+
+** New procedures for dealing with file names
+
+See "File System" for documentation on `system-file-name-convention',
+`file-name-separator?', `absolute-file-name?', and
+`file-name-separator-string'.
+
+** `array-length', an array's first dimension
+
+See "Array Procedures".
+
+** `hash-count', for hash tables
+
+See "Hash Tables".
+
+** `round-ash', a bit-shifting operator that rounds on right-shift
+
+See "Bitwise Operations".
+
+** New foreign types: `ssize_t', `ptrdiff_t'
+
+See "Foreign Types".
+
+** New C helpers: `scm_from_ptrdiff_t', `scm_to_ptrdiff_t'
+
+See "Integers".
+
+** Socket option `SO_REUSEPORT' now available from Scheme
+
+If supported on the platform, `SO_REUSEPORT' is now available from
+Scheme as well. See "Network Sockets and Communication".
+
+** `current-language' in default environment
+
+Previously defined only in `(system base language)', `current-language'
+is now defined in the default environment, and is used to determine the
+language for the REPL, and for `compile-and-load'.
+
+** New procedure: `fluid->parameter'
+
+See "Parameters", for information on how to convert a fluid to a
+parameter.
+
+** New `print' REPL option
+
+See "REPL Commands" in the manual for information on the new
+user-customizable REPL printer.
+
+** New variable: %site-ccache-dir
+
+The "Installing Site Packages" and "Build Config" manual sections now
+refer to this variable to describe where users should install their
+`.go' files.
+
+* Build fixes
+
+** Fix compilation against libgc 7.3.
+** Fix cross-compilation of `c-tokenize.o'.
+** Fix warning when compiling against glibc 2.17.
+** Fix documentation build against Texinfo 5.0.
+** Fix building Guile from a directory with non-ASCII characters.
+** Fix native MinGW build.
+** Fix --disable-posix build.
+** Fix MinGW builds with networking, POSIX, and thread support.
+
+* Bug fixes
+
+** Fix inexact number printer.
+ (http://bugs.gnu.org/13757)
+** Fix infinite loop when parsing optional-argument short options (SRFI-37).
+ (http://bugs.gnu.org/13176)
+** web: Support non-GMT date headers in the HTTP client.
+ (http://bugs.gnu.org/13544)
+** web: support IP-literal (IPv6 address) in Host header.
+** Avoid stack overflows with `par-map' and nested futures in general.
+ (http://bugs.gnu.org/13188)
+** Peek-char no longer consumes EOF.
+ (http://bugs.gnu.org/12216)
+** Avoid swallowing multiple EOFs in R6RS binary-input procedures.
+** A fork when multiple threads are running will now print a warning.
+** Allow for spurious wakeups from pthread_cond_wait.
+ (http://bugs.gnu.org/10641)
+** Warn and ignore module autoload failures.
+ (http://bugs.gnu.org/12202)
+** Use chmod portably in (system base compile).
+ (http://bugs.gnu.org/10474)
+** Fix response-body-port for HTTP responses without content-length.
+ (http://bugs.gnu.org/13857)
+** Allow case-lambda expressions with no clauses.
+ (http://bugs.gnu.org/9776)
+** Improve standards conformance of string->number.
+ (http://bugs.gnu.org/11887)
+** Support calls and tail-calls with more than 255 formals.
+** ,option evaluates its right-hand-side.
+ (http://bugs.gnu.org/13076)
+** Structs with tail arrays are not simple.
+ (http://bugs.gnu.org/12808)
+** Make `SCM_LONG_BIT' usable in preprocessor conditionals.
+ (http://bugs.gnu.org/13848)
+** Fix thread-unsafe lazy initializations.
+** Allow SMOB mark procedures to be called from parallel markers.
+ (http://bugs.gnu.org/13611)
+** Fix later-bindings-win logic in with-fluids.
+ (http://bugs.gnu.org/13843)
+** Fix duplicate removal of with-fluids.
+ (http://bugs.gnu.org/13838)
+** Support calling foreign functions of 10 arguments or more.
+ (http://bugs.gnu.org/13809)
+** Let reverse! accept arbitrary types as second argument.
+ (http://bugs.gnu.org/13835)
+** Recognize the `x86_64.*-gnux32' triplet.
+** Check whether a triplet's OS part specifies an ABI.
+** Recognize mips64* as having 32-bit pointers by default.
+** Use portable sed constructs.
+ (http://bugs.gnu.org/14042)
+** Remove language/glil/decompile-assembly.scm.
+ (http://bugs.gnu.org/10622)
+** Use O_BINARY in `copy-file', `load-objcode', `mkstemp'.
+** Use byte-oriented functions in `get-bytevector*'.
+** Fix abort when iconv swallows BOM from UTF-16 or UTF-32 stream.
+** Fix compilation of functions with more than 255 local variables.
+** Fix `getgroups' for when zero supplementary group IDs exist.
+** Allow (define-macro name (lambda ...)).
+** Various fixes to the (texinfo) modules.
+** guild: Gracefully handle failures to install the locale.
+** Fix format string warnings for ~!, ~|, ~/, ~q, ~Q, and ~^.
+ (http://bugs.gnu.org/13485)
+** Fix source annotation bug in psyntax 'expand-body'.
+** Ecmascript: Fix conversion to boolean for non-numbers.
+** Use case-insensitive comparisons for encoding names.
+** Add missing cond-expand feature identifiers.
+** A failure to find a module's file does not prevent future loading.
+** Many (oop goops save) fixes.
+** `http-get': don't shutdown write end of socket.
+ (http://bugs.gnu.org/13095)
+** Avoid signed integer overflow in scm_product.
+** http: read-response-body always returns bytevector or #f, never EOF.
+** web: Correctly detect "No route to host" conditions.
+** `system*': failure to execvp no longer leaks dangling processes.
+ (http://bugs.gnu.org/13166)
+** More sensible case-lambda* dispatch.
+ (http://bugs.gnu.org/12929)
+** Do not defer expansion of internal define-syntax forms.
+ (http://bugs.gnu.org/13509)
+
+
+
Changes in 2.0.7 (since 2.0.6):
* Notable changes
diff --git a/README b/README
index 31fdb80..215f9e5 100644
--- a/README
+++ b/README
@@ -62,7 +62,7 @@ Required External Packages
================================================
Guile requires the following external packages:
- - GNU MP, at least version 4.1
+ - GNU MP, at least version 4.2
GNU MP is used for bignum arithmetic. It is available from
http://gmplib.org/ .
@@ -72,7 +72,7 @@ Guile requires the following external packages:
libltdl is used for loading extensions at run-time. It is
available from http://www.gnu.org/software/libtool/ .
- - GNU libunistring
+ - GNU libunistring, at least version 0.9.3
libunistring is used for Unicode string operations, such as the
`utf*->string' procedures. It is available from
diff --git a/THANKS b/THANKS
index fc2bf49..a01dcfb 100644
--- a/THANKS
+++ b/THANKS
@@ -1,7 +1,9 @@
Contributors since the last release:
+ Greg Benison
Tristan Colgate-McFarlane
Ludovic Courtès
+ Jason Earl
Brian Gough
Volker Grabsch
Julian Graham
@@ -9,8 +11,12 @@ Contributors since the last release:
Daniel Hartwig
No Itisnt
Neil Jerram
+ Chris K Jester-Young
+ David Kastrup
Daniel Kraft
+ Daniel Krueger
Noah Lavine
+ Daniel Llorens
Gregory Marton
Thien-Thi Nguyen
Han-Wen Nienhuys
@@ -21,11 +27,14 @@ Contributors since the last release:
Ken Raeburn
Andreas Rottmann
Kevin Ryde
- Brian Templeton
+ Stefan I Tampe
+ BT Templeton
+ Bake Timmons
Mark H Weaver
Göran Weinholt
Ralf Wildenhues
Andy Wingo
+ Eli Zaretskii
Authors of free software libraries that have been included into Guile
since the last release:
@@ -41,6 +50,7 @@ For fixes or providing information which led to a fix:
Hans Ã
berg
David Allouche
Andrew Bagdanov
+ LluÃs Batlle i Rossell
Martin Baulig
Fabrice Bauzac
Sylvain Beucler
@@ -94,6 +104,8 @@ For fixes or providing information which led to a fix:
David Jaquay
Paul Jarc
Steve Juranich
+ Nikita Karetnikov
+ David Kastrup
Richard Kim
Bruce Korb
René Köcher
@@ -136,17 +148,20 @@ For fixes or providing information which led to a fix:
Hugh Sasse
Werner Scheinast
Bill Schottstaedt
+ Jan Schukat
Frank Schwidom
John Steele Scott
Thiemo Seufer
Ivan Shcherbakov
Scott Shedden
Alex Shinn
+ Peter Simons
Daniel Skarda
Dale Smith
Cesar Strauss
Klaus Stehle
Rainer Tammer
+ Samuel Thibault
Richard Todd
Issac Trotts
Greg Troxel
@@ -164,6 +179,7 @@ For fixes or providing information which led to a fix:
Thomas Wawrzinek
Mark H. Weaver
Göran Weinholt
+ David A. Wheeler
Ralf Wildenhues
Jon Wilson
Andy Wingo
diff --git a/build-aux/announce-gen b/build-aux/announce-gen
index ec7c22a..3a64ec6 100755
--- a/build-aux/announce-gen
+++ b/build-aux/announce-gen
@@ -9,7 +9,7 @@ my $VERSION = '2012-06-08 06:53'; # UTC
# If you change this file with Emacs, please let the write hook
# do its job. Otherwise, update this string manually.
-# Copyright (C) 2002-2012 Free Software Foundation, Inc.
+# Copyright (C) 2002-2013 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/config.rpath b/build-aux/config.rpath
index 1a07018..c38b914 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-2012 Free Software Foundation, Inc.
+# Copyright 1996-2013 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
index 0c0bc4b..e4bfc9f 100755
--- a/build-aux/gendocs.sh
+++ b/build-aux/gendocs.sh
@@ -2,9 +2,9 @@
# 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=2012-10-27.11
+scriptversion=2013-02-03.15
-# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
# Free Software Foundation, Inc.
#
# This program is free software: you can redistribute it and/or modify
@@ -56,7 +56,7 @@ unset use_texi2html
version="gendocs.sh $scriptversion
-Copyright 2012 Free Software Foundation, Inc.
+Copyright 2013 Free Software Foundation, Inc.
There is NO warranty. You may redistribute this software
under the terms of the GNU General Public License.
For more information about these matters, see the files named COPYING."
@@ -69,16 +69,23 @@ 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/.
- -I DIR append DIR to the Texinfo search path.
- --email ADR use ADR as contact in generated web pages.
- --docbook convert through DocBook too (xml, txt, html, pdf).
- --html ARG pass indicated ARG to makeinfo or texi2html for HTML targets.
- --info ARG pass indicated ARG to makeinfo for Info, instead of --no-split.
- --texi2html use texi2html to generate HTML targets.
- --help display this help and exit successfully.
- --version display version information and exit successfully.
+ --email ADR use ADR as contact in generated web pages; always give this.
+
+ -s SRCFILE read Texinfo from SRCFILE, instead of PACKAGE.{texinfo|texi|txi}
+ -o OUTDIR write files into OUTDIR, instead of manual/.
+ -I DIR append DIR to the Texinfo search path.
+ --common ARG pass ARG in all invocations.
+ --html ARG pass ARG to makeinfo or texi2html for HTML targets.
+ --info ARG pass ARG to makeinfo for Info, instead of --no-split.
+ --no-ascii skip generating the plain text output.
+ --source ARG include ARG in tar archive of sources.
+ --split HOW make split HTML by node, section, chapter; default node.
+
+ --texi2html use texi2html to make HTML target, with all split versions.
+ --docbook convert through DocBook too (xml, txt, html, pdf).
+
+ --help display this help and exit successfully.
+ --version display version information and exit successfully.
Simple example: $prog --email address@hidden emacs \"GNU Emacs Manual\"
@@ -92,8 +99,8 @@ Output will be in a new subdirectory \"manual\" (by default;
use -o OUTDIR to override). Move all the new files into your web CVS
tree, as explained in the Web Pages node of maintain.texi.
-Please do use the --email ADDRESS option to specify your bug-reporting
-address in the generated HTML pages.
+Please use the --email ADDRESS option so your own bug-reporting
+address will be used in the generated HTML pages.
MANUAL-TITLE is included as part of the HTML <title> of the overall
manual/index.html file. It should include the name of the package being
@@ -117,7 +124,7 @@ You can set the environment variables MAKEINFO, TEXI2DVI,
TEXI2HTML,
and PERL to control the programs that get executed, and
GENDOCS_TEMPLATE_DIR to control where the gendocs_template file is
looked for. With --docbook, the environment variables DOCBOOK2HTML,
-DOCBOOK2PDF, and DOCBOOK2TXT are also respected.
+DOCBOOK2PDF, and DOCBOOK2TXT are also consulted.
By default, makeinfo and texi2dvi are run in the default (English)
locale, since that's the language of most Texinfo manuals. If you
@@ -130,25 +137,34 @@ Email bug reports or enhancement requests to
address@hidden
MANUAL_TITLE=
PACKAGE=
address@hidden # please override with --email
-commonarg= # Options passed to all the tools (-I dir).
+commonarg= # passed to all makeinfo/texi2html invcations.
+dirargs= # passed to all tools (-I dir).
dirs= # -I's directories.
htmlarg=
infoarg=--no-split
+generate_ascii=true
outdir=manual
+source_extra=
+split=node
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;;
- -I) shift; commonarg="$commonarg -I '$1'"; dirs="$dirs $1";;
- --docbook) docbook=yes;;
- --html) shift; htmlarg=$1;;
- --info) shift; infoarg=$1;;
+ -s) shift; srcfile=$1;;
+ -o) shift; outdir=$1;;
+ -I) shift; dirargs="$dirargs -I '$1'"; dirs="$dirs $1";;
+ --common) shift; commonarg=$1;;
+ --docbook) docbook=yes;;
+ --email) shift; EMAIL=$1;;
+ --html) shift; htmlarg=$1;;
+ --info) shift; infoarg=$1;;
+ --no-ascii) generate_ascii=false;;
+ --source) shift; source_extra=$1;;
+ --split) shift; split=$1;;
--texi2html) use_texi2html=1;;
+
+ --help) echo "$usage"; exit 0;;
+ --version) echo "$version"; exit 0;;
-*)
echo "$0: Unknown option \`$1'." >&2
echo "$0: Try \`--help' for more information." >&2
@@ -166,6 +182,9 @@ while test $# -gt 0; do
shift
done
+# makeinfo uses the dirargs, but texi2dvi doesn't.
+commonarg=" $dirargs $commonarg"
+
# For most of the following, the base name is just $PACKAGE
base=$PACKAGE
@@ -247,46 +266,52 @@ case $outdir in
*) abs_outdir=$srcdir/$outdir;;
esac
-echo "Generating output formats for $srcfile"
+echo "Making output for $srcfile"
+echo " in `pwd`"
+mkdir -p "$outdir/"
cmd="$SETLANG $MAKEINFO -o $PACKAGE.info $commonarg $infoarg \"$srcfile\""
-echo "Generating info file(s)... ($cmd)"
+echo "Generating info... ($cmd)"
eval "$cmd"
-mkdir -p "$outdir/"
tar czf "$outdir/$PACKAGE.info.tar.gz" $PACKAGE.info*
+ls -l "$outdir/$PACKAGE.info.tar.gz"
info_tgz_size=`calcsize "$outdir/$PACKAGE.info.tar.gz"`
# do not mv the info files, there's no point in having them available
# separately on the web.
-cmd="$SETLANG $TEXI2DVI $commonarg \"$srcfile\""
-echo "Generating dvi ... ($cmd)"
+cmd="$SETLANG $TEXI2DVI $dirargs \"$srcfile\""
+printf "\nGenerating dvi... ($cmd)\n"
eval "$cmd"
-
# compress/finish dvi:
gzip -f -9 $PACKAGE.dvi
dvi_gz_size=`calcsize $PACKAGE.dvi.gz`
mv $PACKAGE.dvi.gz "$outdir/"
+ls -l "$outdir/$PACKAGE.dvi.gz"
-cmd="$SETLANG $TEXI2DVI --pdf $commonarg \"$srcfile\""
-echo "Generating pdf ... ($cmd)"
+cmd="$SETLANG $TEXI2DVI --pdf $dirargs \"$srcfile\""
+printf "\nGenerating pdf... ($cmd)\n"
eval "$cmd"
pdf_size=`calcsize $PACKAGE.pdf`
mv $PACKAGE.pdf "$outdir/"
+ls -l "$outdir/$PACKAGE.pdf"
-opt="-o $PACKAGE.txt --no-split --no-headers $commonarg"
-cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
-echo "Generating ASCII... ($cmd)"
-eval "$cmd"
-ascii_size=`calcsize $PACKAGE.txt`
-gzip -f -9 -c $PACKAGE.txt >"$outdir/$PACKAGE.txt.gz"
-ascii_gz_size=`calcsize "$outdir/$PACKAGE.txt.gz"`
-mv $PACKAGE.txt "$outdir/"
+if $generate_ascii; then
+ opt="-o $PACKAGE.txt --no-split --no-headers $commonarg"
+ cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
+ printf "\nGenerating ascii... ($cmd)\n"
+ eval "$cmd"
+ ascii_size=`calcsize $PACKAGE.txt`
+ gzip -f -9 -c $PACKAGE.txt >"$outdir/$PACKAGE.txt.gz"
+ ascii_gz_size=`calcsize "$outdir/$PACKAGE.txt.gz"`
+ mv $PACKAGE.txt "$outdir/"
+ ls -l "$outdir/$PACKAGE.txt" "$outdir/$PACKAGE.txt.gz"
+fi
html_split()
{
- opt="--split=$1 $commonarg $htmlarg --node-files"
+ opt="--split=$1 --node-files $commonarg $htmlarg"
cmd="$SETLANG $TEXI2HTML --output $PACKAGE.html $opt \"$srcfile\""
- echo "Generating html by $1... ($cmd)"
+ printf "\nGenerating html by $1... ($cmd)\n"
eval "$cmd"
split_html_dir=$PACKAGE.html
(
@@ -304,7 +329,7 @@ html_split()
if test -z "$use_texi2html"; then
opt="--no-split --html -o $PACKAGE.html $commonarg $htmlarg"
cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
- echo "Generating monolithic html... ($cmd)"
+ printf "\nGenerating monolithic html... ($cmd)\n"
rm -rf $PACKAGE.html # in case a directory is left over
eval "$cmd"
html_mono_size=`calcsize $PACKAGE.html`
@@ -312,24 +337,29 @@ if test -z "$use_texi2html"; then
html_mono_gz_size=`calcsize "$outdir/$PACKAGE.html.gz"`
copy_images "$outdir/" $PACKAGE.html
mv $PACKAGE.html "$outdir/"
+ ls -l "$outdir/$PACKAGE.html" "$outdir/$PACKAGE.html.gz"
- opt="--html -o $PACKAGE.html $commonarg $htmlarg"
+ opt="--html -o $PACKAGE.html --split=$split $commonarg $htmlarg"
cmd="$SETLANG $MAKEINFO $opt \"$srcfile\""
- echo "Generating html by node... ($cmd)"
+ printf "\nGenerating html by $split... ($cmd)\n"
eval "$cmd"
split_html_dir=$PACKAGE.html
copy_images $split_html_dir/ $split_html_dir/*.html
(
cd $split_html_dir || exit 1
- tar -czf "$abs_outdir/$PACKAGE.html_node.tar.gz" -- *
+ tar -czf "$abs_outdir/$PACKAGE.html_$split.tar.gz" -- *
)
- html_node_tgz_size=`calcsize "$outdir/$PACKAGE.html_node.tar.gz"`
- rm -rf "$outdir/html_node/"
- mv $split_html_dir "$outdir/html_node/"
-else
+ eval \
+ html_${split}_tgz_size=`calcsize "$outdir/$PACKAGE.html_$split.tar.gz"`
+ rm -rf "$outdir/html_$split/"
+ mv $split_html_dir "$outdir/html_$split/"
+ du -s "$outdir/html_$split/"
+ ls -l "$outdir/$PACKAGE.html_$split.tar.gz"
+
+else # use texi2html:
opt="--output $PACKAGE.html $commonarg $htmlarg"
cmd="$SETLANG $TEXI2HTML $opt \"$srcfile\""
- echo "Generating monolithic html... ($cmd)"
+ printf "\nGenerating monolithic html with texi2html... ($cmd)\n"
rm -rf $PACKAGE.html # in case a directory is left over
eval "$cmd"
html_mono_size=`calcsize $PACKAGE.html`
@@ -342,19 +372,20 @@ else
html_split section
fi
-echo Making .tar.gz for sources...
+printf "\nMaking .tar.gz for sources...\n"
d=`dirname $srcfile`
(
cd "$d"
- srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null` || true
- tar cvzfh "$abs_outdir/$PACKAGE.texi.tar.gz" $srcfiles
+ srcfiles=`ls -d *.texinfo *.texi *.txi *.eps $source_extra 2>/dev/null` ||
true
+ tar czfh "$abs_outdir/$PACKAGE.texi.tar.gz" $srcfiles
+ ls -l "$abs_outdir/$PACKAGE.texi.tar.gz"
)
texi_tgz_size=`calcsize "$outdir/$PACKAGE.texi.tar.gz"`
if test -n "$docbook"; then
opt="-o - --docbook $commonarg"
cmd="$SETLANG $MAKEINFO $opt \"$srcfile\" >${srcdir}/$PACKAGE-db.xml"
- echo "Generating docbook XML... ($cmd)"
+ printf "\nGenerating docbook XML... ($cmd)\n"
eval "$cmd"
docbook_xml_size=`calcsize $PACKAGE-db.xml`
gzip -f -9 -c $PACKAGE-db.xml >"$outdir/$PACKAGE-db.xml.gz"
@@ -364,7 +395,7 @@ if test -n "$docbook"; then
split_html_db_dir=html_node_db
opt="$commonarg -o $split_html_db_dir"
cmd="$DOCBOOK2HTML $opt \"${outdir}/$PACKAGE-db.xml\""
- echo "Generating docbook HTML... ($cmd)"
+ printf "\nGenerating docbook HTML... ($cmd)\n"
eval "$cmd"
(
cd ${split_html_db_dir} || exit 1
@@ -377,24 +408,25 @@ if test -n "$docbook"; then
rmdir ${split_html_db_dir}
cmd="$DOCBOOK2TXT \"${outdir}/$PACKAGE-db.xml\""
- echo "Generating docbook ASCII... ($cmd)"
+ printf "\nGenerating docbook ASCII... ($cmd)\n"
eval "$cmd"
docbook_ascii_size=`calcsize $PACKAGE-db.txt`
mv $PACKAGE-db.txt "$outdir/"
cmd="$DOCBOOK2PDF \"${outdir}/$PACKAGE-db.xml\""
- echo "Generating docbook PDF... ($cmd)"
+ printf "\nGenerating docbook PDF... ($cmd)\n"
eval "$cmd"
docbook_pdf_size=`calcsize $PACKAGE-db.pdf`
mv $PACKAGE-db.pdf "$outdir/"
fi
-echo "Writing index file..."
+printf "\nMaking index file...\n"
if test -z "$use_texi2html"; then
- CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\
- /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d"
+ CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\
+ /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d"
else
- CONDS="/%%ENDIF.*%%/d;/%%IF *HTML_SECTION%%/d;/%%IF *HTML_CHAPTER%%/d"
+ # should take account of --split here.
+ CONDS="/%%ENDIF.*%%/d;/%%IF *HTML_SECTION%%/d;/%%IF *HTML_CHAPTER%%/d"
fi
curdate=`$SETLANG date '+%B %d, %Y'`
diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen
index 0b51154..223a61e 100755
--- a/build-aux/git-version-gen
+++ b/build-aux/git-version-gen
@@ -1,8 +1,8 @@
#!/bin/sh
# Print a version string.
-scriptversion=2012-07-06.14; # UTC
+scriptversion=2012-12-31.23; # UTC
-# Copyright (C) 2007-2012 Free Software Foundation, Inc.
+# Copyright (C) 2007-2013 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,16 +85,18 @@ Print a version string.
Options:
- --prefix prefix of git tags to strip from version (default 'v')
- --match pattern for git tags to match (default: '\$prefix*')
+ --prefix prefix of git tags (default 'v')
+ --match pattern for git tags to match (default: '\$prefix*')
+ --fallback fallback version to use if \"git --version\" fails
- --help display this help and exit
- --version output version information and exit
+ --help display this help and exit
+ --version output version information and exit
-Running without arguments will suffice in most cases. If no --match
-argument is given, only match tags that begin with the --prefix."
+Running without arguments will suffice in most cases."
prefix=v
+fallback=
+
unset match
unset tag_sed_script
@@ -104,14 +106,15 @@ while test $# -gt 0; do
--version) echo "$version"; exit 0;;
--prefix) shift; prefix="$1";;
--match) shift; match="$1";;
+ --fallback) shift; fallback="$1";;
-*)
echo "$0: Unknown option '$1'." >&2
echo "$0: Try '--help' for more information." >&2
exit 1;;
*)
- if test -z "$tarball_version_file"; then
+ if test "x$tarball_version_file" = x; then
tarball_version_file="$1"
- elif test -z "$tag_sed_script"; then
+ elif test "x$tag_sed_script" = x; then
tag_sed_script="$1"
else
echo "$0: extra non-option argument '$1'." >&2
@@ -121,7 +124,7 @@ while test $# -gt 0; do
shift
done
-if test -z "$tarball_version_file"; then
+if test "x$tarball_version_file" = x; then
echo "$usage"
exit 1
fi
@@ -146,18 +149,19 @@ then
[0-9]*) ;;
*) v= ;;
esac
- test -z "$v" \
+ test "x$v" = x \
&& echo "$0: WARNING: $tarball_version_file is missing or damaged" 1>&2
fi
-if test -n "$v"
+if test "x$v" != x
then
: # use $v
# Otherwise, if there is at least one git commit involving the working
# directory, and "git describe" output looks sensible, use that to
# derive a version string.
elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
- && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
+ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null \
+ || git describe --abbrev=4 HEAD 2>/dev/null` \
&& v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
&& case $v in
$prefix[0-9]*) ;;
@@ -189,8 +193,10 @@ then
# Remove the "g" in git describe's output string, to save a byte.
v=`echo "$v" | sed 's/-/./;s/\(.*\)-g/\1-/'`;
v_from_git=1
-else
+elif test "x$fallback" = x || git --version >/dev/null 2>&1; then
v=UNKNOWN
+else
+ v=$fallback
fi
v=`echo "$v" |sed "s/^$prefix//"`
@@ -198,7 +204,7 @@ v=`echo "$v" |sed "s/^$prefix//"`
# Test whether to append the "-dirty" suffix only if the version
# string we're using came from git. I.e., skip the test if it's "UNKNOWN"
# or if it came from .tarball-version.
-if test -n "$v_from_git"; then
+if test "x$v_from_git" != x; then
# Don't declare a version "dirty" merely because a time stamp has changed.
git update-index --refresh > /dev/null 2>&1
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 5184edc..e02d34c 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -9,7 +9,7 @@ my $VERSION = '2012-07-29 06:11'; # UTC
# If you change this file with Emacs, please let the write hook
# do its job. Otherwise, update this string manually.
-# Copyright (C) 2008-2012 Free Software Foundation, Inc.
+# Copyright (C) 2008-2013 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 4acd69d..268ecc0 100755
--- a/build-aux/gnu-web-doc-update
+++ b/build-aux/gnu-web-doc-update
@@ -1,15 +1,10 @@
#!/bin/sh
# Run this after each non-alpha release, to update the web documentation at
# http://www.gnu.org/software/$pkg/manual/
-# This script must be run from the top-level directory,
-# assumes you're using git for revision control,
-# and requires a .prev-version file as well as a Makefile,
-# from which it extracts the version number and package name, respectively.
-# Also, it assumes all documentation is in the doc/ sub-directory.
-VERSION=2009-07-21.16; # UTC
+VERSION=2012-12-16.14; # UTC
-# Copyright (C) 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 2009-2013 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
@@ -37,8 +32,14 @@ Run this script from top_srcdir (no arguments) after each
non-alpha
release, to update the web documentation at
http://www.gnu.org/software/\$pkg/manual/
+This script assumes you're using git for revision control, and
+requires a .prev-version file as well as a Makefile, from which it
+extracts the version number and package name, respectively. Also, it
+assumes all documentation is in the doc/ sub-directory.
+
Options:
-C, --builddir=DIR location of (configured) Makefile (default: .)
+ -n, --dry-run don't actually commit anything
--help print this help, then exit
--version print version number, then exit
@@ -100,12 +101,12 @@ find_tool ()
# Requirements: everything required to bootstrap your package, plus
# these.
find_tool CVS cvs
-find_tool CVSU cvsu
find_tool GIT git
find_tool RSYNC rsync
find_tool XARGS gxargs xargs
builddir=.
+dryrun=
while test $# != 0
do
# Handle --option=value by splitting apart and putting back on argv.
@@ -121,6 +122,7 @@ do
case $1 in
--help|--version) ${1#--};;
-C|--builddir) shift; builddir=$1; shift ;;
+ -n|--dry-run) dryrun=echo; shift;;
--*) die "unrecognized option: $1";;
*) break;;
esac
@@ -139,7 +141,7 @@ current_branch=$($GIT branch | sed -ne '/^\* /{s///;p;q;}')
cleanup()
{
__st=$?
- rm -rf "$tmp"
+ $dryrun rm -rf "$tmp"
$GIT checkout "$current_branch"
$GIT submodule update --recursive
$GIT branch -d $tmp_branch
@@ -172,12 +174,15 @@ $RSYNC -avP "$builddir"/doc/manual/ $tmp/$pkg/manual
(
cd $tmp/$pkg/manual
- # Add any new files:
- $CVSU --types='?' \
- | sed s/..// \
- | $XARGS --no-run-if-empty -- $CVS add -ko
+ # Add all the files. This is simpler than trying to add only the
+ # new ones because of new directories: it would require iterating on
+ # adding the outer directories, and then their contents.
+ #
+ # find guarantees that we add outer directories first.
+ find . -name CVS -prune -o -print \
+ | $XARGS --no-run-if-empty -- $dryrun $CVS add -ko
- $CVS ci -m $version
+ $dryrun $CVS ci -m $version
)
# Local variables:
diff --git a/build-aux/gnupload b/build-aux/gnupload
index a0e5c7b..782dd6f 100755
--- a/build-aux/gnupload
+++ b/build-aux/gnupload
@@ -1,9 +1,9 @@
#!/bin/sh
# Sign files and upload them.
-scriptversion=2012-06-11.00; # UTC
+scriptversion=2012-12-11.16; # UTC
-# Copyright (C) 2004-2012 Free Software Foundation, Inc.
+# Copyright (C) 2004-2013 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
@@ -242,6 +242,8 @@ fi
# Make sure passphrase is not exported in the environment.
unset passphrase
+unset passphrase_fd_0
+GNUPGHOME=${GNUPGHOME:-$HOME/.gnupg}
# Reset PATH to be sure that echo is a built-in. We will later use
# 'echo $passphrase' to output the passphrase, so it is important that
@@ -249,12 +251,13 @@ unset passphrase
# listings with their arguments...).
# Remember this script runs with 'set -e', so if echo is not built-in
# it will exit now.
-if $dry_run; then :; else
+if $dry_run || grep -q "^use-agent" $GNUPGHOME/gpg.conf; then :; else
PATH=/empty echo -n "Enter GPG passphrase: "
stty -echo
read -r passphrase
stty echo
echo
+ passphrase_fd_0="--passphrase-fd 0"
fi
if test $# -ne 0; then
@@ -262,7 +265,7 @@ if test $# -ne 0; then
do
echo "Signing $file ..."
rm -f $file.sig
- echo "$passphrase" | $dbg $GPG --passphrase-fd 0 -ba -o $file.sig $file
+ echo "$passphrase" | $dbg $GPG $passphrase_fd_0 -ba -o $file.sig $file
done
fi
@@ -320,12 +323,12 @@ upload ()
case $dest in
alpha.gnu.org:*)
mkdirective "$destdir" "$base" "$file" "$stmt"
- echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign
$base.directive
+ echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign
$base.directive
$dbg ncftpput ftp-upload.gnu.org /incoming/alpha $files
$base.directive.asc
;;
ftp.gnu.org:*)
mkdirective "$destdir" "$base" "$file" "$stmt"
- echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign
$base.directive
+ echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign
$base.directive
$dbg ncftpput ftp-upload.gnu.org /incoming/ftp $files $base.directive.asc
;;
savannah.gnu.org:*)
@@ -344,7 +347,7 @@ upload ()
destdir_p1=`echo "$destdir" | sed 's,^[^/]*/,,'`
destdir_topdir=`echo "$destdir" | sed 's,/.*,,'`
mkdirective "$destdir_p1" "$base" "$file" "$stmt"
- echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign
$base.directive
+ echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign
$base.directive
for f in $files $base.directive.asc
do
echo put $f
@@ -353,7 +356,7 @@ upload ()
/*)
dest_host=`echo "$dest" | sed 's,:.*,,'`
mkdirective "$destdir" "$base" "$file" "$stmt"
- echo "$passphrase" | $dbg $GPG --passphrase-fd 0 --clearsign
$base.directive
+ echo "$passphrase" | $dbg $GPG $passphrase_fd_0 --clearsign
$base.directive
$dbg cp $files $base.directive.asc $dest_host
;;
*)
diff --git a/build-aux/snippet/arg-nonnull.h b/build-aux/snippet/arg-nonnull.h
index 3a9dd26..8ea2a47 100644
--- a/build-aux/snippet/arg-nonnull.h
+++ b/build-aux/snippet/arg-nonnull.h
@@ -1,5 +1,5 @@
/* A C macro for declaring that specific arguments must not be NULL.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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/snippet/c++defs.h b/build-aux/snippet/c++defs.h
index 96da94b..b35b933 100644
--- a/build-aux/snippet/c++defs.h
+++ b/build-aux/snippet/c++defs.h
@@ -1,5 +1,5 @@
/* C++ compatible function declaration macros.
- Copyright (C) 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2010-2013 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/snippet/unused-parameter.h
b/build-aux/snippet/unused-parameter.h
index 1c8d61f..1347c27 100644
--- a/build-aux/snippet/unused-parameter.h
+++ b/build-aux/snippet/unused-parameter.h
@@ -1,5 +1,5 @@
/* A C macro for declaring that specific function parameters are not used.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h
index d4cb94f..1736a1b 100644
--- a/build-aux/snippet/warn-on-use.h
+++ b/build-aux/snippet/warn-on-use.h
@@ -1,5 +1,5 @@
/* A C macro for emitting warnings if a function is used.
- Copyright (C) 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2010-2013 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
@@ -55,7 +55,7 @@
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; }
+ static char ***rpl_environ (void) { return &environ; }
_GL_WARN_ON_USE (rpl_environ, "environ is not always properly declared");
# undef environ
# define environ (*rpl_environ ())
diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free
index 2b64630..663347a 100755
--- a/build-aux/useless-if-before-free
+++ b/build-aux/useless-if-before-free
@@ -10,7 +10,7 @@ my $VERSION = '2012-01-06 07:23'; # UTC
# If you change this file with Emacs, please let the write hook
# do its job. Otherwise, update this string manually.
-# Copyright (C) 2008-2012 Free Software Foundation, Inc.
+# Copyright (C) 2008-2013 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 d477da8..7ec335f 100755
--- a/build-aux/vc-list-files
+++ b/build-aux/vc-list-files
@@ -4,7 +4,7 @@
# Print a version string.
scriptversion=2011-05-16.22; # UTC
-# Copyright (C) 2006-2012 Free Software Foundation, Inc.
+# Copyright (C) 2006-2013 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/configure.ac b/configure.ac
index d41026d..3cbd960 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[
Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
This file is part of GUILE
@@ -35,8 +35,11 @@ AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_SRCDIR(GUILE-VERSION)
-dnl `AM_PROG_AR' was introduced in Automake 1.11.2.
-AM_INIT_AUTOMAKE([1.11.2 gnu no-define -Wall -Wno-override color-tests
dist-xz])
+dnl Use `serial-tests' so the output `check-guile' is not hidden
+dnl (`parallel-tests' is the default in Automake 1.13.)
+dnl `serial-tests' was introduced in Automake 1.12.
+AM_INIT_AUTOMAKE([1.12 gnu no-define -Wall -Wno-override \
+ serial-tests color-tests dist-xz])
m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])],
[AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
@@ -644,12 +647,13 @@ AC_SUBST([SCM_I_GSC_HAVE_STRUCT_DIRENT64])
# this file instead of <fenv.h>
# process.h - mingw specific
# sched.h - missing on MinGW
+# sys/sendfile.h - non-POSIX, found in glibc
#
AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h memory.h process.h
string.h \
sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-direct.h machine/fpu.h poll.h sched.h])
+direct.h machine/fpu.h sched.h sys/sendfile.h])
# "complex double" is new in C99, and "complex" is only a keyword if
# <complex.h> is included
@@ -702,9 +706,6 @@ case $host in
[Define if you have the <winsock2.h> header file.])])
AC_CHECK_LIB(ws2_32, main)
AC_LIBOBJ([win32-uname])
- if test "$enable_networking" = yes ; then
- AC_LIBOBJ([win32-socket])
- fi
if test "$enable_shared" = yes ; then
EXTRA_DEFS="-DSCM_IMPORT"
AC_DEFINE([USE_DLL_IMPORT], 1,
@@ -733,9 +734,6 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# has it as an inline for chsize)
# ioctl - not in mingw.
# gmtime_r - recent posix, not on old systems
-# pipe - not in mingw
-# _pipe - specific to mingw, taking 3 args
-# poll - since posix 2001
# readdir_r - recent posix, not on old systems
# readdir64_r - not available on HP-UX 11.11
# stat64 - SuS largefile stuff, not on old systems
@@ -745,12 +743,24 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
# fork - unavailable on Windows
-# utimensat: posix.1-2008
-# sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
+# utimensat - posix.1-2008
+# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
+# sendfile - non-POSIX, found in glibc
#
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown fchmod getcwd geteuid getsid gettimeofday gmtime_r ioctl
lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename
rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt
stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname
waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent
getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index
bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l
newlocale utimensat sched_getaffinity sched_setaffinity])
-
-AM_CONDITIONAL([HAVE_FORK], [test "x$ac_cv_func_fork" = "xyes"])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid
\
+ fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid \
+ gettimeofday gmtime_r ioctl lstat mkdir mknod nice \
+ readdir_r readdir64_r readlink rename rmdir setegid seteuid \
+ setlocale setpgid setsid sigaction siginterrupt stat64 \
+ strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid \
+ strdup system usleep atexit on_exit chown link fcntl ttyname getpwent
\
+ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \
+ index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron \
+ strcoll strcoll_l newlocale utimensat sched_getaffinity \
+ sched_setaffinity sendfile])
+
+AM_CONDITIONAL([BUILD_ICE_9_POPEN],
+ [test "x$enable_posix" = "xyes" && test "x$ac_cv_func_fork" = "xyes"])
# Reasons for testing:
# netdb.h - not in mingw
@@ -861,6 +871,14 @@ if test "x$HAVE_LIBGMP" != "xyes"; then
AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README])
fi
+dnl `mpz_inits' and `mpz_clears' appeared in GMP 5.0.0.
+save_CPPFLAGS="$CPPFLAGS"
+if test "x$LIBGMP_PREFIX" != "x"; then
+ CPPFLAGS="-I$LIBGMP_PREFIX $CPPFLAGS"
+fi
+AC_CHECK_DECLS([mpz_inits], [], [], [[#include <gmp.h>]])
+CPPFLAGS="$save_CPPFLAGS"
+
dnl GNU libunistring is checked for by Gnulib's `libunistring' module.
if test "x$LTLIBUNISTRING" = "x"; then
AC_MSG_ERROR([GNU libunistring is required, please install it.])
@@ -917,6 +935,8 @@ AC_DEFUN([GUILE_FUNC_DECLARED], [
GUILE_FUNC_DECLARED(sleep, unistd.h)
GUILE_FUNC_DECLARED(usleep, unistd.h)
+AC_CHECK_DECLS([getlogin, alarm])
+
AC_CHECK_DECLS([strptime],,,
[#define _GNU_SOURCE /* ask glibc to give strptime prototype */
#include <time.h>])
@@ -1226,7 +1246,13 @@ save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link
GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap
GC_get_unmapped_bytes GC_set_finalizer_notifier GC_set_finalize_on_demand])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit \
+ GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask \
+ GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link
\
+ GC_get_heap_usage_safe GC_get_free_space_divisor \
+ GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier
\
+ GC_set_finalize_on_demand GC_set_all_interior_pointers GC_get_gc_no \
+ GC_set_java_finalization])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
@@ -1276,8 +1302,11 @@ if test $scm_cv_struct_linger = yes; then
fi
-# On mingw, struct timespec is in <pthread.h>.
-#
+dnl Check for `struct timespec', for the sake of `gen-scmconfig'. When
+dnl building Guile, we always have it, thanks to Gnulib; but scmconfig.h
+dnl must tell whether the system has it.
+dnl
+dnl On MinGW, struct timespec is in <pthread.h>.
AC_MSG_CHECKING(for struct timespec)
AC_CACHE_VAL(scm_cv_struct_timespec,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
@@ -1289,7 +1318,9 @@ AC_CACHE_VAL(scm_cv_struct_timespec,
[scm_cv_struct_timespec="no"]))
AC_MSG_RESULT($scm_cv_struct_timespec)
if test $scm_cv_struct_timespec = yes; then
- AC_DEFINE([HAVE_STRUCT_TIMESPEC], 1,
+ dnl Don't call it `HAVE_STRUCT_TIMESPEC' because pthread-win32's
+ dnl <pthread.h> checks whether that macro is defined.
+ AC_DEFINE([HAVE_SYSTEM_STRUCT_TIMESPEC], 1,
[Define this if your system defines struct timespec via either <time.h> or
<pthread.h>.])
fi
@@ -1629,7 +1660,6 @@ AC_CONFIG_FILES([
AC_CONFIG_FILES([meta/guile-2.2.pc])
AC_CONFIG_FILES([meta/guile-2.2-uninstalled.pc])
-AC_CONFIG_FILES([doc/ref/effective-version.texi])
GUILE_CONFIG_SCRIPT([check-guile])
GUILE_CONFIG_SCRIPT([benchmark-guile])
diff --git a/doc/gendocs_template b/doc/gendocs_template
index a62ad61..63fbe53 100644
--- a/doc/gendocs_template
+++ b/doc/gendocs_template
@@ -75,7 +75,7 @@ the FSF.<br />
Please send broken links and other corrections or suggestions to
<a href="mailto:%%EMAIL%%";><%%EMAIL%%></a>.</p>
-<p>Copyright © 2012 Free Software Foundation, Inc.</p>
+<p>Copyright © 2013 Free Software Foundation, Inc.</p>
<p>Verbatim copying and distribution of this entire article are
permitted worldwide, without royalty, in any medium, provided this
diff --git a/doc/guile-api.alist b/doc/guile-api.alist
index 5830c91..78d3a5c 100644
--- a/doc/guile-api.alist
+++ b/doc/guile-api.alist
@@ -1359,7 +1359,6 @@
(scm_array_copy_x (groups scm C) (scan-data T))
(scm_array_dimensions (groups scm C) (scan-data T))
(scm_array_equal_p (groups scm C) (scan-data T))
-(scm_array_fill_int (groups scm C) (scan-data T))
(scm_array_fill_x (groups scm C) (scan-data T))
(scm_array_for_each (groups scm C) (scan-data T))
(scm_array_identity (groups scm C) (scan-data T))
diff --git a/doc/r5rs/r5rs.texi b/doc/r5rs/r5rs.texi
index b7722c1..775c930 100644
--- a/doc/r5rs/r5rs.texi
+++ b/doc/r5rs/r5rs.texi
@@ -106,7 +106,6 @@
@author C. address@hidden
@author K. M. address@hidden
@author M. address@hidden
address@hidden
@c {\it Dedicated to the Memory of ALGOL 60}
@@ -116,7 +115,7 @@
address@hidden Summary
address@hidden Summary
The report gives a defining description of the programming language
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index 53cc7ce..75b1745 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -123,6 +123,13 @@ autoconf-macros.texi: $(top_srcdir)/meta/guile.m4
snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \
> $(srcdir)/$@
+# Build that file from here rather than at the user's site to avoid
+# triggering a rebuild of `guile.info'. Note that `GUILE-VERSION' is
+# among $(CONFIG_STATUS_DEPENDENCIES); thus, when it's updated, this
+# Makefile is rebuilt, and $(GUILE_EFFECTIVE_VERSION) is up-to-date.
+$(srcdir)/effective-version.texi: $(top_srcdir)/GUILE-VERSION
+ echo "@set EFFECTIVE-VERSION $(GUILE_EFFECTIVE_VERSION)" > $@
+
MAINTAINERCLEANFILES = autoconf-macros.texi
www-commit: html
diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi
index 5763f36..e3a9918 100644
--- a/doc/ref/api-binding.texi
+++ b/doc/ref/api-binding.texi
@@ -218,9 +218,9 @@ variables.
@lisp
(letrec ((a 42)
- (b (+ a 10)))
+ (b (+ a 10))) ;; Illegal access
(* a b))
address@hidden ;; Error: unbound variable: a
+;; The behavior of the expression above is unspecified
(letrec* ((a 42)
(b (+ a 10)))
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index be3d65f..699e760 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
address@hidden 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
address@hidden 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
@c See the file guile.texi for copying conditions.
@node Compound Data Types
@@ -22,7 +22,6 @@ values can be looked up within them.
* Lists:: Special list functions supported by Guile.
* Vectors:: One-dimensional arrays of Scheme objects.
* Bit Vectors:: Vectors of bits.
-* Generalized Vectors:: Treating all vector-like things uniformly.
* Arrays:: Matrices, etc.
* VLists:: Vector-like lists.
* Record Overview:: Walking through the maze of record APIs.
@@ -301,7 +300,7 @@ depending on the datatype of their arguments.
@rnindex list?
@deffn {Scheme Procedure} list? x
@deffnx {C Function} scm_list_p (x)
-Return @code{#t} iff @var{x} is a proper list, else @code{#f}.
+Return @code{#t} if @var{x} is a proper list, else @code{#f}.
@end deffn
The predicate @code{null?} is often used in list-processing code to
@@ -312,7 +311,7 @@ somehow deals with the elements of a list until the list
satisfies
@rnindex null?
@deffn {Scheme Procedure} null? x
@deffnx {C Function} scm_null_p (x)
-Return @code{#t} iff @var{x} is the empty list, else @code{#f}.
+Return @code{#t} if @var{x} is the empty list, else @code{#f}.
@end deffn
@deftypefn {C Function} int scm_is_null (SCM x)
@@ -993,9 +992,8 @@ are displayed as a sequence of @code{0}s and @code{1}s
prefixed by
#*00000000
@end example
-Bit vectors are also generalized vectors, @xref{Generalized
-Vectors}, and can thus be used with the array procedures, @xref{Arrays}.
-Bit vectors are the special case of one dimensional bit arrays.
+Bit vectors are the special case of one dimensional bit arrays, and can
+thus be used with the array procedures, @xref{Arrays}.
@deffn {Scheme Procedure} bitvector? obj
@deffnx {C Function} scm_bitvector_p (obj)
@@ -1163,74 +1161,6 @@ Like @code{scm_bitvector_elements}, but the pointer is
good for reading
and writing.
@end deftypefn
address@hidden Generalized Vectors
address@hidden Generalized Vectors
-
-Guile has a number of data types that are generally vector-like:
-strings, uniform numeric vectors, bytevectors, bitvectors, and of course
-ordinary vectors of arbitrary Scheme values. These types are disjoint:
-a Scheme value belongs to at most one of the five types listed above.
-
-If you want to gloss over this distinction and want to treat all four
-types with common code, you can use the procedures in this section.
-They work with the @emph{generalized vector} type, which is the union
-of the five vector-like types.
-
address@hidden {Scheme Procedure} generalized-vector? obj
address@hidden {C Function} scm_generalized_vector_p (obj)
-Return @code{#t} if @var{obj} is a vector, bytevector, string,
-bitvector, or uniform numeric vector.
address@hidden deffn
-
address@hidden {Scheme Procedure} generalized-vector-length v
address@hidden {C Function} scm_generalized_vector_length (v)
-Return the length of the generalized vector @var{v}.
address@hidden deffn
-
address@hidden {Scheme Procedure} generalized-vector-ref v idx
address@hidden {C Function} scm_generalized_vector_ref (v, idx)
-Return the element at index @var{idx} of the
-generalized vector @var{v}.
address@hidden deffn
-
address@hidden {Scheme Procedure} generalized-vector-set! v idx val
address@hidden {C Function} scm_generalized_vector_set_x (v, idx, val)
-Set the element at index @var{idx} of the
-generalized vector @var{v} to @var{val}.
address@hidden deffn
-
address@hidden {Scheme Procedure} generalized-vector->list v
address@hidden {C Function} scm_generalized_vector_to_list (v)
-Return a new list whose elements are the elements of the
-generalized vector @var{v}.
address@hidden deffn
-
address@hidden {C Function} int scm_is_generalized_vector (SCM obj)
-Return @code{1} if @var{obj} is a vector, string,
-bitvector, or uniform numeric vector; else return @code{0}.
address@hidden deftypefn
-
address@hidden {C Function} size_t scm_c_generalized_vector_length (SCM v)
-Return the length of the generalized vector @var{v}.
address@hidden deftypefn
-
address@hidden {C Function} SCM scm_c_generalized_vector_ref (SCM v, size_t idx)
-Return the element at index @var{idx} of the generalized vector @var{v}.
address@hidden deftypefn
-
address@hidden {C Function} void scm_c_generalized_vector_set_x (SCM v, size_t
idx, SCM val)
-Set the element at index @var{idx} of the generalized vector @var{v}
-to @var{val}.
address@hidden deftypefn
-
address@hidden {C Function} void scm_generalized_vector_get_handle (SCM v,
scm_t_array_handle *handle)
-Like @code{scm_array_get_handle} but an error is signalled when @var{v}
-is not of rank one. You can use @code{scm_array_handle_ref} and
address@hidden to read and write the elements of @var{v},
-or you can use functions like @code{scm_array_handle_<foo>_elements} to
-deal with specific types of vectors.
address@hidden deftypefn
-
@node Arrays
@subsection Arrays
@tpindex Arrays
@@ -1239,13 +1169,13 @@ deal with specific types of vectors.
number of dimensions. Each cell can be accessed in constant time by
supplying an index for each dimension.
-In the current implementation, an array uses a generalized vector for
-the actual storage of its elements. Any kind of generalized vector
-will do, so you can have arrays of uniform numeric values, arrays of
-characters, arrays of bits, and of course, arrays of arbitrary Scheme
-values. For example, arrays with an underlying @code{c64vector} might
-be nice for digital signal processing, while arrays made from a
address@hidden might be used to hold gray-scale images.
+In the current implementation, an array uses a vector of some kind for
+the actual storage of its elements. Any kind of vector will do, so you
+can have arrays of uniform numeric values, arrays of characters, arrays
+of bits, and of course, arrays of arbitrary Scheme values. For example,
+arrays with an underlying @code{c64vector} might be nice for digital
+signal processing, while arrays made from a @code{u8vector} might be
+used to hold gray-scale images.
The number of dimensions of an array is called its @dfn{rank}. Thus,
a matrix is an array of rank 2, while a vector has rank 1. When
@@ -1267,9 +1197,9 @@ matrix with zero columns and 3 rows is different from a
matrix with 3
columns and zero rows, which again is different from a vector of
length zero.
-Generalized vectors, such as strings, uniform numeric vectors,
-bytevectors, bit vectors and ordinary vectors, are the special case of
-one dimensional arrays.
+The array procedures are all polymorphic, treating strings, uniform
+numeric vectors, bytevectors, bit vectors and ordinary vectors as one
+dimensional arrays.
@menu
* Array Syntax::
@@ -1462,6 +1392,7 @@ as elements in the list.
@end deffn
@deffn {Scheme Procedure} array-type array
address@hidden {C Function} scm_array_type (array)
Return the type of @var{array}. This is the `vectag' used for
printing @var{array} (or @code{#t} for ordinary arrays) and can be
used with @code{make-typed-array} to create an array of the same kind
@@ -1469,6 +1400,7 @@ as @var{array}.
@end deffn
@deffn {Scheme Procedure} array-ref array idx @dots{}
address@hidden {C Function} scm_array_ref (array, idxlist)
Return the element at @code{(idx @dots{})} in @var{array}.
@example
@@ -1479,7 +1411,7 @@ Return the element at @code{(idx @dots{})} in @var{array}.
@deffn {Scheme Procedure} array-in-bounds? array idx @dots{}
@deffnx {C Function} scm_array_in_bounds_p (array, idxlist)
-Return @code{#t} if the given index would be acceptable to
+Return @code{#t} if the given indices would be acceptable to
@code{array-ref}.
@example
@@ -1520,6 +1452,13 @@ For example,
@end example
@end deffn
address@hidden {Scheme Procedure} array-length array
address@hidden {C Function} scm_array_length (array)
address@hidden {C Function} size_t scm_c_array_length (array)
+Return the length of an array: its first dimension. It is an error to
+ask for the length of an array of rank 0.
address@hidden deffn
+
@deffn {Scheme Procedure} array-rank array
@deffnx {C Function} scm_array_rank (array)
Return the rank of @var{array}.
@@ -2272,9 +2211,9 @@ different trade-offs. Over the years, each ``standard''
has also come
with its own new record interface, leading to a maze of record APIs.
At the highest level is SRFI-9, a high-level record interface
-implemented by most Scheme implementations (@pxref{SRFI-9}). It defines
-a simple and efficient syntactic abstraction of record types and their
-associated type predicate, fields, and field accessors. SRFI-9 is
+implemented by most Scheme implementations (@pxref{SRFI-9 Records}). It
+defines a simple and efficient syntactic abstraction of record types and
+their associated type predicate, fields, and field accessors. SRFI-9 is
suitable for most uses, and this is the recommended way to create record
types in Guile. Similar high-level record APIs include SRFI-35
(@pxref{SRFI-35}) and R6RS records (@pxref{rnrs records syntactic}).
@@ -2309,7 +2248,7 @@ Overview}). It can be used with:
(use-modules (srfi srfi-9))
@end example
address@hidden {library syntax} define-record-type type @* (constructor
fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{}
address@hidden {Scheme Syntax} define-record-type type @* (constructor
fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{}
@sp 1
Create a new record type, and make various @code{define}s for using
it. This syntax can only occur at the top-level, not nested within
@@ -2344,12 +2283,12 @@ field in a @var{record}.
An example will illustrate typical usage,
@example
-(define-record-type employee-type
+(define-record-type <employee>
(make-employee name age salary)
employee?
- (name get-employee-name)
- (age get-employee-age set-employee-age)
- (salary get-employee-salary set-employee-salary))
+ (name employee-name)
+ (age employee-age set-employee-age!)
+ (salary employee-salary set-employee-salary!))
@end example
This creates a new employee data type, with name, age and salary
@@ -2359,13 +2298,13 @@ that it's established only when an employee object is
created). These
can all then be used as for example,
@example
-employee-type @result{} #<record-type employee-type>
+<employee> @result{} #<record-type <employee>>
(define fred (make-employee "Fred" 45 20000.00))
(employee? fred) @result{} #t
-(get-employee-age fred) @result{} 45
-(set-employee-salary fred 25000.00) ;; pay rise
+(employee-age fred) @result{} 45
+(set-employee-salary! fred 25000.00) ;; pay rise
@end example
The functions created by @code{define-record-type} are ordinary
@@ -2395,10 +2334,10 @@ an output port.
This example prints the employee's name in brackets, for instance
@code{[Fred]}.
@example
-(set-record-type-printer! employee-type
+(set-record-type-printer! <employee>
(lambda (record port)
(write-char #\[ port)
- (display (get-employee-name record) port)
+ (display (employee-name record) port)
(write-char #\] port)))
@end example
@@ -2512,7 +2451,7 @@ data type. A @dfn{record} is an instance of a record
type.
Note that in many ways, this interface is too low-level for every-day
use. Most uses of records are better served by SRFI-9 records.
address@hidden
address@hidden Records}.
@deffn {Scheme Procedure} record? obj
Return @code{#t} if @var{obj} is a record of any type and @code{#f}
@@ -3796,8 +3735,9 @@ key is not found.
#f
@end lisp
-There is no procedure for calculating the number of key/value-pairs in
-a hash table, but @code{hash-fold} can be used for doing exactly that.
+Interesting results can be computed by using @code{hash-fold} to work
+through each element. This example will count the total number of
+elements:
@lisp
(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h)
@@ -3805,6 +3745,24 @@ a hash table, but @code{hash-fold} can be used for doing
exactly that.
3
@end lisp
+The same thing can be done with the procedure @code{hash-count}, which
+can also count the number of elements matching a particular predicate.
+For example, count the number of elements with string values:
+
address@hidden
+(hash-count (lambda (key value) (string? value)) h)
address@hidden
+2
address@hidden lisp
+
+Counting all the elements is a simple task using @code{const}:
+
address@hidden
+(hash-count (const #t) h)
address@hidden
+3
address@hidden lisp
+
@node Hash Table Reference
@subsubsection Hash Table Reference
@@ -4032,6 +3990,13 @@ For example, the following returns a count of how many
keys in
@end example
@end deffn
address@hidden {Scheme Procedure} hash-count pred table
address@hidden {C Function} scm_hash_count (pred, table)
+Return the number of elements in the given hash @var{table} that cause
address@hidden(@var{pred} @var{key} @var{value})} to return true. To quickly
+determine the total number of elements, use @code{(const #t)} for
address@hidden
address@hidden deffn
@c Local Variables:
@c TeX-master: "guile.texi"
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index d8b6a45..f34074e 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010, 2011, 2012
address@hidden Free Software Foundation, Inc.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010,
address@hidden 2011, 2012, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Control Mechanisms
@@ -200,7 +200,7 @@ For this clause type, @var{test} may return multiple
values, and
@code{cond} ignores its boolean state; instead, @code{cond} evaluates
@var{guard} and applies the resulting procedure to the value(s) of
@var{test}, as if @var{guard} were the @var{consumer} argument of
address@hidden Iff the result of that procedure call is a
address@hidden If the result of that procedure call is a
true value, it evaluates @var{expression} and applies the resulting
procedure to the value(s) of @var{test}, in the same manner as the
@var{guard} was called.
@@ -577,9 +577,58 @@ both.
Before moving on, we should mention that if the handler of a prompt is a
@code{lambda} 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
+that prompt will not cause a continuation to be reified. This can be an
important efficiency consideration to keep in mind.
address@hidden continuation, escape
+One example where this optimization matters is @dfn{escape
+continuations}. Escape continuations are delimited continuations whose
+only use is to make a non-local exit---i.e., to escape from the current
+continuation. Such continuations are invoked only once, and for this
+reason they are sometimes called @dfn{one-shot continuations}. A common
+use of escape continuations is when throwing an exception
+(@pxref{Exceptions}).
+
+The constructs below are syntactic sugar atop prompts to simplify the
+use of escape continuations.
+
address@hidden {Scheme Procedure} call-with-escape-continuation proc
address@hidden {Scheme Procedure} call/ec proc
+Call @var{proc} with an escape continuation.
+
+In the example below, the @var{return} continuation is used to escape
+the continuation of the call to @code{fold}.
+
address@hidden
+(use-modules (ice-9 control)
+ (srfi srfi-1))
+
+(define (prefix x lst)
+ ;; Return all the elements before the first occurrence
+ ;; of X in LST.
+ (call/ec
+ (lambda (return)
+ (fold (lambda (element prefix)
+ (if (equal? element x)
+ (return (reverse prefix)) ; escape `fold'
+ (cons element prefix)))
+ '()
+ lst))))
+
+(prefix 'a '(0 1 2 a 3 4 5))
address@hidden (0 1 2)
address@hidden lisp
address@hidden deffn
+
address@hidden {Scheme Syntax} let-escape-continuation k body @dots{}
address@hidden {Scheme Syntax} let/ec k body @dots{}
+Bind @var{k} within @var{body} to an escape continuation.
+
+This is equivalent to
address@hidden(call/ec (lambda (@var{k}) @var{body} @dots{}))}.
address@hidden deffn
+
+
@node Shift and Reset
@subsubsection Shift, Reset, and All That
@@ -987,6 +1036,11 @@ to avoid the risk of confusion with POSIX signals.
This manual prefers to speak of throwing and catching exceptions, since
this terminology matches the corresponding Guile primitives.
+The exception mechanism described in this section has connections with
address@hidden continuations} (@pxref{Prompts}). In particular,
+throwing an exception is akin to invoking an @dfn{escape continuation}
+(@pxref{Prompt Primitives, @code{call/ec}}).
+
@node Catch
@subsubsection Catching Exceptions
@@ -1735,8 +1789,8 @@ and the call to these routines doesn't change
@code{errno}.
@deftypefnx {C Function} void scm_wrong_type_arg (char address@hidden, int
@var{argnum}, SCM @var{bad_value})
@deftypefnx {C Function} void scm_wrong_type_arg_msg (char address@hidden, int
@var{argnum}, SCM @var{bad_value}, const char address@hidden)
@deftypefnx {C Function} void scm_memory_error (char address@hidden)
-Throw an error with the various keys described above.
@deftypefnx {C Function} void scm_misc_error (const char address@hidden, const
char address@hidden, SCM @var{args})
+Throw an error with the various keys described above.
In @code{scm_wrong_num_args}, @var{proc} should be a Scheme symbol
which is the name of the procedure incorrectly invoked. The other
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 28160c8..7603180 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1,7 +1,7 @@
@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, 2010, 2011, 2012, 2013
address@hidden Free Software Foundation, Inc.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007,
address@hidden 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
@c See the file guile.texi for copying conditions.
@node Simple Data Types
@@ -414,6 +414,7 @@ function will always succeed and will always return an
exact number.
@deftypefnx {C Function} {unsigned long long} scm_to_ulong_long (SCM x)
@deftypefnx {C Function} size_t scm_to_size_t (SCM x)
@deftypefnx {C Function} ssize_t scm_to_ssize_t (SCM x)
address@hidden {C Function} scm_t_ptrdiff scm_to_ptrdiff_t (SCM x)
@deftypefnx {C Function} scm_t_int8 scm_to_int8 (SCM x)
@deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x)
@deftypefnx {C Function} scm_t_int16 scm_to_int16 (SCM x)
@@ -447,6 +448,7 @@ the corresponding types are.
@deftypefnx {C Function} SCM scm_from_ulong_long (unsigned long long x)
@deftypefnx {C Function} SCM scm_from_size_t (size_t x)
@deftypefnx {C Function} SCM scm_from_ssize_t (ssize_t x)
address@hidden {C Function} SCM scm_from_ptrdiff_t (scm_t_ptrdiff x)
@deftypefnx {C Function} SCM scm_from_int8 (scm_t_int8 x)
@deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x)
@deftypefnx {C Function} SCM scm_from_int16 (scm_t_int16 x)
@@ -1684,19 +1686,15 @@ starts from 0 for the least significant bit.
@end lisp
@end deffn
address@hidden {Scheme Procedure} ash n cnt
address@hidden {C Function} scm_ash (n, cnt)
-Return @var{n} shifted left by @var{cnt} bits, or shifted right if
address@hidden is negative. This is an ``arithmetic'' shift.
address@hidden {Scheme Procedure} ash n count
address@hidden {C Function} scm_ash (n, count)
+Return @math{floor(n * 2^count)}.
address@hidden and @var{count} must be exact integers.
-This is effectively a multiplication by @m{2^{cnt}, address@hidden, and
-when @var{cnt} is negative it's a division, rounded towards negative
-infinity. (Note that this is not the same rounding as @code{quotient}
-does.)
-
-With @var{n} viewed as an infinite precision twos complement,
address@hidden means a left shift introducing zero bits, or a right shift
-dropping bits.
+With @var{n} viewed as an infinite-precision twos-complement
+integer, @code{ash} means a left shift introducing zero bits
+when @var{count} is positive, or a right shift dropping bits
+when @var{count} is negative. This is an ``arithmetic'' shift.
@lisp
(number->string (ash #b1 3) 2) @result{} "1000"
@@ -1707,6 +1705,28 @@ dropping bits.
@end lisp
@end deffn
address@hidden {Scheme Procedure} round-ash n count
address@hidden {C Function} scm_round_ash (n, count)
+Return @math{round(n * 2^count)}.
address@hidden and @var{count} must be exact integers.
+
+With @var{n} viewed as an infinite-precision twos-complement
+integer, @code{round-ash} means a left shift introducing zero
+bits when @var{count} is positive, or a right shift rounding
+to the nearest integer (with ties going to the nearest even
+integer) when @var{count} is negative. This is a rounded
+``arithmetic'' shift.
+
address@hidden
+(number->string (round-ash #b1 3) 2) @result{} \"1000\"
+(number->string (round-ash #b1010 -1) 2) @result{} \"101\"
+(number->string (round-ash #b1010 -2) 2) @result{} \"10\"
+(number->string (round-ash #b1011 -2) 2) @result{} \"11\"
+(number->string (round-ash #b1101 -2) 2) @result{} \"11\"
+(number->string (round-ash #b1110 -2) 2) @result{} \"100\"
address@hidden lisp
address@hidden deffn
+
@deffn {Scheme Procedure} logcount n
@deffnx {C Function} scm_logcount (n)
Return the number of bits in integer @var{n}. If @var{n} is
@@ -2047,7 +2067,7 @@ number of one to eight digits.
@rnindex char?
@deffn {Scheme Procedure} char? x
@deffnx {C Function} scm_char_p (x)
-Return @code{#t} iff @var{x} is a character, else @code{#f}.
+Return @code{#t} if @var{x} is a character, else @code{#f}.
@end deffn
Fundamentally, the character comparison operations below are
@@ -2055,31 +2075,31 @@ numeric comparisons of the character's code points.
@rnindex char=?
@deffn {Scheme Procedure} char=? x y
-Return @code{#t} iff code point of @var{x} is equal to the code point
+Return @code{#t} if code point of @var{x} is equal to the code point
of @var{y}, else @code{#f}.
@end deffn
@rnindex char<?
@deffn {Scheme Procedure} char<? x y
-Return @code{#t} iff the code point of @var{x} is less than the code
+Return @code{#t} if the code point of @var{x} is less than the code
point of @var{y}, else @code{#f}.
@end deffn
@rnindex char<=?
@deffn {Scheme Procedure} char<=? x y
-Return @code{#t} iff the code point of @var{x} is less than or equal
+Return @code{#t} if the code point of @var{x} is less than or equal
to the code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char>?
@deffn {Scheme Procedure} char>? x y
-Return @code{#t} iff the code point of @var{x} is greater than the
+Return @code{#t} if the code point of @var{x} is greater than the
code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char>=?
@deffn {Scheme Procedure} char>=? x y
-Return @code{#t} iff the code point of @var{x} is greater than or
+Return @code{#t} if the code point of @var{x} is greater than or
equal to the code point of @var{y}, else @code{#f}.
@end deffn
@@ -2097,32 +2117,32 @@ it cannot cover all cases for all languages.
@rnindex char-ci=?
@deffn {Scheme Procedure} char-ci=? x y
-Return @code{#t} iff the case-folded code point of @var{x} is the same
+Return @code{#t} if the case-folded code point of @var{x} is the same
as the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci<?
@deffn {Scheme Procedure} char-ci<? x y
-Return @code{#t} iff the case-folded code point of @var{x} is less
+Return @code{#t} if the case-folded code point of @var{x} is less
than the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci<=?
@deffn {Scheme Procedure} char-ci<=? x y
-Return @code{#t} iff the case-folded code point of @var{x} is less
+Return @code{#t} if the case-folded code point of @var{x} is less
than or equal to the case-folded code point of @var{y}, else
@code{#f}.
@end deffn
@rnindex char-ci>?
@deffn {Scheme Procedure} char-ci>? x y
-Return @code{#t} iff the case-folded code point of @var{x} is greater
+Return @code{#t} if the case-folded code point of @var{x} is greater
than the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci>=?
@deffn {Scheme Procedure} char-ci>=? x y
-Return @code{#t} iff the case-folded code point of @var{x} is greater
+Return @code{#t} if the case-folded code point of @var{x} is greater
than or equal to the case-folded code point of @var{y}, else
@code{#f}.
@end deffn
@@ -2130,36 +2150,36 @@ than or equal to the case-folded code point of @var{y},
else
@rnindex char-alphabetic?
@deffn {Scheme Procedure} char-alphabetic? chr
@deffnx {C Function} scm_char_alphabetic_p (chr)
-Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.
+Return @code{#t} if @var{chr} is alphabetic, else @code{#f}.
@end deffn
@rnindex char-numeric?
@deffn {Scheme Procedure} char-numeric? chr
@deffnx {C Function} scm_char_numeric_p (chr)
-Return @code{#t} iff @var{chr} is numeric, else @code{#f}.
+Return @code{#t} if @var{chr} is numeric, else @code{#f}.
@end deffn
@rnindex char-whitespace?
@deffn {Scheme Procedure} char-whitespace? chr
@deffnx {C Function} scm_char_whitespace_p (chr)
-Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.
+Return @code{#t} if @var{chr} is whitespace, else @code{#f}.
@end deffn
@rnindex char-upper-case?
@deffn {Scheme Procedure} char-upper-case? chr
@deffnx {C Function} scm_char_upper_case_p (chr)
-Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.
+Return @code{#t} if @var{chr} is uppercase, else @code{#f}.
@end deffn
@rnindex char-lower-case?
@deffn {Scheme Procedure} char-lower-case? chr
@deffnx {C Function} scm_char_lower_case_p (chr)
-Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.
+Return @code{#t} if @var{chr} is lowercase, else @code{#f}.
@end deffn
@deffn {Scheme Procedure} char-is-both? chr
@deffnx {C Function} scm_char_is_both_p (chr)
-Return @code{#t} iff @var{chr} is either uppercase or lowercase, else
+Return @code{#t} if @var{chr} is either uppercase or lowercase, else
@code{#f}.
@end deffn
@@ -2581,8 +2601,8 @@ string is not defined.
@deffn {Scheme Procedure} char-set-contains? cs ch
@deffnx {C Function} scm_char_set_contains_p (cs, ch)
-Return @code{#t} iff the character @var{ch} is contained in the
-character set @var{cs}.
+Return @code{#t} if the character @var{ch} is contained in the
+character set @var{cs}, or @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} char-set-every pred cs
@@ -3128,7 +3148,7 @@ placed between the strings, and defaults to the symbol
@item infix
Insert the separator between list elements. An empty string
will produce an empty list.
address@hidden string-infix
address@hidden strict-infix
Like @code{infix}, but will raise an error if given the empty
list.
@item suffix
@@ -4202,7 +4222,7 @@ Unlike the rest of the procedures in this section, you
have to load the
(use-modules (ice-9 iconv))
@end example
address@hidden string->bytevector string encoding [conversion-strategy]
address@hidden {Scheme Procedure} string->bytevector string encoding
[conversion-strategy]
Encode @var{string} as a sequence of bytes.
The string will be encoded in the character set specified by the
@@ -4216,7 +4236,7 @@ bytevectors. @xref{Ports}, for more on character
encodings and
conversion strategies.
@end deffn
address@hidden bytevector->string bytevector encoding [conversion-strategy]
address@hidden {Scheme Procedure} bytevector->string bytevector encoding
[conversion-strategy]
Decode @var{bytevector} into a string.
The bytes will be decoded from the character set by the @var{encoding}
@@ -4227,7 +4247,7 @@ argument to modify this behavior. @xref{Ports}, for more
on character
encodings and conversion strategies.
@end deffn
address@hidden call-with-output-encoded-string encoding proc
[conversion-strategy]
address@hidden {Scheme Procedure} call-with-output-encoded-string encoding proc
[conversion-strategy]
Like @code{call-with-output-string}, but instead of returning a string,
returns a encoding of the string according to @var{encoding}, as a
bytevector. This procedure can be more efficient than collecting a
@@ -4283,9 +4303,9 @@ If the C string is ill-formed, an error will be raised.
Note that these functions should @emph{not} be used to convert C string
constants, because there is no guarantee that the current locale will
-match that of the source code. To convert C string constants, use
address@hidden, @code{scm_from_utf8_string} or
address@hidden
+match that of the execution character set, used for string and character
+constants. Most modern C compilers use UTF-8 by default, so to convert
+C string constants we recommend @code{scm_from_utf8_string}.
@end deftypefn
@deftypefn {C Function} SCM scm_take_locale_string (char *str)
@@ -4548,7 +4568,7 @@ R6RS (@pxref{R6RS I/O Ports}).
* Bytevectors and Integer Lists:: Converting to/from an integer list.
* 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 Arrays:: Guile extension to the bytevector API.
* Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4.
@end menu
@@ -4934,25 +4954,27 @@ or UTF-32-decoded contents of bytevector @var{utf}.
For UTF-16 and UTF-32,
it defaults to big endian.
@end deffn
address@hidden Bytevectors as Generalized Vectors
address@hidden Accessing Bytevectors with the Generalized Vector API
address@hidden Bytevectors as Arrays
address@hidden Accessing Bytevectors with the Array API
As an extension to the R6RS, Guile allows bytevectors to be manipulated
-with the @dfn{generalized vector} procedures (@pxref{Generalized
-Vectors}). This also allows bytevectors to be accessed using the
-generic @dfn{array} procedures (@pxref{Array Procedures}). When using
-these APIs, bytes are accessed one at a time as 8-bit unsigned integers:
+with the @dfn{array} procedures (@pxref{Arrays}). When using these
+APIs, bytes are accessed one at a time as 8-bit unsigned integers:
@example
(define bv #vu8(0 1 2 3))
-(generalized-vector? bv)
+(array? bv)
@result{} #t
-(generalized-vector-ref bv 2)
+(array-rank bv)
address@hidden 1
+
+(array-ref bv 2)
@result{} 2
-(generalized-vector-set! bv 2 77)
+;; Note the different argument order on array-set!.
+(array-set! bv 77 2)
(array-ref bv 2)
@result{} 77
@@ -5353,15 +5375,15 @@ When you want to do more from C, you should convert
between symbols
and strings using @code{scm_symbol_to_string} and
@code{scm_string_to_symbol} and work with the strings.
address@hidden {C Function} scm_from_latin1_symbol (const char *name)
address@hidden {C Function} scm_from_utf8_symbol (const char *name)
address@hidden {C Function} SCM scm_from_latin1_symbol (const char *name)
address@hidden {C Function} SCM scm_from_utf8_symbol (const char *name)
Construct and return a Scheme symbol whose name is specified by the
null-terminated C string @var{name}. These are appropriate when
the C string is hard-coded in the source code.
@end deftypefn
address@hidden {C Function} scm_from_locale_symbol (const char *name)
address@hidden {C Function} scm_from_locale_symboln (const char *name, size_t
len)
address@hidden {C Function} SCM scm_from_locale_symbol (const char *name)
address@hidden {C Function} SCM scm_from_locale_symboln (const char *name,
size_t len)
Construct and return a Scheme symbol whose name is specified by
@var{name}. For @code{scm_from_locale_symbol}, @var{name} must be null
terminated; for @code{scm_from_locale_symboln} the length of @var{name} is
@@ -5369,8 +5391,9 @@ specified explicitly by @var{len}.
Note that these functions should @emph{not} be used when @var{name} is a
C string constant, because there is no guarantee that the current locale
-will match that of the source code. In such cases, use
address@hidden or @code{scm_from_utf8_symbol}.
+will match that of the execution character set, used for string and
+character constants. Most modern C compilers use UTF-8 by default, so
+in such cases we recommend @code{scm_from_utf8_symbol}.
@end deftypefn
@deftypefn {C Function} SCM scm_take_locale_symbol (char *str)
@@ -5770,6 +5793,8 @@ For further details on @code{let-keywords},
@code{define*} and other
facilities provided by the @code{(ice-9 optargs)} module, see
@ref{Optional Arguments}.
+To handle keyword arguments from procedures implemented in C,
+use @code{scm_c_bind_keyword_arguments} (@pxref{Keyword Procedures}).
@node Keyword Read Syntax
@subsubsection Keyword Read Syntax
@@ -5861,8 +5886,9 @@ Equivalent to @code{scm_symbol_to_keyword
(scm_from_locale_symbol
Note that these functions should @emph{not} be used when @var{name} is a
C string constant, because there is no guarantee that the current locale
-will match that of the source code. In such cases, use
address@hidden or @code{scm_from_utf8_keyword}.
+will match that of the execution character set, used for string and
+character constants. Most modern C compilers use UTF-8 by default, so
+in such cases we recommend @code{scm_from_utf8_keyword}.
@end deftypefn
@deftypefn {C Function} SCM scm_from_latin1_keyword (const char *name)
@@ -5872,6 +5898,70 @@ Equivalent to @code{scm_symbol_to_keyword
(scm_from_latin1_symbol
(@var{name}))}, respectively.
@end deftypefn
address@hidden {C Function} void scm_c_bind_keyword_arguments (const char
*subr, @
+ SCM rest, scm_t_keyword_arguments_flags flags, @
+ SCM keyword1, SCM *argp1, @
+ @dots{}, @
+ SCM keywordN, SCM *argpN, @
+ @nicode{SCM_UNDEFINED})
+
+Extract the specified keyword arguments from @var{rest}, which is not
+modified. If the keyword argument @var{keyword1} is present in
address@hidden with an associated value, that value is stored in the
+variable pointed to by @var{argp1}, otherwise the variable is left
+unchanged. Similarly for the other keywords and argument pointers up to
address@hidden and @var{argpN}. The argument list to
address@hidden must be terminated by
address@hidden
+
+Note that since the variables pointed to by @var{argp1} through
address@hidden are left unchanged if the associated keyword argument is not
+present, they should be initialized to their default values before
+calling @code{scm_c_bind_keyword_arguments}. Alternatively, you can
+initialize them to @code{SCM_UNDEFINED} before the call, and then use
address@hidden after the call to see which ones were provided.
+
+If an unrecognized keyword argument is present in @var{rest} and
address@hidden does not contain @code{SCM_ALLOW_OTHER_KEYS}, or if
+non-keyword arguments are present and @var{flags} does not contain
address@hidden, an exception is raised.
address@hidden should be the name of the procedure receiving the keyword
+arguments, for purposes of error reporting.
+
+For example:
+
address@hidden
+SCM k_delimiter;
+SCM k_grammar;
+SCM sym_infix;
+
+SCM my_string_join (SCM strings, SCM rest)
address@hidden
+ SCM delimiter = SCM_UNDEFINED;
+ SCM grammar = sym_infix;
+
+ scm_c_bind_keyword_arguments ("my-string-join", rest, 0,
+ k_delimiter, &delimiter,
+ k_grammar, &grammar,
+ SCM_UNDEFINED);
+
+ if (SCM_UNBNDP (delimiter))
+ delimiter = scm_from_utf8_string (" ");
+
+ return scm_string_join (strings, delimiter, grammar);
address@hidden
+
+void my_init ()
address@hidden
+ k_delimiter = scm_from_utf8_keyword ("delimiter");
+ k_grammar = scm_from_utf8_keyword ("grammar");
+ sym_infix = scm_from_utf8_symbol ("infix");
+ scm_c_define_gsubr ("my-string-join", 1, 0, 1, my_string_join);
address@hidden
address@hidden example
address@hidden deftypefn
+
+
@node Other Types
@subsection ``Functionality-Centric'' Data Types
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 2a86c1e..7f936fe 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,
2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -1176,7 +1176,9 @@ calls to @var{proc}.
In addition, Guile defines a procedure to call a thunk, tracing all
procedure calls and returns within the thunk.
address@hidden {Scheme Procedure} call-with-trace thunk #:key (calls? #t)
(instructions? #f) (width 80) (vm (the-vm))
address@hidden {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @
+ [#:instructions?=#f] @
+ [#:width=80] [#:vm=(the-vm)]
Call @var{thunk}, tracing all execution within its dynamic extent.
If @var{calls?} is true, Guile will print a brief report at each
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 0ffb501..63b1d60 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -22,6 +22,7 @@ loading, evaluating, and compiling Scheme code at run time.
* Delayed Evaluation:: Postponing evaluation until it is needed.
* Local Evaluation:: Evaluation in a local lexical environment.
* Local Inclusion:: Compile-time inclusion of one file in another.
+* REPL Servers:: Serving a REPL over a socket.
@end menu
@@ -488,7 +489,10 @@ procedure in the default environment, but you really want
the one from
(use-modules (ice-9 eval-string))
@end example
address@hidden {Scheme Procedure} eval-string string [module=#f] [file=#f]
[line=#f] [column=#f] [lang=(current-language)] [compile?=#f]
address@hidden {Scheme Procedure} eval-string string [#:module=#f] [#:file=#f] @
+ [#:line=#f] [#:column=#f] @
+ [#:lang=(current-language)] @
+ [#:compile?=#f]
Parse @var{string} according to the current language, normally Scheme.
Evaluate or compile the expressions it contains, in order, returning the
last expression.
@@ -691,7 +695,9 @@ coding declaration as recognized by @code{file-encoding}
The compiler can also be invoked directly by Scheme code using the procedures
below:
address@hidden {Scheme Procedure} compile exp [env=#f]
[from=(current-language)] [to=value] [opts=()]
address@hidden {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;
otherwise @code{compile} is mostly equivalent to @code{eval}.
@@ -700,10 +706,11 @@ For a discussion of languages and compiler options,
@xref{Compiling to
the Virtual Machine}.
@end deffn
address@hidden {Scheme Procedure} compile-file file [output-file=#f] @
- [from=(current-language)] [to='objcode] @
- [env=(default-environment from)] [opts='()] @
- [canonicalization 'relative]
address@hidden {Scheme Procedure} compile-file file [#:output-file=#f] @
+ [#:from=(current-language)] [#:to='objcode] @
+ [#:env=(default-environment from)] @
+ [#:opts='()] @
+ [#:canonicalization='relative]
Compile the file named @var{file}.
Output will be written to a @var{output-file}. If you do not supply an
@@ -984,17 +991,19 @@ three arguments.
@cindex source file encoding
@cindex primitive-load
@cindex load
-Scheme source code files are usually encoded in ASCII, but, the
-built-in reader can interpret other character encodings. The
-procedure @code{primitive-load}, and by extension the functions that
-call it, such as @code{load}, first scan the top 500 characters of the
-file for a coding declaration.
+Scheme source code files are usually encoded in ASCII or UTF-8, but the
+built-in reader can interpret other character encodings as well. When
+Guile loads Scheme source code, it uses the @code{file-encoding}
+procedure (described below) to try to guess the encoding of the file.
+In the absence of any hints, UTF-8 is assumed. One way to provide a
+hint about the encoding of a source file is to place a coding
+declaration in the top 500 characters of the file.
A coding declaration has the form @code{coding: XXXXXX}, where
@code{XXXXXX} is the name of a character encoding in which the source
code file has been encoded. The coding declaration must appear in a
-scheme comment. It can either be a semicolon-initiated comment or a block
address@hidden comment.
+scheme comment. It can either be a semicolon-initiated comment, or the
+first block @code{#!} comment in the file.
The name of the character encoding in the coding declaration is
typically lower case and containing only letters, numbers, and hyphens,
@@ -1043,15 +1052,21 @@ the port's character encoding should be set to the
encoding returned
by @code{file-encoding}, if any, again by using
@code{set-port-encoding!}. Then the code can be read as normal.
+Alternatively, one can use the @code{#:guess-encoding} keyword argument
+of @code{open-file} and related procedures. @xref{File Ports}.
+
@deffn {Scheme Procedure} file-encoding port
@deffnx {C Function} scm_file_encoding (port)
-Scan the port for an Emacs-like character coding declaration near the
-top of the contents of a port with random-accessible contents
-(@pxref{Recognize Coding, how Emacs recognizes file encoding,, emacs,
-The GNU Emacs Reference Manual}). The coding declaration is of the form
address@hidden: XXXXX} and must appear in a Scheme comment. Return a
-string containing the character encoding of the file if a declaration
-was found, or @code{#f} otherwise. The port is rewound.
+Attempt to scan the first few hundred bytes from the @var{port} for
+hints about its character encoding. Return a string containing the
+encoding name or @code{#f} if the encoding cannot be determined. The
+port is rewound.
+
+Currently, the only supported method is to look for an Emacs-like
+character coding declaration (@pxref{Recognize Coding, how Emacs
+recognizes file encoding,, emacs, The GNU Emacs Reference Manual}). The
+coding declaration is of the form @code{coding: XXXXX} and must appear
+in a Scheme comment. Additional heuristics may be added in the future.
@end deffn
@@ -1061,7 +1076,8 @@ was found, or @code{#f} otherwise. The port is rewound.
@cindex promises
Promises are a convenient way to defer a calculation until its result
-is actually needed, and to run such a calculation only once.
+is actually needed, and to run such a calculation only once. Also
address@hidden
@deffn syntax delay expr
@rnindex delay
@@ -1213,6 +1229,52 @@ the source files for a package (as you should!). It
makes it possible
to evaluate an installed file from source, instead of relying on the
@code{.go} file being up to date.
address@hidden REPL Servers
address@hidden REPL Servers
+
address@hidden REPL server
+
+The procedures in this section are provided by
address@hidden
+(use-modules (system repl server))
address@hidden lisp
+
+When an application is written in Guile, it is often convenient to
+allow the user to be able to interact with it by evaluating Scheme
+expressions in a REPL.
+
+The procedures of this module allow you to spawn a @dfn{REPL server},
+which permits interaction over a local or TCP connection. Guile itself
+uses them internally to implement the @option{--listen} switch,
address@hidden Options}.
+
address@hidden {Scheme Procedure} make-tcp-server-socket [#:host=#f] @
+ [#:addr] [#:port=37146]
+Return a stream socket bound to a given address @var{addr} and port
+number @var{port}. If the @var{host} is given, and @var{addr} is not,
+then the @var{host} string is converted to an address. If neither is
+given, we use the loopback address.
address@hidden deffn
+
address@hidden {Scheme Procedure} make-unix-domain-server-socket
[#:path="/tmp/guile-socket"]
+Return a UNIX domain socket, bound to a given @var{path}.
address@hidden deffn
+
address@hidden {Scheme Procedure} run-server [server-socket]
address@hidden {Scheme Procedure} spawn-server [server-socket]
+Create and run a REPL, making it available over the given
address@hidden If @var{server-socket} is not provided, it
+defaults to the socket created by calling @code{make-tcp-server-socket}
+with no arguments.
+
address@hidden runs the server in the current thread, whereas
address@hidden runs the server in a new thread.
address@hidden deffn
+
address@hidden {Scheme Procedure} stop-server-and-clients!
+Closes the connection on all running server sockets.
address@hidden deffn
+
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index f8ed4cc..e595668 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -489,6 +489,8 @@ platform-dependent size:
@defvrx {Scheme Variable} long
@defvrx {Scheme Variable} unsigned-long
@defvrx {Scheme Variable} size_t
address@hidden {Scheme Variable} ssize_t
address@hidden {Scheme Variable} ptrdiff_t
Values exported by the @code{(system foreign)} module, representing C
numeric types. For example, @code{long} may be @code{equal?} to
@code{int64} on a 64-bit platform.
@@ -801,8 +803,8 @@ int64_t a; uint8_t b; @}}:
@end 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
+conventionally-packed structs. But given the @code{bytevector->pointer}
+and @code{pointer->bytevector} routines, one can create and parse
tightly packed structs and unions by hand. See the code for
@code{(system foreign)} for details.
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 11ae580..4c42de8 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009,
address@hidden 2010, 2011 Free Software Foundation, Inc.
address@hidden 2010, 2011, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Input and Output
@@ -19,6 +19,7 @@
* Port Types:: Types of port and how to make them.
* R6RS I/O Ports:: The R6RS port API.
* I/O Extensions:: Using and extending ports in C.
+* BOM Handling:: Handling of Unicode byte order marks.
@end menu
@@ -842,7 +843,10 @@ Most systems have limits on how many files can be open, so
it's
strongly recommended that file ports be closed explicitly when no
longer required (@pxref{Ports}).
address@hidden {Scheme Procedure} open-file filename mode
address@hidden {Scheme Procedure} open-file filename mode @
+ [#:guess-encoding=#f] [#:encoding=#f]
address@hidden {C Function} scm_open_file_with_encoding @
+ (filename, mode, guess_encoding, encoding)
@deffnx {C Function} scm_open_file (filename, mode)
Open the file whose name is @var{filename}, and return a port
representing that file. The attributes of the port are
@@ -884,8 +888,8 @@ Use binary mode, ensuring that each byte in the file will
be read as one
Scheme character.
To provide this property, the file will be opened with the 8-bit
-character encoding "ISO-8859-1", ignoring any coding declaration or port
-encoding. @xref{Ports}, for more information on port encodings.
+character encoding "ISO-8859-1", ignoring the default port encoding.
address@hidden, for more information on port encodings.
Note that while it is possible to read and write binary data as
characters or strings, it is usually better to treat bytes as octets,
@@ -899,15 +903,33 @@ to the underlying @code{open} call. Still, the flag is
generally useful
because of its port encoding ramifications.
@end table
-If a file cannot be opened with the access
-requested, @code{open-file} throws an exception.
+Unless binary mode is requested, the character encoding of the new port
+is determined as follows: First, if @var{guess-encoding} is true, the
address@hidden procedure is used to guess the encoding of the file
+(@pxref{Character Encoding of Source Files}). If @var{guess-encoding}
+is false or if @code{file-encoding} fails, @var{encoding} is used unless
+it is also false. As a last resort, the default port encoding is used.
address@hidden, for more information on port encodings. It is an error to
+pass a non-false @var{guess-encoding} or @var{encoding} if binary mode
+is requested.
+
+If a file cannot be opened with the access requested, @code{open-file}
+throws an exception.
+
+When the file is opened, its encoding is set to the current
address@hidden, unless the @code{b} flag was supplied.
+Sometimes it is desirable to honor Emacs-style coding declarations in
address@hidden 2.0.0 to 2.0.7 would do this by default. This
+behavior was deemed inappropriate and disabled starting from Guile
+2.0.8.}. When that is the case, the @code{file-encoding} procedure can
+be used as follows (@pxref{Character Encoding of Source Files,
address@hidden):
-When the file is opened, this procedure will scan for a coding
-declaration (@pxref{Character Encoding of Source Files}). If a coding
-declaration is found, it will be used to interpret the file. Otherwise,
-the port's encoding will be used. To suppress this behavior, open the
-file in binary mode and then set the port encoding explicitly using
address@hidden
address@hidden
+(let* ((port (open-input-file file))
+ (encoding (file-encoding port)))
+ (set-port-encoding! port (or encoding (port-encoding port))))
address@hidden example
In theory we could create read/write ports which were buffered
in one direction only. However this isn't included in the
@@ -915,23 +937,40 @@ current interfaces.
@end deffn
@rnindex open-input-file
address@hidden {Scheme Procedure} open-input-file filename
-Open @var{filename} for input. Equivalent to
address@hidden {Scheme Procedure} open-input-file filename @
+ [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
+
+Open @var{filename} for input. If @var{binary} is true, open the port
+in binary mode, otherwise use text mode. @var{encoding} and
address@hidden determine the character encoding as described above
+for @code{open-file}. Equivalent to
@lisp
-(open-file @var{filename} "r")
+(open-file @var{filename}
+ (if @var{binary} "rb" "r")
+ #:guess-encoding @var{guess-encoding}
+ #:encoding @var{encoding})
@end lisp
@end deffn
@rnindex open-output-file
address@hidden {Scheme Procedure} open-output-file filename
-Open @var{filename} for output. Equivalent to
address@hidden {Scheme Procedure} open-output-file filename @
+ [#:encoding=#f] [#:binary=#f]
+
+Open @var{filename} for output. If @var{binary} is true, open the port
+in binary mode, otherwise use text mode. @var{encoding} specifies the
+character encoding as described above for @code{open-file}. Equivalent
+to
@lisp
-(open-file @var{filename} "w")
+(open-file @var{filename}
+ (if @var{binary} "wb" "w")
+ #:encoding @var{encoding})
@end lisp
@end deffn
address@hidden {Scheme Procedure} call-with-input-file filename proc
address@hidden {Scheme Procedure} call-with-output-file filename proc
address@hidden {Scheme Procedure} call-with-input-file filename proc @
+ [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
address@hidden {Scheme Procedure} call-with-output-file filename proc @
+ [#:encoding=#f] [#:binary=#f]
@rnindex call-with-input-file
@rnindex call-with-output-file
Open @var{filename} for input or output, and call @code{(@var{proc}
@@ -946,9 +985,12 @@ closed automatically, though it will be garbage collected
in the usual
way if not otherwise referenced.
@end deffn
address@hidden {Scheme Procedure} with-input-from-file filename thunk
address@hidden {Scheme Procedure} with-output-to-file filename thunk
address@hidden {Scheme Procedure} with-error-to-file filename thunk
address@hidden {Scheme Procedure} with-input-from-file filename thunk @
+ [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
address@hidden {Scheme Procedure} with-output-to-file filename thunk @
+ [#:encoding=#f] [#:binary=#f]
address@hidden {Scheme Procedure} with-error-to-file filename thunk @
+ [#:encoding=#f] [#:binary=#f]
@rnindex with-input-from-file
@rnindex with-output-to-file
Open @var{filename} and call @code{(@var{thunk})} with the new port
@@ -1214,9 +1256,10 @@ possible.
* R6RS Textual Output:: Textual output.
@end menu
-A subset of the @code{(rnrs io ports)} module is provided by the
address@hidden(ice-9 binary-ports)} module. It contains binary input/output
-procedures and does not rely on R6RS support.
+A subset of the @code{(rnrs io ports)} module, plus one non-standard
+procedure @code{unget-bytevector} (@pxref{R6RS Binary Input}), is
+provided by the @code{(ice-9 binary-ports)} module. It contains binary
+input/output procedures and does not rely on R6RS support.
@node R6RS File Names
@subsubsection File Names
@@ -1833,9 +1876,10 @@ actually read or the end-of-file object.
@deffn {Scheme Procedure} get-bytevector-some port
@deffnx {C Function} scm_get_bytevector_some (port)
-Read from @var{port}, blocking as necessary, until data are available or
-and end-of-file is reached. Return either a new bytevector containing
-the data read or the end-of-file object.
+Read from @var{port}, blocking as necessary, until bytes are available
+or an end-of-file is reached. Return either the end-of-file object or a
+new bytevector containing some of the available bytes (at least one),
+and update the port position to point just past these bytes.
@end deffn
@deffn {Scheme Procedure} get-bytevector-all port
@@ -1845,6 +1889,18 @@ reached. Return either a new bytevector containing the
data read or the
end-of-file object (if no data were available).
@end deffn
+The @code{(ice-9 binary-ports)} module provides the following procedure
+as an extension to @code{(rnrs io ports)}:
+
address@hidden {Scheme Procedure} unget-bytevector port bv [start [count]]
address@hidden {C Function} scm_unget_bytevector (port, bv, start, count)
+Place the contents of @var{bv} in @var{port}, optionally starting at
+index @var{start} and limiting to @var{count} octets, so that its bytes
+will be read from left-to-right as the next bytes from @var{port} during
+subsequent read operations. If called multiple times, the unread bytes
+will be read again in last-in first-out order.
address@hidden deffn
+
@node R6RS Textual Input
@subsubsection Textual Input
@@ -2372,6 +2428,84 @@ Set using
@end table
address@hidden BOM Handling
address@hidden Handling of Unicode byte order marks.
address@hidden BOM
address@hidden byte order mark
+
+This section documents the finer points of Guile's handling of Unicode
+byte order marks (BOMs). A byte order mark (U+FEFF) is typically found
+at the start of a UTF-16 or UTF-32 stream, to allow readers to reliably
+determine the byte order. Occasionally, a BOM is found at the start of
+a UTF-8 stream, but this is much less common and not generally
+recommended.
+
+Guile attempts to handle BOMs automatically, and in accordance with the
+recommendations of the Unicode Standard, when the port encoding is set
+to @code{UTF-8}, @code{UTF-16}, or @code{UTF-32}. In brief, Guile
+automatically writes a BOM at the start of a UTF-16 or UTF-32 stream,
+and automatically consumes one from the start of a UTF-8, UTF-16, or
+UTF-32 stream.
+
+As specified in the Unicode Standard, a BOM is only handled specially at
+the start of a stream, and only if the port encoding is set to
address@hidden, @code{UTF-16} or @code{UTF-32}. If the port encoding is
+set to @code{UTF-16BE}, @code{UTF-16LE}, @code{UTF-32BE}, or
address@hidden, then BOMs are @emph{not} handled specially, and none of
+the special handling described in this section applies.
+
address@hidden @bullet
address@hidden
+To ensure that Guile will properly detect the byte order of a UTF-16 or
+UTF-32 stream, you must perform a textual read before any writes, seeks,
+or binary I/O. Guile will not attempt to read a BOM unless a read is
+explicitly requested at the start of the stream.
+
address@hidden
+If a textual write is performed before the first read, then an arbitrary
+byte order will be chosen. Currently, big endian is the default on all
+platforms, but that may change in the future. If you wish to explicitly
+control the byte order of an output stream, set the port encoding to
address@hidden, @code{UTF-16LE}, @code{UTF-32BE}, or @code{UTF-32LE},
+and explicitly write a BOM (@code{#\xFEFF}) if desired.
+
address@hidden
+If @code{set-port-encoding!} is called in the middle of a stream, Guile
+treats this as a new logical ``start of stream'' for purposes of BOM
+handling, and will forget about any BOMs that had previously been seen.
+Therefore, it may choose a different byte order than had been used
+previously. This is intended to support multiple logical text streams
+embedded within a larger binary stream.
+
address@hidden
+Binary I/O operations are not guaranteed to update Guile's notion of
+whether the port is at the ``start of the stream'', nor are they
+guaranteed to produce or consume BOMs.
+
address@hidden
+For ports that support seeking (e.g. normal files), the input and output
+streams are considered linked: if the user reads first, then a BOM will
+be consumed (if appropriate), but later writes will @emph{not} produce a
+BOM. Similarly, if the user writes first, then later reads will
address@hidden consume a BOM.
+
address@hidden
+For ports that do not support seeking (e.g. pipes, sockets, and
+terminals), the input and output streams are considered
address@hidden for purposes of BOM handling: the first read will
+consume a BOM (if appropriate), and the first write will @emph{also}
+produce a BOM (if appropriate). However, the input and output streams
+will always use the same byte order.
+
address@hidden
+Seeks to the beginning of a file will set the ``start of stream'' flags.
+Therefore, a subsequent textual read or write will consume or produce a
+BOM. However, unlike @code{set-port-encoding!}, if a byte order had
+already been chosen for the port, it will remain in effect after a seek,
+and cannot be changed by the presence of a BOM. Seeks anywhere other
+than the beginning of a file clear the ``start of stream'' flags.
address@hidden itemize
+
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 347d025..09ffee6 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.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,
2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009,
2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -215,7 +215,7 @@ including ellipsizing and tail patterns.
((_ #((var val) ...) exp exp* ...)
(let ((var val) ...) exp exp* ...))))
(letv #((foo 'bar)) foo)
address@hidden foo
address@hidden bar
@end example
Literals are used to match specific datums in an expression, like the use of
@@ -520,7 +520,8 @@ is impossible with @code{syntax-rules}, given the datum
matching forms. But with
@code{syntax-case} it is easy:
@deffn {Scheme Procedure} identifier? syntax-object
-Returns @code{#t} iff @var{syntax-object} is an identifier.
+Returns @code{#t} if @var{syntax-object} is an identifier, or @code{#f}
+otherwise.
@end deffn
@example
@@ -690,13 +691,13 @@ macros can use to compare, generate, and query objects of
this data
type.
@deffn {Scheme Procedure} bound-identifier=? a b
-Return @code{#t} iff the syntax objects @var{a} and @var{b} refer to the
-same lexically-bound identifier.
+Return @code{#t} if the syntax objects @var{a} and @var{b} refer to the
+same lexically-bound identifier, or @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} free-identifier=? a b
-Return @code{#t} iff the syntax objects @var{a} and @var{b} refer to the
-same free identifier.
+Return @code{#t} if the syntax objects @var{a} and @var{b} refer to the
+same free identifier, or @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} generate-temporaries ls
@@ -725,7 +726,7 @@ Return the name of the module whose source contains the
identifier
@var{id}.
@end deffn
address@hidden {Scheme Procedure} syntax-local-binding id
address@hidden {Scheme Procedure} syntax-local-binding id
[#:resolve-syntax-parameters?=#t]
Resolve the identifer @var{id}, a syntax object, within the current
lexical environment, and return two values, the binding type and a
binding value. The binding type is a symbol, which may be one of the
@@ -738,6 +739,12 @@ of @code{eq?}) identifying this binding.
@item macro
A syntax transformer, either local or global. The value is the
transformer procedure.
address@hidden syntax-parameter
+A syntax parameter (@pxref{Syntax Parameters}). By default,
address@hidden will resolve syntax parameters, so that this
+value will not be returned. Pass @code{#:resolve-syntax-parameters? #f}
+to indicate that you are interested in syntax parameters. The value is
+the default transformer procedure, as in @code{macro}.
@item pattern-variable
A pattern variable, bound via syntax-case. The value is an opaque
object, internal to the expander.
@@ -935,7 +942,7 @@ left-hand side of a @code{set!} expression, as in the
following:
(set! foo @var{val})
;; expands via
(foo-transformer #'(set! foo @var{val}))
-;; iff foo-transformer is a "variable transformer"
+;; if foo-transformer is a "variable transformer"
@end example
As the example notes, the transformer procedure must be explicitly
@@ -1125,7 +1132,8 @@ for syntax-case.
@deffn {Scheme Procedure} macro? obj
@deffnx {C Function} scm_macro_p (obj)
-Return @code{#t} iff @var{obj} is a syntax transformer.
+Return @code{#t} if @var{obj} is a syntax transformer, or @code{#f}
+otherwise.
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
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index 17ab462..286a37d 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, 2009, 2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2008, 2009, 2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -50,7 +50,6 @@ be used for interacting with the module system.
* Variables:: First-class variables.
* Module System Reflection:: First-class modules.
* Accessing Modules from C:: How to work with modules with C code.
-* Included Guile Modules:: Which modules come with Guile?
* provide and require:: The SLIB feature mechanism.
* Environments:: R5RS top-level environments.
@end menu
@@ -111,8 +110,7 @@ interface is the one accessed. For example:
Here, the interface specification is @code{(ice-9 popen)}, and the
result is that the current module now has access to @code{open-pipe},
address@hidden, @code{open-input-pipe}, and so on (@pxref{Included
-Guile Modules}).
address@hidden, @code{open-input-pipe}, and so on (@pxref{Pipes}).
Note in the previous example that if the current module had already
defined @code{open-pipe}, that definition would be overwritten by the
@@ -759,8 +757,8 @@ Return a variable initialized to value @var{init}.
@deffn {Scheme Procedure} variable-bound? var
@deffnx {C Function} scm_variable_bound_p (var)
-Return @code{#t} iff @var{var} is bound to a value.
-Throws an error if @var{var} is not a variable object.
+Return @code{#t} if @var{var} is bound to a value, or @code{#f}
+otherwise. Throws an error if @var{var} is not a variable object.
@end deffn
@deffn {Scheme Procedure} variable-ref var
@@ -784,8 +782,8 @@ Unset the value of the variable @var{var}, leaving
@var{var} unbound.
@deffn {Scheme Procedure} variable? obj
@deffnx {C Function} scm_variable_p (obj)
-Return @code{#t} iff @var{obj} is a variable object, else
-return @code{#f}.
+Return @code{#t} if @var{obj} is a variable object, else return
address@hidden
@end deffn
@@ -827,7 +825,8 @@ the time @var{thunk}'s dynamic extent was last entered) is
restored. If
saved, and the previously saved inner module is set current again.
@end deffn
address@hidden {Scheme Procedure} resolve-module name [autoload=#t]
[version=#f] [#:ensure=#t]
address@hidden {Scheme Procedure} resolve-module name [autoload=#t]
[version=#f] @
+ [#:ensure=#t]
@deffnx {C Function} scm_resolve_module (name)
Find the module named @var{name} and return it. When it has not already
been defined and @var{autoload} is true, try to auto-load it. When it
@@ -837,7 +836,9 @@ that the resulting module is compatible with the given
version reference
(@pxref{R6RS Version References}). The name is a list of symbols.
@end deffn
address@hidden {Scheme Procedure} resolve-interface name [#:select=#f]
[#:hide='()] [#:select=()] [#:prefix=#f] [#:renamer] [#:version=#f]
address@hidden {Scheme Procedure} resolve-interface name [#:select=#f] @
+ [#:hide='()] [#:prefix=#f] @
+ [#:renamer=#f] [#:version=#f]
Find the module named @var{name} as with @code{resolve-module} and
return its interface. The interface of a module is also a module
object, but it contains only the exported bindings.
@@ -942,14 +943,18 @@ the @var{name} is not bound in the module, signals an
error. Returns a
variable, always.
@example
-SCM my_eval_string (SCM str)
address@hidden
- static SCM eval_string_var = SCM_BOOL_F;
+static SCM eval_string_var;
- if (scm_is_false (eval_string_var))
- eval_string_var =
- scm_c_public_lookup ("ice-9 eval-string", "eval-string");
+/* NOTE: It is important that the call to 'my_init'
+ happens-before all calls to 'my_eval_string'. */
+void my_init (void)
address@hidden
+ eval_string_var = scm_c_public_lookup ("ice-9 eval-string",
+ "eval-string");
address@hidden
+SCM my_eval_string (SCM str)
address@hidden
return scm_call_1 (scm_variable_ref (eval_string_var), str);
@}
@end example
@@ -1055,124 +1060,6 @@ of the current module. The list of names is terminated
by
@end deftypefn
address@hidden Included Guile Modules
address@hidden Included Guile Modules
-
-Some modules are included in the Guile distribution; here are references
-to the entries in this manual which describe them in more detail:
-
address@hidden @strong
address@hidden boot-9
-boot-9 is Guile's initialization module, and it is always loaded when
-Guile starts up.
-
address@hidden (ice-9 expect)
-Actions based on matching input from a port (@pxref{Expect}).
-
address@hidden (ice-9 format)
-Formatted output in the style of Common Lisp (@pxref{Formatted
-Output}).
-
address@hidden (ice-9 ftw)
-File tree walker (@pxref{File Tree Walk}).
-
address@hidden (ice-9 getopt-long)
-Command line option processing (@pxref{getopt-long}).
-
address@hidden (ice-9 history)
-Refer to previous interactive expressions (@pxref{Value History}).
-
address@hidden (ice-9 popen)
-Pipes to and from child processes (@pxref{Pipes}).
-
address@hidden (ice-9 pretty-print)
-Nicely formatted output of Scheme expressions and objects
-(@pxref{Pretty Printing}).
-
address@hidden (ice-9 q)
-First-in first-out queues (@pxref{Queues}).
-
address@hidden (ice-9 rdelim)
-Line- and character-delimited input (@pxref{Line/Delimited}).
-
address@hidden (ice-9 readline)
address@hidden interactive command line editing (@pxref{Readline
-Support}).
-
address@hidden (ice-9 receive)
-Multiple-value handling with @code{receive} (@pxref{Multiple Values}).
-
address@hidden (ice-9 regex)
-Regular expression matching (@pxref{Regular Expressions}).
-
address@hidden (ice-9 rw)
-Block string input/output (@pxref{Block Reading and Writing}).
-
address@hidden (ice-9 streams)
-Sequence of values calculated on-demand (@pxref{Streams}).
-
address@hidden (ice-9 syncase)
-R5RS @code{syntax-rules} macro system (@pxref{Syntax Rules}).
-
address@hidden (ice-9 threads)
-Guile's support for multi threaded execution (@pxref{Scheduling}).
-
address@hidden (ice-9 documentation)
-Online documentation (REFFIXME).
-
address@hidden (srfi srfi-1)
-A library providing a lot of useful list and pair processing
-procedures (@pxref{SRFI-1}).
-
address@hidden (srfi srfi-2)
-Support for @code{and-let*} (@pxref{SRFI-2}).
-
address@hidden (srfi srfi-4)
-Support for homogeneous numeric vectors (@pxref{SRFI-4}).
-
address@hidden (srfi srfi-6)
-Support for some additional string port procedures (@pxref{SRFI-6}).
-
address@hidden (srfi srfi-8)
-Multiple-value handling with @code{receive} (@pxref{SRFI-8}).
-
address@hidden (srfi srfi-9)
-Record definition with @code{define-record-type} (@pxref{SRFI-9}).
-
address@hidden (srfi srfi-10)
-Read hash extension @code{#,()} (@pxref{SRFI-10}).
-
address@hidden (srfi srfi-11)
-Multiple-value handling with @code{let-values} and @code{let*-values}
-(@pxref{SRFI-11}).
-
address@hidden (srfi srfi-13)
-String library (@pxref{SRFI-13}).
-
address@hidden (srfi srfi-14)
-Character-set library (@pxref{SRFI-14}).
-
address@hidden (srfi srfi-16)
address@hidden procedures of variable arity (@pxref{SRFI-16}).
-
address@hidden (srfi srfi-17)
-Getter-with-setter support (@pxref{SRFI-17}).
-
address@hidden (srfi srfi-19)
-Time/Date library (@pxref{SRFI-19}).
-
address@hidden (srfi srfi-26)
-Convenient syntax for partial application (@pxref{SRFI-26})
-
address@hidden (srfi srfi-31)
address@hidden convenient recursive expressions (@pxref{SRFI-31})
-
address@hidden (ice-9 slib)
-This module contains hooks for using Aubrey Jaffer's portable Scheme
-library SLIB from Guile (@pxref{SLIB}).
address@hidden table
-
-
@node provide and require
@subsection provide and require
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index 1734318..8fa4f98 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -1,6 +1,7 @@
@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, 2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006,
address@hidden 2008, 2009, 2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -96,6 +97,13 @@ your site should be installed. On Unix-like systems, this
is usually
@file{/usr/local/share/guile/site} or @file{/usr/share/guile/site}.
@end deffn
address@hidden {Scheme Procedure} %site-ccache-dir
address@hidden {C Function} scm_sys_site_ccache_dir ()
+Return the directory where users should install compiled @code{.go}
+files for use with this version of Guile. Might look something like
address@hidden/usr/lib/guile/@value{EFFECTIVE-VERSION}/site-ccache}.
address@hidden deffn
+
@defvar %guile-build-info
Alist of information collected during the building of a particular
Guile. Entries can be grouped into one of several categories:
@@ -274,6 +282,11 @@ Databases}).
Indicates support for POSIX functions: @code{pipe}, @code{getgroups},
@code{kill}, @code{execl} and so on (@pxref{POSIX}).
address@hidden fork
+Indicates support for the POSIX @code{fork} function (@pxref{Processes,
address@hidden). This is a prerequisite for the @code{(ice-9
+popen)} module (@pxref{Pipes}).
+
@item random
Indicates availability of random number generation functions:
@code{random}, @code{copy-random-state}, @code{random-uniform} and so on
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index bef3386..e11479d 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -157,7 +157,8 @@ appropriate module first, though:
@deffn {Scheme Procedure} program? obj
@deffnx {C Function} scm_program_p (obj)
-Returns @code{#t} iff @var{obj} is a compiled procedure.
+Returns @code{#t} if @var{obj} is a compiled procedure, or @code{#f}
+otherwise.
@end deffn
@deffn {Scheme Procedure} program-objcode program
@@ -333,7 +334,11 @@ cheaply, without allocating a rest list.
@code{lambda*} is like @code{lambda}, except with some extensions to
allow optional and keyword arguments.
address@hidden {library syntax} lambda* (address@hidden @* [#:optional
address@hidden @* [#:key address@hidden [#:allow-other-keys]] @* [#:rest var |
. var]) @* body
address@hidden {library syntax} lambda* (address@hidden @* @
+ [#:optional address@hidden @* @
+ [#:key address@hidden [#:allow-other-keys]] @* @
+ [#:rest var | . var]) @* @
+ body1 body2 @dots{}
@sp 1
Create a procedure which takes optional and/or keyword arguments
specified with @code{#:optional} and @code{#:key}. For example,
@@ -570,7 +575,8 @@ with @code{lambda} (@pxref{Lambda}).
@example
@group
<case-lambda>
- --> (case-lambda <case-lambda-clause>)
+ --> (case-lambda <case-lambda-clause>*)
+ --> (case-lambda <docstring> <case-lambda-clause>*)
<case-lambda-clause>
--> (<formals> <definition-or-command>*)
<formals>
@@ -585,6 +591,7 @@ Rest lists can be useful with @code{case-lambda}:
@lisp
(define plus
(case-lambda
+ "Return the sum of all arguments."
(() 0)
((a) a)
((a b) (+ a b))
@@ -712,6 +719,11 @@ compatible arity.
Return X.
@end deffn
address@hidden {Scheme Procedure} and=> value proc
+When @var{value} is @code{#f}, return @code{#f}. Otherwise, return
address@hidden(@var{proc} @var{value})}.
address@hidden deffn
+
@node Procedure Properties
@subsection Procedure Properties and Meta-information
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index 749583a..b230821 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -247,7 +247,7 @@ Once @var{body} or @var{handler} returns, the return value
is made the
@deffn {Scheme Procedure} thread? obj
@deffnx {C Function} scm_thread_p (obj)
-Return @code{#t} iff @var{obj} is a thread; otherwise, return
+Return @code{#t} ff @var{obj} is a thread; otherwise, return
@code{#f}.
@end deffn
@@ -267,7 +267,7 @@ specified; @code{#f} is returned otherwise).
@deffn {Scheme Procedure} thread-exited? thread
@deffnx {C Function} scm_thread_exited_p (thread)
-Return @code{#t} iff @var{thread} has exited.
+Return @code{#t} if @var{thread} has exited, or @code{#f} otherwise.
@end deffn
@c begin (texi-doc-string "guile" "yield")
@@ -376,7 +376,7 @@ The returned mutex will be recursive.
@deffn {Scheme Procedure} mutex? obj
@deffnx {C Function} scm_mutex_p (obj)
-Return @code{#t} iff @var{obj} is a mutex; otherwise, return
+Return @code{#t} if @var{obj} is a mutex; otherwise, return
@code{#f}.
@end deffn
@@ -481,7 +481,7 @@ Return a new condition variable.
@deffn {Scheme Procedure} condition-variable? obj
@deffnx {C Function} scm_condition_variable_p (obj)
-Return @code{#t} iff @var{obj} is a condition variable; otherwise,
+Return @code{#t} if @var{obj} is a condition variable; otherwise,
return @code{#f}.
@end deffn
@@ -702,7 +702,7 @@ implicitly bound to some definite value).
@deffn {Scheme Procedure} fluid? obj
@deffnx {C Function} scm_fluid_p (obj)
-Return @code{#t} iff @var{obj} is a fluid; otherwise, return
+Return @code{#t} if @var{obj} is a fluid; otherwise, return
@code{#f}.
@end deffn
@@ -726,7 +726,7 @@ Disassociate the given fluid from any value, making it
unbound.
@deffn {Scheme Procedure} fluid-bound? fluid
@deffnx {C Function} scm_fluid_bound_p (fluid)
-Returns @code{#t} iff the given fluid is bound to a value, otherwise
+Returns @code{#t} if the given fluid is bound to a value, otherwise
@code{#f}.
@end deffn
@@ -1037,6 +1037,13 @@ future has completed. This suspend/resume is achieved
by capturing the
calling future's continuation, and later reinstating it (@pxref{Prompts,
delimited continuations}).
+Note that @code{par-map} above is not tail-recursive. This could lead
+to stack overflows when @var{lst} is large compared to
address@hidden(current-processor-count)}. To address that, @code{touch} uses
+the suspend mechanism described above to limit the number of nested
+futures executing on the same stack. Thus, the above code should never
+run into stack overflows.
+
@deffn {Scheme Syntax} future exp
Return a future for expression @var{exp}. This is equivalent to:
diff --git a/doc/ref/api-smobs.texi b/doc/ref/api-smobs.texi
index cb2034c..345bf7c 100644
--- a/doc/ref/api-smobs.texi
+++ b/doc/ref/api-smobs.texi
@@ -124,9 +124,9 @@ Else, signal an error.
@end deftypefn
@deftypefn {C Macro} int SCM_SMOB_PREDICATE (scm_t_bits tag, SCM exp)
-Return true iff @var{exp} is a smob instance of the type indicated by
address@hidden The expression @var{exp} can be evaluated more than once,
-so it shouldn't contain any side effects.
+Return true if @var{exp} is a smob instance of the type indicated by
address@hidden, or false otherwise. The expression @var{exp} can be
+evaluated more than once, so it shouldn't contain any side effects.
@end deftypefn
@deftypefn {C Function} SCM scm_new_smob (scm_t_bits tag, void *data)
diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi
index 1ffb3a9..4e478f4 100644
--- a/doc/ref/api-undocumented.texi
+++ b/doc/ref/api-undocumented.texi
@@ -188,8 +188,8 @@ would modify regular hash tables. (@pxref{Hash Tables})
@end deffn
@deffn {Scheme Procedure} include-deprecated-features
-Return @code{#t} iff deprecated features should be included
-in public interfaces.
+Return @code{#t} if deprecated features should be included in public
+interfaces, or @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} issue-deprecation-warning . msgs
@@ -202,7 +202,7 @@ they are printed in turn, each one followed by a newline.
@deffn {Scheme Procedure} valid-object-procedure? proc
@deffnx {C Function} scm_valid_object_procedure_p (proc)
-Return @code{#t} iff @var{proc} is a procedure that can be used with
@code{set-object-procedure}. It is always valid to use a closure constructed
by @code{lambda}.
+Return @code{#t} ff @var{proc} is a procedure that can be used with
@code{set-object-procedure}. It is always valid to use a closure constructed
by @code{lambda}.
@end deffn
@deffn {Scheme Procedure} %get-pre-modules-obarray
diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi
index 17694ec..76c50b2 100644
--- a/doc/ref/api-utility.texi
+++ b/doc/ref/api-utility.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011,
2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011,
2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -308,10 +308,10 @@ input.
@deffn {Scheme Procedure} sorted? items less
@deffnx {C Function} scm_sorted_p (items, less)
-Return @code{#t} iff @var{items} is a list or vector such that,
+Return @code{#t} if @var{items} is a list or vector such that,
for each element @var{x} and the next element @var{y} of
@var{items}, @code{(@var{less} @var{y} @var{x})} returns
address@hidden
address@hidden Otherwise return @code{#f}.
@end deffn
@deffn {Scheme Procedure} sort items less
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index fcb4a0e..0615ef7 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -53,9 +53,11 @@ Languages are registered in the module, @code{(system base
language)}:
They are registered with the @code{define-language} form.
@deffn {Scheme Syntax} define-language @
-name title reader printer @
-[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] @
-[joiner=#f] [make-default-environment=make-fresh-user-module]
+ [#:name] [#:title] [#:reader] [#:printer] @
+ [#:parser=#f] [#:compilers='()] @
+ [#:decompilers='()] [#:evaluator=#f] @
+ [#:joiner=#f] [#:for-humans?=#t] @
+ [#:make-default-environment=make-fresh-user-module]
Define a language.
This syntax defines a @code{#<language>} object, bound to @var{name}
@@ -589,9 +591,9 @@ variables. @var{vars} is a list of @code{(@var{name}
@var{type}
program's metadata and do not form part of a program's code path.
@end deftp
@deftp {Scheme Variable} <glil-mv-bind> vars rest
-A multiple-value binding of the values on the stack to @var{vars}. Iff
address@hidden is true, the last element of @var{vars} will be treated as
-a rest argument.
+A multiple-value binding of the values on the stack to @var{vars}. If
address@hidden is true, the last element of @var{vars} will be treated as a
+rest argument.
In addition to pushing a binding annotation on the stack, like
@code{<glil-bind>}, an expression is emitted at compilation time to
@@ -798,7 +800,7 @@ objcode)} module.
@deffn {Scheme Procedure} objcode? obj
@deffnx {C Function} scm_objcode_p (obj)
-Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise.
+Returns @code{#f} if @var{obj} is object code, @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} bytecode->objcode bytecode [endianness]
diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi
index 5a9a3f7..207c6f3 100644
--- a/doc/ref/guile-invoke.texi
+++ b/doc/ref/guile-invoke.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,
2010, 2011
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2010, 2011, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -71,6 +71,9 @@ before any directories in the @env{GUILE_LOAD_PATH}
environment
variable. Paths added here are @emph{not} in effect during execution of
the user's @file{.guile} file.
address@hidden -C @var{directory}
+Like @option{-L}, but adjusts the load path for @emph{compiled} files.
+
@item -x @var{extension}
Add @var{extension} to the front of Guile's load extension list
(@pxref{Load Paths, @code{%load-extensions}}). The specified extensions
@@ -205,6 +208,35 @@ Treat the auto-compilation cache as invalid, forcing
recompilation.
@item --no-auto-compile
Disable automatic source file compilation.
address@hidden
+
address@hidden address@hidden
+For the remainder of the command line arguments, assume that files
+mentioned with @code{-l} and expressions passed with @code{-c} are
+written in @var{lang}. @var{lang} must be the name of one of the
+languages supported by the compiler (@pxref{Compiler Tower}). When run
+interactively, set the REPL's language to @var{lang} (@pxref{Using Guile
+Interactively}).
+
+The default language is @code{scheme}; other interesting values include
address@hidden (for Emacs Lisp), and @code{ecmascript}.
+
+The example below shows the evaluation of expressions in Scheme, Emacs
+Lisp, and ECMAScript:
+
address@hidden
+guile -c "(apply + '(1 2))"
+guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)"
+guile --language=ecmascript -c '(function (x) @{ return x * x; @})(2);'
address@hidden example
+
+To load a file written in Scheme and one written in Emacs Lisp, and then
+start a Scheme REPL, type:
+
address@hidden
+guile -l foo.scm --language=elisp -l foo.el --language=scheme
address@hidden example
+
@vnew{2.0}
@item address@hidden, }--help
@@ -291,6 +323,32 @@ This variable names the file that holds the Guile REPL
command history.
You can specify a different history file by setting this environment
variable. By default, the history file is @file{$HOME/.guile_history}.
address@hidden GUILE_INSTALL_LOCALE
address@hidden GUILE_INSTALL_LOCALE
+This is a flag that can be used to tell Guile whether or not to install
+the current locale at startup, via a call to @code{(setlocale LC_ALL
+"")}. @xref{Locales}, for more information on locales.
+
+You may explicitly indicate that you do not want to install
+the locale by setting @env{GUILE_INSTALL_LOCALE} to @code{0}, or
+explicitly enable it by setting the variable to @code{1}.
+
+Usually, installing the current locale is the right thing to do. It
+allows Guile to correctly parse and print strings with non-ASCII
+characters. Therefore, this option is on by default.
+
address@hidden GUILE_STACK_SIZE
address@hidden GUILE_STACK_SIZE
+Guile currently has a limited stack size for Scheme computations.
+Attempting to call too many nested functions will signal an error. This
+is good to detect infinite recursion, but sometimes the limit is reached
+for normal computations. This environment variable, if set to a
+positive integer, specifies the number of Scheme value slots to allocate
+for the stack.
+
+In the future we will implement stacks that can grow and shrink, but for
+now this hack will have to do.
+
@item GUILE_LOAD_COMPILED_PATH
@vindex GUILE_LOAD_COMPILED_PATH
This variable may be used to augment the path that is searched for
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 262cd64..c3170ce 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -374,7 +374,7 @@ available through both Scheme and C interfaces.
* Curried Definitions:: Extended @code{define} syntax.
* Statprof:: An easy-to-use statistical profiler.
* SXML:: Parsing, transforming, and serializing XML.
-* Texinfo:: Munging documents written in Texinfo.
+* Texinfo Processing:: Munging documents written in Texinfo.
@end menu
@include slib.texi
diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi
index e94948f..28da4ac 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,
2010, 2011
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2010, 2011, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -288,21 +288,6 @@ classes, multiple inheritance and generic functions.
@node Typographical Conventions
@section Typographical Conventions
-We use some conventions in this manual.
-
address@hidden @bullet
-
address@hidden
-For some procedures, notably type predicates, we use ``iff'' to mean
-``if and only if''. The construct is usually something like: `Return
address@hidden iff @var{condition}', where @var{val} is usually
address@hidden'' or address@hidden''. This typically means that
address@hidden is returned if @var{condition} holds, and that @samp{#f} is
-returned otherwise. To clarify: @var{val} will @strong{only} be
-returned when @var{condition} is true.
address@hidden iff
-
address@hidden
In examples and procedure descriptions and all other places where the
evaluation of Scheme expression is shown, we use some notation for
denoting the output and evaluation results of expressions.
@@ -328,10 +313,6 @@ As you can see, this code prints @samp{1} (denoted by
@address@hidden), and returns @code{hooray} (denoted by
@address@hidden).
address@hidden Add other conventions here.
-
address@hidden itemize
-
@c Local Variables:
@c TeX-master: "guile.texi"
diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index cf1e0e4..c1e65d7 100644
--- a/doc/ref/misc-modules.texi
+++ b/doc/ref/misc-modules.texi
@@ -1573,6 +1573,9 @@ modifies the queue @var{list} then it must either maintain
@section Streams
@cindex streams
+This section documents Guile's legacy stream module. For a more
+complete and portable stream library, @pxref{SRFI-41}.
+
A stream represents a sequence of values, each of which is calculated
only when required. This allows large or even infinite sequences to
be represented and manipulated with familiar operations like ``car'',
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index a019f4e..40c20e7 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -803,6 +803,36 @@ Copy the file specified by @var{oldfile} to @var{newfile}.
The return value is unspecified.
@end deffn
address@hidden {Scheme Procedure} sendfile out in count [offset]
address@hidden {C Function} scm_sendfile (out, in, count, offset)
+Send @var{count} bytes from @var{in} to @var{out}, both of which
+must be either open file ports or file descriptors. When
address@hidden is omitted, start reading from @var{in}'s current
+position; otherwise, start reading at @var{offset}. Return
+the number of bytes actually sent.
+
+When @var{in} is a port, it is often preferable to specify @var{offset},
+because @var{in}'s offset as a port may be different from the offset of
+its underlying file descriptor.
+
+On systems that support it, such as GNU/Linux, this procedure uses the
address@hidden libc function, which usually corresponds to a system
+call. This is faster than doing a series of @code{read} and
address@hidden system calls. A typical application is to send a file over
+a socket.
+
+In some cases, the @code{sendfile} libc function may return
address@hidden or @code{ENOSYS}. In that case, Guile's @code{sendfile}
+procedure automatically falls back to doing a series of @code{read} and
address@hidden calls.
+
+In other cases, the libc function may send fewer bytes than
address@hidden instance because @var{out} is a slow or limited
+device, such as a pipe. When that happens, Guile's @code{sendfile}
+automatically retries until exactly @var{count} bytes were sent or an
+error occurs.
address@hidden deffn
+
@findex rename
@deffn {Scheme Procedure} rename-file oldname newname
@deffnx {C Function} scm_rename (oldname, newname)
@@ -986,6 +1016,43 @@ Return @code{#t} if the file named @var{filename} exists,
@code{#f} if
not.
@end deffn
address@hidden file name separator
address@hidden absolute file name
+
+Many operating systems, such as GNU, use @code{/} (forward slash) to
+separate the components of a file name; any file name starting with
address@hidden/} is considered an @dfn{absolute file name}. These conventions
+are specified by the POSIX Base Definitions, which refer to conforming
+file names as ``pathnames''. Some operating systems use a different
+convention; in particular, Windows uses @code{\} (backslash) as the file
+name separator, and also has the notion of @dfn{volume names} like
address@hidden:\} for absolute file names. The following procedures and
+variables provide support for portable file name manipulations.
+
address@hidden {Scheme Procedure} system-file-name-convention
+Return either @code{posix} or @code{windows}, depending on
+what kind of system this Guile is running on.
address@hidden deffn
+
address@hidden {Scheme Procedure} file-name-separator? c
+Return true if character @var{c} is a file name separator on the host
+platform.
address@hidden deffn
+
address@hidden {Scheme Procedure} absolute-file-name? file-name
+Return true if @var{file-name} denotes an absolute file name on the host
+platform.
address@hidden deffn
+
address@hidden {Scheme Variable} file-name-separator-string
+The preferred file name separator.
+
+Note that on MinGW builds for Windows, both @code{/} and @code{\} are
+valid separators. Thus, programs should not assume that
address@hidden is the @emph{only} file name
+separator---e.g., when extracting the components of a file name.
address@hidden defvr
+
@node User Information
@subsection User Information
@@ -1718,6 +1785,18 @@ interpretation is not required.
Example: (system* "echo" "foo" "bar")
@end deffn
address@hidden {Scheme Procedure} quit [status]
address@hidden {Scheme Procedure} exit [status]
+Terminate the current process with proper unwinding of the Scheme stack.
+The exit status zero if @var{status} is not supplied. If @var{status}
+is supplied, and it is an integer, that integer is used as the exit
+status. If @var{status} is @code{#t} or @code{#f}, the exit status is 0
+or 1, respectively.
+
+The procedure @code{exit} is an alias of @code{quit}. They have the
+same functionality.
address@hidden deffn
+
@deffn {Scheme Procedure} primitive-exit [status]
@deffnx {Scheme Procedure} primitive-_exit [status]
@deffnx {C Function} scm_primitive_exit (status)
@@ -2154,7 +2233,8 @@ controlling terminal. The return value is unspecified.
The following procedures are similar to the @code{popen} and
@code{pclose} system routines. The code is in a separate ``popen''
-module:
address@hidden module is only available on systems where the
address@hidden feature is provided (@pxref{Common Feature Symbols}).}:
@lisp
(use-modules (ice-9 popen))
@@ -2528,8 +2608,11 @@ code should be prepared to handle it when it is defined.
@var{hint_socktype} was not recognized.
@item EAI_SYSTEM
-A system error occurred; the error code can be found in
address@hidden
+A system error occurred. In C, the error code can be found in
address@hidden; this value is not accessible from Scheme, but in
+practice it provides little information about the actual error
+cause.
address@hidden See <http://bugs.gnu.org/13958>.
@end table
Users are encouraged to read the
@@ -3052,6 +3135,7 @@ Manual}, or @command{man 7 socket}.
@defvarx SO_OOBINLINE
@defvarx SO_NO_CHECK
@defvarx SO_PRIORITY
address@hidden SO_REUSEPORT
The @var{value} taken or returned is an integer.
@end defvar
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index 2028ada..9c5984b 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010, 2011, 2012
address@hidden Copyright (C) 2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -273,10 +273,8 @@ grouped below by the existing manual sections to which
they correspond.
@end deffn
@deffn {Scheme Syntax} define-syntax keyword expression
address@hidden {Scheme Syntax} let-syntax ((keyword transformer) @dots{})
- exp1 exp2 @dots{}
address@hidden {Scheme Syntax} letrec-syntax ((keyword transformer) @dots{})
- exp1 exp2 @dots{}
address@hidden {Scheme Syntax} let-syntax ((keyword transformer) @dots{}) exp1
exp2 @dots{}
address@hidden {Scheme Syntax} letrec-syntax ((keyword transformer) @dots{})
exp1 exp2 @dots{}
@xref{Defining Macros}, for documentation.
@end deffn
@@ -828,11 +826,11 @@ This form is identical to the one provided by Guile's
core library.
@node R6RS Records
@subsubsection R6RS Records
-The manual sections below describe Guile's implementation of R6RS
+The manual sections below describe Guile's implementation of R6RS
records, which provide support for user-defined data types. The R6RS
records API provides a superset of the features provided by Guile's
``native'' records, as well as those of the SRFI-9 records API;
address@hidden, and @ref{SRFI-9}, for a description of those
address@hidden, and @ref{SRFI-9 Records}, for a description of those
interfaces.
As with SRFI-9 and Guile's native records, R6RS records are constructed
@@ -1523,9 +1521,9 @@ This procedure is identical to the one provided by
Guile's core library.
@xref{Runtime Environment}, for documentation.
@end deffn
address@hidden {Scheme Procedure} exit
address@hidden {Scheme Procedure} exit obj
-This procedure is identical to the one provided by Guile's core library.
address@hidden {Scheme Procedure} exit [status]
+This procedure is identical to the one provided by Guile's core
+library. @xref{Processes}, for documentation.
@end deffn
@node rnrs arithmetic fixnums
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index e0f91af..4422c18 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -125,7 +125,7 @@ The programmatic interface to value history is in a module:
@end lisp
@deffn {Scheme Procedure} value-history-enabled?
-Return true iff value history is enabled.
+Return true if value history is enabled, or false otherwise.
@end deffn
@deffn {Scheme Procedure} enable-value-history!
@@ -430,8 +430,11 @@ Garbage collection.
Display statistics.
@end deffn
address@hidden {REPL Command} option [key value]
-List/show/set options.
address@hidden {REPL Command} option [name] [exp]
+With no arguments, lists all options. With one argument, shows the
+current value of the @var{name} option. With two arguments, sets the
address@hidden option to the result of evaluating the Scheme expression
address@hidden
@end deffn
@deffn {REPL Command} quit
@@ -749,6 +752,7 @@ list}, or simply @code{guild}.
@cindex site path
@cindex load path
@findex %site-dir
address@hidden %site-ccache-dir
At some point, you will probably want to share your code with other
people. To do so effectively, it is important to follow a set of common
@@ -780,11 +784,11 @@ find them.
As with Scheme files, Guile searches a path to find compiled @code{.go}
files, the @code{%load-compiled-path}. By default, this path has two
entries: a path for Guile's files, and a path for site packages. You
-should install your @code{.go} files into the latter. Currently there
-is no procedure to get at this path, which is probably a bug. As in the
-previous example, if Guile @value{EFFECTIVE-VERSION} is installed on
-your system in @code{/usr/}, then the place to put compiled files for
-site packages will be
+should install your @code{.go} files into the latter directory, whose
+value is returned by invoking the @code{%site-ccache-dir} procedure. As
+in the previous example, if Guile @value{EFFECTIVE-VERSION} is installed
+on your system in @code{/usr/}, then @code{(%site-ccache-dir)} site
+packages will be
@code{/usr/lib/guile/@value{EFFECTIVE-VERSION}/site-ccache}.
Note that a @code{.go} file will only be loaded in preference to a
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index f92ddaf..f0158d5 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, 2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -45,6 +45,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-37:: args-fold program argument processor
* SRFI-38:: External Representation for Data With Shared
Structure
* SRFI-39:: Parameter objects
+* SRFI-41:: Streams.
* SRFI-42:: Eager comprehensions
* SRFI-45:: Primitives for expressing iterative lazy
algorithms
* SRFI-55:: Requiring Features.
@@ -76,13 +77,13 @@ check for the Scheme implementation, that is, before she
can know that
it is safe to use @code{use-modules} to load SRFI support modules. The
second reason is that some features defined in SRFIs had been
implemented in Guile before the developers started to add SRFI
-implementations as modules (for example SRFI-6 (@pxref{SRFI-6})). In
+implementations as modules (for example SRFI-13 (@pxref{SRFI-13})). In
the future, it is possible that SRFIs in the core library might be
factored out into separate modules, requiring explicit module loading
when they are needed. So you should be prepared to have to use
address@hidden someday in the future to access SRFI-6 bindings. If
address@hidden someday in the future to access SRFI-13 bindings. If
you want, you can do that already. We have included the module
address@hidden(srfi srfi-6)} in the distribution, which currently does nothing,
address@hidden(srfi srfi-13)} in the distribution, which currently does nothing,
but ensures that you can write future-safe code.
Generally, support for a specific SRFI is made available by using
@@ -145,9 +146,13 @@ guile-2 ;; starting from Guile 2.x
r5rs
srfi-0
srfi-4
-srfi-6
srfi-13
srfi-14
+srfi-23
+srfi-39
+srfi-55
+srfi-61
+srfi-105
@end example
Other SRFI feature symbols are defined once their code has been loaded
@@ -1770,8 +1775,8 @@ Like @code{scm_vector_writable_elements} (@pxref{Vector
Accessing from
C}), but returns a pointer to the elements of a uniform numeric vector.
@end 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.
+Unless you really need to the limited generality of these functions, it
+is best to use the type-specific functions, or the array accessors.
@node SRFI-4 and Bytevectors
@subsubsection SRFI-4 - Relation to bytevectors
@@ -1846,11 +1851,19 @@ uniform numeric vector, it is returned unchanged.
@cindex SRFI-6
SRFI-6 defines the procedures @code{open-input-string},
address@hidden and @code{get-output-string}. These
-procedures are included in the Guile core, so using this module does not
-make any difference at the moment. But it is possible that support for
-SRFI-6 will be factored out of the core library in the future, so using
-this module does not hurt, after all.
address@hidden and @code{get-output-string}.
+
+Note that although versions of these procedures are included in the
+Guile core, the core versions are not fully conformant with SRFI-6:
+attempts to read or write characters that are not supported by the
+current @code{%default-port-encoding} will fail.
+
+We therefore recommend that you import this module, which supports all
+characters:
+
address@hidden
+(use-modules (srfi srfi-6))
address@hidden example
@node SRFI-8
@subsection SRFI-8 - receive
@@ -3429,9 +3442,10 @@ Note that all fields of @var{type} and its supertypes
must be specified.
@end deffn
@deffn {Scheme Procedure} make-compound-condition condition1 condition2 @dots{}
-Return a new compound condition composed of @var{conditions}. The
-returned condition has the type of each condition of @var{conditions}
-(per @code{condition-has-type?}).
+Return a new compound condition composed of @var{condition1}
address@hidden @enddots{}. The returned condition has the type of
+each condition of condition1 condition2 @dots{} (per
address@hidden).
@end deffn
@deffn {Scheme Procedure} condition-has-type? c type
@@ -3775,6 +3789,712 @@ scope and the result from that @var{thunk} is the
return from
@code{with-parameters*}.
@end defun
address@hidden SRFI-41
address@hidden SRFI-41 - Streams
address@hidden SRFI-41
+
+This subsection is based on the
address@hidden://srfi.schemers.org/srfi-41/srfi-41.html, specification of
+SRFI-41} by Philip L.@: Bewig.
+
address@hidden The copyright notice and license text of the SRFI-41
specification is
address@hidden reproduced below:
+
address@hidden Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
+
address@hidden Permission is hereby granted, free of charge, to any person
obtaining a
address@hidden copy of this software and associated documentation files (the
address@hidden "Software"), to deal in the Software without restriction,
including
address@hidden without limitation the rights to use, copy, modify, merge,
publish,
address@hidden distribute, sublicense, and/or sell copies of the Software, and
to
address@hidden permit persons to whom the Software is furnished to do so,
subject to
address@hidden the following conditions:
+
address@hidden The above copyright notice and this permission notice shall be
included
address@hidden in all copies or substantial portions of the Software.
+
address@hidden THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS
address@hidden OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
address@hidden MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
address@hidden NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE
address@hidden LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
ACTION
address@hidden OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION
address@hidden WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
address@hidden
+This SRFI implements streams, sometimes called lazy lists, a sequential
+data structure containing elements computed only on demand. A stream is
+either null or is a pair with a stream in its cdr. Since elements of a
+stream are computed only when accessed, streams can be infinite. Once
+computed, the value of a stream element is cached in case it is needed
+again. SRFI-41 can be made available with:
+
address@hidden
+(use-modules (srfi srfi-41))
address@hidden example
+
address@hidden
+* SRFI-41 Stream Fundamentals::
+* SRFI-41 Stream Primitives::
+* SRFI-41 Stream Library::
address@hidden menu
+
address@hidden SRFI-41 Stream Fundamentals
address@hidden SRFI-41 Stream Fundamentals
+
+SRFI-41 Streams are based on two mutually-recursive abstract data types:
+An object of the @code{stream} abstract data type is a promise that,
+when forced, is either @code{stream-null} or is an object of type
address@hidden An object of the @code{stream-pair} abstract data
+type contains a @code{stream-car} and a @code{stream-cdr}, which must be
+a @code{stream}. The essential feature of streams is the systematic
+suspensions of the recursive promises between the two data types.
+
+The object stored in the @code{stream-car} of a @code{stream-pair} is a
+promise that is forced the first time the @code{stream-car} is accessed;
+its value is cached in case it is needed again. The object may have any
+type, and different stream elements may have different types. If the
address@hidden is never accessed, the object stored there is never
+evaluated. Likewise, the @code{stream-cdr} is a promise to return a
+stream, and is only forced on demand.
+
address@hidden SRFI-41 Stream Primitives
address@hidden SRFI-41 Stream Primitives
+
+This library provides eight operators: constructors for
address@hidden and @code{stream-pair}s, type predicates for streams
+and the two kinds of streams, accessors for both fields of a
address@hidden, and a lambda that creates procedures that return
+streams.
+
address@hidden {Scheme Variable} stream-null
+A promise that, when forced, is a single object, distinguishable from
+all other objects, that represents the null stream. @code{stream-null}
+is immutable and unique.
address@hidden defvr
+
address@hidden {Scheme Syntax} stream-cons object-expr stream-expr
+Creates a newly-allocated stream containing a promise that, when forced,
+is a @code{stream-pair} with @var{object-expr} in its @code{stream-car}
+and @var{stream-expr} in its @code{stream-cdr}. Neither
address@hidden nor @var{stream-expr} is evaluated when
address@hidden is called.
+
+Once created, a @code{stream-pair} is immutable; there is no
address@hidden or @code{stream-set-cdr!} that modifies an
+existing stream-pair. There is no dotted-pair or improper stream as
+with lists.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream? object
+Returns true if @var{object} is a stream, otherwise returns false. If
address@hidden is a stream, its promise will not be forced. If
address@hidden(stream? obj)} returns true, then one of @code{(stream-null? obj)}
+or @code{(stream-pair? obj)} will return true and the other will return
+false.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-null? object
+Returns true if @var{object} is the distinguished null stream, otherwise
+returns false. If @var{object} is a stream, its promise will be forced.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-pair? object
+Returns true if @var{object} is a @code{stream-pair} constructed by
address@hidden, otherwise returns false. If @var{object} is a
+stream, its promise will be forced.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-car stream
+Returns the object stored in the @code{stream-car} of @var{stream}. An
+error is signalled if the argument is not a @code{stream-pair}. This
+causes the @var{object-expr} passed to @code{stream-cons} to be
+evaluated if it had not yet been; the value is cached in case it is
+needed again.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-cdr stream
+Returns the stream stored in the @code{stream-cdr} of @var{stream}. An
+error is signalled if the argument is not a @code{stream-pair}.
address@hidden deffn
+
address@hidden {Scheme Syntax} stream-lambda formals body @dots{}
+Creates a procedure that returns a promise to evaluate the @var{body} of
+the procedure. The last @var{body} expression to be evaluated must
+yield a stream. As with normal @code{lambda}, @var{formals} may be a
+single variable name, in which case all the formal arguments are
+collected into a single list, or a list of variable names, which may be
+null if there are no arguments, proper if there are an exact number of
+arguments, or dotted if a fixed number of arguments is to be followed by
+zero or more arguments collected into a list. @var{Body} must contain
+at least one expression, and may contain internal definitions preceding
+any expressions to be evaluated.
address@hidden deffn
+
address@hidden
+(define strm123
+ (stream-cons 1
+ (stream-cons 2
+ (stream-cons 3
+ stream-null))))
+
+(stream-car strm123) @result{} 1
+(stream-car (stream-cdr strm123) @result{} 2
+
+(stream-pair?
+ (stream-cdr
+ (stream-cons (/ 1 0) stream-null))) @result{} #f
+
+(stream? (list 1 2 3)) @result{} #f
+
+(define iter
+ (stream-lambda (f x)
+ (stream-cons x (iter f (f x)))))
+
+(define nats (iter (lambda (x) (+ x 1)) 0))
+
+(stream-car (stream-cdr nats)) @result{} 1
+
+(define stream-add
+ (stream-lambda (s1 s2)
+ (stream-cons
+ (+ (stream-car s1) (stream-car s2))
+ (stream-add (stream-cdr s1)
+ (stream-cdr s2)))))
+
+(define evens (stream-add nats nats))
+
+(stream-car evens) @result{} 0
+(stream-car (stream-cdr evens)) @result{} 2
+(stream-car (stream-cdr (stream-cdr evens))) @result{} 4
address@hidden example
+
address@hidden SRFI-41 Stream Library
address@hidden SRFI-41 Stream Library
+
address@hidden {Scheme Syntax} define-stream (name args @dots{}) body @dots{}
+Creates a procedure that returns a stream, and may appear anywhere a
+normal @code{define} may appear, including as an internal definition.
+It may contain internal definitions of its own. The defined procedure
+takes arguments in the same way as @code{stream-lambda}.
address@hidden is syntactic sugar on @code{stream-lambda}; see
+also @code{stream-let}, which is also a sugaring of
address@hidden
+
+A simple version of @code{stream-map} that takes only a single input
+stream calls itself recursively:
+
address@hidden
+(define-stream (stream-map proc strm)
+ (if (stream-null? strm)
+ stream-null
+ (stream-cons
+ (proc (stream-car strm))
+ (stream-map proc (stream-cdr strm))))))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} list->stream list
+Returns a newly-allocated stream containing the elements from
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} port->stream [port]
+Returns a newly-allocated stream containing in its elements the
+characters on the port. If @var{port} is not given it defaults to the
+current input port. The returned stream has finite length and is
+terminated by @code{stream-null}.
+
+It looks like one use of @code{port->stream} would be this:
+
address@hidden
+(define s ;wrong!
+ (with-input-from-file filename
+ (lambda () (port->stream))))
address@hidden example
+
+But that fails, because @code{with-input-from-file} is eager, and closes
+the input port prematurely, before the first character is read. To read
+a file into a stream, say:
+
address@hidden
+(define-stream (file->stream filename)
+ (let ((p (open-input-file filename)))
+ (stream-let loop ((c (read-char p)))
+ (if (eof-object? c)
+ (begin (close-input-port p)
+ stream-null)
+ (stream-cons c
+ (loop (read-char p)))))))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Syntax} stream object-expr @dots{}
+Creates a newly-allocated stream containing in its elements the objects,
+in order. The @var{object-expr}s are evaluated when they are accessed,
+not when the stream is created. If no objects are given, as in
+(stream), the null stream is returned. See also @code{list->stream}.
+
address@hidden
+(define strm123 (stream 1 2 3))
+
+; (/ 1 0) not evaluated when stream is created
+(define s (stream 1 (/ 1 0) -1))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream->list [n] stream
+Returns a newly-allocated list containing in its elements the first
address@hidden items in @var{stream}. If @var{stream} has less than @var{n}
+items, all the items in the stream will be included in the returned
+list. If @var{n} is not given it defaults to infinity, which means that
+unless @var{stream} is finite @code{stream->list} will never return.
+
address@hidden
+(stream->list 10
+ (stream-map (lambda (x) (* x x))
+ (stream-from 0)))
+ @result{} (0 1 4 9 16 25 36 49 64 81)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-append stream @dots{}
+Returns a newly-allocated stream containing in its elements those
+elements contained in its input @var{stream}s, in order of input. If
+any of the input streams is infinite, no elements of any of the
+succeeding input streams will appear in the output stream. See also
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-concat stream
+Takes a @var{stream} consisting of one or more streams and returns a
+newly-allocated stream containing all the elements of the input streams.
+If any of the streams in the input @var{stream} is infinite, any
+remaining streams in the input stream will never appear in the output
+stream. See also @code{stream-append}.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-constant object @dots{}
+Returns a newly-allocated stream containing in its elements the
address@hidden, repeating in succession forever.
+
address@hidden
+(stream-constant 1) @result{} 1 1 1 @dots{}
+(stream-constant #t #f) @result{} #t #f #t #f #t #f @dots{}
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-drop n stream
+Returns the suffix of the input @var{stream} that starts at the next
+element after the first @var{n} elements. The output stream shares
+structure with the input @var{stream}; thus, promises forced in one
+instance of the stream are also forced in the other instance of the
+stream. If the input @var{stream} has less than @var{n} elements,
address@hidden returns the null stream. See also
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-drop-while pred stream
+Returns the suffix of the input @var{stream} that starts at the first
+element @var{x} for which @code{(pred x)} returns false. The output
+stream shares structure with the input @var{stream}. See also
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-filter pred stream
+Returns a newly-allocated stream that contains only those elements
address@hidden of the input @var{stream} which satisfy the predicate
address@hidden
+
address@hidden
+(stream-filter odd? (stream-from 0))
+ @result{} 1 3 5 7 9 @dots{}
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-fold proc base stream
+Applies a binary procedure @var{proc} to @var{base} and the first
+element of @var{stream} to compute a new @var{base}, then applies the
+procedure to the new @var{base} and the next element of @var{stream} to
+compute a succeeding @var{base}, and so on, accumulating a value that is
+finally returned as the value of @code{stream-fold} when the end of the
+stream is reached. @var{stream} must be finite, or @code{stream-fold}
+will enter an infinite loop. See also @code{stream-scan}, which is
+similar to @code{stream-fold}, but useful for infinite streams. For
+readers familiar with other functional languages, this is a left-fold;
+there is no corresponding right-fold, since right-fold relies on finite
+streams that are fully-evaluated, in which case they may as well be
+converted to a list.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-for-each proc stream @dots{}
+Applies @var{proc} element-wise to corresponding elements of the input
address@hidden for side-effects; it returns nothing.
address@hidden stops as soon as any of its input streams is
+exhausted.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-from first [step]
+Creates a newly-allocated stream that contains @var{first} as its first
+element and increments each succeeding element by @var{step}. If
address@hidden is not given it defaults to 1. @var{first} and @var{step}
+may be of any numeric type. @code{stream-from} is frequently useful as
+a generator in @code{stream-of} expressions. See also
address@hidden for a similar procedure that creates finite streams.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-iterate proc base
+Creates a newly-allocated stream containing @var{base} in its first
+element and applies @var{proc} to each element in turn to determine the
+succeeding element. See also @code{stream-unfold} and
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-length stream
+Returns the number of elements in the @var{stream}; it does not evaluate
+its elements. @code{stream-length} may only be used on finite streams;
+it enters an infinite loop with infinite streams.
address@hidden deffn
+
address@hidden {Scheme Syntax} stream-let tag ((var expr) @dots{}) body @dots{}
+Creates a local scope that binds each variable to the value of its
+corresponding expression. It additionally binds @var{tag} to a
+procedure which takes the bound variables as arguments and @var{body} as
+its defining expressions, binding the @var{tag} with
address@hidden @var{tag} is in scope within body, and may be
+called recursively. When the expanded expression defined by the
address@hidden is evaluated, @code{stream-let} evaluates the
+expressions in its @var{body} in an environment containing the
+newly-bound variables, returning the value of the last expression
+evaluated, which must yield a stream.
+
address@hidden provides syntactic sugar on @code{stream-lambda}, in
+the same manner as normal @code{let} provides syntactic sugar on normal
address@hidden However, unlike normal @code{let}, the @var{tag} is
+required, not optional, because unnamed @code{stream-let} is
+meaningless.
+
+For example, @code{stream-member} returns the first @code{stream-pair}
+of the input @var{strm} with a @code{stream-car} @var{x} that satisfies
address@hidden(eql? obj x)}, or the null stream if @var{x} is not present in
address@hidden
+
address@hidden
+(define-stream (stream-member eql? obj strm)
+ (stream-let loop ((strm strm))
+ (cond ((stream-null? strm) strm)
+ ((eql? obj (stream-car strm)) strm)
+ (else (loop (stream-cdr strm))))))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-map proc stream @dots{}
+Applies @var{proc} element-wise to corresponding elements of the input
address@hidden, returning a newly-allocated stream containing elements
+that are the results of those procedure applications. The output stream
+has as many elements as the minimum-length input stream, and may be
+infinite.
address@hidden deffn
+
address@hidden {Scheme Syntax} stream-match stream clause @dots{}
+Provides pattern-matching for streams. The input @var{stream} is an
+expression that evaluates to a stream. Clauses are of the form
address@hidden(pattern [fender] expression)}, consisting of a @var{pattern} that
+matches a stream of a particular shape, an optional @var{fender} that
+must succeed if the pattern is to match, and an @var{expression} that is
+evaluated if the pattern matches. There are four types of patterns:
+
address@hidden @bullet
address@hidden
+() matches the null stream.
+
address@hidden
+(@var{pat0} @var{pat1} @dots{}) matches a finite stream with length
+exactly equal to the number of pattern elements.
+
address@hidden
+(@var{pat0} @var{pat1} @dots{} @code{.} @var{pat-rest}) matches an
+infinite stream, or a finite stream with length at least as great as the
+number of pattern elements before the literal dot.
+
address@hidden
address@hidden matches an entire stream. Should always appear last in the
+list of clauses; it's not an error to appear elsewhere, but subsequent
+clauses could never match.
address@hidden itemize
+
+Each pattern element may be either:
+
address@hidden @bullet
address@hidden
+An identifier, which matches any stream element. Additionally, the
+value of the stream element is bound to the variable named by the
+identifier, which is in scope in the @var{fender} and @var{expression}
+of the corresponding @var{clause}. Each identifier in a single pattern
+must be unique.
+
address@hidden
+A literal underscore (@code{_}), which matches any stream element but
+creates no bindings.
address@hidden itemize
+
+The @var{pattern}s are tested in order, left-to-right, until a matching
+pattern is found; if @var{fender} is present, it must evaluate to a true
+value for the match to be successful. Pattern variables are bound in
+the corresponding @var{fender} and @var{expression}. Once the matching
address@hidden is found, the corresponding @var{expression} is evaluated
+and returned as the result of the match. An error is signaled if no
+pattern matches the input @var{stream}.
+
address@hidden is often used to distinguish null streams from
+non-null streams, binding @var{head} and @var{tail}:
+
address@hidden
+(define (len strm)
+ (stream-match strm
+ (() 0)
+ ((head . tail) (+ 1 (len tail)))))
address@hidden example
+
+Fenders can test the common case where two stream elements must be
+identical; the @code{else} pattern is an identifier bound to the entire
+stream, not a keyword as in @code{cond}.
+
address@hidden
+(stream-match strm
+ ((x y . _) (equal? x y) 'ok)
+ (else 'error))
address@hidden example
+
+A more complex example uses two nested matchers to match two different
+stream arguments; @code{(stream-merge lt? . strms)} stably merges two or
+more streams ordered by the @code{lt?} predicate:
+
address@hidden
+(define-stream (stream-merge lt? . strms)
+ (define-stream (merge xx yy)
+ (stream-match xx (() yy) ((x . xs)
+ (stream-match yy (() xx) ((y . ys)
+ (if (lt? y x)
+ (stream-cons y (merge xx ys))
+ (stream-cons x (merge xs yy))))))))
+ (stream-let loop ((strms strms))
+ (cond ((null? strms) stream-null)
+ ((null? (cdr strms)) (car strms))
+ (else (merge (car strms)
+ (apply stream-merge lt?
+ (cdr strms)))))))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Syntax} stream-of expr clause @dots{}
+Provides the syntax of stream comprehensions, which generate streams by
+means of looping expressions. The result is a stream of objects of the
+type returned by @var{expr}. There are four types of clauses:
+
address@hidden @bullet
address@hidden
+(@var{var} @code{in} @var{stream-expr}) loops over the elements of
address@hidden, in order from the start of the stream, binding each
+element of the stream in turn to @var{var}. @code{stream-from} and
address@hidden are frequently useful as generators for
address@hidden
+
address@hidden
+(@var{var} @code{is} @var{expr}) binds @var{var} to the value obtained
+by evaluating @var{expr}.
+
address@hidden
+(@var{pred} @var{expr}) includes in the output stream only those
+elements @var{x} which satisfy the predicate @var{pred}.
address@hidden itemize
+
+The scope of variables bound in the stream comprehension is the clauses
+to the right of the binding clause (but not the binding clause itself)
+plus the result expression.
+
+When two or more generators are present, the loops are processed as if
+they are nested from left to right; that is, the rightmost generator
+varies fastest. A consequence of this is that only the first generator
+may be infinite and all subsequent generators must be finite. If no
+generators are present, the result of a stream comprehension is a stream
+containing the result expression; thus, @samp{(stream-of 1)} produces a
+finite stream containing only the element 1.
+
address@hidden
+(stream-of (* x x)
+ (x in (stream-range 0 10))
+ (even? x))
+ @result{} 0 4 16 36 64
+
+(stream-of (list a b)
+ (a in (stream-range 1 4))
+ (b in (stream-range 1 3)))
+ @result{} (1 1) (1 2) (2 1) (2 2) (3 1) (3 2)
+
+(stream-of (list i j)
+ (i in (stream-range 1 5))
+ (j in (stream-range (+ i 1) 5)))
+ @result{} (1 2) (1 3) (1 4) (2 3) (2 4) (3 4)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-range first past [step]
+Creates a newly-allocated stream that contains @var{first} as its first
+element and increments each succeeding element by @var{step}. The
+stream is finite and ends before @var{past}, which is not an element of
+the stream. If @var{step} is not given it defaults to 1 if @var{first}
+is less than past and -1 otherwise. @var{first}, @var{past} and
address@hidden may be of any real numeric type. @code{stream-range} is
+frequently useful as a generator in @code{stream-of} expressions. See
+also @code{stream-from} for a similar procedure that creates infinite
+streams.
+
address@hidden
+(stream-range 0 10) @result{} 0 1 2 3 4 5 6 7 8 9
+(stream-range 0 10 2) @result{} 0 2 4 6 8
address@hidden example
+
+Successive elements of the stream are calculated by adding @var{step} to
address@hidden, so if any of @var{first}, @var{past} or @var{step} are
+inexact, the length of the output stream may differ from
address@hidden(ceiling (- (/ (- past first) step) 1)}.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-ref stream n
+Returns the @var{n}th element of stream, counting from zero. An error
+is signaled if @var{n} is greater than or equal to the length of stream.
+
address@hidden
+(define (fact n)
+ (stream-ref
+ (stream-scan * 1 (stream-from 1))
+ n))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-reverse stream
+Returns a newly-allocated stream containing the elements of the input
address@hidden but in reverse order. @code{stream-reverse} may only be
+used with finite streams; it enters an infinite loop with infinite
+streams. @code{stream-reverse} does not force evaluation of the
+elements of the stream.
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-scan proc base stream
+Accumulates the partial folds of an input @var{stream} into a
+newly-allocated output stream. The output stream is the @var{base}
+followed by @code{(stream-fold proc base (stream-take i stream))} for
+each of the first @var{i} elements of @var{stream}.
+
address@hidden
+(stream-scan + 0 (stream-from 1))
+ @result{} (stream 0 1 3 6 10 15 @dots{})
+
+(stream-scan * 1 (stream-from 1))
+ @result{} (stream 1 1 2 6 24 120 @dots{})
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-take n stream
+Returns a newly-allocated stream containing the first @var{n} elements
+of the input @var{stream}. If the input @var{stream} has less than
address@hidden elements, so does the output stream. See also
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-take-while pred stream
+Takes a predicate and a @code{stream} and returns a newly-allocated
+stream containing those elements @code{x} that form the maximal prefix
+of the input stream which satisfy @var{pred}. See also
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-unfold map pred gen base
+The fundamental recursive stream constructor. It constructs a stream by
+repeatedly applying @var{gen} to successive values of @var{base}, in the
+manner of @code{stream-iterate}, then applying @var{map} to each of the
+values so generated, appending each of the mapped values to the output
+stream as long as @code{(pred? base)} returns a true value. See also
address@hidden and @code{stream-unfolds}.
+
+The expression below creates the finite stream @samp{0 1 4 9 16 25 36 49
+64 81}. Initially the @var{base} is 0, which is less than 10, so
address@hidden squares the @var{base} and the mapped value becomes the first
+element of the output stream. Then @var{gen} increments the @var{base}
+by 1, so it becomes 1; this is less than 10, so @var{map} squares the
+new @var{base} and 1 becomes the second element of the output stream.
+And so on, until the base becomes 10, when @var{pred} stops the
+recursion and stream-null ends the output stream.
+
address@hidden
+(stream-unfold
+ (lambda (x) (expt x 2)) ; map
+ (lambda (x) (< x 10)) ; pred?
+ (lambda (x) (+ x 1)) ; gen
+ 0) ; base
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-unfolds proc seed
+Returns @var{n} newly-allocated streams containing those elements
+produced by successive calls to the generator @var{proc}, which takes
+the current @var{seed} as its argument and returns @var{n}+1 values
+
+(@var{proc} @var{seed}) @result{} @var{seed} @var{result_0} @dots{}
@var{result_n-1}
+
+where the returned @var{seed} is the input @var{seed} to the next call
+to the generator and @var{result_i} indicates how to produce the next
+element of the @var{i}th result stream:
+
address@hidden @bullet
address@hidden
+(@var{value}): @var{value} is the next car of the result stream.
+
address@hidden
address@hidden: no value produced by this iteration of the generator
address@hidden for the result stream.
+
address@hidden
+(): the end of the result stream.
address@hidden itemize
+
+It may require multiple calls of @var{proc} to produce the next element
+of any particular result stream. See also @code{stream-iterate} and
address@hidden
+
address@hidden
+(define (stream-partition pred? strm)
+ (stream-unfolds
+ (lambda (s)
+ (if (stream-null? s)
+ (values s '() '())
+ (let ((a (stream-car s))
+ (d (stream-cdr s)))
+ (if (pred? a)
+ (values d (list a) #f)
+ (values d #f (list a))))))
+ strm))
+
+(call-with-values
+ (lambda ()
+ (stream-partition odd?
+ (stream-range 1 6)))
+ (lambda (odds evens)
+ (list (stream->list odds)
+ (stream->list evens))))
+ @result{} ((1 3 5) (2 4))
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} stream-zip stream @dots{}
+Returns a newly-allocated stream in which each element is a list (not a
+stream) of the corresponding elements of the input @var{stream}s. The
+output stream is as long as the shortest input @var{stream}, if any of
+the input @var{stream}s is finite, or is infinite if all the input
address@hidden are infinite.
address@hidden deffn
+
@node SRFI-42
@subsection SRFI-42 - Eager Comprehensions
@cindex SRFI-42
@@ -3832,6 +4552,13 @@ words, no program that uses the R5RS definitions of
delay and force will
break if those definition are replaced by the SRFI-45 definitions of
delay and force.
+Guile also adds @code{promise?} to the list of exports, which is not
+part of the official SRFI-45.
+
address@hidden {Scheme Procedure} promise? obj
+Return true if @var{obj} is an SRFI-45 promise, otherwise return false.
address@hidden deffn
+
@deffn {Scheme Syntax} delay expression
Takes an expression of arbitrary type @var{a} and returns a promise of
type @code{(Promise @var{a})} which at some point in the future may be
diff --git a/doc/ref/sxml-match.texi b/doc/ref/sxml-match.texi
index 7a1a9ac..d2795a5 100644
--- a/doc/ref/sxml-match.texi
+++ b/doc/ref/sxml-match.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010 Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@c
@c Based on the documentation at
@@ -16,10 +16,10 @@
@cindex pattern matching (SXML)
@cindex SXML pattern matching
-The @code{(sxml match)} module provides syntactic forms for pattern matching of
-SXML trees, in a ``by example'' style reminiscent of the pattern matching of
the
address@hidden and @code{syntax-case} macro systems. @xref{sxml simple,
-the @code{(sxml simple)} module}, for more information on SXML.
+The @code{(sxml match)} module provides syntactic forms for pattern
+matching of SXML trees, in a ``by example'' style reminiscent of the
+pattern matching of the @code{syntax-rules} and @code{syntax-case} macro
+systems. @xref{SXML}, for more information on SXML.
The following address@hidden example is taken from a paper by
Krishnamurthi et al. Their paper was the first to show the usefulness of the
diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi
index 3ce6062..75867f3 100644
--- a/doc/ref/sxml.texi
+++ b/doc/ref/sxml.texi
@@ -6,257 +6,290 @@
@node SXML
@section SXML
address@hidden
-* 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
address@hidden menu
-
address@hidden sxml apply-templates
address@hidden (sxml apply-templates)
address@hidden Overview
-Pre-order traversal of a tree and creation of a new tree:
-
address@hidden
- apply-templates:: tree x <templates> -> <new-tree>
address@hidden smallexample
-
-where
-
address@hidden
- <templates> ::= (<template> ...)
- <template> ::= (<node-test> <node-test> ... <node-test> . <handler>)
- <node-test> ::= an argument to node-typeof? above
- <handler> ::= <tree> -> <new-tree>
address@hidden 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
address@hidden function of XSLT.
-
address@hidden Usage
address@hidden apply-templates address@hidden apply-templates tree templates
address@hidden defun
-
address@hidden sxml fold
address@hidden (sxml fold)
address@hidden Overview
address@hidden(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}.
-
address@hidden Usage
address@hidden fold address@hidden foldt fup fhere tree
-The standard multithreaded tree fold.
-
address@hidden is of type [a] -> a. @var{fhere} is of type object -> a.
-
address@hidden defun
-
address@hidden fold address@hidden foldts fdown fup fhere seed tree
-The single-threaded tree fold originally defined in SSAX. @xref{sxml
-ssax,,(sxml ssax)}, for more information.
+SXML is a native representation of XML in terms of standard Scheme data
+types: lists, symbols, and strings. For example, the simple XML
+fragment:
address@hidden defun
-
address@hidden fold address@hidden 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}.
-
address@hidden defun
-
address@hidden fold address@hidden 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
-
address@hidden defun
-
address@hidden fold address@hidden 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, @emph{Applications
-of fold to XML transformation}.
-
address@hidden defun
-
address@hidden fold address@hidden 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
+<parrot type="African Grey"><name>Alfie</name></parrot>
@end 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.
+may be represented with the following SXML:
address@hidden post-handler
-A function of five arguments:
address@hidden
+(parrot (@@ (type "African Grey)) (name "Alfie"))
address@hidden example
address@hidden @var
address@hidden tag
-the current tag being processed
+SXML is very general, and is capable of representing all of XML.
+Formally, this means that SXML is a conforming implementation of the
address@hidden Information Set,http://www.w3.org/TR/xml-infoset/} standard.
address@hidden params
-the params of the current node
+Guile includes several facilities for working with XML and SXML:
+parsers, serializers, and transformers.
address@hidden layout
-the layout coming into the current node, before any kids were processed
address@hidden
+* SXML Overview:: XML, as it was meant to be
+* Reading and Writing XML:: Convenient XML parsing and serializing
+* SSAX:: Custom functional-style XML parsers
+* Transforming SXML:: Munging SXML with @code{pre-post-order}
+* SXML Tree Fold:: Fold-based SXML transformations
+* SXPath:: XPath for SXML
+* sxml apply-templates:: A more XSLT-like approach to SXML
transformations
+* sxml ssax input-parse:: The SSAX tokenizer, optimized for Guile
address@hidden menu
address@hidden klayout
-the layout after processing all of the children
address@hidden SXML Overview
address@hidden SXML Overview
address@hidden kids
-the already-processed child nodes
+(This section needs to be written; volunteers welcome.)
address@hidden table
address@hidden should return two values, the layout to pass to the
-next node and the final tree.
address@hidden Reading and Writing XML
address@hidden Reading and Writing XML
address@hidden text-handler
address@hidden is a function of three arguments:
+The @code{(sxml simple)} module presents a basic interface for parsing
+XML from a port into the Scheme SXML format, and for serializing it back
+to text.
address@hidden @var
address@hidden text
-the string
address@hidden
+(use-modules (sxml simple))
address@hidden example
address@hidden params
-the current params
address@hidden {Scheme Procedure} xml->sxml [string-or-port] [#:namespaces='()]
@
+ [#:declare-namespaces?=#t] [#:trim-whitespace?=#f] @
+ [#:entities='()] [#:default-entity-handler=#f] @
+ [#:doctype-handler=#f]
+Use SSAX to parse an XML document into SXML. Takes one optional
+argument, @var{string-or-port}, which defaults to the current input
+port. Returns the resulting SXML document. If @var{string-or-port} is
+a port, it will be left pointing at the next available character in the
+port.
address@hidden deffn
+
+As is normal in SXML, XML elements parse as tagged lists. Attributes,
+if any, are placed after the tag, within an @code{@@} element. The root
+of the resulting XML will be contained in a special tag, @code{*TOP*}.
+This tag will contain the root element of the XML, but also any prior
+processing instructions.
+
address@hidden
+(xml->sxml "<foo/>")
address@hidden (*TOP* (foo))
+(xml->sxml "<foo>text</foo>")
address@hidden (*TOP* (foo "text"))
+(xml->sxml "<foo kind=\"bar\">text</foo>")
address@hidden (*TOP* (foo (@@ (kind "bar")) "text"))
+(xml->sxml "<?xml version=\"1.0\"?><foo/>")
address@hidden (*TOP* (*PI* xml "version=\"1.0\"") (foo))
address@hidden example
address@hidden layout
-the current layout
+All namespaces in the XML document must be declared, via @code{xmlns}
+attributes. SXML elements built from non-default namespaces will have
+their tags prefixed with their URI. Users can specify custom prefixes
+for certain namespaces with the @code{#:namespaces} keyword argument to
address@hidden>sxml}.
+
address@hidden
+(xml->sxml "<foo xmlns=\"http://example.org/ns1\";>text</foo>")
address@hidden (*TOP* (http://example.org/ns1:foo "text"))
+(xml->sxml "<foo xmlns=\"http://example.org/ns1\";>text</foo>"
+ #:namespaces '((ns1 . "http://example.org/ns1";)))
address@hidden (*TOP* (ns1:foo "text"))
+(xml->sxml "<foo xmlns:bar=\"http://example.org/ns2\";><bar:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2";)))
address@hidden (*TOP* (foo (ns2:baz)))
address@hidden example
address@hidden table
+By default, namespaces passed to @code{xml->sxml} are treated as if they
+were declared on the root element. Passing a false
address@hidden:declare-namespaces?} argument will disable this behavior,
+requiring in-document declarations of namespaces before use..
+
address@hidden
+(xml->sxml "<foo><ns2:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2";)))
address@hidden (*TOP* (foo (ns2:baz)))
+(xml->sxml "<foo><ns2:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2";))
+ #:declare-namespaces? #f)
address@hidden error: undeclared namespace: `bar'
address@hidden example
address@hidden should return two values, the layout to pass to the
-next node and the value to which the string should transform.
+By default, all whitespace in XML is significant. Passing the
address@hidden:trim-whitespace?} keyword argument to @code{xml->sxml} will trim
+whitespace in front, behind and between elements, treating it as
+``unsignificant''. Whitespace in text fragments is left alone.
+
address@hidden
+(xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>")
address@hidden (*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n"))
+(xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>"
+ #:trim-whitespace? #t)
address@hidden (*TOP* (foo (bar " Alfie the parrot! ")))
address@hidden example
address@hidden table
+Parsed entities may be declared with the @code{#:entities} keyword
+argument, or handled with the @code{#:default-entity-handler}. By
+default, only the standard @code{<}, @code{>}, @code{&},
address@hidden'} and @code{"} entities are defined, as well as the
address@hidden&address@hidden;} and @code{&address@hidden;} (decimal and
hexadecimal)
+numeric character entities.
+
address@hidden
+(xml->sxml "<foo>&</foo>")
address@hidden (*TOP* (foo "&"))
+(xml->sxml "<foo> </foo>")
address@hidden error: undefined entity: nbsp
+(xml->sxml "<foo> </foo>")
address@hidden (*TOP* (foo "\xa0"))
+(xml->sxml "<foo> </foo>"
+ #:entities '((nbsp . "\xa0")))
address@hidden (*TOP* (foo "\xa0"))
+(xml->sxml "<foo> &foo;</foo>"
+ #:default-entity-handler
+ (lambda (port name)
+ (case name
+ ((nbsp) "\xa0")
+ (else
+ (format (current-warning-port)
+ "~a:~a:~a: undefined entitity: ~a\n"
+ (or (port-filename port) "<unknown file>")
+ (port-line port) (port-column port)
+ name)
+ (symbol->string name)))))
address@hidden <unknown file>:0:17: undefined entitity: foo
address@hidden (*TOP* (foo "\xa0 foo"))
address@hidden example
address@hidden defun
+By default, @code{xml->sxml} skips over the @code{<!DOCTYPE>}
+declaration, if any. This behavior can be overridden with the
address@hidden:doctype-handler} argument, which should be a procedure of three
+arguments: the @dfn{docname} (a symbol), @dfn{systemid} (a string), and
+the internal doctype subset (as a string or @code{#f} if not present).
+
+The handler should return keyword arguments as multiple values, as if it
+were calling its continuation with keyword arguments. The continuation
+accepts the @code{#:entities} and @code{#:namespaces} keyword arguments,
+in the same format that @code{xml->sxml} itself takes. These entities
+and namespaces will be prepended to those given to the @code{xml->sxml}
+invocation.
+
address@hidden
+(define (handle-foo docname systemid internal-subset)
+ (case docname
+ ((foo)
+ (values #:entities '((greets . "<i>Hello, world!</i>"))))
+ (else
+ (values))))
+
+(xml->sxml "<!DOCTYPE foo><p>&greets;</p>"
+ #:doctype-handler handle-foo)
address@hidden (*TOP* (p (i "Hello, world!")))
address@hidden example
address@hidden sxml simple
address@hidden (sxml simple)
address@hidden Overview
-A simple interface to XML parsing and serialization.
+If the document has no doctype declaration, the @var{doctype-handler} is
+invoked with @code{#f} for the three arguments.
address@hidden Usage
address@hidden simple xml->address@hidden xml->sxml [port]
-Use SSAX to parse an XML document into SXML. Takes one optional
-argument, @var{port}, which defaults to the current input port.
-
address@hidden defun
+In the future, the continuation may accept other keyword arguments, for
+example to validate the parsed SXML against the doctype.
address@hidden simple sxml->address@hidden sxml->xml tree [port]
-Serialize the sxml tree @var{tree} as XML. The output will be written to
address@hidden {Scheme Procedure} sxml->xml tree [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.
address@hidden deffn
address@hidden defun
-
address@hidden simple sxml->address@hidden sxml->string sxml
address@hidden {Scheme Procedure} sxml->string sxml
Detag an sxml tree @var{sxml} into a string. Does not perform any
formatting.
-
address@hidden defun
-
address@hidden sxml ssax
address@hidden (sxml ssax)
address@hidden Overview
address@hidden Functional XML parsing framework
address@hidden 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
address@hidden deffn
+
address@hidden SSAX
address@hidden SSAX: A Functional XML Parsing Toolkit
+
+Guile's XML parser is based on Oleg Kiselyov's powerful XML parsing
+toolkit, SSAX.
+
address@hidden History
+
+Back in the 1990s, when the world was young again and XML was the
+solution to all of its problems, there were basically two kinds of XML
+parsers out there: DOM parsers and SAX parsers.
+
+A DOM parser reads through an entire XML document, building up a tree of
+``DOM objects'' representing the document structure. They are very easy
+to use, but sometimes you don't actually want all of the information in
+a document; building an object tree is not necessary if all you want to
+do is to count word frequencies in a document, for example.
+
+SAX parsers were created to give the programmer more control on the
+parsing process. A programmer gives the SAX parser a number of
+``callbacks'': functions that will be called on various features of the
+XML stream as they are encountered. SAX parsers are more efficient, but
+much harder to user, as users typically have to manually maintain a
+stack of open elements.
+
+Kiselyov realized that the SAX programming model could be made much
+simpler if the callbacks were formulated not as a linear fold across the
+features of the XML stream, but as a @emph{tree fold} over the structure
+implicit in the XML. In this way, the user has a very convenient,
+functional-style interface that can still generate optimal parsers.
+
+The @code{xml->sxml} interface from the @code{(sxml simple)} module is a
+DOM-style parser built using SSAX, though it returns SXML instead of DOM
+objects.
+
address@hidden Implementation
+
address@hidden(sxml ssax)} 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.
+
+SSAX 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
address@hidden The functions of this framework do not process or affect the
address@hidden 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:
address@hidden:make-elem-parser} or @code{SSAX:make-parser}. In the latter
address@hidden 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:
address@hidden: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
+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.
+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].
+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
@@ -287,20 +320,22 @@ 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
address@hidden://www.w3.org/TR/1998/REC-xml-19980210.html}
+The XML standard document referred to in this module is
address@hidden://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
+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.
+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:
+The present frameworks fully supports the XML Namespaces Recommendation:
address@hidden://www.w3.org/TR/REC-xml-names/}.
+
+Other links:
@table @asis
@item [1]
@@ -319,175 +354,104 @@ Pearl. Proc ICFP'00, pp. 186-197.
@end table
@subsubsection Usage
address@hidden ssax address@hidden current-ssax-error-port
address@hidden defun
address@hidden {Scheme Procedure} current-ssax-error-port
address@hidden deffn
address@hidden ssax address@hidden with-ssax-error-to-port port thunk
address@hidden defun
address@hidden {Scheme Procedure} with-ssax-error-to-port port thunk
address@hidden deffn
address@hidden ssax address@hidden xml-token? _
address@hidden {Scheme Procedure} xml-token? _
@verbatim
-- Scheme Procedure: pair? x
Return `#t' if X is a pair; otherwise return `#f'.
@end verbatim
address@hidden deffn
address@hidden defun
-
address@hidden ssax address@hidden xml-token-kind token
address@hidden defspec
address@hidden {Scheme Syntax} xml-token-kind token
address@hidden deffn
address@hidden ssax address@hidden xml-token-head token
address@hidden defspec
address@hidden {Scheme Syntax} xml-token-head token
address@hidden deffn
address@hidden ssax address@hidden make-empty-attlist
address@hidden defun
address@hidden {Scheme Procedure} make-empty-attlist
address@hidden deffn
address@hidden ssax address@hidden attlist-add attlist name-value
address@hidden defun
address@hidden {Scheme Procedure} attlist-add attlist name-value
address@hidden deffn
address@hidden ssax address@hidden attlist-null? _
address@hidden
- -- Scheme Procedure: null? x
- Return `#t' iff X is the empty list, else `#f'.
address@hidden {Scheme Procedure} attlist-null? x
+Return @code{#t} if @var{x} is the empty list, else @code{#f}.
address@hidden deffn
-
address@hidden verbatim
address@hidden {Scheme Procedure} attlist-remove-top attlist
address@hidden deffn
address@hidden defun
address@hidden {Scheme Procedure} attlist->alist attlist
address@hidden deffn
address@hidden ssax address@hidden attlist-remove-top attlist
address@hidden defun
address@hidden {Scheme Procedure} attlist-fold kons knil lis1
address@hidden deffn
address@hidden ssax attlist->address@hidden attlist->alist attlist
address@hidden defun
-
address@hidden ssax address@hidden attlist-fold kons knil lis1
address@hidden defun
-
address@hidden ssax address@hidden define-parsed-entity! entity str
-Define a new parsed entity. @var{entity} should be a symbol.
address@hidden {Scheme Procedure} define-parsed-entity! entity str
+Define a new parsed entity. @var{entity} should be a symbol.
Instances of &@var{entity}; in XML text will be replaced with the string
@var{str}, which will then be parsed.
address@hidden deffn
address@hidden defun
-
address@hidden ssax address@hidden reset-parsed-entity-definitions!
address@hidden {Scheme Procedure} reset-parsed-entity-definitions!
Restore the set of parsed entity definitions to its initial state.
address@hidden deffn
address@hidden defun
-
address@hidden ssax ssax:uri-string->address@hidden ssax:uri-string->symbol
uri-str
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:skip-internal-dtd port
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:read-pi-body-as-string port
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:reverse-collect-str-drop-ws
fragments
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:read-markup-token port
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:read-cdata-body port str-handler
seed
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:read-char-ref port
address@hidden defun
address@hidden {Scheme Procedure} ssax:uri-string->symbol uri-str
address@hidden deffn
address@hidden ssax ssax:address@hidden ssax:read-attributes port entities
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:complete-start-tag tag-head port
elems entities namespaces
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:read-external-id port
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:read-char-data port expect-eof?
str-handler seed
address@hidden defun
-
address@hidden ssax ssax:xml->address@hidden ssax:xml->sxml port
namespace-prefix-assig
address@hidden defun
-
address@hidden ssax ssax:address@hidden ssax:make-parser . kw-val-pairs
address@hidden defspec
-
address@hidden ssax ssax:address@hidden ssax:make-pi-parser orig-handlers
address@hidden defspec
-
address@hidden ssax ssax:address@hidden ssax:make-elem-parser my-new-level-seed
my-finish-element my-char-data-handler my-pi-handlers
address@hidden defspec
-
address@hidden sxml ssax input-parse
address@hidden (sxml ssax input-parse)
address@hidden Overview
-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*}.
address@hidden {Scheme Procedure} ssax:skip-internal-dtd port
address@hidden deffn
-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.
address@hidden {Scheme Procedure} ssax:read-pi-body-as-string port
address@hidden deffn
-If the parser encounters an error, it will throw an exception to the key
address@hidden The arguments will be of the form @code{(@var{port}
address@hidden @var{specialising-msg}*)}.
address@hidden {Scheme Procedure} ssax:reverse-collect-str-drop-ws fragments
address@hidden deffn
-The first argument is a port, which typically points to the offending
-character or its neighborhood. You can then use @code{port-column} and
address@hidden to query the current position. @var{message} is the
-description of the error. Other arguments supply more details about the
-problem.
address@hidden {Scheme Procedure} ssax:read-markup-token port
address@hidden deffn
address@hidden Usage
address@hidden ssax input-parse address@hidden peek-next-char [port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:read-cdata-body port str-handler seed
address@hidden deffn
address@hidden ssax input-parse address@hidden assert-curr-char expected-chars
comment [port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:read-char-ref port
address@hidden deffn
address@hidden ssax input-parse address@hidden skip-until arg [port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:read-attributes port entities
address@hidden deffn
address@hidden ssax input-parse address@hidden skip-while skip-chars [port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:complete-start-tag tag-head port elems
entities namespaces
address@hidden deffn
address@hidden ssax input-parse address@hidden next-token prefix-skipped-chars
break-chars [comment] [port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:read-external-id port
address@hidden deffn
address@hidden ssax input-parse address@hidden next-token-of incl-list/pred
[port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:read-char-data port expect-eof?
str-handler seed
address@hidden deffn
address@hidden ssax input-parse address@hidden read-text-line [port]
address@hidden defun
address@hidden {Scheme Procedure} ssax:xml->sxml port namespace-prefix-assig
address@hidden deffn
address@hidden ssax input-parse address@hidden read-string n [port]
address@hidden defun
address@hidden {Scheme Syntax} ssax:make-parser . kw-val-pairs
address@hidden deffn
address@hidden ssax input-parse address@hidden find-string-from-port? _ _ . _
-Looks for @var{str} in @var{<input-port>}, optionally within the first
address@hidden characters.
address@hidden {Scheme Syntax} ssax:make-pi-parser orig-handlers
address@hidden deffn
address@hidden defun
address@hidden {Scheme Syntax} ssax:make-elem-parser my-new-level-seed
my-finish-element my-char-data-handler my-pi-handlers
address@hidden deffn
address@hidden sxml transform
address@hidden (sxml transform)
address@hidden Transforming SXML
address@hidden Transforming SXML
@subsubsection Overview
@heading SXML expression tree transformers
@subheading Pre-Post-order traversal of a tree and creation of a new tree
@@ -508,11 +472,11 @@ where
@end smallexample
The pre-post-order function visits the nodes and nodelists
-pre-post-order (depth-first). For each @code{<Node>} of the form
+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,
address@hidden tries to locate a @code{*default*} binding. It's
-an error if the latter attempt fails as well. Having found a binding,
+given @var{name} among its @var{<bindings>}. If failed,
address@hidden 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
@@ -520,14 +484,14 @@ of the form
(<trigger-symbol> *preorder* . <handler>)
@end smallexample
-If it is, the handler is 'applied' to the current node. Otherwise, the
+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
address@hidden<bindings>} in effect. The result of these calls is passed to the
address@hidden<handler>} (along with the head of the current @var{<Node>}). To
be
address@hidden<bindings>} in effect. The result of these calls is passed to the
address@hidden<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
+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.
@@ -537,60 +501,182 @@ A binding can also be of a form
(<trigger-symbol> *macro* . <handler>)
@end smallexample
-This is equivalent to @code{*preorder*} described above. However, the
+This is equivalent to @code{*preorder*} described above. However, the
result is re-processed again, with the current stylesheet.
@subsubsection Usage
address@hidden transform SRV:address@hidden SRV:send-reply . fragments
address@hidden {Scheme Procedure} 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
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
+and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
anything was written at all; otherwise the result is @code{#f} If
@code{#t} occurs among the fragments, it is not written out but causes
the result of @code{SRV:send-reply} to be @code{#t}.
address@hidden deffn
+
address@hidden {Scheme Procedure} foldts fdown fup fhere seed tree
address@hidden deffn
+
address@hidden {Scheme Procedure} post-order tree bindings
address@hidden deffn
+
address@hidden {Scheme Procedure} pre-post-order tree bindings
address@hidden deffn
+
address@hidden {Scheme Procedure} replace-range beg-pred end-pred forest
address@hidden deffn
+
address@hidden SXML Tree Fold
address@hidden SXML Tree Fold
address@hidden Overview
address@hidden(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}.
+
address@hidden Usage
address@hidden {Scheme Procedure} foldt fup fhere tree
+The standard multithreaded tree fold.
+
address@hidden is of type [a] -> a. @var{fhere} is of type object -> a.
address@hidden deffn
+
address@hidden {Scheme Procedure} foldts fdown fup fhere seed tree
+The single-threaded tree fold originally defined in SSAX. @xref{SSAX},
+for more information.
address@hidden deffn
+
address@hidden {Scheme Procedure} foldts* fdown fup fhere seed tree
+A variant of @code{foldts} that allows pre-order tree
+rewrites. Originally defined in Andy Wingo's 2007 paper,
address@hidden of fold to XML transformation}.
address@hidden deffn
+
address@hidden {Scheme Procedure} fold-values proc list . seeds
+A variant of @code{fold} that allows multi-valued seeds. Note that the
+order of the arguments differs from that of @code{fold}. @xref{SRFI-1
+Fold and Map}.
address@hidden deffn
+
address@hidden {Scheme Procedure} foldts*-values fdown fup fhere tree . seeds
+A variant of @code{foldts*} that allows multi-valued
+seeds. Originally defined in Andy Wingo's 2007 paper, @emph{Applications
+of fold to XML transformation}.
address@hidden deffn
+
address@hidden {Scheme Procedure} fold-layout tree bindings params layout
stylesheet
+A traversal combinator in the spirit of @code{pre-post-order}.
address@hidden SXML}.
+
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 defun
address@hidden post-handler
+A function of five arguments:
address@hidden transform address@hidden foldts fdown fup fhere seed tree
address@hidden defun
address@hidden @var
address@hidden tag
+the current tag being processed
address@hidden transform address@hidden post-order tree bindings
address@hidden defun
address@hidden params
+the params of the current node
address@hidden transform address@hidden pre-post-order tree bindings
address@hidden defun
address@hidden layout
+the layout coming into the current node, before any kids were processed
address@hidden transform address@hidden replace-range beg-pred end-pred forest
address@hidden defun
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 sxml xpath
address@hidden (sxml xpath)
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
address@hidden deffn
+
address@hidden SXPath
address@hidden SXPath
@subsubsection Overview
@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
+(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
+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
+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
+suitable for querying as it is. Bowing to the XPath specification, we
will refer to SXML information items as 'Nodes':
@example
@@ -610,124 +696,217 @@ An (ordered) set of nodes is just a list of the
constituent nodes:
<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
+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
+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
+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
+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
+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
+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
+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
+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
+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
+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
+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.
@subsubsection Usage
address@hidden xpath address@hidden nodeset? x
address@hidden defun
address@hidden {Scheme Procedure} nodeset? x
address@hidden deffn
address@hidden xpath address@hidden node-typeof? crit
address@hidden defun
address@hidden {Scheme Procedure} node-typeof? crit
address@hidden deffn
address@hidden xpath address@hidden node-eq? other
address@hidden defun
address@hidden {Scheme Procedure} node-eq? other
address@hidden deffn
address@hidden xpath address@hidden node-equal? other
address@hidden defun
address@hidden {Scheme Procedure} node-equal? other
address@hidden deffn
address@hidden xpath address@hidden node-pos n
address@hidden defun
address@hidden {Scheme Procedure} node-pos n
address@hidden deffn
address@hidden xpath address@hidden filter pred?
address@hidden {Scheme Procedure} filter pred?
@verbatim
-- Scheme Procedure: filter pred list
Return all the elements of 2nd arg LIST that satisfy predicate
PRED. The list is not disordered - elements that appear in the
result list occur in the same order as they occur in the argument
- list. The returned list may share a common tail with the argument
- list. The dynamic order in which the various applications of pred
+ list. The returned list may share a common tail with the argument
+ list. The dynamic order in which the various applications of pred
are made is not specified.
(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)
@end verbatim
address@hidden deffn
address@hidden defun
-
address@hidden xpath address@hidden take-until pred?
address@hidden defun
address@hidden {Scheme Procedure} take-until pred?
address@hidden deffn
address@hidden xpath address@hidden take-after pred?
address@hidden defun
address@hidden {Scheme Procedure} take-after pred?
address@hidden deffn
address@hidden xpath address@hidden map-union proc lst
address@hidden defun
address@hidden {Scheme Procedure} map-union proc lst
address@hidden deffn
address@hidden xpath address@hidden node-reverse node-or-nodeset
address@hidden defun
address@hidden {Scheme Procedure} node-reverse node-or-nodeset
address@hidden deffn
address@hidden xpath address@hidden node-trace title
address@hidden defun
address@hidden {Scheme Procedure} node-trace title
address@hidden deffn
address@hidden xpath address@hidden select-kids test-pred?
address@hidden defun
address@hidden {Scheme Procedure} select-kids test-pred?
address@hidden deffn
address@hidden xpath address@hidden node-self pred?
address@hidden {Scheme Procedure} node-self pred?
@verbatim
-- Scheme Procedure: filter pred list
Return all the elements of 2nd arg LIST that satisfy predicate
PRED. The list is not disordered - elements that appear in the
result list occur in the same order as they occur in the argument
- list. The returned list may share a common tail with the argument
- list. The dynamic order in which the various applications of pred
+ list. The returned list may share a common tail with the argument
+ list. The dynamic order in which the various applications of pred
are made is not specified.
(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)
@end verbatim
address@hidden deffn
address@hidden defun
address@hidden {Scheme Procedure} node-join . selectors
address@hidden deffn
address@hidden xpath address@hidden node-join . selectors
address@hidden defun
address@hidden {Scheme Procedure} node-reduce . converters
address@hidden deffn
address@hidden xpath address@hidden node-reduce . converters
address@hidden defun
address@hidden {Scheme Procedure} node-or . converters
address@hidden deffn
address@hidden xpath address@hidden node-or . converters
address@hidden defun
address@hidden {Scheme Procedure} node-closure test-pred?
address@hidden deffn
address@hidden xpath address@hidden node-closure test-pred?
address@hidden defun
address@hidden {Scheme Procedure} node-parent rootnode
address@hidden deffn
address@hidden xpath address@hidden node-parent rootnode
address@hidden defun
address@hidden {Scheme Procedure} sxpath path
address@hidden deffn
+
address@hidden sxml ssax input-parse
address@hidden (sxml ssax input-parse)
address@hidden Overview
+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
address@hidden The arguments will be of the form @code{(@var{port}
address@hidden @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
address@hidden to query the current position. @var{message} is the
+description of the error. Other arguments supply more details about the
+problem.
+
address@hidden Usage
address@hidden {Scheme Procedure} peek-next-char [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} assert-curr-char expected-chars comment [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} skip-until arg [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} skip-while skip-chars [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} next-token prefix-skipped-chars break-chars
[comment] [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} next-token-of incl-list/pred [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} read-text-line [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} read-string n [port]
address@hidden deffn
+
address@hidden {Scheme Procedure} find-string-from-port? _ _ . _
+Looks for @var{str} in @var{<input-port>}, optionally within the first
address@hidden characters.
address@hidden deffn
+
address@hidden sxml apply-templates
address@hidden (sxml apply-templates)
address@hidden Overview
+Pre-order traversal of a tree and creation of a new tree:
+
address@hidden
+ apply-templates:: tree x <templates> -> <new-tree>
address@hidden smallexample
+
+where
+
address@hidden
+ <templates> ::= (<template> ...)
+ <template> ::= (<node-test> <node-test> ... <node-test> . <handler>)
+ <node-test> ::= an argument to node-typeof? above
+ <handler> ::= <tree> -> <new-tree>
address@hidden 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
address@hidden function of XSLT.
+
address@hidden Usage
address@hidden {Scheme Procedure} apply-templates tree templates
address@hidden deffn
address@hidden xpath address@hidden sxpath path
address@hidden defun
diff --git a/doc/ref/texinfo.texi b/doc/ref/texinfo.texi
index b2947fc..ec06863 100644
--- a/doc/ref/texinfo.texi
+++ b/doc/ref/texinfo.texi
@@ -3,8 +3,12 @@
@c Copyright (C) 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
address@hidden Texinfo
address@hidden Texinfo
address@hidden Note: Don't use "Texinfo" as the node name here because this
leads to
address@hidden a clash in the HTML output between texinfo.html (from the
"texinfo"
address@hidden node) and Texinfo.html on case-insensitive file systems such as
address@hidden HFS+ (MacOS X).
address@hidden Texinfo Processing
address@hidden Texinfo Processing
@menu
* texinfo:: Parse texinfo files or fragments into @code{stexi}, a
scheme representation
@@ -152,8 +156,8 @@ interested in @code{replace-titles} and
@code{filter-empty-elements}.
@xref{texinfo 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.
+Returns a nodeset; that is to say, an untagged list of stexi elements.
address@hidden, for the definition of a nodeset.
@end defun
@@ -184,10 +188,12 @@ For example:
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.
+that it must eventually be serialized by @code{sxml->xml}.
address@hidden and Writing XML}.
+
+References (i.e., the @code{@@ref} family of commands) are resolved by a
address@hidden @xref{texinfo html
+add-ref-resolver!,add-ref-resolver!}.
@subsubsection Usage
@anchor{texinfo html address@hidden add-ref-resolver! proc
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 0f69089..0d41f9f 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -10,7 +10,7 @@
@cindex HTTP
It has always been possible to connect computers together and share
-information between them, but the rise of the World-Wide Web over the
+information between them, but the rise of the World Wide Web over the
last couple of decades has made it much easier to do so. The result is
a richly connected network of computation, in which Guile forms a part.
@@ -127,8 +127,8 @@ basic idea is that HTML is either text, represented by a
string, or an
element, represented as a tagged list. So @samp{foo} becomes
@samp{"foo"}, and @samp{<b>foo</b>} becomes @samp{(b "foo")}.
Attributes, if present, go in a tagged list headed by @samp{@@}, like
address@hidden(img (@@ (src "http://example.com/foo.png";)))}. @xref{sxml
-simple}, for more information.
address@hidden(img (@@ (src "http://example.com/foo.png";)))}. @xref{SXML}, for
+more information.
The good thing about SXML is that HTML elements cannot be confused with
text. Let's make a new definition of @code{para}:
@@ -206,9 +206,10 @@ The following procedures can be found in the @code{(web
uri)}
module. Load it into your Guile, using a form like the above, to have
access to them.
address@hidden {Scheme Procedure} build-uri scheme [#:address@hidden
[#:address@hidden @
- [#:address@hidden [#:address@hidden""}] [#:address@hidden @
- [#:address@hidden [#:address@hidden
address@hidden {Scheme Procedure} build-uri scheme @
+ [#:address@hidden [#:address@hidden [#:address@hidden @
+ [#:address@hidden""}] [#:address@hidden [#:address@hidden @
+ [#:address@hidden
Construct a URI object. @var{scheme} should be a symbol, @var{port}
either a positive, exact integer or @code{#f}, and the rest of the
fields are either strings or @code{#f}. If @var{validate?} is true,
@@ -216,7 +217,7 @@ also run some consistency checks to make sure that the
constructed URI
is valid.
@end deffn
address@hidden {Scheme Procedure} uri? x
address@hidden {Scheme Procedure} uri? obj
@deffnx {Scheme Procedure} uri-scheme uri
@deffnx {Scheme Procedure} uri-userinfo uri
@deffnx {Scheme Procedure} uri-host uri
@@ -249,9 +250,9 @@ Percent-decode the given @var{str}, according to
@var{encoding}, which
should be the name of a character encoding.
Note that this function should not generally be applied to a full URI
-string. For paths, use split-and-decode-uri-path instead. For query
-strings, split the query on @code{&} and @code{=} boundaries, and decode
-the components separately.
+string. For paths, use @code{split-and-decode-uri-path} instead. For
+query strings, split the query on @code{&} and @code{=} boundaries, and
+decode the components separately.
Note also that percent-encoded strings encode @emph{bytes}, not
characters. There is no guarantee that a given byte sequence is a valid
@@ -351,8 +352,8 @@ parsing and serialization procedures. If a header is
unknown, its
string name is simply its symbol name in title-case.
@deffn {Scheme Procedure} known-header? sym
-Return @code{#t} iff @var{sym} is a known header, with associated
-parsers and serialization procedures.
+Return @code{#t} if @var{sym} is a known header, with associated
+parsers and serialization procedures, or @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} header-parser sym
@@ -378,7 +379,8 @@ For more on the set of headers that Guile knows about out
of the box,
@pxref{HTTP Headers}. To add your own, use the @code{declare-header!}
procedure:
address@hidden {Scheme Procedure} declare-header! name parser validator writer
[#:address@hidden
address@hidden {Scheme Procedure} declare-header! name parser validator writer @
+ [#:address@hidden
Declare a parser, validator, and writer for a given header.
@end deffn
@@ -405,8 +407,8 @@ you want a header's value to be returned/written ``as-is''.
@end deffn
@deffn {Scheme Procedure} valid-header? sym val
-Return a true value iff @var{val} is a valid Scheme value for the header
-with name @var{sym}.
+Return a true value if @var{val} is a valid Scheme value for the header
+with name @var{sym}, or @code{#f} otherwise.
@end deffn
Now that we have a generic interface for reading and writing headers, we
@@ -450,7 +452,7 @@ like @code{GET}.
@end deffn
@deffn {Scheme Procedure} parse-http-version str [start] [end]
-Parse an HTTP version from @var{str}, returning it as a major-minor
+Parse an HTTP version from @var{str}, returning it as a major--minor
pair. For example, @code{HTTP/1.1} parses as the pair of integers,
@code{(1 . 1)}.
@end deffn
@@ -471,7 +473,7 @@ Write the first line of an HTTP request to @var{port}.
@deffn {Scheme Procedure} read-response-line port
Read the first line of an HTTP response from @var{port}, returning three
-values: the HTTP version, the response code, and the "reason phrase".
+values: the HTTP version, the response code, and the ``reason phrase''.
@end deffn
@deffn {Scheme Procedure} write-response-line version code reason-phrase port
@@ -1130,13 +1132,13 @@ any loss of generality.
@subsubsection Request API
address@hidden {Scheme Procedure} request?
address@hidden {Scheme Procedure} request-method
address@hidden {Scheme Procedure} request-uri
address@hidden {Scheme Procedure} request-version
address@hidden {Scheme Procedure} request-headers
address@hidden {Scheme Procedure} request-meta
address@hidden {Scheme Procedure} request-port
address@hidden {Scheme Procedure} request? obj
address@hidden {Scheme Procedure} request-method request
address@hidden {Scheme Procedure} request-uri request
address@hidden {Scheme Procedure} request-version request
address@hidden {Scheme Procedure} request-headers request
address@hidden {Scheme Procedure} request-meta request
address@hidden {Scheme Procedure} request-port request
A predicate and field accessors for the request type. The fields are as
follows:
@table @code
@@ -1170,7 +1172,9 @@ request, you may read the body separately, and likewise
for writing
requests.
@end deffn
address@hidden {Scheme Procedure} build-request uri [#:method='GET]
[#:version='(1 . 1)] [#:headers='()] [#:port=#f] [#:meta='()]
[#:validate-headers?=#t]
address@hidden {Scheme Procedure} build-request uri [#:method='GET] @
+ [#:version='(1 . 1)] [#:headers='()] [#:port=#f] [#:meta='()] @
+ [#:validate-headers?=#t]
Construct an HTTP request object. If @var{validate-headers?} is true,
the headers are each run through their respective validators.
@end deffn
@@ -1253,12 +1257,12 @@ A helper routine to determine the absolute URI of a
request, using the
As with requests (@pxref{Requests}), Guile offers a data type for HTTP
responses. Again, the body is represented separately from the request.
address@hidden {Scheme Procedure} response?
address@hidden {Scheme Procedure} response-version
address@hidden {Scheme Procedure} response-code
address@hidden {Scheme Procedure} response? obj
address@hidden {Scheme Procedure} response-version response
address@hidden {Scheme Procedure} response-code response
@deffnx {Scheme Procedure} response-reason-phrase response
address@hidden {Scheme Procedure} response-headers
address@hidden {Scheme Procedure} response-port
address@hidden {Scheme Procedure} response-headers response
address@hidden {Scheme Procedure} response-port response
A predicate and field accessors for the response type. The fields are as
follows:
@table @code
@@ -1384,6 +1388,10 @@ Return @code{#t} if @var{type}, a symbol as returned by
@code{(web client)} provides a simple, synchronous HTTP client, built on
the lower-level HTTP, request, and response modules.
address@hidden
+(use-modules (web client))
address@hidden example
+
@deffn {Scheme Procedure} open-socket-for-uri uri
Return an open input/output port for a connection to URI.
@end deffn
@@ -1419,9 +1427,9 @@ If you already have a port open, pass it as @var{port}.
Otherwise, a
connection will be opened to the server corresponding to @var{uri}. Any
extra headers in the alist @var{headers} will be added to the request.
-If @var{body} is not #f, a message body will also be sent with the HTTP
-request. If @var{body} is a string, it is encoded according to the
-content-type in @var{headers}, defaulting to UTF-8. Otherwise
+If @var{body} is not @code{#f}, a message body will also be sent with
+the HTTP request. If @var{body} is a string, it is encoded according to
+the content-type in @var{headers}, defaulting to UTF-8. Otherwise
@var{body} should be a bytevector, or @code{#f} for no body. Although a
message body may be sent with any request, usually only @code{POST} and
@code{PUT} requests have bodies.
@@ -1480,8 +1488,8 @@ The life cycle of a server goes as follows:
@enumerate
@item
-The @code{open} hook is called, to open the server. @code{open} takes 0 or
-more arguments, depending on the backend, and returns an opaque
+The @code{open} hook is called, to open the server. @code{open} takes
+zero or more arguments, depending on the backend, and returns an opaque
server socket object, or signals an error.
@item
@@ -1578,8 +1586,8 @@ in, allowing the user's handler to explicitly manage its
state.
@end deffn
@deffn {Scheme Procedure} sanitize-response request response body
-"Sanitize" the given response and body, making them appropriate for the
-given request.
+``Sanitize'' the given response and body, making them appropriate for
+the given request.
As a convenience to web handler authors, @var{response} may be given as
an alist of headers, in which case it is used to construct a default
@@ -1615,7 +1623,9 @@ and body, and write the response to the client. Return
the new state
produced by the handler procedure.
@end deffn
address@hidden {Scheme Procedure} run-server handler [impl='http]
[open-params='()] . state
address@hidden {Scheme Procedure} run-server handler @
+ [impl='http] [open-params='()] @
+ arg @dots{}
Run Guile's built-in web server.
@var{handler} should be a procedure that takes two or more arguments,
@@ -1627,16 +1637,20 @@ For examples, skip ahead to the next section, @ref{Web
Examples}.
The response and body will be run through @code{sanitize-response}
before sending back to the client.
-Additional arguments to @var{handler} are taken from @var{state}.
-Additional return values are accumulated into a new @var{state}, which
-will be used for subsequent requests. In this way a handler can
-explicitly manage its state.
+Additional arguments to @var{handler} are taken from @var{arg}
address@hidden These arguments comprise a @dfn{state}. Additional return
+values are accumulated into a new state, which will be used for
+subsequent requests. In this way a handler can explicitly manage its
+state.
@end deffn
The default web server implementation is @code{http}, which binds to a
socket, listening for request on that port.
address@hidden {HTTP Implementation} http [#:host=#f] [#:family=AF_INET]
[#:addr=INADDR_LOOPBACK] [#:port 8080] [#:socket]
address@hidden {HTTP Implementation} http [#:host=#f] @
+ [#:family=AF_INET] @
+ [#:addr=INADDR_LOOPBACK] @
+ [#:port 8080] [#:socket]
The default HTTP implementation. We document it as a function with
keyword arguments, because that is precisely the way that it is -- all
of the @var{open-params} to @code{run-server} get passed to the
@@ -1769,7 +1783,7 @@ message body is long enough.)
The web handler interface is a common baseline that all kinds of Guile
web applications can use. You will usually want to build something on
top of it, however, especially when producing HTML. Here is a simple
-example that builds up HTML output using SXML (@pxref{sxml simple}).
+example that builds up HTML output using SXML (@pxref{SXML}).
First, load up the modules:
diff --git a/doc/release.org b/doc/release.org
index 95ba12e..875ec27 100644
--- a/doc/release.org
+++ b/doc/release.org
@@ -1,5 +1,6 @@
#+TITLE: Release Process for GNU Guile 2.0
#+AUTHOR: Ludovic Courtès
+#+STARTUP: content
#+EMAIL: address@hidden
This document describes the typical release process for Guile 2.0.
@@ -53,7 +54,6 @@ If you're still in a good mood, you may also want to check on
porter
boxes for other OSes. The GNU/Hurd people have
[[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], and
so do
the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]] and
the
[[http://lists.gnu.org/archive/html/autoconf/2012-11/msg00039.html][Snakebite]]
project.
-
*** Post a pre-release announcement to address@hidden'
Send a link to
[[http://hydra.nixos.org/job/gnu/guile-2-0/tarball/latest/download-by-type/file/source-dist][the
latest tarball]]. This will allow readers to test on
@@ -87,15 +87,14 @@ The tag *must* be `v2.0.X'. For the sake of consistency,
always use
Normally nobody committed in the meantime. ;-)
-** Run "make dist"
+** Run "make distcheck"
This should trigger an `autoreconf', as `build-aux/git-version-gen'
-notices the new tag. After "make dist", double-check that `./configure
---version' reports the new version number.
+notices the new tag. Make sure you have configured with all options
+enabled (Readline, --enable-deprecated, etc.)
-The reason for running "make dist" instead of "make distcheck" is that
-it's much faster and any distribution issues should have been caught by
-Hydra already.
+After "make distcheck", double-check that `./configure --version'
+reports the new version number.
** Upload
@@ -146,7 +145,7 @@ Use `build-aux/gendocs', add to the manual/ directory of
the web site.
$ build-aux/announce-gen --release-type=stable --package-name=guile \
--previous-version=2.0.1 --current-version=2.0.2 \
--gpg-key-id=MY-KEY --url-directory=ftp://ftp.gnu.org/gnu/guile \
- --bootstrap-tools=autoconf,automake,libtool,gnulib \
+ --bootstrap-tools=autoconf,automake,libtool,gnulib,makeinfo \
--gnulib-version=$( cd ~/src/gnulib ; git describe )
The subject must be "GNU Guile 2.0.X released". The text should remain
@@ -174,7 +173,7 @@ more informal, with a link to the email announcement for
details.
-Copyright © 2011, 2012 Free Software Foundation, Inc.
+Copyright © 2011, 2012, 2013 Free Software Foundation, Inc.
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
diff --git a/gnulib-local/build-aux/git-version-gen.diff
b/gnulib-local/build-aux/git-version-gen.diff
index c222a99..f875f49 100644
--- a/gnulib-local/build-aux/git-version-gen.diff
+++ b/gnulib-local/build-aux/git-version-gen.diff
@@ -2,47 +2,33 @@ This patch is being discussed
at <http://lists.gnu.org/archive/html/bug-gnulib/2012-07/msg00079.html>.
Remove when integrated in Gnulib.
---- a/build-aux/git-version-gen 2012-06-12 21:25:48.000000000 +0200
-+++ b/build-aux/git-version-gen 2012-07-07 01:52:08.000000000 +0200
-@@ -1,6 +1,6 @@
- #!/bin/sh
- # Print a version string.
--scriptversion=2012-03-18.17; # UTC
-+scriptversion=2012-07-06.14; # UTC
-
- # Copyright (C) 2007-2012 Free Software Foundation, Inc.
- #
-@@ -85,20 +85,25 @@
-
+--- a/build-aux/git-version-gen
++++ b/build-aux/git-version-gen
+@@ -86,6 +86,7 @@ Print a version string.
Options:
-- --prefix prefix of git tags (default 'v')
-+ --prefix prefix of git tags to strip from version (default 'v')
-+ --match pattern for git tags to match (default: '\$prefix*')
-
-- --help display this help and exit
-- --version output version information and exit
-+ --help display this help and exit
-+ --version output version information and exit
-
--Running without arguments will suffice in most cases."
-+Running without arguments will suffice in most cases. If no --match
-+argument is given, only match tags that begin with the --prefix."
+ --prefix prefix of git tags (default 'v')
++ --match pattern for git tags to match (default: '\$prefix*')
+ --fallback fallback version to use if \"git --version\" fails
+ --help display this help and exit
+@@ -96,11 +97,15 @@ Running without arguments will suffice in most cases."
prefix=v
+ fallback=
+
+unset match
+unset tag_sed_script
-
++
while test $# -gt 0; do
case $1 in
--help) echo "$usage"; exit 0;;
--version) echo "$version"; exit 0;;
--prefix) shift; prefix="$1";;
+ --match) shift; match="$1";;
+ --fallback) shift; fallback="$1";;
-*)
echo "$0: Unknown option '$1'." >&2
- echo "$0: Try '--help' for more information." >&2
-@@ -121,6 +126,7 @@
+@@ -124,6 +129,7 @@ if test "x$tarball_version_file" = x; then
exit 1
fi
@@ -50,13 +36,12 @@ Remove when integrated in Gnulib.
tag_sed_script="${tag_sed_script:-s/x/x/}"
nl='
-@@ -151,8 +157,7 @@
+@@ -154,7 +160,7 @@ then
# directory, and "git describe" output looks sensible, use that to
# derive a version string.
elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
- && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
-- || git describe --abbrev=4 HEAD 2>/dev/null` \
-+ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
++ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null \
+ || git describe --abbrev=4 HEAD 2>/dev/null` \
&& v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
&& case $v in
- $prefix[0-9]*) ;;
diff --git a/guile-readline/readline.c b/guile-readline/readline.c
index 1e697eb..aac6e18 100644
--- a/guile-readline/readline.c
+++ b/guile-readline/readline.c
@@ -1,6 +1,7 @@
/* readline.c --- line editing support for Guile */
-/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009,
2010, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008,
+ * 2009, 2010, 2013 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
@@ -27,19 +28,13 @@
#ifdef HAVE_RL_GETC_FUNCTION
#include "libguile.h"
-#include "libguile/iselect.h"
#include <stdio.h>
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#endif
#include <readline/readline.h>
#include <readline/history.h>
-#ifndef __MINGW32__
#include <sys/time.h>
-#else
-#include <io.h>
-#endif
+#include <sys/select.h>
#include <signal.h>
#include "libguile/validate.h"
@@ -207,10 +202,8 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0,
scm_dynwind_end ();
-#ifndef __MINGW32__
fclose (rl_instream);
fclose (rl_outstream);
-#endif
--in_readline;
return ans;
@@ -240,10 +233,8 @@ unwind_readline (void *unused)
rl_free_line_state ();
rl_cleanup_after_signal ();
fputc ('\n', rl_outstream); /* We don't want next output on this line */
-#ifndef __MINGW32__
fclose (rl_instream);
fclose (rl_outstream);
-#endif
--in_readline;
}
@@ -314,10 +305,8 @@ scm_readline_init_ports (SCM inp, SCM outp)
input_port = inp;
output_port = outp;
-#ifndef __MINGW32__
rl_instream = stream_from_fport (inp, "r", s_scm_readline);
rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
-#endif
}
@@ -489,11 +478,9 @@ static int
match_paren (int x, int k)
{
int tmp;
-#ifndef __MINGW32__
int fno;
- SELECT_TYPE readset;
+ fd_set readset;
struct timeval timeout;
-#endif
rl_insert (x, k);
if (!SCM_READLINE_BOUNCE_PARENS)
@@ -504,14 +491,12 @@ match_paren (int x, int k)
&& rl_line_buffer[rl_point - 2] == '\\')
return 0;
-#ifndef __MINGW32__
tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
timeout.tv_sec = tmp / 1000000;
timeout.tv_usec = tmp % 1000000;
FD_ZERO (&readset);
fno = fileno (rl_instream);
FD_SET (fno, &readset);
-#endif
if (rl_point > 1)
{
@@ -520,12 +505,7 @@ match_paren (int x, int k)
if (rl_point > -1)
{
rl_redisplay ();
-#ifndef __MINGW32__
- scm_std_select (fno + 1, &readset, NULL, NULL, &timeout);
-#else
- WaitForSingleObject (GetStdHandle(STD_INPUT_HANDLE),
- SCM_READLINE_BOUNCE_PARENS);
-#endif
+ select (fno + 1, &readset, NULL, NULL, &timeout);
}
rl_point = tmp;
}
@@ -542,9 +522,7 @@ scm_init_readline ()
#include "guile-readline/readline.x"
scm_readline_completion_function_var
= scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
-#ifndef __MINGW32__
rl_getc_function = current_input_getc;
-#endif
#if defined (_RL_FUNCTION_TYPEDEF)
rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
#else
diff --git a/lib/Makefile.am b/lib/Makefile.am
index 49c5140..8857a90 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-2012 Free Software Foundation, Inc.
+# Copyright (C) 2002-2013 Free Software Foundation, Inc.
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -21,7 +21,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local
--lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp full-read full-write func
gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen
gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf
inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility
libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu
malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send
sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh
string sys_stat trunc verify vsnprintf warnings wchar
+# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local
--lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close
connect dirfd duplocale environ extensions flock floor fpieee frexp fstat
full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname
getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload
havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp
lib-symbol-versions lib-symbol-visibility libunistring listen localcharset
locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open
pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto
setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string
sys_stat time times trunc verify vsnprintf warnings wchar
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
@@ -62,6 +62,8 @@ libgnu_la_LDFLAGS += $(ISNANL_LIBM)
libgnu_la_LDFLAGS += $(LDEXP_LIBM)
libgnu_la_LDFLAGS += $(LIBSOCKET)
libgnu_la_LDFLAGS += $(LIB_CLOCK_GETTIME)
+libgnu_la_LDFLAGS += $(LIB_POLL)
+libgnu_la_LDFLAGS += $(LIB_SELECT)
libgnu_la_LDFLAGS += $(LOG1P_LIBM)
libgnu_la_LDFLAGS += $(LOG_LIBM)
libgnu_la_LDFLAGS += $(LTLIBICONV)
@@ -87,6 +89,17 @@ EXTRA_DIST += alignof.h
## end gnulib module alignof
+## begin gnulib module alloca
+
+
+libgnu_la_LIBADD += @LTALLOCA@
+libgnu_la_DEPENDENCIES += @LTALLOCA@
+EXTRA_DIST += alloca.c
+
+EXTRA_libgnu_la_SOURCES += alloca.c
+
+## end gnulib module alloca
+
## begin gnulib module alloca-opt
BUILT_SOURCES += $(ALLOCA_H)
@@ -371,6 +384,15 @@ EXTRA_DIST += dosname.h
## end gnulib module dosname
+## begin gnulib module dup2
+
+
+EXTRA_DIST += dup2.c
+
+EXTRA_libgnu_la_SOURCES += dup2.c
+
+## end gnulib module dup2
+
## begin gnulib module duplocale
@@ -556,6 +578,15 @@ EXTRA_libgnu_la_SOURCES += gai_strerror.c getaddrinfo.c
## end gnulib module getaddrinfo
+## begin gnulib module getlogin
+
+
+EXTRA_DIST += getlogin.c
+
+EXTRA_libgnu_la_SOURCES += getlogin.c
+
+## end gnulib module getlogin
+
## begin gnulib module getpeername
@@ -1006,6 +1037,7 @@ EXTRA_DIST += malloca.h malloca.valgrind
## begin gnulib module math
BUILT_SOURCES += math.h
+libgnu_la_SOURCES += math.c
# We need the following in order to create <math.h> when the system
# doesn't have one that works with the given compiler.
@@ -1438,12 +1470,59 @@ EXTRA_DIST += pathmax.h
## end gnulib module pathmax
+## begin gnulib module pipe-posix
+
+
+EXTRA_DIST += pipe.c
+
+EXTRA_libgnu_la_SOURCES += pipe.c
+
+## end gnulib module pipe-posix
+
## begin gnulib module pipe2
libgnu_la_SOURCES += pipe2.c
## end gnulib module pipe2
+## begin gnulib module poll
+
+
+EXTRA_DIST += poll.c
+
+EXTRA_libgnu_la_SOURCES += poll.c
+
+## end gnulib module poll
+
+## begin gnulib module poll-h
+
+BUILT_SOURCES += poll.h
+
+# We need the following in order to create <poll.h> when the system
+# doesn't have one.
+poll.h: poll.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H)
+ $(AM_V_GEN)rm -f address@hidden $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''GUARD_PREFIX''@|GL|g' \
+ -e 's|@''HAVE_POLL_H''@|$(HAVE_POLL_H)|g' \
+ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
+ -e 's|@''NEXT_POLL_H''@|$(NEXT_POLL_H)|g' \
+ -e 's/@''GNULIB_POLL''@/$(GNULIB_POLL)/g' \
+ -e 's|@''HAVE_POLL''@|$(HAVE_POLL)|g' \
+ -e 's|@''REPLACE_POLL''@|$(REPLACE_POLL)|g' \
+ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
+ < $(srcdir)/poll.in.h; \
+ } > address@hidden && \
+ mv -f address@hidden $@
+MOSTLYCLEANFILES += poll.h poll.h-t
+
+EXTRA_DIST += poll.in.h
+
+## end gnulib module poll-h
+
## begin gnulib module putenv
@@ -1559,6 +1638,15 @@ EXTRA_DIST += same-inode.h
## end gnulib module same-inode
+## begin gnulib module select
+
+
+EXTRA_DIST += select.c
+
+EXTRA_libgnu_la_SOURCES += select.c
+
+## end gnulib module select
+
## begin gnulib module send
@@ -2093,6 +2181,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status
$(CXXDEFS_H) \
-e 's/@''GNULIB_REALLOC_POSIX''@/$(GNULIB_REALLOC_POSIX)/g' \
-e 's/@''GNULIB_REALPATH''@/$(GNULIB_REALPATH)/g' \
-e 's/@''GNULIB_RPMATCH''@/$(GNULIB_RPMATCH)/g' \
+ -e 's/@''GNULIB_SECURE_GETENV''@/$(GNULIB_SECURE_GETENV)/g' \
-e 's/@''GNULIB_SETENV''@/$(GNULIB_SETENV)/g' \
-e 's/@''GNULIB_STRTOD''@/$(GNULIB_STRTOD)/g' \
-e 's/@''GNULIB_STRTOLL''@/$(GNULIB_STRTOLL)/g' \
@@ -2121,6 +2210,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status
$(CXXDEFS_H) \
-e 's|@''HAVE_RANDOM_R''@|$(HAVE_RANDOM_R)|g' \
-e 's|@''HAVE_REALPATH''@|$(HAVE_REALPATH)|g' \
-e 's|@''HAVE_RPMATCH''@|$(HAVE_RPMATCH)|g' \
+ -e 's|@''HAVE_SECURE_GETENV''@|$(HAVE_SECURE_GETENV)|g' \
-e 's|@''HAVE_DECL_SETENV''@|$(HAVE_DECL_SETENV)|g' \
-e 's|@''HAVE_STRTOD''@|$(HAVE_STRTOD)|g' \
-e 's|@''HAVE_STRTOLL''@|$(HAVE_STRTOLL)|g' \
@@ -2311,9 +2401,44 @@ EXTRA_DIST += sys_file.in.h
## end gnulib module sys_file
+## begin gnulib module sys_select
+
+BUILT_SOURCES += sys/select.h
+
+# We need the following in order to create <sys/select.h> when the system
+# doesn't have one that works with the given compiler.
+sys/select.h: sys_select.in.h $(top_builddir)/config.status $(CXXDEFS_H)
$(WARN_ON_USE_H)
+ $(AM_V_at)$(MKDIR_P) sys
+ $(AM_V_GEN)rm -f address@hidden $@ && \
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's|@''GUARD_PREFIX''@|GL|g' \
+ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
+ -e 's|@''NEXT_SYS_SELECT_H''@|$(NEXT_SYS_SELECT_H)|g' \
+ -e 's|@''HAVE_SYS_SELECT_H''@|$(HAVE_SYS_SELECT_H)|g' \
+ -e 's/@''GNULIB_PSELECT''@/$(GNULIB_PSELECT)/g' \
+ -e 's/@''GNULIB_SELECT''@/$(GNULIB_SELECT)/g' \
+ -e 's|@''HAVE_WINSOCK2_H''@|$(HAVE_WINSOCK2_H)|g' \
+ -e 's|@''HAVE_PSELECT''@|$(HAVE_PSELECT)|g' \
+ -e 's|@''REPLACE_PSELECT''@|$(REPLACE_PSELECT)|g' \
+ -e 's|@''REPLACE_SELECT''@|$(REPLACE_SELECT)|g' \
+ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
+ < $(srcdir)/sys_select.in.h; \
+ } > address@hidden && \
+ mv address@hidden $@
+MOSTLYCLEANFILES += sys/select.h sys/select.h-t
+MOSTLYCLEANDIRS += sys
+
+EXTRA_DIST += sys_select.in.h
+
+## end gnulib module sys_select
+
## begin gnulib module sys_socket
BUILT_SOURCES += sys/socket.h
+libgnu_la_SOURCES += sys_socket.c
# We need the following in order to create <sys/socket.h> when the system
# doesn't have one that works with the given compiler.
@@ -2458,6 +2583,37 @@ EXTRA_DIST += sys_time.in.h
## end gnulib module sys_time
+## begin gnulib module sys_times
+
+BUILT_SOURCES += sys/times.h
+
+# We need the following in order to create <sys/times.h> when the system
+# doesn't have one that works with the given compiler.
+sys/times.h: sys_times.in.h $(top_builddir)/config.status $(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! */'; \
+ sed -e 's|@''GUARD_PREFIX''@|GL|g' \
+ -e 's/@''HAVE_SYS_TIMES_H''@/$(HAVE_SYS_TIMES_H)/g' \
+ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
+ -e 's|@''NEXT_SYS_TIMES_H''@|$(NEXT_SYS_TIMES_H)|g' \
+ -e 's/@''GNULIB_TIMES''@/$(GNULIB_TIMES)/g' \
+ -e 's|@''HAVE_STRUCT_TMS''@|$(HAVE_STRUCT_TMS)|g' \
+ -e 's|@''HAVE_TIMES''@|$(HAVE_TIMES)|g' \
+ -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
+ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
+ < $(srcdir)/sys_times.in.h; \
+ } > address@hidden && \
+ mv address@hidden $@
+MOSTLYCLEANFILES += sys/times.h sys/times.h-t
+MOSTLYCLEANDIRS += sys
+
+EXTRA_DIST += sys_times.in.h
+
+## end gnulib module sys_times
+
## begin gnulib module sys_types
BUILT_SOURCES += sys/types.h
@@ -2560,6 +2716,15 @@ EXTRA_libgnu_la_SOURCES += time_r.c
## end gnulib module time_r
+## begin gnulib module times
+
+
+EXTRA_DIST += times.c
+
+EXTRA_libgnu_la_SOURCES += times.c
+
+## end gnulib module times
+
## begin gnulib module trunc
@@ -2572,6 +2737,7 @@ EXTRA_libgnu_la_SOURCES += trunc.c
## begin gnulib module unistd
BUILT_SOURCES += unistd.h
+libgnu_la_SOURCES += unistd.c
# We need the following in order to create an empty placeholder for
# <unistd.h> when the system doesn't have one.
@@ -2963,6 +3129,7 @@ EXTRA_libgnu_la_SOURCES += wcrtomb.c
## begin gnulib module wctype-h
BUILT_SOURCES += wctype.h
+libgnu_la_SOURCES += wctype-h.c
# We need the following in order to create <wctype.h> when the system
# doesn't have one that works with the given compiler.
diff --git a/lib/accept.c b/lib/accept.c
index 78bb822..0c8e52e 100644
--- a/lib/accept.c
+++ b/lib/accept.c
@@ -1,6 +1,6 @@
/* accept.c --- wrappers for Windows accept function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/alignof.h b/lib/alignof.h
index b6d8666..2bf3820 100644
--- a/lib/alignof.h
+++ b/lib/alignof.h
@@ -1,5 +1,5 @@
/* Determine alignment of types.
- Copyright (C) 2003-2004, 2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003-2004, 2006, 2009-2013 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.c b/lib/alloca.c
new file mode 100644
index 0000000..ee0f018
--- /dev/null
+++ b/lib/alloca.c
@@ -0,0 +1,478 @@
+/* alloca.c -- allocate automatically reclaimed memory
+ (Mostly) portable public-domain implementation -- D A Gwyn
+
+ This implementation of the PWB library alloca function,
+ which is used to allocate space off the run-time stack so
+ that it is automatically reclaimed upon procedure exit,
+ was inspired by discussions with J. Q. Johnson of Cornell.
+ J.Otto Tennant <address@hidden> contributed the Cray support.
+
+ There are some preprocessor constants that can
+ be defined when compiling for your specific system, for
+ improved efficiency; however, the defaults should be okay.
+
+ The general concept of this implementation is to keep
+ track of all alloca-allocated blocks, and reclaim any
+ that are found to be deeper in the stack than the current
+ invocation. This heuristic does not reclaim storage as
+ soon as it becomes invalid, but it will do so eventually.
+
+ As a special case, alloca(0) reclaims storage without
+ allocating any. It is a good idea to use alloca(0) in
+ your main control loop, etc. to force garbage collection. */
+
+#include <config.h>
+
+#include <alloca.h>
+
+#include <string.h>
+#include <stdlib.h>
+
+#ifdef emacs
+# include "lisp.h"
+# include "blockinput.h"
+# ifdef EMACS_FREE
+# undef free
+# define free EMACS_FREE
+# endif
+#else
+# define memory_full() abort ()
+#endif
+
+/* If compiling with GCC 2, this file's not needed. */
+#if !defined (__GNUC__) || __GNUC__ < 2
+
+/* If someone has defined alloca as a macro,
+ there must be some other way alloca is supposed to work. */
+# ifndef alloca
+
+# ifdef emacs
+# ifdef static
+/* actually, only want this if static is defined as ""
+ -- this is for usg, in which emacs must undefine static
+ in order to make unexec workable
+ */
+# ifndef STACK_DIRECTION
+you
+lose
+-- must know STACK_DIRECTION at compile-time
+/* Using #error here is not wise since this file should work for
+ old and obscure compilers. */
+# endif /* STACK_DIRECTION undefined */
+# endif /* static */
+# endif /* emacs */
+
+/* If your stack is a linked list of frames, you have to
+ provide an "address metric" ADDRESS_FUNCTION macro. */
+
+# if defined (CRAY) && defined (CRAY_STACKSEG_END)
+long i00afunc ();
+# define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
+# else
+# define ADDRESS_FUNCTION(arg) &(arg)
+# endif
+
+/* Define STACK_DIRECTION if you know the direction of stack
+ growth for your system; otherwise it will be automatically
+ deduced at run-time.
+
+ STACK_DIRECTION > 0 => grows toward higher addresses
+ STACK_DIRECTION < 0 => grows toward lower addresses
+ STACK_DIRECTION = 0 => direction of growth unknown */
+
+# ifndef STACK_DIRECTION
+# define STACK_DIRECTION 0 /* Direction unknown. */
+# endif
+
+# if STACK_DIRECTION != 0
+
+# define STACK_DIR STACK_DIRECTION /* Known at compile-time. */
+
+# else /* STACK_DIRECTION == 0; need run-time code. */
+
+static int stack_dir; /* 1 or -1 once known. */
+# define STACK_DIR stack_dir
+
+static int
+find_stack_direction (int *addr, int depth)
+{
+ int dir, dummy = 0;
+ if (! addr)
+ addr = &dummy;
+ *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1;
+ dir = depth ? find_stack_direction (addr, depth - 1) : 0;
+ return dir + dummy;
+}
+
+# endif /* STACK_DIRECTION == 0 */
+
+/* An "alloca header" is used to:
+ (a) chain together all alloca'ed blocks;
+ (b) keep track of stack depth.
+
+ It is very important that sizeof(header) agree with malloc
+ alignment chunk size. The following default should work okay. */
+
+# ifndef ALIGN_SIZE
+# define ALIGN_SIZE sizeof(double)
+# endif
+
+typedef union hdr
+{
+ char align[ALIGN_SIZE]; /* To force sizeof(header). */
+ struct
+ {
+ union hdr *next; /* For chaining headers. */
+ char *deep; /* For stack depth measure. */
+ } h;
+} header;
+
+static header *last_alloca_header = NULL; /* -> last alloca header. */
+
+/* Return a pointer to at least SIZE bytes of storage,
+ which will be automatically reclaimed upon exit from
+ the procedure that called alloca. Originally, this space
+ was supposed to be taken from the current stack frame of the
+ caller, but that method cannot be made to work for some
+ implementations of C, for example under Gould's UTX/32. */
+
+void *
+alloca (size_t size)
+{
+ auto char probe; /* Probes stack depth: */
+ register char *depth = ADDRESS_FUNCTION (probe);
+
+# if STACK_DIRECTION == 0
+ if (STACK_DIR == 0) /* Unknown growth direction. */
+ STACK_DIR = find_stack_direction (NULL, (size & 1) + 20);
+# endif
+
+ /* Reclaim garbage, defined as all alloca'd storage that
+ was allocated from deeper in the stack than currently. */
+
+ {
+ register header *hp; /* Traverses linked list. */
+
+# ifdef emacs
+ BLOCK_INPUT;
+# endif
+
+ for (hp = last_alloca_header; hp != NULL;)
+ if ((STACK_DIR > 0 && hp->h.deep > depth)
+ || (STACK_DIR < 0 && hp->h.deep < depth))
+ {
+ register header *np = hp->h.next;
+
+ free (hp); /* Collect garbage. */
+
+ hp = np; /* -> next header. */
+ }
+ else
+ break; /* Rest are not deeper. */
+
+ last_alloca_header = hp; /* -> last valid storage. */
+
+# ifdef emacs
+ UNBLOCK_INPUT;
+# endif
+ }
+
+ if (size == 0)
+ return NULL; /* No allocation required. */
+
+ /* Allocate combined header + user data storage. */
+
+ {
+ /* Address of header. */
+ register header *new;
+
+ size_t combined_size = sizeof (header) + size;
+ if (combined_size < sizeof (header))
+ memory_full ();
+
+ new = malloc (combined_size);
+
+ if (! new)
+ memory_full ();
+
+ new->h.next = last_alloca_header;
+ new->h.deep = depth;
+
+ last_alloca_header = new;
+
+ /* User storage begins just after header. */
+
+ return (void *) (new + 1);
+ }
+}
+
+# if defined (CRAY) && defined (CRAY_STACKSEG_END)
+
+# ifdef DEBUG_I00AFUNC
+# include <stdio.h>
+# endif
+
+# ifndef CRAY_STACK
+# define CRAY_STACK
+# ifndef CRAY2
+/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
+struct stack_control_header
+ {
+ long shgrow:32; /* Number of times stack has grown. */
+ long shaseg:32; /* Size of increments to stack. */
+ long shhwm:32; /* High water mark of stack. */
+ long shsize:32; /* Current size of stack (all segments). */
+ };
+
+/* The stack segment linkage control information occurs at
+ the high-address end of a stack segment. (The stack
+ grows from low addresses to high addresses.) The initial
+ part of the stack segment linkage control information is
+ 0200 (octal) words. This provides for register storage
+ for the routine which overflows the stack. */
+
+struct stack_segment_linkage
+ {
+ long ss[0200]; /* 0200 overflow words. */
+ long sssize:32; /* Number of words in this segment. */
+ long ssbase:32; /* Offset to stack base. */
+ long:32;
+ long sspseg:32; /* Offset to linkage control of previous
+ segment of stack. */
+ long:32;
+ long sstcpt:32; /* Pointer to task common address block. */
+ long sscsnm; /* Private control structure number for
+ microtasking. */
+ long ssusr1; /* Reserved for user. */
+ long ssusr2; /* Reserved for user. */
+ long sstpid; /* Process ID for pid based multi-tasking. */
+ long ssgvup; /* Pointer to multitasking thread giveup. */
+ long sscray[7]; /* Reserved for Cray Research. */
+ long ssa0;
+ long ssa1;
+ long ssa2;
+ long ssa3;
+ long ssa4;
+ long ssa5;
+ long ssa6;
+ long ssa7;
+ long sss0;
+ long sss1;
+ long sss2;
+ long sss3;
+ long sss4;
+ long sss5;
+ long sss6;
+ long sss7;
+ };
+
+# else /* CRAY2 */
+/* The following structure defines the vector of words
+ returned by the STKSTAT library routine. */
+struct stk_stat
+ {
+ long now; /* Current total stack size. */
+ long maxc; /* Amount of contiguous space which would
+ be required to satisfy the maximum
+ stack demand to date. */
+ long high_water; /* Stack high-water mark. */
+ long overflows; /* Number of stack overflow ($STKOFEN) calls.
*/
+ long hits; /* Number of internal buffer hits. */
+ long extends; /* Number of block extensions. */
+ long stko_mallocs; /* Block allocations by $STKOFEN. */
+ long underflows; /* Number of stack underflow calls ($STKRETN).
*/
+ long stko_free; /* Number of deallocations by $STKRETN. */
+ long stkm_free; /* Number of deallocations by $STKMRET. */
+ long segments; /* Current number of stack segments. */
+ long maxs; /* Maximum number of stack segments so far. */
+ long pad_size; /* Stack pad size. */
+ long current_address; /* Current stack segment address. */
+ long current_size; /* Current stack segment size. This
+ number is actually corrupted by STKSTAT to
+ include the fifteen word trailer area. */
+ long initial_address; /* Address of initial segment. */
+ long initial_size; /* Size of initial segment. */
+ };
+
+/* The following structure describes the data structure which trails
+ any stack segment. I think that the description in 'asdef' is
+ out of date. I only describe the parts that I am sure about. */
+
+struct stk_trailer
+ {
+ long this_address; /* Address of this block. */
+ long this_size; /* Size of this block (does not include
+ this trailer). */
+ long unknown2;
+ long unknown3;
+ long link; /* Address of trailer block of previous
+ segment. */
+ long unknown5;
+ long unknown6;
+ long unknown7;
+ long unknown8;
+ long unknown9;
+ long unknown10;
+ long unknown11;
+ long unknown12;
+ long unknown13;
+ long unknown14;
+ };
+
+# endif /* CRAY2 */
+# endif /* not CRAY_STACK */
+
+# ifdef CRAY2
+/* Determine a "stack measure" for an arbitrary ADDRESS.
+ I doubt that "lint" will like this much. */
+
+static long
+i00afunc (long *address)
+{
+ struct stk_stat status;
+ struct stk_trailer *trailer;
+ long *block, size;
+ long result = 0;
+
+ /* We want to iterate through all of the segments. The first
+ step is to get the stack status structure. We could do this
+ more quickly and more directly, perhaps, by referencing the
+ $LM00 common block, but I know that this works. */
+
+ STKSTAT (&status);
+
+ /* Set up the iteration. */
+
+ trailer = (struct stk_trailer *) (status.current_address
+ + status.current_size
+ - 15);
+
+ /* There must be at least one stack segment. Therefore it is
+ a fatal error if "trailer" is null. */
+
+ if (trailer == 0)
+ abort ();
+
+ /* Discard segments that do not contain our argument address. */
+
+ while (trailer != 0)
+ {
+ block = (long *) trailer->this_address;
+ size = trailer->this_size;
+ if (block == 0 || size == 0)
+ abort ();
+ trailer = (struct stk_trailer *) trailer->link;
+ if ((block <= address) && (address < (block + size)))
+ break;
+ }
+
+ /* Set the result to the offset in this segment and add the sizes
+ of all predecessor segments. */
+
+ result = address - block;
+
+ if (trailer == 0)
+ {
+ return result;
+ }
+
+ do
+ {
+ if (trailer->this_size <= 0)
+ abort ();
+ result += trailer->this_size;
+ trailer = (struct stk_trailer *) trailer->link;
+ }
+ while (trailer != 0);
+
+ /* We are done. Note that if you present a bogus address (one
+ not in any segment), you will get a different number back, formed
+ from subtracting the address of the first block. This is probably
+ not what you want. */
+
+ return (result);
+}
+
+# else /* not CRAY2 */
+/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
+ Determine the number of the cell within the stack,
+ given the address of the cell. The purpose of this
+ routine is to linearize, in some sense, stack addresses
+ for alloca. */
+
+static long
+i00afunc (long address)
+{
+ long stkl = 0;
+
+ long size, pseg, this_segment, stack;
+ long result = 0;
+
+ struct stack_segment_linkage *ssptr;
+
+ /* Register B67 contains the address of the end of the
+ current stack segment. If you (as a subprogram) store
+ your registers on the stack and find that you are past
+ the contents of B67, you have overflowed the segment.
+
+ B67 also points to the stack segment linkage control
+ area, which is what we are really interested in. */
+
+ stkl = CRAY_STACKSEG_END ();
+ ssptr = (struct stack_segment_linkage *) stkl;
+
+ /* If one subtracts 'size' from the end of the segment,
+ one has the address of the first word of the segment.
+
+ If this is not the first segment, 'pseg' will be
+ nonzero. */
+
+ pseg = ssptr->sspseg;
+ size = ssptr->sssize;
+
+ this_segment = stkl - size;
+
+ /* It is possible that calling this routine itself caused
+ a stack overflow. Discard stack segments which do not
+ contain the target address. */
+
+ while (!(this_segment <= address && address <= stkl))
+ {
+# ifdef DEBUG_I00AFUNC
+ fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
+# endif
+ if (pseg == 0)
+ break;
+ stkl = stkl - pseg;
+ ssptr = (struct stack_segment_linkage *) stkl;
+ size = ssptr->sssize;
+ pseg = ssptr->sspseg;
+ this_segment = stkl - size;
+ }
+
+ result = address - this_segment;
+
+ /* If you subtract pseg from the current end of the stack,
+ you get the address of the previous stack segment's end.
+ This seems a little convoluted to me, but I'll bet you save
+ a cycle somewhere. */
+
+ while (pseg != 0)
+ {
+# ifdef DEBUG_I00AFUNC
+ fprintf (stderr, "%011o %011o\n", pseg, size);
+# endif
+ stkl = stkl - pseg;
+ ssptr = (struct stack_segment_linkage *) stkl;
+ size = ssptr->sssize;
+ pseg = ssptr->sspseg;
+ result += size;
+ }
+ return (result);
+}
+
+# endif /* not CRAY2 */
+# endif /* CRAY */
+
+# endif /* no alloca */
+#endif /* not GCC 2 */
diff --git a/lib/alloca.in.h b/lib/alloca.in.h
index c36bdf9..19aea41 100644
--- a/lib/alloca.in.h
+++ b/lib/alloca.in.h
@@ -1,6 +1,6 @@
/* Memory allocation on the stack.
- Copyright (C) 1995, 1999, 2001-2004, 2006-2012 Free Software Foundation,
+ Copyright (C) 1995, 1999, 2001-2004, 2006-2013 Free Software Foundation,
Inc.
This program is free software; you can redistribute it and/or modify it
diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h
index e580723..5344a92 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2008-2013 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/asnprintf.c b/lib/asnprintf.c
index 778068f..8c399b2 100644
--- a/lib/asnprintf.c
+++ b/lib/asnprintf.c
@@ -1,5 +1,5 @@
/* Formatted output to strings.
- Copyright (C) 1999, 2002, 2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002, 2006, 2009-2013 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/basename-lgpl.c b/lib/basename-lgpl.c
index 8ddbfc3..5e89d26 100644
--- a/lib/basename-lgpl.c
+++ b/lib/basename-lgpl.c
@@ -1,6 +1,6 @@
/* basename.c -- return the last element in a file name
- Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2012 Free Software
+ Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2013 Free Software
Foundation, Inc.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/binary-io.h b/lib/binary-io.h
index 30315e1..b2095a2 100644
--- a/lib/binary-io.h
+++ b/lib/binary-io.h
@@ -1,5 +1,5 @@
/* Binary mode I/O.
- Copyright (C) 2001, 2003, 2005, 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2003, 2005, 2008-2013 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/bind.c b/lib/bind.c
index 1a2a3b6..e26f88e 100644
--- a/lib/bind.c
+++ b/lib/bind.c
@@ -1,6 +1,6 @@
/* bind.c --- wrappers for Windows bind function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/btowc.c b/lib/btowc.c
index 485e995..aca5742 100644
--- a/lib/btowc.c
+++ b/lib/btowc.c
@@ -1,5 +1,5 @@
/* Convert unibyte character to wide character.
- Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008, 2010-2013 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/byteswap.in.h b/lib/byteswap.in.h
index a9baa68..6c7ab6d 100644
--- a/lib/byteswap.in.h
+++ b/lib/byteswap.in.h
@@ -1,5 +1,5 @@
/* byteswap.h - Byte swapping
- Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005, 2007, 2009-2013 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 6b388fa..ccd8d94 100644
--- a/lib/c-ctype.c
+++ b/lib/c-ctype.c
@@ -1,6 +1,6 @@
/* Character handling in C locale.
- Copyright 2000-2003, 2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright 2000-2003, 2006, 2009-2013 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 6ef0550..64bae06 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2000-2003, 2006, 2008-2013 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 4d8b60c..e484aa8 100644
--- a/lib/c-strcase.h
+++ b/lib/c-strcase.h
@@ -1,5 +1,5 @@
/* Case-insensitive string comparison functions in C locale.
- Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2012 Free Software
+ Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2013 Free Software
Foundation, Inc.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c
index 6983195..765b25a 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2013 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 25e6e07..53ce1e1 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2007, 2009-2013 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 dbec89e..ad5f4f6 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2013 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 16550cf..5451791 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 1996-2013 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
@@ -16,16 +16,16 @@
along with this program. If not, see <http://www.gnu.org/licenses/>. */
#ifndef _LIBC
+/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
+ optimizes away the name == NULL test below. */
+# define _GL_ARG_NONNULL(params)
+
# define _GL_USE_STDLIB_ALLOC 1
# include <config.h>
#endif
#if !HAVE_CANONICALIZE_FILE_NAME || !FUNC_REALPATH_WORKS || defined _LIBC
-/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
- optimizes away the name == NULL test below. */
-#define _GL_ARG_NONNULL(params)
-
/* Specification. */
#include <stdlib.h>
@@ -51,6 +51,7 @@
# define __realpath realpath
# include "pathmax.h"
# include "malloca.h"
+# include "dosname.h"
# if HAVE_GETCWD
# if IN_RELOCWRAPPER
/* When building the relocatable program wrapper, use the system's getcwd
@@ -101,6 +102,7 @@ __realpath (const char *name, char *resolved)
const char *start, *end, *rpath_limit;
long int path_max;
int num_links = 0;
+ size_t prefix_len;
if (name == NULL)
{
@@ -143,7 +145,11 @@ __realpath (const char *name, char *resolved)
rpath = resolved;
rpath_limit = rpath + path_max;
- if (name[0] != '/')
+ /* This is always zero for Posix hosts, but can be 2 for MS-Windows
+ and MS-DOS X:/foo/bar file names. */
+ prefix_len = FILE_SYSTEM_PREFIX_LEN (name);
+
+ if (!IS_ABSOLUTE_FILE_NAME (name))
{
if (!__getcwd (rpath, path_max))
{
@@ -151,20 +157,28 @@ __realpath (const char *name, char *resolved)
goto error;
}
dest = strchr (rpath, '\0');
+ start = name;
+ prefix_len = FILE_SYSTEM_PREFIX_LEN (rpath);
}
else
{
- rpath[0] = '/';
- dest = rpath + 1;
+ dest = rpath;
+ if (prefix_len)
+ {
+ memcpy (rpath, name, prefix_len);
+ dest += prefix_len;
+ }
+ *dest++ = '/';
if (DOUBLE_SLASH_IS_DISTINCT_ROOT)
{
- if (name[1] == '/' && name[2] != '/')
+ if (ISSLASH (name[1]) && !ISSLASH (name[2]) && !prefix_len)
*dest++ = '/';
*dest = '\0';
}
+ start = name + prefix_len;
}
- for (start = end = name; *start; start = end)
+ for (end = start; *start; start = end)
{
#ifdef _LIBC
struct stat64 st;
@@ -174,11 +188,11 @@ __realpath (const char *name, char *resolved)
int n;
/* Skip sequence of multiple path-separators. */
- while (*start == '/')
+ while (ISSLASH (*start))
++start;
/* Find end of path component. */
- for (end = start; *end && *end != '/'; ++end)
+ for (end = start; *end && !ISSLASH (*end); ++end)
/* Nothing. */;
if (end - start == 0)
@@ -188,17 +202,19 @@ __realpath (const char *name, char *resolved)
else if (end - start == 2 && start[0] == '.' && start[1] == '.')
{
/* Back up to previous component, ignore if at root already. */
- if (dest > rpath + 1)
- while ((--dest)[-1] != '/');
- if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
- && *dest == '/' && dest[1] != '/')
+ if (dest > rpath + prefix_len + 1)
+ for (--dest; dest > rpath && !ISSLASH (dest[-1]); --dest)
+ continue;
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT
+ && dest == rpath + 1 && !prefix_len
+ && ISSLASH (*dest) && !ISSLASH (dest[1]))
dest++;
}
else
{
size_t new_size;
- if (dest[-1] != '/')
+ if (!ISSLASH (dest[-1]))
*dest++ = '/';
if (dest + (end - start) >= rpath_limit)
@@ -209,7 +225,7 @@ __realpath (const char *name, char *resolved)
if (resolved)
{
__set_errno (ENAMETOOLONG);
- if (dest > rpath + 1)
+ if (dest > rpath + prefix_len + 1)
dest--;
*dest = '\0';
goto error;
@@ -299,24 +315,32 @@ __realpath (const char *name, char *resolved)
memmove (&extra_buf[n], end, len + 1);
name = end = memcpy (extra_buf, buf, n);
- if (buf[0] == '/')
+ if (IS_ABSOLUTE_FILE_NAME (buf))
{
- dest = rpath + 1; /* It's an absolute symlink */
+ size_t pfxlen = FILE_SYSTEM_PREFIX_LEN (buf);
+
+ if (pfxlen)
+ memcpy (rpath, buf, pfxlen);
+ dest = rpath + pfxlen;
+ *dest++ = '/'; /* It's an absolute symlink */
if (DOUBLE_SLASH_IS_DISTINCT_ROOT)
{
- if (buf[1] == '/' && buf[2] != '/')
+ if (ISSLASH (buf[1]) && !ISSLASH (buf[2]) && !pfxlen)
*dest++ = '/';
*dest = '\0';
}
+ /* Install the new prefix to be in effect hereafter. */
+ prefix_len = pfxlen;
}
else
{
/* Back up to previous component, ignore if at root
already: */
- if (dest > rpath + 1)
- while ((--dest)[-1] != '/');
+ if (dest > rpath + prefix_len + 1)
+ for (--dest; dest > rpath && !ISSLASH (dest[-1]); --dest)
+ continue;
if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
- && *dest == '/' && dest[1] != '/')
+ && ISSLASH (*dest) && !ISSLASH (dest[1]) && !prefix_len)
dest++;
}
}
@@ -327,10 +351,10 @@ __realpath (const char *name, char *resolved)
}
}
}
- if (dest > rpath + 1 && dest[-1] == '/')
+ if (dest > rpath + prefix_len + 1 && ISSLASH (dest[-1]))
--dest;
- if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
- && *dest == '/' && dest[1] != '/')
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 && !prefix_len
+ && ISSLASH (*dest) && !ISSLASH (dest[1]))
dest++;
*dest = '\0';
diff --git a/lib/ceil.c b/lib/ceil.c
index 810179c..3a264ae 100644
--- a/lib/ceil.c
+++ b/lib/ceil.c
@@ -1,5 +1,5 @@
/* Round towards positive infinity.
- Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2010-2013 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/close.c b/lib/close.c
index 2b6f598..02ff0b1 100644
--- a/lib/close.c
+++ b/lib/close.c
@@ -1,5 +1,5 @@
/* close replacement.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/config.charset b/lib/config.charset
index 58ac759..f15f5bb 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-2012 Free Software Foundation, Inc.
+# Copyright (C) 2000-2004, 2006-2013 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/connect.c b/lib/connect.c
index 303cd0b..03746f8 100644
--- a/lib/connect.c
+++ b/lib/connect.c
@@ -1,6 +1,6 @@
/* connect.c --- wrappers for Windows connect function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/dirent.in.h b/lib/dirent.in.h
index 8882415..aff6af3 100644
--- a/lib/dirent.in.h
+++ b/lib/dirent.in.h
@@ -1,5 +1,5 @@
/* A GNU-like <dirent.h>.
- Copyright (C) 2006-2012 Free Software Foundation, Inc.
+ Copyright (C) 2006-2013 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/dirfd.c b/lib/dirfd.c
index 7013010..c535b17 100644
--- a/lib/dirfd.c
+++ b/lib/dirfd.c
@@ -1,6 +1,6 @@
/* dirfd.c -- return the file descriptor associated with an open DIR*
- Copyright (C) 2001, 2006, 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2006, 2008-2013 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/dirname-lgpl.c b/lib/dirname-lgpl.c
index 5d0cc07..90597ac 100644
--- a/lib/dirname-lgpl.c
+++ b/lib/dirname-lgpl.c
@@ -1,6 +1,6 @@
/* dirname.c -- return all but the last element in a file name
- Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2012 Free Software
+ Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2013 Free Software
Foundation, Inc.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/dirname.h b/lib/dirname.h
index ce77baf..4b5acd9 100644
--- a/lib/dirname.h
+++ b/lib/dirname.h
@@ -1,6 +1,6 @@
/* Take file names apart into directory and base names.
- Copyright (C) 1998, 2001, 2003-2006, 2009-2012 Free Software Foundation,
+ Copyright (C) 1998, 2001, 2003-2006, 2009-2013 Free Software Foundation,
Inc.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/dosname.h b/lib/dosname.h
index f4b1439..82d62e5 100644
--- a/lib/dosname.h
+++ b/lib/dosname.h
@@ -1,6 +1,6 @@
/* File names on MS-DOS/Windows systems.
- Copyright (C) 2000-2001, 2004-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2000-2001, 2004-2006, 2009-2013 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/dup2.c b/lib/dup2.c
new file mode 100644
index 0000000..89b40c4
--- /dev/null
+++ b/lib/dup2.c
@@ -0,0 +1,160 @@
+/* Duplicate an open file descriptor to a specified file descriptor.
+
+ Copyright (C) 1999, 2004-2007, 2009-2013 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* written by Paul Eggert */
+
+#include <config.h>
+
+/* Specification. */
+#include <unistd.h>
+
+#include <errno.h>
+#include <fcntl.h>
+
+#if HAVE_DUP2
+
+# undef dup2
+
+# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+
+/* Get declarations of the native Windows API functions. */
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+
+# include "msvc-inval.h"
+
+/* Get _get_osfhandle. */
+# include "msvc-nothrow.h"
+
+static int
+ms_windows_dup2 (int fd, int desired_fd)
+{
+ int result;
+
+ /* If fd is closed, mingw hangs on dup2 (fd, fd). If fd is open,
+ dup2 (fd, fd) returns 0, but all further attempts to use fd in
+ future dup2 calls will hang. */
+ if (fd == desired_fd)
+ {
+ if ((HANDLE) _get_osfhandle (fd) == INVALID_HANDLE_VALUE)
+ {
+ errno = EBADF;
+ return -1;
+ }
+ return fd;
+ }
+
+ /* Wine 1.0.1 return 0 when desired_fd is negative but not -1:
+ http://bugs.winehq.org/show_bug.cgi?id=21289 */
+ if (desired_fd < 0)
+ {
+ errno = EBADF;
+ return -1;
+ }
+
+ TRY_MSVC_INVAL
+ {
+ result = dup2 (fd, desired_fd);
+ }
+ CATCH_MSVC_INVAL
+ {
+ errno = EBADF;
+ result = -1;
+ }
+ DONE_MSVC_INVAL;
+
+ if (result == 0)
+ result = desired_fd;
+
+ return result;
+}
+
+# define dup2 ms_windows_dup2
+
+# endif
+
+int
+rpl_dup2 (int fd, int desired_fd)
+{
+ int result;
+
+# ifdef F_GETFL
+ /* On Linux kernels 2.6.26-2.6.29, dup2 (fd, fd) returns -EBADF.
+ On Cygwin 1.5.x, dup2 (1, 1) returns 0.
+ On Cygwin 1.7.17, dup2 (1, -1) dumps core.
+ On Haiku, dup2 (fd, fd) mistakenly clears FD_CLOEXEC. */
+ if (desired_fd < 0)
+ fd = desired_fd;
+ if (fd == desired_fd)
+ return fcntl (fd, F_GETFL) == -1 ? -1 : fd;
+# endif
+
+ result = dup2 (fd, desired_fd);
+
+ /* Correct an errno value on FreeBSD 6.1 and Cygwin 1.5.x. */
+ if (result == -1 && errno == EMFILE)
+ errno = EBADF;
+# if REPLACE_FCHDIR
+ if (fd != desired_fd && result != -1)
+ result = _gl_register_dup (fd, result);
+# endif
+ return result;
+}
+
+#else /* !HAVE_DUP2 */
+
+/* On older platforms, dup2 did not exist. */
+
+# ifndef F_DUPFD
+static int
+dupfd (int fd, int desired_fd)
+{
+ int duplicated_fd = dup (fd);
+ if (duplicated_fd < 0 || duplicated_fd == desired_fd)
+ return duplicated_fd;
+ else
+ {
+ int r = dupfd (fd, desired_fd);
+ int e = errno;
+ close (duplicated_fd);
+ errno = e;
+ return r;
+ }
+}
+# endif
+
+int
+dup2 (int fd, int desired_fd)
+{
+ int result = fcntl (fd, F_GETFL) < 0 ? -1 : fd;
+ if (result == -1 || fd == desired_fd)
+ return result;
+ close (desired_fd);
+# ifdef F_DUPFD
+ result = fcntl (fd, F_DUPFD, desired_fd);
+# if REPLACE_FCHDIR
+ if (0 <= result)
+ result = _gl_register_dup (fd, result);
+# endif
+# else
+ result = dupfd (fd, desired_fd);
+# endif
+ if (result == -1 && (errno == EMFILE || errno == EINVAL))
+ errno = EBADF;
+ return result;
+}
+#endif /* !HAVE_DUP2 */
diff --git a/lib/duplocale.c b/lib/duplocale.c
index dd85efe..5a291b9 100644
--- a/lib/duplocale.c
+++ b/lib/duplocale.c
@@ -1,5 +1,5 @@
/* Duplicate a locale object.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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 774c786..f2295cd 100644
--- a/lib/errno.in.h
+++ b/lib/errno.in.h
@@ -1,6 +1,6 @@
/* A POSIX-like <errno.h>.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/fcntl.in.h b/lib/fcntl.in.h
index 5c934c0..f71ce2f 100644
--- a/lib/fcntl.in.h
+++ b/lib/fcntl.in.h
@@ -1,6 +1,6 @@
/* Like <fcntl.h>, but with non-working flags defined to 0.
- Copyright (C) 2006-2012 Free Software Foundation, Inc.
+ Copyright (C) 2006-2013 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/fd-hook.c b/lib/fd-hook.c
index 39e25ea..cafd91c 100644
--- a/lib/fd-hook.c
+++ b/lib/fd-hook.c
@@ -1,5 +1,5 @@
/* Hook for making making file descriptor functions close(), ioctl()
extensible.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2009.
This program is free software: you can redistribute it and/or modify it
diff --git a/lib/fd-hook.h b/lib/fd-hook.h
index b3b200d..397dbb0 100644
--- a/lib/fd-hook.h
+++ b/lib/fd-hook.h
@@ -1,5 +1,5 @@
/* Hook for making making file descriptor functions close(), ioctl()
extensible.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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/float+.h b/lib/float+.h
index fd4a9ed..1bd368c 100644
--- a/lib/float+.h
+++ b/lib/float+.h
@@ -1,5 +1,5 @@
/* Supplemental information about the floating-point formats.
- Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009-2013 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.c b/lib/float.c
index 94c6cfd..37b0b49 100644
--- a/lib/float.c
+++ b/lib/float.c
@@ -1,5 +1,5 @@
/* Auxiliary definitions for <float.h>.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2011.
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 b3740b8..40875a2 100644
--- a/lib/float.in.h
+++ b/lib/float.in.h
@@ -1,6 +1,6 @@
/* A correct <float.h>.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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 3eb9abb..f15fe12 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 Free Software 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/floor.c b/lib/floor.c
index 7efbe9e..3dca6f5 100644
--- a/lib/floor.c
+++ b/lib/floor.c
@@ -1,5 +1,5 @@
/* Round towards negative infinity.
- Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2010-2013 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/frexp.c b/lib/frexp.c
index baeb462..eb2b379 100644
--- a/lib/frexp.c
+++ b/lib/frexp.c
@@ -1,5 +1,5 @@
/* Split a double into fraction and mantissa.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/fstat.c b/lib/fstat.c
index 3f49e9b..121f4bf 100644
--- a/lib/fstat.c
+++ b/lib/fstat.c
@@ -1,5 +1,5 @@
/* fstat() replacement.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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,7 +31,7 @@
#endif
#undef __need_system_sys_stat_h
-static inline int
+static int
orig_fstat (int fd, struct stat *buf)
{
return fstat (fd, buf);
@@ -51,7 +51,7 @@ orig_fstat (int fd, struct stat *buf)
#endif
#if HAVE_MSVC_INVALID_PARAMETER_HANDLER
-static inline int
+static int
fstat_nothrow (int fd, struct stat *buf)
{
int result;
diff --git a/lib/full-read.c b/lib/full-read.c
index 68b273d..f884bb6 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2003, 2009-2013 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 fdf2331..81f6edf 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2009-2013 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 20d99b7..8f30798 100644
--- a/lib/full-write.c
+++ b/lib/full-write.c
@@ -1,6 +1,6 @@
/* An interface to read and write that retries (if necessary) until complete.
- Copyright (C) 1993-1994, 1997-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1993-1994, 1997-2006, 2009-2013 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 018b25c..cb05bff 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2003, 2009-2013 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
index 8b36694..0205a78 100644
--- a/lib/gai_strerror.c
+++ b/lib/gai_strerror.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2012 Free Software
+/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2013 Free Software
Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Philip Blundell <address@hidden>, 1997.
diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c
index e53a69b..9b0297c 100644
--- a/lib/getaddrinfo.c
+++ b/lib/getaddrinfo.c
@@ -1,5 +1,5 @@
/* Get address information (partial implementation).
- Copyright (C) 1997, 2001-2002, 2004-2012 Free Software Foundation, Inc.
+ Copyright (C) 1997, 2001-2002, 2004-2013 Free Software Foundation, Inc.
Contributed by Simon Josefsson <address@hidden>.
This program is free software; you can redistribute it and/or modify
@@ -15,12 +15,12 @@
You should have received a copy of the GNU Lesser General Public License
along with this program; if not, see <http://www.gnu.org/licenses/>. */
-#include <config.h>
-
/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
optimizes away the sa == NULL test below. */
#define _GL_ARG_NONNULL(params)
+#include <config.h>
+
#include <netdb.h>
#if HAVE_NETINET_IN_H
@@ -109,7 +109,7 @@ use_win32_p (void)
}
#endif
-static inline bool
+static bool
validate_family (int family)
{
/* FIXME: Support more families. */
diff --git a/lib/getlogin.c b/lib/getlogin.c
new file mode 100644
index 0000000..ebe7c33
--- /dev/null
+++ b/lib/getlogin.c
@@ -0,0 +1,41 @@
+/* Provide a working getlogin for systems which lack it.
+
+ Copyright (C) 2010-2013 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Bruno Haible, 2010. */
+
+#include <config.h>
+
+/* Specification. */
+#include <unistd.h>
+
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+#endif
+
+char *
+getlogin (void)
+{
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+ static char login_name[1024];
+ DWORD sz = sizeof (login_name);
+
+ if (GetUserName (login_name, &sz))
+ return login_name;
+#endif
+ return NULL;
+}
diff --git a/lib/getpeername.c b/lib/getpeername.c
index 02e3fad..307c9e2 100644
--- a/lib/getpeername.c
+++ b/lib/getpeername.c
@@ -1,6 +1,6 @@
/* getpeername.c --- wrappers for Windows getpeername function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/getsockname.c b/lib/getsockname.c
index 890c50e..daac0c0 100644
--- a/lib/getsockname.c
+++ b/lib/getsockname.c
@@ -1,6 +1,6 @@
/* getsockname.c --- wrappers for Windows getsockname function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/getsockopt.c b/lib/getsockopt.c
index 0bf74b0..c80487f 100644
--- a/lib/getsockopt.c
+++ b/lib/getsockopt.c
@@ -1,6 +1,6 @@
/* getsockopt.c --- wrappers for Windows getsockopt function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/gettext.h b/lib/gettext.h
index d130faa..2cc0e05 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -1,5 +1,5 @@
/* Convenience header for conditional use of GNU <libintl.h>.
- Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2012 Free Software
+ Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2013 Free Software
Foundation, Inc.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/iconv.c b/lib/iconv.c
index de2fb31..933730b 100644
--- a/lib/iconv.c
+++ b/lib/iconv.c
@@ -1,5 +1,5 @@
/* Character set conversion.
- Copyright (C) 1999-2001, 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999-2001, 2007, 2009-2013 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 e150947..2e7efbe 100644
--- a/lib/iconv.in.h
+++ b/lib/iconv.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <iconv.h>.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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_close.c b/lib/iconv_close.c
index d8b027a..3492f28 100644
--- a/lib/iconv_close.c
+++ b/lib/iconv_close.c
@@ -1,5 +1,5 @@
/* Character set conversion.
- Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009-2013 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 c011241..eaf7c7d 100644
--- a/lib/iconv_open.c
+++ b/lib/iconv_open.c
@@ -1,5 +1,5 @@
/* Character set conversion.
- Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009-2013 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 4a4f506..8d792ac 100644
--- a/lib/iconveh.h
+++ b/lib/iconveh.h
@@ -1,5 +1,5 @@
/* Character set conversion handler type.
- Copyright (C) 2001-2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2007, 2009-2013 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 0ccd997..96202e2 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2008-2013 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 36e981a..08f1b20 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2006, 2008-2013 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/isinf.c b/lib/isinf.c
index 5efaa9d..24c32d3 100644
--- a/lib/isinf.c
+++ b/lib/isinf.c
@@ -1,5 +1,5 @@
/* Test for positive or negative infinity.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/isnan.c b/lib/isnan.c
index 1faa28a..18fa5a2 100644
--- a/lib/isnan.c
+++ b/lib/isnan.c
@@ -1,5 +1,5 @@
/* Test for NaN that does not need libm.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/isnand-nolibm.h b/lib/isnand-nolibm.h
index e9e64db..3510202 100644
--- a/lib/isnand-nolibm.h
+++ b/lib/isnand-nolibm.h
@@ -1,5 +1,5 @@
/* Test for NaN that does not need libm.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/isnand.c b/lib/isnand.c
index 308caac..9bd092b 100644
--- a/lib/isnand.c
+++ b/lib/isnand.c
@@ -1,5 +1,5 @@
/* Test for NaN that does not need libm.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/isnanf.c b/lib/isnanf.c
index 6376ce0..503575f 100644
--- a/lib/isnanf.c
+++ b/lib/isnanf.c
@@ -1,5 +1,5 @@
/* Test for NaN that does not need libm.
- Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009-2013 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/isnanl.c b/lib/isnanl.c
index cfe2545..967eaff 100644
--- a/lib/isnanl.c
+++ b/lib/isnanl.c
@@ -1,5 +1,5 @@
/* Test for NaN that does not need libm.
- Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009-2013 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/itold.c b/lib/itold.c
index 0c41e2d..ff43bd0 100644
--- a/lib/itold.c
+++ b/lib/itold.c
@@ -1,5 +1,5 @@
/* Replacement for 'int' to 'long double' conversion routine.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2011.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h
index 63b92fd..d60a980 100644
--- a/lib/langinfo.in.h
+++ b/lib/langinfo.in.h
@@ -1,5 +1,5 @@
/* Substitute for and wrapper around <langinfo.h>.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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/listen.c b/lib/listen.c
index 28f3aaf..ea6eddc 100644
--- a/lib/listen.c
+++ b/lib/listen.c
@@ -1,6 +1,6 @@
/* listen.c --- wrappers for Windows listen function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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 c4a0596..e967ee5 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2000-2006, 2008-2013 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 b4467f6..4580edf 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2000-2003, 2009-2013 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 89b6745..ca67816 100644
--- a/lib/locale.in.h
+++ b/lib/locale.in.h
@@ -1,5 +1,5 @@
/* A POSIX <locale.h>.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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
@@ -14,16 +14,30 @@
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. */
-#ifndef address@hidden@_LOCALE_H
-
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
#endif
@PRAGMA_COLUMNS@
+#ifdef _GL_ALREADY_INCLUDING_LOCALE_H
+
+/* Special invocation conventions to handle Solaris header files
+ (through Solaris 10) when combined with gettext's libintl.h. */
+
address@hidden@ @NEXT_LOCALE_H@
+
+#else
+/* Normal invocation convention. */
+
+#ifndef address@hidden@_LOCALE_H
+
+#define _GL_ALREADY_INCLUDING_LOCALE_H
+
/* The include_next requires a split double-inclusion guard. */
address@hidden@ @NEXT_LOCALE_H@
+#undef _GL_ALREADY_INCLUDING_LOCALE_H
+
#ifndef address@hidden@_LOCALE_H
#define address@hidden@_LOCALE_H
@@ -198,4 +212,5 @@ _GL_WARN_ON_USE (duplocale, "duplocale is buggy on some
glibc systems - "
#endif
#endif /* address@hidden@_LOCALE_H */
+#endif /* ! _GL_ALREADY_INCLUDING_LOCALE_H */
#endif /* address@hidden@_LOCALE_H */
diff --git a/lib/localeconv.c b/lib/localeconv.c
index c22860c..41396a0 100644
--- a/lib/localeconv.c
+++ b/lib/localeconv.c
@@ -1,5 +1,5 @@
/* Query locale dependent information for formatting numbers.
- Copyright (C) 2012 Free Software Foundation, Inc.
+ Copyright (C) 2012-2013 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/log.c b/lib/log.c
index 9ec5eae..892721a 100644
--- a/lib/log.c
+++ b/lib/log.c
@@ -1,5 +1,5 @@
/* Logarithm.
- Copyright (C) 2012 Free Software Foundation, Inc.
+ Copyright (C) 2012-2013 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/log1p.c b/lib/log1p.c
index 397b140..8c0788a 100644
--- a/lib/log1p.c
+++ b/lib/log1p.c
@@ -1,5 +1,5 @@
/* Natural logarithm of 1 plus argument.
- Copyright (C) 2012 Free Software Foundation, Inc.
+ Copyright (C) 2012-2013 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/lstat.c b/lib/lstat.c
index fe20e61..b0873d3 100644
--- a/lib/lstat.c
+++ b/lib/lstat.c
@@ -1,6 +1,6 @@
/* Work around a bug of lstat on some systems
- Copyright (C) 1997-2006, 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 1997-2006, 2008-2013 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
@@ -35,7 +35,7 @@ typedef int dummy;
# include <sys/stat.h>
# undef __need_system_sys_stat_h
-static inline int
+static int
orig_lstat (const char *filename, struct stat *buf)
{
return lstat (filename, buf);
diff --git a/lib/malloc.c b/lib/malloc.c
index 109c65c..8124cad 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1997-1998, 2006-2007, 2009-2013 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 2d4c479..04ddc23 100644
--- a/lib/malloca.c
+++ b/lib/malloca.c
@@ -1,5 +1,5 @@
/* Safe automatic memory allocation.
- Copyright (C) 2003, 2006-2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2006-2007, 2009-2013 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 deb9bda..7747679 100644
--- a/lib/malloca.h
+++ b/lib/malloca.h
@@ -1,5 +1,5 @@
/* Safe automatic memory allocation.
- Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003-2007, 2009-2013 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/math.c b/lib/math.c
new file mode 100644
index 0000000..ddb2ded
--- /dev/null
+++ b/lib/math.c
@@ -0,0 +1,3 @@
+#include <config.h>
+#define _GL_MATH_INLINE _GL_EXTERN_INLINE
+#include "math.h"
diff --git a/lib/math.in.h b/lib/math.in.h
index ee0fc95..46d0cf1 100644
--- a/lib/math.in.h
+++ b/lib/math.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <math.h>.
- Copyright (C) 2002-2003, 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2003, 2007-2013 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -28,6 +28,10 @@
#ifndef address@hidden@_MATH_H
#define address@hidden@_MATH_H
+_GL_INLINE_HEADER_BEGIN
+#ifndef _GL_MATH_INLINE
+# define _GL_MATH_INLINE _GL_INLINE
+#endif
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
@@ -78,17 +82,17 @@ func (long double l)
\
classification macros with an argument of real-floating (that is,
one of float, double, or long double). */
#define _GL_WARN_REAL_FLOATING_DECL(func) \
-static inline int \
+_GL_MATH_INLINE int \
rpl_ ## func ## f (float f) \
{ \
return func (f); \
} \
-static inline int \
+_GL_MATH_INLINE int \
rpl_ ## func ## d (double d) \
{ \
return func (d); \
} \
-static inline int \
+_GL_MATH_INLINE int \
rpl_ ## func ## l (long double l) \
{ \
return func (l); \
@@ -124,7 +128,7 @@ static void (*_gl_math_fix_itold) (long double *, int) =
_Qp_itoq;
/* The Compaq (ex-DEC) C 6.4 compiler and the Microsoft MSVC 9 compiler
choke on the expression 0.0 / 0.0. */
# if defined __DECC || defined _MSC_VER
-static float
+_GL_MATH_INLINE float
_NaN ()
{
static float zero = 0.0f;
@@ -2265,6 +2269,7 @@ _GL_WARN_REAL_FLOATING_DECL (signbit);
# endif
#endif
+_GL_INLINE_HEADER_END
#endif /* address@hidden@_MATH_H */
#endif /* address@hidden@_MATH_H */
diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c
index 5f2ec07..75d10bc 100644
--- a/lib/mbrtowc.c
+++ b/lib/mbrtowc.c
@@ -1,5 +1,5 @@
/* Convert multibyte character to wide character.
- Copyright (C) 1999-2002, 2005-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2005-2013 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 79278d4..98ae1e6 100644
--- a/lib/mbsinit.c
+++ b/lib/mbsinit.c
@@ -1,5 +1,5 @@
/* Test for initial conversion state.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/mbtowc-impl.h b/lib/mbtowc-impl.h
index 3183f91..35b3528 100644
--- a/lib/mbtowc-impl.h
+++ b/lib/mbtowc-impl.h
@@ -1,5 +1,5 @@
/* Convert multibyte character to wide character.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2011.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/mbtowc.c b/lib/mbtowc.c
index e48b2f2..7777f0a 100644
--- a/lib/mbtowc.c
+++ b/lib/mbtowc.c
@@ -1,5 +1,5 @@
/* Convert multibyte character to wide character.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2011.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/memchr.c b/lib/memchr.c
index 7b6e258..6b28405 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-2012
+/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2013
Free Software Foundation, Inc.
Based on strlen implementation by Torbjorn Granlund (address@hidden),
diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c
index 7da3541..5e59da7 100644
--- a/lib/msvc-inval.c
+++ b/lib/msvc-inval.c
@@ -1,5 +1,5 @@
/* Invalid parameter handler for MSVC runtime libraries.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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/msvc-inval.h b/lib/msvc-inval.h
index ce6fcee..3ff7494 100644
--- a/lib/msvc-inval.h
+++ b/lib/msvc-inval.h
@@ -1,5 +1,5 @@
/* Invalid parameter handler for MSVC runtime libraries.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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/msvc-nothrow.c b/lib/msvc-nothrow.c
index 3e791c3..c17a9a2 100644
--- a/lib/msvc-nothrow.c
+++ b/lib/msvc-nothrow.c
@@ -1,6 +1,6 @@
/* Wrappers that don't throw invalid parameter notifications
with MSVC runtime libraries.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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/msvc-nothrow.h b/lib/msvc-nothrow.h
index 573bc8e..80d4785 100644
--- a/lib/msvc-nothrow.h
+++ b/lib/msvc-nothrow.h
@@ -1,6 +1,6 @@
/* Wrappers that don't throw invalid parameter notifications
with MSVC runtime libraries.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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/netdb.in.h b/lib/netdb.in.h
index 63ebd2d..dff665c 100644
--- a/lib/netdb.in.h
+++ b/lib/netdb.in.h
@@ -1,5 +1,5 @@
/* Provide a netdb.h header file for systems lacking it (read: MinGW).
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 Free Software Foundation, Inc.
Written by Simon Josefsson.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h
index a93dcdf..97ec58d 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/nl_langinfo.c b/lib/nl_langinfo.c
index 4b9bdbe..2210b7f 100644
--- a/lib/nl_langinfo.c
+++ b/lib/nl_langinfo.c
@@ -1,6 +1,6 @@
/* nl_langinfo() replacement: query locale dependent information.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/nproc.c b/lib/nproc.c
index c4b151a..86aefe5 100644
--- a/lib/nproc.c
+++ b/lib/nproc.c
@@ -1,6 +1,6 @@
/* Detect the number of processors.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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/nproc.h b/lib/nproc.h
index c5f6322..57689aa 100644
--- a/lib/nproc.h
+++ b/lib/nproc.h
@@ -1,6 +1,6 @@
/* Detect the number of processors.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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/open.c b/lib/open.c
index 3a74813..b4d9c87 100644
--- a/lib/open.c
+++ b/lib/open.c
@@ -1,5 +1,5 @@
/* Open a descriptor to a file.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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
@@ -27,7 +27,7 @@
#include <sys/types.h>
#undef __need_system_fcntl_h
-static inline int
+static int
orig_open (const char *filename, int flags, mode_t mode)
{
return open (filename, flags, mode);
diff --git a/lib/pathmax.h b/lib/pathmax.h
index 2361321..105edae 100644
--- a/lib/pathmax.h
+++ b/lib/pathmax.h
@@ -1,5 +1,5 @@
/* Define PATH_MAX somehow. Requires sys/types.h.
- Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2012 Free Software
+ Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2013 Free Software
Foundation, Inc.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/pipe.c b/lib/pipe.c
new file mode 100644
index 0000000..fc11967
--- /dev/null
+++ b/lib/pipe.c
@@ -0,0 +1,50 @@
+/* Create a pipe.
+ Copyright (C) 2009-2013 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include <unistd.h>
+
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+/* Native Windows API. */
+
+/* Get _pipe(). */
+# include <io.h>
+
+/* Get _O_BINARY. */
+# include <fcntl.h>
+
+int
+pipe (int fd[2])
+{
+ /* Mingw changes fd to {-1,-1} on failure, but this violates
+ http://austingroupbugs.net/view.php?id=467 */
+ int tmp[2];
+ int result = _pipe (tmp, 4096, _O_BINARY);
+ if (!result)
+ {
+ fd[0] = tmp[0];
+ fd[1] = tmp[1];
+ }
+ return result;
+}
+
+#else
+
+# error "This platform lacks a pipe function, and Gnulib doesn't provide a
replacement. This is a bug in Gnulib."
+
+#endif
diff --git a/lib/pipe2.c b/lib/pipe2.c
index 2c018d5..09952eb 100644
--- a/lib/pipe2.c
+++ b/lib/pipe2.c
@@ -1,5 +1,5 @@
/* Create a pipe, with specific opening flags.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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/poll.c b/lib/poll.c
new file mode 100644
index 0000000..2767f5a
--- /dev/null
+++ b/lib/poll.c
@@ -0,0 +1,611 @@
+/* Emulation for poll(2)
+ Contributed by Paolo Bonzini.
+
+ Copyright 2001-2003, 2006-2013 Free Software Foundation, Inc.
+
+ This file is part of gnulib.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+/* Tell gcc not to warn about the (nfd < 0) tests, below. */
+#if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__
+# pragma GCC diagnostic ignored "-Wtype-limits"
+#endif
+
+#include <config.h>
+#include <alloca.h>
+
+#include <sys/types.h>
+
+/* Specification. */
+#include <poll.h>
+
+#include <errno.h>
+#include <limits.h>
+#include <assert.h>
+
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# define WINDOWS_NATIVE
+# include <winsock2.h>
+# include <windows.h>
+# include <io.h>
+# include <stdio.h>
+# include <conio.h>
+# include "msvc-nothrow.h"
+#else
+# include <sys/time.h>
+# include <sys/socket.h>
+# include <sys/select.h>
+# include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_IOCTL_H
+# include <sys/ioctl.h>
+#endif
+#ifdef HAVE_SYS_FILIO_H
+# include <sys/filio.h>
+#endif
+
+#include <time.h>
+
+#ifndef INFTIM
+# define INFTIM (-1)
+#endif
+
+/* BeOS does not have MSG_PEEK. */
+#ifndef MSG_PEEK
+# define MSG_PEEK 0
+#endif
+
+#ifdef WINDOWS_NATIVE
+
+/* Optimized test whether a HANDLE refers to a console.
+ See <http://lists.gnu.org/archive/html/bug-gnulib/2009-08/msg00065.html>.
*/
+#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3)
+
+static BOOL
+IsSocketHandle (HANDLE h)
+{
+ WSANETWORKEVENTS ev;
+
+ if (IsConsoleHandle (h))
+ return FALSE;
+
+ /* Under Wine, it seems that getsockopt returns 0 for pipes too.
+ WSAEnumNetworkEvents instead distinguishes the two correctly. */
+ ev.lNetworkEvents = 0xDEADBEEF;
+ WSAEnumNetworkEvents ((SOCKET) h, NULL, &ev);
+ return ev.lNetworkEvents != 0xDEADBEEF;
+}
+
+/* Declare data structures for ntdll functions. */
+typedef struct _FILE_PIPE_LOCAL_INFORMATION {
+ ULONG NamedPipeType;
+ ULONG NamedPipeConfiguration;
+ ULONG MaximumInstances;
+ ULONG CurrentInstances;
+ ULONG InboundQuota;
+ ULONG ReadDataAvailable;
+ ULONG OutboundQuota;
+ ULONG WriteQuotaAvailable;
+ ULONG NamedPipeState;
+ ULONG NamedPipeEnd;
+} FILE_PIPE_LOCAL_INFORMATION, *PFILE_PIPE_LOCAL_INFORMATION;
+
+typedef struct _IO_STATUS_BLOCK
+{
+ union {
+ DWORD Status;
+ PVOID Pointer;
+ } u;
+ ULONG_PTR Information;
+} IO_STATUS_BLOCK, *PIO_STATUS_BLOCK;
+
+typedef enum _FILE_INFORMATION_CLASS {
+ FilePipeLocalInformation = 24
+} FILE_INFORMATION_CLASS, *PFILE_INFORMATION_CLASS;
+
+typedef DWORD (WINAPI *PNtQueryInformationFile)
+ (HANDLE, IO_STATUS_BLOCK *, VOID *, ULONG, FILE_INFORMATION_CLASS);
+
+# ifndef PIPE_BUF
+# define PIPE_BUF 512
+# endif
+
+/* Compute revents values for file handle H. If some events cannot happen
+ for the handle, eliminate them from *P_SOUGHT. */
+
+static int
+windows_compute_revents (HANDLE h, int *p_sought)
+{
+ int i, ret, happened;
+ INPUT_RECORD *irbuffer;
+ DWORD avail, nbuffer;
+ BOOL bRet;
+ IO_STATUS_BLOCK iosb;
+ FILE_PIPE_LOCAL_INFORMATION fpli;
+ static PNtQueryInformationFile NtQueryInformationFile;
+ static BOOL once_only;
+
+ switch (GetFileType (h))
+ {
+ case FILE_TYPE_PIPE:
+ if (!once_only)
+ {
+ NtQueryInformationFile = (PNtQueryInformationFile)
+ GetProcAddress (GetModuleHandle ("ntdll.dll"),
+ "NtQueryInformationFile");
+ once_only = TRUE;
+ }
+
+ happened = 0;
+ if (PeekNamedPipe (h, NULL, 0, NULL, &avail, NULL) != 0)
+ {
+ if (avail)
+ happened |= *p_sought & (POLLIN | POLLRDNORM);
+ }
+ else if (GetLastError () == ERROR_BROKEN_PIPE)
+ happened |= POLLHUP;
+
+ else
+ {
+ /* It was the write-end of the pipe. Check if it is writable.
+ If NtQueryInformationFile fails, optimistically assume the pipe is
+ writable. This could happen on Windows 9x, where
+ NtQueryInformationFile is not available, or if we inherit a pipe
+ that doesn't permit FILE_READ_ATTRIBUTES access on the write end
+ (I think this should not happen since Windows XP SP2; WINE seems
+ fine too). Otherwise, ensure that enough space is available for
+ atomic writes. */
+ memset (&iosb, 0, sizeof (iosb));
+ memset (&fpli, 0, sizeof (fpli));
+
+ if (!NtQueryInformationFile
+ || NtQueryInformationFile (h, &iosb, &fpli, sizeof (fpli),
+ FilePipeLocalInformation)
+ || fpli.WriteQuotaAvailable >= PIPE_BUF
+ || (fpli.OutboundQuota < PIPE_BUF &&
+ fpli.WriteQuotaAvailable == fpli.OutboundQuota))
+ happened |= *p_sought & (POLLOUT | POLLWRNORM | POLLWRBAND);
+ }
+ return happened;
+
+ case FILE_TYPE_CHAR:
+ ret = WaitForSingleObject (h, 0);
+ if (!IsConsoleHandle (h))
+ return ret == WAIT_OBJECT_0 ? *p_sought & ~(POLLPRI | POLLRDBAND) : 0;
+
+ nbuffer = avail = 0;
+ bRet = GetNumberOfConsoleInputEvents (h, &nbuffer);
+ if (bRet)
+ {
+ /* Input buffer. */
+ *p_sought &= POLLIN | POLLRDNORM;
+ if (nbuffer == 0)
+ return POLLHUP;
+ if (!*p_sought)
+ return 0;
+
+ irbuffer = (INPUT_RECORD *) alloca (nbuffer * sizeof (INPUT_RECORD));
+ bRet = PeekConsoleInput (h, irbuffer, nbuffer, &avail);
+ if (!bRet || avail == 0)
+ return POLLHUP;
+
+ for (i = 0; i < avail; i++)
+ if (irbuffer[i].EventType == KEY_EVENT)
+ return *p_sought;
+ return 0;
+ }
+ else
+ {
+ /* Screen buffer. */
+ *p_sought &= POLLOUT | POLLWRNORM | POLLWRBAND;
+ return *p_sought;
+ }
+
+ default:
+ ret = WaitForSingleObject (h, 0);
+ if (ret == WAIT_OBJECT_0)
+ return *p_sought & ~(POLLPRI | POLLRDBAND);
+
+ return *p_sought & (POLLOUT | POLLWRNORM | POLLWRBAND);
+ }
+}
+
+/* Convert fd_sets returned by select into revents values. */
+
+static int
+windows_compute_revents_socket (SOCKET h, int sought, long lNetworkEvents)
+{
+ int happened = 0;
+
+ if ((lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) == FD_ACCEPT)
+ happened |= (POLLIN | POLLRDNORM) & sought;
+
+ else if (lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE))
+ {
+ int r, error;
+
+ char data[64];
+ WSASetLastError (0);
+ r = recv (h, data, sizeof (data), MSG_PEEK);
+ error = WSAGetLastError ();
+ WSASetLastError (0);
+
+ if (r > 0 || error == WSAENOTCONN)
+ happened |= (POLLIN | POLLRDNORM) & sought;
+
+ /* Distinguish hung-up sockets from other errors. */
+ else if (r == 0 || error == WSAESHUTDOWN || error == WSAECONNRESET
+ || error == WSAECONNABORTED || error == WSAENETRESET)
+ happened |= POLLHUP;
+
+ else
+ happened |= POLLERR;
+ }
+
+ if (lNetworkEvents & (FD_WRITE | FD_CONNECT))
+ happened |= (POLLOUT | POLLWRNORM | POLLWRBAND) & sought;
+
+ if (lNetworkEvents & FD_OOB)
+ happened |= (POLLPRI | POLLRDBAND) & sought;
+
+ return happened;
+}
+
+#else /* !MinGW */
+
+/* Convert select(2) returned fd_sets into poll(2) revents values. */
+static int
+compute_revents (int fd, int sought, fd_set *rfds, fd_set *wfds, fd_set *efds)
+{
+ int happened = 0;
+ if (FD_ISSET (fd, rfds))
+ {
+ int r;
+ int socket_errno;
+
+# if defined __MACH__ && defined __APPLE__
+ /* There is a bug in Mac OS X that causes it to ignore MSG_PEEK
+ for some kinds of descriptors. Detect if this descriptor is a
+ connected socket, a server socket, or something else using a
+ 0-byte recv, and use ioctl(2) to detect POLLHUP. */
+ r = recv (fd, NULL, 0, MSG_PEEK);
+ socket_errno = (r < 0) ? errno : 0;
+ if (r == 0 || socket_errno == ENOTSOCK)
+ ioctl (fd, FIONREAD, &r);
+# else
+ char data[64];
+ r = recv (fd, data, sizeof (data), MSG_PEEK);
+ socket_errno = (r < 0) ? errno : 0;
+# endif
+ if (r == 0)
+ happened |= POLLHUP;
+
+ /* If the event happened on an unconnected server socket,
+ that's fine. */
+ else if (r > 0 || ( /* (r == -1) && */ socket_errno == ENOTCONN))
+ happened |= (POLLIN | POLLRDNORM) & sought;
+
+ /* Distinguish hung-up sockets from other errors. */
+ else if (socket_errno == ESHUTDOWN || socket_errno == ECONNRESET
+ || socket_errno == ECONNABORTED || socket_errno == ENETRESET)
+ happened |= POLLHUP;
+
+ /* some systems can't use recv() on non-socket, including HP NonStop */
+ else if (socket_errno == ENOTSOCK)
+ happened |= (POLLIN | POLLRDNORM) & sought;
+
+ else
+ happened |= POLLERR;
+ }
+
+ if (FD_ISSET (fd, wfds))
+ happened |= (POLLOUT | POLLWRNORM | POLLWRBAND) & sought;
+
+ if (FD_ISSET (fd, efds))
+ happened |= (POLLPRI | POLLRDBAND) & sought;
+
+ return happened;
+}
+#endif /* !MinGW */
+
+int
+poll (struct pollfd *pfd, nfds_t nfd, int timeout)
+{
+#ifndef WINDOWS_NATIVE
+ fd_set rfds, wfds, efds;
+ struct timeval tv;
+ struct timeval *ptv;
+ int maxfd, rc;
+ nfds_t i;
+
+# ifdef _SC_OPEN_MAX
+ static int sc_open_max = -1;
+
+ if (nfd < 0
+ || (nfd > sc_open_max
+ && (sc_open_max != -1
+ || nfd > (sc_open_max = sysconf (_SC_OPEN_MAX)))))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+# else /* !_SC_OPEN_MAX */
+# ifdef OPEN_MAX
+ if (nfd < 0 || nfd > OPEN_MAX)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+# endif /* OPEN_MAX -- else, no check is needed */
+# endif /* !_SC_OPEN_MAX */
+
+ /* EFAULT is not necessary to implement, but let's do it in the
+ simplest case. */
+ if (!pfd && nfd)
+ {
+ errno = EFAULT;
+ return -1;
+ }
+
+ /* convert timeout number into a timeval structure */
+ if (timeout == 0)
+ {
+ ptv = &tv;
+ ptv->tv_sec = 0;
+ ptv->tv_usec = 0;
+ }
+ else if (timeout > 0)
+ {
+ ptv = &tv;
+ ptv->tv_sec = timeout / 1000;
+ ptv->tv_usec = (timeout % 1000) * 1000;
+ }
+ else if (timeout == INFTIM)
+ /* wait forever */
+ ptv = NULL;
+ else
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* create fd sets and determine max fd */
+ maxfd = -1;
+ FD_ZERO (&rfds);
+ FD_ZERO (&wfds);
+ FD_ZERO (&efds);
+ for (i = 0; i < nfd; i++)
+ {
+ if (pfd[i].fd < 0)
+ continue;
+
+ if (pfd[i].events & (POLLIN | POLLRDNORM))
+ FD_SET (pfd[i].fd, &rfds);
+
+ /* see select(2): "the only exceptional condition detectable
+ is out-of-band data received on a socket", hence we push
+ POLLWRBAND events onto wfds instead of efds. */
+ if (pfd[i].events & (POLLOUT | POLLWRNORM | POLLWRBAND))
+ FD_SET (pfd[i].fd, &wfds);
+ if (pfd[i].events & (POLLPRI | POLLRDBAND))
+ FD_SET (pfd[i].fd, &efds);
+ if (pfd[i].fd >= maxfd
+ && (pfd[i].events & (POLLIN | POLLOUT | POLLPRI
+ | POLLRDNORM | POLLRDBAND
+ | POLLWRNORM | POLLWRBAND)))
+ {
+ maxfd = pfd[i].fd;
+ if (maxfd > FD_SETSIZE)
+ {
+ errno = EOVERFLOW;
+ return -1;
+ }
+ }
+ }
+
+ /* examine fd sets */
+ rc = select (maxfd + 1, &rfds, &wfds, &efds, ptv);
+ if (rc < 0)
+ return rc;
+
+ /* establish results */
+ rc = 0;
+ for (i = 0; i < nfd; i++)
+ if (pfd[i].fd < 0)
+ pfd[i].revents = 0;
+ else
+ {
+ int happened = compute_revents (pfd[i].fd, pfd[i].events,
+ &rfds, &wfds, &efds);
+ if (happened)
+ {
+ pfd[i].revents = happened;
+ rc++;
+ }
+ }
+
+ return rc;
+#else
+ static struct timeval tv0;
+ static HANDLE hEvent;
+ WSANETWORKEVENTS ev;
+ HANDLE h, handle_array[FD_SETSIZE + 2];
+ DWORD ret, wait_timeout, nhandles;
+ fd_set rfds, wfds, xfds;
+ BOOL poll_again;
+ MSG msg;
+ int rc = 0;
+ nfds_t i;
+
+ if (nfd < 0 || timeout < -1)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ if (!hEvent)
+ hEvent = CreateEvent (NULL, FALSE, FALSE, NULL);
+
+restart:
+ handle_array[0] = hEvent;
+ nhandles = 1;
+ FD_ZERO (&rfds);
+ FD_ZERO (&wfds);
+ FD_ZERO (&xfds);
+
+ /* Classify socket handles and create fd sets. */
+ for (i = 0; i < nfd; i++)
+ {
+ int sought = pfd[i].events;
+ pfd[i].revents = 0;
+ if (pfd[i].fd < 0)
+ continue;
+ if (!(sought & (POLLIN | POLLRDNORM | POLLOUT | POLLWRNORM | POLLWRBAND
+ | POLLPRI | POLLRDBAND)))
+ continue;
+
+ h = (HANDLE) _get_osfhandle (pfd[i].fd);
+ assert (h != NULL);
+ if (IsSocketHandle (h))
+ {
+ int requested = FD_CLOSE;
+
+ /* see above; socket handles are mapped onto select. */
+ if (sought & (POLLIN | POLLRDNORM))
+ {
+ requested |= FD_READ | FD_ACCEPT;
+ FD_SET ((SOCKET) h, &rfds);
+ }
+ if (sought & (POLLOUT | POLLWRNORM | POLLWRBAND))
+ {
+ requested |= FD_WRITE | FD_CONNECT;
+ FD_SET ((SOCKET) h, &wfds);
+ }
+ if (sought & (POLLPRI | POLLRDBAND))
+ {
+ requested |= FD_OOB;
+ FD_SET ((SOCKET) h, &xfds);
+ }
+
+ if (requested)
+ WSAEventSelect ((SOCKET) h, hEvent, requested);
+ }
+ else
+ {
+ /* Poll now. If we get an event, do not poll again. Also,
+ screen buffer handles are waitable, and they'll block until
+ a character is available. windows_compute_revents eliminates
+ bits for the "wrong" direction. */
+ pfd[i].revents = windows_compute_revents (h, &sought);
+ if (sought)
+ handle_array[nhandles++] = h;
+ if (pfd[i].revents)
+ timeout = 0;
+ }
+ }
+
+ if (select (0, &rfds, &wfds, &xfds, &tv0) > 0)
+ {
+ /* Do MsgWaitForMultipleObjects anyway to dispatch messages, but
+ no need to call select again. */
+ poll_again = FALSE;
+ wait_timeout = 0;
+ }
+ else
+ {
+ poll_again = TRUE;
+ if (timeout == INFTIM)
+ wait_timeout = INFINITE;
+ else
+ wait_timeout = timeout;
+ }
+
+ for (;;)
+ {
+ ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE,
+ wait_timeout, QS_ALLINPUT);
+
+ if (ret == WAIT_OBJECT_0 + nhandles)
+ {
+ /* new input of some other kind */
+ BOOL bRet;
+ while ((bRet = PeekMessage (&msg, NULL, 0, 0, PM_REMOVE)) != 0)
+ {
+ TranslateMessage (&msg);
+ DispatchMessage (&msg);
+ }
+ }
+ else
+ break;
+ }
+
+ if (poll_again)
+ select (0, &rfds, &wfds, &xfds, &tv0);
+
+ /* Place a sentinel at the end of the array. */
+ handle_array[nhandles] = NULL;
+ nhandles = 1;
+ for (i = 0; i < nfd; i++)
+ {
+ int happened;
+
+ if (pfd[i].fd < 0)
+ continue;
+ if (!(pfd[i].events & (POLLIN | POLLRDNORM |
+ POLLOUT | POLLWRNORM | POLLWRBAND)))
+ continue;
+
+ h = (HANDLE) _get_osfhandle (pfd[i].fd);
+ if (h != handle_array[nhandles])
+ {
+ /* It's a socket. */
+ WSAEnumNetworkEvents ((SOCKET) h, NULL, &ev);
+ WSAEventSelect ((SOCKET) h, 0, 0);
+
+ /* If we're lucky, WSAEnumNetworkEvents already provided a way
+ to distinguish FD_READ and FD_ACCEPT; this saves a recv later. */
+ if (FD_ISSET ((SOCKET) h, &rfds)
+ && !(ev.lNetworkEvents & (FD_READ | FD_ACCEPT)))
+ ev.lNetworkEvents |= FD_READ | FD_ACCEPT;
+ if (FD_ISSET ((SOCKET) h, &wfds))
+ ev.lNetworkEvents |= FD_WRITE | FD_CONNECT;
+ if (FD_ISSET ((SOCKET) h, &xfds))
+ ev.lNetworkEvents |= FD_OOB;
+
+ happened = windows_compute_revents_socket ((SOCKET) h, pfd[i].events,
+ ev.lNetworkEvents);
+ }
+ else
+ {
+ /* Not a socket. */
+ int sought = pfd[i].events;
+ happened = windows_compute_revents (h, &sought);
+ nhandles++;
+ }
+
+ if ((pfd[i].revents |= happened) != 0)
+ rc++;
+ }
+
+ if (!rc && timeout == INFTIM)
+ {
+ SleepEx (1, TRUE);
+ goto restart;
+ }
+
+ return rc;
+#endif
+}
diff --git a/lib/poll.in.h b/lib/poll.in.h
new file mode 100644
index 0000000..3c0b48f
--- /dev/null
+++ b/lib/poll.in.h
@@ -0,0 +1,103 @@
+/* Header for poll(2) emulation
+ Contributed by Paolo Bonzini.
+
+ Copyright 2001-2003, 2007, 2009-2013 Free Software Foundation, Inc.
+
+ This file is part of gnulib.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef address@hidden@_POLL_H
+
+#if __GNUC__ >= 3
address@hidden@
+#endif
address@hidden@
+
+/* The include_next requires a split double-inclusion guard. */
+#if @HAVE_POLL_H@
+# @INCLUDE_NEXT@ @NEXT_POLL_H@
+#endif
+
+#ifndef address@hidden@_POLL_H
+#define address@hidden@_POLL_H
+
+
+/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
+
+/* The definition of _GL_WARN_ON_USE is copied here. */
+
+
+#if address@hidden@
+
+/* fake a poll(2) environment */
+# define POLLIN 0x0001 /* any readable data available */
+# define POLLPRI 0x0002 /* OOB/Urgent readable data */
+# define POLLOUT 0x0004 /* file descriptor is writable */
+# define POLLERR 0x0008 /* some poll error occurred */
+# define POLLHUP 0x0010 /* file descriptor was "hung up" */
+# define POLLNVAL 0x0020 /* requested events "invalid" */
+# define POLLRDNORM 0x0040
+# define POLLRDBAND 0x0080
+# define POLLWRNORM 0x0100
+# define POLLWRBAND 0x0200
+
+# if !GNULIB_defined_poll_types
+
+struct pollfd
+{
+ int fd; /* which file descriptor to poll */
+ short events; /* events we are interested in */
+ short revents; /* events found on return */
+};
+
+typedef unsigned long nfds_t;
+
+# define GNULIB_defined_poll_types 1
+# endif
+
+/* Define INFTIM only if doing so conforms to POSIX. */
+# if !defined (_POSIX_C_SOURCE) && !defined (_XOPEN_SOURCE)
+# define INFTIM (-1)
+# endif
+
+#endif
+
+
+#if @GNULIB_POLL@
+# if @REPLACE_POLL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef poll
+# define poll rpl_poll
+# endif
+_GL_FUNCDECL_RPL (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout));
+_GL_CXXALIAS_RPL (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout));
+# endif
+_GL_CXXALIAS_SYS (poll, int, (struct pollfd *pfd, nfds_t nfd, int timeout));
+# endif
+_GL_CXXALIASWARN (poll);
+#elif defined GNULIB_POSIXCHECK
+# undef poll
+# if HAVE_RAW_DECL_POLL
+_GL_WARN_ON_USE (poll, "poll is unportable - "
+ "use gnulib module poll for portability");
+# endif
+#endif
+
+
+#endif /* address@hidden@_POLL_H */
+#endif /* address@hidden@_POLL_H */
diff --git a/lib/printf-args.c b/lib/printf-args.c
index c768883..73fa7a4 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-2012 Free Software
+ Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2013 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 0bc75ca..af7e72d 100644
--- a/lib/printf-args.h
+++ b/lib/printf-args.h
@@ -1,5 +1,5 @@
/* Decomposed printf argument list.
- Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2012 Free Software
+ Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2013 Free Software
Foundation, Inc.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/printf-parse.c b/lib/printf-parse.c
index fcc302f..9a266df 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999-2000, 2002-2003, 2006-2013 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 94883c6..0d535fa 100644
--- a/lib/printf-parse.h
+++ b/lib/printf-parse.h
@@ -1,5 +1,5 @@
/* Parse printf format string.
- Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2012 Free Software
+ Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2013 Free Software
Foundation, Inc.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/putenv.c b/lib/putenv.c
index eb3fae3..2abc6ac 100644
--- a/lib/putenv.c
+++ b/lib/putenv.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2012 Free Software
+/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2013 Free Software
Foundation, Inc.
NOTE: The canonical source of this file is maintained with the GNU C
@@ -115,6 +115,37 @@ putenv (char *string)
if (*ep == NULL)
{
+#if HAVE__PUTENV
+ /* Rely on _putenv to allocate the new environment. If other
+ parts of the application use _putenv, the !HAVE__PUTENV code
+ would fight over who owns the environ vector, causing a crash. */
+ if (name_end[1])
+ return _putenv (string);
+ else
+ {
+ /* _putenv ("NAME=") unsets NAME, so invoke _putenv ("NAME=x")
+ to allocate the environ vector and then replace the new
+ entry with "NAME=". */
+ int putenv_result, putenv_errno;
+ char *name_x = malloc (name_end - string + sizeof "=x");
+ if (!name_x)
+ return -1;
+ memcpy (name_x, string, name_end - string + 1);
+ name_x[name_end - string + 1] = 'x';
+ name_x[name_end - string + 2] = 0;
+ putenv_result = _putenv (name_x);
+ putenv_errno = errno;
+ for (ep = environ; *ep; ep++)
+ if (*ep == name_x)
+ {
+ *ep = string;
+ break;
+ }
+ free (name_x);
+ __set_errno (putenv_errno);
+ return putenv_result;
+ }
+#else
static char **last_environ = NULL;
char **new_environ = (char **) malloc ((size + 2) * sizeof (char *));
if (new_environ == NULL)
@@ -126,6 +157,7 @@ putenv (char *string)
free (last_environ);
last_environ = new_environ;
environ = new_environ;
+#endif
}
else
*ep = string;
diff --git a/lib/raise.c b/lib/raise.c
index 0c3acbb..3720dfa 100644
--- a/lib/raise.c
+++ b/lib/raise.c
@@ -1,6 +1,6 @@
/* Provide a non-threads replacement for the POSIX raise function.
- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2003, 2005-2006, 2009-2013 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
@@ -32,7 +32,7 @@
# undef raise
# if HAVE_MSVC_INVALID_PARAMETER_HANDLER
-static inline int
+static int
raise_nothrow (int sig)
{
int result;
diff --git a/lib/read.c b/lib/read.c
index 9018bb5..155e6d1 100644
--- a/lib/read.c
+++ b/lib/read.c
@@ -1,5 +1,5 @@
/* POSIX compatible read() function.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2011.
This program is free software: you can redistribute it and/or modify
@@ -34,7 +34,7 @@
# undef read
# if HAVE_MSVC_INVALID_PARAMETER_HANDLER
-static inline ssize_t
+static ssize_t
read_nothrow (int fd, void *buf, size_t count)
{
ssize_t result;
diff --git a/lib/readlink.c b/lib/readlink.c
index c75d794..ce8a0e8 100644
--- a/lib/readlink.c
+++ b/lib/readlink.c
@@ -1,5 +1,5 @@
/* Stub for readlink().
- Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003-2007, 2009-2013 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/recv.c b/lib/recv.c
index 7a5946a..aaa7d00 100644
--- a/lib/recv.c
+++ b/lib/recv.c
@@ -1,6 +1,6 @@
/* recv.c --- wrappers for Windows recv function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/recvfrom.c b/lib/recvfrom.c
index bfd97ac..3155071 100644
--- a/lib/recvfrom.c
+++ b/lib/recvfrom.c
@@ -1,6 +1,6 @@
/* recvfrom.c --- wrappers for Windows recvfrom function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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-add.sin b/lib/ref-add.sin
index 8c1a7d0..7cbdec5 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, 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 2000, 2009-2013 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 fd87588..cf7b492 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, 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 2000, 2009-2013 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/regcomp.c b/lib/regcomp.c
index 76947c2..b236f36 100644
--- a/lib/regcomp.c
+++ b/lib/regcomp.c
@@ -1,20 +1,21 @@
/* Extended regular expression matching and search library.
- Copyright (C) 2002-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <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.
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
+ The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
+ 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/>. */
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern,
size_t length, reg_syntax_t syntax);
@@ -93,20 +94,20 @@ static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE
trans,
bitset_t sbcset,
re_charset_t *mbcset,
Idx *char_class_alloc,
- const unsigned char *class_name,
+ const char *class_name,
reg_syntax_t syntax);
#else /* not RE_ENABLE_I18N */
static reg_errcode_t build_equiv_class (bitset_t sbcset,
const unsigned char *name);
static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans,
bitset_t sbcset,
- const unsigned char *class_name,
+ const char *class_name,
reg_syntax_t syntax);
#endif /* not RE_ENABLE_I18N */
static bin_tree_t *build_charclass_op (re_dfa_t *dfa,
RE_TRANSLATE_TYPE trans,
- const unsigned char *class_name,
- const unsigned char *extra,
+ const char *class_name,
+ const char *extra,
bool non_match, reg_errcode_t *err);
static bin_tree_t *create_tree (re_dfa_t *dfa,
bin_tree_t *left, bin_tree_t *right,
@@ -952,10 +953,10 @@ static void
internal_function
init_word_char (re_dfa_t *dfa)
{
- dfa->word_ops_used = 1;
int i = 0;
int j;
int ch = 0;
+ dfa->word_ops_used = 1;
if (BE (dfa->map_notascii == 0, 1))
{
bitset_word_t bits0 = 0x00000000;
@@ -2421,8 +2422,8 @@ parse_expression (re_string_t *regexp, regex_t *preg,
re_token_t *token,
case OP_WORD:
case OP_NOTWORD:
tree = build_charclass_op (dfa, regexp->trans,
- (const unsigned char *) "alnum",
- (const unsigned char *) "_",
+ "alnum",
+ "_",
token->type == OP_NOTWORD, err);
if (BE (*err != REG_NOERROR && tree == NULL, 0))
return NULL;
@@ -2430,8 +2431,8 @@ parse_expression (re_string_t *regexp, regex_t *preg,
re_token_t *token,
case OP_SPACE:
case OP_NOTSPACE:
tree = build_charclass_op (dfa, regexp->trans,
- (const unsigned char *) "space",
- (const unsigned char *) "",
+ "space",
+ "",
token->type == OP_NOTSPACE, err);
if (BE (*err != REG_NOERROR && tree == NULL, 0))
return NULL;
@@ -2711,7 +2712,6 @@ build_range_exp (const reg_syntax_t syntax,
wchar_t wc;
wint_t start_wc;
wint_t end_wc;
- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'};
start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch
: ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0]
@@ -2725,11 +2725,7 @@ build_range_exp (const reg_syntax_t syntax,
? __btowc (end_ch) : end_elem->opr.wch);
if (start_wc == WEOF || end_wc == WEOF)
return REG_ECOLLATE;
- cmp_buf[0] = start_wc;
- cmp_buf[4] = end_wc;
-
- if (BE ((syntax & RE_NO_EMPTY_RANGES)
- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0))
+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0))
return REG_ERANGE;
/* Got valid collation sequence values, add them as a new entry.
@@ -2770,9 +2766,7 @@ build_range_exp (const reg_syntax_t syntax,
/* Build the table for single byte characters. */
for (wc = 0; wc < SBC_MAX; ++wc)
{
- cmp_buf[2] = wc;
- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0
- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0)
+ if (start_wc <= wc && wc <= end_wc)
bitset_set (sbcset, wc);
}
}
@@ -2969,6 +2963,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
re_token_t *token,
0))
return REG_ERANGE;
+ /* FIXME: Implement rational ranges here, too. */
start_collseq = lookup_collation_sequence_value (start_elem);
end_collseq = lookup_collation_sequence_value (end_elem);
/* Check start/end collation sequence values. */
@@ -3296,7 +3291,8 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
re_token_t *token,
#ifdef RE_ENABLE_I18N
mbcset, &char_class_alloc,
#endif /* RE_ENABLE_I18N */
- start_elem.opr.name, syntax);
+ (const char *) start_elem.opr.name,
+ syntax);
if (BE (*err != REG_NOERROR, 0))
goto parse_bracket_exp_free_return;
break;
@@ -3576,14 +3572,14 @@ static reg_errcode_t
#ifdef RE_ENABLE_I18N
build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
re_charset_t *mbcset, Idx *char_class_alloc,
- const unsigned char *class_name, reg_syntax_t syntax)
+ const char *class_name, reg_syntax_t syntax)
#else /* not RE_ENABLE_I18N */
build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
- const unsigned char *class_name, reg_syntax_t syntax)
+ const char *class_name, reg_syntax_t syntax)
#endif /* not RE_ENABLE_I18N */
{
int i;
- const char *name = (const char *) class_name;
+ const char *name = class_name;
/* In case of REG_ICASE "upper" and "lower" match the both of
upper and lower cases. */
@@ -3657,8 +3653,8 @@ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset,
static bin_tree_t *
build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans,
- const unsigned char *class_name,
- const unsigned char *extra, bool non_match,
+ const char *class_name,
+ const char *extra, bool non_match,
reg_errcode_t *err)
{
re_bitset_ptr_t sbcset;
diff --git a/lib/regex.c b/lib/regex.c
index c578852..ca40e6e 100644
--- a/lib/regex.c
+++ b/lib/regex.c
@@ -1,20 +1,21 @@
/* Extended regular expression matching and search library.
- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <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.
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
+ The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
+ 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/>. */
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
#ifndef _LIBC
# include <config.h>
diff --git a/lib/regex.h b/lib/regex.h
index 07c1b3d..74645ca 100644
--- a/lib/regex.h
+++ b/lib/regex.h
@@ -1,21 +1,22 @@
/* Definitions for data structures and routines for the regular
expression library.
- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012
- Free Software Foundation, Inc.
+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 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
- 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.
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
+ The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
+ 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/>. */
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
#ifndef _REGEX_H
#define _REGEX_H 1
diff --git a/lib/regex_internal.c b/lib/regex_internal.c
index 71ee41e..e11ad3d 100644
--- a/lib/regex_internal.c
+++ b/lib/regex_internal.c
@@ -1,20 +1,21 @@
/* Extended regular expression matching and search library.
- Copyright (C) 2002-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <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.
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
+ The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
+ 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/>. */
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
static void re_string_construct_common (const char *str, Idx len,
re_string_t *pstr,
@@ -973,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx size)
set->alloc = size;
set->nelem = 0;
set->elems = re_malloc (Idx, size);
- if (BE (set->elems == NULL, 0))
+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0))
return REG_ESPACE;
return REG_NOERROR;
}
@@ -1442,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token)
dfa->nodes[dfa->nodes_len] = token;
dfa->nodes[dfa->nodes_len].constraint = 0;
#ifdef RE_ENABLE_I18N
- {
- int type = token.type;
dfa->nodes[dfa->nodes_len].accept_mb =
- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET;
- }
+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1)
+ || token.type == COMPLEX_BRACKET);
#endif
dfa->nexts[dfa->nodes_len] = REG_MISSING;
re_node_set_init_empty (dfa->edests + dfa->nodes_len);
@@ -1454,7 +1453,7 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token)
return dfa->nodes_len++;
}
-static inline re_hashval_t
+static re_hashval_t
internal_function
calc_state_hash (const re_node_set *nodes, unsigned int context)
{
diff --git a/lib/regex_internal.h b/lib/regex_internal.h
index fd331b1..fa93382 100644
--- a/lib/regex_internal.h
+++ b/lib/regex_internal.h
@@ -1,20 +1,21 @@
/* Extended regular expression matching and search library.
- Copyright (C) 2002-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <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.
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
+ The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
+ 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/>. */
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
#ifndef _REGEX_INTERNAL_H
#define _REGEX_INTERNAL_H 1
@@ -26,9 +27,6 @@
#include <string.h>
#include <langinfo.h>
-#ifndef _LIBC
-# include "localcharset.h"
-#endif
#include <locale.h>
#include <wchar.h>
#include <wctype.h>
@@ -37,7 +35,6 @@
#if defined _LIBC
# include <bits/libc-lock.h>
#else
-# define __libc_lock_define(CLASS,NAME)
# define __libc_lock_init(NAME) do { } while (0)
# define __libc_lock_lock(NAME) do { } while (0)
# define __libc_lock_unlock(NAME) do { } while (0)
@@ -63,7 +60,7 @@
# ifdef _LIBC
# undef gettext
# define gettext(msgid) \
- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES)
+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES)
# endif
#else
# define gettext(msgid) (msgid)
@@ -83,9 +80,6 @@
# define BE(expr, val) __builtin_expect (expr, val)
#else
# define BE(expr, val) (expr)
-# ifdef _LIBC
-# define inline
-# endif
#endif
/* Number of ASCII characters. */
@@ -102,6 +96,8 @@
/* Rename to standard API for using out of glibc. */
#ifndef _LIBC
+# undef __wctype
+# undef __iswctype
# define __wctype wctype
# define __iswctype iswctype
# define __btowc btowc
@@ -449,7 +445,9 @@ static unsigned int re_string_context_at (const re_string_t
*input, Idx idx,
#define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx))
#define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx))
-#include <alloca.h>
+#if defined _LIBC || HAVE_ALLOCA
+# include <alloca.h>
+#endif
#ifndef _LIBC
# if HAVE_ALLOCA
@@ -466,6 +464,12 @@ static unsigned int re_string_context_at (const
re_string_t *input, Idx idx,
# endif
#endif
+#ifdef _LIBC
+# define MALLOC_0_IS_NONNULL 1
+#elif !defined MALLOC_0_IS_NONNULL
+# define MALLOC_0_IS_NONNULL 0
+#endif
+
#ifndef MAX
# define MAX(a,b) ((a) < (b) ? (b) : (a))
#endif
@@ -696,7 +700,9 @@ struct re_dfa_t
#ifdef DEBUG
char* re_str;
#endif
+#ifdef _LIBC
__libc_lock_define (, lock)
+#endif
};
#define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set))
@@ -727,33 +733,33 @@ typedef struct
} bracket_elem_t;
-/* Inline functions for bitset_t operation. */
+/* Functions for bitset_t operation. */
-static inline void
+static void
bitset_set (bitset_t set, Idx i)
{
set[i / BITSET_WORD_BITS] |= (bitset_word_t) 1 << i % BITSET_WORD_BITS;
}
-static inline void
+static void
bitset_clear (bitset_t set, Idx i)
{
set[i / BITSET_WORD_BITS] &= ~ ((bitset_word_t) 1 << i % BITSET_WORD_BITS);
}
-static inline bool
+static bool
bitset_contain (const bitset_t set, Idx i)
{
return (set[i / BITSET_WORD_BITS] >> i % BITSET_WORD_BITS) & 1;
}
-static inline void
+static void
bitset_empty (bitset_t set)
{
memset (set, '\0', sizeof (bitset_t));
}
-static inline void
+static void
bitset_set_all (bitset_t set)
{
memset (set, -1, sizeof (bitset_word_t) * (SBC_MAX / BITSET_WORD_BITS));
@@ -762,13 +768,13 @@ bitset_set_all (bitset_t set)
((bitset_word_t) 1 << SBC_MAX % BITSET_WORD_BITS) - 1;
}
-static inline void
+static void
bitset_copy (bitset_t dest, const bitset_t src)
{
memcpy (dest, src, sizeof (bitset_t));
}
-static inline void
+static void
bitset_not (bitset_t set)
{
int bitset_i;
@@ -780,7 +786,7 @@ bitset_not (bitset_t set)
& ~set[BITSET_WORDS - 1]);
}
-static inline void
+static void
bitset_merge (bitset_t dest, const bitset_t src)
{
int bitset_i;
@@ -788,7 +794,7 @@ bitset_merge (bitset_t dest, const bitset_t src)
dest[bitset_i] |= src[bitset_i];
}
-static inline void
+static void
bitset_mask (bitset_t dest, const bitset_t src)
{
int bitset_i;
@@ -797,8 +803,8 @@ bitset_mask (bitset_t dest, const bitset_t src)
}
#ifdef RE_ENABLE_I18N
-/* Inline functions for re_string. */
-static inline int
+/* Functions for re_string. */
+static int
internal_function __attribute ((pure))
re_string_char_size_at (const re_string_t *pstr, Idx idx)
{
@@ -811,7 +817,7 @@ re_string_char_size_at (const re_string_t *pstr, Idx idx)
return byte_idx;
}
-static inline wint_t
+static wint_t
internal_function __attribute ((pure))
re_string_wchar_at (const re_string_t *pstr, Idx idx)
{
diff --git a/lib/regexec.c b/lib/regexec.c
index 13c3f15..1bd1640 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -1,20 +1,21 @@
/* Extended regular expression matching and search library.
- Copyright (C) 2002-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
This file is part of the GNU C Library.
Contributed by Isamu Hasegawa <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.
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
+ The GNU C Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
+ 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/>. */
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, see
+ <http://www.gnu.org/licenses/>. */
static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags,
Idx n) internal_function;
@@ -198,7 +199,7 @@ static Idx group_nodes_into_DFAstates (const re_dfa_t *dfa,
static bool check_node_accept (const re_match_context_t *mctx,
const re_token_t *node, Idx idx)
internal_function;
-static reg_errcode_t extend_buffers (re_match_context_t *mctx)
+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len)
internal_function;
/* Entry point for POSIX code. */
@@ -1175,7 +1176,7 @@ check_matching (re_match_context_t *mctx, bool
fl_longest_match,
|| (BE (next_char_idx >= mctx->input.valid_len, 0)
&& mctx->input.valid_len < mctx->input.len))
{
- err = extend_buffers (mctx);
+ err = extend_buffers (mctx, next_char_idx + 1);
if (BE (err != REG_NOERROR, 0))
{
assert (err == REG_ESPACE);
@@ -1755,7 +1756,7 @@ clean_state_log_if_needed (re_match_context_t *mctx, Idx
next_state_log_idx)
&& mctx->input.valid_len < mctx->input.len))
{
reg_errcode_t err;
- err = extend_buffers (mctx);
+ err = extend_buffers (mctx, next_state_log_idx + 1);
if (BE (err != REG_NOERROR, 0))
return err;
}
@@ -2812,7 +2813,7 @@ get_subexp (re_match_context_t *mctx, Idx bkref_node, Idx
bkref_str_idx)
if (bkref_str_off >= mctx->input.len)
break;
- err = extend_buffers (mctx);
+ err = extend_buffers (mctx, bkref_str_off + 1);
if (BE (err != REG_NOERROR, 0))
return err;
@@ -3935,6 +3936,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx
node_idx,
in_collseq = find_collation_sequence_value (pin, elem_len);
}
/* match with range expression? */
+ /* FIXME: Implement rational ranges here, too. */
for (i = 0; i < cset->nranges; ++i)
if (cset->range_starts[i] <= in_collseq
&& in_collseq <= cset->range_ends[i])
@@ -3986,18 +3988,9 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx
node_idx,
# endif /* _LIBC */
{
/* match with range expression? */
-#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__)
- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'};
-#else
- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'};
- cmp_buf[2] = wc;
-#endif
for (i = 0; i < cset->nranges; ++i)
{
- cmp_buf[0] = cset->range_starts[i];
- cmp_buf[4] = cset->range_ends[i];
- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0
- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0)
+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i])
{
match_len = char_len;
goto check_node_accept_bytes_match;
@@ -4135,7 +4128,7 @@ check_node_accept (const re_match_context_t *mctx, const
re_token_t *node,
static reg_errcode_t
internal_function __attribute_warn_unused_result__
-extend_buffers (re_match_context_t *mctx)
+extend_buffers (re_match_context_t *mctx, int min_len)
{
reg_errcode_t ret;
re_string_t *pstr = &mctx->input;
@@ -4145,8 +4138,10 @@ extend_buffers (re_match_context_t *mctx)
<= pstr->bufs_len, 0))
return REG_ESPACE;
- /* Double the lengths of the buffers. */
- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2));
+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */
+ ret = re_string_realloc_buffers (pstr,
+ MAX (min_len,
+ MIN (pstr->len, pstr->bufs_len * 2)));
if (BE (ret != REG_NOERROR, 0))
return ret;
diff --git a/lib/rename.c b/lib/rename.c
index 547a6a2..eceadec 100644
--- a/lib/rename.c
+++ b/lib/rename.c
@@ -1,6 +1,6 @@
/* Work around rename bugs in some systems.
- Copyright (C) 2001-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2003, 2005-2006, 2009-2013 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/rmdir.c b/lib/rmdir.c
index 0b53626..f18acbe 100644
--- a/lib/rmdir.c
+++ b/lib/rmdir.c
@@ -1,6 +1,6 @@
/* Work around rmdir bugs.
- Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2012 Free Software
+ Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2013 Free Software
Foundation, Inc.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/round.c b/lib/round.c
index 53dfe84..4d4e69b 100644
--- a/lib/round.c
+++ b/lib/round.c
@@ -1,5 +1,5 @@
/* Round toward nearest, breaking ties away from zero.
- Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2010-2013 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 d2d85c7..39490ab 100644
--- a/lib/safe-read.c
+++ b/lib/safe-read.c
@@ -1,6 +1,6 @@
/* An interface to read and write that retries after interrupts.
- Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2012 Free Software
+ Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2013 Free Software
Foundation, Inc.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/safe-read.h b/lib/safe-read.h
index dc73922..91a86c6 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006, 2009-2013 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 cd42722..71f2f3d 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2009-2013 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 3a7f509..779f5d5 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2009-2013 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/same-inode.h b/lib/same-inode.h
index 7ce286d..94fe3e2 100644
--- a/lib/same-inode.h
+++ b/lib/same-inode.h
@@ -1,6 +1,6 @@
/* Determine whether two stat buffers refer to the same file.
- Copyright (C) 2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2006, 2009-2013 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/select.c b/lib/select.c
new file mode 100644
index 0000000..13ca150
--- /dev/null
+++ b/lib/select.c
@@ -0,0 +1,547 @@
+/* Emulation for select(2)
+ Contributed by Paolo Bonzini.
+
+ Copyright 2008-2013 Free Software Foundation, Inc.
+
+ This file is part of gnulib.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <alloca.h>
+#include <assert.h>
+
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+/* Native Windows. */
+
+#include <sys/types.h>
+#include <errno.h>
+#include <limits.h>
+
+#include <winsock2.h>
+#include <windows.h>
+#include <io.h>
+#include <stdio.h>
+#include <conio.h>
+#include <time.h>
+
+/* Get the overridden 'struct timeval'. */
+#include <sys/time.h>
+
+#include "msvc-nothrow.h"
+
+#undef select
+
+struct bitset {
+ unsigned char in[FD_SETSIZE / CHAR_BIT];
+ unsigned char out[FD_SETSIZE / CHAR_BIT];
+};
+
+/* Declare data structures for ntdll functions. */
+typedef struct _FILE_PIPE_LOCAL_INFORMATION {
+ ULONG NamedPipeType;
+ ULONG NamedPipeConfiguration;
+ ULONG MaximumInstances;
+ ULONG CurrentInstances;
+ ULONG InboundQuota;
+ ULONG ReadDataAvailable;
+ ULONG OutboundQuota;
+ ULONG WriteQuotaAvailable;
+ ULONG NamedPipeState;
+ ULONG NamedPipeEnd;
+} FILE_PIPE_LOCAL_INFORMATION, *PFILE_PIPE_LOCAL_INFORMATION;
+
+typedef struct _IO_STATUS_BLOCK
+{
+ union {
+ DWORD Status;
+ PVOID Pointer;
+ } u;
+ ULONG_PTR Information;
+} IO_STATUS_BLOCK, *PIO_STATUS_BLOCK;
+
+typedef enum _FILE_INFORMATION_CLASS {
+ FilePipeLocalInformation = 24
+} FILE_INFORMATION_CLASS, *PFILE_INFORMATION_CLASS;
+
+typedef DWORD (WINAPI *PNtQueryInformationFile)
+ (HANDLE, IO_STATUS_BLOCK *, VOID *, ULONG, FILE_INFORMATION_CLASS);
+
+#ifndef PIPE_BUF
+#define PIPE_BUF 512
+#endif
+
+/* Optimized test whether a HANDLE refers to a console.
+ See <http://lists.gnu.org/archive/html/bug-gnulib/2009-08/msg00065.html>.
*/
+#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3)
+
+static BOOL
+IsSocketHandle (HANDLE h)
+{
+ WSANETWORKEVENTS ev;
+
+ if (IsConsoleHandle (h))
+ return FALSE;
+
+ /* Under Wine, it seems that getsockopt returns 0 for pipes too.
+ WSAEnumNetworkEvents instead distinguishes the two correctly. */
+ ev.lNetworkEvents = 0xDEADBEEF;
+ WSAEnumNetworkEvents ((SOCKET) h, NULL, &ev);
+ return ev.lNetworkEvents != 0xDEADBEEF;
+}
+
+/* Compute output fd_sets for libc descriptor FD (whose Windows handle is
+ H). */
+
+static int
+windows_poll_handle (HANDLE h, int fd,
+ struct bitset *rbits,
+ struct bitset *wbits,
+ struct bitset *xbits)
+{
+ BOOL read, write, except;
+ int i, ret;
+ INPUT_RECORD *irbuffer;
+ DWORD avail, nbuffer;
+ BOOL bRet;
+ IO_STATUS_BLOCK iosb;
+ FILE_PIPE_LOCAL_INFORMATION fpli;
+ static PNtQueryInformationFile NtQueryInformationFile;
+ static BOOL once_only;
+
+ read = write = except = FALSE;
+ switch (GetFileType (h))
+ {
+ case FILE_TYPE_DISK:
+ read = TRUE;
+ write = TRUE;
+ break;
+
+ case FILE_TYPE_PIPE:
+ if (!once_only)
+ {
+ NtQueryInformationFile = (PNtQueryInformationFile)
+ GetProcAddress (GetModuleHandle ("ntdll.dll"),
+ "NtQueryInformationFile");
+ once_only = TRUE;
+ }
+
+ if (PeekNamedPipe (h, NULL, 0, NULL, &avail, NULL) != 0)
+ {
+ if (avail)
+ read = TRUE;
+ }
+ else if (GetLastError () == ERROR_BROKEN_PIPE)
+ ;
+
+ else
+ {
+ /* It was the write-end of the pipe. Check if it is writable.
+ If NtQueryInformationFile fails, optimistically assume the pipe is
+ writable. This could happen on Windows 9x, where
+ NtQueryInformationFile is not available, or if we inherit a pipe
+ that doesn't permit FILE_READ_ATTRIBUTES access on the write end
+ (I think this should not happen since Windows XP SP2; WINE seems
+ fine too). Otherwise, ensure that enough space is available for
+ atomic writes. */
+ memset (&iosb, 0, sizeof (iosb));
+ memset (&fpli, 0, sizeof (fpli));
+
+ if (!NtQueryInformationFile
+ || NtQueryInformationFile (h, &iosb, &fpli, sizeof (fpli),
+ FilePipeLocalInformation)
+ || fpli.WriteQuotaAvailable >= PIPE_BUF
+ || (fpli.OutboundQuota < PIPE_BUF &&
+ fpli.WriteQuotaAvailable == fpli.OutboundQuota))
+ write = TRUE;
+ }
+ break;
+
+ case FILE_TYPE_CHAR:
+ write = TRUE;
+ if (!(rbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1)))))
+ break;
+
+ ret = WaitForSingleObject (h, 0);
+ if (ret == WAIT_OBJECT_0)
+ {
+ if (!IsConsoleHandle (h))
+ {
+ read = TRUE;
+ break;
+ }
+
+ nbuffer = avail = 0;
+ bRet = GetNumberOfConsoleInputEvents (h, &nbuffer);
+
+ /* Screen buffers handles are filtered earlier. */
+ assert (bRet);
+ if (nbuffer == 0)
+ {
+ except = TRUE;
+ break;
+ }
+
+ irbuffer = (INPUT_RECORD *) alloca (nbuffer * sizeof (INPUT_RECORD));
+ bRet = PeekConsoleInput (h, irbuffer, nbuffer, &avail);
+ if (!bRet || avail == 0)
+ {
+ except = TRUE;
+ break;
+ }
+
+ for (i = 0; i < avail; i++)
+ if (irbuffer[i].EventType == KEY_EVENT)
+ read = TRUE;
+ }
+ break;
+
+ default:
+ ret = WaitForSingleObject (h, 0);
+ write = TRUE;
+ if (ret == WAIT_OBJECT_0)
+ read = TRUE;
+
+ break;
+ }
+
+ ret = 0;
+ if (read && (rbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1)))))
+ {
+ rbits->out[fd / CHAR_BIT] |= (1 << (fd & (CHAR_BIT - 1)));
+ ret++;
+ }
+
+ if (write && (wbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1)))))
+ {
+ wbits->out[fd / CHAR_BIT] |= (1 << (fd & (CHAR_BIT - 1)));
+ ret++;
+ }
+
+ if (except && (xbits->in[fd / CHAR_BIT] & (1 << (fd & (CHAR_BIT - 1)))))
+ {
+ xbits->out[fd / CHAR_BIT] |= (1 << (fd & (CHAR_BIT - 1)));
+ ret++;
+ }
+
+ return ret;
+}
+
+int
+rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds,
+ struct timeval *timeout)
+#undef timeval
+{
+ static struct timeval tv0;
+ static HANDLE hEvent;
+ HANDLE h, handle_array[FD_SETSIZE + 2];
+ fd_set handle_rfds, handle_wfds, handle_xfds;
+ struct bitset rbits, wbits, xbits;
+ unsigned char anyfds_in[FD_SETSIZE / CHAR_BIT];
+ DWORD ret, wait_timeout, nhandles, nsock, nbuffer;
+ MSG msg;
+ int i, fd, rc;
+
+ if (nfds > FD_SETSIZE)
+ nfds = FD_SETSIZE;
+
+ if (!timeout)
+ wait_timeout = INFINITE;
+ else
+ {
+ wait_timeout = timeout->tv_sec * 1000 + timeout->tv_usec / 1000;
+
+ /* select is also used as a portable usleep. */
+ if (!rfds && !wfds && !xfds)
+ {
+ Sleep (wait_timeout);
+ return 0;
+ }
+ }
+
+ if (!hEvent)
+ hEvent = CreateEvent (NULL, FALSE, FALSE, NULL);
+
+ handle_array[0] = hEvent;
+ nhandles = 1;
+ nsock = 0;
+
+ /* Copy descriptors to bitsets. At the same time, eliminate
+ bits in the "wrong" direction for console input buffers
+ and screen buffers, because screen buffers are waitable
+ and they will block until a character is available. */
+ memset (&rbits, 0, sizeof (rbits));
+ memset (&wbits, 0, sizeof (wbits));
+ memset (&xbits, 0, sizeof (xbits));
+ memset (anyfds_in, 0, sizeof (anyfds_in));
+ if (rfds)
+ for (i = 0; i < rfds->fd_count; i++)
+ {
+ fd = rfds->fd_array[i];
+ h = (HANDLE) _get_osfhandle (fd);
+ if (IsConsoleHandle (h)
+ && !GetNumberOfConsoleInputEvents (h, &nbuffer))
+ continue;
+
+ rbits.in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1));
+ anyfds_in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1));
+ }
+ else
+ rfds = (fd_set *) alloca (sizeof (fd_set));
+
+ if (wfds)
+ for (i = 0; i < wfds->fd_count; i++)
+ {
+ fd = wfds->fd_array[i];
+ h = (HANDLE) _get_osfhandle (fd);
+ if (IsConsoleHandle (h)
+ && GetNumberOfConsoleInputEvents (h, &nbuffer))
+ continue;
+
+ wbits.in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1));
+ anyfds_in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1));
+ }
+ else
+ wfds = (fd_set *) alloca (sizeof (fd_set));
+
+ if (xfds)
+ for (i = 0; i < xfds->fd_count; i++)
+ {
+ fd = xfds->fd_array[i];
+ xbits.in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1));
+ anyfds_in[fd / CHAR_BIT] |= 1 << (fd & (CHAR_BIT - 1));
+ }
+ else
+ xfds = (fd_set *) alloca (sizeof (fd_set));
+
+ /* Zero all the fd_sets, including the application's. */
+ FD_ZERO (rfds);
+ FD_ZERO (wfds);
+ FD_ZERO (xfds);
+ FD_ZERO (&handle_rfds);
+ FD_ZERO (&handle_wfds);
+ FD_ZERO (&handle_xfds);
+
+ /* Classify handles. Create fd sets for sockets, poll the others. */
+ for (i = 0; i < nfds; i++)
+ {
+ if ((anyfds_in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) == 0)
+ continue;
+
+ h = (HANDLE) _get_osfhandle (i);
+ if (!h)
+ {
+ errno = EBADF;
+ return -1;
+ }
+
+ if (IsSocketHandle (h))
+ {
+ int requested = FD_CLOSE;
+
+ /* See above; socket handles are mapped onto select, but we
+ need to map descriptors to handles. */
+ if (rbits.in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ {
+ requested |= FD_READ | FD_ACCEPT;
+ FD_SET ((SOCKET) h, rfds);
+ FD_SET ((SOCKET) h, &handle_rfds);
+ }
+ if (wbits.in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ {
+ requested |= FD_WRITE | FD_CONNECT;
+ FD_SET ((SOCKET) h, wfds);
+ FD_SET ((SOCKET) h, &handle_wfds);
+ }
+ if (xbits.in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ {
+ requested |= FD_OOB;
+ FD_SET ((SOCKET) h, xfds);
+ FD_SET ((SOCKET) h, &handle_xfds);
+ }
+
+ WSAEventSelect ((SOCKET) h, hEvent, requested);
+ nsock++;
+ }
+ else
+ {
+ handle_array[nhandles++] = h;
+
+ /* Poll now. If we get an event, do not wait below. */
+ if (wait_timeout != 0
+ && windows_poll_handle (h, i, &rbits, &wbits, &xbits))
+ wait_timeout = 0;
+ }
+ }
+
+ /* Place a sentinel at the end of the array. */
+ handle_array[nhandles] = NULL;
+
+restart:
+ if (wait_timeout == 0 || nsock == 0)
+ rc = 0;
+ else
+ {
+ /* See if we need to wait in the loop below. If any select is ready,
+ do MsgWaitForMultipleObjects anyway to dispatch messages, but
+ no need to call select again. */
+ rc = select (0, &handle_rfds, &handle_wfds, &handle_xfds, &tv0);
+ if (rc == 0)
+ {
+ /* Restore the fd_sets for the other select we do below. */
+ memcpy (&handle_rfds, rfds, sizeof (fd_set));
+ memcpy (&handle_wfds, wfds, sizeof (fd_set));
+ memcpy (&handle_xfds, xfds, sizeof (fd_set));
+ }
+ else
+ wait_timeout = 0;
+ }
+
+ for (;;)
+ {
+ ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE,
+ wait_timeout, QS_ALLINPUT);
+
+ if (ret == WAIT_OBJECT_0 + nhandles)
+ {
+ /* new input of some other kind */
+ BOOL bRet;
+ while ((bRet = PeekMessage (&msg, NULL, 0, 0, PM_REMOVE)) != 0)
+ {
+ TranslateMessage (&msg);
+ DispatchMessage (&msg);
+ }
+ }
+ else
+ break;
+ }
+
+ /* If we haven't done it yet, check the status of the sockets. */
+ if (rc == 0 && nsock > 0)
+ rc = select (0, &handle_rfds, &handle_wfds, &handle_xfds, &tv0);
+
+ if (nhandles > 1)
+ {
+ /* Count results that are not counted in the return value of select. */
+ nhandles = 1;
+ for (i = 0; i < nfds; i++)
+ {
+ if ((anyfds_in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) == 0)
+ continue;
+
+ h = (HANDLE) _get_osfhandle (i);
+ if (h == handle_array[nhandles])
+ {
+ /* Not a socket. */
+ nhandles++;
+ windows_poll_handle (h, i, &rbits, &wbits, &xbits);
+ if (rbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))
+ || wbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))
+ || xbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ rc++;
+ }
+ }
+
+ if (rc == 0 && wait_timeout == INFINITE)
+ {
+ /* Sleep 1 millisecond to avoid busy wait and retry with the
+ original fd_sets. */
+ memcpy (&handle_rfds, rfds, sizeof (fd_set));
+ memcpy (&handle_wfds, wfds, sizeof (fd_set));
+ memcpy (&handle_xfds, xfds, sizeof (fd_set));
+ SleepEx (1, TRUE);
+ goto restart;
+ }
+ }
+
+ /* Now fill in the results. */
+ FD_ZERO (rfds);
+ FD_ZERO (wfds);
+ FD_ZERO (xfds);
+ nhandles = 1;
+ for (i = 0; i < nfds; i++)
+ {
+ if ((anyfds_in[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1)))) == 0)
+ continue;
+
+ h = (HANDLE) _get_osfhandle (i);
+ if (h != handle_array[nhandles])
+ {
+ /* Perform handle->descriptor mapping. */
+ WSAEventSelect ((SOCKET) h, NULL, 0);
+ if (FD_ISSET (h, &handle_rfds))
+ FD_SET (i, rfds);
+ if (FD_ISSET (h, &handle_wfds))
+ FD_SET (i, wfds);
+ if (FD_ISSET (h, &handle_xfds))
+ FD_SET (i, xfds);
+ }
+ else
+ {
+ /* Not a socket. */
+ nhandles++;
+ if (rbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ FD_SET (i, rfds);
+ if (wbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ FD_SET (i, wfds);
+ if (xbits.out[i / CHAR_BIT] & (1 << (i & (CHAR_BIT - 1))))
+ FD_SET (i, xfds);
+ }
+ }
+
+ return rc;
+}
+
+#else /* ! Native Windows. */
+
+#include <sys/select.h>
+#include <stddef.h> /* NULL */
+#include <errno.h>
+#include <unistd.h>
+
+#undef select
+
+int
+rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds,
+ struct timeval *timeout)
+{
+ int i;
+
+ /* FreeBSD 8.2 has a bug: it does not always detect invalid fds. */
+ if (nfds < 0 || nfds > FD_SETSIZE)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+ for (i = 0; i < nfds; i++)
+ {
+ if (((rfds && FD_ISSET (i, rfds))
+ || (wfds && FD_ISSET (i, wfds))
+ || (xfds && FD_ISSET (i, xfds)))
+ && dup2 (i, i) != i)
+ return -1;
+ }
+
+ /* Interix 3.5 has a bug: it does not support nfds == 0. */
+ if (nfds == 0)
+ {
+ nfds = 1;
+ rfds = NULL;
+ wfds = NULL;
+ xfds = NULL;
+ }
+ return select (nfds, rfds, wfds, xfds, timeout);
+}
+
+#endif
diff --git a/lib/send.c b/lib/send.c
index 64d0e8d..3e76ce1 100644
--- a/lib/send.c
+++ b/lib/send.c
@@ -1,6 +1,6 @@
/* send.c --- wrappers for Windows send function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/sendto.c b/lib/sendto.c
index 7a8e994..2154582 100644
--- a/lib/sendto.c
+++ b/lib/sendto.c
@@ -1,6 +1,6 @@
/* sendto.c --- wrappers for Windows sendto function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/setenv.c b/lib/setenv.c
index 75f423f..8076c54 100644
--- a/lib/setenv.c
+++ b/lib/setenv.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1992, 1995-2003, 2005-2012 Free Software Foundation, Inc.
+/* Copyright (C) 1992, 1995-2003, 2005-2013 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
@@ -15,14 +15,14 @@
along with this program. If not, see <http://www.gnu.org/licenses/>. */
#if !_LIBC
+/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
+ optimizes away the name == NULL test below. */
+# define _GL_ARG_NONNULL(params)
+
# define _GL_USE_STDLIB_ALLOC 1
# include <config.h>
#endif
-/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
- optimizes away the name == NULL test below. */
-#define _GL_ARG_NONNULL(params)
-
#include <alloca.h>
/* Specification. */
diff --git a/lib/setsockopt.c b/lib/setsockopt.c
index 07e9023..7a50835 100644
--- a/lib/setsockopt.c
+++ b/lib/setsockopt.c
@@ -1,6 +1,6 @@
/* setsockopt.c --- wrappers for Windows setsockopt function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/shutdown.c b/lib/shutdown.c
index 1e646a9..2f5fc54 100644
--- a/lib/shutdown.c
+++ b/lib/shutdown.c
@@ -1,6 +1,6 @@
/* shutdown.c --- wrappers for Windows shutdown function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/signal.in.h b/lib/signal.in.h
index 627ae17..6f96f0d 100644
--- a/lib/signal.in.h
+++ b/lib/signal.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <signal.h>.
- Copyright (C) 2006-2012 Free Software Foundation, Inc.
+ Copyright (C) 2006-2013 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 60d50f1..20fb1b7 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2009-2013 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
index eb27f5d..3cccf48 100644
--- a/lib/snprintf.c
+++ b/lib/snprintf.c
@@ -1,5 +1,5 @@
/* Formatted output to strings.
- Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2006-2013 Free Software Foundation, Inc.
Written by Simon Josefsson and Paul Eggert.
This program is free software; you can redistribute it and/or modify
diff --git a/lib/socket.c b/lib/socket.c
index 24f16c9..17fecc4 100644
--- a/lib/socket.c
+++ b/lib/socket.c
@@ -1,6 +1,6 @@
/* socket.c --- wrappers for Windows socket function
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/sockets.c b/lib/sockets.c
index 635479a..d4652a2 100644
--- a/lib/sockets.c
+++ b/lib/sockets.c
@@ -1,6 +1,6 @@
/* sockets.c --- wrappers for Windows socket functions
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/sockets.h b/lib/sockets.h
index 35d6923..4eb4dcb 100644
--- a/lib/sockets.h
+++ b/lib/sockets.h
@@ -1,6 +1,6 @@
/* sockets.h - wrappers for Windows socket functions
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/stat-time.h b/lib/stat-time.h
index daf2ca6..a3dff54 100644
--- a/lib/stat-time.h
+++ b/lib/stat-time.h
@@ -1,6 +1,6 @@
/* stat-related time functions.
- Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005, 2007, 2009-2013 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/stat.c b/lib/stat.c
index f46e31d..c42962b 100644
--- a/lib/stat.c
+++ b/lib/stat.c
@@ -1,5 +1,5 @@
/* Work around platform bugs in stat.
- Copyright (C) 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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
@@ -42,7 +42,7 @@
# endif
#endif
-static inline int
+static int
orig_stat (const char *filename, struct stat *buf)
{
return stat (filename, buf);
diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h
index e043871..d9b2eec 100644
--- a/lib/stdalign.in.h
+++ b/lib/stdalign.in.h
@@ -1,6 +1,6 @@
/* A substitute for ISO C11 <stdalign.h>.
- Copyright 2011-2012 Free Software Foundation, Inc.
+ Copyright 2011-2013 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 4193429..bd629ed 100644
--- a/lib/stdbool.in.h
+++ b/lib/stdbool.in.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001-2003, 2006-2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001-2003, 2006-2013 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 e17ef24..614c9bc 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2009-2013 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 3a73abf..889bca7 100644
--- a/lib/stdint.in.h
+++ b/lib/stdint.in.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001-2002, 2004-2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001-2002, 2004-2013 Free Software Foundation, Inc.
Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood.
This file is part of gnulib.
@@ -39,7 +39,7 @@
Ideally we should test __BIONIC__ here, but it is only defined after
<sys/cdefs.h> has been included; hence test __ANDROID__ instead. */
#if defined __ANDROID__ \
- && defined _SYS_TYPES_H_ && !defined _SSIZE_T_DEFINED_
+ && defined _SYS_TYPES_H_ && !defined __need_size_t
# @INCLUDE_NEXT@ @NEXT_STDINT_H@
#else
diff --git a/lib/stdio.in.h b/lib/stdio.in.h
index f7e06ad..bc3fccb 100644
--- a/lib/stdio.in.h
+++ b/lib/stdio.in.h
@@ -1,6 +1,6 @@
/* A GNU-like <stdio.h>.
- Copyright (C) 2004, 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2007-2013 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
@@ -575,21 +575,17 @@ _GL_CXXALIAS_RPL (fwrite, size_t,
_GL_CXXALIAS_SYS (fwrite, size_t,
(const void *ptr, size_t s, size_t n, FILE *stream));
-/* Work around glibc bug 11959
+/* Work around bug 11959 when fortifying glibc 2.4 through 2.15
<http://sources.redhat.com/bugzilla/show_bug.cgi?id=11959>,
which sometimes causes an unwanted diagnostic for fwrite calls.
- This affects only function declaration attributes, so it's not
- needed for C++. */
-# if !defined __cplusplus && 0 < __USE_FORTIFY_LEVEL
-static inline size_t _GL_ARG_NONNULL ((1, 4))
-rpl_fwrite (const void *ptr, size_t s, size_t n, FILE *stream)
-{
- size_t r = fwrite (ptr, s, n, stream);
- (void) r;
- return r;
-}
+ This affects only function declaration attributes under certain
+ versions of gcc, and is not needed for C++. */
+# if (0 < __USE_FORTIFY_LEVEL \
+ && __GLIBC__ == 2 && 4 <= __GLIBC_MINOR__ && __GLIBC_MINOR__ <= 15 \
+ && 3 < __GNUC__ + (4 <= __GNUC_MINOR__) \
+ && !defined __cplusplus)
# undef fwrite
-# define fwrite rpl_fwrite
+# define fwrite(a, b, c, d) ({size_t __r = fwrite (a, b, c, d); __r; })
# endif
# endif
_GL_CXXALIASWARN (fwrite);
@@ -1333,7 +1329,6 @@ _GL_WARN_ON_USE (vsprintf, "vsprintf is not always POSIX
compliant - "
"POSIX compliance");
#endif
-
#endif /* address@hidden@_STDIO_H */
#endif /* address@hidden@_STDIO_H */
#endif
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
index b67a348..552fdf0 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 1995, 2001-2004, 2006-2013 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
@@ -20,8 +20,9 @@
#endif
@PRAGMA_COLUMNS@
-#if defined __need_malloc_and_calloc
-/* Special invocation convention inside glibc header files. */
+#if defined __need_system_stdlib_h || defined __need_malloc_and_calloc
+/* Special invocation conventions inside some gnulib header files,
+ and inside some glibc header files, respectively. */
address@hidden@ @NEXT_STDLIB_H@
@@ -766,6 +767,22 @@ _GL_WARN_ON_USE (rpmatch, "rpmatch is unportable - "
# endif
#endif
+#if @GNULIB_SECURE_GETENV@
+/* Look up NAME in the environment, returning 0 in insecure situations. */
+# if address@hidden@
+_GL_FUNCDECL_SYS (secure_getenv, char *,
+ (char const *name) _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (secure_getenv, char *, (char const *name));
+_GL_CXXALIASWARN (secure_getenv);
+#elif defined GNULIB_POSIXCHECK
+# undef secure_getenv
+# if HAVE_RAW_DECL_SECURE_GETENV
+_GL_WARN_ON_USE (secure_getenv, "secure_getenv is unportable - "
+ "use gnulib module secure_getenv for portability");
+# endif
+#endif
+
#if @GNULIB_SETENV@
/* Set NAME to VALUE in the environment.
If REPLACE is nonzero, overwrite an existing value. */
diff --git a/lib/streq.h b/lib/streq.h
index 7fd07c8..03ede61 100644
--- a/lib/streq.h
+++ b/lib/streq.h
@@ -1,5 +1,5 @@
/* Optimized string comparison.
- Copyright (C) 2001-2002, 2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2007, 2009-2013 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 f5fc3c9..058ba11 100644
--- a/lib/strftime.c
+++ b/lib/strftime.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1991-2001, 2003-2007, 2009-2012 Free Software Foundation, Inc.
+/* Copyright (C) 1991-2001, 2003-2007, 2009-2013 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
@@ -26,7 +26,6 @@
#else
# include <config.h>
# if FPRINTFTIME
-# include "ignore-value.h"
# include "fprintftime.h"
# else
# include "strftime.h"
@@ -210,13 +209,12 @@ extern char *tzname[];
fwrite_uppcase (p, (s), _n); \
else \
{ \
- /* We are ignoring the value of fwrite here, in spite of the \
- fact that technically, that may not be valid: the fwrite \
- specification in POSIX 2008 defers to that of fputc, which \
- is intended to be consistent with the one from ISO C, \
- which permits failure due to ENOMEM *without* setting the \
- stream's error indicator. */ \
- ignore_value (fwrite ((s), _n, 1, p)); \
+ /* Ignore the value of fwrite. The caller can determine whether \
+ an error occurred by inspecting ferror (P). All known fwrite \
+ implementations set the stream's error indicator when they \
+ fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \
+ not require this. */ \
+ fwrite (s, _n, 1, p); \
} \
} \
while (0) \
diff --git a/lib/strftime.h b/lib/strftime.h
index 596b0b8..a521875 100644
--- a/lib/strftime.h
+++ b/lib/strftime.h
@@ -1,6 +1,6 @@
/* declarations for strftime.c
- Copyright (C) 2002, 2004, 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2004, 2008-2013 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 8a38236..bc841eb 100644
--- a/lib/striconveh.c
+++ b/lib/striconveh.c
@@ -1,5 +1,5 @@
/* Character set conversion with error handling.
- Copyright (C) 2001-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2013 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 77730a0..ea6a6dc 100644
--- a/lib/striconveh.h
+++ b/lib/striconveh.h
@@ -1,5 +1,5 @@
/* Character set conversion with error handling.
- Copyright (C) 2001-2007, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2007, 2009-2013 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 0c23526..5dcf8de 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 1995-1996, 2001-2013 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/stripslash.c b/lib/stripslash.c
index 63b77cd..16d4339 100644
--- a/lib/stripslash.c
+++ b/lib/stripslash.c
@@ -1,6 +1,6 @@
/* stripslash.c -- remove redundant trailing slashes from a file name
- Copyright (C) 1990, 2001, 2003-2006, 2009-2012 Free Software Foundation,
+ Copyright (C) 1990, 2001, 2003-2006, 2009-2013 Free Software Foundation,
Inc.
This program is free software: you can redistribute it and/or modify
diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h
index 476f2f6..152311c 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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_select.in.h b/lib/sys_select.in.h
new file mode 100644
index 0000000..0e3e32d
--- /dev/null
+++ b/lib/sys_select.in.h
@@ -0,0 +1,309 @@
+/* Substitute for <sys/select.h>.
+ Copyright (C) 2007-2013 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+# if __GNUC__ >= 3
address@hidden@
+# endif
address@hidden@
+
+/* On OSF/1 and Solaris 2.6, <sys/types.h> and <sys/time.h>
+ both include <sys/select.h>.
+ Simply delegate to the system's header in this case. */
+#if (@HAVE_SYS_SELECT_H@ \
+ && ((defined __osf__ && defined _SYS_TYPES_H_ && defined _OSF_SOURCE) \
+ || (defined __sun && defined _SYS_TYPES_H \
+ && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \
+ || defined __EXTENSIONS__))) \
+ && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H)
+
+# define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H
+# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@
+
+#elif (@HAVE_SYS_SELECT_H@ \
+ && ((defined __osf__ && defined _SYS_TIME_H_ && defined _OSF_SOURCE) \
+ || (defined __sun && defined _SYS_TIME_H \
+ && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \
+ || defined __EXTENSIONS__))) \
+ && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H)
+
+# define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H
+# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@
+
+/* On IRIX 6.5, <sys/timespec.h> includes <sys/types.h>, which includes
+ <sys/bsd_types.h>, which includes <sys/select.h>. At this point we cannot
+ include <signal.h>, because that includes <internal/signal_core.h>, which
+ gives a syntax error because <sys/timespec.h> has not been completely
+ processed. Simply delegate to the system's header in this case. */
+#elif @HAVE_SYS_SELECT_H@ && defined __sgi && (defined _SYS_BSD_TYPES_H &&
!defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_BSD_TYPES_H)
+
+# define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_BSD_TYPES_H
+# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@
+
+/* On OpenBSD 5.0, <pthread.h> includes <sys/types.h>, which includes
+ <sys/select.h>. At this point we cannot include <signal.h>, because that
+ includes gnulib's pthread.h override, which gives a syntax error because
+ /usr/include/pthread.h has not been completely processed. Simply delegate
+ to the system's header in this case. */
+#elif @HAVE_SYS_SELECT_H@ && defined __OpenBSD__ && (defined _PTHREAD_H_ &&
!defined PTHREAD_MUTEX_INITIALIZER)
+
+# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@
+
+#else
+
+#ifndef address@hidden@_SYS_SELECT_H
+
+/* On many platforms, <sys/select.h> assumes prior inclusion of
+ <sys/types.h>. Also, mingw defines sigset_t there, instead of
+ in <signal.h> where it belongs. */
+#include <sys/types.h>
+
+#if @HAVE_SYS_SELECT_H@
+
+/* On OSF/1 4.0, <sys/select.h> provides only a forward declaration
+ of 'struct timeval', and no definition of this type.
+ Also, Mac OS X, AIX, HP-UX, IRIX, Solaris, Interix declare select()
+ in <sys/time.h>.
+ But avoid namespace pollution on glibc systems. */
+# ifndef __GLIBC__
+# include <sys/time.h>
+# endif
+
+/* On AIX 7 and Solaris 10, <sys/select.h> provides an FD_ZERO implementation
+ that relies on memset(), but without including <string.h>.
+ But in any case avoid namespace pollution on glibc systems. */
+# if (defined __OpenBSD__ || defined _AIX || defined __sun || defined __osf__
|| defined __BEOS__) \
+ && ! defined __GLIBC__
+# include <string.h>
+# endif
+
+/* The include_next requires a split double-inclusion guard. */
+# @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@
+
+#endif
+
+/* Get definition of 'sigset_t'.
+ But avoid namespace pollution on glibc systems.
+ Do this after the include_next (for the sake of OpenBSD 5.0) but before
+ the split double-inclusion guard (for the sake of Solaris). */
+#if !(defined __GLIBC__ && !defined __UCLIBC__)
+# include <signal.h>
+#endif
+
+#ifndef address@hidden@_SYS_SELECT_H
+#define address@hidden@_SYS_SELECT_H
+
+#if address@hidden@
+/* A platform that lacks <sys/select.h>. */
+/* Get the 'struct timeval' and 'fd_set' types and the FD_* macros
+ on most platforms. */
+# include <sys/time.h>
+/* On HP-UX 11, <sys/time.h> provides an FD_ZERO implementation
+ that relies on memset(), but without including <string.h>. */
+# if defined __hpux
+# include <string.h>
+# endif
+/* On native Windows platforms:
+ Get the 'fd_set' type.
+ Get the close() declaration before we override it. */
+# if @HAVE_WINSOCK2_H@
+# if !defined _GL_INCLUDING_WINSOCK2_H
+# define _GL_INCLUDING_WINSOCK2_H
+# include <winsock2.h>
+# undef _GL_INCLUDING_WINSOCK2_H
+# endif
+# include <io.h>
+# endif
+#endif
+
+/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
+
+/* The definition of _GL_WARN_ON_USE is copied here. */
+
+
+/* Fix some definitions from <winsock2.h>. */
+
+#if @HAVE_WINSOCK2_H@
+
+# if !GNULIB_defined_rpl_fd_isset
+
+/* Re-define FD_ISSET to avoid a WSA call while we are not using
+ network sockets. */
+static int
+rpl_fd_isset (SOCKET fd, fd_set * set)
+{
+ u_int i;
+ if (set == NULL)
+ return 0;
+
+ for (i = 0; i < set->fd_count; i++)
+ if (set->fd_array[i] == fd)
+ return 1;
+
+ return 0;
+}
+
+# define GNULIB_defined_rpl_fd_isset 1
+# endif
+
+# undef FD_ISSET
+# define FD_ISSET(fd, set) rpl_fd_isset(fd, set)
+
+#endif
+
+/* Hide some function declarations from <winsock2.h>. */
+
+#if @HAVE_WINSOCK2_H@
+# if !defined address@hidden@_UNISTD_H
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef close
+# define close close_used_without_including_unistd_h
+# else
+ _GL_WARN_ON_USE (close,
+ "close() used without including <unistd.h>");
+# endif
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef gethostname
+# define gethostname gethostname_used_without_including_unistd_h
+# else
+ _GL_WARN_ON_USE (gethostname,
+ "gethostname() used without including <unistd.h>");
+# endif
+# endif
+# if !defined address@hidden@_SYS_SOCKET_H
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef socket
+# define socket socket_used_without_including_sys_socket_h
+# undef connect
+# define connect connect_used_without_including_sys_socket_h
+# undef accept
+# define accept accept_used_without_including_sys_socket_h
+# undef bind
+# define bind bind_used_without_including_sys_socket_h
+# undef getpeername
+# define getpeername getpeername_used_without_including_sys_socket_h
+# undef getsockname
+# define getsockname getsockname_used_without_including_sys_socket_h
+# undef getsockopt
+# define getsockopt getsockopt_used_without_including_sys_socket_h
+# undef listen
+# define listen listen_used_without_including_sys_socket_h
+# undef recv
+# define recv recv_used_without_including_sys_socket_h
+# undef send
+# define send send_used_without_including_sys_socket_h
+# undef recvfrom
+# define recvfrom recvfrom_used_without_including_sys_socket_h
+# undef sendto
+# define sendto sendto_used_without_including_sys_socket_h
+# undef setsockopt
+# define setsockopt setsockopt_used_without_including_sys_socket_h
+# undef shutdown
+# define shutdown shutdown_used_without_including_sys_socket_h
+# else
+ _GL_WARN_ON_USE (socket,
+ "socket() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (connect,
+ "connect() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (accept,
+ "accept() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (bind,
+ "bind() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (getpeername,
+ "getpeername() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (getsockname,
+ "getsockname() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (getsockopt,
+ "getsockopt() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (listen,
+ "listen() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (recv,
+ "recv() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (send,
+ "send() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (recvfrom,
+ "recvfrom() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (sendto,
+ "sendto() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (setsockopt,
+ "setsockopt() used without including <sys/socket.h>");
+ _GL_WARN_ON_USE (shutdown,
+ "shutdown() used without including <sys/socket.h>");
+# endif
+# endif
+#endif
+
+
+#if @GNULIB_PSELECT@
+# if @REPLACE_PSELECT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef pselect
+# define pselect rpl_pselect
+# endif
+_GL_FUNCDECL_RPL (pselect, int,
+ (int, fd_set *restrict, fd_set *restrict, fd_set *restrict,
+ struct timespec const *restrict, const sigset_t *restrict));
+_GL_CXXALIAS_RPL (pselect, int,
+ (int, fd_set *restrict, fd_set *restrict, fd_set *restrict,
+ struct timespec const *restrict, const sigset_t *restrict));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (pselect, int,
+ (int, fd_set *restrict, fd_set *restrict, fd_set *restrict,
+ struct timespec const *restrict, const sigset_t *restrict));
+# endif
+_GL_CXXALIAS_SYS (pselect, int,
+ (int, fd_set *restrict, fd_set *restrict, fd_set *restrict,
+ struct timespec const *restrict, const sigset_t *restrict));
+# endif
+_GL_CXXALIASWARN (pselect);
+#elif defined GNULIB_POSIXCHECK
+# undef pselect
+# if HAVE_RAW_DECL_PSELECT
+_GL_WARN_ON_USE (pselect, "pselect is not portable - "
+ "use gnulib module pselect for portability");
+# endif
+#endif
+
+#if @GNULIB_SELECT@
+# if @REPLACE_SELECT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef select
+# define select rpl_select
+# endif
+_GL_FUNCDECL_RPL (select, int,
+ (int, fd_set *, fd_set *, fd_set *, struct timeval *));
+_GL_CXXALIAS_RPL (select, int,
+ (int, fd_set *, fd_set *, fd_set *, struct timeval *));
+# else
+_GL_CXXALIAS_SYS (select, int,
+ (int, fd_set *, fd_set *, fd_set *, struct timeval *));
+# endif
+_GL_CXXALIASWARN (select);
+#elif @HAVE_WINSOCK2_H@
+# undef select
+# define select select_used_without_requesting_gnulib_module_select
+#elif defined GNULIB_POSIXCHECK
+# undef select
+# if HAVE_RAW_DECL_SELECT
+_GL_WARN_ON_USE (select, "select is not always POSIX compliant - "
+ "use gnulib module select for portability");
+# endif
+#endif
+
+
+#endif /* address@hidden@_SYS_SELECT_H */
+#endif /* address@hidden@_SYS_SELECT_H */
+#endif /* OSF/1 */
diff --git a/lib/sys_socket.c b/lib/sys_socket.c
new file mode 100644
index 0000000..3f017f8
--- /dev/null
+++ b/lib/sys_socket.c
@@ -0,0 +1,3 @@
+#include <config.h>
+#define _GL_SYS_SOCKET_INLINE _GL_EXTERN_INLINE
+#include "sys/socket.h"
diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h
index a0bcffb..31ed042 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005-2013 Free Software Foundation, Inc.
Written by Simon Josefsson.
This program is free software; you can redistribute it and/or modify
@@ -63,6 +63,11 @@
#ifndef address@hidden@_SYS_SOCKET_H
#define address@hidden@_SYS_SOCKET_H
+_GL_INLINE_HEADER_BEGIN
+#ifndef _GL_SYS_SOCKET_INLINE
+# define _GL_SYS_SOCKET_INLINE _GL_INLINE
+#endif
+
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
@@ -201,7 +206,7 @@ struct msghdr {
/* Re-define FD_ISSET to avoid a WSA call while we are not using
network sockets. */
-static inline int
+_GL_SYS_SOCKET_INLINE int
rpl_fd_isset (SOCKET fd, fd_set * set)
{
u_int i;
@@ -677,6 +682,8 @@ _GL_WARN_ON_USE (accept4, "accept4 is unportable - "
# endif
#endif
+_GL_INLINE_HEADER_END
+
#endif /* address@hidden@_SYS_SOCKET_H */
#endif /* address@hidden@_SYS_SOCKET_H */
#endif
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h
index 97fb3c4..12f99da 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005-2013 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
@@ -150,6 +150,10 @@
# endif
#endif
+#ifndef S_ISMPX /* AIX */
+# define S_ISMPX(m) 0
+#endif
+
#ifndef S_ISNAM /* Xenix */
# ifdef S_IFNAM
# define S_ISNAM(m) (((m) & S_IFMT) == S_IFNAM)
@@ -497,7 +501,7 @@ _GL_CXXALIAS_RPL (mkdir, int, (char const *name, mode_t
mode));
# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
# if !GNULIB_defined_rpl_mkdir
-static inline int
+static int
rpl_mkdir (char const *name, mode_t mode)
{
return _mkdir (name);
diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h
index 3dbbf91..f2398c5 100644
--- a/lib/sys_time.in.h
+++ b/lib/sys_time.in.h
@@ -1,6 +1,6 @@
/* Provide a more complete sys/time.h.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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
@@ -17,37 +17,34 @@
/* Written by Paul Eggert. */
+#ifndef address@hidden@_SYS_TIME_H
+
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
#endif
@PRAGMA_COLUMNS@
-#if defined address@hidden@_SYS_TIME_H
-
-/* Simply delegate to the system's header, without adding anything. */
-# if @HAVE_SYS_TIME_H@
-# @INCLUDE_NEXT@ @NEXT_SYS_TIME_H@
-# endif
-
-#else
+/* The include_next requires a split double-inclusion guard. */
+#if @HAVE_SYS_TIME_H@
+# @INCLUDE_NEXT@ @NEXT_SYS_TIME_H@
+#endif
-# define address@hidden@_SYS_TIME_H
+#ifndef address@hidden@_SYS_TIME_H
+#define address@hidden@_SYS_TIME_H
-# if @HAVE_SYS_TIME_H@
-# @INCLUDE_NEXT@ @NEXT_SYS_TIME_H@
-# else
-# include <time.h>
-# endif
+#if ! @HAVE_SYS_TIME_H@
+# include <time.h>
+#endif
/* On native Windows with MSVC, get the 'struct timeval' type.
Also, on native Windows with a 64-bit time_t, where we are overriding the
'struct timeval' type, get all declarations of system functions whose
signature contains 'struct timeval'. */
-# if (defined _MSC_VER || @REPLACE_STRUCT_TIMEVAL@) && @HAVE_WINSOCK2_H@ &&
!defined _GL_INCLUDING_WINSOCK2_H
-# define _GL_INCLUDING_WINSOCK2_H
-# include <winsock2.h>
-# undef _GL_INCLUDING_WINSOCK2_H
-# endif
+#if (defined _MSC_VER || @REPLACE_STRUCT_TIMEVAL@) && @HAVE_WINSOCK2_H@ &&
!defined _GL_INCLUDING_WINSOCK2_H
+# define _GL_INCLUDING_WINSOCK2_H
+# include <winsock2.h>
+# undef _GL_INCLUDING_WINSOCK2_H
+#endif
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
@@ -55,112 +52,112 @@
/* The definition of _GL_WARN_ON_USE is copied here. */
-# ifdef __cplusplus
+#ifdef __cplusplus
extern "C" {
-# endif
+#endif
-# if address@hidden@ || @REPLACE_STRUCT_TIMEVAL@
+#if address@hidden@ || @REPLACE_STRUCT_TIMEVAL@
-# if @REPLACE_STRUCT_TIMEVAL@
-# define timeval rpl_timeval
-# endif
+# if @REPLACE_STRUCT_TIMEVAL@
+# define timeval rpl_timeval
+# endif
-# if !GNULIB_defined_struct_timeval
+# if !GNULIB_defined_struct_timeval
struct timeval
{
time_t tv_sec;
long int tv_usec;
};
-# define GNULIB_defined_struct_timeval 1
-# endif
-
+# define GNULIB_defined_struct_timeval 1
# endif
-# ifdef __cplusplus
+#endif
+
+#ifdef __cplusplus
}
-# endif
+#endif
-# if @GNULIB_GETTIMEOFDAY@
-# if @REPLACE_GETTIMEOFDAY@
-# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
-# undef gettimeofday
-# define gettimeofday rpl_gettimeofday
-# endif
+#if @GNULIB_GETTIMEOFDAY@
+# if @REPLACE_GETTIMEOFDAY@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef gettimeofday
+# define gettimeofday rpl_gettimeofday
+# endif
_GL_FUNCDECL_RPL (gettimeofday, int,
(struct timeval *restrict, void *restrict)
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (gettimeofday, int,
(struct timeval *restrict, void *restrict));
-# else
-# if address@hidden@
+# else
+# if address@hidden@
_GL_FUNCDECL_SYS (gettimeofday, int,
(struct timeval *restrict, void *restrict)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
/* Need to cast, because on glibc systems, by default, the second argument is
struct timezone *. */
_GL_CXXALIAS_SYS_CAST (gettimeofday, int,
(struct timeval *restrict, void *restrict));
-# endif
+# endif
_GL_CXXALIASWARN (gettimeofday);
-# elif defined GNULIB_POSIXCHECK
-# undef gettimeofday
-# if HAVE_RAW_DECL_GETTIMEOFDAY
+#elif defined GNULIB_POSIXCHECK
+# undef gettimeofday
+# if HAVE_RAW_DECL_GETTIMEOFDAY
_GL_WARN_ON_USE (gettimeofday, "gettimeofday is unportable - "
"use gnulib module gettimeofday for portability");
-# endif
# endif
+#endif
/* Hide some function declarations from <winsock2.h>. */
-# if defined _MSC_VER && @HAVE_WINSOCK2_H@
-# if !defined address@hidden@_UNISTD_H
-# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
-# undef close
-# define close close_used_without_including_unistd_h
-# else
+#if defined _MSC_VER && @HAVE_WINSOCK2_H@
+# if !defined address@hidden@_UNISTD_H
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef close
+# define close close_used_without_including_unistd_h
+# else
_GL_WARN_ON_USE (close,
"close() used without including <unistd.h>");
-# endif
-# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
-# undef gethostname
-# define gethostname gethostname_used_without_including_unistd_h
-# else
+# endif
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef gethostname
+# define gethostname gethostname_used_without_including_unistd_h
+# else
_GL_WARN_ON_USE (gethostname,
"gethostname() used without including <unistd.h>");
-# endif
# endif
-# if !defined address@hidden@_SYS_SOCKET_H
-# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
-# undef socket
-# define socket socket_used_without_including_sys_socket_h
-# undef connect
-# define connect connect_used_without_including_sys_socket_h
-# undef accept
-# define accept accept_used_without_including_sys_socket_h
-# undef bind
-# define bind bind_used_without_including_sys_socket_h
-# undef getpeername
-# define getpeername getpeername_used_without_including_sys_socket_h
-# undef getsockname
-# define getsockname getsockname_used_without_including_sys_socket_h
-# undef getsockopt
-# define getsockopt getsockopt_used_without_including_sys_socket_h
-# undef listen
-# define listen listen_used_without_including_sys_socket_h
-# undef recv
-# define recv recv_used_without_including_sys_socket_h
-# undef send
-# define send send_used_without_including_sys_socket_h
-# undef recvfrom
-# define recvfrom recvfrom_used_without_including_sys_socket_h
-# undef sendto
-# define sendto sendto_used_without_including_sys_socket_h
-# undef setsockopt
-# define setsockopt setsockopt_used_without_including_sys_socket_h
-# undef shutdown
-# define shutdown shutdown_used_without_including_sys_socket_h
-# else
+# endif
+# if !defined address@hidden@_SYS_SOCKET_H
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef socket
+# define socket socket_used_without_including_sys_socket_h
+# undef connect
+# define connect connect_used_without_including_sys_socket_h
+# undef accept
+# define accept accept_used_without_including_sys_socket_h
+# undef bind
+# define bind bind_used_without_including_sys_socket_h
+# undef getpeername
+# define getpeername getpeername_used_without_including_sys_socket_h
+# undef getsockname
+# define getsockname getsockname_used_without_including_sys_socket_h
+# undef getsockopt
+# define getsockopt getsockopt_used_without_including_sys_socket_h
+# undef listen
+# define listen listen_used_without_including_sys_socket_h
+# undef recv
+# define recv recv_used_without_including_sys_socket_h
+# undef send
+# define send send_used_without_including_sys_socket_h
+# undef recvfrom
+# define recvfrom recvfrom_used_without_including_sys_socket_h
+# undef sendto
+# define sendto sendto_used_without_including_sys_socket_h
+# undef setsockopt
+# define setsockopt setsockopt_used_without_including_sys_socket_h
+# undef shutdown
+# define shutdown shutdown_used_without_including_sys_socket_h
+# else
_GL_WARN_ON_USE (socket,
"socket() used without including <sys/socket.h>");
_GL_WARN_ON_USE (connect,
@@ -189,17 +186,18 @@ _GL_WARN_ON_USE (gettimeofday, "gettimeofday is
unportable - "
"setsockopt() used without including <sys/socket.h>");
_GL_WARN_ON_USE (shutdown,
"shutdown() used without including <sys/socket.h>");
-# endif
# endif
-# if !defined address@hidden@_SYS_SELECT_H
-# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
-# undef select
-# define select select_used_without_including_sys_select_h
-# else
+# endif
+# if !defined address@hidden@_SYS_SELECT_H
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef select
+# define select select_used_without_including_sys_select_h
+# else
_GL_WARN_ON_USE (select,
"select() used without including <sys/select.h>");
-# endif
# endif
# endif
+#endif
#endif /* address@hidden@_SYS_TIME_H */
+#endif /* address@hidden@_SYS_TIME_H */
diff --git a/lib/sys_times.in.h b/lib/sys_times.in.h
new file mode 100644
index 0000000..8ea8088
--- /dev/null
+++ b/lib/sys_times.in.h
@@ -0,0 +1,80 @@
+/* Provide a sys/times.h header file.
+ Copyright (C) 2008-2013 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Simon Josefsson <address@hidden>, 2008. */
+
+/* This file is supposed to be used on platforms where <sys/times.h>
+ is missing. */
+
+#ifndef address@hidden@_SYS_TIMES_H
+
+# if __GNUC__ >= 3
address@hidden@
+# endif
address@hidden@
+
+# if @HAVE_SYS_TIMES_H@
+# @INCLUDE_NEXT@ @NEXT_SYS_TIMES_H@
+# endif
+
+# define address@hidden@_SYS_TIMES_H
+
+/* Get clock_t.
+ But avoid namespace pollution on glibc systems. */
+# ifndef __GLIBC__
+# include <time.h>
+# endif
+
+/* 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 address@hidden@
+# if !GNULIB_defined_struct_tms
+ /* Structure describing CPU time used by a process and its children. */
+ struct tms
+ {
+ clock_t tms_utime; /* User CPU time. */
+ clock_t tms_stime; /* System CPU time. */
+
+ clock_t tms_cutime; /* User CPU time of dead children. */
+ clock_t tms_cstime; /* System CPU time of dead children. */
+ };
+# define GNULIB_defined_struct_tms 1
+# endif
+# endif
+
+# if @GNULIB_TIMES@
+# if address@hidden@
+ extern clock_t times (struct tms *buffer) _GL_ARG_NONNULL ((1));
+# endif
+# elif defined GNULIB_POSIXCHECK
+# undef times
+# if HAVE_RAW_DECL_TIMES
+_GL_WARN_ON_USE (times, "times is unportable - "
+ "use gnulib module times for portability");
+# endif
+# endif
+
+# ifdef __cplusplus
+}
+# endif
+
+#endif /* address@hidden@_SYS_TIMES_H */
diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h
index 6eedaeb..520f6c8 100644
--- a/lib/sys_types.in.h
+++ b/lib/sys_types.in.h
@@ -1,6 +1,6 @@
/* Provide a more complete sys/types.h.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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_uio.in.h b/lib/sys_uio.in.h
index 73c34be..6f605df 100644
--- a/lib/sys_uio.in.h
+++ b/lib/sys_uio.in.h
@@ -1,5 +1,5 @@
/* Substitute for <sys/uio.h>.
- Copyright (C) 2011-2012 Free Software Foundation, Inc.
+ Copyright (C) 2011-2013 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/time.in.h b/lib/time.in.h
index 11c6ca1..71dcc36 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -1,6 +1,6 @@
/* A more-standard <time.h>.
- Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/time_r.c b/lib/time_r.c
index 267c18d..9a61794 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, 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2006-2007, 2010-2013 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/times.c b/lib/times.c
new file mode 100644
index 0000000..cf2fa1d
--- /dev/null
+++ b/lib/times.c
@@ -0,0 +1,66 @@
+/* Get process times
+
+ Copyright (C) 2008-2013 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Simon Josefsson <address@hidden>, 2008. */
+
+#include <config.h>
+
+/* Get times prototype. */
+#include <sys/times.h>
+
+/* Get round. */
+#include <math.h>
+
+/* Get GetProcessTimes etc. */
+#include <windows.h>
+
+static clock_t
+filetime2clock (FILETIME time)
+{
+ float f;
+
+ /* We have a 64-bit value, in the form of two DWORDS aka unsigned
+ int, counting the number of 100-nanosecond intervals. We need to
+ convert these to clock ticks. Older POSIX uses CLK_TCK to
+ indicate the number of clock ticks per second while modern POSIX
+ uses sysconf(_SC_CLK_TCK). Mingw32 does not appear to have
+ sysconf(_SC_CLK_TCK), but appears to have CLK_TCK = 1000 so we
+ use it. Note that CLOCKS_PER_SEC constant does not apply here,
+ it is for use with the clock function. */
+
+ f = (unsigned long long) time.dwHighDateTime << 32;
+ f += time.dwLowDateTime;
+ f = f * CLK_TCK / 10000000;
+ return (clock_t) round (f);
+}
+
+clock_t
+times (struct tms * buffer)
+{
+ FILETIME creation_time, exit_time, kernel_time, user_time;
+
+ if (GetProcessTimes (GetCurrentProcess (), &creation_time, &exit_time,
+ &kernel_time, &user_time) == 0)
+ return (clock_t) -1;
+
+ buffer->tms_utime = filetime2clock (user_time);
+ buffer->tms_stime = filetime2clock (kernel_time);
+ buffer->tms_cutime = 0;
+ buffer->tms_cstime = 0;
+
+ return filetime2clock (creation_time);
+}
diff --git a/lib/trunc.c b/lib/trunc.c
index 3b86ef0..26a784b 100644
--- a/lib/trunc.c
+++ b/lib/trunc.c
@@ -1,5 +1,5 @@
/* Round towards zero.
- Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2010-2013 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.c b/lib/unistd.c
new file mode 100644
index 0000000..6c6a8e2
--- /dev/null
+++ b/lib/unistd.c
@@ -0,0 +1,3 @@
+#include <config.h>
+#define _GL_UNISTD_INLINE _GL_EXTERN_INLINE
+#include "unistd.h"
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index e96a39c..84bed4a 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003-2013 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
@@ -14,29 +14,13 @@
You should have received a copy of the GNU Lesser General Public License
along with this program; if not, see <http://www.gnu.org/licenses/>. */
+#ifndef address@hidden@_UNISTD_H
+
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
#endif
@PRAGMA_COLUMNS@
-/* Special invocation convention:
- - On mingw, several headers, including <winsock2.h>, include <unistd.h>,
- but we need to ensure that both the system <unistd.h> and <winsock2.h>
- are completely included before we replace gethostname. */
-#if @GNULIB_GETHOSTNAME@ && @UNISTD_H_HAVE_WINSOCK2_H@ \
- && !defined _GL_WINSOCK2_H_WITNESS && defined _WINSOCK2_H
-/* <unistd.h> is being indirectly included for the first time from
- <winsock2.h>; avoid declaring any overrides. */
-# if @HAVE_UNISTD_H@
-# @INCLUDE_NEXT@ @NEXT_UNISTD_H@
-# else
-# error unexpected; report this to address@hidden
-# endif
-# define _GL_WINSOCK2_H_WITNESS
-
-/* Normal invocation. */
-#elif !defined address@hidden@_UNISTD_H
-
/* The include_next requires a split double-inclusion guard. */
#if @HAVE_UNISTD_H@
# @INCLUDE_NEXT@ @NEXT_UNISTD_H@
@@ -79,7 +63,9 @@
/* Solaris declares getcwd not only in <unistd.h> but also in <stdlib.h>. */
/* But avoid namespace pollution on glibc systems. */
#ifndef __GLIBC__
+# define __need_system_stdlib_h
# include <stdlib.h>
+# undef __need_system_stdlib_h
#endif
/* Native Windows platforms declare chdir, getcwd, rmdir in
@@ -124,9 +110,15 @@
/* Get getopt(), optarg, optind, opterr, optopt.
But avoid namespace pollution on glibc systems. */
#if @GNULIB_UNISTD_H_GETOPT@ && !defined __GLIBC__ && !defined
_GL_SYSTEM_GETOPT
+# define __need_getopt
# include <getopt.h>
#endif
+_GL_INLINE_HEADER_BEGIN
+#ifndef _GL_UNISTD_INLINE
+# define _GL_UNISTD_INLINE _GL_INLINE
+#endif
+
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
@@ -404,7 +396,7 @@ extern char **environ;
# endif
#elif defined GNULIB_POSIXCHECK
# if HAVE_RAW_DECL_ENVIRON
-static inline char ***
+_GL_UNISTD_INLINE char ***
rpl_environ (void)
{
return &environ;
@@ -862,7 +854,7 @@ _GL_CXXALIAS_RPL (getpagesize, int, (void));
# define getpagesize() _gl_getpagesize ()
# else
# if !GNULIB_defined_getpagesize_function
-static inline int
+_GL_UNISTD_INLINE int
getpagesize ()
{
return _gl_getpagesize ();
@@ -1530,6 +1522,7 @@ _GL_CXXALIAS_SYS_CAST (write, ssize_t, (int fd, const
void *buf, size_t count));
_GL_CXXALIASWARN (write);
#endif
+_GL_INLINE_HEADER_END
#endif /* address@hidden@_UNISTD_H */
#endif /* address@hidden@_UNISTD_H */
diff --git a/lib/unistr.in.h b/lib/unistr.in.h
index 2706789..2d28b1f 100644
--- a/lib/unistr.in.h
+++ b/lib/unistr.in.h
@@ -1,5 +1,5 @@
/* Elementary Unicode string functions.
- Copyright (C) 2001-2002, 2005-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2005-2013 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/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c
index e68a8e2..0179498 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2006-2007, 2009-2013 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 38db03d..65f792c 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2001-2002, 2006-2007, 2009-2013 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 6fbde71..8aecdd4 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2006-2007, 2009-2013 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 d286c27..2e644bb 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2006-2007, 2009-2013 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 f01cfe9..7b9d8a7 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2006-2007, 2009-2013 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 04def87..5e97909 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006-2007, 2009-2013 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 1a44ddb..a6d21a4 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, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2006-2007, 2009-2013 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 4bfe261..5e6a825 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2005-2006, 2009-2013 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.in.h b/lib/unitypes.in.h
index c588589..50a59f1 100644
--- a/lib/unitypes.in.h
+++ b/lib/unitypes.in.h
@@ -1,5 +1,5 @@
/* Elementary types and macros for the GNU UniString library.
- Copyright (C) 2002, 2005-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2005-2006, 2009-2013 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 1da25f5..2e6bc80 100644
--- a/lib/vasnprintf.c
+++ b/lib/vasnprintf.c
@@ -1,5 +1,5 @@
/* vsprintf with automatic memory allocation.
- Copyright (C) 1999, 2002-2012 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2002-2013 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
@@ -1530,7 +1530,7 @@ is_borderline (const char *digits, size_t precision)
/* Returns the number of TCHAR_T units needed as temporary space for the result
of sprintf or SNPRINTF of a single conversion directive. */
-static inline size_t
+static size_t
MAX_ROOM_NEEDED (const arguments *ap, size_t arg_index, FCHAR_T conversion,
arg_type type, int flags, size_t width, int has_precision,
size_t precision, int pad_ourselves)
diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h
index 277f270..8571eb7 100644
--- a/lib/vasnprintf.h
+++ b/lib/vasnprintf.h
@@ -1,5 +1,5 @@
/* vsprintf with automatic memory allocation.
- Copyright (C) 2002-2004, 2007-2012 Free Software Foundation, Inc.
+ Copyright (C) 2002-2004, 2007-2013 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/verify.h b/lib/verify.h
index 780b55e..40b8ef5 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -1,6 +1,6 @@
/* Compile-time assert-like macros.
- Copyright (C) 2005-2006, 2009-2012 Free Software Foundation, Inc.
+ Copyright (C) 2005-2006, 2009-2013 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 1d8db4e..4dd428c 100644
--- a/lib/vsnprintf.c
+++ b/lib/vsnprintf.c
@@ -1,5 +1,5 @@
/* Formatted output to strings.
- Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2006-2013 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/w32sock.h b/lib/w32sock.h
index b397115..76c6f9f 100644
--- a/lib/w32sock.h
+++ b/lib/w32sock.h
@@ -1,6 +1,6 @@
/* w32sock.h --- internal auxiliary functions for Windows socket functions
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/wchar.in.h b/lib/wchar.in.h
index 5c93616..97f7dc8 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-2012 Free Software Foundation, Inc.
+ Copyright (C) 2007-2013 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/wcrtomb.c b/lib/wcrtomb.c
index a4d6bcd..0aab985 100644
--- a/lib/wcrtomb.c
+++ b/lib/wcrtomb.c
@@ -1,5 +1,5 @@
/* Convert wide character to multibyte character.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 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/wctype-h.c b/lib/wctype-h.c
new file mode 100644
index 0000000..bb5f847
--- /dev/null
+++ b/lib/wctype-h.c
@@ -0,0 +1,4 @@
+/* Normally this would be wctype.c, but that name's already taken. */
+#include <config.h>
+#define _GL_WCTYPE_INLINE _GL_EXTERN_INLINE
+#include "wctype.h"
diff --git a/lib/wctype.in.h b/lib/wctype.in.h
index e819d44..246ce9d 100644
--- a/lib/wctype.in.h
+++ b/lib/wctype.in.h
@@ -1,6 +1,6 @@
/* A substitute for ISO C99 <wctype.h>, for platforms that lack it.
- Copyright (C) 2006-2012 Free Software Foundation, Inc.
+ Copyright (C) 2006-2013 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
@@ -54,6 +54,11 @@
#ifndef address@hidden@_WCTYPE_H
#define address@hidden@_WCTYPE_H
+_GL_INLINE_HEADER_BEGIN
+#ifndef _GL_WCTYPE_INLINE
+# define _GL_WCTYPE_INLINE _GL_INLINE
+#endif
+
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_WARN_ON_USE is copied here. */
@@ -148,7 +153,7 @@ typedef unsigned int rpl_wint_t;
# endif
# endif
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswalnum
# else
@@ -160,7 +165,7 @@ iswalnum
|| ((wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'Z'));
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswalpha
# else
@@ -171,7 +176,7 @@ iswalpha
return (wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'Z';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswblank
# else
@@ -182,7 +187,7 @@ iswblank
return wc == ' ' || wc == '\t';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswcntrl
# else
@@ -193,7 +198,7 @@ iswcntrl
return (wc & ~0x1f) == 0 || wc == 0x7f;
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswdigit
# else
@@ -204,7 +209,7 @@ iswdigit
return wc >= '0' && wc <= '9';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswgraph
# else
@@ -215,7 +220,7 @@ iswgraph
return wc >= '!' && wc <= '~';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswlower
# else
@@ -226,7 +231,7 @@ iswlower
return wc >= 'a' && wc <= 'z';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswprint
# else
@@ -237,7 +242,7 @@ iswprint
return wc >= ' ' && wc <= '~';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswpunct
# else
@@ -250,7 +255,7 @@ iswpunct
|| ((wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'Z')));
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswspace
# else
@@ -262,7 +267,7 @@ iswspace
|| wc == '\n' || wc == '\v' || wc == '\f' || wc == '\r');
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswupper
# else
@@ -273,7 +278,7 @@ iswupper
return wc >= 'A' && wc <= 'Z';
}
-static inline int
+_GL_WCTYPE_INLINE int
# if @REPLACE_ISWCNTRL@
rpl_iswxdigit
# else
@@ -285,7 +290,7 @@ iswxdigit
|| ((wc & ~0x20) >= 'A' && (wc & ~0x20) <= 'F'));
}
-static inline wint_t
+_GL_WCTYPE_INLINE wint_t
# if @REPLACE_TOWLOWER@
rpl_towlower
# else
@@ -296,7 +301,7 @@ towlower
return (wc >= 'A' && wc <= 'Z' ? wc - 'A' + 'a' : wc);
}
-static inline wint_t
+_GL_WCTYPE_INLINE wint_t
# if @REPLACE_TOWLOWER@
rpl_towupper
# else
@@ -336,7 +341,7 @@ _GL_FUNCDECL_SYS (iswblank, int, (wint_t wc));
result register. We need to fix this by adding a zero-extend from
wchar_t to wint_t after the call. */
-static inline wint_t
+_GL_WCTYPE_INLINE wint_t
rpl_towlower (wint_t wc)
{
return (wint_t) (wchar_t) towlower (wc);
@@ -345,7 +350,7 @@ rpl_towlower (wint_t wc)
# define towlower rpl_towlower
# endif
-static inline wint_t
+_GL_WCTYPE_INLINE wint_t
rpl_towupper (wint_t wc)
{
return (wint_t) (wchar_t) towupper (wc);
@@ -493,6 +498,7 @@ _GL_WARN_ON_USE (towctrans, "towctrans is unportable - "
# endif
#endif
+_GL_INLINE_HEADER_END
#endif /* address@hidden@_WCTYPE_H */
#endif /* address@hidden@_WCTYPE_H */
diff --git a/lib/write.c b/lib/write.c
index 2473cdb..d7d00de 100644
--- a/lib/write.c
+++ b/lib/write.c
@@ -1,5 +1,5 @@
/* POSIX compatible write() function.
- Copyright (C) 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2008-2013 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
@@ -40,7 +40,7 @@
# undef write
# if HAVE_MSVC_INVALID_PARAMETER_HANDLER
-static inline ssize_t
+static ssize_t
write_nothrow (int fd, const void *buf, size_t count)
{
ssize_t result;
diff --git a/lib/xsize.h b/lib/xsize.h
index 8312243..a7a34c5 100644
--- a/lib/xsize.h
+++ b/lib/xsize.h
@@ -1,6 +1,6 @@
/* xsize.h -- Checked size_t computations.
- Copyright (C) 2003, 2008-2012 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2008-2013 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/Makefile.am b/libguile/Makefile.am
index d4fb70f..ce437e4 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,6 +1,7 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
+## 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -93,7 +94,7 @@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c
c-tokenize.$(OBJEXT): c-tokenize.c
$(AM_V_GEN) \
if [ "$(cross_compiling)" = "yes" ]; then \
- $(CC_FOR_BUILD) -c -o $@ $<; \
+ $(CC_FOR_BUILD) -I$(top_builddir) -c -o $@ $<; \
else \
$(COMPILE) -c -o $@ $<; \
fi
@@ -445,12 +446,16 @@ BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \
scmconfig.h \
$(DOT_I_FILES) vm-operations.h $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+# Force the generation of `guile-procedures.texi' because the top-level
+# Makefile expects it to be built.
+all-local: guile-procedures.texi
+
address@hidden@_la_SOURCES = _scm.h \
memmove.c strerror.c \
dynl.c regex-posix.c \
posix.c net_db.c socket.c \
debug-malloc.c mkstemp.c \
- win32-uname.c win32-socket.c \
+ win32-uname.c \
locale-categories.h
## delete guile-snarf.awk from the installation bindir, in case it's
@@ -467,8 +472,8 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c
\
elf.h \
srfi-14.i.c \
quicksort.i.c \
- win32-uname.h win32-socket.h \
- private-gc.h private-options.h
+ win32-uname.h \
+ private-gc.h private-options.h ports-internal.h
# vm instructions
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
@@ -731,25 +736,9 @@ guile.texi: $(alldotdocfiles) guile$(EXEEXT)
guile-procedures.texi: $(alldotdocfiles) guile$(EXEEXT)
$(AM_V_GEN)$(dotdoc2texi) > $@ || { rm $@; false; }
-if HAVE_MAKEINFO
-
-guile-procedures.txt: guile-procedures.texi
- rm -f $@
- makeinfo --force -o $@ guile-procedures.texi || test -f $@
-
-else
-
-guile-procedures.txt: guile-procedures.texi
- cp guile-procedures.texi $@
-
-endif
-
c-tokenize.c: c-tokenize.lex
flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }
-schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
-schemelib_DATA = guile-procedures.txt
-
## Add -MG to make the .x magic work with auto-dep code.
MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
diff --git a/libguile/__scm.h b/libguile/__scm.h
index b42b823..0a749be 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -371,7 +371,7 @@
#ifdef LONG_BIT
# define SCM_LONG_BIT LONG_BIT
#else
-# define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char))
+# define SCM_LONG_BIT (SCM_SIZEOF_LONG * 8)
#endif
#define SCM_I_UTYPE_MAX(type) ((type)-1)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 7114f78..62d8520 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
+ * 2006, 2009, 2011, 2013 Free Software 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
@@ -97,6 +98,47 @@ scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
return pos;
}
+static void
+check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
+{
+ if (idx < dim->lbnd || idx > dim->ubnd)
+ scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
+ scm_list_3 (scm_from_ssize_t (dim->lbnd),
+ scm_from_ssize_t (dim->ubnd),
+ scm_from_ssize_t (idx)),
+ scm_list_1 (scm_from_ssize_t (idx)));
+}
+
+ssize_t
+scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
+{
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+
+ if (scm_array_handle_rank (h) != 1)
+ scm_misc_error (NULL, "wrong number of indices, expecting ~A",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
+
+ check_array_index_bounds (&dim[0], idx0);
+
+ return (idx0 - dim[0].lbnd) * dim[0].inc;
+}
+
+ssize_t
+scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
+{
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+
+ if (scm_array_handle_rank (h) != 2)
+ scm_misc_error (NULL, "wrong number of indices, expecting ~A",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
+
+ check_array_index_bounds (&dim[0], idx0);
+ check_array_index_bounds (&dim[1], idx1);
+
+ return ((idx0 - dim[0].lbnd) * dim[0].inc
+ + (idx1 - dim[1].lbnd) * dim[1].inc);
+}
+
SCM
scm_array_handle_element_type (scm_t_array_handle *h)
{
diff --git a/libguile/array-handle.h b/libguile/array-handle.h
index 2e8af77..fa2449d 100644
--- a/libguile/array-handle.h
+++ b/libguile/array-handle.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_HANDLE_H
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006,
- * 2008, 2009, 2011 Free Software Foundation, Inc.
+ * 2008, 2009, 2011, 2013 Free Software 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,8 @@
#include "libguile/__scm.h"
+#include "libguile/error.h"
+#include "libguile/numbers.h"
@@ -112,12 +114,42 @@ typedef struct scm_t_array_handle {
SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
+SCM_API ssize_t scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0);
+SCM_API ssize_t scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0,
ssize_t idx1);
SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h);
SCM_API void scm_array_handle_release (scm_t_array_handle *h);
SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h);
SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h);
-/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
+
+SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
+SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM
val);
+
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+/* Either inlining, or being included from inline.c. */
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
+{
+ if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
+ /* catch overflow */
+ scm_out_of_range (NULL, scm_from_ssize_t (p));
+ /* perhaps should catch overflow here too */
+ return h->impl->vref (h, h->base + p);
+}
+
+SCM_INLINE_IMPLEMENTATION void
+scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
+{
+ if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
+ /* catch overflow */
+ scm_out_of_range (NULL, scm_from_ssize_t (p));
+ /* perhaps should catch overflow here too */
+ h->impl->vset (h, h->base + p, v);
+}
+
+#endif
+
SCM_INTERNAL void scm_init_array_handle (void);
diff --git a/libguile/array-map.c b/libguile/array-map.c
index c0f0f00..e47fb56 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011,
2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
+ * 2010, 2011, 2012, 2013 Free Software 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
@@ -317,6 +318,23 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra,
const char *what)
}
}
+static int
+rafill (SCM dst, SCM fill)
+{
+ long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ scm_t_array_handle h;
+ size_t i;
+ ssize_t inc;
+ scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
+ i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
+ inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+
+ for (; n-- > 0; i += inc)
+ h.impl->vset (&h, i, fill);
+
+ scm_array_handle_release (&h);
+ return 1;
+}
SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
(SCM ra, SCM fill),
@@ -324,47 +342,35 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
"returned is unspecified.")
#define FUNC_NAME s_scm_array_fill_x
{
- scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
+ scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-/* to be used as cproc in scm_ramapc to fill an array dimension with
- "fill". */
-int
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-#define FUNC_NAME s_scm_array_fill_x
-{
- unsigned long i;
- unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd
+ 1;
- long inc = SCM_I_ARRAY_DIMS (ra)->inc;
- unsigned long base = SCM_I_ARRAY_BASE (ra);
-
- ra = SCM_I_ARRAY_V (ra);
-
- for (i = base; n--; i += inc)
- GVSET (ra, i, fill);
-
- return 1;
-}
-#undef FUNC_NAME
-
-
-static int
+static int
racp (SCM src, SCM dst)
{
long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
- long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
- unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
+ scm_t_array_handle h_s, h_d;
+ size_t i_s, i_d;
+ ssize_t inc_s, inc_d;
+
dst = SCM_CAR (dst);
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- i_d = SCM_I_ARRAY_BASE (dst);
- src = SCM_I_ARRAY_V (src);
- dst = SCM_I_ARRAY_V (dst);
+ scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
+ scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
+
+ i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
+ i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
+ inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
+ inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- GVSET (dst, i_d, GVREF (src, i_s));
+ h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
+
+ scm_array_handle_release (&h_d);
+ scm_array_handle_release (&h_s);
+
return 1;
}
@@ -385,8 +391,28 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
}
#undef FUNC_NAME
-/* Functions callable by ARRAY-MAP! */
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* to be used as cproc in scm_ramapc to fill an array dimension with
+ "fill". */
+int
+scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
+{
+ unsigned long i;
+ unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd
+ 1;
+ long inc = SCM_I_ARRAY_DIMS (ra)->inc;
+ unsigned long base = SCM_I_ARRAY_BASE (ra);
+
+ ra = SCM_I_ARRAY_V (ra);
+
+ for (i = base; n--; i += inc)
+ GVSET (ra, i, fill);
+
+ return 1;
+}
+
+/* Functions callable by ARRAY-MAP! */
int
scm_ra_eqp (SCM ra0, SCM ras)
@@ -628,37 +654,52 @@ scm_array_identity (SCM dst, SCM src)
return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
}
+#endif /* SCM_ENABLE_DEPRECATED */
-
-static int
+static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
- long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
- ra0 = SCM_I_ARRAY_V (ra0);
+ ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+
+ scm_t_array_handle h0;
+ size_t i0, i0end;
+ ssize_t inc0;
+ scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+ i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+ i0end = i0 + n*inc0;
if (scm_is_null (ras))
- for (; i <= n; i++)
- GVSET (ra0, i*inc+base, scm_call_0 (proc));
+ for (; i0 < i0end; i0 += inc0)
+ h0.impl->vset (&h0, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
- SCM args;
- unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = scm_vector (SCM_CDR (ras));
-
- for (; i <= n; i++, i1 += inc1)
- {
- args = SCM_EOL;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
- args = scm_cons (GVREF (ra1, i1), args);
- GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
- }
+ scm_t_array_handle h1;
+ size_t i1;
+ ssize_t inc1;
+ scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
+ i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
+ inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
+ ras = SCM_CDR (ras);
+ if (scm_is_null (ras))
+ for (; i0 < i0end; i0 += inc0, i1 += inc1)
+ h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1,
i1)));
+ else
+ {
+ ras = scm_vector (ras);
+ for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+ {
+ SCM args = SCM_EOL;
+ unsigned long k;
+ for (k = scm_c_vector_length (ras); k--;)
+ args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1,
i1), args));
+ }
+ }
+ scm_array_handle_release (&h1);
}
+ scm_array_handle_release (&h0);
return 1;
}
@@ -691,36 +732,35 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
static int
rafe (SCM ra0, SCM proc, SCM ras)
{
- long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
- ra0 = SCM_I_ARRAY_V (ra0);
+ ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+
+ scm_t_array_handle h0;
+ size_t i0, i0end;
+ ssize_t inc0;
+ scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+ i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+ i0end = i0 + n*inc0;
if (scm_is_null (ras))
- for (; i <= n; i++, i0 += inc0)
- scm_call_1 (proc, GVREF (ra0, i0));
+ for (; i0 < i0end; i0 += inc0)
+ scm_call_1 (proc, h0.impl->vref (&h0, i0));
else
{
- SCM ra1 = SCM_CAR (ras);
- SCM args;
- unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = scm_vector (SCM_CDR (ras));
-
- for (; i <= n; i++, i0 += inc0, i1 += inc1)
- {
- args = SCM_EOL;
- for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
- args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
- scm_apply_0 (proc, args);
- }
+ ras = scm_vector (ras);
+ for (; i0 < i0end; i0 += inc0, ++i)
+ {
+ SCM args = SCM_EOL;
+ unsigned long k;
+ for (k = scm_c_vector_length (ras); k--;)
+ args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
+ }
}
+ scm_array_handle_release (&h0);
return 1;
}
-
SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
(SCM proc, SCM ra0, SCM lra),
"Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
diff --git a/libguile/array-map.h b/libguile/array-map.h
index 43d2a92..b0592d8 100644
--- a/libguile/array-map.h
+++ b/libguile/array-map.h
@@ -4,7 +4,7 @@
#define SCM_ARRAY_MAP_H
/* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010,
- * 2011 Free Software Foundation, Inc.
+ * 2011, 2013 Free Software 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,25 +31,30 @@
SCM_API int scm_ra_matchp (SCM ra0, SCM ras);
SCM_API int scm_ramapc (void *cproc, SCM data, SCM ra0, SCM lra,
const char *what);
-SCM_API int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
SCM_API SCM scm_array_fill_x (SCM ra, SCM fill);
SCM_API SCM scm_array_copy_x (SCM src, SCM dst);
-SCM_API int scm_ra_eqp (SCM ra0, SCM ras);
-SCM_API int scm_ra_lessp (SCM ra0, SCM ras);
-SCM_API int scm_ra_leqp (SCM ra0, SCM ras);
-SCM_API int scm_ra_grp (SCM ra0, SCM ras);
-SCM_API int scm_ra_greqp (SCM ra0, SCM ras);
-SCM_API int scm_ra_sum (SCM ra0, SCM ras);
-SCM_API int scm_ra_difference (SCM ra0, SCM ras);
-SCM_API int scm_ra_product (SCM ra0, SCM ras);
-SCM_API int scm_ra_divide (SCM ra0, SCM ras);
-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_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);
+#if SCM_ENABLE_DEPRECATED == 1
+
+SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
+SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst);
+
+#endif /* SCM_ENABLE_DEPRECATED == 1 */
+
#endif /* SCM_ARRAY_MAP_H */
/*
diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h
index 2e1fce2..7aa757f 100644
--- a/libguile/bdw-gc.h
+++ b/libguile/bdw-gc.h
@@ -1,7 +1,7 @@
#ifndef SCM_BDW_GC_H
#define SCM_BDW_GC_H
-/* Copyright (C) 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2011, 2012, 2013 Free Software 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,6 +37,11 @@
routines. */
# define GC_NO_THREAD_REDIRECTS 1
+#ifdef __MINGW32__
+/* Rely on pthreads-w32. */
+#define GC_WIN32_PTHREADS
+#endif
+
#endif
#include <gc/gc.h>
diff --git a/libguile/c-tokenize.lex b/libguile/c-tokenize.lex
index dc72257..856224e 100644
--- a/libguile/c-tokenize.lex
+++ b/libguile/c-tokenize.lex
@@ -14,7 +14,8 @@ FLOQUAL (f|F|l|L)
INTQUAL (l|L|ll|LL|lL|Ll|u|U)
%{
-
+#include <config.h>
+
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
diff --git a/libguile/debug.c b/libguile/debug.c
index 87513bf..9e63f2c 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, 2010, 2011, 2012 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012, 2013 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
@@ -115,45 +115,6 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface",
0, 1, 0,
}
#undef FUNC_NAME
-
-SCM_SYMBOL (scm_sym_source, "source");
-
-SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
- (SCM proc),
- "Return the name of the procedure @var{proc}")
-#define FUNC_NAME s_scm_procedure_name
-{
- SCM_VALIDATE_PROC (1, proc);
- while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
- proc = SCM_STRUCT_PROCEDURE (proc);
- return scm_procedure_property (proc, scm_sym_name);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
- (SCM proc),
- "Return the source of the procedure @var{proc}.")
-#define FUNC_NAME s_scm_procedure_source
-{
- SCM src;
- SCM_VALIDATE_PROC (1, proc);
-
- do
- {
- src = scm_procedure_property (proc, scm_sym_source);
- if (scm_is_true (src))
- return src;
-
- if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
- && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
- continue;
- }
- while (0);
-
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
@@ -202,10 +163,14 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
SCM
scm_local_eval (SCM exp, SCM env)
{
- static SCM local_eval_var = SCM_BOOL_F;
+ static SCM local_eval_var = SCM_UNDEFINED;
+ static scm_i_pthread_mutex_t local_eval_var_mutex
+ = SCM_I_PTHREAD_MUTEX_INITIALIZER;
- if (scm_is_false (local_eval_var))
+ scm_i_scm_pthread_mutex_lock (&local_eval_var_mutex);
+ if (SCM_UNBNDP (local_eval_var))
local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
+ scm_i_pthread_mutex_unlock (&local_eval_var_mutex);
return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
}
diff --git a/libguile/debug.h b/libguile/debug.h
index 362d9b7..e535a6a 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,2010,2011,2012
+/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -44,8 +44,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_procedure_source (SCM proc);
-SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_debug_options (SCM setting);
SCM_INTERNAL void scm_init_debug (void);
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index cf44024..cca1454 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2,7 +2,7 @@
deprecate something, move it here when that is feasible.
*/
-/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software
Foundation, Inc.
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free
Software 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,88 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector, string,\n"
+ "bitvector, or uniform numeric vector.")
+#define FUNC_NAME s_scm_generalized_vector_p
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector? is deprecated. Use array? and check the "
+ "array-rank instead.");
+ return scm_from_bool (scm_is_generalized_vector (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0,
0,
+ (SCM v),
+ "Return the length of the generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_length
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-length is deprecated. Use array-length instead.");
+ return scm_from_size_t (scm_c_generalized_vector_length (v));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_ref
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-ref is deprecated. Use array-ref instead.");
+ return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "generalized vector @var{v} to @var{val}.")
+#define FUNC_NAME s_scm_generalized_vector_set_x
+{
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-set! is deprecated. Use array-set! instead. "
+ "Note the change in argument order!");
+ scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0,
0,
+ (SCM v),
+ "Return a new list whose elements are the elements of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_to_list
+{
+ /* FIXME: This duplicates `array_to_list'. */
+ SCM ret = SCM_EOL;
+ long inc;
+ ssize_t pos, i;
+ scm_t_array_handle h;
+
+ scm_c_issue_deprecation_warning
+ ("generalized-vector->list is deprecated. Use array->list instead.");
+
+ scm_generalized_vector_get_handle (v, &h);
+
+ i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+ inc = h.dims[0].inc;
+ pos = (i - 1) * inc;
+
+ for (; i > 0; i--, pos -= inc)
+ ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
+
+ scm_array_handle_release (&h);
+ return ret;
+}
+#undef FUNC_NAME
+
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/error.c b/libguile/error.c
index 790ed05..0df4c73 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2004, 2006, 2010,
- * 2012 Free Software Foundation, Inc.
+ * 2012, 2013 Free Software 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
@@ -100,17 +100,6 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
}
#undef FUNC_NAME
-#if defined __MINGW32__ && defined HAVE_NETWORKING
-# include "win32-socket.h"
-# define SCM_I_STRERROR(err) \
- ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
-# define SCM_I_ERRNO() \
- (errno ? errno : scm_i_socket_errno ())
-#else
-# define SCM_I_STRERROR(err) strerror (err)
-# define SCM_I_ERRNO() errno
-#endif /* __MINGW32__ */
-
/* strerror may not be thread safe, for instance in glibc (version 2.3.2) an
error number not among the known values results in a string like "Unknown
error 9999" formed in a static buffer, which will be overwritten by a
@@ -136,7 +125,7 @@ SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
- ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
+ ret = scm_from_locale_string (strerror (scm_to_int (err)));
scm_dynwind_end ();
return ret;
@@ -147,7 +136,7 @@ SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
void
scm_syserror (const char *subr)
{
- SCM err = scm_from_int (SCM_I_ERRNO ());
+ SCM err = scm_from_int (errno);
/* It could be that we're getting here because the syscall was
interrupted by a signal. In that case a signal handler might have
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 3d5b1fb..1893c02 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
- * 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -45,7 +45,6 @@
#include "libguile/feature.h"
#include "libguile/fports.h"
#include "libguile/private-gc.h" /* for SCM_MAX */
-#include "libguile/iselect.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
@@ -81,9 +80,7 @@
#include <libc.h>
#endif
-#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
-#endif
#ifdef HAVE_STRING_H
#include <string.h>
@@ -101,6 +98,18 @@
#define NAMLEN(dirent) strlen ((dirent)->d_name)
+#ifdef HAVE_SYS_SENDFILE_H
+# include <sys/sendfile.h>
+#endif
+
+/* Glibc's `sendfile' function. */
+#define sendfile_or_sendfile64 \
+ CHOOSE_LARGEFILE (sendfile, sendfile64)
+
+#include <full-read.h>
+#include <full-write.h>
+
+
/* Some more definitions for the native Windows port. */
#ifdef __MINGW32__
# define fsync(fd) _commit (fd)
@@ -435,30 +444,17 @@ scm_stat2scm (struct stat_or_stat64 *stat_temp)
return ans;
}
-#ifdef __MINGW32__
-/*
- * Try getting the appropiate stat buffer for a given file descriptor
- * under Windows. It differentiates between file, pipe and socket
- * descriptors.
- */
-static int fstat_Win32 (int fdes, struct stat *buf)
+static int
+is_file_name_separator (SCM c)
{
- int error, optlen = sizeof (int);
-
- memset (buf, 0, sizeof (struct stat));
-
- /* Is this a socket ? */
- if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
- {
- buf->st_mode = _S_IREAD | _S_IWRITE | _S_IEXEC;
- buf->st_nlink = 1;
- buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL);
- return 0;
- }
- /* Maybe a regular file or pipe ? */
- return fstat (fdes, buf);
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
+ return 1;
+#ifdef __MINGW32__
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
+ return 1;
+#endif
+ return 0;
}
-#endif /* __MINGW32__ */
SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
(SCM object, SCM exception_on_error),
@@ -532,21 +528,11 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
if (scm_is_integer (object))
{
-#ifdef __MINGW32__
- SCM_SYSCALL (rv = fstat_Win32 (scm_to_int (object), &stat_temp));
-#else
SCM_SYSCALL (rv = fstat_or_fstat64 (scm_to_int (object), &stat_temp));
-#endif
}
else if (scm_is_string (object))
{
char *file = scm_to_locale_string (object);
-#ifdef __MINGW32__
- char *p;
- p = file + strlen (file) - 1;
- while (p > file && (*p == '/' || *p == '\\'))
- *p-- = '\0';
-#endif
SCM_SYSCALL (rv = stat_or_stat64 (file, &stat_temp));
free (file);
}
@@ -555,11 +541,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
object = SCM_COERCE_OUTPORT (object);
SCM_VALIDATE_OPFPORT (1, object);
fdes = SCM_FPORT_FDES (object);
-#ifdef __MINGW32__
- SCM_SYSCALL (rv = fstat_Win32 (fdes, &stat_temp));
-#else
SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
-#endif
}
if (rv == -1)
@@ -653,15 +635,13 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
-#ifdef HAVE_SELECT
-
/* check that element is a port or file descriptor. if it's a port
and its buffer is ready for use, add it to the ports_ready list.
otherwise add its file descriptor to *set. the type of list can be
determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
SCM_ARG3 for excepts. */
static int
-set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
+set_element (fd_set *set, SCM *ports_ready, SCM element, int pos)
{
int fd;
@@ -707,7 +687,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM
element, int pos)
determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
SCM_ARG3 for excepts. */
static int
-fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
+fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos)
{
int max_fd = 0;
@@ -742,7 +722,7 @@ fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM
list_or_vec, int pos)
/* if element (a file descriptor or port) appears in *set, cons it to
list. return list. */
static SCM
-get_element (SELECT_TYPE *set, SCM element, SCM list)
+get_element (fd_set *set, SCM element, SCM list)
{
int fd;
@@ -768,7 +748,7 @@ get_element (SELECT_TYPE *set, SCM element, SCM list)
*set and appending them to ports_ready. result is converted to a
vector if list_or_vec is a vector. */
static SCM
-retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec)
+retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec)
{
SCM answer_list = ports_ready;
@@ -829,9 +809,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
{
struct timeval timeout;
struct timeval * time_ptr;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
+ fd_set read_set;
+ fd_set write_set;
+ fd_set except_set;
int read_count;
int write_count;
int except_count;
@@ -922,9 +902,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
}
{
- int rv = scm_std_select (max_fd + 1,
- &read_set, &write_set, &except_set,
- time_ptr);
+ int rv = select (max_fd + 1,
+ &read_set, &write_set, &except_set,
+ time_ptr);
if (rv < 0)
SCM_SYSERROR;
}
@@ -933,7 +913,6 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
retrieve_select_type (&except_set, SCM_EOL, excepts));
}
#undef FUNC_NAME
-#endif /* HAVE_SELECT */
@@ -1095,15 +1074,11 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
c_newfile = scm_to_locale_string (newfile);
scm_dynwind_free (c_newfile);
- oldfd = open_or_open64 (c_oldfile, O_RDONLY);
+ oldfd = open_or_open64 (c_oldfile, O_RDONLY | O_BINARY);
if (oldfd == -1)
SCM_SYSERROR;
-#ifdef __MINGW32__
- SCM_SYSCALL (rv = fstat_Win32 (oldfd, &oldstat));
-#else
SCM_SYSCALL (rv = fstat_or_fstat64 (oldfd, &oldstat));
-#endif
if (rv == -1)
goto err_close_oldfd;
@@ -1133,6 +1108,117 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
+ (SCM out, SCM in, SCM count, SCM offset),
+ "Send @var{count} bytes from @var{in} to @var{out}, both of which "
+ "must be either open file ports or file descriptors. When "
+ "@var{offset} is omitted, start reading from @var{in}'s current "
+ "position; otherwise, start reading at @var{offset}. Return "
+ "the number of bytes actually sent.")
+#define FUNC_NAME s_scm_sendfile
+{
+#define VALIDATE_FD_OR_PORT(cvar, svar, pos) \
+ if (scm_is_integer (svar)) \
+ cvar = scm_to_int (svar); \
+ else \
+ { \
+ SCM_VALIDATE_OPFPORT (pos, svar); \
+ scm_flush (svar); \
+ cvar = SCM_FPORT_FDES (svar); \
+ }
+
+ ssize_t result SCM_UNUSED;
+ size_t c_count, total = 0;
+ scm_t_off c_offset;
+ int in_fd, out_fd;
+
+ VALIDATE_FD_OR_PORT (out_fd, out, 1);
+ VALIDATE_FD_OR_PORT (in_fd, in, 2);
+ c_count = scm_to_size_t (count);
+ c_offset = SCM_UNBNDP (offset) ? 0 : scm_to_off_t (offset);
+
+#if defined HAVE_SYS_SENDFILE_H && defined HAVE_SENDFILE
+ /* The Linux-style sendfile(2), which is different from the BSD-style. */
+
+ {
+ off_t *offset_ptr;
+
+ offset_ptr = SCM_UNBNDP (offset) ? NULL : &c_offset;
+
+ /* On Linux, when OUT_FD is a file, everything is transferred at once and
+ RESULT == C_COUNT. However, when OUT_FD is a pipe or other "slow"
+ device, fewer bytes may be transferred, hence the loop. RESULT == 0
+ means EOF on IN_FD, so leave the loop in that case. */
+ do
+ {
+ result = sendfile_or_sendfile64 (out_fd, in_fd, offset_ptr,
+ c_count - total);
+ if (result > 0)
+ /* At this point, either OFFSET_PTR is non-NULL and it has been
+ updated to the current offset in IN_FD, or it is NULL and IN_FD's
+ offset has been updated. */
+ total += result;
+ else if (result < 0 && (errno == EINTR || errno == EAGAIN))
+ /* Keep going. */
+ result = 1;
+ }
+ while (total < c_count && result > 0);
+ }
+
+ /* Quoting the Linux man page: "In Linux kernels before 2.6.33, out_fd
+ must refer to a socket. Since Linux 2.6.33 it can be any file."
+ Fall back to read(2) and write(2) when such an error occurs. */
+ if (result < 0 && errno != EINVAL && errno != ENOSYS)
+ SCM_SYSERROR;
+ else if (result < 0)
+#endif
+ {
+ char buf[8192];
+ size_t left;
+ int reached_eof = 0;
+
+ if (!SCM_UNBNDP (offset))
+ {
+ if (SCM_PORTP (in))
+ scm_seek (in, scm_from_off_t (c_offset), scm_from_int (SEEK_SET));
+ else
+ {
+ if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0)
+ SCM_SYSERROR;
+ }
+ }
+
+ for (total = 0, left = c_count; total < c_count && !reached_eof; )
+ {
+ size_t asked, obtained, written;
+
+ asked = SCM_MIN (sizeof buf, left);
+ obtained = full_read (in_fd, buf, asked);
+ if (obtained < asked)
+ {
+ if (errno == 0)
+ reached_eof = 1;
+ else
+ SCM_SYSERROR;
+ }
+
+ left -= obtained;
+
+ written = full_write (out_fd, buf, obtained);
+ if (written < obtained)
+ SCM_SYSERROR;
+
+ total += written;
+ }
+
+ }
+
+ return scm_from_size_t (total);
+
+#undef VALIDATE_FD_OR_PORT
+}
+#undef FUNC_NAME
+
#endif /* HAVE_POSIX */
@@ -1434,6 +1520,24 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
SCM scm_dot_string;
+#ifdef __MINGW32__
+SCM_SYMBOL (sym_file_name_convention, "windows");
+#else
+SCM_SYMBOL (sym_file_name_convention, "posix");
+#endif
+
+SCM_INTERNAL SCM scm_system_file_name_convention (void);
+
+SCM_DEFINE (scm_system_file_name_convention,
+ "system-file-name-convention", 0, 0, 0, (void),
+ "Return either @code{posix} or @code{windows}, depending on\n"
+ "what kind of system this Guile is running on.")
+#define FUNC_NAME s_scm_system_file_name_convention
+{
+ return sym_file_name_convention;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
(SCM filename),
"Return the directory name component of the file name\n"
@@ -1449,32 +1553,17 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
len = scm_i_string_length (filename);
i = len - 1;
-#ifdef __MINGW32__
- while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
- || scm_i_string_ref (filename, i) == '\\'))
- --i;
- while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
- && scm_i_string_ref (filename, i) != '\\'))
- --i;
- while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
- || scm_i_string_ref (filename, i) == '\\'))
- --i;
-#else
- while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+
+ while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
- while (i >= 0 && scm_i_string_ref (filename, i) != '/')
+ while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
- while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
-#endif /* ndef __MINGW32__ */
+
if (i < 0)
{
-#ifdef __MINGW32__
- if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
- || scm_i_string_ref (filename, 0) == '\\'))
-#else
- if (len > 0 && scm_i_string_ref (filename, 0) == '/')
-#endif /* ndef __MINGW32__ */
+ if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
@@ -1505,14 +1594,8 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
j = scm_i_string_length (suffix) - 1;
}
i = len - 1;
-#ifdef __MINGW32__
- while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
- || scm_i_string_ref (filename, i) == '\\'))
- --i;
-#else
- while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
-#endif /* ndef __MINGW32__ */
end = i;
while (i >= 0 && j >= 0
&& (scm_i_string_ref (filename, i)
@@ -1523,22 +1606,11 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
}
if (j == -1)
end = i;
-#ifdef __MINGW32__
- while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
- && scm_i_string_ref (filename, i) != '\\'))
- --i;
-#else
- while (i >= 0 && scm_i_string_ref (filename, i) != '/')
+ while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i)))
--i;
-#endif /* ndef __MINGW32__ */
if (i == end)
{
-#ifdef __MINGW32__
- if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
- || scm_i_string_ref (filename, 0) == '\\'))
-#else
- if (len > 0 && scm_i_string_ref (filename, 0) == '/')
-#endif /* ndef __MINGW32__ */
+ if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0)))
return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
@@ -1605,14 +1677,7 @@ scm_i_relativize_path (SCM path, SCM in_path)
will be delimited by single delimiters. When DIR does not
have a trailing delimiter, add one to the length to strip
off the delimiter within SCANON. */
- if (
-#ifdef __MINGW32__
- (scm_i_string_ref (dir, len - 1) != '/'
- && scm_i_string_ref (dir, len - 1) != '\\')
-#else
- scm_i_string_ref (dir, len - 1) != '/'
-#endif
- )
+ if (!is_file_name_separator (scm_c_string_ref (dir, len - 1)))
len++;
if (scm_c_string_length (scanon) > len)
diff --git a/libguile/filesys.h b/libguile/filesys.h
index c420992..fc66e40 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -3,7 +3,8 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
+ * 2010, 2011, 2013 Free Software 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
@@ -66,6 +67,7 @@ SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
SCM_API SCM scm_dirname (SCM filename);
SCM_API SCM scm_basename (SCM filename, SCM suffix);
SCM_API SCM scm_canonicalize_path (SCM path);
+SCM_API SCM scm_sendfile (SCM out, SCM in, SCM count, SCM offset);
SCM_INTERNAL SCM scm_i_relativize_path (SCM path, SCM in_path);
SCM_INTERNAL void scm_init_filesys (void);
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 8e36acd..146854b 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
+ * 2011, 2012, 2013 Free Software 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
@@ -304,22 +305,24 @@ apply_thunk (void *thunk)
size_t
scm_prepare_fluids (size_t n, SCM *fluids, SCM *values)
{
- size_t j = n;
+ size_t j;
/* 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. */
- while (j--)
+ for (j = n; j--;)
{
size_t i;
if (SCM_UNLIKELY (!IS_FLUID (fluids[j])))
scm_wrong_type_arg ("with-fluids", 0, fluids[j]);
- for (i = 0; i < j; i++)
+ for (i = j; i--;)
if (scm_is_eq (fluids[i], fluids[j]))
{
values[i] = values[j]; /* later bindings win */
n--;
+ fluids[j] = fluids[n];
+ values[j] = values[n];
break;
}
}
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 47077f7..4f5aa58 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2011, 2012, 2013 Free Software 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
@@ -53,6 +53,8 @@ SCM_SYMBOL (sym_unsigned_short, "unsigned-short");
SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
SCM_SYMBOL (sym_size_t, "size_t");
+SCM_SYMBOL (sym_ssize_t, "ssize_t");
+SCM_SYMBOL (sym_ptrdiff_t, "ptrdiff_t");
/* that's for pointers, you know. */
SCM_SYMBOL (sym_asterisk, "*");
@@ -768,37 +770,40 @@ SCM_DEFINE (scm_pointer_to_procedure,
"pointer->procedure", 3, 0, 0,
/* 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
+#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M
(40)
+#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M
(0)
#else
-#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
+#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M
(0)
+#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M
(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 \
+#define GEN_CODE(M, nreq) \
+ OBJCODE_HEADER (M), \
+ /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of
args */ \
+ /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the
function pointer */ \
+ /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as
well) */ \
+ /* 7 */ M (scm_op_nop), \
+ /* 8 */ META (M, 3, 7, nreq)
+
+#define META(M, start, end, nreq) \
+ META_HEADER (M), \
+ /* 0 */ M (scm_op_make_eol), /* bindings */ \
+ /* 1 */ M (scm_op_make_eol), /* sources */ \
+ /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /*
arity: from ip N to ip N */ \
+ /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \
+ /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \
+ /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of
that one list */ \
+ /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M
('M'), M ('e'), /* `name' */ \
+ /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \
+ /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \
+ /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and
arities into list */ \
+ /* 28 */ M (scm_op_return), /* and return */ \
+ /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \
/* 32 */
+#define M_STATIC(x) (x)
+#define CODE(nreq) GEN_CODE (M_STATIC, nreq)
+
static const struct
{
scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way
*/
@@ -812,8 +817,28 @@ static const struct
}
};
-#undef CODE
+static SCM
+make_objcode_trampoline (unsigned int nargs)
+{
+ const int size = sizeof (struct scm_objcode) + 8
+ + sizeof (struct scm_objcode) + 32;
+ SCM bytecode = scm_c_make_bytevector (size);
+ scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode);
+ int i = 0;
+
+#define M_DYNAMIC(x) (bytes[i++] = (x))
+ GEN_CODE (M_DYNAMIC, nargs);
+#undef M_DYNAMIC
+
+ if (i != size)
+ scm_syserror ("make_objcode_trampoline");
+ return scm_bytecode_to_objcode (bytecode, SCM_UNDEFINED);
+}
+
+#undef GEN_CODE
#undef META
+#undef M_STATIC
+#undef CODE
#undef OBJCODE_HEADER
#undef META_HEADER
@@ -876,21 +901,43 @@ static const SCM objcode_trampolines[10] = {
SCM_PACK (objcode_cells.cells+18),
};
+static SCM large_objcode_trampolines = SCM_UNDEFINED;
+static scm_i_pthread_mutex_t large_objcode_trampolines_mutex =
+ SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
static SCM
-cif_to_procedure (SCM cif, SCM func_ptr)
+get_objcode_trampoline (unsigned int nargs)
{
- ffi_cif *c_cif;
- unsigned int nargs;
- SCM objcode, table, ret;
-
- c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
- nargs = c_cif->nargs;
+ SCM objcode;
if (nargs < 10)
objcode = objcode_trampolines[nargs];
+ else if (nargs < 128)
+ {
+ scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex);
+ if (SCM_UNBNDP (large_objcode_trampolines))
+ large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED);
+ objcode = scm_c_vector_ref (large_objcode_trampolines, nargs);
+ if (SCM_UNBNDP (objcode))
+ scm_c_vector_set_x (large_objcode_trampolines, nargs,
+ objcode = make_objcode_trampoline (nargs));
+ scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex);
+ }
else
- scm_misc_error ("make-foreign-function", "args >= 10 currently
unimplemented",
+ scm_misc_error ("make-foreign-function", "args >= 128 currently
unimplemented",
SCM_EOL);
+
+ return objcode;
+}
+
+static SCM
+cif_to_procedure (SCM cif, SCM func_ptr)
+{
+ ffi_cif *c_cif;
+ SCM objcode, table, ret;
+
+ c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
+ objcode = get_objcode_trampoline (c_cif->nargs);
table = scm_c_make_vector (2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
@@ -1282,6 +1329,26 @@ scm_init_foreign (void)
#endif
);
+ scm_define (sym_ssize_t,
+#if SIZEOF_SIZE_T == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SIZEOF_SIZE_T == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#else
+# error unsupported sizeof (ssize_t)
+#endif
+ );
+
+ scm_define (sym_ptrdiff_t,
+#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SCM_SIZEOF_SCM_T_PTRDIFF == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#else
+# error unsupported sizeof (scm_t_ptrdiff)
+#endif
+ );
+
null_pointer = scm_cell (scm_tc7_pointer, 0);
scm_define (sym_null, null_pointer);
}
diff --git a/libguile/fports.c b/libguile/fports.c
index 94ce434..13d1dd7 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation,
Inc.
+ * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software
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,15 +28,6 @@
#include <stdio.h>
#include <fcntl.h>
-#include "libguile/_scm.h"
-#include "libguile/strings.h"
-#include "libguile/validate.h"
-#include "libguile/gc.h"
-#include "libguile/posix.h"
-#include "libguile/dynwind.h"
-#include "libguile/hashtab.h"
-
-#include "libguile/fports.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -50,36 +41,23 @@
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
#include <sys/stat.h>
#endif
-#ifdef HAVE_POLL_H
#include <poll.h>
-#endif
#include <errno.h>
#include <sys/types.h>
+#include <sys/stat.h>
+#include <sys/select.h>
#include <full-write.h>
-#include "libguile/iselect.h"
-
-/* Some defines for Windows (native port, not Cygwin). */
-#ifdef __MINGW32__
-# include <sys/stat.h>
-# include <winsock2.h>
-#endif /* __MINGW32__ */
-
-#include <full-write.h>
-
-/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
- already, but have this code here in case that wasn't so in past versions,
- or perhaps to help other minimal DOS environments.
-
- gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
- might be possibilities if we've got other systems without ftruncate. */
+#include "libguile/_scm.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/gc.h"
+#include "libguile/posix.h"
+#include "libguile/dynwind.h"
+#include "libguile/hashtab.h"
-#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
-# define ftruncate(fd, size) chsize (fd, size)
-# undef HAVE_FTRUNCATE
-# define HAVE_FTRUNCATE 1
-#endif
+#include "libguile/fports.h"
#if SIZEOF_OFF_T == SIZEOF_INT
#define OFF_T_MAX INT_MAX
@@ -247,8 +225,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
if (ndrained > 0)
/* Put DRAINED back to PORT. */
- while (ndrained-- > 0)
- scm_unget_byte (drained[ndrained], port);
+ scm_unget_bytes ((unsigned char *) drained, ndrained, port);
return SCM_UNSPECIFIED;
}
@@ -338,71 +315,35 @@ fport_canonicalize_filename (SCM filename)
}
}
+/* scm_open_file_with_encoding
+ Return a new port open on a given file.
-/* scm_open_file
- * Return a new port open on a given file.
- *
- * The mode string must match the pattern: [rwa+]** which
- * is interpreted in the usual unix way.
- *
- * Return the new port.
- */
-SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
- (SCM filename, SCM mode),
- "Open the file whose name is @var{filename}, and return a port\n"
- "representing that file. The attributes of the port are\n"
- "determined by the @var{mode} string. The way in which this is\n"
- "interpreted is similar to C stdio. The first character must be\n"
- "one of the following:\n"
- "@table @samp\n"
- "@item r\n"
- "Open an existing file for input.\n"
- "@item w\n"
- "Open a file for output, creating it if it doesn't already exist\n"
- "or removing its contents if it does.\n"
- "@item a\n"
- "Open a file for output, creating it if it doesn't already\n"
- "exist. All writes to the port will go to the end of the file.\n"
- "The \"append mode\" can be turned off while the port is in use\n"
- "@pxref{Ports and File Descriptors, fcntl}\n"
- "@end table\n"
- "The following additional characters can be appended:\n"
- "@table @samp\n"
- "@item b\n"
- "Open the underlying file in binary mode, if supported by the
system.\n"
- "Also, open the file using the binary-compatible character
encoding\n"
- "\"ISO-8859-1\", ignoring the port's encoding and the coding
declaration\n"
- "at the top of the input file, if any.\n"
- "@item +\n"
- "Open the port for both input and output. E.g., @code{r+}: open\n"
- "an existing file for both input and output.\n"
- "@item 0\n"
- "Create an \"unbuffered\" port. In this case input and output\n"
- "operations are passed directly to the underlying port\n"
- "implementation without additional buffering. This is likely to\n"
- "slow down I/O operations. The buffering mode can be changed\n"
- "while a port is in use @pxref{Ports and File Descriptors,\n"
- "setvbuf}\n"
- "@item l\n"
- "Add line-buffering to the port. The port output buffer will be\n"
- "automatically flushed whenever a newline character is written.\n"
- "@end table\n"
- "When the file is opened, this procedure will scan for a coding\n"
- "address@hidden Encoding of Source Files}. If present\n"
- "will use that encoding for interpreting the file. Otherwise,
the\n"
- "port's encoding will be used.\n"
- "\n"
- "In theory we could create read/write ports which were buffered\n"
- "in one direction only. However this isn't included in the\n"
- "current interfaces. If a file cannot be opened with the access\n"
- "requested, @code{open-file} throws an exception.")
-#define FUNC_NAME s_scm_open_file
+ The mode string must match the pattern: [rwa+]** which
+ is interpreted in the usual unix way.
+
+ Unless binary mode is requested, the character encoding of the new
+ port is determined as follows: First, if GUESS_ENCODING is true,
+ 'file-encoding' is used to guess the encoding of the file. If
+ GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used
+ unless it is also false. As a last resort, the default port encoding
+ is used. It is an error to pass a non-false GUESS_ENCODING or
+ ENCODING if binary mode is requested.
+
+ Return the new port. */
+SCM
+scm_open_file_with_encoding (SCM filename, SCM mode,
+ SCM guess_encoding, SCM encoding)
+#define FUNC_NAME "open-file"
{
SCM port;
- int fdes, flags = 0, use_encoding = 1;
+ int fdes, flags = 0, binary = 0;
unsigned int retries;
char *file, *md, *ptr;
+ if (SCM_UNLIKELY (!(scm_is_false (encoding) || scm_is_string (encoding))))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, encoding,
+ "encoding to be string or false");
+
scm_dynwind_begin (0);
file = scm_to_locale_string (filename);
@@ -434,7 +375,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
break;
case 'b':
- use_encoding = 0;
+ binary = 1;
#if defined (O_BINARY)
flags |= O_BINARY;
#endif
@@ -473,21 +414,44 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode),
fport_canonicalize_filename (filename));
- if (use_encoding)
+ if (binary)
{
- /* If this file has a coding declaration, use that as the port
- encoding. */
- if (SCM_INPUT_PORT_P (port))
- {
- char *enc = scm_i_scan_for_encoding (port);
- if (enc != NULL)
- scm_i_set_port_encoding_x (port, enc);
- }
+ if (scm_is_true (encoding))
+ scm_misc_error (FUNC_NAME,
+ "Encoding specified on a binary port",
+ scm_list_1 (encoding));
+ if (scm_is_true (guess_encoding))
+ scm_misc_error (FUNC_NAME,
+ "Request to guess encoding on a binary port",
+ SCM_EOL);
+
+ /* Use the binary-friendly ISO-8859-1 encoding. */
+ scm_i_set_port_encoding_x (port, NULL);
}
else
- /* If this is a binary file, use the binary-friendly ISO-8859-1
- encoding. */
- scm_i_set_port_encoding_x (port, NULL);
+ {
+ char *enc = NULL;
+
+ if (scm_is_true (guess_encoding))
+ {
+ if (SCM_INPUT_PORT_P (port))
+ enc = scm_i_scan_for_encoding (port);
+ else
+ scm_misc_error (FUNC_NAME,
+ "Request to guess encoding on an output-only port",
+ SCM_EOL);
+ }
+
+ if (!enc && scm_is_true (encoding))
+ {
+ char *buf = scm_to_latin1_string (encoding);
+ enc = scm_gc_strdup (buf, "encoding");
+ free (buf);
+ }
+
+ if (enc)
+ scm_i_set_port_encoding_x (port, enc);
+ }
scm_dynwind_end ();
@@ -495,49 +459,76 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
}
#undef FUNC_NAME
-
-#ifdef __MINGW32__
-/*
- * Try getting the appropiate file flags for a given file descriptor
- * under Windows. This incorporates some fancy operations because Windows
- * differentiates between file, pipe and socket descriptors.
- */
-#ifndef O_ACCMODE
-# define O_ACCMODE 0x0003
-#endif
+SCM
+scm_open_file (SCM filename, SCM mode)
+{
+ return scm_open_file_with_encoding (filename, mode, SCM_BOOL_F, SCM_BOOL_F);
+}
+
+/* We can't define these using SCM_KEYWORD, because keywords have not
+ yet been initialized when scm_init_fports is called. */
+static SCM k_guess_encoding = SCM_UNDEFINED;
+static SCM k_encoding = SCM_UNDEFINED;
-static int getflags (int fdes)
+SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1,
+ (SCM filename, SCM mode, SCM keyword_args),
+ "Open the file whose name is @var{filename}, and return a port\n"
+ "representing that file. The attributes of the port are\n"
+ "determined by the @var{mode} string. The way in which this is\n"
+ "interpreted is similar to C stdio. The first character must be\n"
+ "one of the following:\n"
+ "@table @samp\n"
+ "@item r\n"
+ "Open an existing file for input.\n"
+ "@item w\n"
+ "Open a file for output, creating it if it doesn't already exist\n"
+ "or removing its contents if it does.\n"
+ "@item a\n"
+ "Open a file for output, creating it if it doesn't already\n"
+ "exist. All writes to the port will go to the end of the file.\n"
+ "The \"append mode\" can be turned off while the port is in use\n"
+ "@pxref{Ports and File Descriptors, fcntl}\n"
+ "@end table\n"
+ "The following additional characters can be appended:\n"
+ "@table @samp\n"
+ "@item b\n"
+ "Open the underlying file in binary mode, if supported by the
system.\n"
+ "Also, open the file using the binary-compatible character
encoding\n"
+ "\"ISO-8859-1\", ignoring the default port encoding.\n"
+ "@item +\n"
+ "Open the port for both input and output. E.g., @code{r+}: open\n"
+ "an existing file for both input and output.\n"
+ "@item 0\n"
+ "Create an \"unbuffered\" port. In this case input and output\n"
+ "operations are passed directly to the underlying port\n"
+ "implementation without additional buffering. This is likely to\n"
+ "slow down I/O operations. The buffering mode can be changed\n"
+ "while a port is in use @pxref{Ports and File Descriptors,\n"
+ "setvbuf}\n"
+ "@item l\n"
+ "Add line-buffering to the port. The port output buffer will be\n"
+ "automatically flushed whenever a newline character is written.\n"
+ "@end table\n"
+ "In theory we could create read/write ports which were buffered\n"
+ "in one direction only. However this isn't included in the\n"
+ "current interfaces. If a file cannot be opened with the access\n"
+ "requested, @code{open-file} throws an exception.")
+#define FUNC_NAME s_scm_i_open_file
{
- int flags = 0;
- struct stat buf;
- int error, optlen = sizeof (int);
-
- /* Is this a socket ? */
- if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
- flags = O_RDWR;
- /* Maybe a regular file ? */
- else if (fstat (fdes, &buf) < 0)
- flags = -1;
- else
- {
- /* Or an anonymous pipe handle ? */
- if (buf.st_mode & _S_IFIFO)
- flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
- NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
- /* stdin ? */
- else if (fdes == fileno (stdin) && isatty (fdes))
- flags = O_RDONLY;
- /* stdout / stderr ? */
- else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
- isatty (fdes))
- flags = O_WRONLY;
- else
- flags = buf.st_mode;
- }
- return flags;
+ SCM encoding = SCM_BOOL_F;
+ SCM guess_encoding = SCM_BOOL_F;
+
+ scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
+ k_guess_encoding, &guess_encoding,
+ k_encoding, &encoding,
+ SCM_UNDEFINED);
+
+ return scm_open_file_with_encoding (filename, mode,
+ guess_encoding, encoding);
}
-#endif /* __MINGW32__ */
+#undef FUNC_NAME
+
/* Building Guile ports from a file descriptor. */
/* Build a Scheme port from an open file descriptor `fdes'.
@@ -551,14 +542,10 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
{
SCM port;
scm_t_fport *fp;
- int flags;
- /* test that fdes is valid. */
-#ifdef __MINGW32__
- flags = getflags (fdes);
-#else
- flags = fcntl (fdes, F_GETFL, 0);
-#endif
+ /* Test that fdes is valid. */
+#ifdef F_GETFL
+ int flags = fcntl (fdes, F_GETFL, 0);
if (flags == -1)
SCM_SYSERROR;
flags &= O_ACCMODE;
@@ -568,6 +555,13 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
{
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
+#else
+ /* If we don't have F_GETFL, as on mingw, at least we can test that
+ it is a valid file descriptor. */
+ struct stat st;
+ if (fstat (fdes, &st) != 0)
+ SCM_SYSERROR;
+#endif
fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
"file port");
@@ -600,52 +594,12 @@ fport_input_waiting (SCM port)
{
int fdes = SCM_FSTREAM (port)->fdes;
- /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the
- highest numerical value of file descriptors that can be monitored.
- Thus, use poll(2) whenever that is possible. */
-
-#ifdef HAVE_POLL
struct pollfd pollfd = { fdes, POLLIN, 0 };
if (poll (&pollfd, 1, 0) < 0)
scm_syserror ("fport_input_waiting");
return pollfd.revents & POLLIN ? 1 : 0;
-
-#elif defined(HAVE_SELECT)
- struct timeval timeout;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
-
- FD_ZERO (&read_set);
- FD_ZERO (&write_set);
- FD_ZERO (&except_set);
-
- FD_SET (fdes, &read_set);
-
- timeout.tv_sec = 0;
- timeout.tv_usec = 0;
-
- if (select (SELECT_SET_SIZE,
- &read_set, &write_set, &except_set, &timeout)
- < 0)
- scm_syserror ("fport_input_waiting");
- return FD_ISSET (fdes, &read_set) ? 1 : 0;
-
-#elif HAVE_IOCTL && defined (FIONREAD)
- /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
- (for use with winsock ioctlsocket()) but not ioctl(). */
- int fdes = SCM_FSTREAM (port)->fdes;
- int remir;
- ioctl(fdes, FIONREAD, &remir);
- return remir;
-
-#else
- scm_misc_error ("fport_input_waiting",
- "Not fully implemented on this platform",
- SCM_EOL);
-#endif
}
@@ -1022,6 +976,15 @@ scm_make_fptob ()
return tc;
}
+/* We can't initialize the keywords from 'scm_init_fports', because
+ keywords haven't yet been initialized at that point. */
+void
+scm_init_fports_keywords ()
+{
+ k_guess_encoding = scm_from_latin1_keyword ("guess-encoding");
+ k_encoding = scm_from_latin1_keyword ("encoding");
+}
+
void
scm_init_fports ()
{
diff --git a/libguile/fports.h b/libguile/fports.h
index 4094f14..092b43e 100644
--- a/libguile/fports.h
+++ b/libguile/fports.h
@@ -54,6 +54,8 @@ SCM_API scm_t_bits scm_tc16_fport;
SCM_API SCM scm_setbuf0 (SCM port);
SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size);
SCM_API void scm_evict_ports (int fd);
+SCM_API SCM scm_open_file_with_encoding (SCM filename, SCM modes,
+ SCM guess_encoding, SCM encoding);
SCM_API SCM scm_open_file (SCM filename, SCM modes);
SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
SCM_API SCM scm_file_port_p (SCM obj);
@@ -66,6 +68,7 @@ SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
SCM_API SCM scm_adjust_port_revealed_x (SCM port, SCM addend);
+SCM_INTERNAL void scm_init_fports_keywords (void);
SCM_INTERNAL void scm_init_fports (void);
/* internal functions */
diff --git a/libguile/gc.c b/libguile/gc.c
index d580a65..581bbc5 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006,
+ * 2008, 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -281,7 +282,13 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
&bytes_since_gc, &total_bytes);
+#ifdef HAVE_GC_GET_GC_NO
+ /* This function was added in 7.2alpha2 (June 2009). */
+ gc_times = GC_get_gc_no ();
+#else
+ /* This symbol is deprecated as of 7.3. */
gc_times = GC_gc_no;
+#endif
answer =
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
@@ -582,7 +589,14 @@ scm_getenv_int (const char *var, int def)
void
scm_storage_prehistory ()
{
+#ifdef HAVE_GC_SET_ALL_INTERIOR_POINTERS
+ /* This function was added in 7.2alpha2 (June 2009). */
+ GC_set_all_interior_pointers (0);
+#else
+ /* This symbol is deprecated in 7.3. */
GC_all_interior_pointers = 0;
+#endif
+
free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
minimum_free_space_divisor = free_space_divisor;
target_free_space_divisor = free_space_divisor;
diff --git a/libguile/gc.h b/libguile/gc.h
index b1df82d..0857781 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -4,7 +4,7 @@
#define SCM_GC_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006,
- * 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -181,6 +181,7 @@ SCM_API char *scm_gc_strdup (const char *str, const char
*what)
SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what)
SCM_MALLOC;
+#define scm_gc_typed_calloc(t) ((t *) scm_gc_calloc (sizeof (t), #t))
#ifdef BUILDING_LIBGUILE
#include "libguile/bdw-gc.h"
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index e1cc030..11020cf 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -1,3 +1,20 @@
+/* Copyright (C) 2003-2013 Free Software 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
+ */
/**********************************************************************
@@ -268,7 +285,7 @@ main (int argc, char *argv[])
pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
pf ("\n");
- pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n"
+ pf ("/* scm_t_ptrdiff and size, always defined -- defined to long if\n"
" platform doesn't have ptrdiff_t. */\n");
pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF);
if (0 == strcmp ("long", SCM_I_GSC_T_PTRDIFF))
@@ -284,7 +301,7 @@ main (int argc, char *argv[])
pf ("\n");
pf ("/* same as POSIX \"struct timespec\" -- always defined */\n");
-#ifdef HAVE_STRUCT_TIMESPEC
+#ifdef HAVE_SYSTEM_STRUCT_TIMESPEC
pf ("typedef struct timespec scm_t_timespec;\n");
#else
pf ("/* POSIX.4 structure for a time value. This is like a `struct timeval'"
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 3a0ce25..59925a0 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, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2013 Free Software 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,6 +33,12 @@
#include "libguile/generalized-arrays.h"
+SCM_INTERNAL SCM scm_i_array_ref (SCM v,
+ SCM idx0, SCM idx1, SCM idxN);
+SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
+ SCM idx0, SCM idx1, SCM idxN);
+
+
int
scm_is_array (SCM obj)
{
@@ -107,6 +113,35 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
#undef FUNC_NAME
+size_t
+scm_c_array_length (SCM array)
+{
+ scm_t_array_handle handle;
+ size_t res;
+
+ scm_array_get_handle (array, &handle);
+ if (scm_array_handle_rank (&handle) < 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
+ }
+ res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
+ scm_array_handle_release (&handle);
+
+ return res;
+}
+
+SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
+ (SCM array),
+ "Return the length of an array: its first dimension.\n"
+ "It is an error to ask for the length of an array of rank 0.")
+#define FUNC_NAME s_scm_array_length
+{
+ return scm_from_size_t (scm_c_array_length (array));
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
(SCM ra),
"@code{array-dimensions} is similar to @code{array-shape} but
replaces\n"
@@ -195,11 +230,35 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1,
0, 1,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
- (SCM v, SCM args),
- "Return the element at the @code{(index1, index2)} element in\n"
- "array @var{v}.")
-#define FUNC_NAME s_scm_array_ref
+
+SCM
+scm_c_array_ref_1 (SCM array, ssize_t idx0)
+{
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (array, &handle);
+ res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+
+SCM
+scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
+{
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (array, &handle);
+ res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0,
idx1));
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+
+SCM
+scm_array_ref (SCM v, SCM args)
{
scm_t_array_handle handle;
SCM res;
@@ -209,15 +268,34 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
scm_array_handle_release (&handle);
return res;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
- (SCM v, SCM obj, SCM args),
- "Set the element at the @code{(index1, index2)} element in array\n"
- "@var{v} to @var{obj}. The value returned by @code{array-set!}\n"
- "is unspecified.")
-#define FUNC_NAME s_scm_array_set_x
+void
+scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
+{
+ scm_t_array_handle handle;
+
+ scm_array_get_handle (array, &handle);
+ scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
+ obj);
+ scm_array_handle_release (&handle);
+}
+
+
+void
+scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
+{
+ scm_t_array_handle handle;
+
+ scm_array_get_handle (array, &handle);
+ scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
+ obj);
+ scm_array_handle_release (&handle);
+}
+
+
+SCM
+scm_array_set_x (SCM v, SCM obj, SCM args)
{
scm_t_array_handle handle;
@@ -226,8 +304,47 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
}
+
+
+SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
+ (SCM v, SCM idx0, SCM idx1, SCM idxN),
+ "Return the element at the @code{(idx0, idx1, idxN...)}\n"
+ "position in array @var{v}.")
+#define FUNC_NAME s_scm_i_array_ref
+{
+ if (SCM_UNBNDP (idx0))
+ return scm_array_ref (v, SCM_EOL);
+ else if (SCM_UNBNDP (idx1))
+ return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
+ else if (scm_is_null (idxN))
+ return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
+ else
+ return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
+}
#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
+ (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
+ "Set the element at the @code{(idx0, idx1, idxN...)} position\n"
+ "in the array @var{v} to @var{obj}. The value returned by\n"
+ "@code{array-set!} is unspecified.")
+#define FUNC_NAME s_scm_i_array_set_x
+{
+ if (SCM_UNBNDP (idx0))
+ scm_array_set_x (v, obj, SCM_EOL);
+ else if (SCM_UNBNDP (idx1))
+ scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
+ else if (scm_is_null (idxN))
+ scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
+ else
+ scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
static SCM
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
{
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index 1f9b6ad..d9fcea6 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_ARRAYS_H
#define SCM_GENERALIZED_ARRAYS_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013
Free Software 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,10 +44,19 @@ SCM_API SCM scm_typed_array_p (SCM v, SCM type);
SCM_API size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_array_rank (SCM ra);
+SCM_API size_t scm_c_array_length (SCM ra);
+SCM_API SCM scm_array_length (SCM ra);
+
SCM_API SCM scm_array_dimensions (SCM ra);
SCM_API SCM scm_array_type (SCM ra);
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
+SCM_API SCM scm_c_array_ref_1 (SCM v, ssize_t idx0);
+SCM_API SCM scm_c_array_ref_2 (SCM v, ssize_t idx0, ssize_t idx1);
+
+SCM_API void scm_c_array_set_1_x (SCM v, SCM obj, ssize_t idx0);
+SCM_API void scm_c_array_set_2_x (SCM v, SCM obj, ssize_t idx0, ssize_t idx1);
+
SCM_API SCM scm_array_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_to_list (SCM v);
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 4da0e88..5e3e552 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
- * 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2005, 2006, 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -83,16 +83,6 @@ scm_is_generalized_vector (SCM obj)
return ret;
}
-SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a vector, string,\n"
- "bitvector, or uniform numeric vector.")
-#define FUNC_NAME s_scm_generalized_vector_p
-{
- return scm_from_bool (scm_is_generalized_vector (obj));
-}
-#undef FUNC_NAME
-
#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle)
@@ -119,15 +109,6 @@ scm_c_generalized_vector_length (SCM v)
return ret;
}
-SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0,
0,
- (SCM v),
- "Return the length of the generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_length
-{
- return scm_from_size_t (scm_c_generalized_vector_length (v));
-}
-#undef FUNC_NAME
-
SCM
scm_c_generalized_vector_ref (SCM v, size_t idx)
{
@@ -141,16 +122,6 @@ scm_c_generalized_vector_ref (SCM v, size_t idx)
return ret;
}
-SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
- (SCM v, SCM idx),
- "Return the element at index @var{idx} of the\n"
- "generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_ref
-{
- return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
void
scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
{
@@ -162,43 +133,6 @@ scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
scm_array_handle_release (&h);
}
-SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
- (SCM v, SCM idx, SCM val),
- "Set the element at index @var{idx} of the\n"
- "generalized vector @var{v} to @var{val}.")
-#define FUNC_NAME s_scm_generalized_vector_set_x
-{
- scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0,
0,
- (SCM v),
- "Return a new list whose elements are the elements of the\n"
- "generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_to_list
-{
- /* FIXME: This duplicates `array_to_list'. */
- SCM ret = SCM_EOL;
- long inc;
- ssize_t pos, i;
- scm_t_array_handle h;
-
- scm_generalized_vector_get_handle (v, &h);
-
- i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
- inc = h.dims[0].inc;
- pos = (i - 1) * inc;
-
- for (; i > 0; i--, pos -= inc)
- ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
-
- scm_array_handle_release (&h);
- return ret;
-}
-#undef FUNC_NAME
-
void
scm_init_generalized_vectors ()
{
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index 71b58d2..e2acb98 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_VECTORS_H
#define SCM_GENERALIZED_VECTORS_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013
Free Software 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,12 +30,6 @@
/* Generalized vectors */
-SCM_API SCM scm_generalized_vector_p (SCM v);
-SCM_API SCM scm_generalized_vector_length (SCM v);
-SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
-SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
-SCM_API SCM scm_generalized_vector_to_list (SCM v);
-
SCM_API int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v);
SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
diff --git a/libguile/guardians.c b/libguile/guardians.c
index 8a0d296..49d7cba 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011,
- * 2012 Free Software Foundation, Inc.
+ * 2012, 2013 Free Software 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
@@ -355,7 +355,13 @@ void
scm_init_guardians ()
{
/* We use unordered finalization `a la Java. */
+#ifdef HAVE_GC_SET_JAVA_FINALIZATION
+ /* This function was added in 7.2alpha2 (June 2009). */
+ GC_set_java_finalization (1);
+#else
+ /* This symbol is deprecated as of 7.3. */
GC_java_finalization = 1;
+#endif
tc16_guardian = scm_make_smob_type ("guardian", 0);
diff --git a/libguile/guile.c b/libguile/guile.c
index 133afc4..03b603e 100644
--- a/libguile/guile.c
+++ b/libguile/guile.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 2000, 2001, 2006, 2008,
- * 2011 Free Software Foundation, Inc.
+ * 2011, 2013 Free Software 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
@@ -66,15 +66,41 @@ inner_main (void *closure SCM_UNUSED, int argc, char **argv)
#endif /* __MINGW32__ */
}
+static int
+get_integer_from_environment (const char *var, int def)
+{
+ char *end = 0;
+ char *val = getenv (var);
+ long res = def;
+ if (!val)
+ return def;
+ res = strtol (val, &end, 10);
+ if (end == val)
+ {
+ fprintf (stderr, "guile: warning: invalid %s: %s\n", var, val);
+ return def;
+ }
+ return res;
+}
+
+static int
+should_install_locale (void)
+{
+ /* If the GUILE_INSTALL_LOCALE environment variable is unset,
+ or set to a nonzero value, we should install the locale via
+ setlocale(). */
+ return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 1);
+}
+
int
main (int argc, char **argv)
{
- /* Install the locale right at the beginning so that string conversion
- for command-line arguments, along with possible error messages, use
- the right locale. See
+ /* If we should install a locale, do it right at the beginning so that
+ string conversion for command-line arguments, along with possible
+ error messages, use the right locale. See
<https://lists.gnu.org/archive/html/guile-devel/2011-11/msg00041.html>
for the rationale. */
- if (setlocale (LC_ALL, "") == NULL)
+ if (should_install_locale () && setlocale (LC_ALL, "") == NULL)
fprintf (stderr, "guile: warning: failed to install locale\n");
scm_install_gmp_memory_functions = 1;
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index fc7fa42..fff48b8 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -205,6 +205,7 @@ SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
}
#undef FUNC_NAME
+
/* Accessing hash table entries. */
@@ -966,6 +967,33 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0,
0,
}
#undef FUNC_NAME
+static SCM
+count_proc (void *pred, SCM key, SCM data, SCM value)
+{
+ if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
+ return value;
+ else
+ return scm_oneplus(value);
+}
+
+SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
+ (SCM pred, SCM table),
+ "Return the number of elements in the given hash TABLE that\n"
+ "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
+ "the total number of elements, use `(const #t)' for PRED.")
+#define FUNC_NAME s_scm_hash_count
+{
+ SCM init;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_HASHTABLE (2, table);
+
+ init = scm_from_int (0);
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
+ (void *) SCM_UNPACK (pred), init, table);
+}
+#undef FUNC_NAME
+
SCM
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 8eb685a..82ed22e 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -134,6 +134,7 @@ SCM_API SCM scm_hash_fold (SCM proc, SCM init, SCM hash);
SCM_API SCM scm_hash_for_each (SCM proc, SCM hash);
SCM_API SCM scm_hash_for_each_handle (SCM proc, SCM hash);
SCM_API SCM scm_hash_map_to_list (SCM proc, SCM hash);
+SCM_API SCM scm_hash_count (SCM hash, SCM pred);
SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state
*pstate);
SCM_INTERNAL void scm_init_hashtab (void);
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 817c661..dc6d07d 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software
Foundation, Inc.
+/* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software
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
@@ -685,6 +685,8 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
}
}
+ /* silence gcc's unused variable warning */
+ (void) c_base_locale;
#endif
return locale;
diff --git a/libguile/init.c b/libguile/init.c
index 684f6eb..6787483 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2004, 2006, 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -75,7 +75,6 @@
#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/list.h"
@@ -443,6 +442,7 @@ scm_i_init_guile (void *base)
scm_init_gettext ();
scm_init_ioext ();
scm_init_keywords (); /* Requires smob_prehistory */
+ scm_init_fports_keywords ();
scm_init_list ();
scm_init_random (); /* Requires smob_prehistory */
scm_init_macros (); /* Requires smob_prehistory and random */
diff --git a/libguile/inline.c b/libguile/inline.c
index e005b26..6e7688c 100644
--- a/libguile/inline.c
+++ b/libguile/inline.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2008, 2011, 2012, 2013 Free Software 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,6 +23,7 @@
#define SCM_IMPLEMENT_INLINES 1
#define SCM_INLINE_C_IMPLEMENTING_INLINES 1
#include "libguile/inline.h"
+#include "libguile/array-handle.h"
#include "libguile/gc.h"
#include "libguile/smob.h"
#include "libguile/pairs.h"
diff --git a/libguile/inline.h b/libguile/inline.h
index 89bbf9d..3c9b09b 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -4,7 +4,7 @@
#define SCM_INLINE_H
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010,
- * 2011, 2012 Free Software Foundation, Inc.
+ * 2011, 2012, 2013 Free Software 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,9 +37,6 @@
#include "libguile/error.h"
-SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
-SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM
val);
-
SCM_INLINE int scm_is_string (SCM x);
SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
@@ -50,26 +47,6 @@ SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint32
n_words);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
/* Either inlining, or being included from inline.c. */
-SCM_INLINE_IMPLEMENTATION SCM
-scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
-{
- if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
- /* catch overflow */
- scm_out_of_range (NULL, scm_from_ssize_t (p));
- /* perhaps should catch overflow here too */
- return h->impl->vref (h, h->base + p);
-}
-
-SCM_INLINE_IMPLEMENTATION void
-scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
-{
- if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
- /* catch overflow */
- scm_out_of_range (NULL, scm_from_ssize_t (p));
- /* perhaps should catch overflow here too */
- h->impl->vset (h, h->base + p, v);
-}
-
SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 11004fc..08f7cd6 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -64,8 +64,8 @@ struct scm_instruction {
M(X8_U12_U12) \
M(X8_R24) \
M(X8_L24) \
- M(U1_X7_L24) \
- M(U1_U7_L24)
+ M(B1_X7_L24) \
+ M(B1_U7_L24)
#define TYPE_WIDTH 5
diff --git a/libguile/iselect.h b/libguile/iselect.h
index 760d959..1c7b12d 100644
--- a/libguile/iselect.h
+++ b/libguile/iselect.h
@@ -3,7 +3,8 @@
#ifndef SCM_ISELECT_H
#define SCM_ISELECT_H
-/* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1997,1998,2000,2001, 2002, 2006,
+ * 2013 Free Software 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,35 +30,18 @@
#include <sys/types.h>
#if SCM_HAVE_SYS_SELECT_H
-# include <sys/select.h>
-#endif
-#if SCM_HAVE_WINSOCK2_H
-# include <winsock2.h>
-#endif
+#include <sys/select.h>
-#ifdef FD_SET
+SCM_API int scm_std_select (int fds,
+ fd_set *rfds,
+ fd_set *wfds,
+ fd_set *efds,
+ struct timeval *timeout);
#define SELECT_TYPE fd_set
-#define SELECT_SET_SIZE FD_SETSIZE
-
-#else /* no FD_SET */
-
-/* Define the macros to access a single-int bitmap of descriptors. */
-#define SELECT_SET_SIZE 32
-#define SELECT_TYPE int
-#define FD_SET(n, p) (*(p) |= (1 << (n)))
-#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
-#define FD_ISSET(n, p) (*(p) & (1 << (n)))
-#define FD_ZERO(p) (*(p) = 0)
-#endif /* no FD_SET */
-
-SCM_API int scm_std_select (int fds,
- SELECT_TYPE *rfds,
- SELECT_TYPE *wfds,
- SELECT_TYPE *efds,
- struct timeval *timeout);
+#endif /* SCM_HAVE_SYS_SELECT_H */
#endif /* SCM_ISELECT_H */
diff --git a/libguile/keywords.c b/libguile/keywords.c
index e4a79ac..96c0b01 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -23,6 +23,7 @@
#endif
#include <string.h>
+#include <stdarg.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
@@ -124,6 +125,72 @@ scm_from_utf8_keyword (const char *name)
return scm_symbol_to_keyword (scm_from_utf8_symbol (name));
}
+SCM_SYMBOL (scm_keyword_argument_error, "keyword-argument-error");
+
+void
+scm_c_bind_keyword_arguments (const char *subr, SCM rest,
+ scm_t_keyword_arguments_flags flags, ...)
+{
+ va_list va;
+
+ if (SCM_UNLIKELY (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS)
+ && scm_ilength (rest) % 2 != 0))
+ scm_error (scm_keyword_argument_error,
+ subr, "Odd length of keyword argument list",
+ SCM_EOL, SCM_BOOL_F);
+
+ while (scm_is_pair (rest))
+ {
+ SCM kw_or_arg = SCM_CAR (rest);
+ SCM tail = SCM_CDR (rest);
+
+ if (scm_is_keyword (kw_or_arg) && scm_is_pair (tail))
+ {
+ SCM kw;
+ SCM *arg_p;
+
+ va_start (va, flags);
+ for (;;)
+ {
+ kw = va_arg (va, SCM);
+ if (SCM_UNBNDP (kw))
+ {
+ /* KW_OR_ARG is not in the list of expected keywords. */
+ if (!(flags & SCM_ALLOW_OTHER_KEYS))
+ scm_error (scm_keyword_argument_error,
+ subr, "Unrecognized keyword",
+ SCM_EOL, SCM_BOOL_F);
+ break;
+ }
+ arg_p = va_arg (va, SCM *);
+ if (scm_is_eq (kw_or_arg, kw))
+ {
+ /* We found the matching keyword. Store the
+ associated value and break out of the loop. */
+ *arg_p = SCM_CAR (tail);
+ break;
+ }
+ }
+ va_end (va);
+
+ /* Advance REST. */
+ rest = SCM_CDR (tail);
+ }
+ else
+ {
+ /* The next argument is not a keyword, or is a singleton
+ keyword at the end of REST. */
+ if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS))
+ scm_error (scm_keyword_argument_error,
+ subr, "Invalid keyword",
+ SCM_EOL, SCM_BOOL_F);
+
+ /* Advance REST. */
+ rest = tail;
+ }
+ }
+}
+
/* njrev: critical sections reviewed so far up to here */
void
scm_init_keywords ()
diff --git a/libguile/keywords.h b/libguile/keywords.h
index c9e6af1..3cdb0ec 100644
--- a/libguile/keywords.h
+++ b/libguile/keywords.h
@@ -41,6 +41,18 @@ SCM_API SCM scm_from_locale_keywordn (const char *name,
size_t len);
SCM_API SCM scm_from_latin1_keyword (const char *name);
SCM_API SCM scm_from_utf8_keyword (const char *name);
+enum scm_keyword_arguments_flags
+{
+ SCM_ALLOW_OTHER_KEYS = (1U << 0),
+ SCM_ALLOW_NON_KEYWORD_ARGUMENTS = (1U << 1)
+};
+
+typedef enum scm_keyword_arguments_flags scm_t_keyword_arguments_flags;
+
+SCM_API void
+scm_c_bind_keyword_arguments (const char *subr, SCM rest,
+ scm_t_keyword_arguments_flags flags, ...);
+
SCM_INTERNAL void scm_init_keywords (void);
#endif /* SCM_KEYWORDS_H */
diff --git a/libguile/list.c b/libguile/list.c
index 6276403..1f44ad0 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -377,8 +377,6 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
SCM_VALIDATE_LIST (1, lst);
if (SCM_UNBNDP (new_tail))
new_tail = SCM_EOL;
- else
- SCM_VALIDATE_LIST (2, new_tail);
while (!SCM_NULL_OR_NIL_P (lst))
{
diff --git a/libguile/load.c b/libguile/load.c
index 081c364..ebf79a9 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -198,6 +198,19 @@ SCM_DEFINE (scm_sys_global_site_dir, "%global-site-dir",
0,0,0,
#undef FUNC_NAME
#endif /* SCM_GLOBAL_SITE_DIR */
+#ifdef SCM_SITE_CCACHE_DIR
+SCM_DEFINE (scm_sys_site_ccache_dir, "%site-ccache-dir", 0,0,0,
+ (),
+ "Return the directory where users should install compiled\n"
+ "@code{.go} files for use with this version of Guile.\n\n"
+ "E.g., may return \"/usr/lib/guile/" SCM_EFFECTIVE_VERSION
"/site-ccache\".")
+#define FUNC_NAME s_scm_sys_site_ccache_dir
+{
+ return scm_from_locale_string (SCM_SITE_CCACHE_DIR);
+}
+#undef FUNC_NAME
+#endif /* SCM_SITE_CCACHE_DIR */
+
/* Initializing the load path, and searching it. */
@@ -447,6 +460,60 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM
extensions)
return 0;
}
+#ifdef __MINGW32__
+#define FILE_NAME_SEPARATOR_STRING "\\"
+#else
+#define FILE_NAME_SEPARATOR_STRING "/"
+#endif
+
+static int
+is_file_name_separator (SCM c)
+{
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
+ return 1;
+#ifdef __MINGW32__
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
+ return 1;
+#endif
+ return 0;
+}
+
+static int
+is_drive_letter (SCM c)
+{
+#ifdef __MINGW32__
+ if (SCM_CHAR (c) >= 'a' && SCM_CHAR (c) <= 'z')
+ return 1;
+ else if (SCM_CHAR (c) >= 'A' && SCM_CHAR (c) <= 'Z')
+ return 1;
+#endif
+ return 0;
+}
+
+static int
+is_absolute_file_name (SCM filename)
+{
+ size_t filename_len = scm_c_string_length (filename);
+
+ if (filename_len >= 1
+ && is_file_name_separator (scm_c_string_ref (filename, 0))
+#ifdef __MINGW32__
+ /* On Windows, one initial separator indicates a drive-relative
+ path. Two separators indicate a Universal Naming Convention
+ (UNC) path. UNC paths are always absolute. */
+ && filename_len >= 2
+ && is_file_name_separator (scm_c_string_ref (filename, 1))
+#endif
+ )
+ return 1;
+ if (filename_len >= 3
+ && is_drive_letter (scm_c_string_ref (filename, 0))
+ && scm_is_eq (scm_c_string_ref (filename, 1), SCM_MAKE_CHAR (':'))
+ && is_file_name_separator (scm_c_string_ref (filename, 2)))
+ return 1;
+ return 0;
+}
+
/* Search PATH for a directory containing a file named FILENAME.
The file must be readable, and not a directory.
If we find one, return its full pathname; otherwise, return #f.
@@ -477,16 +544,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM
require_exts,
scm_dynwind_free (filename_chars);
/* If FILENAME is absolute and is still valid, return it unchanged. */
-#ifdef __MINGW32__
- if (((filename_len >= 1) &&
- (filename_chars[0] == '/' || filename_chars[0] == '\\')) ||
- ((filename_len >= 3) && filename_chars[1] == ':' &&
- ((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') ||
- (filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) &&
- (filename_chars[2] == '/' || filename_chars[2] == '\\')))
-#else
- if (filename_len >= 1 && filename_chars[0] == '/')
-#endif
+ if (is_absolute_file_name (filename))
{
if ((scm_is_false (require_exts) ||
scm_c_string_has_an_ext (filename_chars, filename_len,
@@ -520,11 +578,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM
require_exts,
extensions = SCM_EOL;
break;
}
-#ifdef __MINGW32__
- else if (*endp == '/' || *endp == '\\')
-#else
- else if (*endp == '/')
-#endif
+ else if (is_file_name_separator (SCM_MAKE_CHAR (*endp)))
/* This filename has no extension, so keep the current list
of extensions. */
break;
@@ -553,12 +607,9 @@ search_path (SCM path, SCM filename, SCM extensions, SCM
require_exts,
/* Concatenate the path name and the filename. */
-#ifdef __MINGW32__
- if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\'))
-#else
- if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/'))
-#endif
- stringbuf_cat (&buf, "/");
+ if (buf.ptr > buf.buf
+ && !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1])))
+ stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING);
stringbuf_cat (&buf, filename_chars);
sans_ext_len = buf.ptr - buf.buf;
@@ -823,24 +874,36 @@ scm_try_auto_compile (SCM source)
NULL, NULL);
}
-/* See also (system base compile):compiled-file-name. */
+/* The auto-compilation code will residualize a .go file in the cache
+ dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This
+ function determines the PATH to use as a key into the compilation
+ cache. See also (system base compile):compiled-file-name. */
static SCM
canonical_suffix (SCM fname)
{
SCM canon;
- size_t len;
+ /* CANON should be absolute. */
canon = scm_canonicalize_path (fname);
- len = scm_c_string_length (canon);
- if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
- return canon;
- else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR
(':')))
- return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"),
- scm_c_substring (canon, 0, 1),
- scm_c_substring (canon, 2, len)));
- else
- return canon;
+#ifdef __MINGW32__
+ {
+ size_t len = scm_c_string_length (canon);
+
+ /* On Windows, an absolute file name that doesn't start with a
+ separator starts with a drive component. Transform the drive
+ component to a file name element: c:\foo -> \c\foo. */
+ if (len >= 2
+ && is_absolute_file_name (canon)
+ && !is_file_name_separator (scm_c_string_ref (canon, 0)))
+ return scm_string_append
+ (scm_list_3 (scm_from_latin1_string (FILE_NAME_SEPARATOR_STRING),
+ scm_c_substring (canon, 0, 1),
+ scm_c_substring (canon, 2, len)));
+ }
+#endif
+
+ return canon;
}
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
diff --git a/libguile/load.h b/libguile/load.h
index 698bbaf..ab75ea3 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -3,7 +3,7 @@
#ifndef SCM_LOAD_H
#define SCM_LOAD_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013
Free Software 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,6 +34,7 @@ SCM_API SCM scm_sys_package_data_dir (void);
SCM_API SCM scm_sys_library_dir (void);
SCM_API SCM scm_sys_site_dir (void);
SCM_API SCM scm_sys_global_site_dir (void);
+SCM_API SCM scm_sys_site_ccache_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM rest);
SCM_API SCM scm_sys_search_load_path (SCM filename);
SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);
diff --git a/libguile/memoize.c b/libguile/memoize.c
index af68610..f20241c 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -284,14 +284,33 @@ memoize (SCM exp, SCM env)
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case. */
+ /* The body will be a lambda-case or #f. */
{
- SCM meta, docstring, proc;
+ SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
- proc = memoize (REF (exp, LAMBDA, BODY), env);
+ body = REF (exp, LAMBDA, BODY);
+ if (scm_is_false (body))
+ /* Give a body to case-lambda with no clauses. */
+ proc = MAKMEMO_LAMBDA
+ (MAKMEMO_CALL
+ (MAKMEMO_MOD_REF (list_of_guile,
+ scm_from_latin1_symbol ("throw"),
+ SCM_BOOL_F),
+ 5,
+ scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
+ MAKMEMO_QUOTE (SCM_BOOL_F),
+ MAKMEMO_QUOTE (scm_from_latin1_string
+ ("Wrong number of arguments")),
+ MAKMEMO_QUOTE (SCM_EOL),
+ MAKMEMO_QUOTE (SCM_BOOL_F))),
+ FIXED_ARITY (0),
+ SCM_BOOL_F /* docstring */);
+ else
+ proc = memoize (body, env);
+
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);
@@ -910,7 +929,6 @@ void
scm_init_memoize ()
{
scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
- scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c
index 6a573c6..a7eaf10 100644
--- a/libguile/mkstemp.c
+++ b/libguile/mkstemp.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006 Free Software Foundation,
Inc.
+/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013 Free Software
Foundation, Inc.
This file is derived from mkstemps.c from the GNU Libiberty Library
which in turn is derived from the GNU C Library.
@@ -112,7 +112,7 @@ mkstemp (template)
v /= 62;
XXXXXX[5] = letters[v % 62];
- fd = open (template, O_RDWR|O_CREAT|O_EXCL, 0600);
+ fd = open (template, O_RDWR|O_CREAT|O_EXCL|O_BINARY, 0600);
if (fd >= 0)
/* The file does not exist. */
return fd;
diff --git a/libguile/net_db.c b/libguile/net_db.c
index 4d63aab..d7a12c5 100644
--- a/libguile/net_db.c
+++ b/libguile/net_db.c
@@ -1,6 +1,6 @@
/* "net_db.c" network database support
* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2006, 2009,
- * 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013 Free Software 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,48 +34,36 @@
#include <verify.h>
#include <errno.h>
-#include "libguile/_scm.h"
-#include "libguile/feature.h"
-#include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/dynwind.h"
-
-#include "libguile/validate.h"
-#include "libguile/net_db.h"
-#include "libguile/socket.h"
-
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#include <sys/types.h>
-#ifdef HAVE_WINSOCK2_H
-#include <winsock2.h>
-#else
#include <sys/socket.h>
#include <netdb.h>
#include <netinet/in.h>
#include <arpa/inet.h>
-#endif
-#ifdef __MINGW32__
-#include "win32-socket.h"
-#endif
+#include "libguile/_scm.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/dynwind.h"
-#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
-/* h_errno not found in netdb.h, maybe this will help. */
-extern int h_errno;
-#endif
+#include "libguile/validate.h"
+#include "libguile/net_db.h"
+#include "libguile/socket.h"
+
+
+#if defined (HAVE_H_ERRNO)
+/* Only wrap gethostbyname / gethostbyaddr if h_errno is available. */
-#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \
- && !defined __MINGW32__ && !defined __CYGWIN__
+#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR
/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */
extern const char *hstrerror (int);
#endif
-
-
SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
SCM_SYMBOL (scm_try_again_key, "try-again");
SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
@@ -204,6 +192,8 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
}
#undef FUNC_NAME
+#endif /* HAVE_H_ERRNO */
+
/* In all subsequent getMUMBLE functions, when we're called with no
arguments, we're supposed to traverse the tables entry by entry.
@@ -267,7 +257,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
#undef FUNC_NAME
#endif
-#if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
+#if defined (HAVE_GETPROTOENT)
SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
(SCM protocol),
"@deffnx {Scheme Procedure} getprotobyname name\n"
@@ -318,7 +308,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
#undef FUNC_NAME
#endif
-#if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
+#if defined (HAVE_GETSERVENT)
static SCM
scm_return_entry (struct servent *entry)
{
@@ -420,7 +410,7 @@ SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
#undef FUNC_NAME
#endif
-#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined
(__MINGW32__)
+#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT)
SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
(SCM stayopen),
"If @var{stayopen} is omitted, this is equivalent to
@code{endprotoent}.\n"
@@ -436,7 +426,7 @@ SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
#undef FUNC_NAME
#endif
-#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined
(__MINGW32__)
+#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT)
SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
(SCM stayopen),
"If @var{stayopen} is omitted, this is equivalent to
@code{endservent}.\n"
@@ -605,8 +595,10 @@ SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0,
"@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"
+ "A system error occurred. In C, the error code can be found in "
+ "@code{errno}; this value is not accessible from Scheme, but in\n"
+ "practice it provides little information about the actual error "
+ "cause.\n\n" /* see <http://bugs.gnu.org/13958>. */
"@end table\n"
"\n"
"Users are encouraged to read the "
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 01f8e05..d941133 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1,4 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006,
2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
+ * 2013 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
@@ -56,6 +58,8 @@
#include <complex.h>
#endif
+#include <stdarg.h>
+
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/ports.h"
@@ -81,6 +85,9 @@
#define M_PI 3.14159265358979323846
#endif
+/* FIXME: We assume that FLT_RADIX is 2 */
+verify (FLT_RADIX == 2);
+
typedef scm_t_signed_bits scm_t_inum;
#define scm_from_inum(x) (scm_from_signed_integer (x))
@@ -93,6 +100,31 @@ typedef scm_t_signed_bits scm_t_inum;
#define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
#define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
+
+#if ! HAVE_DECL_MPZ_INITS
+
+/* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
+
+#define VARARG_MPZ_ITERATOR(func) \
+ static void \
+ func ## s (mpz_t x, ...) \
+ { \
+ va_list ap; \
+ \
+ va_start (ap, x); \
+ while (x != NULL) \
+ { \
+ func (x); \
+ x = va_arg (ap, mpz_ptr); \
+ } \
+ va_end (ap); \
+ }
+
+VARARG_MPZ_ITERATOR (mpz_init)
+VARARG_MPZ_ITERATOR (mpz_clear)
+
+#endif
+
/*
@@ -327,81 +359,52 @@ scm_i_dbl2num (double u)
return scm_i_dbl2big (u);
}
-/* scm_i_big2dbl() rounds to the closest representable double, in accordance
- with R5RS exact->inexact.
-
- The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
- (ie. truncate towards zero), then adjust to get the closest double by
- examining the next lower bit and adding 1 (to the absolute value) if
- necessary.
-
- Bignums exactly half way between representable doubles are rounded to the
- next higher absolute value (ie. away from zero). This seems like an
- adequate interpretation of R5RS "numerically closest", and it's easier
- and faster than a full "nearest-even" style.
+static SCM round_right_shift_exact_integer (SCM n, long count);
- The bit test must be done on the absolute value of the mpz_t, which means
- we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
- negatives as twos complement.
+/* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
+ bignum b into a normalized significand and exponent such that
+ b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
+ The return value is the significand rounded to the closest
+ representable double, and the exponent is placed into *expon_p.
+ If b is zero, then the returned exponent and significand are both
+ zero. */
- In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
- following the hardware rounding mode, but applied to the absolute
- value of the mpz_t operand. This is not what we want so we put the
- high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
- (released in March 2006) mpz_get_d now always truncates towards zero.
-
- ENHANCE-ME: The temporary init+clear to force the rounding in GMP
- before 4.2 is a slowdown. It'd be faster to pick out the relevant
- high bits with mpz_getlimbn. */
-
-double
-scm_i_big2dbl (SCM b)
+static double
+scm_i_big2dbl_2exp (SCM b, long *expon_p)
{
- double result;
- size_t bits;
-
- bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
-
-#if 1
- {
- /* For GMP earlier than 4.2, force truncation towards zero */
-
- /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
- _not_ the number of bits, so this code will break badly on a
- system with non-binary doubles. */
-
- mpz_t tmp;
- if (bits > DBL_MANT_DIG)
- {
- size_t shift = bits - DBL_MANT_DIG;
- mpz_init2 (tmp, DBL_MANT_DIG);
- mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
- result = ldexp (mpz_get_d (tmp), shift);
- mpz_clear (tmp);
- }
- else
- {
- result = mpz_get_d (SCM_I_BIG_MPZ (b));
- }
- }
-#else
- /* GMP 4.2 or later */
- result = mpz_get_d (SCM_I_BIG_MPZ (b));
-#endif
+ size_t bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
+ size_t shift = 0;
if (bits > DBL_MANT_DIG)
{
- unsigned long pos = bits - DBL_MANT_DIG - 1;
- /* test bit number "pos" in absolute value */
- if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
- & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
+ shift = bits - DBL_MANT_DIG;
+ b = round_right_shift_exact_integer (b, shift);
+ if (SCM_I_INUMP (b))
{
- result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
+ int expon;
+ double signif = frexp (SCM_I_INUM (b), &expon);
+ *expon_p = expon + shift;
+ return signif;
}
}
- scm_remember_upto_here_1 (b);
- return result;
+ {
+ long expon;
+ double signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b));
+ scm_remember_upto_here_1 (b);
+ *expon_p = expon + shift;
+ return signif;
+ }
+}
+
+/* scm_i_big2dbl() rounds to the closest representable double,
+ in accordance with R5RS exact->inexact. */
+double
+scm_i_big2dbl (SCM b)
+{
+ long expon;
+ double signif = scm_i_big2dbl_2exp (b, &expon);
+ return ldexp (signif, expon);
}
SCM
@@ -436,107 +439,212 @@ scm_i_mpz2num (mpz_t b)
}
}
-/* this is needed when we want scm_divide to make a float, not a ratio, even
if passed two ints */
-static SCM scm_divide2real (SCM x, SCM y);
-
+/* Make the ratio NUMERATOR/DENOMINATOR, where:
+ 1. NUMERATOR and DENOMINATOR are exact integers
+ 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
static SCM
-scm_i_make_ratio (SCM numerator, SCM denominator)
-#define FUNC_NAME "make-ratio"
+scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator)
{
- /* First make sure the arguments are proper.
- */
- if (SCM_I_INUMP (denominator))
+ /* Flip signs so that the denominator is positive. */
+ if (scm_is_false (scm_positive_p (denominator)))
{
- if (scm_is_eq (denominator, SCM_INUM0))
+ if (SCM_UNLIKELY (scm_is_eq (denominator, SCM_INUM0)))
scm_num_overflow ("make-ratio");
- if (scm_is_eq (denominator, SCM_INUM1))
- return numerator;
- }
- else
- {
- if (!(SCM_BIGP(denominator)))
- SCM_WRONG_TYPE_ARG (2, denominator);
+ else
+ {
+ numerator = scm_difference (numerator, SCM_UNDEFINED);
+ denominator = scm_difference (denominator, SCM_UNDEFINED);
+ }
}
- if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator))
- SCM_WRONG_TYPE_ARG (1, numerator);
- /* Then flip signs so that the denominator is positive.
- */
- if (scm_is_true (scm_negative_p (denominator)))
- {
- numerator = scm_difference (numerator, SCM_UNDEFINED);
- denominator = scm_difference (denominator, SCM_UNDEFINED);
- }
+ /* Check for the integer case */
+ if (scm_is_eq (denominator, SCM_INUM1))
+ return numerator;
- /* Now consider for each of the four fixnum/bignum combinations
- whether the rational number is really an integer.
- */
- if (SCM_I_INUMP (numerator))
+ return scm_double_cell (scm_tc16_fraction,
+ SCM_UNPACK (numerator),
+ SCM_UNPACK (denominator), 0);
+}
+
+static SCM scm_exact_integer_quotient (SCM x, SCM y);
+
+/* Make the ratio NUMERATOR/DENOMINATOR */
+static SCM
+scm_i_make_ratio (SCM numerator, SCM denominator)
+#define FUNC_NAME "make-ratio"
+{
+ /* Make sure the arguments are proper */
+ if (!SCM_LIKELY (SCM_I_INUMP (numerator) || SCM_BIGP (numerator)))
+ SCM_WRONG_TYPE_ARG (1, numerator);
+ else if (!SCM_LIKELY (SCM_I_INUMP (denominator) || SCM_BIGP (denominator)))
+ SCM_WRONG_TYPE_ARG (2, denominator);
+ else
{
- scm_t_inum x = SCM_I_INUM (numerator);
- if (scm_is_eq (numerator, SCM_INUM0))
- return SCM_INUM0;
- if (SCM_I_INUMP (denominator))
+ SCM the_gcd = scm_gcd (numerator, denominator);
+ if (!(scm_is_eq (the_gcd, SCM_INUM1)))
{
- scm_t_inum y;
- y = SCM_I_INUM (denominator);
- if (x == y)
- return SCM_INUM1;
- if ((x % y) == 0)
- return SCM_I_MAKINUM (x / y);
+ /* Reduce to lowest terms */
+ numerator = scm_exact_integer_quotient (numerator, the_gcd);
+ denominator = scm_exact_integer_quotient (denominator, the_gcd);
}
- else
- {
- /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
- of that value for the denominator, as a bignum. Apart from
- that case, abs(bignum) > abs(inum) so inum/bignum is not an
- integer. */
- if (x == SCM_MOST_NEGATIVE_FIXNUM
- && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator),
- - SCM_MOST_NEGATIVE_FIXNUM) == 0)
- return SCM_I_MAKINUM(-1);
- }
+ return scm_i_make_ratio_already_reduced (numerator, denominator);
}
- else if (SCM_BIGP (numerator))
+}
+#undef FUNC_NAME
+
+static mpz_t scm_i_divide2double_lo2b;
+
+/* Return the double that is closest to the exact rational N/D, with
+ ties rounded toward even mantissas. N and D must be exact
+ integers. */
+static double
+scm_i_divide2double (SCM n, SCM d)
+{
+ int neg;
+ mpz_t nn, dd, lo, hi, x;
+ ssize_t e;
+
+ if (SCM_LIKELY (SCM_I_INUMP (d)))
{
- if (SCM_I_INUMP (denominator))
- {
- scm_t_inum yy = SCM_I_INUM (denominator);
- if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
- return scm_divide (numerator, denominator);
- }
- else
- {
- if (scm_is_eq (numerator, denominator))
- return SCM_INUM1;
- if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
- SCM_I_BIG_MPZ (denominator)))
- return scm_divide(numerator, denominator);
- }
+ if (SCM_LIKELY (SCM_I_INUMP (n)
+ && (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG
+ || (SCM_I_INUM (n) < (1L << DBL_MANT_DIG)
+ && SCM_I_INUM (d) < (1L << DBL_MANT_DIG)))))
+ /* If both N and D can be losslessly converted to doubles, then
+ we can rely on IEEE floating point to do proper rounding much
+ faster than we can. */
+ return ((double) SCM_I_INUM (n)) / ((double) SCM_I_INUM (d));
+
+ if (SCM_UNLIKELY (scm_is_eq (d, SCM_INUM0)))
+ {
+ if (scm_is_true (scm_positive_p (n)))
+ return 1.0 / 0.0;
+ else if (scm_is_true (scm_negative_p (n)))
+ return -1.0 / 0.0;
+ else
+ return 0.0 / 0.0;
+ }
+
+ mpz_init_set_si (dd, SCM_I_INUM (d));
}
+ else
+ mpz_init_set (dd, SCM_I_BIG_MPZ (d));
- /* No, it's a proper fraction.
- */
+ if (SCM_I_INUMP (n))
+ mpz_init_set_si (nn, SCM_I_INUM (n));
+ else
+ mpz_init_set (nn, SCM_I_BIG_MPZ (n));
+
+ neg = (mpz_sgn (nn) < 0) ^ (mpz_sgn (dd) < 0);
+ mpz_abs (nn, nn);
+ mpz_abs (dd, dd);
+
+ /* Now we need to find the value of e such that:
+
+ For e <= 0:
+ b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
+ (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
+ (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
+
+ For e >= 0:
+ b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
+ (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
+ (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
+
+ where: p = DBL_MANT_DIG
+ b = FLT_RADIX (here assumed to be 2)
+
+ After rounding, the mantissa must be an integer between b^{p-1} and
+ (b^p - 1), except for subnormal numbers. In the inequations [1A]
+ and [1B], the middle expression represents the mantissa *before*
+ rounding, and therefore is bounded by the range of values that will
+ round to a floating-point number with the exponent e. The upper
+ bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
+ ties will round up to the next power of b. The lower bound is
+ (b^{p-1} - 1/2b), and is inclusive because ties will round toward
+ this power of b. Here we subtract 1/2b instead of 1/2 because it
+ is in the range of the next smaller exponent, where the
+ representable numbers are closer together by a factor of b.
+
+ Inequations [2A] and [2B] are derived from [1A] and [1B] by
+ multiplying by 2b, and in [3A] and [3B] we multiply by the
+ denominator of the middle value to obtain integer expressions.
+
+ In the code below, we refer to the three expressions in [3A] or
+ [3B] as lo, x, and hi. If the number is normalizable, we will
+ achieve the goal: lo <= x < hi */
+
+ /* Make an initial guess for e */
+ e = mpz_sizeinbase (nn, 2) - mpz_sizeinbase (dd, 2) - (DBL_MANT_DIG-1);
+ if (e < DBL_MIN_EXP - DBL_MANT_DIG)
+ e = DBL_MIN_EXP - DBL_MANT_DIG;
+
+ /* Compute the initial values of lo, x, and hi
+ based on the initial guess of e */
+ mpz_inits (lo, hi, x, NULL);
+ mpz_mul_2exp (x, nn, 2 + ((e < 0) ? -e : 0));
+ mpz_mul (lo, dd, scm_i_divide2double_lo2b);
+ if (e > 0)
+ mpz_mul_2exp (lo, lo, e);
+ mpz_mul_2exp (hi, lo, 1);
+
+ /* Adjust e as needed to satisfy the inequality lo <= x < hi,
+ (but without making e less then the minimum exponent) */
+ while (mpz_cmp (x, lo) < 0 && e > DBL_MIN_EXP - DBL_MANT_DIG)
+ {
+ mpz_mul_2exp (x, x, 1);
+ e--;
+ }
+ while (mpz_cmp (x, hi) >= 0)
+ {
+ /* If we ever used lo's value again,
+ we would need to double lo here. */
+ mpz_mul_2exp (hi, hi, 1);
+ e++;
+ }
+
+ /* Now compute the rounded mantissa:
+ n / b^e d (if e >= 0)
+ n b^-e / d (if e <= 0) */
{
- SCM divisor = scm_gcd (numerator, denominator);
- if (!(scm_is_eq (divisor, SCM_INUM1)))
- {
- numerator = scm_divide (numerator, divisor);
- denominator = scm_divide (denominator, divisor);
- }
-
- return scm_double_cell (scm_tc16_fraction,
- SCM_UNPACK (numerator),
- SCM_UNPACK (denominator), 0);
+ int cmp;
+ double result;
+
+ if (e < 0)
+ mpz_mul_2exp (nn, nn, -e);
+ else
+ mpz_mul_2exp (dd, dd, e);
+
+ /* mpz does not directly support rounded right
+ shifts, so we have to do it the hard way.
+ For efficiency, we reuse lo and hi.
+ hi == quotient, lo == remainder */
+ mpz_fdiv_qr (hi, lo, nn, dd);
+
+ /* The fractional part of the unrounded mantissa would be
+ remainder/dividend, i.e. lo/dd. So we have a tie if
+ lo/dd = 1/2. Multiplying both sides by 2*dd yields the
+ integer expression 2*lo = dd. Here we do that comparison
+ to decide whether to round up or down. */
+ mpz_mul_2exp (lo, lo, 1);
+ cmp = mpz_cmp (lo, dd);
+ if (cmp > 0 || (cmp == 0 && mpz_odd_p (hi)))
+ mpz_add_ui (hi, hi, 1);
+
+ result = ldexp (mpz_get_d (hi), e);
+ if (neg)
+ result = -result;
+
+ mpz_clears (nn, dd, lo, hi, x, NULL);
+ return result;
}
}
-#undef FUNC_NAME
double
scm_i_fraction2double (SCM z)
{
- return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
- SCM_FRACTION_DENOMINATOR (z)));
+ return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z),
+ SCM_FRACTION_DENOMINATOR (z));
}
static int
@@ -820,8 +928,9 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
return x;
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (x));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
}
else
return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
@@ -889,6 +998,84 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
}
#undef FUNC_NAME
+/* Return the exact integer q such that n = q*d, for exact integers n
+ and d, where d is known in advance to divide n evenly (with zero
+ remainder). For large integers, this can be computed more
+ efficiently than when the remainder is unknown. */
+static SCM
+scm_exact_integer_quotient (SCM n, SCM d)
+#define FUNC_NAME "exact-integer-quotient"
+{
+ if (SCM_LIKELY (SCM_I_INUMP (n)))
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+ if (SCM_LIKELY (SCM_I_INUMP (d)))
+ {
+ scm_t_inum dd = SCM_I_INUM (d);
+ if (SCM_UNLIKELY (dd == 0))
+ scm_num_overflow ("exact-integer-quotient");
+ else
+ {
+ scm_t_inum qq = nn / dd;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_LIKELY (SCM_BIGP (d)))
+ {
+ /* n is an inum and d is a bignum. Given that d is known to
+ divide n evenly, there are only two possibilities: n is 0,
+ or else n is fixnum-min and d is abs(fixnum-min). */
+ if (nn == 0)
+ return SCM_INUM0;
+ else
+ return SCM_I_MAKINUM (-1);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (2, d);
+ }
+ else if (SCM_LIKELY (SCM_BIGP (n)))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (d)))
+ {
+ scm_t_inum dd = SCM_I_INUM (d);
+ if (SCM_UNLIKELY (dd == 0))
+ scm_num_overflow ("exact-integer-quotient");
+ else if (SCM_UNLIKELY (dd == 1))
+ return n;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (dd > 0)
+ mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), dd);
+ else
+ {
+ mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), -dd);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (n);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_LIKELY (SCM_BIGP (d)))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_divexact (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (n),
+ SCM_I_BIG_MPZ (d));
+ scm_remember_upto_here_2 (n, d);
+ return scm_i_normbig (q);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (2, d);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
+}
+#undef FUNC_NAME
+
/* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
two-valued functions. It is called from primitive generics that take
two arguments and return two values, when the core procedure is
@@ -3888,52 +4075,58 @@ SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
SCM
scm_gcd (SCM x, SCM y)
{
- if (SCM_UNBNDP (y))
+ if (SCM_UNLIKELY (SCM_UNBNDP (y)))
return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x);
- if (SCM_I_INUMP (x))
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
{
- if (SCM_I_INUMP (y))
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
{
scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum yy = SCM_I_INUM (y);
scm_t_inum u = xx < 0 ? -xx : xx;
scm_t_inum v = yy < 0 ? -yy : yy;
scm_t_inum result;
- if (xx == 0)
+ if (SCM_UNLIKELY (xx == 0))
result = v;
- else if (yy == 0)
+ else if (SCM_UNLIKELY (yy == 0))
result = u;
else
{
- scm_t_inum k = 1;
- scm_t_inum t;
+ int k = 0;
/* Determine a common factor 2^k */
- while (!(1 & (u | v)))
+ while (((u | v) & 1) == 0)
{
- k <<= 1;
+ k++;
u >>= 1;
v >>= 1;
}
/* Now, any factor 2^n can be eliminated */
- if (u & 1)
- t = -v;
+ if ((u & 1) == 0)
+ while ((u & 1) == 0)
+ u >>= 1;
else
+ while ((v & 1) == 0)
+ v >>= 1;
+ /* Both u and v are now odd. Subtract the smaller one
+ from the larger one to produce an even number, remove
+ more factors of two, and repeat. */
+ while (u != v)
{
- t = u;
- b3:
- t = SCM_SRS (t, 1);
+ if (u > v)
+ {
+ u -= v;
+ while ((u & 1) == 0)
+ u >>= 1;
+ }
+ else
+ {
+ v -= u;
+ while ((v & 1) == 0)
+ v >>= 1;
+ }
}
- if (!(1 & t))
- goto b3;
- if (t > 0)
- u = t;
- else
- v = -t;
- t = u - v;
- if (t != 0)
- goto b3;
- result = u * k;
+ result = u << k;
}
return (SCM_POSFIXABLE (result)
? SCM_I_MAKINUM (result)
@@ -4666,6 +4859,26 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
else /* return NaN for (0 ^ k) for negative k per R6RS */
return scm_nan ();
}
+ else if (SCM_FRACTIONP (n))
+ {
+ /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
+ needless reduction of intermediate products to lowest terms.
+ If a and b have no common factors, then a^k and b^k have no
+ common factors. Use 'scm_i_make_ratio_already_reduced' to
+ construct the final result, so that no gcd computations are
+ needed to exponentiate a fraction. */
+ if (scm_is_true (scm_positive_p (k)))
+ return scm_i_make_ratio_already_reduced
+ (scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k),
+ scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k));
+ else
+ {
+ k = scm_difference (k, SCM_UNDEFINED);
+ return scm_i_make_ratio_already_reduced
+ (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k),
+ scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k));
+ }
+ }
if (SCM_I_INUMP (k))
i2 = SCM_I_INUM (k);
@@ -4723,19 +4936,119 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
}
#undef FUNC_NAME
+/* Efficiently compute (N * 2^COUNT),
+ where N is an exact integer, and COUNT > 0. */
+static SCM
+left_shift_exact_integer (SCM n, long count)
+{
+ if (SCM_I_INUMP (n))
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+
+ /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
+ overflow a non-zero fixnum. For smaller shifts we check the
+ bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
+ all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
+ Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
+
+ if (nn == 0)
+ return n;
+ else if (count < SCM_I_FIXNUM_BIT-1 &&
+ ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1)
+ <= 1))
+ return SCM_I_MAKINUM (nn << count);
+ else
+ {
+ SCM result = scm_i_inum2big (nn);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
+ count);
+ return result;
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), count);
+ scm_remember_upto_here_1 (n);
+ return result;
+ }
+ else
+ scm_syserror ("left_shift_exact_integer");
+}
+
+/* Efficiently compute floor (N / 2^COUNT),
+ where N is an exact integer and COUNT > 0. */
+static SCM
+floor_right_shift_exact_integer (SCM n, long count)
+{
+ if (SCM_I_INUMP (n))
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+
+ if (count >= SCM_I_FIXNUM_BIT)
+ return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1));
+ else
+ return SCM_I_MAKINUM (SCM_SRS (nn, count));
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
+ count);
+ scm_remember_upto_here_1 (n);
+ return scm_i_normbig (result);
+ }
+ else
+ scm_syserror ("floor_right_shift_exact_integer");
+}
+
+/* Efficiently compute round (N / 2^COUNT),
+ where N is an exact integer and COUNT > 0. */
+static SCM
+round_right_shift_exact_integer (SCM n, long count)
+{
+ if (SCM_I_INUMP (n))
+ {
+ if (count >= SCM_I_FIXNUM_BIT)
+ return SCM_INUM0;
+ else
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+ scm_t_inum qq = SCM_SRS (nn, count);
+
+ if (0 == (nn & (1L << (count-1))))
+ return SCM_I_MAKINUM (qq); /* round down */
+ else if (nn & ((1L << (count-1)) - 1))
+ return SCM_I_MAKINUM (qq + 1); /* round up */
+ else
+ return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM q = scm_i_mkbig ();
+
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count);
+ if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1)
+ && (mpz_odd_p (SCM_I_BIG_MPZ (q))
+ || (mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1)))
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ scm_remember_upto_here_1 (n);
+ return scm_i_normbig (q);
+ }
+ else
+ scm_syserror ("round_right_shift_exact_integer");
+}
+
SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
- (SCM n, SCM cnt),
- "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
- "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
- "\n"
- "This is effectively a multiplication by address@hidden, and when\n"
- "@var{cnt} is negative it's a division, rounded towards negative\n"
- "infinity. (Note that this is not the same rounding as\n"
- "@code{quotient} does.)\n"
+ (SCM n, SCM count),
+ "Return @math{floor(@var{n} * address@hidden)}.\n"
+ "@var{n} and @var{count} must be exact integers.\n"
"\n"
- "With @var{n} viewed as an infinite precision twos complement,\n"
- "@code{ash} means a left shift introducing zero bits, or a right\n"
- "shift dropping bits.\n"
+ "With @var{n} viewed as an infinite-precision twos-complement\n"
+ "integer, @code{ash} means a left shift introducing zero bits\n"
+ "when @var{count} is positive, or a right shift dropping bits\n"
+ "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
"\n"
"@lisp\n"
"(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
@@ -4746,79 +5059,57 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_ash
{
- long bits_to_shift;
- bits_to_shift = scm_to_long (cnt);
-
- if (SCM_I_INUMP (n))
+ if (SCM_I_INUMP (n) || SCM_BIGP (n))
{
- scm_t_inum nn = SCM_I_INUM (n);
+ long bits_to_shift = scm_to_long (count);
if (bits_to_shift > 0)
- {
- /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
- overflow a non-zero fixnum. For smaller shifts we check the
- bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
- all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
- Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
- bits_to_shift)". */
-
- if (nn == 0)
- return n;
-
- if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((scm_t_bits)
- (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
- <= 1))
- {
- return SCM_I_MAKINUM (nn << bits_to_shift);
- }
- else
- {
- SCM result = scm_i_inum2big (nn);
- mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
- bits_to_shift);
- return result;
- }
- }
+ return left_shift_exact_integer (n, bits_to_shift);
+ else if (SCM_LIKELY (bits_to_shift < 0))
+ return floor_right_shift_exact_integer (n, -bits_to_shift);
else
- {
- bits_to_shift = -bits_to_shift;
- if (bits_to_shift >= SCM_LONG_BIT)
- return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1));
- else
- return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift));
- }
-
+ return n;
}
- else if (SCM_BIGP (n))
- {
- SCM result;
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
- if (bits_to_shift == 0)
- return n;
+SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
+ (SCM n, SCM count),
+ "Return @math{round(@var{n} * address@hidden)}.\n"
+ "@var{n} and @var{count} must be exact integers.\n"
+ "\n"
+ "With @var{n} viewed as an infinite-precision twos-complement\n"
+ "integer, @code{round-ash} means a left shift introducing zero\n"
+ "bits when @var{count} is positive, or a right shift rounding\n"
+ "to the nearest integer (with ties going to the nearest even\n"
+ "integer) when @var{count} is negative. This is a rounded\n"
+ "``arithmetic'' shift.\n"
+ "\n"
+ "@lisp\n"
+ "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
+ "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
+ "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
+ "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
+ "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
+ "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_ash
+{
+ if (SCM_I_INUMP (n) || SCM_BIGP (n))
+ {
+ long bits_to_shift = scm_to_long (count);
- result = scm_i_mkbig ();
- if (bits_to_shift >= 0)
- {
- mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
- bits_to_shift);
- return result;
- }
+ if (bits_to_shift > 0)
+ return left_shift_exact_integer (n, bits_to_shift);
+ else if (SCM_LIKELY (bits_to_shift < 0))
+ return round_right_shift_exact_integer (n, -bits_to_shift);
else
- {
- /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
- we have to allocate a bignum even if the result is going to be a
- fixnum. */
- mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
- -bits_to_shift);
- return scm_i_normbig (result);
- }
-
+ return n;
}
else
- {
- SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
- }
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
}
#undef FUNC_NAME
@@ -4998,220 +5289,230 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1,
0, 0,
#undef FUNC_NAME
/*** NUMBERS -> STRINGS ***/
-#define SCM_MAX_DBL_PREC 60
#define SCM_MAX_DBL_RADIX 36
-/* this is an array starting with radix 2, and ending with radix
SCM_MAX_DBL_RADIX */
-static int scm_dblprec[SCM_MAX_DBL_RADIX - 1];
-static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC];
-
-static
-void init_dblprec(int *prec, int radix) {
- /* determine floating point precision by adding successively
- smaller increments to 1.0 until it is considered == 1.0 */
- double f = ((double)1.0)/radix;
- double fsum = 1.0 + f;
-
- *prec = 0;
- while (fsum != 1.0)
- {
- if (++(*prec) > SCM_MAX_DBL_PREC)
- fsum = 1.0;
- else
- {
- f /= radix;
- fsum = f + 1.0;
- }
- }
- (*prec) -= 1;
-}
-
-static
-void init_fx_radix(double *fx_list, int radix)
-{
- /* initialize a per-radix list of tolerances. When added
- to a number < 1.0, we can determine if we should raund
- up and quit converting a number to a string. */
- int i;
- fx_list[0] = 0.0;
- fx_list[1] = 0.5;
- for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i )
- fx_list[i] = (fx_list[i-1] / radix);
-}
-
/* use this array as a way to generate a single digit */
static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
+static mpz_t dbl_minimum_normal_mantissa;
+
static size_t
-idbl2str (double f, char *a, int radix)
+idbl2str (double dbl, char *a, int radix)
{
- int efmt, dpt, d, i, wp;
- double *fx;
-#ifdef DBL_MIN_10_EXP
- double f_cpy;
- int exp_cpy;
-#endif /* DBL_MIN_10_EXP */
- size_t ch = 0;
- int exp = 0;
-
- if(radix < 2 ||
- radix > SCM_MAX_DBL_RADIX)
- {
- /* revert to existing behavior */
- radix = 10;
- }
+ int ch = 0;
- wp = scm_dblprec[radix-2];
- fx = fx_per_radix[radix-2];
+ if (radix < 2 || radix > SCM_MAX_DBL_RADIX)
+ /* revert to existing behavior */
+ radix = 10;
- if (f == 0.0)
+ if (isinf (dbl))
{
-#ifdef HAVE_COPYSIGN
- double sgn = copysign (1.0, f);
-
- if (sgn < 0.0)
- a[ch++] = '-';
-#endif
- goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
+ strcpy (a, (dbl > 0.0) ? "+inf.0" : "-inf.0");
+ return 6;
}
-
- if (isinf (f))
+ else if (dbl > 0.0)
+ ;
+ else if (dbl < 0.0)
{
- if (f < 0)
- strcpy (a, "-inf.0");
- else
- strcpy (a, "+inf.0");
- return ch+6;
+ dbl = -dbl;
+ a[ch++] = '-';
}
- else if (isnan (f))
+ else if (dbl == 0.0)
{
- strcpy (a, "+nan.0");
- return ch+6;
+ if (!double_is_non_negative_zero (dbl))
+ a[ch++] = '-';
+ strcpy (a + ch, "0.0");
+ return ch + 3;
}
-
- if (f < 0.0)
+ else if (isnan (dbl))
{
- f = -f;
- a[ch++] = '-';
+ strcpy (a, "+nan.0");
+ return 6;
}
-#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
- make-uniform-vector, from causing infinite loops. */
- /* just do the checking...if it passes, we do the conversion for our
- radix again below */
- f_cpy = f;
- exp_cpy = exp;
+ /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
+ Accurately" by Robert G. Burger and R. Kent Dybvig */
+ {
+ int e, k;
+ mpz_t f, r, s, mplus, mminus, hi, digit;
+ int f_is_even, f_is_odd;
+ int expon;
+ int show_exp = 0;
+
+ mpz_inits (f, r, s, mplus, mminus, hi, digit, NULL);
+ mpz_set_d (f, ldexp (frexp (dbl, &e), DBL_MANT_DIG));
+ if (e < DBL_MIN_EXP)
+ {
+ mpz_tdiv_q_2exp (f, f, DBL_MIN_EXP - e);
+ e = DBL_MIN_EXP;
+ }
+ e -= DBL_MANT_DIG;
- while (f_cpy < 1.0)
- {
- f_cpy *= 10.0;
- if (exp_cpy-- < DBL_MIN_10_EXP)
- {
- a[ch++] = '#';
- a[ch++] = '.';
- a[ch++] = '#';
- return ch;
- }
- }
- while (f_cpy > 10.0)
- {
- f_cpy *= 0.10;
- if (exp_cpy++ > DBL_MAX_10_EXP)
- {
- a[ch++] = '#';
- a[ch++] = '.';
- a[ch++] = '#';
- return ch;
- }
- }
-#endif
+ f_is_even = !mpz_odd_p (f);
+ f_is_odd = !f_is_even;
- while (f < 1.0)
- {
- f *= radix;
- exp--;
- }
- while (f > radix)
- {
- f /= radix;
- exp++;
- }
+ /* Initialize r, s, mplus, and mminus according
+ to Table 1 from the paper. */
+ if (e < 0)
+ {
+ mpz_set_ui (mminus, 1);
+ if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0
+ || e == DBL_MIN_EXP - DBL_MANT_DIG)
+ {
+ mpz_set_ui (mplus, 1);
+ mpz_mul_2exp (r, f, 1);
+ mpz_mul_2exp (s, mminus, 1 - e);
+ }
+ else
+ {
+ mpz_set_ui (mplus, 2);
+ mpz_mul_2exp (r, f, 2);
+ mpz_mul_2exp (s, mminus, 2 - e);
+ }
+ }
+ else
+ {
+ mpz_set_ui (mminus, 1);
+ mpz_mul_2exp (mminus, mminus, e);
+ if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0)
+ {
+ mpz_set (mplus, mminus);
+ mpz_mul_2exp (r, f, 1 + e);
+ mpz_set_ui (s, 2);
+ }
+ else
+ {
+ mpz_mul_2exp (mplus, mminus, 1);
+ mpz_mul_2exp (r, f, 2 + e);
+ mpz_set_ui (s, 4);
+ }
+ }
- if (f + fx[wp] >= radix)
- {
- f = 1.0;
- exp++;
- }
- zero:
- efmt = (exp < -3) || (exp > wp + 2);
- if (!efmt)
+ /* Find the smallest k such that:
+ (r + mplus) / s < radix^k (if f is even)
+ (r + mplus) / s <= radix^k (if f is odd) */
{
- if (exp < 0)
- {
- a[ch++] = '0';
- a[ch++] = '.';
- dpt = exp;
- while (++dpt)
- a[ch++] = '0';
- }
- else
- dpt = exp + 1;
+ /* IMPROVE-ME: Make an initial guess to speed this up */
+ mpz_add (hi, r, mplus);
+ k = 0;
+ while (mpz_cmp (hi, s) >= f_is_odd)
+ {
+ mpz_mul_ui (s, s, radix);
+ k++;
+ }
+ if (k == 0)
+ {
+ mpz_mul_ui (hi, hi, radix);
+ while (mpz_cmp (hi, s) < f_is_odd)
+ {
+ mpz_mul_ui (r, r, radix);
+ mpz_mul_ui (mplus, mplus, radix);
+ mpz_mul_ui (mminus, mminus, radix);
+ mpz_mul_ui (hi, hi, radix);
+ k--;
+ }
+ }
}
- else
- dpt = 1;
- do
- {
- d = f;
- f -= d;
- a[ch++] = number_chars[d];
- if (f < fx[wp])
- break;
- if (f + fx[wp] >= 1.0)
- {
- a[ch - 1] = number_chars[d+1];
- break;
- }
- f *= radix;
- if (!(--dpt))
- a[ch++] = '.';
- }
- while (wp--);
+ expon = k - 1;
+ if (k <= 0)
+ {
+ if (k <= -3)
+ {
+ /* Use scientific notation */
+ show_exp = 1;
+ k = 1;
+ }
+ else
+ {
+ int i;
- if (dpt > 0)
- {
- if ((dpt > 4) && (exp > 6))
- {
- d = (a[0] == '-' ? 2 : 1);
- for (i = ch++; i > d; i--)
- a[i] = a[i - 1];
- a[d] = '.';
- efmt = 1;
- }
- else
- {
- while (--dpt)
- a[ch++] = '0';
- a[ch++] = '.';
- }
- }
- if (a[ch - 1] == '.')
- a[ch++] = '0'; /* trailing zero */
- if (efmt && exp)
- {
- a[ch++] = 'e';
- if (exp < 0)
- {
- exp = -exp;
- a[ch++] = '-';
- }
- for (i = radix; i <= exp; i *= radix);
- for (i /= radix; i; i /= radix)
- {
- a[ch++] = number_chars[exp / i];
- exp %= i;
- }
- }
+ /* Print leading zeroes */
+ a[ch++] = '0';
+ a[ch++] = '.';
+ for (i = 0; i > k; i--)
+ a[ch++] = '0';
+ }
+ }
+
+ for (;;)
+ {
+ int end_1_p, end_2_p;
+ int d;
+
+ mpz_mul_ui (mplus, mplus, radix);
+ mpz_mul_ui (mminus, mminus, radix);
+ mpz_mul_ui (r, r, radix);
+ mpz_fdiv_qr (digit, r, r, s);
+ d = mpz_get_ui (digit);
+
+ mpz_add (hi, r, mplus);
+ end_1_p = (mpz_cmp (r, mminus) < f_is_even);
+ end_2_p = (mpz_cmp (s, hi) < f_is_even);
+ if (end_1_p || end_2_p)
+ {
+ mpz_mul_2exp (r, r, 1);
+ if (!end_2_p)
+ ;
+ else if (!end_1_p)
+ d++;
+ else if (mpz_cmp (r, s) >= !(d & 1))
+ d++;
+ a[ch++] = number_chars[d];
+ if (--k == 0)
+ a[ch++] = '.';
+ break;
+ }
+ else
+ {
+ a[ch++] = number_chars[d];
+ if (--k == 0)
+ a[ch++] = '.';
+ }
+ }
+
+ if (k > 0)
+ {
+ if (expon >= 7 && k >= 4 && expon >= k)
+ {
+ /* Here we would have to print more than three zeroes
+ followed by a decimal point and another zero. It
+ makes more sense to use scientific notation. */
+
+ /* Adjust k to what it would have been if we had chosen
+ scientific notation from the beginning. */
+ k -= expon;
+
+ /* k will now be <= 0, with magnitude equal to the number of
+ digits that we printed which should now be put after the
+ decimal point. */
+
+ /* Insert a decimal point */
+ memmove (a + ch + k + 1, a + ch + k, -k);
+ a[ch + k] = '.';
+ ch++;
+
+ show_exp = 1;
+ }
+ else
+ {
+ for (; k > 0; k--)
+ a[ch++] = '0';
+ a[ch++] = '.';
+ }
+ }
+
+ if (k == 0)
+ a[ch++] = '0';
+
+ if (show_exp)
+ {
+ a[ch++] = 'e';
+ ch += scm_iint2str (expon, radix, a + ch);
+ }
+
+ mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL);
+ }
return ch;
}
@@ -5695,7 +5996,7 @@ mem2decimal_from_point (SCM result, SCM mem,
break;
}
- if (exponent > SCM_MAXEXP)
+ if (exponent > ((sign == 1) ? SCM_MAXEXP : SCM_MAXEXP + DBL_DIG + 1))
{
size_t exp_len = idx - start;
SCM exp_string = scm_i_substring_copy (mem, start, start +
exp_len);
@@ -5731,7 +6032,8 @@ mem2decimal_from_point (SCM result, SCM mem,
static SCM
mem2ureal (SCM mem, unsigned int *p_idx,
- unsigned int radix, enum t_exactness forced_x)
+ unsigned int radix, enum t_exactness forced_x,
+ int allow_inf_or_nan)
{
unsigned int idx = *p_idx;
SCM result;
@@ -5744,30 +6046,53 @@ mem2ureal (SCM mem, unsigned int *p_idx,
if (idx == len)
return SCM_BOOL_F;
- if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0"))
- {
- *p_idx = idx+5;
- return scm_inf ();
- }
-
- if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan."))
- {
- /* Cobble up the fractional part. We might want to set the
- NaN's mantissa from it. */
- idx += 4;
- if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0))
- {
+ if (allow_inf_or_nan && forced_x != EXACT && idx+5 <= len)
+ switch (scm_i_string_ref (mem, idx))
+ {
+ case 'i': case 'I':
+ switch (scm_i_string_ref (mem, idx + 1))
+ {
+ case 'n': case 'N':
+ switch (scm_i_string_ref (mem, idx + 2))
+ {
+ case 'f': case 'F':
+ if (scm_i_string_ref (mem, idx + 3) == '.'
+ && scm_i_string_ref (mem, idx + 4) == '0')
+ {
+ *p_idx = idx+5;
+ return scm_inf ();
+ }
+ }
+ }
+ case 'n': case 'N':
+ switch (scm_i_string_ref (mem, idx + 1))
+ {
+ case 'a': case 'A':
+ switch (scm_i_string_ref (mem, idx + 2))
+ {
+ case 'n': case 'N':
+ if (scm_i_string_ref (mem, idx + 3) == '.')
+ {
+ /* Cobble up the fractional part. We might want to
+ set the NaN's mantissa from it. */
+ idx += 4;
+ if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x),
+ SCM_INUM0))
+ {
#if SCM_ENABLE_DEPRECATED == 1
- scm_c_issue_deprecation_warning
- ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
+ scm_c_issue_deprecation_warning
+ ("Non-zero suffixes to `+nan.' are deprecated. Use
`+nan.0'.");
#else
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
#endif
- }
+ }
- *p_idx = idx;
- return scm_nan ();
- }
+ *p_idx = idx;
+ return scm_nan ();
+ }
+ }
+ }
+ }
if (scm_i_string_ref (mem, idx) == '.')
{
@@ -5800,7 +6125,7 @@ mem2ureal (SCM mem, unsigned int *p_idx,
return SCM_BOOL_F;
divisor = mem2uinteger (mem, &idx, radix, &implicit_x);
- if (scm_is_false (divisor))
+ if (scm_is_false (divisor) || scm_is_eq (divisor, SCM_INUM0))
return SCM_BOOL_F;
/* both are int/big here, I assume */
@@ -5876,7 +6201,7 @@ mem2complex (SCM mem, unsigned int idx,
if (idx == len)
return SCM_BOOL_F;
- ureal = mem2ureal (mem, &idx, radix, forced_x);
+ ureal = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
if (scm_is_false (ureal))
{
/* input must be either +i or -i */
@@ -5945,9 +6270,9 @@ mem2complex (SCM mem, unsigned int idx,
sign = -1;
}
else
- sign = 1;
+ sign = 0;
- angle = mem2ureal (mem, &idx, radix, forced_x);
+ angle = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
if (scm_is_false (angle))
return SCM_BOOL_F;
if (idx != len)
@@ -5969,7 +6294,7 @@ mem2complex (SCM mem, unsigned int idx,
else
{
int sign = (c == '+') ? 1 : -1;
- SCM imag = mem2ureal (mem, &idx, radix, forced_x);
+ SCM imag = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
if (scm_is_false (imag))
imag = SCM_I_MAKINUM (sign);
@@ -7323,8 +7648,9 @@ scm_difference (SCM x, SCM y)
return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
-SCM_COMPLEX_IMAG (x));
else if (SCM_FRACTIONP (x))
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (x));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
else
return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
}
@@ -7850,8 +8176,8 @@ SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
#define s_divide s_scm_i_divide
#define g_divide g_scm_i_divide
-static SCM
-do_divide (SCM x, SCM y, int inexact)
+SCM
+scm_divide (SCM x, SCM y)
#define FUNC_NAME s_divide
{
double a;
@@ -7870,18 +8196,10 @@ do_divide (SCM x, SCM y, int inexact)
scm_num_overflow (s_divide);
#endif
else
- {
- if (inexact)
- return scm_from_double (1.0 / (double) xx);
- else return scm_i_make_ratio (SCM_INUM1, x);
- }
+ return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
}
else if (SCM_BIGP (x))
- {
- if (inexact)
- return scm_from_double (1.0 / scm_i_big2dbl (x));
- else return scm_i_make_ratio (SCM_INUM1, x);
- }
+ return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
else if (SCM_REALP (x))
{
double xx = SCM_REAL_VALUE (x);
@@ -7910,8 +8228,8 @@ do_divide (SCM x, SCM y, int inexact)
}
}
else if (SCM_FRACTIONP (x))
- return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
- SCM_FRACTION_NUMERATOR (x));
+ return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_NUMERATOR (x));
else
return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
}
@@ -7931,11 +8249,7 @@ do_divide (SCM x, SCM y, int inexact)
#endif
}
else if (xx % yy != 0)
- {
- if (inexact)
- return scm_from_double ((double) xx / (double) yy);
- else return scm_i_make_ratio (x, y);
- }
+ return scm_i_make_ratio (x, y);
else
{
scm_t_inum z = xx / yy;
@@ -7946,11 +8260,7 @@ do_divide (SCM x, SCM y, int inexact)
}
}
else if (SCM_BIGP (y))
- {
- if (inexact)
- return scm_from_double ((double) xx / scm_i_big2dbl (y));
- else return scm_i_make_ratio (x, y);
- }
+ return scm_i_make_ratio (x, y);
else if (SCM_REALP (y))
{
double yy = SCM_REAL_VALUE (y);
@@ -7959,6 +8269,9 @@ do_divide (SCM x, SCM y, int inexact)
scm_num_overflow (s_divide);
else
#endif
+ /* FIXME: Precision may be lost here due to:
+ (1) The cast from 'scm_t_inum' to 'double'
+ (2) Double rounding */
return scm_from_double ((double) xx / yy);
}
else if (SCM_COMPLEXP (y))
@@ -7985,7 +8298,7 @@ do_divide (SCM x, SCM y, int inexact)
else if (SCM_FRACTIONP (y))
/* a / b/c = ac / b */
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
- SCM_FRACTION_NUMERATOR (y));
+ SCM_FRACTION_NUMERATOR (y));
else
return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
@@ -8029,43 +8342,24 @@ do_divide (SCM x, SCM y, int inexact)
return scm_i_normbig (result);
}
else
- {
- if (inexact)
- return scm_from_double (scm_i_big2dbl (x) / (double) yy);
- else return scm_i_make_ratio (x, y);
- }
+ return scm_i_make_ratio (x, y);
}
}
else if (SCM_BIGP (y))
{
- /* big_x / big_y */
- if (inexact)
- {
- /* It's easily possible for the ratio x/y to fit a double
- but one or both x and y be too big to fit a double,
- hence the use of mpq_get_d rather than converting and
- dividing. */
- mpq_t q;
- *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
- *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
- return scm_from_double (mpq_get_d (q));
- }
- else
- {
- int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- if (divisible_p)
- {
- SCM result = scm_i_mkbig ();
- mpz_divexact (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (result);
- }
- else
- return scm_i_make_ratio (x, y);
- }
+ int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ if (divisible_p)
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_divexact (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ return scm_i_make_ratio (x, y);
}
else if (SCM_REALP (y))
{
@@ -8075,6 +8369,8 @@ do_divide (SCM x, SCM y, int inexact)
scm_num_overflow (s_divide);
else
#endif
+ /* FIXME: Precision may be lost here due to:
+ (1) scm_i_big2dbl (2) Double rounding */
return scm_from_double (scm_i_big2dbl (x) / yy);
}
else if (SCM_COMPLEXP (y))
@@ -8084,7 +8380,7 @@ do_divide (SCM x, SCM y, int inexact)
}
else if (SCM_FRACTIONP (y))
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
- SCM_FRACTION_NUMERATOR (y));
+ SCM_FRACTION_NUMERATOR (y));
else
return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
@@ -8099,10 +8395,16 @@ do_divide (SCM x, SCM y, int inexact)
scm_num_overflow (s_divide);
else
#endif
+ /* FIXME: Precision may be lost here due to:
+ (1) The cast from 'scm_t_inum' to 'double'
+ (2) Double rounding */
return scm_from_double (rx / (double) yy);
}
else if (SCM_BIGP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from bignum to double
+ (2) Double rounding */
double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
return scm_from_double (rx / dby);
@@ -8140,12 +8442,18 @@ do_divide (SCM x, SCM y, int inexact)
else
#endif
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from 'scm_t_inum' to double
+ (2) Double rounding */
double d = yy;
return scm_c_make_rectangular (rx / d, ix / d);
}
}
else if (SCM_BIGP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from bignum to double
+ (2) Double rounding */
double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
return scm_c_make_rectangular (rx / dby, ix / dby);
@@ -8179,6 +8487,9 @@ do_divide (SCM x, SCM y, int inexact)
}
else if (SCM_FRACTIONP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
double yy = scm_i_fraction2double (y);
return scm_c_make_rectangular (rx / yy, ix / yy);
}
@@ -8196,12 +8507,12 @@ do_divide (SCM x, SCM y, int inexact)
else
#endif
return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
- scm_product (SCM_FRACTION_DENOMINATOR (x),
y));
+ scm_product (SCM_FRACTION_DENOMINATOR
(x), y));
}
else if (SCM_BIGP (y))
{
return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
- scm_product (SCM_FRACTION_DENOMINATOR (x), y));
+ scm_product (SCM_FRACTION_DENOMINATOR (x),
y));
}
else if (SCM_REALP (y))
{
@@ -8211,33 +8522,28 @@ do_divide (SCM x, SCM y, int inexact)
scm_num_overflow (s_divide);
else
#endif
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
return scm_from_double (scm_i_fraction2double (x) / yy);
}
else if (SCM_COMPLEXP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
a = scm_i_fraction2double (x);
goto complex_div;
}
else if (SCM_FRACTIONP (y))
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (y)),
- scm_product (SCM_FRACTION_NUMERATOR (y),
SCM_FRACTION_DENOMINATOR (x)));
+ scm_product (SCM_FRACTION_NUMERATOR (y),
SCM_FRACTION_DENOMINATOR (x)));
else
return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
-
-SCM
-scm_divide (SCM x, SCM y)
-{
- return do_divide (x, y, 0);
-}
-
-static SCM scm_divide2real (SCM x, SCM y)
-{
- return do_divide (x, y, 1);
-}
#undef FUNC_NAME
@@ -8875,8 +9181,9 @@ SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0,
0,
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
return z;
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z),
SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (z));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (z));
}
else
return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
@@ -8973,21 +9280,35 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact,
"inexact->exact", 1, 0, 0,
if (!SCM_LIKELY (DOUBLE_IS_FINITE (val)))
SCM_OUT_OF_RANGE (1, z);
+ else if (val == 0.0)
+ return SCM_INUM0;
else
{
- mpq_t frac;
- SCM q;
-
- mpq_init (frac);
- mpq_set_d (frac, val);
- q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
- scm_i_mpz2num (mpq_denref (frac)));
+ int expon;
+ SCM numerator;
- /* When scm_i_make_ratio throws, we leak the memory allocated
- for frac...
- */
- mpq_clear (frac);
- return q;
+ numerator = scm_i_dbl2big (ldexp (frexp (val, &expon),
+ DBL_MANT_DIG));
+ expon -= DBL_MANT_DIG;
+ if (expon < 0)
+ {
+ int shift = mpz_scan1 (SCM_I_BIG_MPZ (numerator), 0);
+
+ if (shift > -expon)
+ shift = -expon;
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator),
+ SCM_I_BIG_MPZ (numerator),
+ shift);
+ expon += shift;
+ }
+ numerator = scm_i_normbig (numerator);
+ if (expon < 0)
+ return scm_i_make_ratio_already_reduced
+ (numerator, left_shift_exact_integer (SCM_INUM1, -expon));
+ else if (expon > 0)
+ return left_shift_exact_integer (numerator, expon);
+ else
+ return numerator;
}
}
}
@@ -9423,26 +9744,20 @@ log_of_shifted_double (double x, long shift)
return scm_c_make_rectangular (ans, M_PI);
}
-/* Returns log(n), for exact integer n of integer-length size */
-static SCM
-log_of_exact_integer_with_size (SCM n, long size)
-{
- long shift = size - 2 * scm_dblprec[0];
-
- if (shift > 0)
- return log_of_shifted_double
- (scm_to_double (scm_ash (n, scm_from_long(-shift))),
- shift);
- else
- return log_of_shifted_double (scm_to_double (n), 0);
-}
-
/* Returns log(n), for exact integer n */
static SCM
log_of_exact_integer (SCM n)
{
- return log_of_exact_integer_with_size
- (n, scm_to_long (scm_integer_length (n)));
+ if (SCM_I_INUMP (n))
+ return log_of_shifted_double (SCM_I_INUM (n), 0);
+ else if (SCM_BIGP (n))
+ {
+ long expon;
+ double signif = scm_i_big2dbl_2exp (n, &expon);
+ return log_of_shifted_double (signif, expon);
+ }
+ else
+ scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1, n);
}
/* Returns log(n/d), for exact non-zero integers n and d */
@@ -9453,16 +9768,15 @@ log_of_fraction (SCM n, SCM d)
long d_size = scm_to_long (scm_integer_length (d));
if (abs (n_size - d_size) > 1)
- return (scm_difference (log_of_exact_integer_with_size (n, n_size),
- log_of_exact_integer_with_size (d, d_size)));
+ return (scm_difference (log_of_exact_integer (n),
+ log_of_exact_integer (d)));
else if (scm_is_false (scm_negative_p (n)))
return scm_from_double
- (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d))));
+ (log1p (scm_i_divide2double (scm_difference (n, d), d)));
else
return scm_c_make_rectangular
- (log1p (scm_to_double (scm_divide2real
- (scm_difference (scm_abs (n), d),
- d))),
+ (log1p (scm_i_divide2double (scm_difference (scm_abs (n), d),
+ d)),
M_PI);
}
@@ -9610,25 +9924,17 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
{
if (SCM_LIKELY (SCM_I_INUMP (k)))
{
- scm_t_inum kk = SCM_I_INUM (k);
- scm_t_inum uu = kk;
- scm_t_inum ss;
+ mpz_t kk, ss, rr;
- if (SCM_LIKELY (kk > 0))
- {
- do
- {
- ss = uu;
- uu = (ss + kk/ss) / 2;
- } while (uu < ss);
- *sp = SCM_I_MAKINUM (ss);
- *rp = SCM_I_MAKINUM (kk - ss*ss);
- }
- else if (SCM_LIKELY (kk == 0))
- *sp = *rp = SCM_INUM0;
- else
+ if (SCM_I_INUM (k) < 0)
scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
"exact non-negative integer");
+ mpz_init_set_ui (kk, SCM_I_INUM (k));
+ mpz_inits (ss, rr, NULL);
+ mpz_sqrtrem (ss, rr, kk);
+ *sp = SCM_I_MAKINUM (mpz_get_ui (ss));
+ *rp = SCM_I_MAKINUM (mpz_get_ui (rr));
+ mpz_clears (kk, ss, rr, NULL);
}
else if (SCM_LIKELY (SCM_BIGP (k)))
{
@@ -9649,6 +9955,56 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
"exact non-negative integer");
}
+/* Return true iff K is a perfect square.
+ K must be an exact integer. */
+static int
+exact_integer_is_perfect_square (SCM k)
+{
+ int result;
+
+ if (SCM_LIKELY (SCM_I_INUMP (k)))
+ {
+ mpz_t kk;
+
+ mpz_init_set_si (kk, SCM_I_INUM (k));
+ result = mpz_perfect_square_p (kk);
+ mpz_clear (kk);
+ }
+ else
+ {
+ result = mpz_perfect_square_p (SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_1 (k);
+ }
+ return result;
+}
+
+/* Return the floor of the square root of K.
+ K must be an exact integer. */
+static SCM
+exact_integer_floor_square_root (SCM k)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (k)))
+ {
+ mpz_t kk;
+ scm_t_inum ss;
+
+ mpz_init_set_ui (kk, SCM_I_INUM (k));
+ mpz_sqrt (kk, kk);
+ ss = mpz_get_ui (kk);
+ mpz_clear (kk);
+ return SCM_I_MAKINUM (ss);
+ }
+ else
+ {
+ SCM s;
+
+ s = scm_i_mkbig ();
+ mpz_sqrt (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_1 (k);
+ return scm_i_normbig (s);
+ }
+}
+
SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
(SCM z),
@@ -9679,11 +10035,111 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
}
else if (SCM_NUMBERP (z))
{
- double xx = scm_to_double (z);
- if (xx < 0)
- return scm_c_make_rectangular (0.0, sqrt (-xx));
- else
- return scm_from_double (sqrt (xx));
+ if (SCM_I_INUMP (z))
+ {
+ scm_t_inum x = SCM_I_INUM (z);
+
+ if (SCM_LIKELY (x >= 0))
+ {
+ if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG
+ || x < (1L << (DBL_MANT_DIG - 1))))
+ {
+ double root = sqrt (x);
+
+ /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
+ integer, then the result is exact. */
+ if (root == floor (root))
+ return SCM_I_MAKINUM ((scm_t_inum) root);
+ else
+ return scm_from_double (root);
+ }
+ else
+ {
+ mpz_t xx;
+ scm_t_inum root;
+
+ mpz_init_set_ui (xx, x);
+ if (mpz_perfect_square_p (xx))
+ {
+ mpz_sqrt (xx, xx);
+ root = mpz_get_ui (xx);
+ mpz_clear (xx);
+ return SCM_I_MAKINUM (root);
+ }
+ else
+ mpz_clear (xx);
+ }
+ }
+ }
+ else if (SCM_BIGP (z))
+ {
+ if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z)))
+ {
+ SCM root = scm_i_mkbig ();
+
+ mpz_sqrt (SCM_I_BIG_MPZ (root), SCM_I_BIG_MPZ (z));
+ scm_remember_upto_here_1 (z);
+ return scm_i_normbig (root);
+ }
+ else
+ {
+ long expon;
+ double signif = scm_i_big2dbl_2exp (z, &expon);
+
+ if (expon & 1)
+ {
+ signif *= 2;
+ expon--;
+ }
+ if (signif < 0)
+ return scm_c_make_rectangular
+ (0.0, ldexp (sqrt (-signif), expon / 2));
+ else
+ return scm_from_double (ldexp (sqrt (signif), expon / 2));
+ }
+ }
+ else if (SCM_FRACTIONP (z))
+ {
+ SCM n = SCM_FRACTION_NUMERATOR (z);
+ SCM d = SCM_FRACTION_DENOMINATOR (z);
+
+ if (exact_integer_is_perfect_square (n)
+ && exact_integer_is_perfect_square (d))
+ return scm_i_make_ratio_already_reduced
+ (exact_integer_floor_square_root (n),
+ exact_integer_floor_square_root (d));
+ else
+ {
+ double xx = scm_i_divide2double (n, d);
+ double abs_xx = fabs (xx);
+ long shift = 0;
+
+ if (SCM_UNLIKELY (abs_xx > DBL_MAX || abs_xx < DBL_MIN))
+ {
+ shift = (scm_to_long (scm_integer_length (n))
+ - scm_to_long (scm_integer_length (d))) / 2;
+ if (shift > 0)
+ d = left_shift_exact_integer (d, 2 * shift);
+ else
+ n = left_shift_exact_integer (n, -2 * shift);
+ xx = scm_i_divide2double (n, d);
+ }
+
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx), shift));
+ else
+ return scm_from_double (ldexp (sqrt (xx), shift));
+ }
+ }
+
+ /* Fallback method, when the cases above do not apply. */
+ {
+ double xx = scm_to_double (z);
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, sqrt (-xx));
+ else
+ return scm_from_double (sqrt (xx));
+ }
}
else
return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
@@ -9695,8 +10151,6 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
void
scm_init_numbers ()
{
- int i;
-
if (scm_install_gmp_memory_functions)
mp_set_memory_functions (custom_gmp_malloc,
custom_gmp_realloc,
@@ -9718,18 +10172,25 @@ scm_init_numbers ()
flo0 = scm_from_double (0.0);
flo_log10e = scm_from_double (M_LOG10E);
- /* determine floating point precision */
- for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
- {
- init_dblprec(&scm_dblprec[i-2],i);
- init_fx_radix(fx_per_radix[i-2],i);
- }
-#ifdef DBL_DIG
- /* hard code precision for base 10 if the preprocessor tells us to... */
- scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
-#endif
-
exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2));
+
+ {
+ /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
+ mpz_init_set_ui (scm_i_divide2double_lo2b, 1);
+ mpz_mul_2exp (scm_i_divide2double_lo2b,
+ scm_i_divide2double_lo2b,
+ DBL_MANT_DIG + 1); /* 2 b^p */
+ mpz_sub_ui (scm_i_divide2double_lo2b, scm_i_divide2double_lo2b, 1);
+ }
+
+ {
+ /* Set dbl_minimum_normal_mantissa to b^{p-1} */
+ mpz_init_set_ui (dbl_minimum_normal_mantissa, 1);
+ mpz_mul_2exp (dbl_minimum_normal_mantissa,
+ dbl_minimum_normal_mantissa,
+ DBL_MANT_DIG - 1);
+ }
+
#include "libguile/numbers.x"
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index cef2b86..01eb2cf 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -3,7 +3,8 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008,
2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006,
+ * 2008, 2009, 2010, 2011, 2013 Free Software 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
@@ -204,7 +205,8 @@ SCM_API SCM scm_logbit_p (SCM n1, SCM n2);
SCM_API SCM scm_lognot (SCM n);
SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m);
SCM_API SCM scm_integer_expt (SCM z1, SCM z2);
-SCM_API SCM scm_ash (SCM n, SCM cnt);
+SCM_API SCM scm_ash (SCM n, SCM count);
+SCM_API SCM scm_round_ash (SCM n, SCM count);
SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end);
SCM_API SCM scm_logcount (SCM n);
SCM_API SCM scm_integer_length (SCM n);
@@ -500,6 +502,18 @@ SCM_API SCM scm_from_mpz (mpz_t rop);
#endif
#endif
+#if SCM_SIZEOF_SCM_T_PTRDIFF == 4
+#define scm_to_ptrdiff_t scm_to_int32
+#define scm_from_ptrdiff_t scm_from_int32
+#else
+#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
+#define scm_to_ptrdiff_t scm_to_int64
+#define scm_from_ptrdiff_t scm_from_int64
+#else
+#error sizeof(scm_t_ptrdiff) is not 4 or 8.
+#endif
+#endif
+
/* conversion functions for double */
SCM_API int scm_is_real (SCM val);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 0639028..4177c34 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012
+ * 2013 Free Software 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
@@ -88,6 +89,8 @@
#define ELFDATA ELFDATA2LSB
#endif
+static void register_elf (char *data, size_t len);
+
enum bytecode_kind
{
BYTECODE_KIND_NONE,
@@ -160,48 +163,104 @@ check_elf_header (const Elf_Ehdr *header)
return NULL;
}
-static int
-segment_flags_to_prot (Elf_Word flags)
+#define IS_ALIGNED(offset, alignment) \
+ (!((offset) & ((alignment) - 1)))
+#define ALIGN(offset, alignment) \
+ ((offset + (alignment - 1)) & ~(alignment - 1))
+
+static unsigned
+sniff_elf_alignment (const char *data, size_t len)
{
- int prot = 0;
-
- if (flags & PF_X)
- prot |= PROT_EXEC;
- if (flags & PF_W)
- prot |= PROT_WRITE;
- if (flags & PF_R)
- prot |= PROT_READ;
+ Elf_Ehdr *header;
+ int i;
+ unsigned alignment = 8;
+
+ if (len < sizeof(Elf_Ehdr))
+ return alignment;
+ header = (Elf_Ehdr *) data;
+ if (header->e_phoff + header->e_phnum * header->e_phentsize >= len)
+ return alignment;
+ for (i = 0; i < header->e_phnum; i++)
+ {
+ Elf_Phdr *phdr;
+ const char *phdr_addr = data + header->e_phoff + i * header->e_phentsize;
- return prot;
+ if (!IS_ALIGNED ((scm_t_uintptr) phdr_addr, alignof_type (Elf_Phdr)))
+ return alignment;
+ phdr = (Elf_Phdr *) phdr_addr;
+
+ if (phdr->p_align & (phdr->p_align - 1))
+ return alignment;
+
+ if (phdr->p_align > alignment)
+ alignment = phdr->p_align;
+ }
+
+ return alignment;
}
-static int
-map_segments (int fd, char **base,
- const Elf_Phdr *from, const Elf_Phdr *to)
+/* This function leaks the memory that it allocates. */
+static char*
+alloc_aligned (size_t len, unsigned alignment)
{
- int prot = segment_flags_to_prot (from->p_flags);
char *ret;
- ret = mmap (*base + from->p_vaddr,
- to->p_offset + to->p_filesz - from->p_offset,
- prot, MAP_PRIVATE, fd, from->p_offset);
+ if (alignment == 8)
+ {
+ /* FIXME: Assert that we actually have an 8-byte-aligned malloc. */
+ ret = malloc (len);
+ }
+#if defined(HAVE_SYS_MMAN_H) && defined(MMAP_ANONYMOUS)
+ else if (alignment == SCM_PAGE_SIZE)
+ {
+ ret = mmap (NULL, len, PROT_READ | PROT_WRITE, -1, 0);
+ if (ret == MAP_FAILED)
+ SCM_SYSERROR;
+ }
+#endif
+ else
+ {
+ if (len + alignment < len)
+ abort ();
- if (ret == (char *) -1)
- return 1;
+ ret = malloc (len + alignment - 1);
+ if (!ret)
+ abort ();
+ ret = (char *) ALIGN ((scm_t_uintptr) ret, alignment);
+ }
- if (!*base)
- *base = ret;
+ return ret;
+}
- return 0;
+static char*
+copy_and_align_elf_data (const char *data, size_t len)
+{
+ unsigned alignment;
+ char *copy;
+
+ alignment = sniff_elf_alignment (data, len);
+ copy = alloc_aligned (len, alignment);
+ memcpy(copy, data, len);
+
+ return copy;
}
+#ifdef HAVE_SYS_MMAN_H
static int
-mprotect_segments (char *base, const Elf_Phdr *from, const Elf_Phdr *to)
+segment_flags_to_prot (Elf_Word flags)
{
- return mprotect (base + from->p_vaddr,
- to->p_vaddr + to->p_memsz - from->p_vaddr,
- segment_flags_to_prot (from->p_flags));
+ int prot = 0;
+
+ if (flags & PF_X)
+ prot |= PROT_EXEC;
+ if (flags & PF_W)
+ prot |= PROT_WRITE;
+ if (flags & PF_R)
+ prot |= PROT_READ;
+
+ return prot;
}
+#endif
static char*
process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
@@ -299,152 +358,38 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
#define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
-#ifdef HAVE_SYS_MMAN_H
static SCM
-load_thunk_from_fd_using_mmap (int fd)
-#define FUNC_NAME "load-thunk-from-disk"
+load_thunk_from_memory (char *data, size_t len, int is_read_only)
+#define FUNC_NAME "load-thunk-from-memory"
{
- Elf_Ehdr header;
+ Elf_Ehdr *header;
Elf_Phdr *ph;
const char *err_msg = 0;
- char *base = 0;
- size_t n;
+ size_t n, alignment = 8;
int i;
- int start_segment = -1;
- int prev_segment = -1;
int dynamic_segment = -1;
SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
- if (full_read (fd, &header, sizeof header) != sizeof header)
+ if (len < sizeof *header)
ABORT ("object file too small");
- if ((err_msg = check_elf_header (&header)))
- goto cleanup;
-
- if (lseek (fd, header.e_phoff, SEEK_SET) == (off_t) -1)
- goto cleanup;
+ header = (Elf_Ehdr*) data;
- n = header.e_phnum;
- ph = scm_gc_malloc_pointerless (n * sizeof (Elf_Phdr), "segment headers");
-
- if (full_read (fd, ph, n * sizeof (Elf_Phdr)) != n * sizeof (Elf_Phdr))
- ABORT ("failed to read program headers");
-
- for (i = 0; i < n; i++)
- {
- if (!ph[i].p_memsz)
- continue;
-
- if (ph[i].p_filesz != ph[i].p_memsz)
- ABORT ("expected p_filesz == p_memsz");
-
- if (!ph[i].p_flags)
- ABORT ("expected nonzero segment flags");
-
- if (ph[i].p_type == PT_DYNAMIC)
- {
- if (dynamic_segment >= 0)
- ABORT ("expected only one PT_DYNAMIC segment");
- dynamic_segment = i;
- }
-
- if (start_segment < 0)
- {
- if (!base && ph[i].p_vaddr)
- ABORT ("first loadable vaddr is not 0");
-
- start_segment = prev_segment = i;
- continue;
- }
-
- if (ph[i].p_flags == ph[start_segment].p_flags)
- {
- if (ph[i].p_vaddr - ph[prev_segment].p_vaddr
- != ph[i].p_offset - ph[prev_segment].p_offset)
- ABORT ("coalesced segments not contiguous");
-
- prev_segment = i;
- continue;
- }
-
- /* Otherwise we have a new kind of segment. Map previous
- segments. */
- if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
- goto cleanup;
-
- /* Open a new set of segments. */
- start_segment = prev_segment = i;
- }
-
- /* Map last segments. */
- if (start_segment < 0)
- ABORT ("no loadable segments");
-
- if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
+ if ((err_msg = check_elf_header (header)))
goto cleanup;
- if (dynamic_segment < 0)
- ABORT ("no PT_DYNAMIC segment");
-
- if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
- &init, &entry)))
- goto cleanup;
-
- if (scm_is_true (init))
- scm_call_0 (init);
-
- /* Finally! Return the thunk. */
- return entry;
-
- /* FIXME: munmap on error? */
- cleanup:
- {
- int errno_save = errno;
- (void) close (fd);
- errno = errno_save;
- if (errno)
- SCM_SYSERROR;
- scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
- SCM_EOL);
- }
-}
-#undef FUNC_NAME
-#endif /* HAVE_SYS_MMAN_H */
-
-static SCM
-load_thunk_from_memory (char *data, size_t len)
-#define FUNC_NAME "load-thunk-from-memory"
-{
- Elf_Ehdr header;
- Elf_Phdr *ph;
- const char *err_msg = 0;
- char *base = 0;
- size_t n, memsz = 0, alignment = 8;
- int i;
- int first_loadable = -1;
- int start_segment = -1;
- int prev_segment = -1;
- int dynamic_segment = -1;
- SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
+ if (header->e_phnum == 0)
+ ABORT ("no loadable segments");
+ n = header->e_phnum;
- if (len < sizeof header)
+ if (len < header->e_phoff + n * sizeof (Elf_Phdr))
ABORT ("object file too small");
- memcpy (&header, data, sizeof header);
-
- if ((err_msg = check_elf_header (&header)))
- goto cleanup;
-
- n = header.e_phnum;
- if (len < header.e_phoff + n * sizeof (Elf_Phdr))
- goto cleanup;
- ph = (Elf_Phdr*) (data + header.e_phoff);
+ ph = (Elf_Phdr*) (data + header->e_phoff);
+ /* Check that the segment table is sane. */
for (i = 0; i < n; i++)
{
- if (!ph[i].p_memsz)
- continue;
-
if (ph[i].p_filesz != ph[i].p_memsz)
ABORT ("expected p_filesz == p_memsz");
@@ -465,90 +410,57 @@ load_thunk_from_memory (char *data, size_t len)
dynamic_segment = i;
}
- if (first_loadable < 0)
+ if (i == 0)
{
- if (ph[i].p_vaddr)
+ if (ph[i].p_vaddr != 0)
ABORT ("first loadable vaddr is not 0");
-
- first_loadable = i;
}
+ else
+ {
+ if (ph[i].p_vaddr < ph[i-1].p_vaddr + ph[i-1].p_memsz)
+ ABORT ("overlapping segments");
- if (ph[i].p_vaddr < memsz)
- ABORT ("overlapping segments");
-
- if (ph[i].p_offset + ph[i].p_filesz > len)
- ABORT ("segment beyond end of byte array");
-
- memsz = ph[i].p_vaddr + ph[i].p_memsz;
+ if (ph[i].p_offset + ph[i].p_filesz > len)
+ ABORT ("segment beyond end of byte array");
+ }
}
- if (first_loadable < 0)
- ABORT ("no loadable segments");
-
if (dynamic_segment < 0)
ABORT ("no PT_DYNAMIC segment");
- /* Now copy segments. */
-
- /* We leak this memory, as we leak the memory mappings in
- load_thunk_from_fd_using_mmap.
+ if (!IS_ALIGNED ((scm_t_uintptr) data, alignment))
+ ABORT ("incorrectly aligned base");
- If the file is has an alignment of 8, use the standard malloc.
- (FIXME to ensure alignment on non-GNU malloc.) Otherwise use
- posix_memalign. We only use mprotect if the aligment is 4096. */
- if (alignment == 8)
+ /* Allow writes to writable pages. */
+ if (is_read_only)
{
- base = malloc (memsz);
- if (!base)
- goto cleanup;
- }
- else
- if ((errno = posix_memalign ((void **) &base, alignment, memsz)))
- goto cleanup;
-
- memset (base, 0, memsz);
-
- for (i = 0; i < n; i++)
- {
- if (!ph[i].p_memsz)
- continue;
-
- memcpy (base + ph[i].p_vaddr,
- data + ph[i].p_offset,
- ph[i].p_memsz);
-
- if (start_segment < 0)
- {
- start_segment = prev_segment = i;
- continue;
- }
-
- if (ph[i].p_flags == ph[start_segment].p_flags)
+#ifdef HAVE_SYS_MMAN_H
+ for (i = 0; i < n; i++)
{
- prev_segment = i;
- continue;
+ if (ph[i].p_flags == PF_R)
+ continue;
+ if (ph[i].p_align != 4096)
+ continue;
+
+ if (mprotect (data + ph[i].p_vaddr,
+ ph[i].p_memsz,
+ segment_flags_to_prot (ph[i].p_flags)))
+ goto cleanup;
}
-
- if (alignment == 4096)
- if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
- goto cleanup;
-
- /* Open a new set of segments. */
- start_segment = prev_segment = i;
+#else
+ ABORT ("expected writable pages");
+#endif
}
- /* Mprotect the last segments. */
- if (alignment == 4096)
- if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
- goto cleanup;
-
- if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
+ if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment],
&init, &entry)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
+ register_elf (data, len);
+
/* Finally! Return the thunk. */
return entry;
@@ -562,22 +474,40 @@ load_thunk_from_memory (char *data, size_t len)
}
#undef FUNC_NAME
-#ifndef HAVE_SYS_MMAN_H
-static SCM
-load_thunk_from_fd_using_read (int fd)
-#define FUNC_NAME "load-thunk-from-disk"
+#define SCM_PAGE_SIZE 4096
+
+static char*
+map_file_contents (int fd, size_t len, int *is_read_only)
+#define FUNC_NAME "load-thunk-from-file"
{
char *data;
- size_t len;
- struct stat st;
- int ret;
- ret = fstat (fd, &st);
- if (ret < 0)
+#ifdef HAVE_SYS_MMAN_H
+ data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0);
+ if (data == MAP_FAILED)
SCM_SYSERROR;
- len = st.st_size;
- data = scm_gc_malloc_pointerless (len, "objcode");
- if (full_read (fd, data, len) != len)
+ *is_read_only = 1;
+#else
+ if (lseek (fd, 0, SEEK_START) < 0)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+
+ /* Given that we are using the read fallback, optimistically assume
+ that the .go files were made with 8-byte alignment.
+ alignment. */
+ data = malloc (end);
+ if (!data)
+ {
+ (void) close (fd);
+ scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes",
+ scm_list_1 (scm_from_size_t (end)));
+ }
+
+ if (full_read (fd, data, end) != end)
{
int errno_save = errno;
(void) close (fd);
@@ -587,11 +517,25 @@ load_thunk_from_fd_using_read (int fd)
scm_misc_error (FUNC_NAME, "short read while loading objcode",
SCM_EOL);
}
- (void) close (fd);
- return load_thunk_from_memory (data, len);
+
+ /* If our optimism failed, fall back. */
+ {
+ unsigned alignment = sniff_elf_alignment (data, end);
+
+ if (alignment != 8)
+ {
+ char *copy = copy_and_align_elf_data (data, end, alignment);
+ free (data);
+ data = copy;
+ }
+ }
+
+ *is_read_only = 0;
+#endif
+
+ return data;
}
#undef FUNC_NAME
-#endif /* ! HAVE_SYS_MMAN_H */
SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
(SCM filename),
@@ -599,20 +543,26 @@ SCM_DEFINE (scm_load_thunk_from_file,
"load-thunk-from-file", 1, 0, 0,
#define FUNC_NAME s_scm_load_thunk_from_file
{
char *c_filename;
- int fd;
+ int fd, is_read_only;
+ off_t end;
+ char *data;
SCM_VALIDATE_STRING (1, filename);
c_filename = scm_to_locale_string (filename);
- fd = open (c_filename, O_RDONLY | O_CLOEXEC);
+ fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC);
free (c_filename);
if (fd < 0) SCM_SYSERROR;
-#ifdef HAVE_SYS_MMAN_H
- return load_thunk_from_fd_using_mmap (fd);
-#else
- return load_thunk_from_fd_using_read (fd);
-#endif
+ end = lseek (fd, 0, SEEK_END);
+ if (end < 0)
+ SCM_SYSERROR;
+
+ data = map_file_contents (fd, end, &is_read_only);
+
+ (void) close (fd);
+
+ return load_thunk_from_memory (data, end, is_read_only);
}
#undef FUNC_NAME
@@ -621,10 +571,20 @@ SCM_DEFINE (scm_load_thunk_from_memory,
"load-thunk-from-memory", 1, 0, 0,
"")
#define FUNC_NAME s_scm_load_thunk_from_memory
{
+ char *data;
+ size_t len;
+
SCM_VALIDATE_BYTEVECTOR (1, bv);
- return load_thunk_from_memory ((char *) SCM_BYTEVECTOR_CONTENTS (bv),
- SCM_BYTEVECTOR_LENGTH (bv));
+ data = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ /* Copy data in order to align it, to trace its GC roots and
+ writable sections, and to keep it in memory. */
+
+ data = copy_and_align_elf_data (data, len);
+
+ return load_thunk_from_memory (data, len, 0);
}
#undef FUNC_NAME
@@ -679,6 +639,107 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
}
#undef FUNC_NAME
+struct mapped_elf_image
+{
+ char *start;
+ char *end;
+};
+
+static struct mapped_elf_image *mapped_elf_images = NULL;
+static size_t mapped_elf_images_count = 0;
+static size_t mapped_elf_images_allocated = 0;
+
+static size_t
+find_mapped_elf_insertion_index (char *ptr)
+{
+ /* "mapped_elf_images_count" must never be dereferenced. */
+ size_t start = 0, end = mapped_elf_images_count;
+
+ while (start < end)
+ {
+ size_t n = start + (end - start) / 2;
+
+ if (ptr < mapped_elf_images[n].end)
+ end = n;
+ else
+ start = n + 1;
+ }
+
+ return start;
+}
+
+static void
+register_elf (char *data, size_t len)
+{
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ /* My kingdom for a generic growable sorted vector library. */
+ if (mapped_elf_images_count == mapped_elf_images_allocated)
+ {
+ struct mapped_elf_image *prev;
+ size_t n;
+
+ if (mapped_elf_images_allocated)
+ mapped_elf_images_allocated *= 2;
+ else
+ mapped_elf_images_allocated = 16;
+
+ prev = mapped_elf_images;
+ mapped_elf_images =
+ scm_gc_malloc_pointerless (sizeof (*mapped_elf_images)
+ * mapped_elf_images_allocated,
+ "mapped elf images");
+
+ for (n = 0; n < mapped_elf_images_count; n++)
+ {
+ mapped_elf_images[n].start = prev[n].start;
+ mapped_elf_images[n].end = prev[n].end;
+ }
+ }
+
+ {
+ size_t end;
+ size_t n = find_mapped_elf_insertion_index (data);
+
+ for (end = mapped_elf_images_count; n < end; end--)
+ {
+ mapped_elf_images[end].start = mapped_elf_images[end - 1].start;
+ mapped_elf_images[end].end = mapped_elf_images[end - 1].end;
+ }
+ mapped_elf_images_count++;
+
+ mapped_elf_images[n].start = data;
+ mapped_elf_images[n].end = data + len;
+ }
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+}
+
+static SCM
+scm_find_mapped_elf_image (SCM ip)
+{
+ char *ptr = (char *) scm_to_unsigned_integer (ip, 0, SCM_T_UINTPTR_MAX);
+ SCM result;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ size_t n = find_mapped_elf_insertion_index ((char *) ptr);
+ if (n < mapped_elf_images_count
+ && mapped_elf_images[n].start <= ptr
+ && ptr < mapped_elf_images[n].end)
+ {
+ signed char *data = (signed char *) mapped_elf_images[n].start;
+ size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
+ result = scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
+ }
+ else
+ result = SCM_BOOL_F;
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ return result;
+}
+
/*
* Scheme interface
@@ -817,6 +878,9 @@ scm_init_objcodes (void)
#include "libguile/objcodes.x"
#endif
+ scm_c_define_gsubr ("find-mapped-elf-image", 1, 0, 0,
+ (scm_t_subr) scm_find_mapped_elf_image);
+
scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
}
diff --git a/libguile/poll.c b/libguile/poll.c
index 1bb7572..9ea846b 100644
--- a/libguile/poll.c
+++ b/libguile/poll.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2013 Free Software 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,8 @@
# include <config.h>
#endif
+#include <poll.h>
+
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
#include "libguile/numbers.h"
@@ -34,11 +36,6 @@
#include "libguile/poll.h"
-#ifdef HAVE_POLL_H
-#include <poll.h>
-#endif
-
-
/* {Poll}
*/
@@ -73,7 +70,6 @@
If timeout is given and is non-negative, the poll will return after that
number of milliseconds if no fd became active.
*/
-#ifdef HAVE_POLL
static SCM
scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout)
#define FUNC_NAME "primitive-poll"
@@ -174,7 +170,6 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM
timeout)
return scm_from_int (rv);
}
#undef FUNC_NAME
-#endif /* HAVE_POLL */
@@ -182,12 +177,8 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM
timeout)
static void
scm_init_poll (void)
{
-#if HAVE_POLL
scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_poll);
scm_c_define ("%sizeof-struct-pollfd", scm_from_size_t (sizeof (struct
pollfd)));
-#else
- scm_misc_error ("%init-poll", "`poll' unavailable on this platform",
SCM_EOL);
-#endif
#ifdef POLLIN
scm_c_define ("POLLIN", scm_from_int (POLLIN));
diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h
new file mode 100644
index 0000000..bff89cb
--- /dev/null
+++ b/libguile/ports-internal.h
@@ -0,0 +1,66 @@
+/*
+ * ports-internal.h - internal-only declarations for ports.
+ *
+ * Copyright (C) 2013 Free Software 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_PORTS_INTERNAL
+#define SCM_PORTS_INTERNAL
+
+#include "libguile/_scm.h"
+#include "libguile/ports.h"
+
+enum scm_port_encoding_mode {
+ SCM_PORT_ENCODING_MODE_UTF8,
+ SCM_PORT_ENCODING_MODE_LATIN1,
+ SCM_PORT_ENCODING_MODE_ICONV
+};
+
+typedef enum scm_port_encoding_mode scm_t_port_encoding_mode;
+
+/* This is a separate object so that only those ports that use iconv
+ cause finalizers to be registered. */
+struct scm_iconv_descriptors
+{
+ /* input/output iconv conversion descriptors */
+ void *input_cd;
+ void *output_cd;
+};
+
+typedef struct scm_iconv_descriptors scm_t_iconv_descriptors;
+
+struct scm_port_internal
+{
+ unsigned at_stream_start_for_bom_read : 1;
+ unsigned at_stream_start_for_bom_write : 1;
+ scm_t_port_encoding_mode encoding_mode;
+ scm_t_iconv_descriptors *iconv_descriptors;
+ int pending_eof;
+ SCM alist;
+};
+
+typedef struct scm_port_internal scm_t_port_internal;
+
+#define SCM_UNICODE_BOM 0xFEFFUL /* Unicode byte-order mark */
+
+#define SCM_PORT_GET_INTERNAL(x) (SCM_PTAB_ENTRY(x)->internal)
+
+SCM_INTERNAL scm_t_iconv_descriptors *
+scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode);
+
+#endif
diff --git a/libguile/ports.c b/libguile/ports.c
index 0aacacc..20c9081 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -55,6 +55,7 @@
#include "libguile/mallocs.h"
#include "libguile/validate.h"
#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/vectors.h"
#include "libguile/weak-set.h"
#include "libguile/fluids.h"
@@ -329,6 +330,30 @@ scm_set_port_input_waiting (scm_t_bits tc, int
(*input_waiting) (SCM))
scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting;
}
+static void
+scm_i_set_pending_eof (SCM port)
+{
+ SCM_PORT_GET_INTERNAL (port)->pending_eof = 1;
+}
+
+static void
+scm_i_clear_pending_eof (SCM port)
+{
+ SCM_PORT_GET_INTERNAL (port)->pending_eof = 0;
+}
+
+SCM
+scm_i_port_alist (SCM port)
+{
+ return SCM_PORT_GET_INTERNAL (port)->alist;
+}
+
+void
+scm_i_set_port_alist_x (SCM port, SCM alist)
+{
+ SCM_PORT_GET_INTERNAL (port)->alist = alist;
+}
+
/* Standard ports --- current input, output, error, and more(!). */
@@ -383,10 +408,14 @@ SCM_DEFINE (scm_current_error_port, "current-error-port",
0, 0, 0,
SCM
scm_current_warning_port (void)
{
- static SCM cwp_var = SCM_BOOL_F;
+ static SCM cwp_var = SCM_UNDEFINED;
+ static scm_i_pthread_mutex_t cwp_var_mutex
+ = SCM_I_PTHREAD_MUTEX_INITIALIZER;
- if (scm_is_false (cwp_var))
- cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+ scm_i_scm_pthread_mutex_lock (&cwp_var_mutex);
+ if (SCM_UNBNDP (cwp_var))
+ cwp_var = scm_c_private_variable ("guile", "current-warning-port");
+ scm_i_pthread_mutex_unlock (&cwp_var_mutex);
return scm_call_0 (scm_variable_ref (cwp_var));
}
@@ -637,9 +666,11 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned
long mode_bits,
{
SCM ret;
scm_t_port *entry;
+ scm_t_port_internal *pti;
scm_t_ptob_descriptor *ptob;
- entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+ entry = scm_gc_typed_calloc (scm_t_port);
+ pti = scm_gc_typed_calloc (scm_t_port_internal);
ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag));
ret = scm_words (tag | mode_bits, 3);
@@ -649,6 +680,7 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned
long mode_bits,
entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock");
scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive);
+ entry->internal = pti;
entry->file_name = SCM_BOOL_F;
entry->rw_active = SCM_PORT_NEITHER;
entry->port = ret;
@@ -656,24 +688,28 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned
long mode_bits,
if (encoding_matches (encoding, "UTF-8"))
{
- entry->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
entry->encoding = "UTF-8";
}
else if (encoding_matches (encoding, "ISO-8859-1"))
{
- entry->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
entry->encoding = "ISO-8859-1";
}
else
{
- entry->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
entry->encoding = canonicalize_encoding (encoding);
}
entry->ilseq_handler = handler;
- entry->iconv_descriptors = NULL;
+ pti->iconv_descriptors = NULL;
+
+ pti->at_stream_start_for_bom_read = 1;
+ pti->at_stream_start_for_bom_write = 1;
- entry->alist = SCM_EOL;
+ pti->pending_eof = 0;
+ pti->alist = SCM_EOL;
if (SCM_PORT_DESCRIPTOR (ret)->free)
scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
@@ -779,7 +815,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
"descriptors.")
#define FUNC_NAME s_scm_close_port
{
- scm_t_port *p;
+ scm_t_port_internal *pti;
int rv;
port = SCM_COERCE_OUTPORT (port);
@@ -788,7 +824,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
- p = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
SCM_CLR_PORT_OPEN_FLAG (port);
if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH)
@@ -801,12 +837,12 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
else
rv = 0;
- if (p->iconv_descriptors)
+ if (pti->iconv_descriptors)
{
/* If we don't get here, the iconv_descriptors finalizer will
clean up. */
- close_iconv_descriptors (p->iconv_descriptors);
- p->iconv_descriptors = NULL;
+ close_iconv_descriptors (pti->iconv_descriptors);
+ pti->iconv_descriptors = NULL;
}
return scm_from_bool (rv >= 0);
@@ -971,6 +1007,66 @@ scm_i_set_default_port_conversion_handler
(scm_t_string_failed_conversion_handle
}
static void
+scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port);
+
+/* If the next LEN bytes from PORT are equal to those in BYTES, then
+ return 1, else return 0. Leave the port position unchanged. */
+static int
+looking_at_bytes (SCM port, const unsigned char *bytes, int len)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ int i = 0;
+
+ while (i < len && scm_peek_byte_or_eof_unlocked (port) == bytes[i])
+ {
+ pt->read_pos++;
+ i++;
+ }
+ scm_i_unget_bytes_unlocked (bytes, i, port);
+ return (i == len);
+}
+
+static const unsigned char scm_utf8_bom[3] = {0xEF, 0xBB, 0xBF};
+static const unsigned char scm_utf16be_bom[2] = {0xFE, 0xFF};
+static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE};
+static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF};
+static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00};
+
+/* Decide what byte order to use for a UTF-16 port. Return "UTF-16BE"
+ or "UTF-16LE". MODE must be either SCM_PORT_READ or SCM_PORT_WRITE,
+ and specifies which operation is about to be done. The MODE
+ determines how we will decide the byte order. We deliberately avoid
+ reading from the port unless the user is about to do so. If the user
+ is about to read, then we look for a BOM, and if present, we use it
+ to determine the byte order. Otherwise we choose big endian, as
+ recommended by the Unicode Standard. Note that the BOM (if any) is
+ not consumed here. */
+static const char *
+decide_utf16_encoding (SCM port, scm_t_port_rw_active mode)
+{
+ if (mode == SCM_PORT_READ
+ && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
+ && looking_at_bytes (port, scm_utf16le_bom, sizeof scm_utf16le_bom))
+ return "UTF-16LE";
+ else
+ return "UTF-16BE";
+}
+
+/* Decide what byte order to use for a UTF-32 port. Return "UTF-32BE"
+ or "UTF-32LE". See the comment above 'decide_utf16_encoding' for
+ details. */
+static const char *
+decide_utf32_encoding (SCM port, scm_t_port_rw_active mode)
+{
+ if (mode == SCM_PORT_READ
+ && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
+ && looking_at_bytes (port, scm_utf32le_bom, sizeof scm_utf32le_bom))
+ return "UTF-32LE";
+ else
+ return "UTF-32BE";
+}
+
+static void
finalize_iconv_descriptors (void *ptr, void *data)
{
close_iconv_descriptors (ptr);
@@ -1053,25 +1149,36 @@ close_iconv_descriptors (scm_t_iconv_descriptors *id)
}
scm_t_iconv_descriptors *
-scm_i_port_iconv_descriptors (SCM port)
+scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode)
{
- scm_t_port *pt;
-
- pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
- assert (pt->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
+ assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
- if (!pt->iconv_descriptors)
+ if (!pti->iconv_descriptors)
{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ const char *precise_encoding;
+
if (!pt->encoding)
pt->encoding = "ISO-8859-1";
- pt->iconv_descriptors =
- open_iconv_descriptors (pt->encoding,
+
+ /* If the specified encoding is UTF-16 or UTF-32, then make
+ that more precise by deciding what byte order to use. */
+ if (strcmp (pt->encoding, "UTF-16") == 0)
+ precise_encoding = decide_utf16_encoding (port, mode);
+ else if (strcmp (pt->encoding, "UTF-32") == 0)
+ precise_encoding = decide_utf32_encoding (port, mode);
+ else
+ precise_encoding = pt->encoding;
+
+ pti->iconv_descriptors =
+ open_iconv_descriptors (precise_encoding,
SCM_INPUT_PORT_P (port),
SCM_OUTPUT_PORT_P (port));
}
- return pt->iconv_descriptors;
+ return pti->iconv_descriptors;
}
/* The name of the encoding is itself encoded in ASCII. */
@@ -1079,36 +1186,39 @@ void
scm_i_set_port_encoding_x (SCM port, const char *encoding)
{
scm_t_port *pt;
+ scm_t_port_internal *pti;
scm_t_iconv_descriptors *prev;
/* Set the character encoding for this port. */
pt = SCM_PTAB_ENTRY (port);
- prev = pt->iconv_descriptors;
+ pti = SCM_PORT_GET_INTERNAL (port);
+ prev = pti->iconv_descriptors;
+
+ /* In order to handle cases where the encoding changes mid-stream
+ (e.g. within an HTTP stream, or within a file that is composed of
+ segments with different encodings), we consider this to be "stream
+ start" for purposes of BOM handling, regardless of our actual file
+ position. */
+ pti->at_stream_start_for_bom_read = 1;
+ pti->at_stream_start_for_bom_write = 1;
if (encoding_matches (encoding, "UTF-8"))
{
pt->encoding = "UTF-8";
- pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
- pt->iconv_descriptors = NULL;
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
}
else if (encoding_matches (encoding, "ISO-8859-1"))
{
pt->encoding = "ISO-8859-1";
- pt->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
- pt->iconv_descriptors = NULL;
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
}
else
{
- /* Open descriptors before mutating the port. */
- char *gc_encoding = canonicalize_encoding (encoding);
- pt->iconv_descriptors =
- open_iconv_descriptors (gc_encoding,
- SCM_INPUT_PORT_P (port),
- SCM_OUTPUT_PORT_P (port));
- pt->encoding = gc_encoding;
- pt->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ pt->encoding = canonicalize_encoding (encoding);
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
}
+ pti->iconv_descriptors = NULL;
if (prev)
close_iconv_descriptors (prev);
}
@@ -1334,17 +1444,21 @@ swap_buffer (void *data)
psb->size = old_size;
}
+static int scm_i_fill_input_unlocked (SCM port);
+
size_t
scm_c_read_unlocked (SCM port, void *buffer, size_t size)
#define FUNC_NAME "scm_c_read"
{
scm_t_port *pt;
+ scm_t_port_internal *pti;
size_t n_read = 0, n_available;
struct port_and_swap_buffer psb;
SCM_VALIDATE_OPINPORT (1, port);
pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
if (pt->rw_active == SCM_PORT_WRITE)
SCM_PORT_DESCRIPTOR (port)->flush (port);
@@ -1366,24 +1480,23 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t
size)
if (size == 0)
return n_read;
- /* Now we will call scm_fill_input repeatedly until we have read the
- requested number of bytes. (Note that a single scm_fill_input
- call does not guarantee to fill the whole of the port's read
- buffer.) */
+ /* Now we will call scm_i_fill_input_unlocked repeatedly until we have
+ read the requested number of bytes. (Note that a single
+ scm_i_fill_input_unlocked call does not guarantee to fill the whole
+ of the port's read buffer.) */
if (pt->read_buf_size <= 1
- && pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ && pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
{
- /* The port that we are reading from is unbuffered - i.e. does
- not have its own persistent buffer - but we have a buffer,
- provided by our caller, that is the right size for the data
- that is wanted. For the following scm_fill_input calls,
- therefore, we use the buffer in hand as the port's read
- buffer.
-
- We need to make sure that the port's normal (1 byte) buffer
- is reinstated in case one of the scm_fill_input () calls
- throws an exception; we use the scm_dynwind_* API to achieve
- that.
+ /* The port that we are reading from is unbuffered - i.e. does not
+ have its own persistent buffer - but we have a buffer, provided
+ by our caller, that is the right size for the data that is
+ wanted. For the following scm_i_fill_input_unlocked calls,
+ therefore, we use the buffer in hand as the port's read buffer.
+
+ We need to make sure that the port's normal (1 byte) buffer is
+ reinstated in case one of the scm_i_fill_input_unlocked ()
+ calls throws an exception; we use the scm_dynwind_* API to
+ achieve that.
A consequence of this optimization is that the fill_input
functions can't unget characters. That'll push data to the
@@ -1398,9 +1511,9 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size)
scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
- /* Call scm_fill_input until we have all the bytes that we need,
- or we hit EOF. */
- while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF))
+ /* Call scm_i_fill_input_unlocked until we have all the bytes that
+ we need, or we hit EOF. */
+ while (pt->read_buf_size && (scm_i_fill_input_unlocked (port) != EOF))
{
pt->read_buf_size -= (pt->read_end - pt->read_pos);
pt->read_pos = pt->read_buf = pt->read_end;
@@ -1424,7 +1537,7 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size)
that a custom port implementation's entry points (in
particular, fill_input) can rely on the buffer always being
the same as they first set up. */
- while (size && (scm_fill_input_unlocked (port) != EOF))
+ while (size && (scm_i_fill_input_unlocked (port) != EOF))
{
n_available = min (size, pt->read_end - pt->read_pos);
memcpy (buffer, pt->read_pos, n_available);
@@ -1682,64 +1795,77 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
{
scm_t_iconv_descriptors *id;
- int err, byte_read;
- size_t bytes_consumed, output_size;
- char *output;
scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
+ size_t input_size = 0;
- id = scm_i_port_iconv_descriptors (port);
+ id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ);
- for (output_size = 0, output = (char *) utf8_buf,
- bytes_consumed = 0, err = 0;
- err == 0 && output_size == 0
- && (bytes_consumed == 0 || byte_read != EOF);
- bytes_consumed++)
+ for (;;)
{
- char *input;
+ int byte_read;
+ char *input, *output;
size_t input_left, output_left, done;
byte_read = scm_get_byte_or_eof_unlocked (port);
- if (byte_read == EOF)
+ if (SCM_UNLIKELY (byte_read == EOF))
{
- if (bytes_consumed == 0)
- {
- *codepoint = (scm_t_wchar) EOF;
- *len = 0;
- return 0;
- }
- else
- continue;
+ if (SCM_LIKELY (input_size == 0))
+ {
+ *codepoint = (scm_t_wchar) EOF;
+ *len = input_size;
+ return 0;
+ }
+ else
+ {
+ /* EOF found in the middle of a multibyte character. */
+ scm_i_set_pending_eof (port);
+ return EILSEQ;
+ }
}
- buf[bytes_consumed] = byte_read;
+ buf[input_size++] = byte_read;
input = buf;
- input_left = bytes_consumed + 1;
+ input_left = input_size;
+ output = (char *) utf8_buf;
output_left = sizeof (utf8_buf);
done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
+
if (done == (size_t) -1)
{
- err = errno;
- if (err == EINVAL)
- /* Missing input: keep trying. */
- err = 0;
+ int err = errno;
+ if (SCM_LIKELY (err == EINVAL))
+ /* The input byte sequence did not form a complete
+ character. Read another byte and try again. */
+ continue;
+ else
+ return err;
}
else
- output_size = sizeof (utf8_buf) - output_left;
- }
-
- if (SCM_UNLIKELY (output_size == 0))
- /* An unterminated sequence. */
- err = EILSEQ;
- else if (SCM_LIKELY (err == 0))
- {
- /* Convert the UTF8_BUF sequence to a Unicode code point. */
- *codepoint = utf8_to_codepoint (utf8_buf, output_size);
- *len = bytes_consumed;
+ {
+ size_t output_size = sizeof (utf8_buf) - output_left;
+ if (SCM_LIKELY (output_size > 0))
+ {
+ /* iconv generated output. Convert the UTF8_BUF sequence
+ to a Unicode code point. */
+ *codepoint = utf8_to_codepoint (utf8_buf, output_size);
+ *len = input_size;
+ return 0;
+ }
+ else
+ {
+ /* iconv consumed some bytes without producing any output.
+ Most likely this means that a Unicode byte-order mark
+ (BOM) was consumed, which should not be included in the
+ returned buf. Shift any remaining bytes to the beginning
+ of buf, and continue the loop. */
+ memmove (buf, input, input_left);
+ input_size = input_left;
+ continue;
+ }
+ }
}
-
- return err;
}
/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
@@ -1752,16 +1878,35 @@ get_codepoint (SCM port, scm_t_wchar *codepoint,
{
int err;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
- if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
- else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
err = get_latin1_codepoint (port, codepoint, buf, len);
else
err = get_iconv_codepoint (port, codepoint, buf, len);
if (SCM_LIKELY (err == 0))
- update_port_lf (*codepoint, port);
+ {
+ if (SCM_UNLIKELY (pti->at_stream_start_for_bom_read))
+ {
+ /* Record that we're no longer at stream start. */
+ pti->at_stream_start_for_bom_read = 0;
+ if (pt->rw_random)
+ pti->at_stream_start_for_bom_write = 0;
+
+ /* If we just read a BOM in an encoding that recognizes them,
+ then silently consume it and read another code point. */
+ if (SCM_UNLIKELY
+ (*codepoint == SCM_UNICODE_BOM
+ && (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+ || strcmp (pt->encoding, "UTF-16") == 0
+ || strcmp (pt->encoding, "UTF-32") == 0)))
+ return get_codepoint (port, codepoint, buf, len);
+ }
+ update_port_lf (*codepoint, port);
+ }
else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
{
*codepoint = '?';
@@ -1833,52 +1978,28 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
/* Pushback. */
+
-void
-scm_unget_byte_unlocked (int c, SCM port)
-#define FUNC_NAME "scm_unget_byte"
+
+static void
+scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port)
+#define FUNC_NAME "scm_unget_bytes"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t old_len, new_len;
- if (pt->read_buf == pt->putback_buf)
- /* already using the put-back buffer. */
- {
- /* enlarge putback_buf if necessary. */
- if (pt->read_end == pt->read_buf + pt->read_buf_size
- && pt->read_buf == pt->read_pos)
- {
- size_t new_size = pt->read_buf_size * 2;
- unsigned char *tmp = (unsigned char *)
- scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
- "putback buffer");
-
- pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
- pt->read_end = pt->read_buf + pt->read_buf_size;
- pt->read_buf_size = pt->putback_buf_size = new_size;
- }
+ scm_i_clear_pending_eof (port);
- /* shift any existing bytes to buffer + 1. */
- if (pt->read_pos == pt->read_end)
- pt->read_end = pt->read_buf + 1;
- else if (pt->read_pos != pt->read_buf + 1)
- {
- int count = pt->read_end - pt->read_pos;
-
- memmove (pt->read_buf + 1, pt->read_pos, count);
- pt->read_end = pt->read_buf + 1 + count;
- }
-
- pt->read_pos = pt->read_buf;
- }
- else
+ if (pt->read_buf != pt->putback_buf)
/* switch to the put-back buffer. */
{
if (pt->putback_buf == NULL)
{
+ pt->putback_buf_size = (len > SCM_INITIAL_PUTBACK_BUF_SIZE
+ ? len : SCM_INITIAL_PUTBACK_BUF_SIZE);
pt->putback_buf
= (unsigned char *) scm_gc_malloc_pointerless
- (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer");
- pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
+ (pt->putback_buf_size, "putback buffer");
}
pt->saved_read_buf = pt->read_buf;
@@ -1886,27 +2007,97 @@ scm_unget_byte_unlocked (int c, SCM port)
pt->saved_read_end = pt->read_end;
pt->saved_read_buf_size = pt->read_buf_size;
- pt->read_pos = pt->read_buf = pt->putback_buf;
- pt->read_end = pt->read_buf + 1;
+ /* Put read_pos at the end of the buffer, so that ungets will not
+ have to shift the buffer contents each time. */
+ pt->read_buf = pt->putback_buf;
+ pt->read_pos = pt->read_end = pt->putback_buf + pt->putback_buf_size;
pt->read_buf_size = pt->putback_buf_size;
}
- *pt->read_buf = c;
+ old_len = pt->read_end - pt->read_pos;
+ new_len = old_len + len;
+
+ if (new_len > pt->read_buf_size)
+ /* The putback buffer needs to be enlarged. */
+ {
+ size_t new_buf_size;
+ unsigned char *new_buf, *new_end, *new_pos;
+
+ new_buf_size = pt->read_buf_size * 2;
+ if (new_buf_size < new_len)
+ new_buf_size = new_len;
+
+ new_buf = (unsigned char *)
+ scm_gc_malloc_pointerless (new_buf_size, "putback buffer");
+
+ /* Put the bytes at the end of the buffer, so that future
+ ungets won't need to shift the buffer. */
+ new_end = new_buf + new_buf_size;
+ new_pos = new_end - old_len;
+ memcpy (new_pos, pt->read_pos, old_len);
+
+ pt->read_buf = pt->putback_buf = new_buf;
+ pt->read_pos = new_pos;
+ pt->read_end = new_end;
+ pt->read_buf_size = pt->putback_buf_size = new_buf_size;
+ }
+ else if (pt->read_buf + len < pt->read_pos)
+ /* If needed, shift the existing buffer contents up.
+ This should not happen unless some external code
+ manipulates the putback buffer pointers. */
+ {
+ unsigned char *new_end = pt->read_buf + pt->read_buf_size;
+ unsigned char *new_pos = new_end - old_len;
+
+ memmove (new_pos, pt->read_pos, old_len);
+ pt->read_pos = new_pos;
+ pt->read_end = new_end;
+ }
+
+ /* Move read_pos back and copy the bytes there. */
+ pt->read_pos -= len;
+ memcpy (pt->read_buf + (pt->read_pos - pt->read_buf), buf, len);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
}
#undef FUNC_NAME
+void
+scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port)
+{
+ scm_i_unget_bytes_unlocked (buf, len, port);
+}
+
+void
+scm_unget_byte_unlocked (int c, SCM port)
+{
+ unsigned char byte = c;
+ scm_i_unget_bytes_unlocked (&byte, 1, port);
+}
+
+void
+scm_unget_bytes (const unsigned char *buf, size_t len, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_i_unget_bytes_unlocked (buf, len, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+}
+
void
scm_unget_byte (int c, SCM port)
{
+ unsigned char byte = c;
scm_i_pthread_mutex_t *lock;
scm_c_lock_port (port, &lock);
- scm_unget_byte_unlocked (c, port);
+ scm_i_unget_bytes_unlocked (&byte, 1, port);
if (lock)
scm_i_pthread_mutex_unlock (lock);
-
}
void
@@ -1917,7 +2108,6 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port)
char *result;
char result_buf[10];
size_t len;
- int i;
len = sizeof (result_buf);
result = u32_conv_to_encoding (pt->encoding,
@@ -1930,8 +2120,7 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port)
"conversion to port encoding failed",
SCM_BOOL_F, SCM_MAKE_CHAR (c));
- for (i = len - 1; i >= 0; i--)
- scm_unget_byte_unlocked (result[i], port);
+ scm_i_unget_bytes_unlocked ((unsigned char *) result, len, port);
if (SCM_UNLIKELY (result != result_buf))
free (result);
@@ -2010,7 +2199,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
SCM result;
scm_t_wchar c;
char bytes[SCM_MBCHAR_BUF_SIZE];
- long column, line, i;
+ long column, line;
size_t len;
if (SCM_UNBNDP (port))
@@ -2022,8 +2211,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
err = get_codepoint (port, &c, bytes, &len);
- for (i = len - 1; i >= 0; i--)
- scm_unget_byte_unlocked (bytes[i], port);
+ scm_i_unget_bytes_unlocked ((unsigned char *) bytes, len, port);
SCM_COL (port) = column;
SCM_LINUM (port) = line;
@@ -2036,7 +2224,10 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
result = SCM_BOOL_F;
}
else if (c == EOF)
- result = SCM_EOF_VAL;
+ {
+ scm_i_set_pending_eof (port);
+ result = SCM_EOF_VAL;
+ }
else
result = SCM_MAKE_CHAR (c);
@@ -2109,13 +2300,20 @@ scm_port_non_buffer (scm_t_port *pt)
/* this should only be called when the read buffer is empty. it
tries to refill the read buffer. it returns the first char from
the port, which is either EOF or *(pt->read_pos). */
-int
-scm_fill_input_unlocked (SCM port)
+static int
+scm_i_fill_input_unlocked (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
assert (pt->read_pos == pt->read_end);
+ if (pti->pending_eof)
+ {
+ pti->pending_eof = 0;
+ return EOF;
+ }
+
if (pt->read_buf == pt->putback_buf)
{
/* finished reading put-back chars. */
@@ -2144,6 +2342,51 @@ scm_fill_input (SCM port)
return ret;
}
+/* Slow-path fallback for 'scm_get_byte_or_eof_unlocked' */
+int
+scm_slow_get_byte_or_eof_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush_unlocked (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF))
+ return EOF;
+ }
+
+ return *pt->read_pos++;
+}
+
+/* Slow-path fallback for 'scm_peek_byte_or_eof_unlocked' */
+int
+scm_slow_peek_byte_or_eof_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush_unlocked (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF))
+ {
+ scm_i_set_pending_eof (port);
+ return EOF;
+ }
+ }
+
+ return *pt->read_pos;
+}
+
/* Move up to READ_LEN bytes from PORT's putback and/or read buffers
into memory starting at DEST. Return the number of bytes moved.
PORT's line/column numbers are left unchanged. */
@@ -2226,6 +2469,7 @@ scm_end_input_unlocked (SCM port)
long offset;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_i_clear_pending_eof (port);
if (pt->read_buf == pt->putback_buf)
{
offset = pt->read_end - pt->read_pos;
@@ -2290,6 +2534,12 @@ scm_flush (SCM port)
}
+int
+scm_fill_input_unlocked (SCM port)
+{
+ return scm_i_fill_input_unlocked (port);
+}
+
@@ -2499,6 +2749,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
if (SCM_OPPORTP (fd_port))
{
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port);
scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port);
off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
off_t_or_off64_t rv;
@@ -2507,7 +2758,14 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
SCM_MISC_ERROR ("port is not seekable",
scm_cons (fd_port, SCM_EOL));
else
- rv = ptob->seek (fd_port, off, how);
+ rv = ptob->seek (fd_port, off, how);
+
+ /* Set stream-start flags according to new position. */
+ pti->at_stream_start_for_bom_read = (rv == 0);
+ pti->at_stream_start_for_bom_write = (rv == 0);
+
+ scm_i_clear_pending_eof (fd_port);
+
return scm_from_off_t_or_off64_t (rv);
}
else /* file descriptor?. */
@@ -2596,14 +2854,16 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
scm_t_port *pt = SCM_PTAB_ENTRY (object);
scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
-
+
if (!ptob->truncate)
SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+
+ scm_i_clear_pending_eof (object);
if (pt->rw_active == SCM_PORT_READ)
scm_end_input_unlocked (object);
else if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (object);
-
+
ptob->truncate (object, c_length);
rv = 0;
}
diff --git a/libguile/ports.h b/libguile/ports.h
index c1ba719..80644898 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -4,7 +4,7 @@
#define SCM_PORTS_H
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software 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,20 +48,8 @@ typedef enum scm_t_port_rw_active {
SCM_PORT_WRITE = 2
} scm_t_port_rw_active;
-typedef enum scm_t_port_encoding_mode {
- SCM_PORT_ENCODING_MODE_UTF8,
- SCM_PORT_ENCODING_MODE_LATIN1,
- SCM_PORT_ENCODING_MODE_ICONV
-} scm_t_port_encoding_mode;
-
-/* This is a separate object so that only those ports that use iconv
- cause finalizers to be registered. */
-typedef struct scm_t_iconv_descriptors
-{
- /* input/output iconv conversion descriptors */
- void *input_cd;
- void *output_cd;
-} scm_t_iconv_descriptors;
+/* An internal-only structure defined in ports-internal.h. */
+struct scm_port_internal;
/* C representation of a Scheme port. */
@@ -70,6 +58,9 @@ typedef struct
SCM port; /* Link back to the port object. */
scm_i_pthread_mutex_t *lock; /* A recursive lock for this port. */
+ /* pointer to internal-only port structure */
+ struct scm_port_internal *internal;
+
/* data for the underlying port implementation as a raw C value. */
scm_t_bits stream;
@@ -129,13 +120,7 @@ typedef struct
/* Character encoding support */
char *encoding;
- scm_t_port_encoding_mode encoding_mode;
scm_t_string_failed_conversion_handler ilseq_handler;
- scm_t_iconv_descriptors *iconv_descriptors;
-
- /* an alist for storing additional information
- (e.g. used to store per-port read options) */
- SCM alist;
} scm_t_port;
@@ -305,7 +290,6 @@ SCM_INTERNAL scm_t_string_failed_conversion_handler
scm_i_default_port_conversion_handler (void);
SCM_INTERNAL void
scm_i_set_default_port_conversion_handler
(scm_t_string_failed_conversion_handler);
-SCM_INTERNAL scm_t_iconv_descriptors *scm_i_port_iconv_descriptors (SCM port);
SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
SCM_API SCM scm_port_encoding (SCM port);
SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
@@ -320,8 +304,10 @@ SCM_INLINE int scm_c_try_lock_port (SCM port,
scm_i_pthread_mutex_t **lock);
/* Input. */
SCM_API int scm_get_byte_or_eof (SCM port);
SCM_INLINE int scm_get_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_slow_get_byte_or_eof_unlocked (SCM port);
SCM_API int scm_peek_byte_or_eof (SCM port);
SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_slow_peek_byte_or_eof_unlocked (SCM port);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size);
SCM_API scm_t_wchar scm_getc (SCM port);
@@ -329,6 +315,8 @@ SCM_API scm_t_wchar scm_getc_unlocked (SCM port);
SCM_API SCM scm_read_char (SCM port);
/* Pushback. */
+SCM_API void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port);
+SCM_API void scm_unget_bytes_unlocked (const unsigned char *buf, size_t len,
SCM port);
SCM_API void scm_unget_byte (int c, SCM port);
SCM_API void scm_unget_byte_unlocked (int c, SCM port);
SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
@@ -374,6 +362,10 @@ SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
SCM_API SCM scm_port_filename (SCM port);
SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
+/* Port alist. */
+SCM_INTERNAL SCM scm_i_port_alist (SCM port);
+SCM_INTERNAL void scm_i_set_port_alist_x (SCM port, SCM alist);
+
/* Implementation helpers for port printing functions. */
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_print_port_mode (SCM exp, SCM port);
@@ -423,50 +415,26 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t
**lock)
SCM_INLINE_IMPLEMENTATION int
scm_get_byte_or_eof_unlocked (SCM port)
{
- int c;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- /* may be marginally faster than calling scm_flush. */
- SCM_PORT_DESCRIPTOR (port)->flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
- return EOF;
- }
-
- c = *(pt->read_pos++);
-
- return c;
+ if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
+ && pt->read_pos < pt->read_end))
+ return *pt->read_pos++;
+ else
+ return scm_slow_get_byte_or_eof_unlocked (port);
}
/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
SCM_INLINE_IMPLEMENTATION int
scm_peek_byte_or_eof_unlocked (SCM port)
{
- int c;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- /* may be marginally faster than calling scm_flush. */
- SCM_PORT_DESCRIPTOR (port)->flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
- return EOF;
- }
-
- c = *pt->read_pos;
-
- return c;
+ if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
+ && pt->read_pos < pt->read_end))
+ return *pt->read_pos;
+ else
+ return scm_slow_peek_byte_or_eof_unlocked (port);
}
SCM_INLINE_IMPLEMENTATION void
diff --git a/libguile/posix.c b/libguile/posix.c
index b9097d4..822599d 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -32,23 +32,6 @@
# include <sched.h>
#endif
-#include "libguile/_scm.h"
-#include "libguile/dynwind.h"
-#include "libguile/fports.h"
-#include "libguile/scmsigs.h"
-#include "libguile/feature.h"
-#include "libguile/strings.h"
-#include "libguile/srfi-13.h"
-#include "libguile/srfi-14.h"
-#include "libguile/vectors.h"
-#include "libguile/values.h"
-
-#include "libguile/validate.h"
-#include "libguile/posix.h"
-#include "libguile/gettext.h"
-#include "libguile/threads.h"
-
-
#ifdef HAVE_STRING_H
#include <string.h>
#endif
@@ -65,10 +48,6 @@
#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#else
-#ifndef ttyname
-extern char *ttyname();
-#endif
#endif
#ifdef LIBC_H_WITH_UNISTD_H
@@ -85,15 +64,23 @@ extern char *ttyname();
#ifdef HAVE_IO_H
#include <io.h>
#endif
-#ifdef HAVE_WINSOCK2_H
-#include <winsock2.h>
-#endif
-#ifdef __MINGW32__
-/* Some defines for Windows here. */
-# include <process.h>
-# define pipe(fd) _pipe (fd, 256, O_BINARY)
-#endif /* __MINGW32__ */
+#include "libguile/_scm.h"
+#include "libguile/dynwind.h"
+#include "libguile/fports.h"
+#include "libguile/scmsigs.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-14.h"
+#include "libguile/vectors.h"
+#include "libguile/values.h"
+
+#include "libguile/validate.h"
+#include "libguile/posix.h"
+#include "libguile/gettext.h"
+#include "libguile/threads.h"
+
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
@@ -168,6 +155,13 @@ extern char *ttyname();
int sethostname (char *name, size_t namelen);
#endif
+#if defined HAVE_GETLOGIN && !HAVE_DECL_GETLOGIN
+/* MinGW doesn't supply this decl; see
+ http://lists.gnu.org/archive/html/bug-gnulib/2013-03/msg00030.html for more
+ details. */
+char *getlogin (void);
+#endif
+
/* On NextStep, <utime.h> doesn't define struct utime, unless we
#define _POSIX_SOURCE before #including it. I think this is less
of a kludge than defining struct utimbuf ourselves. */
@@ -265,8 +259,10 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
GETGROUPS_T *groups;
ngroups = getgroups (0, NULL);
- if (ngroups <= 0)
+ if (ngroups < 0)
SCM_SYSERROR;
+ else if (ngroups == 0)
+ return scm_c_make_vector (0, SCM_BOOL_F);
size = ngroups * sizeof (GETGROUPS_T);
groups = scm_malloc (size);
@@ -1146,12 +1142,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
exec_argv = scm_i_allocate_string_pointers (args);
- execv (exec_file,
-#ifdef __MINGW32__
- /* extra "const" in mingw formals, provokes warning from gcc */
- (const char * const *)
-#endif
- exec_argv);
+ execv (exec_file, exec_argv);
SCM_SYSERROR;
/* not reached. */
@@ -1180,12 +1171,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
exec_argv = scm_i_allocate_string_pointers (args);
- execvp (exec_file,
-#ifdef __MINGW32__
- /* extra "const" in mingw formals, provokes warning from gcc */
- (const char * const *)
-#endif
- exec_argv);
+ execvp (exec_file, exec_argv);
SCM_SYSERROR;
/* not reached. */
@@ -1219,17 +1205,7 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
exec_argv = scm_i_allocate_string_pointers (args);
exec_env = scm_i_allocate_string_pointers (env);
- execve (exec_file,
-#ifdef __MINGW32__
- /* extra "const" in mingw formals, provokes warning from gcc */
- (const char * const *)
-#endif
- exec_argv,
-#ifdef __MINGW32__
- /* extra "const" in mingw formals, provokes warning from gcc */
- (const char * const *)
-#endif
- exec_env);
+ execve (exec_file, exec_argv, exec_env);
SCM_SYSERROR;
/* not reached. */
@@ -1430,12 +1406,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
close (err);
}
- execvp (exec_file,
-#ifdef __MINGW32__
- /* extra "const" in mingw formals, provokes warning from gcc */
- (const char * const *)
-#endif
- exec_argv);
+ execvp (exec_file, exec_argv);
/* The exec failed! There is nothing sensible to do. */
if (err > 0)
@@ -1636,6 +1607,12 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
struct utimbuf utm;
utm.actime = atim_sec;
utm.modtime = mtim_sec;
+ /* Silence warnings. */
+ (void) atim_nsec;
+ (void) mtim_nsec;
+
+ if (f != 0)
+ scm_out_of_range(FUNC_NAME, flags);
STRING_SYSCALL (pathname, c_pathname,
rv = utime (c_pathname, &utm));
@@ -1920,22 +1897,6 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_CHROOT */
-
-#ifdef __MINGW32__
-/* Wrapper function to supplying `getlogin()' under Windows. */
-static char * getlogin (void)
-{
- static char user[256];
- static unsigned long len = 256;
-
- if (!GetUserName (user, &len))
- return NULL;
- return user;
-}
-#endif /* __MINGW32__ */
-
-
-#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
(void),
"Return a string containing the name of the user logged in on\n"
@@ -1951,7 +1912,6 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
return scm_from_locale_string (p);
}
#undef FUNC_NAME
-#endif /* HAVE_GETLOGIN */
#if HAVE_GETPRIORITY
SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
@@ -2377,6 +2337,7 @@ scm_init_posix ()
#include "libguile/posix.x"
#ifdef HAVE_FORK
+ scm_add_feature ("fork");
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_popen",
(scm_t_extension_init_func) scm_init_popen,
diff --git a/libguile/print.c b/libguile/print.c
index 26e4dfc..50f5a3e 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- * 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2013 Free Software 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,6 +44,7 @@
#include "libguile/alist.h"
#include "libguile/struct.h"
#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
@@ -656,8 +657,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_i_variable_print (exp, port, pstate);
break;
case scm_tc7_rtl_program:
- scm_i_rtl_program_print (exp, port, pstate);
- break;
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
@@ -950,8 +949,24 @@ display_string_using_iconv (const void *str, int narrow_p,
size_t len,
{
size_t printed;
scm_t_iconv_descriptors *id;
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
+
+ id = scm_i_port_iconv_descriptors (port, SCM_PORT_WRITE);
+
+ if (SCM_UNLIKELY (pti->at_stream_start_for_bom_write && len > 0))
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ /* Record that we're no longer at stream start. */
+ pti->at_stream_start_for_bom_write = 0;
+ if (pt->rw_random)
+ pti->at_stream_start_for_bom_read = 0;
- id = scm_i_port_iconv_descriptors (port);
+ /* Write a BOM if appropriate. */
+ if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0
+ || strcmp(pt->encoding, "UTF-32") == 0))
+ display_character (SCM_UNICODE_BOM, port, iconveh_error);
+ }
printed = 0;
@@ -1049,13 +1064,13 @@ display_string (const void *str, int narrow_p,
size_t len, SCM port,
scm_t_string_failed_conversion_handler strategy)
{
- scm_t_port *pt;
+ scm_t_port_internal *pti;
- pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
- if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
return display_string_as_utf8 (str, narrow_p, len, port);
- else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
return display_string_as_latin1 (str, narrow_p, len, port, strategy);
else
return display_string_using_iconv (str, narrow_p, len, port, strategy);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index d37495b..2d9e655 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, 2010,
2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 2012, 2013 Free Software 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
@@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
return 1;
}
- while (!SCM_PROGRAM_P (proc))
+ while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc))
{
@@ -82,14 +82,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
return 1;
}
- else if (SCM_RTL_PROGRAM_P (proc))
- {
- *req = 0;
- *opt = 0;
- *rest = 1;
-
- return 1;
- }
else
return 0;
}
@@ -154,6 +146,8 @@ SCM_DEFINE (scm_procedure_properties,
"procedure-properties", 1, 0, 0,
{
if (SCM_PROGRAM_P (proc))
ret = scm_i_program_properties (proc);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_properties (proc);
else
ret = SCM_EOL;
}
@@ -212,8 +206,99 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
}
#undef FUNC_NAME
+
+SCM_SYMBOL (scm_sym_source, "source");
+
+
+SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+ "Return the name of the procedure @var{proc}")
+#define FUNC_NAME s_scm_procedure_name
+{
+ SCM props, ret;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (props))
+ ret = scm_assq_ref (props, scm_sym_name);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_name (proc);
+ else if (SCM_PROGRAM_P (proc))
+ ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
+ else
+ ret = SCM_BOOL_F;
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and
the\n"
+ "first expression is a string constant, that string is assumed to
contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+ SCM props, ret;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (props))
+ ret = scm_assq_ref (props, scm_sym_documentation);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_documentation (proc);
+ else if (SCM_PROGRAM_P (proc))
+ ret = scm_assq_ref (scm_i_program_properties (proc),
scm_sym_documentation);
+ else
+ ret = SCM_BOOL_F;
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+ "Return the source of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_source
+{
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
+
+ do
+ {
+ src = scm_procedure_property (proc, scm_sym_source);
+ if (scm_is_true (src))
+ return src;
+
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
+ continue;
+ }
+ while (0);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+
void
scm_init_procprop ()
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 88e44ec..41d0753 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011, 2013 Free
Software 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,6 +29,7 @@
SCM_API SCM scm_sym_name;
SCM_API SCM scm_sym_system_procedure;
+SCM_INTERNAL SCM scm_sym_documentation;
@@ -40,6 +41,9 @@ SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key);
SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
+SCM_API SCM scm_procedure_source (SCM proc);
+SCM_API SCM scm_procedure_name (SCM proc);
+SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index bda6d34..8d9ef15 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -66,21 +66,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
-
-SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
- (SCM proc),
- "Return the documentation string associated with @code{proc}. By\n"
- "convention, if a procedure contains more than one expression and
the\n"
- "first expression is a string constant, that string is assumed to
contain\n"
- "documentation for that procedure.")
-#define FUNC_NAME s_scm_procedure_documentation
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, scm_sym_documentation);
-}
-#undef FUNC_NAME
-
/* Procedure-with-setter
*/
diff --git a/libguile/procs.h b/libguile/procs.h
index a35872e..c4c78f2 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -4,7 +4,7 @@
#define SCM_PROCS_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2012 Free Software Foundation, Inc.
+ * 2012, 2013 Free Software 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,15 +30,12 @@
SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_thunk_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);
SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
-SCM_INTERNAL SCM scm_sym_documentation;
-
#endif /* SCM_PROCS_H */
/*
diff --git a/libguile/programs.c b/libguile/programs.c
index 971ea9d..d8dd378 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software 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,14 +99,53 @@ SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2,
0,
}
#undef FUNC_NAME
-void
-scm_i_rtl_program_print (SCM program, SCM port, scm_print_state *pstate)
+SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_rtl_program_code
+{
+ SCM_VALIDATE_RTL_PROGRAM (1, program);
+
+ /* FIXME: we need scm_from_uintptr (). */
+ return scm_from_size_t ((size_t) SCM_RTL_PROGRAM_CODE (program));
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_rtl_program_name (SCM program)
+{
+ static SCM rtl_program_name = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
+ rtl_program_name =
+ scm_c_private_variable ("system vm program", "rtl-program-name");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_name), program);
+}
+
+SCM
+scm_i_rtl_program_documentation (SCM program)
{
- scm_puts_unlocked ("#<rtl-program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc_unlocked (' ', port);
- scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
- scm_putc_unlocked ('>', port);
+ static SCM rtl_program_documentation = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
+ rtl_program_documentation =
+ scm_c_private_variable ("system vm program",
+ "rtl-program-documentation");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
+}
+
+SCM
+scm_i_rtl_program_properties (SCM program)
+{
+ static SCM rtl_program_properties = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
+ rtl_program_properties =
+ scm_c_private_variable ("system vm program", "rtl-program-properties");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_properties), program);
}
void
@@ -115,9 +154,8 @@ scm_i_program_print (SCM program, SCM port, scm_print_state
*pstate)
static int print_error = 0;
if (scm_is_false (write_program) && scm_module_system_booted_p)
- write_program = scm_module_local_variable
- (scm_c_resolve_module ("system vm program"),
- scm_from_latin1_symbol ("write-program"));
+ write_program = scm_c_private_variable ("system vm program",
+ "write-program");
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
@@ -135,9 +173,20 @@ scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate)
}
else if (scm_is_false (write_program) || print_error)
{
- scm_puts_unlocked ("#<program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc_unlocked ('>', port);
+ if (SCM_RTL_PROGRAM_P (program))
+ {
+ scm_puts_unlocked ("#<rtl-program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked (' ', port);
+ scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16,
port);
+ scm_putc_unlocked ('>', port);
+ }
+ else
+ {
+ scm_puts_unlocked ("#<program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked ('>', port);
+ }
}
else
{
@@ -161,6 +210,15 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_rtl_program_p
+{
+ return scm_from_bool (SCM_RTL_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
(SCM program),
"")
@@ -416,11 +474,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest)
*req = *opt = *rest = 0;
}
+static int
+scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
+{
+ static SCM rtl_program_minimum_arity = SCM_BOOL_F;
+ SCM l;
+
+ if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
+ rtl_program_minimum_arity =
+ scm_c_private_variable ("system vm debug",
+ "rtl-program-minimum-arity");
+
+ l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
+ if (scm_is_false (l))
+ return 0;
+
+ *req = scm_to_int (scm_car (l));
+ *opt = scm_to_int (scm_cadr (l));
+ *rest = scm_is_true (scm_caddr (l));
+
+ return 1;
+}
+
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
SCM arities;
+ if (SCM_RTL_PROGRAM_P (program))
+ return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
+
arities = scm_program_arities (program);
if (!scm_is_pair (arities))
return 0;
diff --git a/libguile/programs.h b/libguile/programs.h
index f2d519c..e42a76e 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -32,6 +32,7 @@
#define SCM_RTL_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_RTL_PROGRAM_FREE_VARIABLES
(x)[i])
#define SCM_RTL_PROGRAM_FREE_VARIABLE_SET(x,i,v)
(SCM_RTL_PROGRAM_FREE_VARIABLES (x)[i]=(v))
#define SCM_RTL_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
+#define SCM_VALIDATE_RTL_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, RTL_PROGRAM_P)
static inline SCM
scm_i_make_rtl_program (const scm_t_uint32 *code)
@@ -40,9 +41,12 @@ scm_i_make_rtl_program (const scm_t_uint32 *code)
}
SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM byte_offset, SCM
free_variables);
+SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
+SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
-SCM_INTERNAL void scm_i_rtl_program_print (SCM program, SCM port,
- scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
/*
* Programs
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 60ba38c..c6ad90a 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2013 Free Software 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
@@ -480,16 +480,11 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2,
0, 0,
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
- if ((c_read == 0) && (c_count > 0))
+ if (c_read < c_count)
{
- if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
- result = SCM_EOF_VAL;
+ if (c_read == 0)
+ result = SCM_EOF_VAL;
else
- result = scm_null_bytevector;
- }
- else
- {
- if (c_read < c_count)
result = scm_c_shrink_bytevector (result, c_read);
}
@@ -527,13 +522,8 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!",
4, 0, 0,
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
- if ((c_read == 0) && (c_count > 0))
- {
- if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
- result = SCM_EOF_VAL;
- else
- result = SCM_I_MAKINUM (0);
- }
+ if (c_read == 0 && c_count > 0)
+ result = SCM_EOF_VAL;
else
result = scm_from_size_t (c_read);
@@ -544,69 +534,41 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!",
4, 0, 0,
SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
(SCM port),
- "Read from @var{port}, blocking as necessary, until data "
- "are available or and end-of-file is reached. Return either "
- "a new bytevector containing the data read or the "
- "end-of-file object.")
+ "Read from @var{port}, blocking as necessary, until bytes "
+ "are available or an end-of-file is reached. Return either "
+ "the end-of-file object or a new bytevector containing some "
+ "of the available bytes (at least one), and update the port "
+ "position to point just past these bytes.")
#define FUNC_NAME s_scm_get_bytevector_some
{
- /* Read at least one byte, unless the end-of-file is already reached, and
- read while characters are available (buffered). */
-
- SCM result;
- char *c_bv;
- unsigned c_len;
- size_t c_total;
+ scm_t_port *pt;
+ size_t size;
+ SCM bv;
SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
- c_len = 4096;
- c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
- c_total = 0;
-
- do
- {
- int c_chr;
-
- if (c_total + 1 > c_len)
- {
- /* Grow the bytevector. */
- c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
- SCM_GC_BYTEVECTOR);
- c_len *= 2;
- }
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush_unlocked (port);
- /* We can't use `scm_c_read ()' since it blocks. */
- c_chr = scm_getc_unlocked (port);
- if (c_chr != EOF)
- {
- c_bv[c_total] = (char) c_chr;
- c_total++;
- }
- }
- while ((scm_is_true (scm_char_ready_p (port)))
- && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
- if (c_total == 0)
+ if (pt->read_pos >= pt->read_end)
{
- result = SCM_EOF_VAL;
- scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ if (scm_fill_input_unlocked (port) == EOF)
+ return SCM_EOF_VAL;
}
- else
- {
- if (c_len > c_total)
- {
- /* Shrink the bytevector. */
- c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
- SCM_GC_BYTEVECTOR);
- c_len = (unsigned) c_total;
- }
- result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
- SCM_BOOL_F);
- }
+ size = pt->read_end - pt->read_pos;
+ if (pt->read_buf == pt->putback_buf)
+ size += pt->saved_read_end - pt->saved_read_pos;
- return result;
+ bv = scm_c_make_bytevector (size);
+ scm_take_from_input_buffers
+ (port, (char *) SCM_BYTEVECTOR_CONTENTS (bv), size);
+
+ return bv;
}
#undef FUNC_NAME
@@ -645,7 +607,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all",
1, 0, 0,
c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
c_total += c_read, c_count -= c_read;
}
- while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+ while (c_count == 0);
if (c_total == 0)
{
@@ -737,6 +699,49 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Unget the contents of @var{bv} to @var{port}, optionally "
+ "starting at index @var{start} and limiting to @var{count} "
+ "octets.")
+#define FUNC_NAME s_scm_unget_bytevector
+{
+ unsigned char *c_bv;
+ size_t c_start, c_count, c_len;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (!scm_is_eq (start, SCM_UNDEFINED))
+ {
+ c_start = scm_to_size_t (start);
+
+ if (!scm_is_eq (count, SCM_UNDEFINED))
+ {
+ c_count = scm_to_size_t (count);
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (c_start >= c_len))
+ scm_out_of_range (FUNC_NAME, start);
+ else
+ c_count = c_len - c_start;
+ }
+ }
+ else
+ c_start = 0, c_count = c_len;
+
+ scm_unget_bytes (c_bv + c_start, c_count, port);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
/* Bytevector output port ("bop" for short). */
diff --git a/libguile/random.c b/libguile/random.c
index 2db19f7..c0b04bc 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 Free Software
Foundation, Inc.
+/* Copyright (C) 1999, 2000, 2001, 2003, 2005, 2006, 2009, 2010,
+ * 2012, 2013 Free Software 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
@@ -17,7 +18,7 @@
-/* Author: Mikael Djurfeldt <address@hidden> */
+/* Original Author: Mikael Djurfeldt <address@hidden> */
#ifdef HAVE_CONFIG_H
# include <config.h>
@@ -29,6 +30,12 @@
#include <stdio.h>
#include <math.h>
#include <string.h>
+#include <sys/types.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
#include "libguile/smob.h"
#include "libguile/numbers.h"
#include "libguile/feature.h"
@@ -665,7 +672,8 @@ random_state_of_last_resort (void)
SCM time_of_day = scm_gettimeofday ();
SCM sources = scm_list_n
(scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */
- scm_getpid (), /* process ID */
+ /* Avoid scm_getpid, since it depends on HAVE_POSIX. */
+ scm_from_unsigned_integer (getpid ()), /* process ID */
scm_get_internal_real_time (), /* high-resolution process timer */
scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */
scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */
diff --git a/libguile/read.c b/libguile/read.c
index 7c003b4..c8db812 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -29,6 +29,7 @@
#include <unistd.h>
#include <unicase.h>
#include <unictype.h>
+#include <c-strcase.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
@@ -42,6 +43,7 @@
#include "libguile/hashtab.h"
#include "libguile/hash.h"
#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
@@ -968,7 +970,7 @@ scm_read_character (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
size_t charname_len, bytes_read;
scm_t_wchar cp;
int overflow;
- scm_t_port *pt;
+ scm_t_port_internal *pti;
overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE,
&bytes_read);
@@ -986,14 +988,14 @@ scm_read_character (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
return (SCM_MAKE_CHAR (chr));
}
- pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (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_mode == SCM_PORT_ENCODING_MODE_LATIN1))
+ || pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1))
{
SCM_COL (port) += 1;
return SCM_MAKE_CHAR (buffer[0]);
@@ -1969,7 +1971,6 @@ scm_i_scan_for_encoding (SCM port)
char header[SCM_ENCODING_SEARCH_SIZE+1];
size_t bytes_read, encoding_length, i;
char *encoding = NULL;
- int utf8_bom = 0;
char *pos, *encoding_start;
int in_comment;
@@ -2014,10 +2015,6 @@ scm_i_scan_for_encoding (SCM port)
scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
}
- if (bytes_read > 3
- && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf')
- utf8_bom = 1;
-
/* search past "coding[:=]" */
pos = header;
while (1)
@@ -2083,11 +2080,6 @@ scm_i_scan_for_encoding (SCM port)
/* This wasn't in a comment */
return NULL;
- if (utf8_bom && strcasecmp (encoding, "UTF-8"))
- scm_misc_error (NULL,
- "the port input declares the encoding ~s but is encoded as
UTF-8",
- scm_list_1 (scm_from_locale_string (encoding)));
-
return encoding;
}
@@ -2112,7 +2104,7 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
return SCM_BOOL_F;
else
{
- s_enc = scm_from_locale_string (enc);
+ s_enc = scm_string_upcase (scm_from_locale_string (enc));
return s_enc;
}
@@ -2124,8 +2116,9 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
/* Per-port read options.
We store per-port read options in the 'port-read-options' key of the
- port's alist. The value stored in the alist is a single integer that
- contains a two-bit field for each read option.
+ port's alist, which is stored in the internal port structure. The
+ value stored in the alist is a single integer that contains a two-bit
+ field for each read option.
If a bit field contains READ_OPTION_INHERIT (3), that indicates that
the applicable value should be inherited from the corresponding
@@ -2160,12 +2153,12 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options");
static void
set_port_read_option (SCM port, int option, int new_value)
{
- SCM scm_read_options;
+ SCM alist, scm_read_options;
unsigned int read_options;
new_value &= READ_OPTION_MASK;
- scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->alist,
- sym_port_read_options);
+ alist = scm_i_port_alist (port);
+ scm_read_options = scm_assq_ref (alist, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
else
@@ -2173,9 +2166,8 @@ set_port_read_option (SCM port, int option, int new_value)
read_options &= ~(READ_OPTION_MASK << option);
read_options |= new_value << option;
scm_read_options = scm_from_uint (read_options);
- SCM_PTAB_ENTRY(port)->alist = scm_assq_set_x (SCM_PTAB_ENTRY(port)->alist,
- sym_port_read_options,
- scm_read_options);
+ alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options);
+ scm_i_set_port_alist_x (port, alist);
}
/* Set OPTS and PORT's case-insensitivity according to VALUE. */
@@ -2210,11 +2202,11 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts
*opts, int value)
static void
init_read_options (SCM port, scm_t_read_opts *opts)
{
- SCM val, scm_read_options;
+ SCM alist, val, scm_read_options;
unsigned int read_options, x;
- scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->alist,
- sym_port_read_options);
+ alist = scm_i_port_alist (port);
+ scm_read_options = scm_assq_ref (alist, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index 86fce0f..497da2f 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007,
2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007,
2008, 2009, 2011, 2013 Free Software 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,17 +28,6 @@
#include <stdio.h>
#include <errno.h>
-#include "libguile/_scm.h"
-
-#include "libguile/async.h"
-#include "libguile/eval.h"
-#include "libguile/root.h"
-#include "libguile/vectors.h"
-#include "libguile/threads.h"
-
-#include "libguile/validate.h"
-#include "libguile/scmsigs.h"
-
#ifdef HAVE_PROCESS_H
#include <process.h> /* for mingw */
#endif
@@ -51,16 +40,19 @@
#include <sys/time.h>
#endif
-#ifdef __MINGW32__
-#include <windows.h>
-#define alarm(sec) (0)
-/* This weird comma expression is because Sleep is void under Windows. */
-#define sleep(sec) (Sleep ((sec) * 1000), 0)
-#define usleep(usec) (Sleep ((usec) / 1000), 0)
-#endif
-
#include <full-write.h>
+#include "libguile/_scm.h"
+
+#include "libguile/async.h"
+#include "libguile/eval.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+#include "libguile/threads.h"
+
+#include "libguile/validate.h"
+#include "libguile/scmsigs.h"
+
@@ -526,6 +518,7 @@ SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
}
#undef FUNC_NAME
+#if defined HAVE_ALARM && HAVE_DECL_ALARM
SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
(SCM i),
"Set a timer to raise a @code{SIGALRM} signal after the specified\n"
@@ -541,6 +534,7 @@ SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
return scm_from_uint (alarm (scm_to_uint (i)));
}
#undef FUNC_NAME
+#endif /* HAVE_ALARM */
#ifdef HAVE_SETITIMER
SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
diff --git a/libguile/smob.c b/libguile/smob.c
index c2347f3..857773c 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010,
2011, 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -283,6 +284,10 @@ scm_make_smob (scm_t_bits tc)
/* The GC kind used for SMOB types that provide a custom mark procedure. */
static int smob_gc_kind;
+/* Mark stack pointer and limit, used by `scm_gc_mark'. */
+static scm_i_pthread_key_t current_mark_stack_pointer;
+static scm_i_pthread_key_t current_mark_stack_limit;
+
/* The generic SMOB mark procedure that gets called for SMOBs allocated
with smob_gc_kind. */
@@ -321,14 +326,14 @@ smob_mark (GC_word *addr, struct GC_ms_entry
*mark_stack_ptr,
{
SCM obj;
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
- SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
+ scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
/* Invoke the SMOB's mark procedure, which will in turn invoke
- `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */
+ `scm_gc_mark', which may modify `current_mark_stack_pointer'. */
obj = scm_smobs[smobnum].mark (cell);
- mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
+ mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
if (SCM_HEAP_OBJECT_P (obj))
/* Mark the returned object. */
@@ -336,42 +341,35 @@ smob_mark (GC_word *addr, struct GC_ms_entry
*mark_stack_ptr,
mark_stack_ptr,
mark_stack_limit, NULL);
- SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
+ scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
}
return mark_stack_ptr;
}
-/* Mark object O. We assume that this function is only called during the
- mark phase, i.e., from within `smob_mark ()' or one of its
- descendents. */
+/* Mark object O. We assume that this function is only called during the mark
+ phase, i.e., from within `smob_mark' or one of its descendants. */
void
scm_gc_mark (SCM o)
{
-#define CURRENT_MARK_PTR \
- ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
-#define CURRENT_MARK_LIMIT \
- ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
-
if (SCM_HEAP_OBJECT_P (o))
{
- /* At this point, the `current_mark_*' fields of the current thread
- must be defined (they are set in `smob_mark ()'). */
- register struct GC_ms_entry *mark_stack_ptr;
+ void *mark_stack_ptr, *mark_stack_limit;
- if (!CURRENT_MARK_PTR)
+ mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
+ mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
+
+ if (mark_stack_ptr == NULL)
/* The function was not called from a mark procedure. */
abort ();
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
- CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
+ mark_stack_ptr, mark_stack_limit,
NULL);
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
}
-#undef CURRENT_MARK_PTR
-#undef CURRENT_MARK_LIMIT
}
@@ -452,6 +450,9 @@ scm_smob_prehistory ()
{
long i;
+ scm_i_pthread_key_create (¤t_mark_stack_pointer, NULL);
+ scm_i_pthread_key_create (¤t_mark_stack_limit, NULL);
+
smob_gc_kind = GC_new_kind (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
0,
diff --git a/libguile/socket.c b/libguile/socket.c
index 2320414..7e735f4 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
- * 2006, 2007, 2009, 2011, 2012 Free Software Foundation, Inc.
+ * 2006, 2007, 2009, 2011, 2012, 2013 Free Software 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,26 +25,8 @@
#endif
#include <errno.h>
-#include <gmp.h>
#include <verify.h>
-#include "libguile/_scm.h"
-#include "libguile/arrays.h"
-#include "libguile/feature.h"
-#include "libguile/fports.h"
-#include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/dynwind.h"
-#include "libguile/srfi-13.h"
-
-#include "libguile/validate.h"
-#include "libguile/socket.h"
-
-#ifdef __MINGW32__
-#include "win32-socket.h"
-#include <netdb.h>
-#endif
-
#ifdef HAVE_STDINT_H
#include <stdint.h>
#endif
@@ -55,9 +37,6 @@
#include <unistd.h>
#endif
#include <sys/types.h>
-#ifdef HAVE_WINSOCK2_H
-#include <winsock2.h>
-#else
#include <sys/socket.h>
#ifdef HAVE_UNIX_DOMAIN_SOCKETS
#include <sys/un.h>
@@ -65,8 +44,27 @@
#include <netinet/in.h>
#include <netdb.h>
#include <arpa/inet.h>
+
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/arrays.h"
+#include "libguile/feature.h"
+#include "libguile/fports.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/dynwind.h"
+#include "libguile/srfi-13.h"
+
+#include "libguile/validate.h"
+#include "libguile/socket.h"
+
+#if SCM_ENABLE_DEPRECATED == 1
+# include "libguile/deprecation.h"
#endif
+
+
#if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
#define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
+ strlen ((ptr)->sun_path))
@@ -512,6 +510,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
"@defvarx SO_OOBINLINE\n"
"@defvarx SO_NO_CHECK\n"
"@defvarx SO_PRIORITY\n"
+ "@defvarx SO_REUSEPORT\n"
"The value returned is an integer.\n"
"@end defvar\n"
"\n"
@@ -610,6 +609,7 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
"@defvarx SO_OOBINLINE\n"
"@defvarx SO_NO_CHECK\n"
"@defvarx SO_PRIORITY\n"
+ "@defvarx SO_REUSEPORT\n"
"@var{value} is an integer.\n"
"@end defvar\n"
"\n"
@@ -1767,6 +1767,9 @@ scm_init_socket ()
#ifdef SO_LINGER
scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER));
#endif
+#ifdef SO_REUSEPORT /* new in Linux 3.9 */
+ scm_c_define ("SO_REUSEPORT", scm_from_int (SO_REUSEPORT));
+#endif
/* recv/send options. */
#ifdef MSG_DONTWAIT
@@ -1782,10 +1785,6 @@ scm_init_socket ()
scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE));
#endif
-#ifdef __MINGW32__
- scm_i_init_socket_Win32 ();
-#endif
-
#ifdef IP_ADD_MEMBERSHIP
scm_c_define ("IP_ADD_MEMBERSHIP", scm_from_int (IP_ADD_MEMBERSHIP));
scm_c_define ("IP_DROP_MEMBERSHIP", scm_from_int (IP_DROP_MEMBERSHIP));
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 97c5a1d..4e5d572 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -384,7 +384,7 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
"@item infix\n"
"Insert the separator between list elements. An empty string\n"
"will produce an empty list.\n"
- "@item string-infix\n"
+ "@item strict-infix\n"
"Like @code{infix}, but will raise an error if given the empty\n"
"list.\n"
"@item suffix\n"
@@ -394,91 +394,85 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
"@end table")
#define FUNC_NAME s_scm_string_join
{
-#define GRAM_INFIX 0
-#define GRAM_STRICT_INFIX 1
-#define GRAM_SUFFIX 2
-#define GRAM_PREFIX 3
- SCM tmp;
- SCM result;
- int gram = GRAM_INFIX;
- size_t del_len = 0;
- long strings = scm_ilength (ls);
+ SCM append_list = SCM_EOL;
+ long list_len = scm_ilength (ls);
+ size_t delimiter_len = 0;
/* Validate the string list. */
- if (strings < 0)
+ if (list_len < 0)
SCM_WRONG_TYPE_ARG (1, ls);
/* Validate the delimiter and record its length. */
if (SCM_UNBNDP (delimiter))
{
delimiter = scm_from_locale_string (" ");
- del_len = 1;
+ delimiter_len = 1;
}
else
{
SCM_VALIDATE_STRING (2, delimiter);
- del_len = scm_i_string_length (delimiter);
+ delimiter_len = scm_i_string_length (delimiter);
}
- /* Validate the grammar symbol and remember the grammar. */
+ /* Validate the grammar symbol. */
if (SCM_UNBNDP (grammar))
- gram = GRAM_INFIX;
- else if (scm_is_eq (grammar, scm_sym_infix))
- gram = GRAM_INFIX;
- else if (scm_is_eq (grammar, scm_sym_strict_infix))
- gram = GRAM_STRICT_INFIX;
- else if (scm_is_eq (grammar, scm_sym_suffix))
- gram = GRAM_SUFFIX;
- else if (scm_is_eq (grammar, scm_sym_prefix))
- gram = GRAM_PREFIX;
- else
+ grammar = scm_sym_infix;
+ else if (!(scm_is_eq (grammar, scm_sym_infix)
+ || scm_is_eq (grammar, scm_sym_strict_infix)
+ || scm_is_eq (grammar, scm_sym_suffix)
+ || scm_is_eq (grammar, scm_sym_prefix)))
SCM_WRONG_TYPE_ARG (3, grammar);
- /* Check grammar constraints. */
- if (strings == 0 && gram == GRAM_STRICT_INFIX)
- SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
- SCM_EOL);
+ if (list_len == 0)
+ {
+ if (scm_is_eq (grammar, scm_sym_strict_infix))
+ SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
+ SCM_EOL);
+ else
+ /* Handle empty lists specially */
+ append_list = SCM_EOL;
+ }
+ else if (delimiter_len == 0)
+ /* Handle empty delimiters specially */
+ append_list = ls;
+ else
+ {
+ SCM *last_cdr_p = &append_list;
- result = scm_i_make_string (0, NULL, 0);
+#define ADD_TO_APPEND_LIST(x) \
+ ((*last_cdr_p = scm_list_1 (x)), \
+ (last_cdr_p = SCM_CDRLOC (*last_cdr_p)))
- tmp = ls;
- switch (gram)
- {
- case GRAM_INFIX:
- case GRAM_STRICT_INFIX:
- while (scm_is_pair (tmp))
- {
- result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
- if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
- result = scm_string_append (scm_list_2 (result, delimiter));
- tmp = SCM_CDR (tmp);
- }
- break;
- case GRAM_SUFFIX:
- while (scm_is_pair (tmp))
- {
- result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
- if (del_len > 0)
- result = scm_string_append (scm_list_2 (result, delimiter));
- tmp = SCM_CDR (tmp);
- }
- break;
- case GRAM_PREFIX:
- while (scm_is_pair (tmp))
- {
- if (del_len > 0)
- result = scm_string_append (scm_list_2 (result, delimiter));
- result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
- tmp = SCM_CDR (tmp);
- }
- break;
+ /* Build a list of strings to pass to 'string-append'.
+ Here we assume that 'ls' has at least one element. */
+
+ /* If using the 'prefix' grammar, start with the delimiter. */
+ if (scm_is_eq (grammar, scm_sym_prefix))
+ ADD_TO_APPEND_LIST (delimiter);
+
+ /* Handle the first element of 'ls' specially, so that in the loop
+ that follows we can unconditionally insert the delimiter before
+ every remaining element. */
+ ADD_TO_APPEND_LIST (SCM_CAR (ls));
+ ls = SCM_CDR (ls);
+
+ /* Insert the delimiter before every remaining element. */
+ while (scm_is_pair (ls))
+ {
+ ADD_TO_APPEND_LIST (delimiter);
+ ADD_TO_APPEND_LIST (SCM_CAR (ls));
+ ls = SCM_CDR (ls);
+ }
+
+ /* If using the 'suffix' grammar, add the delimiter to the end. */
+ if (scm_is_eq (grammar, scm_sym_suffix))
+ ADD_TO_APPEND_LIST (delimiter);
+
+#undef ADD_TO_APPEND_LIST
}
- return result;
-#undef GRAM_INFIX
-#undef GRAM_STRICT_INFIX
-#undef GRAM_SUFFIX
-#undef GRAM_PREFIX
+ /* Construct the final result. */
+ return scm_string_append (append_list);
}
#undef FUNC_NAME
diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c
index f59a807..42a1c2c 100644
--- a/libguile/srfi-14.i.c
+++ b/libguile/srfi-14.i.c
@@ -4790,7 +4790,7 @@ scm_t_char_range cs_graphic_ranges[] = {
,
{0x2090, 0x209c}
,
- {0x20a0, 0x20b9}
+ {0x20a0, 0x20ba}
,
{0x20d0, 0x20f0}
,
@@ -5906,7 +5906,7 @@ scm_t_char_range cs_printing_ranges[] = {
,
{0x2090, 0x209c}
,
- {0x20a0, 0x20b9}
+ {0x20a0, 0x20ba}
,
{0x20d0, 0x20f0}
,
@@ -6897,7 +6897,7 @@ scm_t_char_range cs_symbol_ranges[] = {
,
{0x208a, 0x208c}
,
- {0x20a0, 0x20b9}
+ {0x20a0, 0x20ba}
,
{0x2100, 0x2101}
,
@@ -7728,7 +7728,7 @@ scm_t_char_range cs_designated_ranges[] = {
,
{0x2090, 0x209c}
,
- {0x20a0, 0x20b9}
+ {0x20a0, 0x20ba}
,
{0x20d0, 0x20f0}
,
diff --git a/libguile/stime.c b/libguile/stime.c
index 7fdbba9..78539d9 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006,
2007, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006,
2007, 2008, 2009, 2011, 2013 Free Software 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
@@ -68,29 +68,14 @@
# include <time.h>
#endif
-#ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#endif
-
-#ifdef HAVE_STRING_H
+#include <sys/types.h>
#include <string.h>
-#endif
-
-#ifdef HAVE_SYS_TIMES_H
-# include <sys/times.h>
-#endif
+#include <sys/times.h>
#ifdef HAVE_SYS_TIMEB_H
# include <sys/timeb.h>
#endif
-#ifndef tzname /* For SGI. */
-extern char *tzname[]; /* RS6000 and others reject char **tzname. */
-#endif
-#if defined (__MINGW32__)
-# define tzname _tzname
-#endif
-
#if ! HAVE_DECL_STRPTIME
extern char *strptime ();
#endif
@@ -177,7 +162,6 @@ get_internal_real_time_gettimeofday (void)
#endif
-#if defined HAVE_TIMES
static long ticks_per_second;
static long
@@ -188,7 +172,6 @@ get_internal_run_time_times (void)
return (time_buffer.tms_utime + time_buffer.tms_stime)
* TIME_UNITS_PER_SECOND / ticks_per_second;
}
-#endif
static timet fallback_real_time_base;
static long
@@ -210,7 +193,6 @@ SCM_DEFINE (scm_get_internal_real_time,
"get-internal-real-time", 0, 0, 0,
#undef FUNC_NAME
-#ifdef HAVE_TIMES
SCM_DEFINE (scm_times, "times", 0, 0, 0,
(void),
"Return an object with information about real and processor\n"
@@ -261,7 +243,6 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0,
return result;
}
#undef FUNC_NAME
-#endif /* HAVE_TIMES */
long
scm_c_get_internal_run_time (void)
@@ -876,7 +857,6 @@ scm_init_stime()
/* Init ticks_per_second for scm_times, and use times(2)-based
run-time timer if needed. */
-#ifdef HAVE_TIMES
#ifdef _SC_CLK_TCK
ticks_per_second = sysconf (_SC_CLK_TCK);
#else
@@ -884,7 +864,6 @@ scm_init_stime()
#endif
if (!get_internal_run_time)
get_internal_run_time = get_internal_run_time_times;
-#endif
if (!get_internal_real_time)
/* No POSIX timers, gettimeofday doesn't work... badness! */
@@ -893,10 +872,6 @@ scm_init_stime()
get_internal_real_time = get_internal_real_time_fallback;
}
- /* If we don't have a run-time timer, use real-time. */
- if (!get_internal_run_time)
- get_internal_run_time = get_internal_real_time;
-
scm_add_feature ("current-time");
#include "libguile/stime.x"
}
diff --git a/libguile/strings.c b/libguile/strings.c
index 85a6c48..fa97a00 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -29,6 +29,7 @@
#include <uninorm.h>
#include <unistr.h>
#include <uniconv.h>
+#include <c-strcase.h>
#include "striconveh.h"
@@ -36,6 +37,8 @@
#include "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/error.h"
#include "libguile/generalized-vectors.h"
#include "libguile/deprecation.h"
@@ -1401,7 +1404,8 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
#define FUNC_NAME s_scm_string_append
{
SCM res;
- size_t len = 0;
+ size_t total = 0;
+ size_t len;
int wide = 0;
SCM l, s;
size_t i;
@@ -1416,15 +1420,18 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
- len += scm_i_string_length (s);
+ len = scm_i_string_length (s);
+ if (((size_t) -1) - total < len)
+ scm_num_overflow (s_scm_string_append);
+ total += len;
if (!scm_i_is_narrow_string (s))
wide = 1;
}
data.narrow = NULL;
if (!wide)
- res = scm_i_make_string (len, &data.narrow, 0);
+ res = scm_i_make_string (total, &data.narrow, 0);
else
- res = scm_i_make_wide_string (len, &data.wide, 0);
+ res = scm_i_make_wide_string (total, &data.wide, 0);
for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
@@ -1432,6 +1439,8 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
len = scm_i_string_length (s);
+ if (len > total)
+ SCM_MISC_ERROR ("list changed during string-append", SCM_EOL);
if (!wide)
{
memcpy (data.narrow, scm_i_string_chars (s), len);
@@ -1441,16 +1450,20 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
{
if (scm_i_is_narrow_string (s))
{
- for (i = 0; i < scm_i_string_length (s); i++)
- data.wide[i] = (unsigned char) scm_i_string_chars (s)[i];
+ const char *src = scm_i_string_chars (s);
+ for (i = 0; i < len; i++)
+ data.wide[i] = (unsigned char) src[i];
}
else
u32_cpy ((scm_t_uint32 *) data.wide,
(scm_t_uint32 *) scm_i_string_wide_chars (s), len);
data.wide += len;
}
+ total -= len;
scm_remember_upto_here_1 (s);
}
+ if (total != 0)
+ SCM_MISC_ERROR ("list changed during string-append", SCM_EOL);
return res;
}
#undef FUNC_NAME
@@ -1524,9 +1537,9 @@ scm_from_stringn (const char *str, size_t len, const char
*encoding,
if (len == (size_t) -1)
len = strlen (str);
- if (strcmp (encoding, "ISO-8859-1") == 0 || len == 0)
+ if (c_strcasecmp (encoding, "ISO-8859-1") == 0 || len == 0)
return scm_from_latin1_stringn (str, len);
- else if (strcmp (encoding, "UTF-8") == 0
+ else if (c_strcasecmp (encoding, "UTF-8") == 0
&& handler == SCM_FAILED_CONVERSION_ERROR)
return scm_from_utf8_stringn (str, len);
@@ -1722,10 +1735,11 @@ SCM
scm_from_port_stringn (const char *str, size_t len, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
- if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
return scm_from_latin1_stringn (str, len);
- else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
&& pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
return scm_from_utf8_stringn (str, len);
else
@@ -2127,11 +2141,12 @@ char *
scm_to_port_stringn (SCM str, size_t *lenp, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
- if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
&& pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
return scm_to_latin1_stringn (str, lenp);
- else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
return scm_to_utf8_stringn (str, lenp);
else
return scm_to_stringn (str, lenp, pt->encoding, pt->ilseq_handler);
@@ -2170,7 +2185,8 @@ scm_to_stringn (SCM str, size_t *lenp, const char
*encoding,
"string contains #\\nul character: ~S",
scm_list_1 (str));
- if (scm_i_is_narrow_string (str) && strcmp (encoding, "ISO-8859-1") == 0)
+ if (scm_i_is_narrow_string (str)
+ && c_strcasecmp (encoding, "ISO-8859-1") == 0)
{
/* If using native Latin-1 encoding, just copy the string
contents. */
diff --git a/libguile/strports.c b/libguile/strports.c
index 425b089..40f656e 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -464,13 +464,16 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1,
1, 0,
"procedure returns.")
#define FUNC_NAME s_scm_eval_string_in_module
{
- static SCM eval_string = SCM_BOOL_F, k_module = SCM_BOOL_F;
+ static SCM eval_string = SCM_UNDEFINED, k_module = SCM_UNDEFINED;
+ static scm_i_pthread_mutex_t init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
- if (scm_is_false (eval_string))
+ scm_i_scm_pthread_mutex_lock (&init_mutex);
+ if (SCM_UNBNDP (eval_string))
{
- eval_string = scm_c_public_lookup ("ice-9 eval-string", "eval-string");
+ eval_string = scm_c_public_variable ("ice-9 eval-string", "eval-string");
k_module = scm_from_locale_keyword ("module");
}
+ scm_i_pthread_mutex_unlock (&init_mutex);
if (SCM_UNBNDP (module))
module = scm_current_module ();
diff --git a/libguile/struct.c b/libguile/struct.c
index db79e79..c7f410b 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008,
2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
+ * 2008, 2009, 2010, 2011, 2012, 2013 Free Software 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
@@ -152,8 +153,9 @@ 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. */
+/* Check whether VTABLE instances have a simple layout (i.e., either
+ only "pr" or only "pw" fields and no tail array) and update its flags
+ accordingly. */
static void
set_vtable_layout_flags (SCM vtable)
{
@@ -179,13 +181,11 @@ set_vtable_layout_flags (SCM vtable)
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;
diff --git a/libguile/struct.h b/libguile/struct.h
index 97b6768..0aecfb9 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011,
2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011,
2012, 2013 Free Software 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
@@ -108,8 +108,8 @@
#define SCM_VTABLE_FLAG_APPLICABLE (1L << 3) /* instances of this vtable are
applicable? */
#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 4) /* instances of this vtable
are applicable-with-setter vtables? */
#define SCM_VTABLE_FLAG_SETTER (1L << 5) /* instances of this vtable are
applicable-with-setters? */
-#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only
"p" fields */
-#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have
only "pw" fields */
+#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only
"p" fields and no tail array*/
+#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have
only "pw" fields and no tail array */
#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8)
#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9)
#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 10)
diff --git a/libguile/texi-fragments-to-docstrings
b/libguile/texi-fragments-to-docstrings
new file mode 100644
index 0000000..b72390b
--- /dev/null
+++ b/libguile/texi-fragments-to-docstrings
@@ -0,0 +1,55 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2013 Free Software 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
+
+
+;;;
+;;; Read Texinfo fragments from stdin (docstrings of Guile's primitives
+;;; in the format of `guile-procedures.texi'), and write to stdout a
+;;; textual rendering thereof. The output preserves page breaks (^L)
+;;; found in the input, as per the Guile Documentation Format
+;;; version 2---see (ice-9 documentation).
+;;;
+
+(use-modules (texinfo)
+ (texinfo plain-text)
+ (srfi srfi-1)
+ (ice-9 match)
+ (rnrs io ports))
+
+(define (docstring-fragments->strings str)
+ "Return the list resulting from the split of STR at each page
+break (^L)"
+ (string-tokenize str (char-set-complement (char-set #\page))))
+
+(match (command-line)
+ ((_ texi-file)
+ (let* ((fragments (remove (compose string-null? string-trim-both)
+ (call-with-input-file texi-file
+ (compose docstring-fragments->strings
+ get-string-all))))
+ (stexi (map texi-fragment->stexi fragments)))
+ (format #t "Produced by GNU Guile ~a from `~a'.~%~%"
+ (version) texi-file)
+ (for-each (lambda (stexi)
+ (display #\page)
+ (display (stexi->plain-text stexi)))
+ stexi)))
+ ((command args ...)
+ (format (current-error-port) "invalid arguments: ~s~%" args)
+ (format (current-error-port) "Usage: ~a TEXINFO-FILE~%" command)
+ (exit 1)))
diff --git a/libguile/threads.c b/libguile/threads.c
index 61fc43e..ef771dc 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
- * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+ * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -45,6 +45,8 @@
# include <pthread_np.h>
#endif
+#include <sys/select.h>
+
#include <assert.h>
#include <fcntl.h>
#include <nproc.h>
@@ -1057,7 +1059,10 @@ SCM_DEFINE (scm_call_with_new_thread,
"call-with-new-thread", 1, 1, 0,
errno = err;
scm_syserror (NULL);
}
- scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+
+ while (scm_is_false (data.thread))
+ scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+
scm_i_pthread_mutex_unlock (&data.mutex);
return data.thread;
@@ -1134,7 +1139,10 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
errno = err;
scm_syserror (NULL);
}
- scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+
+ while (scm_is_false (data.thread))
+ scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+
scm_i_pthread_mutex_unlock (&data.mutex);
assert (SCM_I_IS_THREAD (data.thread));
@@ -1867,9 +1875,9 @@ SCM_DEFINE (scm_condition_variable_p,
"condition-variable?", 1, 0, 0,
struct select_args
{
int nfds;
- SELECT_TYPE *read_fds;
- SELECT_TYPE *write_fds;
- SELECT_TYPE *except_fds;
+ fd_set *read_fds;
+ fd_set *write_fds;
+ fd_set *except_fds;
struct timeval *timeout;
int result;
@@ -1892,11 +1900,19 @@ do_std_select (void *args)
return NULL;
}
+#if !SCM_HAVE_SYS_SELECT_H
+static int scm_std_select (int nfds,
+ fd_set *readfds,
+ fd_set *writefds,
+ fd_set *exceptfds,
+ struct timeval *timeout);
+#endif
+
int
scm_std_select (int nfds,
- SELECT_TYPE *readfds,
- SELECT_TYPE *writefds,
- SELECT_TYPE *exceptfds,
+ fd_set *readfds,
+ fd_set *writefds,
+ fd_set *exceptfds,
struct timeval *timeout)
{
fd_set my_readfds;
diff --git a/libguile/threads.h b/libguile/threads.h
index 3030f6f..147e36d 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -3,7 +3,8 @@
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008,
2009, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006,
+ * 2007, 2008, 2009, 2011, 2012, 2013 Free Software 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,8 +72,8 @@ typedef struct scm_i_thread {
scm_i_pthread_cond_t sleep_cond;
int sleep_fd, sleep_pipe[2];
- /* Information about the Boehm-GC mark stack during the mark phase. This
- is used by `scm_gc_mark ()'. */
+ /* XXX: These two fields used to hold information about the BDW-GC
+ mark stack during the mark phase. They are no longer used. */
void *current_mark_stack_ptr;
void *current_mark_stack_limit;
diff --git a/libguile/uniform.c b/libguile/uniform.c
index d3ecb1b..a58242d 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2013 Free Software 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
@@ -193,7 +193,7 @@ SCM_DEFINE (scm_uniform_vector_to_list,
"uniform-vector->list", 1, 0, 0,
{
if (!scm_is_uniform_vector (uvec))
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
- return scm_generalized_vector_to_list (uvec);
+ return scm_array_to_list (uvec);
}
#undef FUNC_NAME
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 44687e2..3def7a3 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -519,7 +519,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#undef VM_CHECK_UNDERFLOW
#undef VM_DEFINE_OP
#undef VM_INSTRUCTION_TO_LABEL
-#undef VM_USE_HOOKS
@@ -581,6 +580,11 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
vp->sp = fp - 1 + n; \
} while (0)
+/* Compute the number of locals in the frame. This is equal to the
+ number of actual arguments when a function is first called. */
+#define FRAME_LOCALS_COUNT() \
+ (vp->sp + 1 - fp)
+
/* Restore registers after returning from a frame. */
#define RESTORE_FRAME() \
do { \
@@ -660,8 +664,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
fp[-1] = rtl_apply; \
fp[0] = rtl_values; \
fp[1] = vals; \
- nargs = 2; \
- RESET_FRAME (nargs); \
+ RESET_FRAME (2); \
ip = (scm_t_uint32 *) rtl_apply_code; \
goto op_apply; \
} while (0)
@@ -669,7 +672,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#define BR_NARGS(rel) \
scm_t_uint16 expected; \
SCM_UNPACK_RTL_24 (op, expected); \
- if (nargs rel expected) \
+ if (FRAME_LOCALS_COUNT() rel expected) \
{ \
scm_t_int32 offset = ip[1]; \
offset >>= 8; /* Sign-extending shift. */ \
@@ -803,10 +806,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
/* Current opcode: A cache of *ip. */
register scm_t_uint32 op;
- /* Number of arguments passed to a function. When we get native
- compilation, this will be part of a the calling convention. */
- scm_t_uint32 nargs = 0;
-
/* Cached variables. */
struct scm_vm *vp = SCM_VM_DATA (vm);
SCM *stack_limit = vp->stack_limit; /* stack limit address */
@@ -845,7 +844,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
to pull all our state back from the ip/fp/sp.
*/
CACHE_REGISTER ();
- ABORT_CONTINUATION_HOOK (fp, vp->sp + 1 - fp);
+ ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT());
NEXT (0);
}
@@ -862,15 +861,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
continuation, 4 + nargs for the procedure application, and 4 for
setting up a new frame. */
base = vp->sp + 1;
- nargs = nargs_;
- CHECK_OVERFLOW (vp->sp + 4 + 4 + nargs + 4);
+ CHECK_OVERFLOW (vp->sp + 4 + 4 + nargs_ + 4);
/* Since it's possible to receive the arguments on the stack itself,
and indeed the regular VM invokes us that way, shuffle up the
arguments first. */
{
int i;
- for (i = nargs - 1; i >= 0; i--)
+ for (i = nargs_ - 1; i >= 0; i--)
base[8 + i] = argv[i];
}
@@ -891,7 +889,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
base[6] = SCM_PACK (ip); /* ra */
base[7] = program;
fp = vp->fp = &base[8];
- RESET_FRAME (nargs);
+ RESET_FRAME (nargs_);
}
apply:
@@ -907,13 +905,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
}
if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
{
- scm_t_uint32 n = nargs;
+ scm_t_uint32 n = FRAME_LOCALS_COUNT();
/* Shuffle args up, place smob in local 0. */
+ CHECK_OVERFLOW (vp->sp + 1);
+ vp->sp++;
while (n--)
LOCAL_SET (n + 1, LOCAL_REF (n));
LOCAL_SET (0, proc);
- nargs++;
fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
continue;
@@ -925,7 +924,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM ret;
SYNC_ALL ();
- ret = VM_NAME (vm, fp[-1], fp, nargs);
+ ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT ());
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
@@ -975,7 +974,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SYNC_BEFORE_GC();
base = fp + 4;
- n = vp->sp + 1 - base;
+ n = FRAME_LOCALS_COUNT ();
while (n--)
ret = scm_cons (base[n], ret);
@@ -1000,7 +999,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
*/
VM_DEFINE_OP (2, call, "call", OP3 (U8_U24, X8_U24, X8_R24))
{
- scm_t_uint32 from, proc, n;
+ scm_t_uint32 from, proc, nargs, n;
SCM *old_fp = fp;
SCM_UNPACK_RTL_24 (op, from);
@@ -1032,9 +1031,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* call/values from:24 _:8 proc:24
*
* Call a procedure, with the values already pushed above a call frame
- * at FROM. The stack pointer is used to set the nargs. This
- * instruction is used to handle MV returns in the case that we can't
- * inline the handler.
+ * at FROM. This instruction is used to handle MV returns in the case
+ * that we can't inline the handler.
*
* As with `call', the next instruction after the call/values will be
* the MVRA, and the word after that instruction is the RA.
@@ -1051,10 +1049,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
fp = vp->fp = old_fp + from + 4;
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2 + nargs);
- SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3 + nargs);
+ SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
+ SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3);
fp[-1] = old_fp[proc];
- nargs = vp->sp - fp;
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
@@ -1073,7 +1070,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*/
VM_DEFINE_OP (4, tail_call, "tail-call", OP2 (U8_U24, X8_U24))
{
- scm_t_uint32 proc;
+ scm_t_uint32 nargs, proc;
SCM_UNPACK_RTL_24 (op, nargs);
SCM_UNPACK_RTL_24 (ip[1], proc);
@@ -1110,12 +1107,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Return a number of values from a call frame. This opcode
* corresponds to an application of `values' in tail position. As
* with tail calls, we expect that the NVALUES values have already
- * been shuffled down to a contiguous array starting ast slot 0.
+ * been shuffled down to a contiguous array starting at slot 0.
*/
VM_DEFINE_OP (6, return_values, "return/values", OP1 (U8_U24))
{
+ scm_t_uint32 nargs;
SCM_UNPACK_RTL_24 (op, nargs);
- RESET_FRAME(nargs);
+ RESET_FRAME (nargs);
fp[-1] = rtl_values;
goto op_values;
}
@@ -1127,21 +1125,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Specialized call stubs
*/
- /* subr-call nargs:12 ptr-idx:12
+ /* subr-call ptr-idx:24
*
- * Call a subr. Fetch the foreign pointer from PTR-IDX, a free
- * variable. Return from the calling frame. We assume that the
- * arguments are on the stack from slot 0 to NARGS-1. This instruction
- * is part of the trampolines created in gsubr.c, and is not generated
- * by the compiler.
+ * Call a subr, passing all locals in this frame as arguments. Fetch
+ * the foreign pointer from PTR-IDX, a free variable. Return from the
+ * calling frame. This instruction is part of the trampolines
+ * created in gsubr.c, and is not generated by the compiler.
*/
- VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
{
- scm_t_uint16 nargs, ptr_idx;
+ scm_t_uint32 ptr_idx;
SCM pointer, ret;
SCM (*subr)();
- SCM_UNPACK_RTL_12_12 (op, nargs, ptr_idx);
+ SCM_UNPACK_RTL_24 (op, ptr_idx);
pointer = FREE_VARIABLE_REF (ptr_idx);
subr = SCM_POINTER_VALUE (pointer);
@@ -1149,7 +1146,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
VM_HANDLE_INTERRUPTS;
SYNC_IP ();
- switch (nargs)
+ switch (FRAME_LOCALS_COUNT ())
{
case 0:
ret = subr ();
@@ -1197,20 +1194,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
RETURN_ONE_VALUE (ret);
}
- /* foreign-call nargs:8 cif-idx:8 ptr-idx:8
+ /* foreign-call cif-idx:12 ptr-idx:12
*
- * Call a subr. Fetch the CIF and foreign pointer from CIF-IDX and
- * PTR-IDX, both free variables. Return from the calling frame. We
- * assume that the arguments are on the stack from slot 0 to NARGS-1.
- * This instruction is part of the trampolines created by the FFI, and
- * is not generated by the compiler.
+ * Call a foreign function. Fetch the CIF and foreign pointer from
+ * CIF-IDX and PTR-IDX, both free variables. Return from the calling
+ * frame. Arguments are taken from the stack. This instruction is
+ * part of the trampolines created by the FFI, and is not generated by
+ * the compiler.
*/
- VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{
- scm_t_uint8 cif_idx, ptr_idx;
+ scm_t_uint16 cif_idx, ptr_idx;
SCM cif, pointer, ret;
- SCM_UNPACK_RTL_8_8_8 (op, nargs, cif_idx, ptr_idx);
+ SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
cif = FREE_VARIABLE_REF (cif_idx);
pointer = FREE_VARIABLE_REF (ptr_idx);
@@ -1230,21 +1227,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
RETURN_ONE_VALUE (ret);
}
- /* continuation-call nargs:24 _:8 contregs:24
+ /* continuation-call contregs:24
*
- * Return to a continuation, nonlocally. The NARGS values are taken
- * from the stack, from slots 0 to NARGS-1. CONTREGS is a free variable
- * containing the reified continuation. This instruction is part of the
- * implementation of undelimited continuations, and is not generated by
- * the compiler.
+ * Return to a continuation, nonlocally. The arguments to the
+ * continuation are taken from the stack. CONTREGS is a free variable
+ * containing the reified continuation. This instruction is part of
+ * the implementation of undelimited continuations, and is not
+ * generated by the compiler.
*/
- VM_DEFINE_OP (9, continuation_call, "continuation-call", OP2 (U8_U24,
X8_U24))
+ VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
{
SCM contregs;
scm_t_uint32 contregs_idx;
- SCM_UNPACK_RTL_24 (op, nargs);
- SCM_UNPACK_RTL_24 (ip[1], contregs_idx);
+ SCM_UNPACK_RTL_24 (op, contregs_idx);
contregs = FREE_VARIABLE_REF (contregs_idx);
@@ -1252,34 +1248,33 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
scm_i_check_continuation (contregs);
vm_return_to_continuation (scm_i_contregs_vm (contregs),
scm_i_contregs_vm_cont (contregs),
- nargs, fp);
+ FRAME_LOCALS_COUNT (), fp);
scm_i_reinstate_continuation (contregs);
/* no NEXT */
abort ();
}
- /* partial-cont nargs:24 _:8 cont:24
+ /* compose-continuation cont:24
*
* Compose a partial continution with the current continuation. The
- * NARGS values are taken from the stack, from slots 0 to NARGS-1. CONT
- * is a free variable containing the reified continuation. This
+ * arguments to the continuation are taken from the stack. CONT is a
+ * free variable containing the reified continuation. This
* instruction is part of the implementation of partial continuations,
* and is not generated by the compiler.
*/
- VM_DEFINE_OP (10, partial_cont_call, "partial-cont-call", OP2 (U8_U24,
X8_U24))
+ VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
{
SCM vmcont;
scm_t_uint32 cont_idx;
- SCM_UNPACK_RTL_24 (op, nargs);
- SCM_UNPACK_RTL_24 (ip[1], cont_idx);
+ SCM_UNPACK_RTL_24 (op, cont_idx);
vmcont = LOCAL_REF (cont_idx);
SYNC_IP ();
VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
vm_error_continuation_not_rewindable (vmcont));
- vm_reinstate_partial_continuation (vm, vmcont, nargs, fp,
+ vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT (), fp,
¤t_thread->dynstack,
®isters);
CACHE_REGISTER ();
@@ -1294,12 +1289,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*/
VM_DEFINE_OP (11, apply, "apply", OP1 (U8_X24))
{
- int i, list_idx, list_len;
+ int i, list_idx, list_len, nargs;
SCM list;
VM_HANDLE_INTERRUPTS;
- VM_ASSERT (nargs >= 2, abort ());
+ VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
+ nargs = FRAME_LOCALS_COUNT ();
list_idx = nargs - 1;
list = LOCAL_REF (list_idx);
list_len = scm_ilength (list);
@@ -1356,8 +1352,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
fp[-1] = fp[0];
fp[0] = cont;
- nargs = 1;
- RESET_FRAME (nargs);
+ RESET_FRAME (1);
APPLY_HOOK ();
@@ -1380,6 +1375,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
VM_DEFINE_OP (13, values, "values", OP1 (U8_X24))
{
SCM *base = fp;
+#if VM_USE_HOOKS
+ int nargs = FRAME_LOCALS_COUNT ();
+#endif
/* We don't do much; it's the caller that's responsible for
shuffling values and resetting the stack. */
@@ -1429,22 +1427,36 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* assert-nargs-ee expected:24
* assert-nargs-ge expected:24
+ * assert-nargs-le expected:24
*
- * If the number of actual arguments is not == or >= to EXPECTED,
+ * If the number of actual arguments is not ==, >=, or <= EXPECTED,
* respectively, signal an error.
*/
VM_DEFINE_OP (17, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
- VM_ASSERT (nargs == expected, vm_error_wrong_num_args (vm,
SCM_FRAME_PROGRAM (fp), nargs));
+ VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
+ vm_error_wrong_num_args (vm, SCM_FRAME_PROGRAM (fp),
+ FRAME_LOCALS_COUNT ()));
NEXT (1);
}
VM_DEFINE_OP (18, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
- VM_ASSERT (nargs >= expected, vm_error_wrong_num_args (vm,
SCM_FRAME_PROGRAM (fp), nargs));
+ VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
+ vm_error_wrong_num_args (vm, SCM_FRAME_PROGRAM (fp),
+ FRAME_LOCALS_COUNT ()));
+ NEXT (1);
+ }
+ VM_DEFINE_OP (19, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ {
+ scm_t_uint32 expected;
+ SCM_UNPACK_RTL_24 (op, expected);
+ VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
+ vm_error_wrong_num_args (vm, SCM_FRAME_PROGRAM (fp),
+ FRAME_LOCALS_COUNT ()));
NEXT (1);
}
@@ -1454,11 +1466,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* setting them all to SCM_UNDEFINED, except those nargs values that
* were passed as arguments.
*/
- VM_DEFINE_OP (19, reserve_locals, "reserve-locals", OP1 (U8_U24))
+ VM_DEFINE_OP (20, reserve_locals, "reserve-locals", OP1 (U8_U24))
{
- scm_t_uint32 nlocals;
+ scm_t_uint32 nlocals, nargs;
SCM_UNPACK_RTL_24 (op, nlocals);
+ nargs = FRAME_LOCALS_COUNT ();
ALLOC_FRAME (nlocals);
while (nlocals-- > nargs)
LOCAL_SET (nlocals, SCM_UNDEFINED);
@@ -1471,12 +1484,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS.
*/
- VM_DEFINE_OP (20, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1
(U8_U12_U12))
+ VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1
(U8_U12_U12))
{
scm_t_uint16 expected, nlocals;
SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
- VM_ASSERT (nargs == expected, vm_error_wrong_num_args (vm,
SCM_FRAME_PROGRAM (fp), nargs));
+ VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
+ vm_error_wrong_num_args (vm, SCM_FRAME_PROGRAM (fp),
+ FRAME_LOCALS_COUNT ()));
ALLOC_FRAME (expected + nlocals);
while (nlocals--)
LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
@@ -1496,9 +1511,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (21, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24,
N32))
+ VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24,
N32))
{
- scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n;
+ scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
scm_t_int32 kw_offset;
scm_t_bits kw_bits;
SCM kw;
@@ -1514,6 +1529,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
VM_ASSERT (!(kw_bits & 0x7), abort());
kw = SCM_PACK (kw_bits);
+ nargs = FRAME_LOCALS_COUNT ();
+
/* look in optionals for first keyword or last positional */
/* starting after the last required positional arg */
npositional = nreq;
@@ -1578,12 +1595,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Collect any arguments at or above DST into a list, and store that
* list at DST.
*/
- VM_DEFINE_OP (22, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
{
- scm_t_uint32 dst;
+ scm_t_uint32 dst, nargs;
SCM rest = SCM_EOL;
SCM_UNPACK_RTL_24 (op, dst);
+ nargs = FRAME_LOCALS_COUNT ();
while (nargs-- > dst)
{
@@ -1603,13 +1621,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Reset the stack pointer to only have space for NLOCALS values.
* Used after extracting values from an MV return.
*/
- VM_DEFINE_OP (23, drop_values, "drop-values", OP1 (U8_U24))
+ VM_DEFINE_OP (24, drop_values, "drop-values", OP1 (U8_U24))
{
scm_t_bits nlocals;
SCM_UNPACK_RTL_24 (op, nlocals);
- RESET_FRAME(nlocals);
+ RESET_FRAME (nlocals);
NEXT (1);
}
@@ -1626,7 +1644,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Add OFFSET, a signed 24-bit number, to the current instruction
* pointer.
*/
- VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
+ VM_DEFINE_OP (25, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
@@ -1638,7 +1656,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is true for the purposes of Scheme, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, U1_X7_L24))
+ VM_DEFINE_OP (26, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
@@ -1648,7 +1666,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
* signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, U1_X7_L24))
+ VM_DEFINE_OP (27, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
@@ -1658,7 +1676,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, U1_X7_L24))
+ VM_DEFINE_OP (28, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
@@ -1668,7 +1686,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, U1_X7_L24))
+ VM_DEFINE_OP (29, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
@@ -1678,7 +1696,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a struct, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, U1_X7_L24))
+ VM_DEFINE_OP (30, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
@@ -1688,7 +1706,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a char, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, U1_X7_L24))
+ VM_DEFINE_OP (31, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
@@ -1698,7 +1716,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST has the TC7 given in the second word, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, U1_U7_L24))
+ VM_DEFINE_OP (32, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
@@ -1708,7 +1726,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is eq? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, U1_X7_L24))
+ VM_DEFINE_OP (33, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
@@ -1718,7 +1736,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is eqv? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, U1_X7_L24))
+ VM_DEFINE_OP (34, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1732,7 +1750,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* 24-bit number, to the current instruction pointer.
*/
// FIXME: should sync_ip before calling out?
- VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, U1_X7_L24))
+ VM_DEFINE_OP (35, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1745,7 +1763,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is = to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (36, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
@@ -1755,7 +1773,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is < to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (37, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
@@ -1765,7 +1783,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is <= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (38, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (<=, scm_leq_p);
}
@@ -1775,7 +1793,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is > to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (38, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (39, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (>, scm_gr_p);
}
@@ -1785,7 +1803,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is >= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (39, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (40, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (>=, scm_geq_p);
}
@@ -1801,7 +1819,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (40, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (41, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
@@ -1816,7 +1834,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (41, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (42, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
@@ -1832,7 +1850,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Create a new variable holding SRC, and place it in DST.
*/
- VM_DEFINE_OP (42, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (43, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1846,7 +1864,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* general implementation of `letrec', in those cases that fix-letrec
* fails to fix.
*/
- VM_DEFINE_OP (43, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (44, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
SCM_UNPACK_RTL_24 (op, dst);
@@ -1859,7 +1877,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Unpack the variable at SRC into DST, asserting that the variable is
* actually bound.
*/
- VM_DEFINE_OP (44, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (45, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1882,7 +1900,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the contents of the variable at DST to SET.
*/
- VM_DEFINE_OP (45, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (46, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1897,7 +1915,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Load free variable SRC into local slot DST.
*/
- VM_DEFINE_OP (46, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (47, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1913,7 +1931,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* signed 32-bit integer. The registers for the NFREE free variables
* follow.
*/
- VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) |
OP_DST)
+ VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) |
OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
@@ -1940,7 +1958,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* free variables to point to each other. NFREE and the locals FREE0...
* are as in make-closure.
*/
- VM_DEFINE_OP (48, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (49, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
{
scm_t_uint32 dst, nfree, n;
SCM closure;
@@ -1965,7 +1983,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (49, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
+ VM_DEFINE_OP (50, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1980,7 +1998,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (50, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
+ VM_DEFINE_OP (51, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1995,7 +2013,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make an immediate with HIGH-BITS and LOW-BITS.
*/
- VM_DEFINE_OP (51, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
+ VM_DEFINE_OP (52, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2026,7 +2044,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Whether the object is mutable or immutable depends on where it was
* allocated by the compiler, and loaded by the loader.
*/
- VM_DEFINE_OP (52, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
+ VM_DEFINE_OP (53, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2055,7 +2073,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* that the compiler is unable to statically allocate, like symbols.
* These values would be initialized when the object file loads.
*/
- VM_DEFINE_OP (53, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (54, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2078,7 +2096,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Store a SCM value into memory, OFFSET 32-bit words away from the
* current instruction pointer. OFFSET is a signed value.
*/
- VM_DEFINE_OP (54, static_set, "static-set!", OP2 (U8_U24, LO32))
+ VM_DEFINE_OP (55, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2100,7 +2118,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* words away from the current instruction pointer. OFFSET is a
* signed value.
*/
- VM_DEFINE_OP (55, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (56, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2161,7 +2179,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the current module in DST.
*/
- VM_DEFINE_OP (56, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (57, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
@@ -2177,7 +2195,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Resolve SYM in MOD, and place the resulting variable in DST.
*/
- VM_DEFINE_OP (57, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (58, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, mod, sym;
@@ -2195,7 +2213,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* nonzero, resolve the public interface, otherwise use the private
* interface.
*/
- VM_DEFINE_OP (58, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
+ VM_DEFINE_OP (59, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
{
scm_t_uint8 dst, name, public;
SCM mod;
@@ -2216,7 +2234,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL.
*/
- VM_DEFINE_OP (59, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (60, define, "define", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val);
@@ -2244,7 +2262,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* an error if it is unbound, unbox it into DST, and cache the
* resolved variable so that we will hit the cache next time.
*/
- VM_DEFINE_OP (60, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
+ VM_DEFINE_OP (61, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2290,7 +2308,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Set a top-level variable from a variable cache cell. The variable
* is resolved as in toplevel-ref.
*/
- VM_DEFINE_OP (61, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
+ VM_DEFINE_OP (62, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
{
scm_t_uint32 src;
scm_t_int32 var_offset;
@@ -2335,7 +2353,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-ref, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (62, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
+ VM_DEFINE_OP (63, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2385,7 +2403,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-set!, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (63, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
+ VM_DEFINE_OP (64, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
{
scm_t_uint32 src;
scm_t_int32 var_offset;
@@ -2440,7 +2458,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* handler at HANDLER-OFFSET words from the current IP. The handler
* will expect a multiple-value return.
*/
- VM_DEFINE_OP (64, prompt, "prompt", OP2 (U8_U24, U8_L24))
+ VM_DEFINE_OP (65, prompt, "prompt", OP2 (U8_U24, U8_L24))
#if 0
{
scm_t_uint32 tag;
@@ -2472,7 +2490,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the compiler should have inserted checks that they wind and unwind
* procs are thunks, if it could not prove that to be the case.
*/
- VM_DEFINE_OP (65, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (66, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2487,7 +2505,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* VAL1, etc are 24-bit values, in the lower 24 bits of their words.
* The upper 8 bits are 0.
*/
- VM_DEFINE_OP (66, abort, "abort", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (67, abort, "abort", OP2 (U8_U24, X8_R24))
#if 0
{
scm_t_uint32 tag, nvalues;
@@ -2510,7 +2528,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack.
*/
- VM_DEFINE_OP (67, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (68, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (¤t_thread->dynstack);
NEXT (1);
@@ -2522,7 +2540,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* allocated in a continguous range on the stack, starting from
* FLUID-BASE. The values do not have this restriction.
*/
- VM_DEFINE_OP (68, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (69, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
#if 0
{
scm_t_uint32 fluid_base, n;
@@ -2544,7 +2562,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Leave the dynamic extent of a with-fluids expression, restoring the
* fluids to their previous values.
*/
- VM_DEFINE_OP (69, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
+ VM_DEFINE_OP (70, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (¤t_thread->dynstack,
@@ -2556,7 +2574,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Reference the fluid in SRC, and place the value in DST.
*/
- VM_DEFINE_OP (70, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (71, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2589,7 +2607,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the value of the fluid in DST to the value in SRC.
*/
- VM_DEFINE_OP (71, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (72, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2622,7 +2640,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the length of the string in SRC in DST.
*/
- VM_DEFINE_OP (72, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (73, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2639,7 +2657,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the character at position IDX in the string in SRC, and store
* it in DST.
*/
- VM_DEFINE_OP (73, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (74, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2661,7 +2679,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Parse a string in SRC to a number, and store in DST.
*/
- VM_DEFINE_OP (74, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (75, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2677,7 +2695,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Parse a string in SRC to a symbol, and store in DST.
*/
- VM_DEFINE_OP (75, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (76, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2691,7 +2709,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make a keyword from the symbol in SRC, and store it in DST.
*/
- VM_DEFINE_OP (76, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (77, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2710,7 +2728,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Cons CAR and CDR, and store the result in DST.
*/
- VM_DEFINE_OP (77, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (78, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2720,7 +2738,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (78, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (79, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2731,7 +2749,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (79, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (80, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2742,7 +2760,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (80, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (81, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2758,7 +2776,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (81, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (82, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2781,7 +2799,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Add A to B, and place the result in DST.
*/
- VM_DEFINE_OP (82, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (83, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2790,7 +2808,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Add 1 to the value in SRC, and place the result in DST.
*/
- VM_DEFINE_OP (83, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (84, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2816,7 +2834,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Subtract B from A, and place the result in DST.
*/
- VM_DEFINE_OP (84, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (85, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2825,7 +2843,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Subtract 1 from SRC, and place the result in DST.
*/
- VM_DEFINE_OP (85, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (86, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2851,7 +2869,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Multiply A and B, and place the result in DST.
*/
- VM_DEFINE_OP (86, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (87, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2862,7 +2880,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the result in DST.
*/
- VM_DEFINE_OP (87, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2873,7 +2891,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the quotient in DST.
*/
- VM_DEFINE_OP (88, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (89, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2884,7 +2902,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the remainder in DST.
*/
- VM_DEFINE_OP (89, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (90, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2895,7 +2913,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the modulo of A by B in DST.
*/
- VM_DEFINE_OP (90, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2906,7 +2924,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Shift A arithmetically by B bits, and place the result in DST.
*/
- VM_DEFINE_OP (91, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2939,7 +2957,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise AND of A and B into DST.
*/
- VM_DEFINE_OP (92, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (93, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2952,7 +2970,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise inclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (93, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (94, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2965,7 +2983,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise exclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (94, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2978,7 +2996,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the length of the vector in SRC in DST.
*/
- VM_DEFINE_OP (95, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (96, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -2995,7 +3013,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the item at position IDX in the vector in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (96, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (97, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -3016,7 +3034,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors.
*/
- VM_DEFINE_OP (97, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (98, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -3035,7 +3053,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store SRC into the vector DST at index IDX.
*/
- VM_DEFINE_OP (98, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (99, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -3070,7 +3088,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (99, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (100, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -3084,7 +3102,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the locals given by INIT0.... The format of INIT0... is as in the
* "call" opcode: unsigned 24-bit values, with 0 in the high byte.
*/
- VM_DEFINE_OP (100, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
+ VM_DEFINE_OP (101, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
#if 0
{
scm_t_uint16 dst, vtable_r;
@@ -3127,7 +3145,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the item at slot IDX in the struct in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (101, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (102, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -3161,7 +3179,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store SRC into the struct DST at slot IDX.
*/
- VM_DEFINE_OP (102, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (103, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3202,7 +3220,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (103, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (104, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -3217,7 +3235,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
* index into the stack.
*/
- VM_DEFINE_OP (104, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (105, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
@@ -3231,7 +3249,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
* IDX is an 8-bit immediate value, not an index into the stack.
*/
- VM_DEFINE_OP (105, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (106, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
@@ -3252,7 +3270,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed.
*/
- VM_DEFINE_OP (106, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
+ VM_DEFINE_OP (107, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
{
scm_t_uint8 dst, type, shape;
scm_t_int32 offset;
@@ -3270,9 +3288,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* make-array dst:12 type:12 _:8 fill:12 bounds:12
*
- * Make a new array SRC into the vector DST at index IDX.
+ * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
*/
- VM_DEFINE_OP (107, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (108, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, type, fill, bounds;
SCM_UNPACK_RTL_12_12 (op, dst, type);
@@ -3370,42 +3388,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0)
- VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
- VM_DEFINE_OP (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
- VM_DEFINE_OP (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (113, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
#else
BV_INT_REF (u32, uint32, 4);
#endif
- VM_DEFINE_OP (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (114, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
#else
BV_INT_REF (s32, int32, 4);
#endif
- VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (115, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (116, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (117, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (117, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (118, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f64, ieee_double, double, 8);
/* bv-u8-set! dst:8 idx:8 src:8
@@ -3509,42 +3527,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
- VM_DEFINE_OP (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
- VM_DEFINE_OP (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
- VM_DEFINE_OP (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN,
SCM_T_INT16_MAX, 2);
- VM_DEFINE_OP (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (123, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
#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_OP (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (124, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
#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_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (125, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (126, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (127, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (128, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8);
END_DISPATCH_SWITCH;
diff --git a/libguile/vm.c b/libguile/vm.c
index c99431f..18580f2 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software 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,6 +37,8 @@
#include "programs.h"
#include "vm.h"
+#include "private-gc.h" /* scm_getenv_int */
+
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
/* Unfortunately we can't snarf these: snarfed things are only loaded up from
@@ -680,7 +682,17 @@ resolve_variable (SCM what, SCM module)
}
}
+#define VM_MIN_STACK_SIZE (1024)
#define VM_DEFAULT_STACK_SIZE (64 * 1024)
+static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+
+static void
+initialize_default_stack_size (void)
+{
+ int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
+ if (size >= VM_MIN_STACK_SIZE)
+ vm_stack_size = size;
+}
#define VM_NAME vm_regular_engine
#define RTL_VM_NAME rtl_vm_regular_engine
@@ -721,7 +733,7 @@ make_vm (void)
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
- vp->stack_size = VM_DEFAULT_STACK_SIZE;
+ vp->stack_size= vm_stack_size;
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vp->stack_base = (SCM *)
@@ -1135,6 +1147,8 @@ scm_bootstrap_vm (void)
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
+ initialize_default_stack_size ();
+
sym_vm_run = scm_from_latin1_symbol ("vm-run");
sym_vm_error = scm_from_latin1_symbol ("vm-error");
sym_keyword_argument_error = scm_from_latin1_symbol
("keyword-argument-error");
diff --git a/libguile/vports.c b/libguile/vports.c
index a886e36..e726330 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -28,6 +28,8 @@
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/chars.h"
+#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
@@ -86,15 +88,15 @@ sf_fill_input (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
- scm_t_port *pt;
+ scm_t_port_internal *pti;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
- pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
- if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c
deleted file mode 100644
index 825b4c4..0000000
--- a/libguile/win32-socket.c
+++ /dev/null
@@ -1,632 +0,0 @@
-/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/__scm.h"
-#include "libguile/modules.h"
-#include "libguile/numbers.h"
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <ctype.h>
-#include <errno.h>
-#include <limits.h>
-
-#ifndef PATH_MAX
-#define PATH_MAX 255
-#endif
-
-#include "win32-socket.h"
-
-/* Winsock API error description structure. The error description is
- necessary because there is no error list available. */
-typedef struct
-{
- int error; /* Error code. */
- char *str; /* Error description. */
- int replace; /* Possible error code replacement. */
- char *replace_str; /* Replacement symbol. */
- char *correct_str; /* Original symbol. */
-}
-socket_error_t;
-
-#define FILE_ETC_SERVICES "services"
-#define ENVIRON_ETC_SERVICES "SERVICES"
-#define FILE_ETC_NETWORKS "networks"
-#define ENVIRON_ETC_NETWORKS "NETWORKS"
-#define FILE_ETC_PROTOCOLS "protocol"
-#define ENVIRON_ETC_PROTOCOLS "PROTOCOLS"
-#define MAX_NAMLEN 256
-#define MAX_ALIASES 4
-
-/* Internal structure for a thread's M$-Windows servent interface. */
-typedef struct
-{
- FILE *fd; /* Current file. */
- char file[PATH_MAX]; /* File name. */
- struct servent ent; /* Return value. */
- char name[MAX_NAMLEN]; /* Service name. */
- char proto[MAX_NAMLEN]; /* Protocol name. */
- char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */
- char *aliases[MAX_ALIASES]; /* Alias pointers. */
- int port; /* Network port. */
-}
-scm_i_servent_t;
-
-static scm_i_servent_t scm_i_servent;
-
-/* Internal structure for a thread's M$-Windows protoent interface. */
-typedef struct
-{
- FILE *fd; /* Current file. */
- char file[PATH_MAX]; /* File name. */
- struct protoent ent; /* Return value. */
- char name[MAX_NAMLEN]; /* Protocol name. */
- char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */
- char *aliases[MAX_ALIASES]; /* Alias pointers. */
- int proto; /* Protocol number. */
-}
-scm_i_protoent_t;
-
-static scm_i_protoent_t scm_i_protoent;
-
-/* Define replacement symbols for most of the WSA* error codes. */
-#ifndef EWOULDBLOCK
-# define EWOULDBLOCK WSAEWOULDBLOCK
-#endif
-#ifndef EINPROGRESS
-# define EINPROGRESS WSAEINPROGRESS
-#endif
-#ifndef EALREADY
-# define EALREADY WSAEALREADY
-#endif
-#ifndef EDESTADDRREQ
-# define EDESTADDRREQ WSAEDESTADDRREQ
-#endif
-#ifndef EMSGSIZE
-# define EMSGSIZE WSAEMSGSIZE
-#endif
-#ifndef EPROTOTYPE
-# define EPROTOTYPE WSAEPROTOTYPE
-#endif
-#ifndef ENOTSOCK
-# define ENOTSOCK WSAENOTSOCK
-#endif
-#ifndef ENOPROTOOPT
-# define ENOPROTOOPT WSAENOPROTOOPT
-#endif
-#ifndef EPROTONOSUPPORT
-# define EPROTONOSUPPORT WSAEPROTONOSUPPORT
-#endif
-#ifndef ESOCKTNOSUPPORT
-# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT
-#endif
-#ifndef EOPNOTSUPP
-# define EOPNOTSUPP WSAEOPNOTSUPP
-#endif
-#ifndef EPFNOSUPPORT
-# define EPFNOSUPPORT WSAEPFNOSUPPORT
-#endif
-#ifndef EAFNOSUPPORT
-# define EAFNOSUPPORT WSAEAFNOSUPPORT
-#endif
-#ifndef EADDRINUSE
-# define EADDRINUSE WSAEADDRINUSE
-#endif
-#ifndef EADDRNOTAVAIL
-# define EADDRNOTAVAIL WSAEADDRNOTAVAIL
-#endif
-#ifndef ENETDOWN
-# define ENETDOWN WSAENETDOWN
-#endif
-#ifndef ENETUNREACH
-# define ENETUNREACH WSAENETUNREACH
-#endif
-#ifndef ENETRESET
-# define ENETRESET WSAENETRESET
-#endif
-#ifndef ECONNABORTED
-# define ECONNABORTED WSAECONNABORTED
-#endif
-#ifndef ECONNRESET
-# define ECONNRESET WSAECONNRESET
-#endif
-#ifndef ENOBUFS
-# define ENOBUFS WSAENOBUFS
-#endif
-#ifndef EISCONN
-# define EISCONN WSAEISCONN
-#endif
-#ifndef ENOTCONN
-# define ENOTCONN WSAENOTCONN
-#endif
-#ifndef ESHUTDOWN
-# define ESHUTDOWN WSAESHUTDOWN
-#endif
-#ifndef ETOOMANYREFS
-# define ETOOMANYREFS WSAETOOMANYREFS
-#endif
-#ifndef ETIMEDOUT
-# define ETIMEDOUT WSAETIMEDOUT
-#endif
-#ifndef ECONNREFUSED
-# define ECONNREFUSED WSAECONNREFUSED
-#endif
-#ifndef ELOOP
-# define ELOOP WSAELOOP
-#endif
-#ifndef EHOSTDOWN
-# define EHOSTDOWN WSAEHOSTDOWN
-#endif
-#ifndef EHOSTUNREACH
-# define EHOSTUNREACH WSAEHOSTUNREACH
-#endif
-#ifndef EPROCLIM
-# define EPROCLIM WSAEPROCLIM
-#endif
-#ifndef EUSERS
-# define EUSERS WSAEUSERS
-#endif
-#ifndef EDQUOT
-# define EDQUOT WSAEDQUOT
-#endif
-#ifndef ESTALE
-# define ESTALE WSAESTALE
-#endif
-#ifndef EREMOTE
-# define EREMOTE WSAEREMOTE
-#endif
-
-/* List of error structures. */
-static socket_error_t socket_errno [] = {
- /* 000 */ { 0, NULL, 0, NULL, NULL },
- /* 001 */ { 0, NULL, 0, NULL, NULL },
- /* 002 */ { 0, NULL, 0, NULL, NULL },
- /* 003 */ { 0, NULL, 0, NULL, NULL },
- /* 004 */ { WSAEINTR, "Interrupted function call", EINTR, NULL, "WSAEINTR" },
- /* 005 */ { 0, NULL, 0, NULL, NULL },
- /* 006 */ { 0, NULL, 0, NULL, NULL },
- /* 007 */ { 0, NULL, 0, NULL, NULL },
- /* 008 */ { 0, NULL, 0, NULL, NULL },
- /* 009 */ { WSAEBADF, "Bad file number", EBADF, NULL, "WSAEBADF" },
- /* 010 */ { 0, NULL, 0, NULL, NULL },
- /* 011 */ { 0, NULL, 0, NULL, NULL },
- /* 012 */ { 0, NULL, 0, NULL, NULL },
- /* 013 */ { WSAEACCES, "Permission denied", EACCES, NULL, "WSAEACCES" },
- /* 014 */ { WSAEFAULT, "Bad address", EFAULT, NULL, "WSAEFAULT" },
- /* 015 */ { 0, NULL, 0, NULL, NULL },
- /* 016 */ { 0, NULL, 0, NULL, NULL },
- /* 017 */ { 0, NULL, 0, NULL, NULL },
- /* 018 */ { 0, NULL, 0, NULL, NULL },
- /* 019 */ { 0, NULL, 0, NULL, NULL },
- /* 020 */ { 0, NULL, 0, NULL, NULL },
- /* 021 */ { 0, NULL, 0, NULL, NULL },
- /* 022 */ { WSAEINVAL, "Invalid argument", EINVAL, NULL, "WSAEINVAL" },
- /* 023 */ { 0, NULL, 0, NULL, NULL },
- /* 024 */ { WSAEMFILE, "Too many open files", EMFILE, NULL, "WSAEMFILE" },
- /* 025 */ { 0, NULL, 0, NULL, NULL },
- /* 026 */ { 0, NULL, 0, NULL, NULL },
- /* 027 */ { 0, NULL, 0, NULL, NULL },
- /* 028 */ { 0, NULL, 0, NULL, NULL },
- /* 029 */ { 0, NULL, 0, NULL, NULL },
- /* 030 */ { 0, NULL, 0, NULL, NULL },
- /* 031 */ { 0, NULL, 0, NULL, NULL },
- /* 032 */ { 0, NULL, 0, NULL, NULL },
- /* 033 */ { 0, NULL, 0, NULL, NULL },
- /* 034 */ { 0, NULL, 0, NULL, NULL },
- /* 035 */ { WSAEWOULDBLOCK, "Resource temporarily unavailable",
- EWOULDBLOCK, "EWOULDBLOCK", "WSAEWOULDBLOCK" },
- /* 036 */ { WSAEINPROGRESS, "Operation now in progress",
- EINPROGRESS, "EINPROGRESS", "WSAEINPROGRESS" },
- /* 037 */ { WSAEALREADY, "Operation already in progress",
- EALREADY, "EALREADY", "WSAEALREADY" },
- /* 038 */ { WSAENOTSOCK, "Socket operation on non-socket",
- ENOTSOCK, "ENOTSOCK", "WSAENOTSOCK"},
- /* 039 */ { WSAEDESTADDRREQ, "Destination address required",
- EDESTADDRREQ, "EDESTADDRREQ", "WSAEDESTADDRREQ" },
- /* 040 */ { WSAEMSGSIZE, "Message too long",
- EMSGSIZE, "EMSGSIZE", "WSAEMSGSIZE" },
- /* 041 */ { WSAEPROTOTYPE, "Protocol wrong type for socket",
- EPROTOTYPE, "EPROTOTYPE", "WSAEPROTOTYPE" },
- /* 042 */ { WSAENOPROTOOPT, "Bad protocol option",
- ENOPROTOOPT, "ENOPROTOOPT", "WSAENOPROTOOPT" },
- /* 043 */ { WSAEPROTONOSUPPORT, "Protocol not supported",
- EPROTONOSUPPORT, "EPROTONOSUPPORT", "WSAEPROTONOSUPPORT" },
- /* 044 */ { WSAESOCKTNOSUPPORT, "Socket type not supported",
- ESOCKTNOSUPPORT, "ESOCKTNOSUPPORT", "WSAESOCKTNOSUPPORT" },
- /* 045 */ { WSAEOPNOTSUPP, "Operation not supported",
- EOPNOTSUPP, "EOPNOTSUPP", "WSAEOPNOTSUPP" },
- /* 046 */ { WSAEPFNOSUPPORT, "Protocol family not supported",
- EPFNOSUPPORT, "EPFNOSUPPORT", "WSAEPFNOSUPPORT" },
- /* 047 */ { WSAEAFNOSUPPORT,
- "Address family not supported by protocol family",
- EAFNOSUPPORT, "EAFNOSUPPORT", "WSAEAFNOSUPPORT" },
- /* 048 */ { WSAEADDRINUSE, "Address already in use",
- EADDRINUSE, "EADDRINUSE", "WSAEADDRINUSE" },
- /* 049 */ { WSAEADDRNOTAVAIL, "Cannot assign requested address",
- EADDRNOTAVAIL, "EADDRNOTAVAIL", "WSAEADDRNOTAVAIL" },
- /* 050 */ { WSAENETDOWN, "Network is down",
- ENETDOWN, "ENETDOWN", "WSAENETDOWN" },
- /* 051 */ { WSAENETUNREACH, "Network is unreachable",
- ENETUNREACH, "ENETUNREACH", "WSAENETUNREACH" },
- /* 052 */ { WSAENETRESET, "Network dropped connection on reset",
- ENETRESET, "ENETRESET", "WSAENETRESET" },
- /* 053 */ { WSAECONNABORTED, "Software caused connection abort",
- ECONNABORTED, "ECONNABORTED", "WSAECONNABORTED" },
- /* 054 */ { WSAECONNRESET, "Connection reset by peer",
- ECONNRESET, "ECONNRESET", "WSAECONNRESET" },
- /* 055 */ { WSAENOBUFS, "No buffer space available",
- ENOBUFS, "ENOBUFS", "WSAENOBUFS" },
- /* 056 */ { WSAEISCONN, "Socket is already connected",
- EISCONN, "EISCONN", "WSAEISCONN" },
- /* 057 */ { WSAENOTCONN, "Socket is not connected",
- ENOTCONN, "ENOTCONN", "WSAENOTCONN" },
- /* 058 */ { WSAESHUTDOWN, "Cannot send after socket shutdown",
- ESHUTDOWN, "ESHUTDOWN", "WSAESHUTDOWN" },
- /* 059 */ { WSAETOOMANYREFS, "Too many references; can't splice",
- ETOOMANYREFS, "ETOOMANYREFS", "WSAETOOMANYREFS" },
- /* 060 */ { WSAETIMEDOUT, "Connection timed out",
- ETIMEDOUT, "ETIMEDOUT", "WSAETIMEDOUT" },
- /* 061 */ { WSAECONNREFUSED, "Connection refused",
- ECONNREFUSED, "ECONNREFUSED", "WSAECONNREFUSED" },
- /* 062 */ { WSAELOOP, "Too many levels of symbolic links",
- ELOOP, "ELOOP", "WSAELOOP" },
- /* 063 */ { WSAENAMETOOLONG, "File name too long",
- ENAMETOOLONG, NULL, "WSAENAMETOOLONG" },
- /* 064 */ { WSAEHOSTDOWN, "Host is down",
- EHOSTDOWN, "EHOSTDOWN", "WSAEHOSTDOWN" },
- /* 065 */ { WSAEHOSTUNREACH, "No route to host",
- EHOSTUNREACH, "EHOSTUNREACH", "WSAEHOSTUNREACH" },
- /* 066 */ { WSAENOTEMPTY, "Directory not empty",
- ENOTEMPTY, NULL, "WSAENOTEMPTY" },
- /* 067 */ { WSAEPROCLIM, "Too many processes",
- EPROCLIM, "EPROCLIM", "WSAEPROCLIM" },
- /* 068 */ { WSAEUSERS, "Too many users",
- EUSERS, "EUSERS", "WSAEUSERS" },
- /* 069 */ { WSAEDQUOT, "Disc quota exceeded",
- EDQUOT, "EDQUOT", "WSAEDQUOT" },
- /* 070 */ { WSAESTALE, "Stale NFS file handle",
- ESTALE, "ESTALE", "WSAESTALE" },
- /* 071 */ { WSAEREMOTE, "Too many levels of remote in path",
- EREMOTE, "EREMOTE", "WSAEREMOTE" },
- /* 072 */ { 0, NULL, 0, NULL, NULL },
- /* 073 */ { 0, NULL, 0, NULL, NULL },
- /* 074 */ { 0, NULL, 0, NULL, NULL },
- /* 075 */ { 0, NULL, 0, NULL, NULL },
- /* 076 */ { 0, NULL, 0, NULL, NULL },
- /* 077 */ { 0, NULL, 0, NULL, NULL },
- /* 078 */ { 0, NULL, 0, NULL, NULL },
- /* 079 */ { 0, NULL, 0, NULL, NULL },
- /* 080 */ { 0, NULL, 0, NULL, NULL },
- /* 081 */ { 0, NULL, 0, NULL, NULL },
- /* 082 */ { 0, NULL, 0, NULL, NULL },
- /* 083 */ { 0, NULL, 0, NULL, NULL },
- /* 084 */ { 0, NULL, 0, NULL, NULL },
- /* 085 */ { 0, NULL, 0, NULL, NULL },
- /* 086 */ { 0, NULL, 0, NULL, NULL },
- /* 087 */ { 0, NULL, 0, NULL, NULL },
- /* 088 */ { 0, NULL, 0, NULL, NULL },
- /* 089 */ { 0, NULL, 0, NULL, NULL },
- /* 090 */ { 0, NULL, 0, NULL, NULL },
- /* 091 */ { WSASYSNOTREADY, "Network subsystem is unavailable",
- 0, NULL, "WSASYSNOTREADY" },
- /* 092 */ { WSAVERNOTSUPPORTED, "WINSOCK.DLL version out of range",
- 0, NULL, "WSAVERNOTSUPPORTED" },
- /* 093 */ { WSANOTINITIALISED, "Successful WSAStartup not yet performed",
- 0, NULL, "WSANOTINITIALISED" },
- /* 094 */ { 0, NULL, 0, NULL, NULL },
- /* 095 */ { 0, NULL, 0, NULL, NULL },
- /* 096 */ { 0, NULL, 0, NULL, NULL },
- /* 097 */ { 0, NULL, 0, NULL, NULL },
- /* 098 */ { 0, NULL, 0, NULL, NULL },
- /* 099 */ { 0, NULL, 0, NULL, NULL },
- /* 100 */ { 0, NULL, 0, NULL, NULL },
- /* 101 */ { WSAEDISCON, "Graceful shutdown in progress",
- 0, NULL, "WSAEDISCON" },
- /* 102 */ { WSAENOMORE, "No more services",
- 0, NULL, "WSAENOMORE" },
- /* 103 */ { WSAECANCELLED, "Service lookup cancelled",
- 0, NULL, "WSAECANCELLED" },
- /* 104 */ { WSAEINVALIDPROCTABLE, "Invalid procedure call table",
- 0, NULL, "WSAEINVALIDPROCTABLE" },
- /* 105 */ { WSAEINVALIDPROVIDER, "Invalid service provider",
- 0, NULL, "WSAEINVALIDPROVIDER" },
- /* 106 */ { WSAEPROVIDERFAILEDINIT, "Service provider failure",
- 0, NULL, "WSAEPROVIDERFAILEDINIT" },
- /* 107 */ { WSASYSCALLFAILURE, "System call failed",
- 0, NULL, "WSASYSCALLFAILURE" },
- /* 108 */ { WSASERVICE_NOT_FOUND, "No such service",
- 0, NULL, "WSASERVICE_NOT_FOUND" },
- /* 109 */ { WSATYPE_NOT_FOUND, "Class not found",
- 0, NULL, "WSATYPE_NOT_FOUND" },
- /* 110 */ { WSA_E_NO_MORE, "No more services",
- 0, NULL, "WSA_E_NO_MORE" },
- /* 111 */ { WSA_E_CANCELLED, "Service lookup cancelled",
- 0, NULL, "WSA_E_CANCELLED" },
- /* 112 */ { WSAEREFUSED, "Database query refused",
- 0, NULL, "WSAEREFUSED" },
- /* end */ { -1, NULL, -1, NULL, NULL }
-};
-
-/* Extended list of error structures. */
-static socket_error_t socket_h_errno [] = {
- /* 000 */ { 0, NULL, 0, NULL, NULL },
- /* 001 */ { WSAHOST_NOT_FOUND, "Host not found",
- HOST_NOT_FOUND, "HOST_NOT_FOUND", "WSAHOST_NOT_FOUND" },
- /* 002 */ { WSATRY_AGAIN, "Non-authoritative host not found",
- TRY_AGAIN, "TRY_AGAIN", "WSATRY_AGAIN" },
- /* 003 */ { WSANO_RECOVERY, "This is a non-recoverable error",
- NO_RECOVERY, "NO_RECOVERY", "WSANO_RECOVERY" },
- /* 004 */ { WSANO_DATA, "Valid name, no data record of requested type",
- NO_DATA, "NO_DATA", "WSANO_DATA" },
- /* 005 */ { WSANO_ADDRESS, "No address, look for MX record",
- NO_ADDRESS, "NO_ADDRESS", "WSANO_ADDRESS" },
- /* end */ { -1, NULL, -1, NULL, NULL }
-};
-
-/* Returns the result of @code{WSAGetLastError()}. */
-int
-scm_i_socket_errno (void)
-{
- return WSAGetLastError ();
-}
-
-/* Returns a valid error message for Winsock-API error codes obtained via
- @code{WSAGetLastError()} or NULL otherwise. */
-char *
-scm_i_socket_strerror (int error)
-{
- if (error >= WSABASEERR && error <= (WSABASEERR + 112))
- return socket_errno[error - WSABASEERR].str;
- else if (error >= (WSABASEERR + 1000) && error <= (WSABASEERR + 1005))
- return socket_h_errno[error - (WSABASEERR + 1000)].str;
- return NULL;
-}
-
-/* Constructs a valid filename for the given file @var{file} in the M$-Windows
- directory. This is usually the default location for the network files. */
-char *
-scm_i_socket_filename (char *file)
-{
- static char dir[PATH_MAX];
- int len = PATH_MAX;
-
- len = GetWindowsDirectory (dir, len);
- if (dir[len - 1] != '\\')
- strcat (dir, "\\");
- strcat (dir, file);
- return dir;
-}
-
-/* Removes comments and white spaces at end of line and returns a pointer
- to the end of the line. */
-static char *
-scm_i_socket_uncomment (char *line)
-{
- char *end;
-
- if ((end = strchr (line, '#')) != NULL)
- *end-- = '\0';
- else
- {
- end = line + strlen (line) - 1;
- while (end > line && (*end == '\r' || *end == '\n'))
- *end-- = '\0';
- }
- while (end > line && isspace ((int) (*end)))
- *end-- = '\0';
-
- return end;
-}
-
-/* The getservent() function reads the next line from the file `/etc/services'
- and returns a structure servent containing the broken out fields from the
- line. The `/etc/services' file is opened if necessary. */
-struct servent *
-getservent (void)
-{
- char line[MAX_NAMLEN], *end, *p;
- int done = 0, i, n, a;
- struct servent *e = NULL;
-
- /* Ensure a open file. */
- if (scm_i_servent.fd == NULL || feof (scm_i_servent.fd))
- {
- setservent (1);
- if (scm_i_servent.fd == NULL)
- return NULL;
- }
-
- while (!done)
- {
- /* Get new line. */
- if (fgets (line, MAX_NAMLEN, scm_i_servent.fd) != NULL)
- {
- end = scm_i_socket_uncomment (line);
-
- /* Scan the line. */
- if ((i = sscanf (line, "%s %d/%s%n",
- scm_i_servent.name,
- &scm_i_servent.port,
- scm_i_servent.proto, &n)) != 3)
- continue;
-
- /* Scan the remaining aliases. */
- p = line + n;
- for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
- a++, p += n)
- i = sscanf (p, "%s%n", scm_i_servent.alias[a], &n);
-
- /* Prepare the return value. */
- e = &scm_i_servent.ent;
- e->s_name = scm_i_servent.name;
- e->s_port = htons (scm_i_servent.port);
- e->s_proto = scm_i_servent.proto;
- e->s_aliases = scm_i_servent.aliases;
- scm_i_servent.aliases[a] = NULL;
- while (a--)
- scm_i_servent.aliases[a] = scm_i_servent.alias[a];
- done = 1;
- }
- else
- break;
- }
- return done ? e : NULL;
-}
-
-/* The setservent() function opens and rewinds the `/etc/services' file.
- This file can be set from outside with an environment variable specifying
- the file name. */
-void
-setservent (int stayopen)
-{
- char *file = NULL;
-
- endservent ();
- if ((file = getenv (ENVIRON_ETC_SERVICES)) != NULL)
- strcpy (scm_i_servent.file, file);
- else if ((file = scm_i_socket_filename (FILE_ETC_SERVICES)) != NULL)
- strcpy (scm_i_servent.file, file);
- scm_i_servent.fd = fopen (scm_i_servent.file, "rt");
-}
-
-/* The endservent() function closes the `/etc/services' file. */
-void
-endservent (void)
-{
- if (scm_i_servent.fd != NULL)
- {
- fclose (scm_i_servent.fd);
- scm_i_servent.fd = NULL;
- }
-}
-
-/* The getprotoent() function reads the next line from the file
- `/etc/protocols' and returns a structure protoent containing the broken
- out fields from the line. The `/etc/protocols' file is opened if
- necessary. */
-struct protoent *
-getprotoent (void)
-{
- char line[MAX_NAMLEN], *end, *p;
- int done = 0, i, n, a;
- struct protoent *e = NULL;
-
- /* Ensure a open file. */
- if (scm_i_protoent.fd == NULL || feof (scm_i_protoent.fd))
- {
- setprotoent (1);
- if (scm_i_protoent.fd == NULL)
- return NULL;
- }
-
- while (!done)
- {
- /* Get new line. */
- if (fgets (line, MAX_NAMLEN, scm_i_protoent.fd) != NULL)
- {
- end = scm_i_socket_uncomment (line);
-
- /* Scan the line. */
- if ((i = sscanf (line, "%s %d%n",
- scm_i_protoent.name,
- &scm_i_protoent.proto, &n)) != 2)
- continue;
-
- /* Scan the remaining aliases. */
- p = line + n;
- for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
- a++, p += n)
- i = sscanf (p, "%s%n", scm_i_protoent.alias[a], &n);
-
- /* Prepare the return value. */
- e = &scm_i_protoent.ent;
- e->p_name = scm_i_protoent.name;
- e->p_proto = scm_i_protoent.proto;
- e->p_aliases = scm_i_protoent.aliases;
- scm_i_protoent.aliases[a] = NULL;
- while (a--)
- scm_i_protoent.aliases[a] = scm_i_protoent.alias[a];
- done = 1;
- }
- else
- break;
- }
- return done ? e : NULL;
-}
-
-/* The setprotoent() function opens and rewinds the `/etc/protocols' file.
- As in setservent() the user can modify the location of the file using
- an environment variable. */
-void
-setprotoent (int stayopen)
-{
- char *file = NULL;
-
- endprotoent ();
- if ((file = getenv (ENVIRON_ETC_PROTOCOLS)) != NULL)
- strcpy (scm_i_protoent.file, file);
- else if ((file = scm_i_socket_filename (FILE_ETC_PROTOCOLS)) != NULL)
- strcpy (scm_i_protoent.file, file);
- scm_i_protoent.fd = fopen (scm_i_protoent.file, "rt");
-}
-
-/* The endprotoent() function closes `/etc/protocols'. */
-void
-endprotoent (void)
-{
- if (scm_i_protoent.fd != NULL)
- {
- fclose (scm_i_protoent.fd);
- scm_i_protoent.fd = NULL;
- }
-}
-
-/* Define both the original and replacement error symbol is possible. Thus
- the user is able to check symbolic errors after unsuccessful networking
- function calls. */
-static void
-scm_socket_symbols_Win32 (socket_error_t * e)
-{
- while (e->error != -1)
- {
- if (e->error)
- {
- if (e->correct_str)
- scm_c_define (e->correct_str, scm_from_int (e->error));
- if (e->replace && e->replace_str)
- scm_c_define (e->replace_str, scm_from_int (e->replace));
- }
- e++;
- }
-}
-
-/* Initialize Winsock API under M$-Windows. */
-void
-scm_i_init_socket_Win32 (void)
-{
- scm_socket_symbols_Win32 (socket_errno);
- scm_socket_symbols_Win32 (socket_h_errno);
-}
diff --git a/libguile/win32-socket.h b/libguile/win32-socket.h
deleted file mode 100644
index 4ab9b94..0000000
--- a/libguile/win32-socket.h
+++ /dev/null
@@ -1,42 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_WIN32_SOCKET_H
-#define SCM_WIN32_SOCKET_H
-
-/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#include "libguile/__scm.h"
-
-#ifdef SCM_HAVE_WINSOCK2_H
-# include <winsock2.h>
-#endif
-
-int scm_i_socket_errno (void);
-char * scm_i_socket_strerror (int error);
-void scm_i_init_socket_Win32 (void);
-char * scm_i_socket_filename (char *file);
-
-struct servent * getservent (void);
-void setservent (int stayopen);
-void endservent (void);
-struct protoent * getprotoent (void);
-void setprotoent (int stayopen);
-void endprotoent (void);
-
-#endif /* SCM_WIN32_SOCKET_H */
diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4
index d978cb8..d4ad759 100644
--- a/m4/00gnulib.m4
+++ b/m4/00gnulib.m4
@@ -1,5 +1,5 @@
# 00gnulib.m4 serial 2
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/absolute-header.m4 b/m4/absolute-header.m4
index 8a91d20..89ff5be 100644
--- a/m4/absolute-header.m4
+++ b/m4/absolute-header.m4
@@ -1,5 +1,5 @@
# absolute-header.m4 serial 16
-dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2013 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 656924b..270abd0 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,5 +1,5 @@
# alloca.m4 serial 14
-dnl Copyright (C) 2002-2004, 2006-2007, 2009-2012 Free Software Foundation,
+dnl Copyright (C) 2002-2004, 2006-2007, 2009-2013 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,
diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4
index 36915d1..ea69af5 100644
--- a/m4/arpa_inet_h.m4
+++ b/m4/arpa_inet_h.m4
@@ -1,5 +1,5 @@
# arpa_inet_h.m4 serial 13
-dnl Copyright (C) 2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2008-2013 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/autobuild.m4 b/m4/autobuild.m4
index 284dc60..3147b5b 100644
--- a/m4/autobuild.m4
+++ b/m4/autobuild.m4
@@ -1,5 +1,5 @@
# autobuild.m4 serial 7
-dnl Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2004, 2006-2013 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/btowc.m4 b/m4/btowc.m4
index e565321..978a06e 100644
--- a/m4/btowc.m4
+++ b/m4/btowc.m4
@@ -1,5 +1,5 @@
# btowc.m4 serial 10
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/byteswap.m4 b/m4/byteswap.m4
index f3b7ec9..7566903 100644
--- a/m4/byteswap.m4
+++ b/m4/byteswap.m4
@@ -1,5 +1,5 @@
# byteswap.m4 serial 4
-dnl Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2007, 2009-2013 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 ea51ac4..cef3124 100644
--- a/m4/canonicalize.m4
+++ b/m4/canonicalize.m4
@@ -1,6 +1,6 @@
# canonicalize.m4 serial 26
-dnl Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003-2007, 2009-2013 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/ceil.m4 b/m4/ceil.m4
index 890517b..c617561 100644
--- a/m4/ceil.m4
+++ b/m4/ceil.m4
@@ -1,5 +1,5 @@
# ceil.m4 serial 9
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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/check-math-lib.m4 b/m4/check-math-lib.m4
index 4f370eb..77570f4 100644
--- a/m4/check-math-lib.m4
+++ b/m4/check-math-lib.m4
@@ -1,5 +1,5 @@
# check-math-lib.m4 serial 4
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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/clock_time.m4 b/m4/clock_time.m4
index fb3a17a..767a1be 100644
--- a/m4/clock_time.m4
+++ b/m4/clock_time.m4
@@ -1,5 +1,5 @@
# clock_time.m4 serial 10
-dnl Copyright (C) 2002-2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2006, 2009-2013 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/close.m4 b/m4/close.m4
index 379e70d..bccd981 100644
--- a/m4/close.m4
+++ b/m4/close.m4
@@ -1,5 +1,5 @@
# close.m4 serial 8
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/codeset.m4 b/m4/codeset.m4
index cf53d24..c2761be 100644
--- a/m4/codeset.m4
+++ b/m4/codeset.m4
@@ -1,5 +1,5 @@
# codeset.m4 serial 5 (gettext-0.18.2)
-dnl Copyright (C) 2000-2002, 2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2000-2002, 2006, 2008-2013 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/configmake.m4 b/m4/configmake.m4
index 8c82371..823ffc0 100644
--- a/m4/configmake.m4
+++ b/m4/configmake.m4
@@ -1,5 +1,5 @@
# configmake.m4 serial 1
-dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2010-2013 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/dirent_h.m4 b/m4/dirent_h.m4
index f6c0fa7..54c1663 100644
--- a/m4/dirent_h.m4
+++ b/m4/dirent_h.m4
@@ -1,5 +1,5 @@
# dirent_h.m4 serial 16
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/dirfd.m4 b/m4/dirfd.m4
index fc475d7..39bc789 100644
--- a/m4/dirfd.m4
+++ b/m4/dirfd.m4
@@ -2,7 +2,7 @@
dnl Find out how to get the file descriptor associated with an open DIR*.
-# Copyright (C) 2001-2006, 2008-2012 Free Software Foundation, Inc.
+# Copyright (C) 2001-2006, 2008-2013 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/dirname.m4 b/m4/dirname.m4
index 65639ec..5897a2a 100644
--- a/m4/dirname.m4
+++ b/m4/dirname.m4
@@ -1,5 +1,5 @@
#serial 10 -*- autoconf -*-
-dnl Copyright (C) 2002-2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2006, 2009-2013 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/double-slash-root.m4 b/m4/double-slash-root.m4
index 1e03751..bd6f867 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-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2008-2013 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/dup2.m4 b/m4/dup2.m4
new file mode 100644
index 0000000..269cfdc
--- /dev/null
+++ b/m4/dup2.m4
@@ -0,0 +1,84 @@
+#serial 19
+dnl Copyright (C) 2002, 2005, 2007, 2009-2013 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_DUP2],
+[
+ AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ m4_ifdef([gl_FUNC_DUP2_OBSOLETE], [
+ AC_CHECK_FUNCS_ONCE([dup2])
+ if test $ac_cv_func_dup2 = no; then
+ HAVE_DUP2=0
+ fi
+ ], [
+ AC_DEFINE([HAVE_DUP2], [1], [Define to 1 if you have the 'dup2' function.])
+ ])
+ if test $HAVE_DUP2 = 1; then
+ AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works],
+ [AC_RUN_IFELSE([
+ AC_LANG_PROGRAM([[#include <unistd.h>
+#include <fcntl.h>
+#include <errno.h>]],
+ [int result = 0;
+#ifdef FD_CLOEXEC
+ if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1)
+ result |= 1;
+#endif
+ if (dup2 (1, 1) == 0)
+ result |= 2;
+#ifdef FD_CLOEXEC
+ if (fcntl (1, F_GETFD) != FD_CLOEXEC)
+ result |= 4;
+#endif
+ close (0);
+ if (dup2 (0, 0) != -1)
+ result |= 8;
+ /* Many gnulib modules require POSIX conformance of EBADF. */
+ if (dup2 (2, 1000000) == -1 && errno != EBADF)
+ result |= 16;
+ /* Flush out a cygwin core dump. */
+ if (dup2 (2, -1) != -1 || errno != EBADF)
+ result |= 32;
+ return result;
+ ])
+ ],
+ [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no],
+ [case "$host_os" in
+ mingw*) # on this platform, dup2 always returns 0 for success
+ gl_cv_func_dup2_works="guessing no" ;;
+ cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0
+ gl_cv_func_dup2_works="guessing no" ;;
+ linux*) # On linux between 2008-07-27 and 2009-05-11, dup2 of a
+ # closed fd may yield -EBADF instead of -1 / errno=EBADF.
+ gl_cv_func_dup2_works="guessing no" ;;
+ freebsd*) # on FreeBSD 6.1, dup2(1,1000000) gives EMFILE, not EBADF.
+ gl_cv_func_dup2_works="guessing no" ;;
+ haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC.
+ gl_cv_func_dup2_works="guessing no" ;;
+ *) gl_cv_func_dup2_works="guessing yes" ;;
+ esac])
+ ])
+ case "$gl_cv_func_dup2_works" in
+ *yes) ;;
+ *)
+ REPLACE_DUP2=1
+ ;;
+ esac
+ fi
+ dnl Replace dup2() for supporting the gnulib-defined fchdir() function,
+ dnl to keep fchdir's bookkeeping up-to-date.
+ m4_ifdef([gl_FUNC_FCHDIR], [
+ gl_TEST_FCHDIR
+ if test $HAVE_FCHDIR = 0; then
+ if test $HAVE_DUP2 = 1; then
+ REPLACE_DUP2=1
+ fi
+ fi
+ ])
+])
+
+# Prerequisites of lib/dup2.c.
+AC_DEFUN([gl_PREREQ_DUP2], [])
diff --git a/m4/duplocale.m4 b/m4/duplocale.m4
index 6096f5c..9ef894c 100644
--- a/m4/duplocale.m4
+++ b/m4/duplocale.m4
@@ -1,5 +1,5 @@
# duplocale.m4 serial 7
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/eealloc.m4 b/m4/eealloc.m4
index 9e5df45..c640ec1 100644
--- a/m4/eealloc.m4
+++ b/m4/eealloc.m4
@@ -1,5 +1,5 @@
# eealloc.m4 serial 3
-dnl Copyright (C) 2003, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2009-2013 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 8eb57c9..593a33e 100644
--- a/m4/environ.m4
+++ b/m4/environ.m4
@@ -1,5 +1,5 @@
# environ.m4 serial 6
-dnl Copyright (C) 2001-2004, 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2004, 2006-2013 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 4e33ba8..c813ea5 100644
--- a/m4/errno_h.m4
+++ b/m4/errno_h.m4
@@ -1,5 +1,5 @@
# errno_h.m4 serial 12
-dnl Copyright (C) 2004, 2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2004, 2006, 2008-2013 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/exponentd.m4 b/m4/exponentd.m4
index 0ae4ccf..09df468 100644
--- a/m4/exponentd.m4
+++ b/m4/exponentd.m4
@@ -1,5 +1,5 @@
# exponentd.m4 serial 3
-dnl Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2008, 2010-2013 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/exponentf.m4 b/m4/exponentf.m4
index 94d1167..55a04e6 100644
--- a/m4/exponentf.m4
+++ b/m4/exponentf.m4
@@ -1,5 +1,5 @@
# exponentf.m4 serial 2
-dnl Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2008, 2010-2013 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/exponentl.m4 b/m4/exponentl.m4
index a7cd13b..f877cf1 100644
--- a/m4/exponentl.m4
+++ b/m4/exponentl.m4
@@ -1,5 +1,5 @@
# exponentl.m4 serial 3
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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 6d17d8a..07ba376 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,14 +1,14 @@
-# serial 12 -*- Autoconf -*-
+# serial 13 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
-# Copyright (C) 2003, 2006-2012 Free Software Foundation, Inc.
+# Copyright (C) 2003, 2006-2013 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.
# This definition of AC_USE_SYSTEM_EXTENSIONS is stolen from CVS
# Autoconf. Perhaps we can remove this once we can assume Autoconf
-# 2.62 or later everywhere, but since CVS Autoconf mutates rapidly
+# 2.70 or later everywhere, but since Autoconf mutates rapidly
# enough in this area it's likely we'll need to redefine
# AC_USE_SYSTEM_EXTENSIONS for quite some time.
@@ -30,6 +30,7 @@
# ------------------------
# Enable extensions on systems that normally disable them,
# typically due to standards-conformance issues.
+#
# Remember that #undef in AH_VERBATIM gets replaced with #define by
# AC_DEFINE. The goal here is to define all known feature-enabling
# macros, then, if reports of conflicts are made, disable macros that
@@ -38,8 +39,6 @@ AC_DEFUN_ONCE([AC_USE_SYSTEM_EXTENSIONS],
[AC_BEFORE([$0], [AC_COMPILE_IFELSE])dnl
AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
- AC_REQUIRE([AC_CANONICAL_HOST])
-
AC_CHECK_HEADER([minix/config.h], [MINIX=yes], [MINIX=])
if test "$MINIX" = yes; then
AC_DEFINE([_POSIX_SOURCE], [1],
@@ -50,24 +49,18 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
except with this defined.])
AC_DEFINE([_MINIX], [1],
[Define to 1 if on MINIX.])
+ AC_DEFINE([_NETBSD_SOURCE], [1],
+ [Define to 1 to make NetBSD features available. MINIX 3 needs this.])
fi
- dnl HP-UX 11.11 defines mbstate_t only if _XOPEN_SOURCE is defined to 500,
- dnl regardless of whether the flags -Ae or _D_HPUX_SOURCE=1 are already
- dnl provided.
- case "$host_os" in
- hpux*)
- AC_DEFINE([_XOPEN_SOURCE], [500],
- [Define to 500 only on HP-UX.])
- ;;
- esac
-
- AH_VERBATIM([__EXTENSIONS__],
+dnl Use a different key than __EXTENSIONS__, as that name broke existing
+dnl configure.ac when using autoheader 2.62.
+ AH_VERBATIM([USE_SYSTEM_EXTENSIONS],
[/* Enable extensions on AIX 3, Interix. */
#ifndef _ALL_SOURCE
# undef _ALL_SOURCE
#endif
-/* Enable general extensions on Mac OS X. */
+/* Enable general extensions on OS X. */
#ifndef _DARWIN_C_SOURCE
# undef _DARWIN_C_SOURCE
#endif
@@ -83,6 +76,12 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
#ifndef _TANDEM_SOURCE
# undef _TANDEM_SOURCE
#endif
+/* Enable X/Open extensions if necessary. HP-UX 11.11 defines
+ mbstate_t only if _XOPEN_SOURCE is defined to 500, regardless of
+ whether compiling with -Ae or -D_HPUX_SOURCE=1. */
+#ifndef _XOPEN_SOURCE
+# undef _XOPEN_SOURCE
+#endif
/* Enable general extensions on Solaris. */
#ifndef __EXTENSIONS__
# undef __EXTENSIONS__
@@ -103,6 +102,22 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
AC_DEFINE([_GNU_SOURCE])
AC_DEFINE([_POSIX_PTHREAD_SEMANTICS])
AC_DEFINE([_TANDEM_SOURCE])
+ AC_CACHE_CHECK([whether _XOPEN_SOURCE should be defined],
+ [ac_cv_should_define__xopen_source],
+ [ac_cv_should_define__xopen_source=no
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[
+ #include <wchar.h>
+ mbstate_t x;]])],
+ [],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[
+ #define _XOPEN_SOURCE 500
+ #include <wchar.h>
+ mbstate_t x;]])],
+ [ac_cv_should_define__xopen_source=yes])])])
+ test $ac_cv_should_define__xopen_source = yes &&
+ AC_DEFINE([_XOPEN_SOURCE], [500])
])# AC_USE_SYSTEM_EXTENSIONS
# gl_USE_SYSTEM_EXTENSIONS
diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4
index 600c8d3..5880d4f 100644
--- a/m4/extern-inline.m4
+++ b/m4/extern-inline.m4
@@ -1,13 +1,12 @@
dnl 'extern inline' a la ISO C99.
-dnl Copyright 2012 Free Software Foundation, Inc.
+dnl Copyright 2012-2013 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_EXTERN_INLINE],
[
- AC_REQUIRE([AC_C_INLINE])
AH_VERBATIM([extern_inline],
[/* _GL_INLINE is a portable alternative to ISO C99 plain 'inline'.
_GL_EXTERN_INLINE is a portable alternative to 'extern inline'.
@@ -17,13 +16,19 @@ AC_DEFUN([gl_EXTERN_INLINE],
when FOO is an inline function in the header; see
<http://gcc.gnu.org/bugzilla/show_bug.cgi?id=54113>.
_GL_INLINE_HEADER_END contains useful stuff to put
- in the same include file, after uses of _GL_INLINE. */
-#if (__GNUC__ \
- ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \
- : 199901L <= __STDC_VERSION__)
+ in the same include file, after uses of _GL_INLINE.
+
+ Suppress the use of extern inline on Apple's platforms,
+ as Libc-825.25 (2012-09-19) is incompatible with it; see
+ <http://lists.gnu.org/archive/html/bug-gnulib/2012-12/msg00023.html>.
+ Perhaps Apple will fix this some day. */
+#if ((__GNUC__ \
+ ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \
+ : 199901L <= __STDC_VERSION__) \
+ && !defined __APPLE__)
# define _GL_INLINE inline
# define _GL_EXTERN_INLINE extern inline
-#elif 2 < __GNUC__ + (7 <= __GNUC_MINOR__)
+#elif 2 < __GNUC__ + (7 <= __GNUC_MINOR__) && !defined __APPLE__
# if __GNUC_GNU_INLINE__
/* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */
# define _GL_INLINE extern inline __attribute__ ((__gnu_inline__))
@@ -32,8 +37,8 @@ AC_DEFUN([gl_EXTERN_INLINE],
# endif
# define _GL_EXTERN_INLINE extern
#else
-# define _GL_INLINE static inline
-# define _GL_EXTERN_INLINE static inline
+# define _GL_INLINE static _GL_UNUSED
+# define _GL_EXTERN_INLINE static _GL_UNUSED
#endif
#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__)
diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4
index 740e78b..87cc4bd 100644
--- a/m4/fcntl-o.m4
+++ b/m4/fcntl-o.m4
@@ -1,5 +1,5 @@
# fcntl-o.m4 serial 4
-dnl Copyright (C) 2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2009-2013 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/fcntl_h.m4 b/m4/fcntl_h.m4
index cac28ae..3cff1fd 100644
--- a/m4/fcntl_h.m4
+++ b/m4/fcntl_h.m4
@@ -1,6 +1,6 @@
# serial 15
# Configure fcntl.h.
-dnl Copyright (C) 2006-2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2007, 2009-2013 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/float_h.m4 b/m4/float_h.m4
index 51c9c7b..397f2d1 100644
--- a/m4/float_h.m4
+++ b/m4/float_h.m4
@@ -1,5 +1,5 @@
# float_h.m4 serial 9
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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 7746883..bbcc4f9 100644
--- a/m4/flock.m4
+++ b/m4/flock.m4
@@ -1,5 +1,5 @@
# flock.m4 serial 3
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/floor.m4 b/m4/floor.m4
index a6e7ec8..c176a99 100644
--- a/m4/floor.m4
+++ b/m4/floor.m4
@@ -1,5 +1,5 @@
# floor.m4 serial 8
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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 82fd778..97941bb 100644
--- a/m4/fpieee.m4
+++ b/m4/fpieee.m4
@@ -1,5 +1,5 @@
# fpieee.m4 serial 2
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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/frexp.m4 b/m4/frexp.m4
index fb8db70..3909792 100644
--- a/m4/frexp.m4
+++ b/m4/frexp.m4
@@ -1,5 +1,5 @@
# frexp.m4 serial 14
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/fstat.m4 b/m4/fstat.m4
index 3ab3297..b2cf2ad 100644
--- a/m4/fstat.m4
+++ b/m4/fstat.m4
@@ -1,5 +1,5 @@
-# fstat.m4 serial 3
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+# fstat.m4 serial 4
+dnl Copyright (C) 2011-2013 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.
@@ -33,7 +33,4 @@ AC_DEFUN([gl_FUNC_FSTAT],
])
# Prerequisites of lib/fstat.c.
-AC_DEFUN([gl_PREREQ_FSTAT],
-[
- AC_REQUIRE([AC_C_INLINE])
-])
+AC_DEFUN([gl_PREREQ_FSTAT], [:])
diff --git a/m4/func.m4 b/m4/func.m4
index 13c204d..5548d5e 100644
--- a/m4/func.m4
+++ b/m4/func.m4
@@ -1,5 +1,5 @@
# func.m4 serial 2
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/getaddrinfo.m4 b/m4/getaddrinfo.m4
index 9cd3e67..1d631f8 100644
--- a/m4/getaddrinfo.m4
+++ b/m4/getaddrinfo.m4
@@ -1,5 +1,5 @@
-# getaddrinfo.m4 serial 29
-dnl Copyright (C) 2004-2012 Free Software Foundation, Inc.
+# getaddrinfo.m4 serial 30
+dnl Copyright (C) 2004-2013 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.
@@ -134,7 +134,6 @@ AC_DEFUN([gl_PREREQ_GETADDRINFO], [
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
diff --git a/m4/getlogin.m4 b/m4/getlogin.m4
new file mode 100644
index 0000000..9b3f3cd
--- /dev/null
+++ b/m4/getlogin.m4
@@ -0,0 +1,14 @@
+# getlogin.m4 serial 3
+dnl Copyright (C) 2010-2013 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_GETLOGIN],
+[
+ AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+ AC_CHECK_FUNCS_ONCE([getlogin])
+ if test $ac_cv_func_getlogin = no; then
+ HAVE_GETLOGIN=0
+ fi
+])
diff --git a/m4/glibc21.m4 b/m4/glibc21.m4
index c938fb1..613fb2a 100644
--- a/m4/glibc21.m4
+++ b/m4/glibc21.m4
@@ -1,5 +1,5 @@
# glibc21.m4 serial 5
-dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2012 Free Software Foundation,
+dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2013 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,
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 50102b2..81e4646 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -1,4 +1,4 @@
-# Copyright (C) 2002-2012 Free Software Foundation, Inc.
+# Copyright (C) 2002-2013 Free Software Foundation, Inc.
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -27,7 +27,7 @@
# Specification in the form of a command-line invocation:
-# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu
--source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp full-read full-write func
gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen
gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf
inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility
libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu
malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send
sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh
string sys_stat trunc verify vsnprintf warnings wchar
+# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu
--source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close
connect dirfd duplocale environ extensions flock floor fpieee frexp fstat
full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname
getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload
havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp
lib-symbol-versions lib-symbol-visibility libunistring listen localcharset
locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open
pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto
setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string
sys_stat time times trunc verify vsnprintf warnings wchar
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([gnulib-local])
@@ -39,6 +39,7 @@ gl_MODULES([
autobuild
bind
byteswap
+ c-strcase
canonicalize-lgpl
ceil
clock-time
@@ -52,11 +53,13 @@ gl_MODULES([
floor
fpieee
frexp
+ fstat
full-read
full-write
func
gendocs
getaddrinfo
+ getlogin
getpeername
getsockname
getsockopt
@@ -85,12 +88,15 @@ gl_MODULES([
nl_langinfo
nproc
open
+ pipe-posix
pipe2
+ poll
putenv
recv
recvfrom
regex
rename
+ select
send
sendto
setenv
@@ -103,6 +109,8 @@ gl_MODULES([
striconveh
string
sys_stat
+ time
+ times
trunc
verify
vsnprintf
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 15d2b2b..0ae5a9e 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,5 +1,5 @@
# gnulib-common.m4 serial 33
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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.
@@ -294,6 +294,8 @@ Amsterdam
# 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.
+# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness.
+m4_ifndef([AC_AUTOCONF_VERSION],[
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],
@@ -304,13 +306,15 @@ m4_ifdef([AC_PROG_MKDIR_P], [
[AC_REQUIRE([AM_PROG_MKDIR_P])dnl defined by automake
MKDIR_P='$(mkdir_p)'
AC_SUBST([MKDIR_P])])])
+])
# AC_C_RESTRICT
# This definition overrides the AC_C_RESTRICT macro from autoconf 2.60..2.61,
# so that mixed use of GNU C and GNU C++ and mixed use of Sun C and Sun C++
# works.
# This definition can be removed once autoconf >= 2.62 can be assumed.
-m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.62]),[-1],[
+# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness.
+m4_ifndef([AC_AUTOCONF_VERSION],[
AC_DEFUN([AC_C_RESTRICT],
[AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict],
[ac_cv_c_restrict=no
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index b52b972..55c003a 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -1,5 +1,5 @@
# DO NOT EDIT! GENERATED AUTOMATICALLY!
-# Copyright (C) 2002-2012 Free Software Foundation, Inc.
+# Copyright (C) 2002-2013 Free Software Foundation, Inc.
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -41,6 +41,7 @@ AC_DEFUN([gl_EARLY],
AC_REQUIRE([AM_PROG_CC_C_O])
# Code from module accept:
# Code from module alignof:
+ # Code from module alloca:
# Code from module alloca-opt:
# Code from module announce-gen:
# Code from module arpa_inet:
@@ -65,6 +66,7 @@ AC_DEFUN([gl_EARLY],
# Code from module dirname-lgpl:
# Code from module dosname:
# Code from module double-slash-root:
+ # Code from module dup2:
# Code from module duplocale:
# Code from module environ:
# Code from module errno:
@@ -85,6 +87,7 @@ AC_DEFUN([gl_EARLY],
# Code from module func:
# Code from module gendocs:
# Code from module getaddrinfo:
+ # Code from module getlogin:
# Code from module getpeername:
# Code from module getsockname:
# Code from module getsockopt:
@@ -144,7 +147,10 @@ AC_DEFUN([gl_EARLY],
# Code from module nproc:
# Code from module open:
# Code from module pathmax:
+ # Code from module pipe-posix:
# Code from module pipe2:
+ # Code from module poll:
+ # Code from module poll-h:
# Code from module putenv:
# Code from module raise:
# Code from module read:
@@ -158,6 +164,7 @@ AC_DEFUN([gl_EARLY],
# Code from module safe-read:
# Code from module safe-write:
# Code from module same-inode:
+ # Code from module select:
# Code from module send:
# Code from module sendto:
# Code from module servent:
@@ -190,13 +197,16 @@ AC_DEFUN([gl_EARLY],
# Code from module striconveh:
# Code from module string:
# Code from module sys_file:
+ # Code from module sys_select:
# Code from module sys_socket:
# Code from module sys_stat:
# Code from module sys_time:
+ # Code from module sys_times:
# Code from module sys_types:
# Code from module sys_uio:
# Code from module time:
# Code from module time_r:
+ # Code from module times:
# Code from module trunc:
# Code from module unistd:
# Code from module unistr/base:
@@ -238,6 +248,10 @@ AC_DEFUN([gl_INIT],
AC_LIBOBJ([accept])
fi
gl_SYS_SOCKET_MODULE_INDICATOR([accept])
+changequote(,)dnl
+LTALLOCA=`echo "$ALLOCA" | sed -e 's/\.[^.]* /.lo /g;s/\.[^.]*$/.lo/'`
+changequote([, ])dnl
+AC_SUBST([LTALLOCA])
gl_FUNC_ALLOCA
gl_HEADER_ARPA_INET
AC_PROG_MKDIR_P
@@ -287,6 +301,12 @@ AC_DEFUN([gl_INIT],
gl_DIRENT_MODULE_INDICATOR([dirfd])
gl_DIRNAME_LGPL
gl_DOUBLE_SLASH_ROOT
+ gl_FUNC_DUP2
+ if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then
+ AC_LIBOBJ([dup2])
+ gl_PREREQ_DUP2
+ fi
+ gl_UNISTD_MODULE_INDICATOR([dup2])
gl_FUNC_DUPLOCALE
if test $REPLACE_DUPLOCALE = 1; then
AC_LIBOBJ([duplocale])
@@ -336,6 +356,11 @@ AC_DEFUN([gl_INIT],
AC_LIBOBJ([gai_strerror])
fi
gl_NETDB_MODULE_INDICATOR([getaddrinfo])
+ gl_FUNC_GETLOGIN
+ if test $HAVE_GETLOGIN = 0; then
+ AC_LIBOBJ([getlogin])
+ fi
+ gl_UNISTD_MODULE_INDICATOR([getlogin])
AC_REQUIRE([gl_HEADER_SYS_SOCKET])
if test "$ac_cv_header_winsock2_h" = yes; then
AC_LIBOBJ([getpeername])
@@ -529,11 +554,24 @@ AC_DEFUN([gl_INIT],
fi
gl_FCNTL_MODULE_INDICATOR([open])
gl_PATHMAX
+ gl_FUNC_PIPE
+ if test $HAVE_PIPE = 0; then
+ AC_LIBOBJ([pipe])
+ fi
+ gl_UNISTD_MODULE_INDICATOR([pipe])
gl_FUNC_PIPE2
gl_UNISTD_MODULE_INDICATOR([pipe2])
+ gl_FUNC_POLL
+ if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then
+ AC_LIBOBJ([poll])
+ gl_PREREQ_POLL
+ fi
+ gl_POLL_MODULE_INDICATOR([poll])
+ gl_POLL_H
gl_FUNC_PUTENV
if test $REPLACE_PUTENV = 1; then
AC_LIBOBJ([putenv])
+ gl_PREREQ_PUTENV
fi
gl_STDLIB_MODULE_INDICATOR([putenv])
gl_FUNC_RAISE
@@ -586,6 +624,11 @@ AC_DEFUN([gl_INIT],
gl_MATH_MODULE_INDICATOR([round])
gl_PREREQ_SAFE_READ
gl_PREREQ_SAFE_WRITE
+ gl_FUNC_SELECT
+ if test $REPLACE_SELECT = 1; then
+ AC_LIBOBJ([select])
+ fi
+ gl_SYS_SELECT_MODULE_INDICATOR([select])
AC_REQUIRE([gl_HEADER_SYS_SOCKET])
if test "$ac_cv_header_winsock2_h" = yes; then
AC_LIBOBJ([send])
@@ -657,12 +700,16 @@ AC_DEFUN([gl_INIT],
gl_HEADER_STRING_H
gl_HEADER_SYS_FILE_H
AC_PROG_MKDIR_P
+ gl_HEADER_SYS_SELECT
+ AC_PROG_MKDIR_P
gl_HEADER_SYS_SOCKET
AC_PROG_MKDIR_P
gl_HEADER_SYS_STAT_H
AC_PROG_MKDIR_P
gl_HEADER_SYS_TIME_H
AC_PROG_MKDIR_P
+ gl_SYS_TIMES_H
+ AC_PROG_MKDIR_P
gl_SYS_TYPES_H
AC_PROG_MKDIR_P
gl_HEADER_SYS_UIO
@@ -674,6 +721,11 @@ AC_DEFUN([gl_INIT],
gl_PREREQ_TIME_R
fi
gl_TIME_MODULE_INDICATOR([time_r])
+ gl_FUNC_TIMES
+ if test $HAVE_TIMES = 0; then
+ AC_LIBOBJ([times])
+ fi
+ gl_SYS_TIMES_MODULE_INDICATOR([times])
gl_FUNC_TRUNC
if test $HAVE_DECL_TRUNC = 0 || test $REPLACE_TRUNC = 1; then
AC_LIBOBJ([trunc])
@@ -862,6 +914,7 @@ AC_DEFUN([gl_FILE_LIST], [
doc/gendocs_template
lib/accept.c
lib/alignof.h
+ lib/alloca.c
lib/alloca.in.h
lib/arpa_inet.in.h
lib/asnprintf.c
@@ -887,6 +940,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/dirname-lgpl.c
lib/dirname.h
lib/dosname.h
+ lib/dup2.c
lib/duplocale.c
lib/errno.in.h
lib/fcntl.in.h
@@ -905,6 +959,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/full-write.h
lib/gai_strerror.c
lib/getaddrinfo.c
+ lib/getlogin.c
lib/getpeername.c
lib/getsockname.c
lib/getsockopt.c
@@ -942,6 +997,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/malloca.c
lib/malloca.h
lib/malloca.valgrind
+ lib/math.c
lib/math.in.h
lib/mbrtowc.c
lib/mbsinit.c
@@ -960,7 +1016,10 @@ AC_DEFUN([gl_FILE_LIST], [
lib/nproc.h
lib/open.c
lib/pathmax.h
+ lib/pipe.c
lib/pipe2.c
+ lib/poll.c
+ lib/poll.in.h
lib/printf-args.c
lib/printf-args.h
lib/printf-parse.c
@@ -987,6 +1046,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/safe-write.c
lib/safe-write.h
lib/same-inode.h
+ lib/select.c
lib/send.c
lib/sendto.c
lib/setenv.c
@@ -1015,14 +1075,19 @@ AC_DEFUN([gl_FILE_LIST], [
lib/string.in.h
lib/stripslash.c
lib/sys_file.in.h
+ lib/sys_select.in.h
+ lib/sys_socket.c
lib/sys_socket.in.h
lib/sys_stat.in.h
lib/sys_time.in.h
+ lib/sys_times.in.h
lib/sys_types.in.h
lib/sys_uio.in.h
lib/time.in.h
lib/time_r.c
+ lib/times.c
lib/trunc.c
+ lib/unistd.c
lib/unistd.in.h
lib/unistr.in.h
lib/unistr/u8-mbtouc-aux.c
@@ -1041,6 +1106,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/w32sock.h
lib/wchar.in.h
lib/wcrtomb.c
+ lib/wctype-h.c
lib/wctype.in.h
lib/write.c
lib/xsize.c
@@ -1063,6 +1129,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/dirfd.m4
m4/dirname.m4
m4/double-slash-root.m4
+ m4/dup2.m4
m4/duplocale.m4
m4/eealloc.m4
m4/environ.m4
@@ -1082,6 +1149,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/fstat.m4
m4/func.m4
m4/getaddrinfo.m4
+ m4/getlogin.m4
m4/glibc21.m4
m4/gnulib-common.m4
m4/hostent.m4
@@ -1141,7 +1209,10 @@ AC_DEFUN([gl_FILE_LIST], [
m4/off_t.m4
m4/open.m4
m4/pathmax.m4
+ m4/pipe.m4
m4/pipe2.m4
+ m4/poll.m4
+ m4/poll_h.m4
m4/printf.m4
m4/putenv.m4
m4/raise.m4
@@ -1153,6 +1224,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/round.m4
m4/safe-read.m4
m4/safe-write.m4
+ m4/select.m4
m4/servent.m4
m4/setenv.m4
m4/signal_h.m4
@@ -1175,13 +1247,16 @@ AC_DEFUN([gl_FILE_LIST], [
m4/strftime.m4
m4/string_h.m4
m4/sys_file_h.m4
+ m4/sys_select_h.m4
m4/sys_socket_h.m4
m4/sys_stat_h.m4
m4/sys_time_h.m4
+ m4/sys_times_h.m4
m4/sys_types_h.m4
m4/sys_uio_h.m4
m4/time_h.m4
m4/time_r.m4
+ m4/times.m4
m4/tm_gmtoff.m4
m4/trunc.m4
m4/unistd_h.m4
diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4
index a09ffc1..f3dea1a 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, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2004-2005, 2009-2013 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
index 5134775..72be876 100644
--- a/m4/hostent.m4
+++ b/m4/hostent.m4
@@ -1,5 +1,5 @@
# hostent.m4 serial 2
-dnl Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2010-2013 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.m4 b/m4/iconv.m4
index 6a47236..a503646 100644
--- a/m4/iconv.m4
+++ b/m4/iconv.m4
@@ -1,5 +1,5 @@
# iconv.m4 serial 18 (gettext-0.18.2)
-dnl Copyright (C) 2000-2002, 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2000-2002, 2007-2013 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_h.m4 b/m4/iconv_h.m4
index aa86cf8..f0519d9 100644
--- a/m4/iconv_h.m4
+++ b/m4/iconv_h.m4
@@ -1,5 +1,5 @@
# iconv_h.m4 serial 8
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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-utf.m4 b/m4/iconv_open-utf.m4
index f450f55..0ab3a18 100644
--- a/m4/iconv_open-utf.m4
+++ b/m4/iconv_open-utf.m4
@@ -1,5 +1,5 @@
# iconv_open-utf.m4 serial 1
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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 07f4849..1dcf414 100644
--- a/m4/iconv_open.m4
+++ b/m4/iconv_open.m4
@@ -1,5 +1,5 @@
# iconv_open.m4 serial 14
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/include_next.m4 b/m4/include_next.m4
index a60a261..108d945 100644
--- a/m4/include_next.m4
+++ b/m4/include_next.m4
@@ -1,5 +1,5 @@
# include_next.m4 serial 23
-dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2013 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 1ebd960..476f063 100644
--- a/m4/inet_ntop.m4
+++ b/m4/inet_ntop.m4
@@ -1,5 +1,5 @@
# inet_ntop.m4 serial 19
-dnl Copyright (C) 2005-2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2005-2006, 2008-2013 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 e7b44e2..e86db82 100644
--- a/m4/inet_pton.m4
+++ b/m4/inet_pton.m4
@@ -1,5 +1,5 @@
# inet_pton.m4 serial 17
-dnl Copyright (C) 2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2008-2013 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 6fa9972..3a50621 100644
--- a/m4/inline.m4
+++ b/m4/inline.m4
@@ -1,5 +1,5 @@
# inline.m4 serial 4
-dnl Copyright (C) 2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006, 2009-2013 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 c1a4a75..6ea7053 100644
--- a/m4/intmax_t.m4
+++ b/m4/intmax_t.m4
@@ -1,5 +1,5 @@
# intmax_t.m4 serial 8
-dnl Copyright (C) 1997-2004, 2006-2007, 2009-2012 Free Software Foundation,
+dnl Copyright (C) 1997-2004, 2006-2007, 2009-2013 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,
diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4
index 91c7bca..5f05ac5 100644
--- a/m4/inttypes_h.m4
+++ b/m4/inttypes_h.m4
@@ -1,5 +1,5 @@
# inttypes_h.m4 serial 10
-dnl Copyright (C) 1997-2004, 2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 1997-2004, 2006, 2008-2013 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/isinf.m4 b/m4/isinf.m4
index 0f6309e..513a1ba 100644
--- a/m4/isinf.m4
+++ b/m4/isinf.m4
@@ -1,5 +1,5 @@
# isinf.m4 serial 9
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/isnan.m4 b/m4/isnan.m4
index 7ad7127..ababb25 100644
--- a/m4/isnan.m4
+++ b/m4/isnan.m4
@@ -1,5 +1,5 @@
# isnan.m4 serial 5
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/isnand.m4 b/m4/isnand.m4
index 54b64a4..ee05e0f 100644
--- a/m4/isnand.m4
+++ b/m4/isnand.m4
@@ -1,5 +1,5 @@
# isnand.m4 serial 11
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/isnanf.m4 b/m4/isnanf.m4
index 97f638a..f01886a 100644
--- a/m4/isnanf.m4
+++ b/m4/isnanf.m4
@@ -1,5 +1,5 @@
# isnanf.m4 serial 14
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/isnanl.m4 b/m4/isnanl.m4
index 81469ab..ed5bbf8 100644
--- a/m4/isnanl.m4
+++ b/m4/isnanl.m4
@@ -1,5 +1,5 @@
# isnanl.m4 serial 17
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/langinfo_h.m4 b/m4/langinfo_h.m4
index b93fe70..73bef8b 100644
--- a/m4/langinfo_h.m4
+++ b/m4/langinfo_h.m4
@@ -1,5 +1,5 @@
# langinfo_h.m4 serial 7
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/largefile.m4 b/m4/largefile.m4
index a88850a..1e605e3 100644
--- a/m4/largefile.m4
+++ b/m4/largefile.m4
@@ -1,13 +1,14 @@
# Enable large files on systems where this is not the default.
-# Copyright 1992-1996, 1998-2012 Free Software Foundation, Inc.
+# Copyright 1992-1996, 1998-2013 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.
-# The following implementation works around a problem in autoconf <= 2.68;
-# AC_SYS_LARGEFILE does not configure for large inodes on Mac OS X 10.5.
-m4_version_prereq([2.69], [] ,[
+# The following implementation works around a problem in autoconf <= 2.69;
+# AC_SYS_LARGEFILE does not configure for large inodes on Mac OS X 10.5,
+# or configures them incorrectly in some cases.
+m4_version_prereq([2.70], [] ,[
# _AC_SYS_LARGEFILE_TEST_INCLUDES
# -------------------------------
@@ -25,9 +26,9 @@ m4_define([_AC_SYS_LARGEFILE_TEST_INCLUDES],
# _AC_SYS_LARGEFILE_MACRO_VALUE(C-MACRO, VALUE,
-# CACHE-VAR,
-# DESCRIPTION,
-# PROLOGUE, [FUNCTION-BODY])
+# CACHE-VAR,
+# DESCRIPTION,
+# PROLOGUE, [FUNCTION-BODY])
# --------------------------------------------------------
m4_define([_AC_SYS_LARGEFILE_MACRO_VALUE],
[AC_CACHE_CHECK([for $1 value needed for large files], [$3],
@@ -93,15 +94,11 @@ if test "$enable_largefile" != no; then
[_AC_SYS_LARGEFILE_TEST_INCLUDES])
fi
- AH_VERBATIM([_DARWIN_USE_64_BIT_INODE],
-[/* Enable large inode numbers on Mac OS X. */
-#ifndef _DARWIN_USE_64_BIT_INODE
-# define _DARWIN_USE_64_BIT_INODE 1
-#endif])
+ AC_DEFINE([_DARWIN_USE_64_BIT_INODE], [1],
+ [Enable large inode numbers on Mac OS X 10.5.])
fi
])# AC_SYS_LARGEFILE
-
-])# m4_version_prereq 2.69
+])# m4_version_prereq 2.70
# Enable large files on systems where this is implemented by Gnulib, not by the
# system headers.
diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4
index 5ed93ef..63386f1 100644
--- a/m4/ld-version-script.m4
+++ b/m4/ld-version-script.m4
@@ -1,5 +1,5 @@
# ld-version-script.m4 serial 3
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/ldexp.m4 b/m4/ldexp.m4
index 6d26b56..7a75b1b 100644
--- a/m4/ldexp.m4
+++ b/m4/ldexp.m4
@@ -1,5 +1,5 @@
# ldexp.m4 serial 1
-dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2010-2013 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 e1feab5..c145e47 100644
--- a/m4/lib-ld.m4
+++ b/m4/lib-ld.m4
@@ -1,5 +1,5 @@
# lib-ld.m4 serial 6
-dnl Copyright (C) 1996-2003, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 1996-2003, 2009-2013 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 d11b4b4..073f040 100644
--- a/m4/lib-link.m4
+++ b/m4/lib-link.m4
@@ -1,5 +1,5 @@
# lib-link.m4 serial 26 (gettext-0.18.2)
-dnl Copyright (C) 2001-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2013 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 007aa05..60908e8 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-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2005, 2008-2013 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-base.m4 b/m4/libunistring-base.m4
index d91c42b..d105c72 100644
--- a/m4/libunistring-base.m4
+++ b/m4/libunistring-base.m4
@@ -1,5 +1,5 @@
# libunistring-base.m4 serial 5
-dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2010-2013 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 c1bf4d5..fa74d72 100644
--- a/m4/libunistring.m4
+++ b/m4/libunistring.m4
@@ -1,5 +1,5 @@
# libunistring.m4 serial 11
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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 8010379..2e93e58 100644
--- a/m4/localcharset.m4
+++ b/m4/localcharset.m4
@@ -1,5 +1,5 @@
# localcharset.m4 serial 7
-dnl Copyright (C) 2002, 2004, 2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2004, 2006, 2009-2013 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 71b6847..ef199e3 100644
--- a/m4/locale-fr.m4
+++ b/m4/locale-fr.m4
@@ -1,5 +1,5 @@
# locale-fr.m4 serial 17
-dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2013 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 5ba0e43..132a3e7 100644
--- a/m4/locale-ja.m4
+++ b/m4/locale-ja.m4
@@ -1,5 +1,5 @@
# locale-ja.m4 serial 12
-dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2013 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 e5502b2..4eed73f 100644
--- a/m4/locale-zh.m4
+++ b/m4/locale-zh.m4
@@ -1,5 +1,5 @@
# locale-zh.m4 serial 12
-dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2013 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 c0f4d52..8bd12e8 100644
--- a/m4/locale_h.m4
+++ b/m4/locale_h.m4
@@ -1,5 +1,5 @@
# locale_h.m4 serial 19
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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/localeconv.m4 b/m4/localeconv.m4
index 5fae06d..b8bb596 100644
--- a/m4/localeconv.m4
+++ b/m4/localeconv.m4
@@ -1,5 +1,5 @@
# localeconv.m4 serial 1
-dnl Copyright (C) 2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2012-2013 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/log.m4 b/m4/log.m4
index a04362a..31a6adf 100644
--- a/m4/log.m4
+++ b/m4/log.m4
@@ -1,5 +1,5 @@
# log.m4 serial 4
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2011-2013 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/log1p.m4 b/m4/log1p.m4
index 4bca324..8a81511 100644
--- a/m4/log1p.m4
+++ b/m4/log1p.m4
@@ -1,5 +1,5 @@
# log1p.m4 serial 3
-dnl Copyright (C) 2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2012-2013 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/longlong.m4 b/m4/longlong.m4
index b9c65c7..3af6ab5 100644
--- a/m4/longlong.m4
+++ b/m4/longlong.m4
@@ -1,5 +1,5 @@
# longlong.m4 serial 17
-dnl Copyright (C) 1999-2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 1999-2007, 2009-2013 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 b7335bd..5f4db64 100644
--- a/m4/lstat.m4
+++ b/m4/lstat.m4
@@ -1,6 +1,6 @@
-# serial 25
+# serial 26
-# Copyright (C) 1997-2001, 2003-2012 Free Software Foundation, Inc.
+# Copyright (C) 1997-2001, 2003-2013 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -27,11 +27,7 @@ AC_DEFUN([gl_FUNC_LSTAT],
])
# Prerequisites of lib/lstat.c.
-AC_DEFUN([gl_PREREQ_LSTAT],
-[
- AC_REQUIRE([AC_C_INLINE])
- :
-])
+AC_DEFUN([gl_PREREQ_LSTAT], [:])
AC_DEFUN([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK],
[
diff --git a/m4/malloc.m4 b/m4/malloc.m4
index 8fa48e9..4b24a0b 100644
--- a/m4/malloc.m4
+++ b/m4/malloc.m4
@@ -1,5 +1,5 @@
# malloc.m4 serial 14
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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 7841979..791ce10 100644
--- a/m4/malloca.m4
+++ b/m4/malloca.m4
@@ -1,5 +1,5 @@
# malloca.m4 serial 1
-dnl Copyright (C) 2003-2004, 2006-2007, 2009-2012 Free Software Foundation,
+dnl Copyright (C) 2003-2004, 2006-2007, 2009-2013 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,
diff --git a/m4/math_h.m4 b/m4/math_h.m4
index 90d248a..bf0845f 100644
--- a/m4/math_h.m4
+++ b/m4/math_h.m4
@@ -1,5 +1,5 @@
-# math_h.m4 serial 113
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+# math_h.m4 serial 114
+dnl Copyright (C) 2007-2013 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -8,7 +8,6 @@ AC_DEFUN([gl_MATH_H],
[
AC_REQUIRE([gl_MATH_H_DEFAULTS])
gl_CHECK_NEXT_HEADERS([math.h])
- AC_REQUIRE([AC_C_INLINE])
AC_CACHE_CHECK([whether NAN macro works], [gl_cv_header_math_nan_works],
[AC_COMPILE_IFELSE([AC_LANG_PROGRAM(address@hidden:@include <math.h>]],
diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4
index 7147f7e..67b601f 100644
--- a/m4/mathfunc.m4
+++ b/m4/mathfunc.m4
@@ -1,5 +1,5 @@
# mathfunc.m4 serial 11
-dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2010-2013 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 8f829c8..4c9f388 100644
--- a/m4/mbrtowc.m4
+++ b/m4/mbrtowc.m4
@@ -1,5 +1,5 @@
# mbrtowc.m4 serial 25
-dnl Copyright (C) 2001-2002, 2004-2005, 2008-2012 Free Software Foundation,
+dnl Copyright (C) 2001-2002, 2004-2005, 2008-2013 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,
diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4
index da56c3d..2e6d092 100644
--- a/m4/mbsinit.m4
+++ b/m4/mbsinit.m4
@@ -1,5 +1,5 @@
# mbsinit.m4 serial 8
-dnl Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2010-2013 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 61a8190..ed00117 100644
--- a/m4/mbstate_t.m4
+++ b/m4/mbstate_t.m4
@@ -1,5 +1,5 @@
# mbstate_t.m4 serial 13
-dnl Copyright (C) 2000-2002, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2000-2002, 2008-2013 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/mbtowc.m4 b/m4/mbtowc.m4
index fec0d25..e479461 100644
--- a/m4/mbtowc.m4
+++ b/m4/mbtowc.m4
@@ -1,5 +1,5 @@
# mbtowc.m4 serial 2
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2011-2013 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 0040294..2d8abe7 100644
--- a/m4/memchr.m4
+++ b/m4/memchr.m4
@@ -1,5 +1,5 @@
# memchr.m4 serial 12
-dnl Copyright (C) 2002-2004, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2009-2013 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 748b17d..9b60ddf 100644
--- a/m4/mmap-anon.m4
+++ b/m4/mmap-anon.m4
@@ -1,5 +1,5 @@
# mmap-anon.m4 serial 10
-dnl Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2007, 2009-2013 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/mode_t.m4 b/m4/mode_t.m4
index 40f612a..d5b66d4 100644
--- a/m4/mode_t.m4
+++ b/m4/mode_t.m4
@@ -1,5 +1,5 @@
# mode_t.m4 serial 2
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/msvc-inval.m4 b/m4/msvc-inval.m4
index 8db4617..9a6a47a 100644
--- a/m4/msvc-inval.m4
+++ b/m4/msvc-inval.m4
@@ -1,5 +1,5 @@
# msvc-inval.m4 serial 1
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2011-2013 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/msvc-nothrow.m4 b/m4/msvc-nothrow.m4
index 0125050..a39618a 100644
--- a/m4/msvc-nothrow.m4
+++ b/m4/msvc-nothrow.m4
@@ -1,5 +1,5 @@
# msvc-nothrow.m4 serial 1
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2011-2013 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 0c288b8..552ec7e 100644
--- a/m4/multiarch.m4
+++ b/m4/multiarch.m4
@@ -1,5 +1,5 @@
# multiarch.m4 serial 7
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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
index e0f3ee8..2c69f99 100644
--- a/m4/netdb_h.m4
+++ b/m4/netdb_h.m4
@@ -1,5 +1,5 @@
# netdb_h.m4 serial 11
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/netinet_in_h.m4 b/m4/netinet_in_h.m4
index e181388..21971b2 100644
--- a/m4/netinet_in_h.m4
+++ b/m4/netinet_in_h.m4
@@ -1,5 +1,5 @@
# netinet_in_h.m4 serial 5
-dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2013 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/nl_langinfo.m4 b/m4/nl_langinfo.m4
index 80fe60d..25e2101 100644
--- a/m4/nl_langinfo.m4
+++ b/m4/nl_langinfo.m4
@@ -1,5 +1,5 @@
# nl_langinfo.m4 serial 5
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/nocrash.m4 b/m4/nocrash.m4
index c2638df..105b884 100644
--- a/m4/nocrash.m4
+++ b/m4/nocrash.m4
@@ -1,5 +1,5 @@
# nocrash.m4 serial 4
-dnl Copyright (C) 2005, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2009-2013 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/nproc.m4 b/m4/nproc.m4
index a94b97f..0261938 100644
--- a/m4/nproc.m4
+++ b/m4/nproc.m4
@@ -1,5 +1,5 @@
# nproc.m4 serial 4
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/off_t.m4 b/m4/off_t.m4
index dfca2df..d355d01 100644
--- a/m4/off_t.m4
+++ b/m4/off_t.m4
@@ -1,5 +1,5 @@
# off_t.m4 serial 1
-dnl Copyright (C) 2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2012-2013 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/open.m4 b/m4/open.m4
index c85971d..a6cb101 100644
--- a/m4/open.m4
+++ b/m4/open.m4
@@ -1,5 +1,5 @@
-# open.m4 serial 13
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+# open.m4 serial 14
+dnl Copyright (C) 2007-2013 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.
@@ -86,7 +86,6 @@ changequote([,])dnl
# Prerequisites of lib/open.c.
AC_DEFUN([gl_PREREQ_OPEN],
[
- AC_REQUIRE([AC_C_INLINE])
AC_REQUIRE([gl_PROMOTED_TYPE_MODE_T])
:
])
diff --git a/m4/pathmax.m4 b/m4/pathmax.m4
index 0117861..e11bf57 100644
--- a/m4/pathmax.m4
+++ b/m4/pathmax.m4
@@ -1,5 +1,5 @@
# pathmax.m4 serial 10
-dnl Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation,
+dnl Copyright (C) 2002-2003, 2005-2006, 2009-2013 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,
diff --git a/m4/pipe.m4 b/m4/pipe.m4
new file mode 100644
index 0000000..5831283
--- /dev/null
+++ b/m4/pipe.m4
@@ -0,0 +1,15 @@
+# pipe.m4 serial 2
+dnl Copyright (C) 2010-2013 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_PIPE],
+[
+ AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+
+ AC_CHECK_FUNCS_ONCE([pipe])
+ if test $ac_cv_func_pipe != yes; then
+ HAVE_PIPE=0
+ fi
+])
diff --git a/m4/pipe2.m4 b/m4/pipe2.m4
index 00ad82b..6ccee10 100644
--- a/m4/pipe2.m4
+++ b/m4/pipe2.m4
@@ -1,5 +1,5 @@
# pipe2.m4 serial 2
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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/poll.m4 b/m4/poll.m4
new file mode 100644
index 0000000..f0f0b80
--- /dev/null
+++ b/m4/poll.m4
@@ -0,0 +1,103 @@
+# poll.m4 serial 17
+dnl Copyright (c) 2003, 2005-2007, 2009-2013 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_POLL],
+[
+ AC_REQUIRE([gl_POLL_H])
+ AC_REQUIRE([gl_SOCKETS])
+ if test $ac_cv_header_poll_h = no; then
+ ac_cv_func_poll=no
+ gl_cv_func_poll=no
+ else
+ AC_CHECK_FUNC([poll],
+ [# Check whether poll() works on special files (like /dev/null) and
+ # and ttys (like /dev/tty). On Mac OS X 10.4.0 and AIX 5.3, it doesn't.
+ AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <fcntl.h>
+#include <poll.h>
+ int main()
+ {
+ int result = 0;
+ struct pollfd ufd;
+ /* Try /dev/null for reading. */
+ ufd.fd = open ("/dev/null", O_RDONLY);
+ /* If /dev/null does not exist, it's not Mac OS X nor AIX. */
+ if (ufd.fd >= 0)
+ {
+ ufd.events = POLLIN;
+ ufd.revents = 0;
+ if (!(poll (&ufd, 1, 0) == 1 && ufd.revents == POLLIN))
+ result |= 1;
+ }
+ /* Try /dev/null for writing. */
+ ufd.fd = open ("/dev/null", O_WRONLY);
+ /* If /dev/null does not exist, it's not Mac OS X nor AIX. */
+ if (ufd.fd >= 0)
+ {
+ ufd.events = POLLOUT;
+ ufd.revents = 0;
+ if (!(poll (&ufd, 1, 0) == 1 && ufd.revents == POLLOUT))
+ result |= 2;
+ }
+ /* Trying /dev/tty may be too environment dependent. */
+ return result;
+ }]])],
+ [gl_cv_func_poll=yes],
+ [gl_cv_func_poll=no],
+ [# When cross-compiling, assume that poll() works everywhere except on
+ # Mac OS X or AIX, regardless of its version.
+ AC_EGREP_CPP([MacOSX], [
+#if (defined(__APPLE__) && defined(__MACH__)) || defined(_AIX)
+This is MacOSX or AIX
+#endif
+], [gl_cv_func_poll=no], [gl_cv_func_poll=yes])])])
+ fi
+ if test $gl_cv_func_poll != yes; then
+ AC_CHECK_FUNC([poll], [ac_cv_func_poll=yes], [ac_cv_func_poll=no])
+ if test $ac_cv_func_poll = no; then
+ HAVE_POLL=0
+ else
+ REPLACE_POLL=1
+ fi
+ fi
+ if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then
+ :
+ else
+ AC_DEFINE([HAVE_POLL], [1],
+ [Define to 1 if you have the 'poll' function and it works.])
+ fi
+
+ dnl Determine the needed libraries.
+ LIB_POLL="$LIBSOCKET"
+ if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then
+ case "$host_os" in
+ mingw*)
+ dnl On the MSVC platform, the function MsgWaitForMultipleObjects
+ dnl (used in lib/poll.c) requires linking with -luser32. On mingw,
+ dnl it is implicit.
+ AC_LINK_IFELSE(
+ [AC_LANG_SOURCE([[
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+int
+main ()
+{
+ MsgWaitForMultipleObjects (0, NULL, 0, 0, 0);
+ return 0;
+}]])],
+ [],
+ [LIB_POLL="$LIB_POLL -luser32"])
+ ;;
+ esac
+ fi
+ AC_SUBST([LIB_POLL])
+])
+
+# Prerequisites of lib/poll.c.
+AC_DEFUN([gl_PREREQ_POLL],
+[
+ AC_CHECK_HEADERS_ONCE([sys/ioctl.h sys/filio.h])
+])
diff --git a/m4/poll_h.m4 b/m4/poll_h.m4
new file mode 100644
index 0000000..4930674
--- /dev/null
+++ b/m4/poll_h.m4
@@ -0,0 +1,47 @@
+# poll_h.m4 serial 2
+dnl Copyright (C) 2010-2013 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 Bruno Haible.
+
+AC_DEFUN([gl_POLL_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_POLL_H_DEFAULTS])
+
+ AC_CHECK_HEADERS_ONCE([poll.h])
+ if test $ac_cv_header_poll_h = yes; then
+ HAVE_POLL_H=1
+ else
+ HAVE_POLL_H=0
+ fi
+ AC_SUBST([HAVE_POLL_H])
+
+ dnl <poll.h> is always overridden, because of GNULIB_POSIXCHECK.
+ gl_CHECK_NEXT_HEADERS([poll.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 <poll.h>]],
+ [poll])
+])
+
+AC_DEFUN([gl_POLL_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_POLL_H_DEFAULTS])
+ gl_MODULE_INDICATOR_SET_VARIABLE([$1])
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR_FOR_TESTS([$1])
+])
+
+AC_DEFUN([gl_POLL_H_DEFAULTS],
+[
+ GNULIB_POLL=0; AC_SUBST([GNULIB_POLL])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_POLL=1; AC_SUBST([HAVE_POLL])
+ REPLACE_POLL=0; AC_SUBST([REPLACE_POLL])
+])
diff --git a/m4/printf.m4 b/m4/printf.m4
index 751e896..ef44f78 100644
--- a/m4/printf.m4
+++ b/m4/printf.m4
@@ -1,5 +1,5 @@
# printf.m4 serial 50
-dnl Copyright (C) 2003, 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2007-2013 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 b971b12..03ed4f9 100644
--- a/m4/putenv.m4
+++ b/m4/putenv.m4
@@ -1,5 +1,5 @@
# putenv.m4 serial 19
-dnl Copyright (C) 2002-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2013 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,3 +48,9 @@ AC_DEFUN([gl_FUNC_PUTENV],
;;
esac
])
+
+# Prerequisites of lib/putenv.c.
+AC_DEFUN([gl_PREREQ_PUTENV],
+[
+ AC_CHECK_FUNCS([_putenv])
+])
diff --git a/m4/raise.m4 b/m4/raise.m4
index 18eb8b9..7df3317 100644
--- a/m4/raise.m4
+++ b/m4/raise.m4
@@ -1,5 +1,5 @@
-# raise.m4 serial 2
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+# raise.m4 serial 3
+dnl Copyright (C) 2011-2013 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.
@@ -31,6 +31,4 @@ AC_DEFUN([gl_FUNC_RAISE],
])
# Prerequisites of lib/raise.c.
-AC_DEFUN([gl_PREREQ_RAISE], [
- AC_REQUIRE([AC_C_INLINE])
-])
+AC_DEFUN([gl_PREREQ_RAISE], [:])
diff --git a/m4/read.m4 b/m4/read.m4
index 69aeb09..81f0f3a 100644
--- a/m4/read.m4
+++ b/m4/read.m4
@@ -1,5 +1,5 @@
-# read.m4 serial 3
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+# read.m4 serial 4
+dnl Copyright (C) 2011-2013 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,7 +23,4 @@ AC_DEFUN([gl_FUNC_READ],
])
# Prerequisites of lib/read.c.
-AC_DEFUN([gl_PREREQ_READ],
-[
- AC_REQUIRE([AC_C_INLINE])
-])
+AC_DEFUN([gl_PREREQ_READ], [:])
diff --git a/m4/readlink.m4 b/m4/readlink.m4
index ccf5141..96e5042 100644
--- a/m4/readlink.m4
+++ b/m4/readlink.m4
@@ -1,5 +1,5 @@
# readlink.m4 serial 12
-dnl Copyright (C) 2003, 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2007, 2009-2013 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/regex.m4 b/m4/regex.m4
index 41be5e8..ae89e31 100644
--- a/m4/regex.m4
+++ b/m4/regex.m4
@@ -1,6 +1,6 @@
-# serial 61
+# serial 63
-# Copyright (C) 1996-2001, 2003-2012 Free Software Foundation, Inc.
+# Copyright (C) 1996-2001, 2003-2013 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -27,15 +27,21 @@ AC_DEFUN([gl_REGEX],
# following run test, then default to *not* using the included regex.c.
# If cross compiling, assume the test would fail and use the included
# regex.c.
+ AC_CHECK_FUNCS_ONCE([alarm])
AC_CACHE_CHECK([for working re_compile_pattern],
[gl_cv_func_re_compile_pattern_working],
[AC_RUN_IFELSE(
[AC_LANG_PROGRAM(
- [AC_INCLUDES_DEFAULT[
- #include <locale.h>
- #include <limits.h>
- #include <regex.h>
- ]],
+ [[#include <regex.h>
+
+ #include <locale.h>
+ #include <limits.h>
+ #include <string.h>
+ #if HAVE_ALARM
+ # include <unistd.h>
+ # include <signal.h>
+ #endif
+ ]],
[[int result = 0;
static struct re_pattern_buffer regex;
unsigned char folded_chars[UCHAR_MAX + 1];
@@ -43,26 +49,54 @@ AC_DEFUN([gl_REGEX],
const char *s;
struct re_registers regs;
- /* http://sourceware.org/ml/libc-hacker/2006-09/msg00008.html
- This test needs valgrind to catch the bug on Debian
- GNU/Linux 3.1 x86, but it might catch the bug better
- on other platforms and it shouldn't hurt to try the
- test here. */
+#if HAVE_ALARM
+ /* Some builds of glibc go into an infinite loop on this test. */
+ signal (SIGALRM, SIG_DFL);
+ alarm (2);
+#endif
if (setlocale (LC_ALL, "en_US.UTF-8"))
{
- static char const pat[] = "insert into";
- static char const data[] =
- "\xFF\0\x12\xA2\xAA\xC4\xB1,K\x12\xC4\xB1*\xACK";
- re_set_syntax (RE_SYNTAX_GREP | RE_HAT_LISTS_NOT_NEWLINE
- | RE_ICASE);
- memset (®ex, 0, sizeof regex);
- s = re_compile_pattern (pat, sizeof pat - 1, ®ex);
- if (s)
- result |= 1;
- else if (re_search (®ex, data, sizeof data - 1,
- 0, sizeof data - 1, ®s)
- != -1)
- result |= 1;
+ {
+ /* http://sourceware.org/ml/libc-hacker/2006-09/msg00008.html
+ This test needs valgrind to catch the bug on Debian
+ GNU/Linux 3.1 x86, but it might catch the bug better
+ on other platforms and it shouldn't hurt to try the
+ test here. */
+ static char const pat[] = "insert into";
+ static char const data[] =
+ "\xFF\0\x12\xA2\xAA\xC4\xB1,K\x12\xC4\xB1*\xACK";
+ re_set_syntax (RE_SYNTAX_GREP | RE_HAT_LISTS_NOT_NEWLINE
+ | RE_ICASE);
+ memset (®ex, 0, sizeof regex);
+ s = re_compile_pattern (pat, sizeof pat - 1, ®ex);
+ if (s)
+ result |= 1;
+ else if (re_search (®ex, data, sizeof data - 1,
+ 0, sizeof data - 1, ®s)
+ != -1)
+ result |= 1;
+ }
+
+ {
+ /* This test is from glibc bug 15078.
+ The test case is from Andreas Schwab in
+
<http://www.sourceware.org/ml/libc-alpha/2013-01/msg00967.html>.
+ */
+ static char const pat[] = "[^x]x";
+ static char const data[] =
+ "\xe1\x80\x80\xe1\x80\xbb\xe1\x80\xbd\xe1\x80\x94\xe1\x80"
+ "\xba\xe1\x80\xaf\xe1\x80\x95\xe1\x80\xbax";
+ re_set_syntax (0);
+ memset (®ex, 0, sizeof regex);
+ s = re_compile_pattern (pat, sizeof pat - 1, ®ex);
+ if (s)
+ result |= 1;
+ else if (re_search (®ex, data, sizeof data - 1,
+ 0, sizeof data - 1, 0)
+ != 21)
+ result |= 1;
+ }
+
if (! setlocale (LC_ALL, "C"))
return 1;
}
@@ -220,6 +254,7 @@ AC_DEFUN([gl_PREREQ_REGEX],
AC_REQUIRE([AC_C_INLINE])
AC_REQUIRE([AC_C_RESTRICT])
AC_REQUIRE([AC_TYPE_MBSTATE_T])
+ AC_REQUIRE([gl_EEMALLOC])
AC_CHECK_HEADERS([libintl.h])
AC_CHECK_FUNCS_ONCE([isblank iswctype wcscoll])
AC_CHECK_DECLS([isblank], [], [], [[#include <ctype.h>]])
diff --git a/m4/rename.m4 b/m4/rename.m4
index 378b5ec..66430aa 100644
--- a/m4/rename.m4
+++ b/m4/rename.m4
@@ -1,6 +1,6 @@
# serial 26
-# Copyright (C) 2001, 2003, 2005-2006, 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 2001, 2003, 2005-2006, 2009-2013 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/rmdir.m4 b/m4/rmdir.m4
index 34ca876..f6a02dd 100644
--- a/m4/rmdir.m4
+++ b/m4/rmdir.m4
@@ -1,5 +1,5 @@
# rmdir.m4 serial 13
-dnl Copyright (C) 2002, 2005, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2005, 2009-2013 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/round.m4 b/m4/round.m4
index 514c4f7..aab67ac 100644
--- a/m4/round.m4
+++ b/m4/round.m4
@@ -1,5 +1,5 @@
# round.m4 serial 16
-dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2009-2013 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/safe-read.m4 b/m4/safe-read.m4
index c82acdb..be5207a 100644
--- a/m4/safe-read.m4
+++ b/m4/safe-read.m4
@@ -1,5 +1,5 @@
# safe-read.m4 serial 6
-dnl Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation,
+dnl Copyright (C) 2002-2003, 2005-2006, 2009-2013 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,
diff --git a/m4/safe-write.m4 b/m4/safe-write.m4
index c1eff6e..bc2a33f 100644
--- a/m4/safe-write.m4
+++ b/m4/safe-write.m4
@@ -1,5 +1,5 @@
# safe-write.m4 serial 4
-dnl Copyright (C) 2002, 2005-2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2005-2006, 2009-2013 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/select.m4 b/m4/select.m4
new file mode 100644
index 0000000..d025355
--- /dev/null
+++ b/m4/select.m4
@@ -0,0 +1,113 @@
+# select.m4 serial 7
+dnl Copyright (C) 2009-2013 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_SELECT],
+[
+ AC_REQUIRE([gl_HEADER_SYS_SELECT])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_REQUIRE([gl_SOCKETS])
+ if test "$ac_cv_header_winsock2_h" = yes; then
+ REPLACE_SELECT=1
+ else
+ dnl On Interix 3.5, select(0, NULL, NULL, NULL, timeout) fails with error
+ dnl EFAULT.
+ AC_CHECK_HEADERS_ONCE([sys/select.h])
+ AC_CACHE_CHECK([whether select supports a 0 argument],
+ [gl_cv_func_select_supports0],
+ [
+ AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <sys/types.h>
+#include <sys/time.h>
+#if HAVE_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+int main ()
+{
+ struct timeval timeout;
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 5;
+ return select (0, (fd_set *)0, (fd_set *)0, (fd_set *)0, &timeout) < 0;
+}]])], [gl_cv_func_select_supports0=yes], [gl_cv_func_select_supports0=no],
+ [
+changequote(,)dnl
+ case "$host_os" in
+ # Guess no on Interix.
+ interix*) gl_cv_func_select_supports0="guessing no";;
+ # Guess yes otherwise.
+ *) gl_cv_func_select_supports0="guessing yes";;
+ esac
+changequote([,])dnl
+ ])
+ ])
+ case "$gl_cv_func_select_supports0" in
+ *yes) ;;
+ *) REPLACE_SELECT=1 ;;
+ esac
+
+ dnl On FreeBSD 8.2, select() doesn't always reject bad fds.
+ AC_CACHE_CHECK([whether select detects invalid fds],
+ [gl_cv_func_select_detects_ebadf],
+ [
+ AC_RUN_IFELSE([AC_LANG_PROGRAM([[
+#include <sys/types.h>
+#include <sys/time.h>
+#if HAVE_SYS_SELECT_H
+# include <sys/select.h>
+#endif
+#include <unistd.h>
+#include <errno.h>
+]],[[
+ fd_set set;
+ dup2(0, 16);
+ FD_ZERO(&set);
+ FD_SET(16, &set);
+ close(16);
+ struct timeval timeout;
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 5;
+ return select (17, &set, NULL, NULL, &timeout) != -1 || errno != EBADF;
+]])], [gl_cv_func_select_detects_ebadf=yes],
+ [gl_cv_func_select_detects_ebadf=no],
+ [
+ case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_select_detects_ebadf="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_select_detects_ebadf="guessing no" ;;
+ esac
+ ])
+ ])
+ case $gl_cv_func_select_detects_ebadf in
+ *yes) ;;
+ *) REPLACE_SELECT=1 ;;
+ esac
+ fi
+
+ dnl Determine the needed libraries.
+ LIB_SELECT="$LIBSOCKET"
+ if test $REPLACE_SELECT = 1; then
+ case "$host_os" in
+ mingw*)
+ dnl On the MSVC platform, the function MsgWaitForMultipleObjects
+ dnl (used in lib/select.c) requires linking with -luser32. On mingw,
+ dnl it is implicit.
+ AC_LINK_IFELSE(
+ [AC_LANG_SOURCE([[
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+int
+main ()
+{
+ MsgWaitForMultipleObjects (0, NULL, 0, 0, 0);
+ return 0;
+}]])],
+ [],
+ [LIB_SELECT="$LIB_SELECT -luser32"])
+ ;;
+ esac
+ fi
+ AC_SUBST([LIB_SELECT])
+])
diff --git a/m4/servent.m4 b/m4/servent.m4
index 21da957..01c037a 100644
--- a/m4/servent.m4
+++ b/m4/servent.m4
@@ -1,5 +1,5 @@
# servent.m4 serial 2
-dnl Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008, 2010-2013 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/setenv.m4 b/m4/setenv.m4
index e1931e7..cb5351a 100644
--- a/m4/setenv.m4
+++ b/m4/setenv.m4
@@ -1,5 +1,5 @@
# setenv.m4 serial 26
-dnl Copyright (C) 2001-2004, 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2004, 2006-2013 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/signal_h.m4 b/m4/signal_h.m4
index ed4d730..3de9f27 100644
--- a/m4/signal_h.m4
+++ b/m4/signal_h.m4
@@ -1,5 +1,5 @@
# signal_h.m4 serial 18
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/size_max.m4 b/m4/size_max.m4
index 5a8162b..4b247ab 100644
--- a/m4/size_max.m4
+++ b/m4/size_max.m4
@@ -1,5 +1,5 @@
# size_max.m4 serial 10
-dnl Copyright (C) 2003, 2005-2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2005-2006, 2008-2013 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
index de94edd..3698e84 100644
--- a/m4/snprintf.m4
+++ b/m4/snprintf.m4
@@ -1,5 +1,5 @@
# snprintf.m4 serial 6
-dnl Copyright (C) 2002-2004, 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2007-2013 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/socketlib.m4 b/m4/socketlib.m4
index 92a1af2..b08a72f 100644
--- a/m4/socketlib.m4
+++ b/m4/socketlib.m4
@@ -1,5 +1,5 @@
# socketlib.m4 serial 1
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/sockets.m4 b/m4/sockets.m4
index e3738d9..b407391 100644
--- a/m4/sockets.m4
+++ b/m4/sockets.m4
@@ -1,5 +1,5 @@
# sockets.m4 serial 7
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/socklen.m4 b/m4/socklen.m4
index a4ab43b..e3efd6e 100644
--- a/m4/socklen.m4
+++ b/m4/socklen.m4
@@ -1,5 +1,5 @@
# socklen.m4 serial 10
-dnl Copyright (C) 2005-2007, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2005-2007, 2009-2013 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 5f97c3e..89557b1 100644
--- a/m4/sockpfaf.m4
+++ b/m4/sockpfaf.m4
@@ -1,5 +1,5 @@
# sockpfaf.m4 serial 8
-dnl Copyright (C) 2004, 2006, 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2004, 2006, 2009-2013 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 209d64c..6338134 100644
--- a/m4/ssize_t.m4
+++ b/m4/ssize_t.m4
@@ -1,5 +1,5 @@
# ssize_t.m4 serial 5 (gettext-0.18.2)
-dnl Copyright (C) 2001-2003, 2006, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2003, 2006, 2010-2013 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-time.m4 b/m4/stat-time.m4
index 9371d7b..d777f74 100644
--- a/m4/stat-time.m4
+++ b/m4/stat-time.m4
@@ -1,6 +1,6 @@
# Checks for stat-related time functions.
-# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2012 Free Software
+# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2013 Free Software
# Foundation, Inc.
# This file is free software; the Free Software Foundation
diff --git a/m4/stat.m4 b/m4/stat.m4
index a8b79f5..2456297 100644
--- a/m4/stat.m4
+++ b/m4/stat.m4
@@ -1,6 +1,6 @@
-# serial 10
+# serial 11
-# Copyright (C) 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 2009-2013 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -68,8 +68,4 @@ AC_DEFUN([gl_FUNC_STAT],
])
# Prerequisites of lib/stat.c.
-AC_DEFUN([gl_PREREQ_STAT],
-[
- AC_REQUIRE([AC_C_INLINE])
- :
-])
+AC_DEFUN([gl_PREREQ_STAT], [:])
diff --git a/m4/stdalign.m4 b/m4/stdalign.m4
index 6659c9c..3d7993d 100644
--- a/m4/stdalign.m4
+++ b/m4/stdalign.m4
@@ -1,6 +1,6 @@
# Check for stdalign.h that conforms to C11.
-dnl Copyright 2011-2012 Free Software Foundation, Inc.
+dnl Copyright 2011-2013 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 eabfa64..80d5559 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-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2006, 2009-2013 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 cc11609..5da8ab1 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 4
-dnl Copyright (C) 2009-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2009-2013 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 28d342e..27cdcdb 100644
--- a/m4/stdint.m4
+++ b/m4/stdint.m4
@@ -1,5 +1,5 @@
# stdint.m4 serial 43
-dnl Copyright (C) 2001-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2001-2013 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 581de96..511ab4e 100644
--- a/m4/stdint_h.m4
+++ b/m4/stdint_h.m4
@@ -1,5 +1,5 @@
# stdint_h.m4 serial 9
-dnl Copyright (C) 1997-2004, 2006, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 1997-2004, 2006, 2008-2013 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 5298dd6..ebade06 100644
--- a/m4/stdio_h.m4
+++ b/m4/stdio_h.m4
@@ -1,5 +1,5 @@
-# stdio_h.m4 serial 42
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+# stdio_h.m4 serial 43
+dnl Copyright (C) 2007-2013 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -7,7 +7,6 @@ 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_NEXT_HEADERS([stdio.h])
dnl No need to create extra modules for these functions. Everyone who uses
diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4
index 9c69f2e..2027ab3 100644
--- a/m4/stdlib_h.m4
+++ b/m4/stdlib_h.m4
@@ -1,5 +1,5 @@
-# stdlib_h.m4 serial 41
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+# stdlib_h.m4 serial 42
+dnl Copyright (C) 2007-2013 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,7 +22,7 @@ AC_DEFUN([gl_STDLIB_H],
]], [_Exit atoll canonicalize_file_name getloadavg getsubopt grantpt
initstate initstate_r mkdtemp mkostemp mkostemps mkstemp mkstemps
posix_openpt ptsname ptsname_r random random_r realpath rpmatch
- setenv setstate setstate_r srandom srandom_r
+ secure_getenv setenv setstate setstate_r srandom srandom_r
strtod strtoll strtoull unlockpt unsetenv])
])
@@ -60,6 +60,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX])
GNULIB_REALPATH=0; AC_SUBST([GNULIB_REALPATH])
GNULIB_RPMATCH=0; AC_SUBST([GNULIB_RPMATCH])
+ GNULIB_SECURE_GETENV=0; AC_SUBST([GNULIB_SECURE_GETENV])
GNULIB_SETENV=0; AC_SUBST([GNULIB_SETENV])
GNULIB_STRTOD=0; AC_SUBST([GNULIB_STRTOD])
GNULIB_STRTOLL=0; AC_SUBST([GNULIB_STRTOLL])
@@ -88,6 +89,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
HAVE_RANDOM_R=1; AC_SUBST([HAVE_RANDOM_R])
HAVE_REALPATH=1; AC_SUBST([HAVE_REALPATH])
HAVE_RPMATCH=1; AC_SUBST([HAVE_RPMATCH])
+ HAVE_SECURE_GETENV=1; AC_SUBST([HAVE_SECURE_GETENV])
HAVE_SETENV=1; AC_SUBST([HAVE_SETENV])
HAVE_DECL_SETENV=1; AC_SUBST([HAVE_DECL_SETENV])
HAVE_STRTOD=1; AC_SUBST([HAVE_STRTOD])
diff --git a/m4/strftime.m4 b/m4/strftime.m4
index 4204301..b31f495 100644
--- a/m4/strftime.m4
+++ b/m4/strftime.m4
@@ -1,6 +1,6 @@
# serial 33
-# Copyright (C) 1996-1997, 1999-2007, 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 1996-1997, 1999-2007, 2009-2013 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 5677e09..cc5fbbb 100644
--- a/m4/string_h.m4
+++ b/m4/string_h.m4
@@ -1,6 +1,6 @@
# Configure a GNU-like replacement for <string.h>.
-# Copyright (C) 2007-2012 Free Software Foundation, Inc.
+# Copyright (C) 2007-2013 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/sys_file_h.m4 b/m4/sys_file_h.m4
index 89272f1..0cec958 100644
--- a/m4/sys_file_h.m4
+++ b/m4/sys_file_h.m4
@@ -1,7 +1,7 @@
# Configure a replacement for <sys/file.h>.
# serial 6
-# Copyright (C) 2008-2012 Free Software Foundation, Inc.
+# Copyright (C) 2008-2013 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/sys_select_h.m4 b/m4/sys_select_h.m4
new file mode 100644
index 0000000..4962328
--- /dev/null
+++ b/m4/sys_select_h.m4
@@ -0,0 +1,95 @@
+# sys_select_h.m4 serial 20
+dnl Copyright (C) 2006-2013 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_SYS_SELECT],
+[
+ AC_REQUIRE([AC_C_RESTRICT])
+ AC_REQUIRE([gl_SYS_SELECT_H_DEFAULTS])
+ AC_CACHE_CHECK([whether <sys/select.h> is self-contained],
+ [gl_cv_header_sys_select_h_selfcontained],
+ [
+ dnl Test against two bugs:
+ dnl 1. On many platforms, <sys/select.h> assumes prior inclusion of
+ dnl <sys/types.h>.
+ dnl 2. On OSF/1 4.0, <sys/select.h> provides only a forward declaration
+ dnl of 'struct timeval', and no definition of this type.
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/select.h>]],
+ [[struct timeval b;]])],
+ [gl_cv_header_sys_select_h_selfcontained=yes],
+ [gl_cv_header_sys_select_h_selfcontained=no])
+ dnl Test against another bug:
+ dnl 3. On Solaris 10, <sys/select.h> provides an FD_ZERO implementation
+ dnl that relies on memset(), but without including <string.h>.
+ if test $gl_cv_header_sys_select_h_selfcontained = yes; then
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[#include <sys/select.h>]],
+ [[int memset; int bzero;]])
+ ],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM([[#include <sys/select.h>]], [[
+ #undef memset
+ #define memset nonexistent_memset
+ extern
+ #ifdef __cplusplus
+ "C"
+ #endif
+ void *memset (void *, int, unsigned long);
+ #undef bzero
+ #define bzero nonexistent_bzero
+ extern
+ #ifdef __cplusplus
+ "C"
+ #endif
+ void bzero (void *, unsigned long);
+ fd_set fds;
+ FD_ZERO (&fds);
+ ]])
+ ],
+ [],
+ [gl_cv_header_sys_select_h_selfcontained=no])
+ ])
+ fi
+ ])
+ dnl <sys/select.h> is always overridden, because of GNULIB_POSIXCHECK.
+ gl_CHECK_NEXT_HEADERS([sys/select.h])
+ if test $ac_cv_header_sys_select_h = yes; then
+ HAVE_SYS_SELECT_H=1
+ else
+ HAVE_SYS_SELECT_H=0
+ fi
+ AC_SUBST([HAVE_SYS_SELECT_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__ && !defined __UCLIBC__) && HAVE_SYS_TIME_H
+# include <sys/time.h>
+#endif
+#include <sys/select.h>
+ ]], [pselect select])
+])
+
+AC_DEFUN([gl_SYS_SELECT_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_SYS_SELECT_H_DEFAULTS])
+ gl_MODULE_INDICATOR_SET_VARIABLE([$1])
+ dnl Define it also as a C macro, for the benefit of the unit tests.
+ gl_MODULE_INDICATOR_FOR_TESTS([$1])
+])
+
+AC_DEFUN([gl_SYS_SELECT_H_DEFAULTS],
+[
+ GNULIB_PSELECT=0; AC_SUBST([GNULIB_PSELECT])
+ GNULIB_SELECT=0; AC_SUBST([GNULIB_SELECT])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_PSELECT=1; AC_SUBST([HAVE_PSELECT])
+ REPLACE_PSELECT=0; AC_SUBST([REPLACE_PSELECT])
+ REPLACE_SELECT=0; AC_SUBST([REPLACE_SELECT])
+])
diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4
index 8d4e7e1..9486377 100644
--- a/m4/sys_socket_h.m4
+++ b/m4/sys_socket_h.m4
@@ -1,5 +1,5 @@
-# sys_socket_h.m4 serial 22
-dnl Copyright (C) 2005-2012 Free Software Foundation, Inc.
+# sys_socket_h.m4 serial 23
+dnl Copyright (C) 2005-2013 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,7 +10,6 @@ AC_DEFUN([gl_HEADER_SYS_SOCKET],
[
AC_REQUIRE([gl_SYS_SOCKET_H_DEFAULTS])
AC_REQUIRE([AC_CANONICAL_HOST])
- AC_REQUIRE([AC_C_INLINE])
dnl On OSF/1, the functions recv(), send(), recvfrom(), sendto() have
dnl old-style declarations (with return type 'int' instead of 'ssize_t')
diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4
index f45dee1..6dd3d99 100644
--- a/m4/sys_stat_h.m4
+++ b/m4/sys_stat_h.m4
@@ -1,5 +1,5 @@
-# sys_stat_h.m4 serial 27 -*- Autoconf -*-
-dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
+# sys_stat_h.m4 serial 28 -*- Autoconf -*-
+dnl Copyright (C) 2006-2013 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,9 +11,6 @@ AC_DEFUN([gl_HEADER_SYS_STAT_H],
[
AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
- dnl For the mkdir substitute.
- AC_REQUIRE([AC_C_INLINE])
-
dnl Check for broken stat macros.
AC_REQUIRE([AC_HEADER_STAT])
diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4
index c4a30cd..0ac71ac 100644
--- a/m4/sys_time_h.m4
+++ b/m4/sys_time_h.m4
@@ -1,7 +1,7 @@
# Configure a replacement for <sys/time.h>.
# serial 8
-# Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
+# Copyright (C) 2007, 2009-2013 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/sys_times_h.m4 b/m4/sys_times_h.m4
new file mode 100644
index 0000000..6006985
--- /dev/null
+++ b/m4/sys_times_h.m4
@@ -0,0 +1,51 @@
+# Configure a replacement for <sys/times.h>.
+# serial 8
+
+# Copyright (C) 2008-2013 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# Written by Simon Josefsson.
+
+AC_DEFUN([gl_SYS_TIMES_H],
+[
+ AC_REQUIRE([gl_SYS_TIMES_H_DEFAULTS])
+
+ dnl <sys/times.h> is always overridden, because of GNULIB_POSIXCHECK.
+ gl_CHECK_NEXT_HEADERS([sys/times.h])
+ if test $ac_cv_header_sys_times_h = yes; then
+ HAVE_SYS_TIMES_H=1
+ AC_CHECK_TYPES([struct tms], [], [HAVE_STRUCT_TMS=0], [[
+#include <sys/times.h>
+ ]])
+ else
+ HAVE_SYS_TIMES_H=0
+ HAVE_STRUCT_TMS=0
+ fi
+ AC_SUBST([HAVE_SYS_TIMES_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([[
+/* Some systems have incomplete headers. */
+#if !(defined __GLIBC__ && !defined __UCLIBC__)
+# include <time.h>
+#endif
+#include <sys/times.h>
+ ]], [times])
+])
+
+AC_DEFUN([gl_SYS_TIMES_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_SYS_TIMES_H_DEFAULTS])
+ gl_MODULE_INDICATOR_SET_VARIABLE([$1])
+])
+
+AC_DEFUN([gl_SYS_TIMES_H_DEFAULTS],
+[
+ GNULIB_TIMES=0; AC_SUBST([GNULIB_TIMES])
+ HAVE_STRUCT_TMS=1; AC_SUBST([HAVE_STRUCT_TMS])
+ HAVE_TIMES=1; AC_SUBST([HAVE_TIMES])
+])
diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4
index f11eef2..6132727 100644
--- a/m4/sys_types_h.m4
+++ b/m4/sys_types_h.m4
@@ -1,5 +1,5 @@
# sys_types_h.m4 serial 4
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2011-2013 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/sys_uio_h.m4 b/m4/sys_uio_h.m4
index ddf844b..c75cbbd 100644
--- a/m4/sys_uio_h.m4
+++ b/m4/sys_uio_h.m4
@@ -1,5 +1,5 @@
# sys_uio_h.m4 serial 1
-dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2011-2013 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/time_h.m4 b/m4/time_h.m4
index 6415bfb..3b83900 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-2012 Free Software Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009-2013 Free Software Foundation, Inc.
# serial 7
diff --git a/m4/time_r.m4 b/m4/time_r.m4
index 9ddbd01..c388a83 100644
--- a/m4/time_r.m4
+++ b/m4/time_r.m4
@@ -1,6 +1,6 @@
dnl Reentrant time functions: localtime_r, gmtime_r.
-dnl Copyright (C) 2003, 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2006-2013 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/times.m4 b/m4/times.m4
new file mode 100644
index 0000000..a0c8667
--- /dev/null
+++ b/m4/times.m4
@@ -0,0 +1,14 @@
+# times.m4 serial 2
+dnl Copyright (C) 2009-2013 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_TIMES],
+[
+ AC_REQUIRE([gl_SYS_TIMES_H_DEFAULTS])
+ AC_CHECK_FUNCS_ONCE([times])
+ if test $ac_cv_func_times = no; then
+ HAVE_TIMES=0
+ fi
+])
diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4
index c12e6ce..55e7ea3 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-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002, 2009-2013 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/trunc.m4 b/m4/trunc.m4
index 278384d..079cbcb 100644
--- a/m4/trunc.m4
+++ b/m4/trunc.m4
@@ -1,5 +1,5 @@
# trunc.m4 serial 9
-dnl Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007, 2010-2013 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 7e7651b..32dcfa5 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,5 +1,5 @@
-# unistd_h.m4 serial 65
-dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
+# unistd_h.m4 serial 66
+dnl Copyright (C) 2006-2013 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,7 +11,6 @@ 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])
if test $ac_cv_header_unistd_h = yes; then
diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4
index 0ce11da..d730e43 100644
--- a/m4/vasnprintf.m4
+++ b/m4/vasnprintf.m4
@@ -1,5 +1,5 @@
-# vasnprintf.m4 serial 35
-dnl Copyright (C) 2002-2004, 2006-2012 Free Software Foundation, Inc.
+# vasnprintf.m4 serial 36
+dnl Copyright (C) 2002-2004, 2006-2013 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.
@@ -55,7 +55,6 @@ AC_DEFUN([gl_PREREQ_PRINTF_PARSE],
# Prerequisites of lib/vasnprintf.c.
AC_DEFUN_ONCE([gl_PREREQ_VASNPRINTF],
[
- AC_REQUIRE([AC_C_INLINE])
AC_REQUIRE([AC_FUNC_ALLOCA])
AC_REQUIRE([AC_TYPE_LONG_LONG_INT])
AC_REQUIRE([gt_TYPE_WCHAR_T])
diff --git a/m4/visibility.m4 b/m4/visibility.m4
index a7d4d8c..6cbd7e5 100644
--- a/m4/visibility.m4
+++ b/m4/visibility.m4
@@ -1,5 +1,5 @@
# visibility.m4 serial 5 (gettext-0.18.2)
-dnl Copyright (C) 2005, 2008, 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2005, 2008, 2010-2013 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 22ec57b..4900764 100644
--- a/m4/vsnprintf.m4
+++ b/m4/vsnprintf.m4
@@ -1,5 +1,5 @@
# vsnprintf.m4 serial 6
-dnl Copyright (C) 2002-2004, 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2007-2013 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
index a77802e..e43beeb 100644
--- a/m4/warn-on-use.m4
+++ b/m4/warn-on-use.m4
@@ -1,5 +1,5 @@
# warn-on-use.m4 serial 5
-dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2010-2013 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/warnings.m4 b/m4/warnings.m4
index 28b8294..4b2ac38 100644
--- a/m4/warnings.m4
+++ b/m4/warnings.m4
@@ -1,5 +1,5 @@
# warnings.m4 serial 7
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/wchar_h.m4 b/m4/wchar_h.m4
index c7a8b2d..bedb15a 100644
--- a/m4/wchar_h.m4
+++ b/m4/wchar_h.m4
@@ -1,6 +1,6 @@
dnl A placeholder for ISO C99 <wchar.h>, for platforms that have issues.
-dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2007-2013 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/wchar_t.m4 b/m4/wchar_t.m4
index 534735d..e1e1e69 100644
--- a/m4/wchar_t.m4
+++ b/m4/wchar_t.m4
@@ -1,5 +1,5 @@
# wchar_t.m4 serial 4 (gettext-0.18.2)
-dnl Copyright (C) 2002-2003, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2008-2013 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/wcrtomb.m4 b/m4/wcrtomb.m4
index 00d7302..f56b5ba 100644
--- a/m4/wcrtomb.m4
+++ b/m4/wcrtomb.m4
@@ -1,5 +1,5 @@
# wcrtomb.m4 serial 11
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2008-2013 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/wctype_h.m4 b/m4/wctype_h.m4
index 4b19f64..82ada0e 100644
--- a/m4/wctype_h.m4
+++ b/m4/wctype_h.m4
@@ -1,8 +1,8 @@
-# wctype_h.m4 serial 17
+# wctype_h.m4 serial 18
dnl A placeholder for ISO C99 <wctype.h>, for platforms that lack it.
-dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2006-2013 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,8 +22,6 @@ AC_DEFUN([gl_WCTYPE_H],
fi
AC_SUBST([HAVE_ISWCNTRL])
- AC_REQUIRE([AC_C_INLINE])
-
AC_REQUIRE([gt_TYPE_WINT_T])
if test $gt_cv_c_wint_t = yes; then
HAVE_WINT_T=1
diff --git a/m4/wint_t.m4 b/m4/wint_t.m4
index 3260cce..d7cd3db 100644
--- a/m4/wint_t.m4
+++ b/m4/wint_t.m4
@@ -1,5 +1,5 @@
# wint_t.m4 serial 5 (gettext-0.18.2)
-dnl Copyright (C) 2003, 2007-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003, 2007-2013 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 a6b1229..a79b2cc 100644
--- a/m4/write.m4
+++ b/m4/write.m4
@@ -1,5 +1,5 @@
-# write.m4 serial 4
-dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
+# write.m4 serial 5
+dnl Copyright (C) 2008-2013 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.
@@ -29,7 +29,4 @@ AC_DEFUN([gl_FUNC_WRITE],
])
# Prerequisites of lib/write.c.
-AC_DEFUN([gl_PREREQ_WRITE],
-[
- AC_REQUIRE([AC_C_INLINE])
-])
+AC_DEFUN([gl_PREREQ_WRITE], [:])
diff --git a/m4/xsize.m4 b/m4/xsize.m4
index d85a5f1..8ea9f2c 100644
--- a/m4/xsize.m4
+++ b/m4/xsize.m4
@@ -1,5 +1,5 @@
# xsize.m4 serial 5
-dnl Copyright (C) 2003-2004, 2008-2012 Free Software Foundation, Inc.
+dnl Copyright (C) 2003-2004, 2008-2013 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 ea44ece..2b454a1 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-2012 Free Software Foundation, Inc.
+## Copyright (C) 2001-2013 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
@@ -155,7 +155,7 @@ export LC_ALL = C
## Sanity checks. ##
## --------------- ##
-_cfg_mk := $(shell test -f $(srcdir)/cfg.mk && echo '$(srcdir)/cfg.mk')
+_cfg_mk := $(wildcard $(srcdir)/cfg.mk)
# Collect the names of rules starting with 'sc_'.
syntax-check-rules := $(sort $(shell sed -n 's/^\(sc_[a-zA-Z0-9_-]*\):.*/\1/p'
\
@@ -1315,7 +1315,7 @@ announcement_mail_Cc_ ?=
$(announcement_mail_Cc_$(release-type))
announcement_mail_headers_ ?= $(announcement_mail_headers_$(release-type))
announcement: NEWS ChangeLog $(rel-files)
# Not $(AM_V_GEN) since the output of this command serves as
-# annoucement message: it would start with " GEN announcement".
+# announcement message: it would start with " GEN announcement".
$(AM_V_at)$(srcdir)/$(_build-aux)/announce-gen \
--mail-headers='$(announcement_mail_headers_)' \
--release-type=$(release-type) \
@@ -1370,7 +1370,8 @@ endef
.PHONY: no-submodule-changes
no-submodule-changes:
- $(AM_V_GEN)if test -d $(srcdir)/.git; then \
+ $(AM_V_GEN)if test -d $(srcdir)/.git \
+ && git --version >/dev/null 2>&1; then \
diff=$$(cd $(srcdir) && git submodule -q foreach \
git diff-index --name-only HEAD) \
|| exit 1; \
@@ -1388,10 +1389,12 @@ submodule-checks ?= no-submodule-changes
public-submodule-commit
# cannot be built from a fresh clone.
.PHONY: public-submodule-commit
public-submodule-commit:
- $(AM_V_GEN)if test -d $(srcdir)/.git; then \
+ $(AM_V_GEN)if test -d $(srcdir)/.git \
+ && git --version >/dev/null 2>&1; then \
cd $(srcdir) && \
- git submodule --quiet foreach test '$$(git rev-parse $$sha1)' \
- = '$$(git merge-base origin $$sha1)' \
+ git submodule --quiet foreach \
+ test '"$$(git rev-parse "$$sha1")"' \
+ = '"$$(git merge-base origin "$$sha1")"' \
|| { echo '$(ME): found non-public submodule commit' >&2; \
exit 1; }; \
else \
diff --git a/meta/Makefile.am b/meta/Makefile.am
index c9d6a3f..b96483b 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -2,7 +2,7 @@
## Jim Blandy <address@hidden> --- September 1997
##
## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011,
-## 2012 Free Software Foundation, Inc.
+## 2012, 2013 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -30,9 +30,9 @@ EXTRA_DIST= \
# What we now call `guild' used to be known as `guile-tools'.
install-exec-hook:
guild="`echo $(ECHO_N) guild \
- | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+ | $(SED) -e '$(program_transform_name)'`" ; \
guile_tools="`echo $(ECHO_N) guile-tools \
- | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+ | $(SED) -e '$(program_transform_name)'`" ; \
cd $(DESTDIR)$(bindir) && rm -f "$$guile_tools" && \
$(LN_S) "$$guild" "$$guile_tools"
@@ -46,10 +46,10 @@ aclocal_DATA = guile.m4
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 ;
\
- s,@""PKG_CONFIG@,$(PKG_CONFIG),g ;
\
- s,@installed_guile@,$$guile,g"
\
+ cat $(srcdir)/guile-config.in
\
+ | $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g"
\
+ -e "s,@""PKG_CONFIG@,$(PKG_CONFIG),g"
\
+ -e "s,@installed_guile@,$$guile,g"
\
> guile-config.out
mv guile-config.out guile-config
chmod +x guile-config
diff --git a/meta/guild.in b/meta/guild.in
index 183323f..d501a0d 100755
--- a/meta/guild.in
+++ b/meta/guild.in
@@ -8,7 +8,7 @@ exec ${GUILE:address@hidden@/@address@hidden $GUILE_FLAGS -e
'(@@ (guild) main)'
;;;; guild --- running scripts bundled with Guile
;;;; Andy Wingo <address@hidden> --- April 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software 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,7 +51,13 @@ exec ${GUILE:address@hidden@/@address@hidden $GUILE_FLAGS -e
'(@@ (guild) main)'
(define (main args)
(if (defined? 'setlocale)
- (setlocale LC_ALL ""))
+ (catch 'system-error
+ (lambda ()
+ (setlocale LC_ALL ""))
+ (lambda args
+ (format (current-error-port)
+ "warning: failed to install locale: ~a~%"
+ (strerror (system-error-errno args))))))
(let* ((options (getopt-long args *option-grammar*
#:stop-at-first-non-option #t))
diff --git a/meta/guile.in b/meta/guile.in
index 5125827..3d4cacf 100644
--- a/meta/guile.in
+++ b/meta/guile.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2002, 2006, 2008, 2009 Free Software Foundation
+# Copyright (C) 2002, 2006, 2008, 2009, 2013 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -39,7 +39,7 @@
top_builddir="@top_builddir_absolute@"
# set GUILE (clobber)
-GUILE=${top_builddir}/libguile/guile
+GUILE=${top_builddir}/libguile/address@hidden@
export GUILE
XDG_CACHE_HOME=${top_builddir}/cache
export XDG_CACHE_HOME
diff --git a/meta/guile.m4 b/meta/guile.m4
index a7186fb..a3e1ef1 100644
--- a/meta/guile.m4
+++ b/meta/guile.m4
@@ -1,6 +1,6 @@
## Autoconf macros for working with Guile.
##
-## Copyright (C) 1998,2001, 2006, 2010 Free Software Foundation, Inc.
+## Copyright (C) 1998,2001, 2006, 2010, 2012 Free Software Foundation, Inc.
##
## This library is free software; you can redistribute it and/or
## modify it under the terms of the GNU Lesser General Public License
@@ -22,6 +22,7 @@
## Index
## -----
##
+## GUILE_PKG -- find Guile development files
## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
## GUILE_FLAGS -- set flags for compiling and linking with Guile
## GUILE_SITE_DIR -- find path to Guile "site" directory
@@ -38,53 +39,85 @@
## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged
## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory).
-# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
-#
-# Usage: GUILE_PROGS
-#
-# This macro looks for programs @code{guile}, @code{guile-config} and
-# @code{guile-tools}, and sets variables @var{GUILE}, @var{GUILE_CONFIG} and
-# @var{GUILE_TOOLS}, to their paths, respectively. If either of the first two
-# is not found, signal error.
-#
-# The variables are marked for substitution, as by @code{AC_SUBST}.
-#
-AC_DEFUN([GUILE_PROGS],
- [AC_PATH_PROG(GUILE,guile)
- if test "$GUILE" = "" ; then
- AC_MSG_ERROR([guile required but not found])
+# GUILE_PKG -- find Guile development files
+#
+# Usage: GUILE_PKG([VERSIONS])
+#
+# This macro runs the @code{pkg-config} tool to find development files
+# for an available version of Guile.
+#
+# By default, this macro will search for the latest stable version of
+# Guile (e.g. 2.0), falling back to the previous stable version
+# (e.g. 1.8) if it is available. If no address@hidden file is
+# found, an error is signalled. The found version is stored in
+# @var{GUILE_EFFECTIVE_VERSION}.
+#
+# If @code{GUILE_PROGS} was already invoked, this macro ensures that the
+# development files have the same effective version as the Guile
+# program.
+#
+# @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by
+# @code{AC_SUBST}.
+#
+AC_DEFUN([GUILE_PKG],
+ [PKG_PROG_PKG_CONFIG
+ _guile_versions_to_search="m4_default([$1], [2.0 1.8])"
+ if test -n "$GUILE_EFFECTIVE_VERSION"; then
+ _guile_tmp=""
+ for v in $_guile_versions_to_search; do
+ if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then
+ _guile_tmp=$v
+ fi
+ done
+ if test -z "$_guile_tmp"; then
+ AC_MSG_FAILURE([searching for guile development files for versions
$_guile_versions_to_search, but previously found $GUILE version
$GUILE_EFFECTIVE_VERSION])
+ fi
+ _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION
fi
- AC_SUBST(GUILE)
- AC_PATH_PROG(GUILE_CONFIG,guile-config)
- if test "$GUILE_CONFIG" = "" ; then
- AC_MSG_ERROR([guile-config required but not found])
+ GUILE_EFFECTIVE_VERSION=""
+ _guile_errors=""
+ for v in $_guile_versions_to_search; do
+ AC_MSG_NOTICE([checking for guile $v])
+ if test -z "$GUILE_EFFECTIVE_VERSION"; then
+ PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], [])
+ fi
+ done
+
+ if test -z "$GUILE_EFFECTIVE_VERSION"; then
+ AC_MSG_ERROR([
+No Guile development packages were found.
+
+Please verify that you have Guile installed. If you installed Guile
+from a binary distribution, please verify that you have also installed
+the development packages. If you installed it yourself, you might need
+to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more.
+])
fi
- AC_SUBST(GUILE_CONFIG)
- AC_PATH_PROG(GUILE_TOOLS,guile-tools)
- AC_SUBST(GUILE_TOOLS)
+ AC_MSG_NOTICE([found guile $v])
+ AC_SUBST([GUILE_EFFECTIVE_VERSION])
])
# GUILE_FLAGS -- set flags for compiling and linking with Guile
#
# Usage: GUILE_FLAGS
#
-# This macro runs the @code{guile-config} script, installed with Guile, to
-# find out where Guile's header files and libraries are installed. It sets
-# four variables, @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS},
-# and @var{GUILE_LTLIBS}.
+# This macro runs the @code{pkg-config} tool to find out how to compile
+# and link programs against Guile. It sets four variables:
+# @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and
+# @var{GUILE_LTLIBS}.
#
# @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that
# uses Guile header files. This is almost always just one or more @code{-I}
# flags.
#
-# @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program against
-# Guile. This includes @code{-lguile} for the Guile library itself, any
-# libraries that Guile itself requires (like -lqthreads), and so on. It may
-# also include one or more @code{-L} flag to tell the compiler where to find
-# the libraries. But it does not include flags that influence the program's
-# runtime search path for libraries, and will therefore lead to a program
-# that fails to start, unless all necessary libraries are installed in a
-# standard location such as @file{/usr/lib}.
+# @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program
+# against Guile. This includes @address@hidden for the
+# Guile library itself, and may also include one or more @code{-L} flag
+# to tell the compiler where to find the libraries. But it does not
+# include flags that influence the program's runtime search path for
+# libraries, and will therefore lead to a program that fails to start,
+# unless all necessary libraries are installed in a standard location
+# such as @file{/usr/lib}.
#
# @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to
# libtool, respectively, to link a program against Guile. It includes flags
@@ -97,16 +130,14 @@ AC_DEFUN([GUILE_PROGS],
# The variables are marked for substitution, as by @code{AC_SUBST}.
#
AC_DEFUN([GUILE_FLAGS],
- [dnl Find guile-config.
- AC_REQUIRE([GUILE_PROGS])dnl
+ [AC_REQUIRE([GUILE_PKG])
+ PKG_CHECK_MODULES(GUILE, [guile-$GUILE_EFFECTIVE_VERSION])
- AC_MSG_CHECKING([libguile compile flags])
- GUILE_CFLAGS="`$GUILE_CONFIG compile`"
- AC_MSG_RESULT([$GUILE_CFLAGS])
+ dnl GUILE_CFLAGS and GUILE_LIBS are already defined and AC_SUBST'd by
+ dnl PKG_CHECK_MODULES. But GUILE_LIBS to pkg-config is GUILE_LDFLAGS
+ dnl to us.
- AC_MSG_CHECKING([libguile link flags])
- GUILE_LDFLAGS="`$GUILE_CONFIG link`"
- AC_MSG_RESULT([$GUILE_LDFLAGS])
+ GUILE_LDFLAGS=$GUILE_LIBS
dnl Determine the platform dependent parameters needed to use rpath.
dnl AC_LIB_LINKFLAGS_FROM_LIBS is defined in gnulib/m4/lib-link.m4 and needs
@@ -116,6 +147,7 @@ AC_DEFUN([GUILE_FLAGS],
AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LTLIBS], [$GUILE_LDFLAGS], [yes])
GUILE_LTLIBS="$GUILE_LDFLAGS $GUILE_LTLIBS"
+ AC_SUBST([GUILE_EFFECTIVE_VERSION])
AC_SUBST([GUILE_CFLAGS])
AC_SUBST([GUILE_LDFLAGS])
AC_SUBST([GUILE_LIBS])
@@ -133,16 +165,61 @@ AC_DEFUN([GUILE_FLAGS],
# The variable is marked for substitution, as by @code{AC_SUBST}.
#
AC_DEFUN([GUILE_SITE_DIR],
- [AC_REQUIRE([GUILE_PROGS])dnl
+ [AC_REQUIRE([GUILE_PKG])
AC_MSG_CHECKING(for Guile site directory)
- GUILE_SITE=`[$GUILE_CONFIG] info sitedir`
+ GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir
guile-$GUILE_EFFECTIVE_VERSION`
+ AC_MSG_RESULT($GUILE_SITE)
if test "$GUILE_SITE" = ""; then
- GUILE_SITE=`[$GUILE_CONFIG] info pkgdatadir`/site
+ AC_MSG_FAILURE(sitedir not found)
fi
- AC_MSG_RESULT($GUILE_SITE)
AC_SUBST(GUILE_SITE)
])
+# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
+#
+# Usage: GUILE_PROGS
+#
+# This macro looks for programs @code{guile} and @code{guild}, setting
+# variables @var{GUILE} and @var{GUILD} to their paths, respectively.
+# If @code{guile} is not found, signal an error.
+#
+# The effective version of the found @code{guile} is set to
+# @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective
+# version is compatible with the result of a previous invocation of
+# @code{GUILE_FLAGS}, if any.
+#
+# As a legacy interface, it also looks for @code{guile-config} and
+# @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}.
+#
+# The variables are marked for substitution, as by @code{AC_SUBST}.
+#
+AC_DEFUN([GUILE_PROGS],
+ [AC_PATH_PROG(GUILE,guile)
+ if test "$GUILE" = "" ; then
+ AC_MSG_ERROR([guile required but not found])
+ fi
+ AC_SUBST(GUILE)
+
+ _guile_prog_version=`$GUILE -c "(display (effective-version))"`
+ if test -z "$GUILE_EFFECTIVE_VERSION"; then
+ GUILE_EFFECTIVE_VERSION=$_guile_prog_version
+ elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_prog_version"; then
+ AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION,
but $GUILE has effective version $_guile_prog_version])
+ fi
+
+ AC_PATH_PROG(GUILD,guild)
+ AC_SUBST(GUILD)
+
+ AC_PATH_PROG(GUILE_CONFIG,guile-config)
+ AC_SUBST(GUILE_CONFIG)
+ if test -n "$GUILD"; then
+ GUILE_TOOLS=$GUILD
+ else
+ AC_PATH_PROG(GUILE_TOOLS,guile-tools)
+ fi
+ AC_SUBST(GUILE_TOOLS)
+ ])
+
# GUILE_CHECK -- evaluate Guile Scheme code and capture the return value
#
# Usage: GUILE_CHECK_RETVAL(var,check)
diff --git a/module/Makefile.am b/module/Makefile.am
index 06248d7..d70d01e 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -112,8 +112,7 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/spec.scm
GLIL_LANG_SOURCES = \
- language/glil/spec.scm language/glil/compile-assembly.scm \
- language/glil/decompile-assembly.scm
+ language/glil/spec.scm language/glil/compile-assembly.scm
ASSEMBLY_LANG_SOURCES = \
language/assembly/spec.scm \
@@ -159,7 +158,6 @@ BRAINFUCK_LANG_SOURCES = \
language/brainfuck/spec.scm
SCRIPTS_SOURCES = \
- scripts/autofrisk.scm \
scripts/compile.scm \
scripts/disassemble.scm \
scripts/display-commentary.scm \
@@ -175,7 +173,6 @@ SCRIPTS_SOURCES = \
scripts/use2dot.scm \
scripts/snarf-check-and-output-texi.scm \
scripts/summarize-guile-TODO.scm \
- scripts/scan-api.scm \
scripts/api-diff.scm \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm
@@ -257,12 +254,17 @@ ICE_9_SOURCES = \
ice-9/serialize.scm \
ice-9/local-eval.scm
-if HAVE_FORK
+if BUILD_ICE_9_POPEN
# This functionality is missing on systems without `fork'---i.e., Windows.
ICE_9_SOURCES += ice-9/popen.scm
-endif HAVE_FORK
+# These modules rely on (ice-9 popen).
+SCRIPTS_SOURCES += \
+ scripts/autofrisk.scm \
+ scripts/scan-api.scm
+
+endif BUILD_ICE_9_POPEN
SRFI_SOURCES = \
srfi/srfi-2.scm \
@@ -287,6 +289,7 @@ SRFI_SOURCES = \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
+ srfi/srfi-41.scm \
srfi/srfi-42.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
@@ -346,6 +349,7 @@ SYSTEM_SOURCES = \
system/vm/coverage.scm \
system/vm/dwarf.scm \
system/vm/elf.scm \
+ system/vm/linker.scm \
system/vm/frame.scm \
system/vm/instruction.scm \
system/vm/objcode.scm \
@@ -353,7 +357,9 @@ SYSTEM_SOURCES = \
system/vm/trace.scm \
system/vm/traps.scm \
system/vm/trap-state.scm \
- system/vm/rtl.scm \
+ system/vm/assembler.scm \
+ system/vm/debug.scm \
+ system/vm/disassembler.scm \
system/vm/vm.scm \
system/foreign.scm \
system/xref.scm \
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index c07900b..9d6c945 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -1,6 +1,6 @@
;;;; binary-ports.scm --- Binary IO on ports
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -40,6 +40,7 @@
get-string-n!
put-u8
put-bytevector
+ unget-bytevector
open-bytevector-output-port
make-custom-binary-output-port))
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 735ffcf..f1fd041 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -271,12 +271,14 @@ a-cont
(define *null-device* "/dev/null")
+;; NOTE: Later in this file, this is redefined to support keywords
(define (open-input-file str)
"Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file
cannot be opened, an error is signalled."
(open-file str OPEN_READ))
+;; NOTE: Later in this file, this is redefined to support keywords
(define (open-output-file str)
"Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
@@ -391,6 +393,12 @@ file with the given name already exists, the effect is
unspecified."
(apply f (car l1) (map car rest))
(lp (cdr l1) (map cdr rest))))))))
+;; Temporary definition used in the include-from-path expansion;
+;; replaced later.
+
+(define (absolute-file-name? file-name)
+ #t)
+
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
@@ -627,12 +635,10 @@ file with the given name already exists, the effect is
unspecified."
datum
(syntax->datum clause)
(syntax->datum whole-expr)))
- (if (memv datum seen)
- (warn-datum 'duplicate-case-datum))
- (if (or (pair? datum)
- (array? datum)
- (generalized-vector? datum))
- (warn-datum 'bad-case-datum))
+ (when (memv datum seen)
+ (warn-datum 'duplicate-case-datum))
+ (when (or (pair? datum) (array? datum))
+ (warn-datum 'bad-case-datum))
(cons datum seen))
seen
(map syntax->datum #'(datums ...)))))
@@ -966,6 +972,8 @@ information is unavailable."
#'(define-macro macro doc (lambda args body1 body ...)))
((_ (macro . args) body ...)
#'(define-macro macro #f (lambda args body ...)))
+ ((_ macro transformer)
+ #'(define-macro macro #f transformer))
((_ macro doc transformer)
(or (string? (syntax->datum #'doc))
(not (syntax->datum #'doc)))
@@ -1033,13 +1041,32 @@ VALUE."
(lambda _
value))
-(define (and=> value procedure) (and value (procedure value)))
+(define (and=> value procedure)
+ "When VALUE is #f, return #f. Otherwise, return (PROC VALUE)."
+ (and value (procedure value)))
+
(define call/cc call-with-current-continuation)
-(define-syntax-rule (false-if-exception expr)
- (catch #t
- (lambda () expr)
- (lambda (k . args) #f)))
+(define-syntax false-if-exception
+ (syntax-rules ()
+ ((false-if-exception expr)
+ (catch #t
+ (lambda () expr)
+ (lambda args #f)))
+ ((false-if-exception expr #:warning template arg ...)
+ (catch #t
+ (lambda () expr)
+ (lambda (key . args)
+ (for-each (lambda (s)
+ (if (not (string-null? s))
+ (format (current-warning-port) ";;; ~a\n" s)))
+ (string-split
+ (call-with-output-string
+ (lambda (port)
+ (format port template arg ...)
+ (print-exception port #f key args)))
+ #\newline))
+ #f)))))
@@ -1429,26 +1456,48 @@ CONV is not applied to the initial value."
;;; {High-Level Port Routines}
;;;
-(define (call-with-input-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The file must already exist. These procedures
-call PROC with one argument: the port obtained by opening the named file
-for input or output. If the file cannot be opened, an error is
+(define* (open-input-file
+ file #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file file (if binary "rb" "r")
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
+
+(define* (open-output-file file #:key (binary #f) (encoding #f))
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file file (if binary "wb" "w")
+ #:encoding encoding))
+
+(define* (call-with-input-file
+ file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned. If
-the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will never
-again be used for a read or write operation."
- (let ((p (open-input-file str)))
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-input-file file
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-input-port p)
(apply values vals)))))
-(define (call-with-output-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The behaviour is unspecified if the file
+(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The behaviour is unspecified if the file
already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
@@ -1457,7 +1506,7 @@ automatically and the values yielded by the procedure are
returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
- (let ((p (open-output-file str)))
+ (let ((p (open-output-file file #:binary binary #:encoding encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
@@ -1476,44 +1525,52 @@ never again be used for a read or write operation."
(parameterize ((current-error-port port))
(thunk)))
-(define (with-input-from-file file thunk)
+(define* (with-input-from-file
+ file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The file must already exist. The file is opened for
input, an input port connected to it is made
-the default value returned by `current-input-port',
+the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-file file
- (lambda (p) (with-input-from-port p thunk))))
+ (lambda (p) (with-input-from-port p thunk))
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
-(define (with-output-to-file file thunk)
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
+string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
+the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
- (lambda (p) (with-output-to-port p thunk))))
+ (lambda (p) (with-output-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
-(define (with-error-to-file file thunk)
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
+string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
+the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
- (lambda (p) (with-error-to-port p thunk))))
+ (lambda (p) (with-error-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
(define (call-with-input-string string proc)
"Calls the one-argument procedure @var{proc} with a newly created
@@ -1777,16 +1834,70 @@ written into the port is returned."
;;; {Load Paths}
;;;
+(let-syntax ((compile-time-case
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ exp clauses ...)
+ (let ((val (primitive-eval (syntax->datum #'exp))))
+ (let next-clause ((clauses #'(clauses ...)))
+ (syntax-case clauses (else)
+ (()
+ (syntax-violation 'compile-time-case
+ "all clauses failed to match" stx))
+ (((else form ...))
+ #'(begin form ...))
+ ((((k ...) form ...) clauses ...)
+ (if (memv val (syntax->datum #'(k ...)))
+ #'(begin form ...)
+ (next-clause #'(clauses ...))))))))))))
+ ;; emacs: (put 'compile-time-case 'scheme-indent-function 1)
+ (compile-time-case (system-file-name-convention)
+ ((posix)
+ (define (file-name-separator? c)
+ (char=? c #\/))
+
+ (define file-name-separator-string "/")
+
+ (define (absolute-file-name? file-name)
+ (string-prefix? "/" file-name)))
+
+ ((windows)
+ (define (file-name-separator? c)
+ (or (char=? c #\/)
+ (char=? c #\\)))
+
+ (define file-name-separator-string "\\")
+
+ (define (absolute-file-name? file-name)
+ (define (file-name-separator-at-index? idx)
+ (and (> (string-length file-name) idx)
+ (file-name-separator? (string-ref file-name idx))))
+ (define (unc-file-name?)
+ ;; Universal Naming Convention (UNC) file-names start with \\,
+ ;; and are always absolute. See:
+ ;;
http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#fully_qualified_vs._relative_paths
+ (and (file-name-separator-at-index? 0)
+ (file-name-separator-at-index? 1)))
+ (define (has-drive-specifier?)
+ (and (>= (string-length file-name) 2)
+ (let ((drive (string-ref file-name 0)))
+ (or (char<=? #\a drive #\z)
+ (char<=? #\A drive #\Z)))
+ (eqv? (string-ref file-name 1) #\:)))
+ (or (unc-file-name?)
+ (if (has-drive-specifier?)
+ (file-name-separator-at-index? 2)
+ (file-name-separator-at-index? 0)))))))
+
(define (in-vicinity vicinity file)
(let ((tail (let ((len (string-length vicinity)))
(if (zero? len)
#f
(string-ref vicinity (- len 1))))))
(string-append vicinity
- (if (or (not tail)
- (eq? tail #\/))
+ (if (or (not tail) (file-name-separator? tail))
""
- "/")
+ file-name-separator-string)
file)))
@@ -1806,7 +1917,7 @@ written into the port is returned."
(define (load-user-init)
(let* ((home (or (getenv "HOME")
(false-if-exception (passwd:dir (getpwuid (getuid))))
- "/")) ;; fallback for cygwin etc.
+ file-name-separator-string)) ;; fallback for cygwin etc.
(init-file (in-vicinity home ".guile")))
(if (file-exists? init-file)
(primitive-load init-file))))
@@ -3061,16 +3172,18 @@ written into the port is returned."
(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))))))
+ (false-if-exception
+ (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)))
+ #:warning "Failed to autoload ~a in ~a:\n" sym name))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
(make-hash-table 0) '() (make-weak-value-hash-table
31) #f
(make-hash-table 0) #f #f #f)))
@@ -3112,7 +3225,8 @@ but it fails to load."
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
- (string-append (symbol->string elt) "/"))
+ (string-append (symbol->string elt)
+ file-name-separator-string))
dir-hint-module-name))))
(resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
@@ -3795,16 +3909,17 @@ but it fails to load."
;;; {`load'.}
;;;
-;;; Load is tricky when combined with relative paths, compilation, and
-;;; the file system. If a path is relative, what is it relative to? The
-;;; path of the source file at the time it was compiled? The path of
-;;; the compiled file? What if both or either were installed? And how
-;;; do you get that information? Tricky, I say.
+;;; Load is tricky when combined with relative file names, compilation,
+;;; and the file system. If a file name is relative, what is it
+;;; relative to? The name of the source file at the time it was
+;;; compiled? The name of the compiled file? What if both or either
+;;; were installed? And how do you get that information? Tricky, I
+;;; say.
;;;
;;; To get around all of this, we're going to do something nasty, and
-;;; turn `load' into a macro. That way it can know the path of the
+;;; turn `load' into a macro. That way it can know the name of the
;;; source file with respect to which it was invoked, so it can resolve
-;;; relative paths with respect to the original source path.
+;;; relative file names with respect to the original source file.
;;;
;;; There is an exception, and that is that if the source file was in
;;; the load path when it was compiled, instead of looking up against
@@ -3817,18 +3932,28 @@ but it fails to load."
'(#:warnings (unbound-variable arity-mismatch format
duplicate-case-datum bad-case-datum)))
-(define* (load-in-vicinity dir path #:optional reader)
- "Load source file PATH in vicinity of directory DIR. Use a pre-compiled
-version of PATH when available, and auto-compile one when none is available,
-reading PATH with READER."
+(define* (load-in-vicinity dir file-name #:optional reader)
+ "Load source file FILE-NAME in vicinity of directory DIR. Use a
+pre-compiled version of FILE-NAME when available, and auto-compile one
+when none is available, reading FILE-NAME with READER."
+ ;; The auto-compilation code will residualize a .go file in the cache
+ ;; dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This
+ ;; function determines the PATH to use as a key into the compilation
+ ;; cache.
(define (canonical->suffix canon)
(cond
- ((string-prefix? "/" canon) canon)
- ((and (> (string-length canon) 2)
- (eqv? (string-ref canon 1) #\:))
- ;; Paths like C:... transform to /C...
- (string-append "/" (substring canon 0 1) (substring canon 2)))
+ ((and (not (string-null? canon))
+ (file-name-separator? (string-ref canon 0)))
+ canon)
+ ((and (eq? (system-file-name-convention) 'windows)
+ (absolute-file-name? canon))
+ ;; An absolute file name that doesn't start with a separator
+ ;; starts with a drive component. Transform the drive component
+ ;; to a file name element: c:\foo -> \c\foo.
+ (string-append file-name-separator-string
+ (substring canon 0 1)
+ (substring canon 2)))
(else canon)))
(define compiled-extension
@@ -3847,14 +3972,16 @@ reading PATH with READER."
(>= (stat:mtimensec stat1)
(stat:mtimensec stat2)))))
- (define (fallback-file-name canon-path)
- ;; Return the in-cache compiled file name for source file CANON-PATH.
+ (define (fallback-file-name canon-file-name)
+ ;; Return the in-cache compiled file name for source file
+ ;; CANON-FILE-NAME.
- ;; FIXME: would probably be better just to append SHA1(canon-path)
- ;; to the %compile-fallback-path, to avoid deep directory stats.
+ ;; FIXME: would probably be better just to append
+ ;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid
+ ;; deep directory stats.
(and %compile-fallback-path
(string-append %compile-fallback-path
- (canonical->suffix canon-path)
+ (canonical->suffix canon-file-name)
compiled-extension)))
(define (compile file)
@@ -3865,55 +3992,41 @@ reading PATH with READER."
#:opts %auto-compilation-options
#:env (current-module)))
- (define (warn-about-exception key args)
- (for-each (lambda (s)
- (if (not (string-null? s))
- (format (current-warning-port) ";;; ~a\n" s)))
- (string-split
- (call-with-output-string
- (lambda (port) (print-exception port #f key args)))
- #\newline)))
-
- ;; Returns the .go file corresponding to `name'. Does not search load
- ;; paths, only the fallback path. If the .go file is missing or out of
- ;; date, and auto-compilation is enabled, will try auto-compilation, just
- ;; as primitive-load-path does internally. primitive-load is
- ;; unaffected. Returns #f if auto-compilation failed or was disabled.
+ ;; Returns the .go file corresponding to `name'. Does not search load
+ ;; paths, only the fallback path. If the .go file is missing or out
+ ;; of date, and auto-compilation is enabled, will try
+ ;; auto-compilation, just as primitive-load-path does internally.
+ ;; primitive-load is unaffected. Returns #f if auto-compilation
+ ;; failed or was disabled.
;;
- ;; 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 (fresh-compiled-file-name name scmstat go-path)
- ;; Return GO-PATH after making sure that it contains a freshly compiled
- ;; version of source file NAME with stat SCMSTAT; return #f on failure.
- (catch #t
- (lambda ()
- (let ((gostat (and (not %fresh-auto-compile)
- (stat go-path #f))))
- (if (and gostat (more-recent? gostat scmstat))
- go-path
- (begin
- (if gostat
- (format (current-warning-port)
- ";;; note: source file ~a\n;;; newer than
compiled ~a\n"
- name go-path))
- (cond
- (%load-should-auto-compile
- (%warn-auto-compilation-enabled)
- (format (current-warning-port) ";;; compiling ~a\n" name)
- (let ((cfn (compile name)))
- (format (current-warning-port) ";;; compiled ~a\n" cfn)
- cfn))
- (else #f))))))
- (lambda (k . args)
- (format (current-warning-port)
- ";;; WARNING: compilation of ~a failed:\n" name)
- (warn-about-exception k args)
- #f)))
-
- (define (absolute-path? path)
- (string-prefix? "/" path))
+ ;; 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 (fresh-compiled-file-name name scmstat go-file-name)
+ ;; Return GO-FILE-NAME after making sure that it contains a freshly
+ ;; compiled version of source file NAME with stat SCMSTAT; return #f
+ ;; on failure.
+ (false-if-exception
+ (let ((gostat (and (not %fresh-auto-compile)
+ (stat go-file-name #f))))
+ (if (and gostat (more-recent? gostat scmstat))
+ go-file-name
+ (begin
+ (if gostat
+ (format (current-warning-port)
+ ";;; note: source file ~a\n;;; newer than
compiled ~a\n"
+ name go-file-name))
+ (cond
+ (%load-should-auto-compile
+ (%warn-auto-compilation-enabled)
+ (format (current-warning-port) ";;; compiling ~a\n" name)
+ (let ((cfn (compile name)))
+ (format (current-warning-port) ";;; compiled ~a\n" cfn)
+ cfn))
+ (else #f)))))
+ #:warning "WARNING: compilation of ~a failed:\n" name))
(define (sans-extension file)
(let ((dot (string-rindex file #\.)))
@@ -3921,52 +4034,51 @@ reading PATH with READER."
(substring file 0 dot)
file)))
- (define (load-absolute abs-path)
- ;; Load from ABS-PATH, using a compiled file or auto-compiling if needed.
+ (define (load-absolute abs-file-name)
+ ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling
+ ;; if needed.
(define scmstat
- (catch #t
- (lambda ()
- (stat abs-path))
- (lambda (key . args)
- (warn-about-exception key args)
- #f)))
+ (false-if-exception
+ (stat abs-file-name)
+ #:warning "Stat of ~a failed:\n" abs-file-name))
(define (pre-compiled)
- (let ((go-path (search-path %load-compiled-path (sans-extension path)
- %load-compiled-extensions #t)))
- (and go-path
- (let ((gostat (stat go-path #f)))
- (and gostat (more-recent? gostat scmstat)
- go-path)))))
+ (and=> (search-path %load-compiled-path (sans-extension file-name)
+ %load-compiled-extensions #t)
+ (lambda (go-file-name)
+ (let ((gostat (stat go-file-name #f)))
+ (and gostat (more-recent? gostat scmstat)
+ go-file-name)))))
(define (fallback)
- (let ((canon (false-if-exception (canonicalize-path abs-path))))
- (and canon
- (let ((go-path (fallback-file-name canon)))
- (and go-path
- (fresh-compiled-file-name abs-path scmstat go-path))))))
-
- (let ((compiled (and scmstat
- (or (pre-compiled) (fallback)))))
+ (and=> (false-if-exception (canonicalize-path abs-file-name))
+ (lambda (canon)
+ (and=> (fallback-file-name canon)
+ (lambda (go-file-name)
+ (fresh-compiled-file-name abs-file-name
+ scmstat
+ go-file-name))))))
+
+ (let ((compiled (and scmstat (or (pre-compiled) (fallback)))))
(if compiled
(begin
(if %load-hook
- (%load-hook abs-path))
+ (%load-hook abs-file-name))
(load-compiled compiled))
(start-stack 'load-stack
- (primitive-load abs-path)))))
+ (primitive-load abs-file-name)))))
(save-module-excursion
(lambda ()
(with-fluids ((current-reader reader)
(%file-port-name-canonicalization 'relative))
(cond
- ((absolute-path? path)
- (load-absolute path))
- ((absolute-path? dir)
- (load-absolute (in-vicinity dir path)))
+ ((absolute-file-name? file-name)
+ (load-absolute file-name))
+ ((absolute-file-name? dir)
+ (load-absolute (in-vicinity dir file-name)))
(else
- (load-from-path (in-vicinity dir path))))))))
+ (load-from-path (in-vicinity dir file-name))))))))
(define-syntax load
(make-variable-transformer
@@ -4009,22 +4121,22 @@ reading PATH with READER."
;;; <feature-identifier>s `guile' and `r5rs', so that programs can
;;; determine the implementation type and the supported standard.
;;;
-;;; Currently, the following feature identifiers are supported:
-;;;
-;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
-;;;
;;; Remember to update the features list when adding more SRFIs.
;;;
(define %cond-expand-features
- ;; Adjust the above comment when changing this.
+ ;; This should contain only features that are present in core Guile,
+ ;; before loading any modules. Modular features are handled by
+ ;; placing 'cond-expand-provide' in the relevant module.
'(guile
guile-2
guile-2.2
r5rs
srfi-0 ;; cond-expand itself
- srfi-4 ;; homogenous numeric vectors
- srfi-6 ;; open-input-string etc, in the guile core
+ srfi-4 ;; homogeneous numeric vectors
+ ;; We omit srfi-6 because the 'open-input-string' etc in Guile
+ ;; core are not conformant with SRFI-6; they expose details
+ ;; of the binary I/O model and may fail to support some characters.
srfi-13 ;; string library
srfi-14 ;; character sets
srfi-23 ;; `error` procedure
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 2aa50ec..bd19316 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
(define* (version-etc package version #:key
(port (current-output-port))
;; FIXME: authors
- (copyright-year 2012)
+ (copyright-year 2013)
(copyright-holder "Free Software Foundation, Inc.")
(copyright (format #f "Copyright (C) ~a ~a"
copyright-year copyright-holder))
@@ -117,6 +117,7 @@ remaining arguments as the value of (command-line).
If FILE begins with `-' the -s switch is mandatory.
-L DIRECTORY add DIRECTORY to the front of the module load path
+ -C DIRECTORY like -L, but for compiled files
-x EXTENSION add EXTENSION to the front of the load extensions
-l FILE load source code from FILE
-e FUNCTION after reading script, apply FUNCTION to
@@ -194,6 +195,7 @@ If FILE begins with `-' the -s switch is mandatory.
(script-cell #f)
(entry-point #f)
(user-load-path '())
+ (user-load-compiled-path '())
(user-extensions '())
(interactive? #t)
(inhibit-user-init? #f)
@@ -264,6 +266,14 @@ If FILE begins with `-' the -s switch is mandatory.
(parse (cdr args)
out))
+ ((string=? arg "-C") ; add to %load-compiled-path
+ (if (null? args)
+ (error "missing argument to `-C' switch"))
+ (set! user-load-compiled-path
+ (cons (car args) user-load-compiled-path))
+ (parse (cdr args)
+ out))
+
((string=? arg "-x") ; add to %load-extensions
(if (null? args)
(error "missing argument to `-x' switch"))
@@ -430,11 +440,15 @@ If FILE begins with `-' the -s switch is mandatory.
`(set! %load-extensions (cons ,ext %load-extensions)))
user-extensions)
- ;; Add the user-specified load path here, so it won't be in
+ ;; Add the user-specified load paths here, so they won't be in
;; effect during the loading of the user's customization file.
,@(map (lambda (path)
`(set! %load-path (cons ,path %load-path)))
user-load-path)
+ ,@(map (lambda (path)
+ `(set! %load-compiled-path
+ (cons ,path %load-compiled-path)))
+ user-load-compiled-path)
;; Put accumulated actions in their correct order.
,@(reverse! out)
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index 5f25738..3eb71a4 100644
--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@@ -1,6 +1,6 @@
;;; Beyond call/cc
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -21,7 +21,9 @@
(define-module (ice-9 control)
#:re-export (call-with-prompt abort-to-prompt
default-prompt-tag make-prompt-tag)
- #:export (% abort shift reset shift* reset*))
+ #:export (% abort shift reset shift* reset*
+ call-with-escape-continuation call/ec
+ let-escape-continuation let/ec))
(define (abort . args)
(apply abort-to-prompt (default-prompt-tag) args))
@@ -76,3 +78,29 @@
(define (shift* fc)
(shift c (fc c)))
+
+(define (call-with-escape-continuation proc)
+ "Call PROC with an escape continuation."
+ (let ((tag (list 'call/ec)))
+ (call-with-prompt tag
+ (lambda ()
+ (proc (lambda args
+ (apply abort-to-prompt tag args))))
+ (lambda (_ . args)
+ (apply values args)))))
+
+(define call/ec call-with-escape-continuation)
+
+(define-syntax-rule (let-escape-continuation k body ...)
+ "Bind K to an escape continuation within the lexical extent of BODY."
+ (let ((tag (list 'let/ec)))
+ (call-with-prompt tag
+ (lambda ()
+ (let ((k (lambda args
+ (apply abort-to-prompt tag args))))
+ body ...))
+ (lambda (_ . results)
+ (apply values results)))))
+
+(define-syntax-rule (let/ec k body ...)
+ (let-escape-continuation k body ...))
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 6ff104d..90bbe53 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software 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 (srfi srfi-11)
#:use-module (ice-9 q)
#:use-module (ice-9 match)
+ #:use-module (ice-9 control)
#:export (future make-future future? touch))
;;; Author: Ludovic Courtès <address@hidden>
@@ -88,8 +89,14 @@ touched."
;; A mapping of nested futures to futures waiting for them to complete.
(define %futures-waiting '())
-;; Whether currently running within a future.
-(define %within-future? (make-parameter #f))
+;; Nesting level of futures. Incremented each time a future is touched
+;; from within a future.
+(define %nesting-level (make-parameter 0))
+
+;; Maximum nesting level. The point is to avoid stack overflows when
+;; nested futures are executed on the same stack. See
+;; <http://bugs.gnu.org/13188>.
+(define %max-nesting-level 200)
(define-syntax-rule (with-mutex m e0 e1 ...)
;; Copied from (ice-9 threads) to avoid circular dependency.
@@ -99,16 +106,6 @@ touched."
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))
-(define-syntax-rule (let/ec k e e* ...) ; TODO: move to core
- (let ((tag (make-prompt-tag)))
- (call-with-prompt
- tag
- (lambda ()
- (let ((k (lambda args (apply abort-to-prompt tag args))))
- e e* ...))
- (lambda (_ res) res))))
-
-
(define %future-prompt
;; The prompt futures abort to when they want to wait for another
;; future.
@@ -155,7 +152,8 @@ adding it to the waiter queue."
(thunk (lambda ()
(call-with-prompt %future-prompt
(lambda ()
- (parameterize ((%within-future? #t))
+ (parameterize ((%nesting-level
+ (1+ (%nesting-level))))
((future-thunk future))))
suspend))))
(set-future-result! future
@@ -254,14 +252,16 @@ adding it to the waiter queue."
(unlock-mutex (future-mutex future)))
((started)
(unlock-mutex (future-mutex future))
- (if (%within-future?)
+ (if (> (%nesting-level) 0)
(abort-to-prompt %future-prompt future)
(begin
(work)
(loop))))
- (else
+ (else ; queued
(unlock-mutex (future-mutex future))
- (work)
+ (if (> (%nesting-level) %max-nesting-level)
+ (abort-to-prompt %future-prompt future)
+ (work))
(loop))))
((future-result future)))
diff --git a/module/ice-9/mapping.scm b/module/ice-9/mapping.scm
index 2907a8d..bd4dbfb 100644
--- a/module/ice-9/mapping.scm
+++ b/module/ice-9/mapping.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1996, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 2001, 2006, 2013 Free Software 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,9 @@
mapping-ref mapping-set! hash-table-mapping-hooks
make-hash-table-mapping hash-table-mapping))
+(issue-deprecation-warning
+ "(ice-9 mapping) is deprecated. Use srfi-69 or rnrs hash tables instead.")
+
(define mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
create-handle
remove)))
@@ -50,16 +53,15 @@
(define (mapping-get-handle map key)
((mapping-hooks-get-handle (mapping-hooks map)) map key))
-(define (mapping-create-handle! map key . opts)
- (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
+(define (mapping-create-handle! map key init)
+ ((mapping-hooks-create-handle (mapping-hooks map)) map key init))
(define (mapping-remove! map key)
((mapping-hooks-remove (mapping-hooks map)) map key))
-(define (mapping-ref map key . dflt)
+(define* (mapping-ref map key #:optional dflt)
(cond
- ((mapping-get-handle map key) => cdr)
- (dflt => car)
- (else #f)))
+ ((mapping-get-handle map key) => cdr)
+ (else dflt)))
(define (mapping-set! map key val)
(set-cdr! (mapping-create-handle! map key #f) val))
@@ -70,18 +72,18 @@
(let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data
1st) rest)))))
(perfect-funcq 17
- (lambda (hash-proc assoc-proc delete-proc)
- (let ((procs (list hash-proc assoc-proc delete-proc)))
+ (lambda (hash-proc assoc-proc)
+ (let ((procs (list hash-proc assoc-proc)))
(cond
- ((equal? procs `(,hashq ,assq ,delq!))
+ ((equal? procs `(,hashq ,assq))
(make-mapping-hooks (wrap hashq-get-handle)
(wrap hashq-create-handle!)
(wrap hashq-remove!)))
- ((equal? procs `(,hashv ,assv ,delv!))
+ ((equal? procs `(,hashv ,assv))
(make-mapping-hooks (wrap hashv-get-handle)
(wrap hashv-create-handle!)
(wrap hashv-remove!)))
- ((equal? procs `(,hash ,assoc ,delete!))
+ ((equal? procs `(,hash ,assoc))
(make-mapping-hooks (wrap hash-get-handle)
(wrap hash-create-handle!)
(wrap hash-remove!)))
@@ -90,39 +92,27 @@
(lambda (table key)
(hashx-get-handle hash-proc
assoc-proc table key)))
(wrap
- (lambda (table key)
- (hashx-create-handle hash-proc
assoc-proc table key)))
+ (lambda (table key init)
+ (hashx-create-handle! hash-proc
assoc-proc table key init)))
(wrap
(lambda (table key)
- (hashx-get-handle hash-proc
assoc-proc delete-proc table key)))))))))))
-
-(define (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
- (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc)
table))
-
-(define (hash-table-mapping . options)
- (let* ((size (or (and options (number? (car options)) (car options))
- 71))
- (hash-proc (or (kw-arg-ref options #:hash-proc) hash))
- (assoc-proc (or (kw-arg-ref options #:assoc-proc)
- (cond
- ((eq? hash-proc hash) assoc)
- ((eq? hash-proc hashv) assv)
- ((eq? hash-proc hashq) assq)
- (else (error 'hash-table-mapping
- "Hash-procedure specified with no known
assoc function."
- hash-proc)))))
- (delete-proc (or (kw-arg-ref options #:delete-proc)
- (cond
- ((eq? hash-proc hash) delete!)
- ((eq? hash-proc hashv) delv!)
- ((eq? hash-proc hashq) delq!)
- (else (error 'hash-table-mapping
- "Hash-procedure specified with no known
delete function."
- hash-proc)))))
- (table-constructor (or (kw-arg-ref options #:table-constructor)
- (lambda (len) (make-vector len '())))))
- (make-hash-table-mapping (table-constructor size)
- hash-proc
- assoc-proc
- delete-proc)))
-
+ (hashx-remove! hash-proc
assoc-proc table key)))))))))))
+
+(define (make-hash-table-mapping table hash-proc assoc-proc)
+ (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc) table))
+
+(define* (hash-table-mapping #:optional (size 71) #:key
+ (hash-proc hash)
+ (assoc-proc
+ (or (assq-ref `((,hashq . ,assq)
+ (,hashv . ,assv)
+ (,hash . ,assoc))
+ hash-proc)
+ (error 'hash-table-mapping
+ "Hash-procedure specified with no
known assoc function."
+ hash-proc)))
+ (table-constructor
+ (lambda (len) (make-vector len '()))))
+ (make-hash-table-mapping (table-constructor size)
+ hash-proc
+ assoc-proc))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 5c39340..4476f50 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -990,7 +990,7 @@
(let ((e (cdar body)) (er (caar body)))
(call-with-values
(lambda ()
- (syntax-type e er '(()) (source-annotation er) ribcage mod
#f))
+ (syntax-type e er '(()) (source-annotation e) ribcage mod
#f))
(lambda (type value form e w s mod)
(let ((key type))
(cond ((memv key '(define-form))
@@ -1004,20 +1004,31 @@
(cons var vars)
(cons (cons er (wrap e w mod)) vals)
(cons (cons 'lexical var) bindings)))))
- ((memv key '(define-syntax-form
define-syntax-parameter-form))
- (let ((id (wrap value w mod)) (label (gen-label)))
+ ((memv key '(define-syntax-form))
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
(extend-ribcage! ribcage id label)
- (parse (cdr body)
- (cons id ids)
- (cons label labels)
- var-ids
- vars
- vals
- (cons (cons (if (eq? type
'define-syntax-parameter-form)
- 'syntax-parameter
- 'macro)
- (cons er (wrap e w mod)))
- bindings))))
+ (set-cdr!
+ r
+ (extend-env
+ (list label)
+ (list (cons 'macro (eval-local-transformer
(expand e trans-r w mod) mod)))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids
vars vals bindings)))
+ ((memv key '(define-syntax-parameter-form))
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr!
+ r
+ (extend-env
+ (list label)
+ (list (cons 'syntax-parameter
+ (list (eval-local-transformer
(expand e trans-r w mod) mod))))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids
vars vals bindings)))
((memv key '(begin-form))
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ .
each-any))))
(if tmp
@@ -1067,18 +1078,6 @@
#f
"invalid or duplicate identifier in definition"
outer-form))
- (let loop ((bs bindings) (er-cache #f) (r-cache
#f))
- (if (not (null? bs))
- (let ((b (car bs)))
- (if (memq (car b) '(macro syntax-parameter))
- (let* ((er (cadr b))
- (r-cache (if (eq? er er-cache)
r-cache (macros-only-env er))))
- (set-cdr!
- b
- (eval-local-transformer (expand (cddr
b) r-cache '(()) mod) mod))
- (if (eq? (car b) 'syntax-parameter)
(set-cdr! b (list (cdr b))))
- (loop (cdr bs) er r-cache))
- (loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec
#f
@@ -1776,56 +1775,72 @@
'core
'case-lambda
(lambda (e r w s mod)
- (let* ((tmp e)
- (tmp ($sc-dispatch
- tmp
- '(_ (any any . each-any) . #(each (any any . each-any))))))
- (if tmp
- (apply (lambda (args e1 e2 args* e1* e2*)
- (call-with-values
- (lambda ()
- (expand-lambda-case
- e
- r
- w
- s
- mod
- lambda-formals
- (cons (cons args (cons e1 e2))
- (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
- e2*
- e1*
- args*))))
- (lambda (meta lcase) (build-case-lambda s meta lcase))))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda" e)))))
+ (letrec*
+ ((build-it
+ (lambda (meta clauses)
+ (call-with-values
+ (lambda () (expand-lambda-case e r w s mod lambda-formals
clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))))
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (build-it
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1
tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any .
each-any))))))
+ (if (and tmp
+ (apply (lambda (docstring args e1 e2) (string?
(syntax->datum docstring)))
+ tmp))
+ (apply (lambda (docstring args e1 e2)
+ (build-it
+ (list (cons 'documentation (syntax->datum
docstring)))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda" e))))))))
(global-extend
'core
'case-lambda*
(lambda (e r w s mod)
- (let* ((tmp e)
- (tmp ($sc-dispatch
- tmp
- '(_ (any any . each-any) . #(each (any any . each-any))))))
- (if tmp
- (apply (lambda (args e1 e2 args* e1* e2*)
- (call-with-values
- (lambda ()
- (expand-lambda-case
- e
- r
- w
- s
- mod
- lambda*-formals
- (cons (cons args (cons e1 e2))
- (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
- e2*
- e1*
- args*))))
- (lambda (meta lcase) (build-case-lambda s meta lcase))))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+ (letrec*
+ ((build-it
+ (lambda (meta clauses)
+ (call-with-values
+ (lambda () (expand-lambda-case e r w s mod lambda*-formals
clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))))
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (build-it
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1
tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any .
each-any))))))
+ (if (and tmp
+ (apply (lambda (docstring args e1 e2) (string?
(syntax->datum docstring)))
+ tmp))
+ (apply (lambda (docstring args e1 e2)
+ (build-it
+ (list (cons 'documentation (syntax->datum
docstring)))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
(global-extend
'core
'let
@@ -2346,7 +2361,9 @@
(syntax-violation 'syntax-module "invalid argument" x)))
(cdr (syntax-object-module id))))
(syntax-local-binding
- (lambda (id)
+ (lambda* (id
+ #:key
+ (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-local-binding "invalid argument" x)))
@@ -2366,11 +2383,13 @@
(strip-anti-mark (syntax-object-wrap id))
r
(syntax-object-module id)
- #t))
+ resolve-syntax-parameters?))
(lambda (type value mod)
(let ((key type))
(cond ((memv key '(lexical)) (values 'lexical value))
((memv key '(macro)) (values 'macro value))
+ ((memv key '(syntax-parameter))
+ (values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable
value))
((memv key '(displaced-lexical)) (values
'displaced-lexical #f))
((memv key '(global)) (values 'global (cons value
(cdr mod))))
@@ -3027,32 +3046,38 @@
(lambda (x)
(letrec*
((read-file
- (lambda (fn k)
- (let ((p (open-input-file fn)))
- (let f ((x (read p)) (result '()))
- (if (eof-object? x)
- (begin (close-input-port p) (reverse result))
- (f (read p) (cons (datum->syntax k x) result))))))))
- (let ((tmp-1 x))
- (let ((tmp ($sc-dispatch tmp-1 '(any any))))
- (if tmp
- (apply (lambda (k filename)
- (let ((fn (syntax->datum filename)))
- (let ((tmp-1 (read-file fn filename)))
- (let ((tmp ($sc-dispatch tmp-1 'each-any)))
- (if tmp
- (apply (lambda (exp)
- (cons '#(syntax-object begin ((top))
(hygiene guile)) exp))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- tmp-1))))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))))
+ (lambda (fn dir k)
+ (let ((p (open-input-file
+ (if (absolute-file-name? fn) fn (in-vicinity dir
fn)))))
+ (let ((enc (file-encoding p)))
+ (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
+ (let f ((x (read p)) (result '()))
+ (if (eof-object? x)
+ (begin (close-input-port p) (reverse result))
+ (f (read p) (cons (datum->syntax k x) result)))))))))
+ (let ((src (syntax-source x)))
+ (let ((file (if src (assq-ref src 'filename) #f)))
+ (let ((dir (if (string? file) (dirname file) #f)))
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp-1 (read-file fn dir filename)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (exp)
+ (cons '#(syntax-object begin
((top)) (hygiene guile)) exp))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))))
(define include-from-path
(make-syntax-transformer
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 1698a02..0176adb 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1531,7 +1531,7 @@
(syntax-violation #f "no expressions in body" outer-form)
(let ((e (cdar body)) (er (caar body)))
(call-with-values
- (lambda () (syntax-type e er empty-wrap
(source-annotation er) ribcage mod #f))
+ (lambda () (syntax-type e er empty-wrap
(source-annotation e) ribcage mod #f))
(lambda (type value form e w s mod)
(case type
((define-form)
@@ -1543,18 +1543,40 @@
(cons id var-ids)
(cons var vars) (cons (cons er (wrap e w
mod)) vals)
(cons (make-binding 'lexical var)
bindings)))))
- ((define-syntax-form define-syntax-parameter-form)
- (let ((id (wrap value w mod)) (label (gen-label)))
+ ((define-syntax-form)
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ ;; As required by R6RS, evaluate the
right-hand-sides of internal
+ ;; syntax definition forms and add their
transformers to the
+ ;; compile-time environment immediately, so that
the newly-defined
+ ;; keywords may be used in definition context
within the same
+ ;; lexical contour.
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'macro
+ (eval-local-transformer
+ (expand e trans-r w mod)
+ mod)))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars
vals bindings)))
+ ((define-syntax-parameter-form)
+ ;; Same as define-syntax-form, but different format
of the binding.
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
(extend-ribcage! ribcage id label)
- (parse (cdr body)
- (cons id ids) (cons label labels)
- var-ids vars vals
- (cons (make-binding
- (if (eq? type
'define-syntax-parameter-form)
- 'syntax-parameter
- 'macro)
- (cons er (wrap e w mod)))
- bindings))))
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'syntax-parameter
+ (list (eval-local-transformer
+ (expand e trans-r w mod)
+ mod))))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars
vals bindings)))
((begin-form)
(syntax-case e ()
((_ e1 ...)
@@ -1585,23 +1607,6 @@
(syntax-violation
#f "invalid or duplicate identifier in
definition"
outer-form))
- (let loop ((bs bindings) (er-cache #f) (r-cache
#f))
- (if (not (null? bs))
- (let* ((b (car bs)))
- (if (memq (car b) '(macro
syntax-parameter))
- (let* ((er (cadr b))
- (r-cache
- (if (eq? er er-cache)
- r-cache
- (macros-only-env er))))
- (set-cdr! b
- (eval-local-transformer
- (expand (cddr b)
r-cache empty-wrap mod)
- mod))
- (if (eq? (car b)
'syntax-parameter)
- (set-cdr! b (list (cdr b))))
- (loop (cdr bs) er r-cache))
- (loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr
r)))
(build-letrec no-source #t
(reverse (map syntax->datum
var-ids))
@@ -2167,28 +2172,42 @@
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
+ (define (build-it meta clauses)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda-formals
+ clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda-formals
- #'((args e1 e2 ...) (args*
e1* e2* ...) ...)))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
+ ((_ (args e1 e2 ...) ...)
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda"
e)))))
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
+ (define (build-it meta clauses)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda*-formals
+ clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda*-formals
- #'((args e1 e2 ...) (args*
e1* e2* ...) ...)))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
+ ((_ (args e1 e2 ...) ...)
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*"
e)))))
(global-extend 'core 'let
@@ -2643,7 +2662,7 @@
(arg-check nonsymbol-id? id 'syntax-module)
(cdr (syntax-object-module id)))
- (define (syntax-local-binding id)
+ (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
@@ -2660,13 +2679,12 @@
(strip-anti-mark (syntax-object-wrap id))
r
(syntax-object-module id)
- ;; FIXME: come up with a better policy for
- ;; resolve-syntax-parameters
- #t))
+ resolve-syntax-parameters?))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
((macro) (values 'macro value))
+ ((syntax-parameter) (values 'syntax-parameter (car value)))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
((global) (values 'global (cons value (cdr mod))))
@@ -3016,15 +3034,17 @@
(define-syntax include
(lambda (x)
- (define (absolute-path? path)
- (string-prefix? "/" path))
-
(define read-file
(lambda (fn dir k)
- (let ((p (open-input-file
- (if (absolute-path? fn)
- fn
- (in-vicinity dir fn)))))
+ (let* ((p (open-input-file
+ (if (absolute-file-name? fn)
+ fn
+ (in-vicinity dir fn))))
+ (enc (file-encoding p)))
+
+ ;; Choose the input encoding deterministically.
+ (set-port-encoding! p (or enc "UTF-8"))
+
(let f ((x (read p))
(result '()))
(if (eof-object? x)
diff --git a/module/language/assembly/spec.scm
b/module/language/assembly/spec.scm
index 01a55c4..0a497e4 100644
--- a/module/language/assembly/spec.scm
+++ b/module/language/assembly/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Virtual Machine Assembly
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,4 +31,5 @@
#:parser read ;; fixme: make a verifier?
#:compilers `((bytecode . ,compile-bytecode))
#:decompilers `((bytecode . ,decompile-bytecode))
+ #:for-humans? #f
)
diff --git a/module/language/bytecode/spec.scm
b/module/language/bytecode/spec.scm
index c2a6d46..ca703c3 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009, 2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software 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,4 +36,5 @@
#:printer write
#:compilers `((objcode . ,compile-objcode))
#:decompilers `((objcode . ,decompile-objcode))
+ #:for-humans? #f
)
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 69d4f81..793c293 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -10,7 +10,7 @@
#:use-module (srfi srfi-1)
#:use-module (system base compile)
#:use-module (language tree-il compile-cps)
- #:use-module (system vm rtl)
+ #:use-module (system vm assembler)
#:export (cps->rtl generate-shuffle generate-rtl cps-compile
calculate-free-values))
@@ -460,7 +460,7 @@
names funcs)))
(($ <lambda> names rest body)
;; TO DO: save the names of the lambdas
- `((begin-program foo)
+ `((begin-program foo ())
(assert-nargs-ee/locals ,(length names) ,(nlocals cps))
,@(visit body)
(end-program)))
diff --git a/module/language/ecmascript/base.scm
b/module/language/ecmascript/base.scm
index 6f5c65b..ac8493d 100644
--- a/module/language/ecmascript/base.scm
+++ b/module/language/ecmascript/base.scm
@@ -1,6 +1,6 @@
;;; ECMAScript for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -168,7 +168,8 @@
x))
(define (->boolean x)
- (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x)
+ (not (or (not x) (null? x) (eq? x *undefined*)
+ (and (number? x) (or (zero? x) (nan? x)))
(and (string? x) (= (string-length x) 0)))))
(define (->number x)
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index 767fda3..4633485 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -597,33 +597,32 @@
(else (error "what" op)))
(let ((a (quotient index 256))
(b (modulo index 256)))
- `((,(case op
- ((ref)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-ref))
- `((long-local-ref ,a ,b))))
- ((set)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-set))
- `((long-local-set ,a ,b))))
- ((box)
- `((make-variable)
- (variable-set)
- (long-local-set ,a ,b)))
- ((empty-box)
- `((make-variable)
- (long-local-set ,a ,b)))
- ((fix)
- `((fix-closure ,a ,b)))
- ((bound?)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-bound?))
- `((long-local-bound? ,a ,b))))
- (else (error "what" op)))
- ,index))))
+ (case op
+ ((ref)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-ref))
+ `((long-local-ref ,a ,b))))
+ ((set)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-set))
+ `((long-local-set ,a ,b))))
+ ((box)
+ `((make-variable)
+ (variable-set)
+ (long-local-set ,a ,b)))
+ ((empty-box)
+ `((make-variable)
+ (long-local-set ,a ,b)))
+ ((fix)
+ `((fix-closure ,a ,b)))
+ ((bound?)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-bound?))
+ `((long-local-bound? ,a ,b))))
+ (else (error "what" op)))))
`((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil)))
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
deleted file mode 100644
index a50b640..0000000
--- a/module/language/glil/decompile-assembly.scm
+++ /dev/null
@@ -1,191 +0,0 @@
-;;; Guile VM code converters
-
-;; 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 (language glil decompile-assembly)
- #:use-module (system base pmatch)
- #:use-module (system vm program)
- #:use-module (language assembly)
- #:use-module (language glil)
- #:export (decompile-assembly))
-
-(define (decompile-assembly x env opts)
- (values (decompile-toplevel x)
- env))
-
-(define (decompile-toplevel x)
- (pmatch x
- ((load-program ,labels ,len ,meta . ,body)
- (decompile-load-program (decompile-meta meta)
- body labels #f))
- (else
- (error "invalid assembly" x))))
-
-(define (decompile-meta meta)
- (and meta
- (let ((prog (decompile-toplevel meta)))
- (if (and (glil-program? prog)
- (= (length (glil-program-body prog)) 2)
- (glil-const? (car (glil-program-body prog))))
- (glil-const-obj (car (glil-program-body prog)))
- (error "metadata not a thunk returning a const" prog)))))
-
-(define *placeholder* (list 'placeholder))
-
-(define (emit-constants l out)
- (let lp ((in (reverse l)) (out out))
- (cond ((null? in) out)
- ((eq? (car in) *placeholder*) (lp (cdr in) out))
- ((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
- (else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-
-(define (decompile-load-program meta body labels
- objects)
- (let ((glil-labels (sort (map (lambda (x)
- (cons (cdr x) (make-glil-label (car x))))
- labels)
- (lambda (x y) (< (car x) (car y)))))
- (bindings (sort (if meta (car meta) '())
- (lambda (x y) (< (binding:start x) (binding:start
y)))))
- (unbindings (sort (if meta (car meta) '())
- (lambda (x y) (< (binding:end x) (binding:end y)))))
- (sources (if meta (cadr meta) '()))
- (filename #f)
- (props (if meta (cddr meta) '())))
- (define (pop-bindings! addr)
- (let lp ((in bindings) (out '()))
- (if (or (null? in) (> (binding:start (car in)) addr))
- (begin
- (set! bindings in)
- (if (null? out) #f (reverse out)))
- (lp (cdr in) (cons (car in) out)))))
- (define (pop-unbindings! addr)
- (let lp ((in unbindings) (out '()))
- (if (or (null? in) (> (binding:end (car in)) addr))
- (begin
- (set! unbindings in)
- (if (null? out) #f (reverse out)))
- (lp (cdr in) (cons (car in) out)))))
- (define (pop-source! addr)
- ;; a fragile algorithm.
- (cond ((null? sources) #f)
- ((eq? (caar sources) 'filename)
- (set! filename (cdar sources))
- (pop-source! addr))
- ((eqv? (caar sources) addr)
- (let ((x (car sources)))
- (set! sources (cdr sources))
- `((filename . ,filename)
- (line . ,(cadr x))
- (column . ,(cddr x)))))
- (else #f)))
- (let lp ((in body) (stack '()) (out '()) (pos 0))
- (cond
- ((null? in)
- (or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program props (reverse out)))
- ((pop-bindings! pos)
- => (lambda (bindings)
- (lp in stack
- (cons (make-glil-bind bindings)
- out)
- pos)))
- ((pop-unbindings! pos)
- => (lambda (bindings)
- (lp in stack (cons (make-glil-unbind) out) pos)))
- ((pop-source! pos)
- => (lambda (s)
- (lp in stack (cons (make-glil-source s) out) pos)))
- ((and (or (null? out) (not (glil-label? (car out))))
- (assv-ref glil-labels pos))
- => (lambda (label)
- (lp in stack (cons label out) pos)))
- (else
- (pmatch (car in)
- ((nop)
- (lp (cdr in) stack out (1+ pos)))
- ((make-false)
- (lp (cdr in) (cons #f stack) out (1+ pos)))
- ((make-nil)
- (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)
- body labels (car stack))
- (cdr stack))
- out
- (+ pos (byte-length (car in)))))
- ((load-symbol ,str)
- (lp (cdr in) (cons (string->symbol str) stack) out
- (+ pos 1 (string-length str))))
- ((make-int8:0)
- (lp (cdr in) (cons 0 stack) out (1+ pos)))
- ((make-int8:1)
- (lp (cdr in) (cons 1 stack) out (1+ pos)))
- ((make-int8 ,n)
- (lp (cdr in) (cons n stack) out (+ pos 2)))
- ((cons)
- (let ((head (list-head stack 2))
- (stack (list-tail stack 2)))
- (if (memq *placeholder* head)
- (lp (cdr in) (cons *placeholder* stack)
- (cons (make-glil-call 'cons 2) (emit-constants head out))
- (+ pos 1))
- (lp (cdr in) (cons (cons (cadr head) (car head)) stack)
- out (+ pos 3)))))
- ((list ,a ,b)
- (let* ((len (+ (ash a 8) b))
- (head (list-head stack len))
- (stack (list-tail stack len)))
- (if (memq *placeholder* head)
- (lp (cdr in) (cons *placeholder* stack)
- (cons (make-glil-call 'list len) (emit-constants head
out))
- (+ pos 3))
- (lp (cdr in) (cons (reverse head) stack) out (+ pos 3)))))
- ((make-eol)
- (lp (cdr in) (cons '() stack) out (1+ pos)))
- ((return)
- (lp (cdr in) (cdr stack)
- (cons (make-glil-call 'return 1)
- (emit-constants (list-head stack 1) out))
- (1+ pos)))
- ((local-ref ,n)
- (lp (cdr in) (cons *placeholder* stack)
- (cons (make-glil-local 'ref n)
- out) (+ pos 2)))
- ((local-set ,n)
- (lp (cdr in) (cdr stack)
- (cons (make-glil-local 'set n)
- (emit-constants (list-head stack 1) out))
- (+ pos 2)))
- ((br-if-not ,l)
- (lp (cdr in) (cdr stack)
- (cons (make-glil-branch 'br-if-not l) out)
- (+ pos 3)))
- ((mul)
- (lp (cdr in) (cons *placeholder* (cddr stack))
- (cons (make-glil-call 'mul 2)
- (emit-constants (list-head stack 2) out))
- (+ pos 1)))
- ((tail-call ,n)
- (lp (cdr in) (list-tail stack (1+ 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/glil/spec.scm b/module/language/glil/spec.scm
index a8164e5..81e06af 100644
--- a/module/language/glil/spec.scm
+++ b/module/language/glil/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2013 Free Software 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,7 +22,6 @@
#:use-module (system base language)
#:use-module (language glil)
#:use-module (language glil compile-assembly)
- #:use-module (language glil decompile-assembly)
#:export (glil))
(define (write-glil exp . port)
@@ -37,4 +36,5 @@
#:printer write-glil
#:parser parse-glil
#:compilers `((assembly . ,compile-asm))
- #:decompilers `((assembly . ,decompile-assembly)))
+ #:for-humans? #f
+ )
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
index 9654c08..981c398 100644
--- a/module/language/objcode/elf.scm
+++ b/module/language/objcode/elf.scm
@@ -1,6 +1,6 @@
;;; Embedding bytecode in ELF
-;; Copyright (C) 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -30,25 +30,27 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (system vm elf)
+ #:use-module (system vm linker)
#:export (write-objcode))
(define (bytecode->elf bv)
- (let ((string-table (make-elf-string-table)))
+ (let ((string-table (make-string-table)))
(define (intern-string! string)
(call-with-values
- (lambda () (elf-string-table-intern string-table string))
+ (lambda () (string-table-intern string-table string))
(lambda (table idx)
(set! string-table table)
idx)))
- (define (make-object name bv relocs . kwargs)
+ (define (make-object index name bv relocs . kwargs)
(let ((name-idx (intern-string! (symbol->string name))))
- (make-elf-object (apply make-elf-section
- #:name name-idx
- #:size (bytevector-length bv)
- kwargs)
- bv relocs
- (list (make-elf-symbol name 0)))))
- (define (make-dynamic-section word-size endianness)
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-linker-symbol name 0)))))
+ (define (make-dynamic-section index word-size endianness)
(define (make-dynamic-section/32)
(let ((bv (make-bytevector 24 0)))
(bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
@@ -57,7 +59,7 @@
(bytevector-u32-set! bv 12 0 endianness)
(bytevector-u32-set! bv 16 DT_NULL endianness)
(bytevector-u32-set! bv 20 0 endianness)
- (values bv (make-elf-reloc 'abs32/1 12 0 '.rtl-text))))
+ (values bv (make-linker-reloc 'abs32/1 12 0 '.rtl-text))))
(define (make-dynamic-section/64)
(let ((bv (make-bytevector 48 0)))
(bytevector-u64-set! bv 0 DT_GUILE_RTL_VERSION endianness)
@@ -66,26 +68,26 @@
(bytevector-u64-set! bv 24 0 endianness)
(bytevector-u64-set! bv 32 DT_NULL endianness)
(bytevector-u64-set! bv 40 0 endianness)
- (values bv (make-elf-reloc 'abs64/1 24 0 '.rtl-text))))
+ (values bv (make-linker-reloc 'abs64/1 24 0 '.rtl-text))))
(call-with-values (lambda ()
(case word-size
((4) (make-dynamic-section/32))
((8) (make-dynamic-section/64))
(else (error "unexpected word size" word-size))))
(lambda (bv reloc)
- (make-object '.dynamic bv (list reloc)
+ (make-object index '.dynamic bv (list reloc)
#:type SHT_DYNAMIC #:flags SHF_ALLOC))))
- (define (link-string-table)
+ (define (make-string-table index)
(intern-string! ".shstrtab")
- (make-object '.shstrtab (link-elf-string-table string-table) '()
+ (make-object index '.shstrtab (link-string-table string-table) '()
#:type SHT_STRTAB #:flags 0))
(let* ((word-size (target-word-size))
(endianness (target-endianness))
- (text (make-object '.rtl-text bv '()))
- (dt (make-dynamic-section word-size endianness))
+ (text (make-object 1 '.rtl-text bv '()))
+ (dt (make-dynamic-section 2 word-size endianness))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
- (shstrtab (link-string-table)))
+ (shstrtab (make-string-table 3)))
(link-elf (list text dt shstrtab)
#:endianness endianness #:word-size word-size))))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 022419e..16f5241 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, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software 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,4 +80,5 @@
#:printer write-objcode
#:compilers `((value . ,objcode->value))
#:decompilers `((value . ,decompile-value))
+ #:for-humans? #f
)
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index f5bb699..c065474 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -261,20 +261,22 @@
(build-define name (recurse exp)))
((<lambda> meta body)
- (let ((body (recurse body))
- (doc (assq-ref meta 'documentation)))
- (if (not doc)
- body
- (match body
- (('lambda formals body ...)
- `(lambda ,formals ,doc ,@body))
- (('lambda* formals body ...)
- `(lambda* ,formals ,doc ,@body))
- (('case-lambda (formals body ...) clauses ...)
- `(case-lambda (,formals ,doc ,@body) ,@clauses))
- (('case-lambda* (formals body ...) clauses ...)
- `(case-lambda* (,formals ,doc ,@body) ,@clauses))
- (e e)))))
+ (if body
+ (let ((body (recurse body))
+ (doc (assq-ref meta 'documentation)))
+ (if (not doc)
+ body
+ (match body
+ (('lambda formals body ...)
+ `(lambda ,formals ,doc ,@body))
+ (('lambda* formals body ...)
+ `(lambda* ,formals ,doc ,@body))
+ (('case-lambda (formals body ...) clauses ...)
+ `(case-lambda (,formals ,doc ,@body) ,@clauses))
+ (('case-lambda* (formals body ...) clauses ...)
+ `(case-lambda* (,formals ,doc ,@body) ,@clauses))
+ (e e))))
+ '(case-lambda)))
((<lambda-case> req opt rest kw inits gensyms body alternate)
(let ((names (map output-name gensyms)))
@@ -702,7 +704,8 @@
((<seq> head tail)
(primitive 'begin) (recurse head) (recurse tail))
- ((<lambda> body) (recurse body))
+ ((<lambda> body)
+ (if body (recurse body)))
((<lambda-case> req opt rest kw inits gensyms body alternate)
(primitive 'lambda)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index a3991b6..ddcba99 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -311,7 +311,9 @@
`(define ,name ,(unparse-tree-il exp)))
((<lambda> meta body)
- `(lambda ,meta ,(unparse-tree-il body)))
+ (if body
+ `(lambda ,meta ,(unparse-tree-il body))
+ `(lambda ,meta (lambda-case))))
((<lambda-case> req opt rest kw inits gensyms body alternate)
`(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
@@ -397,7 +399,11 @@ This is an implementation of `foldts' as described by Andy
Wingo in
((<seq> head tail)
(up tree (loop tail (loop head (down tree result)))))
((<lambda> body)
- (up tree (loop body (down tree result))))
+ (let ((result (down tree result)))
+ (up tree
+ (if body
+ (loop body result)
+ result))))
((<lambda-case> inits body alternate)
(up tree (if alternate
(loop alternate
@@ -475,7 +481,9 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(let-values (((seed ...) (foldts head seed ...)))
(foldts tail seed ...)))
((<lambda> body)
- (foldts body seed ...))
+ (if body
+ (foldts body seed ...)
+ (values seed ...)))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
@@ -549,7 +557,8 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (toplevel-define-exp x) (lp exp)))
((<lambda> body)
- (set! (lambda-body x) (lp body)))
+ (if body
+ (set! (lambda-body x) (lp body))))
((<lambda-case> inits body alternate)
(set! inits (map lp inits))
@@ -639,7 +648,8 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (toplevel-define-exp x) (lp exp)))
((<lambda> body)
- (set! (lambda-body x) (lp body)))
+ (if body
+ (set! (lambda-body x) (lp body))))
((<lambda-case> inits body alternate)
(set! inits (map lp inits))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 4af7998..f5890b2 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1265,11 +1265,11 @@ accurate information is missing from a given `tree-il'
element."
(case state
((tilde)
(case (car chars)
- ((#\~ #\% #\& #\t #\_ #\newline #\( #\))
+ ((#\~ #\% #\& #\t #\T #\_ #\newline #\( #\) #\! #\| #\/ #\q #\Q)
(loop (cdr chars) 'literal '()
conditions end-group
min-count max-count))
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@)
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@ #\+ #\- #\#)
(loop (cdr chars)
'tilde (cons (car chars) params)
conditions end-group
@@ -1336,16 +1336,23 @@ accurate information is missing from a given `tree-il'
element."
min-count)
(+ (or (previous-number params) 1)
max-count))))
- ((#\? #\k)
+ ((#\? #\k #\K)
;; We don't have enough info to determine the exact number
;; of args, but we could determine a lower bound (TODO).
(values 'any 'any))
+ ((#\^)
+ (values min-count 'any))
((#\h #\H)
(let ((argc (if (memq #\: params) 2 1)))
(loop (cdr chars) 'literal '()
conditions end-group
(+ argc min-count)
(+ argc max-count))))
+ ((#\')
+ (if (null? (cdr chars))
+ (throw &syntax-error 'unexpected-termination)
+ (loop (cddr chars) 'tilde (cons (cadr chars) params)
+ conditions end-group min-count max-count)))
(else (loop (cdr chars) 'literal '()
conditions end-group
(+ 1 min-count) (+ 1 max-count)))))
diff --git a/module/language/tree-il/canonicalize.scm
b/module/language/tree-il/canonicalize.scm
index 2536a71..1db8420 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -1,6 +1,6 @@
;;; Tree-il canonicalizer
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -44,6 +44,21 @@
body)
(($ <dynlet> src () () body)
body)
+ (($ <lambda> src meta #f)
+ ;; Give a body to case-lambda with no clauses.
+ (make-lambda
+ src meta
+ (make-lambda-case
+ #f '() #f #f #f '() '()
+ (make-primcall
+ #f
+ 'throw
+ (list (make-const #f 'wrong-number-of-args)
+ (make-const #f #f)
+ (make-const #f "Wrong number of arguments")
+ (make-const #f '())
+ (make-const #f #f)))
+ #f)))
(($ <prompt> src tag body handler)
(define (escape-only? handler)
(match handler
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 79f4ff9..1b6fea6 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,2010,2011,2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation,
Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -344,9 +344,20 @@
(for-each comp-push args)
(let ((len (length args)))
(case context
- ((tail) (emit-code src (make-glil-call 'tail-call len)))
- ((push) (emit-code src (make-glil-call 'call len))
+ ((tail) (if (<= len #xff)
+ (emit-code src (make-glil-call 'tail-call len))
+ (begin
+ (comp-push (make-const #f len))
+ (emit-code src (make-glil-call 'tail-call/nargs
0)))))
+ ((push) (if (<= len #xff)
+ (emit-code src (make-glil-call 'call len))
+ (begin
+ (comp-push (make-const #f len))
+ (emit-code src (make-glil-call 'call/nargs 0))))
(maybe-emit-return))
+ ;; FIXME: mv-call doesn't have a /nargs variant, so it is
+ ;; limited to 255 args. Can work around it with a
+ ;; trampoline and tail-call/nargs, but it's not so nice.
((vals) (emit-code src (make-glil-mv-call len MVRA))
(maybe-emit-return))
((drop) (let ((MV (make-label)) (POST (make-label)))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index f8fd1cd..f8df3ce 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -1,6 +1,6 @@
;;; Common Subexpression Elimination (CSE) on Tree-IL
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -539,8 +539,10 @@
(return (make-call src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
- (let*-values (((body _) (visit body (control-flow-boundary db)
- env 'values)))
+ (let*-values (((body _) (if body
+ (visit body (control-flow-boundary db)
+ env 'values)
+ (values #f #f))))
(return (make-lambda src meta body)
vlist-null)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index a32fc41..65fd58e 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -1,6 +1,6 @@
;;; Tree-IL verifier
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2013 Free Software 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,10 +115,11 @@
(cond
((and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
- ((not (lambda-case? body))
+ ((and body (not (lambda-case? body)))
(error "lambda body should be lambda-case" exp))
(else
- (visit body env))))
+ (if body
+ (visit body env)))))
(($ <let> src names gensyms vals body)
(cond
((not (and (list? names) (and-map symbol? names)))
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index 8b380da..b5586e2 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -1,6 +1,6 @@
;;; Effects analysis on Tree-IL
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -311,7 +311,12 @@ of an expression."
(cause &type-check))))
(($ <lambda-case>)
(logior (compute-effects body)
- (cause &type-check))))))
+ (cause &type-check)))
+ (#f
+ ;; Calling a case-lambda with no clauses
+ ;; definitely causes bailout.
+ (logior (cause &definite-bailout)
+ (cause &possible-bailout))))))
;; Bailout primitives.
(($ <primcall> _ (? bailout-primitive? name) args)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 5ae691d..c5a1c4e 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -26,6 +26,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 control)
#:export (peval))
;;;
@@ -73,15 +74,6 @@
(newline)
(values)))
-(define-syntax-rule (let/ec k e e* ...)
- (let ((tag (make-prompt-tag)))
- (call-with-prompt
- tag
- (lambda ()
- (let ((k (lambda args (apply abort-to-prompt tag args))))
- e e* ...))
- (lambda (_ res) res))))
-
(define (tree-il-any proc exp)
(let/ec k
(tree-il-fold (lambda (exp res)
@@ -431,6 +423,13 @@ top-level bindings from ENV and return the resulting
expression."
new))
vars))
+ (define (fresh-temporaries ls)
+ (map (lambda (elt)
+ (let ((new (gensym "tmp ")))
+ (record-new-temporary! 'tmp new 1)
+ new))
+ ls))
+
(define (assigned-lexical? sym)
(var-set? (lookup-var sym)))
@@ -508,7 +507,7 @@ top-level bindings from ENV and return the resulting
expression."
(else
(residualize-call))))
- (define (inline-values exp src names gensyms body)
+ (define (inline-values src exp nmin nmax consumer)
(let loop ((exp exp))
(match exp
;; Some expression types are always singly-valued.
@@ -524,17 +523,15 @@ top-level bindings from ENV and return the resulting
expression."
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
($ <module-set>) ;
- ($ <dynset>)) ;
- (and (= (length names) 1)
- (make-let src names gensyms (list exp) body)))
- (($ <primcall> src (? singly-valued-primitive? name))
- (and (= (length names) 1)
- (make-let src names gensyms (list exp) body)))
+ ($ <dynset>) ;
+ ($ <primcall> src (? singly-valued-primitive?)))
+ (and (<= nmin 1) (or (not nmax) (>= nmax 1))
+ (make-call src (make-lambda #f '() consumer) (list exp))))
;; Statically-known number of values.
(($ <primcall> src 'values vals)
- (and (= (length names) (length vals))
- (make-let src names gensyms vals body)))
+ (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
+ (make-call src (make-lambda #f '() consumer) vals)))
;; Not going to copy code into both branches.
(($ <conditional>) #f)
@@ -692,6 +689,49 @@ top-level bindings from ENV and return the resulting
expression."
((vhash-assq var env) => cdr)
(else (error "unbound var" var))))
+ ;; Find a value referenced a specific number of times. This is a hack
+ ;; that's used for propagating fresh data structures like rest lists and
+ ;; prompt tags. Usually we wouldn't copy consed data, but we can do so in
+ ;; some special cases like `apply' or prompts if we can account
+ ;; for all of its uses.
+ ;;
+ ;; You don't want to use this in general because it introduces a slight
+ ;; nonlinearity by running peval again (though with a small effort and size
+ ;; counter).
+ ;;
+ (define (find-definition x n-aliases)
+ (cond
+ ((lexical-ref? x)
+ (cond
+ ((lookup (lexical-ref-gensym x))
+ => (lambda (op)
+ (let ((y (or (operand-residual-value op)
+ (visit-operand op counter 'value 10 10)
+ (operand-source op))))
+ (cond
+ ((and (lexical-ref? y)
+ (= (lexical-refcount (lexical-ref-gensym x)) 1))
+ ;; X is a simple alias for Y. Recurse, regardless of
+ ;; the number of aliases we were expecting.
+ (find-definition y n-aliases))
+ ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+ ;; We found a definition that is aliased the right
+ ;; number of times. We still recurse in case it is a
+ ;; lexical.
+ (values (find-definition y 1)
+ op))
+ (else
+ ;; We can't account for our aliases.
+ (values #f #f))))))
+ (else
+ ;; A formal parameter. Can't say anything about that.
+ (values #f #f))))
+ ((= n-aliases 1)
+ ;; Not a lexical: success, but only if we are looking for an
+ ;; unaliased value.
+ (values x #f))
+ (else (values #f #f))))
+
(define (visit exp ctx)
(loop exp env counter ctx))
@@ -820,6 +860,30 @@ top-level bindings from ENV and return the resulting
expression."
(begin
(record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
+ (($ <let> src
+ (names ... rest)
+ (gensyms ... rest-sym)
+ (vals ... ($ <primcall> _ 'list rest-args))
+ ($ <primcall> asrc (or 'apply '@apply)
+ (proc args ...
+ ($ <lexical-ref> _
+ (? (cut eq? <> rest))
+ (? (lambda (sym)
+ (and (eq? sym rest-sym)
+ (= (lexical-refcount sym) 1))))))))
+ (let* ((tmps (make-list (length rest-args) 'tmp))
+ (tmp-syms (fresh-temporaries tmps)))
+ (for-tail
+ (make-let src
+ (append names tmps)
+ (append gensyms tmp-syms)
+ (append vals rest-args)
+ (make-call
+ asrc
+ proc
+ (append args
+ (map (cut make-lexical-ref #f <> <>)
+ tmps tmp-syms)))))))
(($ <let> src names gensyms vals body)
(define (compute-alias exp)
;; It's very common for macros to introduce something like:
@@ -915,11 +979,13 @@ top-level bindings from ENV and return the resulting
expression."
;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer)))
(or (match consumer
- (($ <lambda-case> src req #f #f #f () gensyms body #f)
- (cond
- ((inline-values producer src req gensyms body)
- => for-tail)
- (else #f)))
+ (($ <lambda-case> src req opt rest #f inits gensyms body #f)
+ (let* ((nmin (length req))
+ (nmax (and (not rest) (+ nmin (if opt (length opt)
0)))))
+ (cond
+ ((inline-values lv-src producer nmin nmax consumer)
+ => for-tail)
+ (else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
(($ <dynwind> src winder pre body post unwinder)
@@ -1102,15 +1168,30 @@ top-level bindings from ENV and return the resulting
expression."
(make-primcall src 'values vals))))))
(($ <primcall> src (or 'apply '@apply) (proc args ... tail))
- (match (for-value tail)
- (($ <const> _ (args* ...))
- (let ((args* (map (lambda (x) (make-const #f x)) args*)))
- (for-tail (make-call src proc (append args args*)))))
- (($ <primcall> _ 'list args*)
- (for-tail (make-call src proc (append args args*))))
- (tail
- (let ((args (append (map for-value args) (list tail))))
- (make-primcall src '@apply (cons (for-value proc) args))))))
+ (let lp ((tail* (find-definition tail 1)) (speculative? #t))
+ (define (copyable? x)
+ ;; Inlining a result from find-definition effectively copies it,
+ ;; relying on the let-pruning to remove its original binding. We
+ ;; shouldn't copy non-constant expressions.
+ (or (not speculative?) (constant-expression? x)))
+ (match tail*
+ (($ <const> _ (args* ...))
+ (let ((args* (map (cut make-const #f <>) args*)))
+ (for-tail (make-call src proc (append args args*)))))
+ (($ <primcall> _ 'cons
+ ((and head (? copyable?)) (and tail (? copyable?))))
+ (for-tail (make-primcall src '@apply
+ (cons proc
+ (append args (list head tail))))))
+ (($ <primcall> _ 'list
+ (and args* ((? copyable?) ...)))
+ (for-tail (make-call src proc (append args args*))))
+ (tail*
+ (if speculative?
+ (lp (for-value tail) #f)
+ (let ((args (append (map for-value args) (list tail*))))
+ (make-primcall src '@apply
+ (cons (for-value proc) args))))))))
(($ <primcall> src (? constructor-primitive? name) args)
(cond
@@ -1219,20 +1300,39 @@ top-level bindings from ENV and return the resulting
expression."
(($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
- (let ((proc (visit orig-proc 'operator)))
+ (let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
(($ <primitive-ref> _ name)
(for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
- ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
- ;; Simple case: no rest, no keyword arguments.
+ ($ <lambda-case> _ req opt rest #f inits gensyms body #f))
+ ;; Simple case: no keyword arguments.
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
(nopt (if opt (length opt) 0))
(key (source-expression proc)))
+ (define (inlined-call)
+ (make-let src
+ (append req
+ (or opt '())
+ (if rest (list rest) '()))
+ gensyms
+ (if (> nargs (+ nreq nopt))
+ (append (list-head orig-args (+ nreq nopt))
+ (list
+ (make-primcall
+ #f 'list
+ (drop orig-args (+ nreq nopt)))))
+ (append orig-args
+ (drop inits (- nargs nreq))
+ (if rest
+ (list (make-const #f '()))
+ '())))
+ body))
+
(cond
- ((or (< nargs nreq) (> nargs (+ nreq nopt)))
+ ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments.
(make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
@@ -1256,12 +1356,7 @@ top-level bindings from ENV and return the resulting
expression."
(lp (counter-prev counter)))))))
(log 'inline-recurse key)
- (loop (make-let src (append req (or opt '()))
- gensyms
- (append orig-args
- (drop inits (- nargs nreq)))
- body)
- env counter ctx))
+ (loop (inlined-call) env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
@@ -1292,12 +1387,7 @@ top-level bindings from ENV and return the resulting
expression."
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
- (loop (make-let src (append req (or opt '()))
- gensyms
- (append orig-args
- (drop inits (- nargs nreq)))
- body)
- env new-counter ctx))
+ (loop (inlined-call) env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.
@@ -1307,6 +1397,31 @@ top-level bindings from ENV and return the resulting
expression."
(log 'inline-end result exp)
result)))))
+ (($ <let> _ _ _ vals _)
+ ;; Attempt to inline `let' in the operator position.
+ ;;
+ ;; We have to re-visit the proc in value mode, since the
+ ;; `let' bindings might have been introduced or renamed,
+ ;; whereas the lambda (if any) in operator position has not
+ ;; been renamed.
+ (if (or (and-map constant-expression? vals)
+ (and-map constant-expression? orig-args))
+ ;; The arguments and the let-bound values commute.
+ (match (for-value orig-proc)
+ (($ <let> lsrc names syms vals body)
+ (log 'inline-let orig-proc)
+ (for-tail
+ (make-let lsrc names syms vals
+ (make-call src body orig-args))))
+ ;; It's possible for a `let' to go away after the
+ ;; visit due to the fact that visiting a procedure in
+ ;; value context will prune unused bindings, whereas
+ ;; visiting in operator mode can't because it doesn't
+ ;; traverse through lambdas. In that case re-visit
+ ;; the procedure.
+ (proc (revisit-proc proc)))
+ (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(_
(make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
@@ -1316,13 +1431,13 @@ top-level bindings from ENV and return the resulting
expression."
((operator) exp)
(else (record-source-expression!
exp
- (make-lambda src meta (for-values body))))))
+ (make-lambda src meta (and body (for-values body)))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
(($ <primcall> _ '@apply
- (($ <lambda> _ _ lcase)
+ (($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
(and (equal? sym gensyms)
@@ -1365,37 +1480,6 @@ top-level bindings from ENV and return the resulting
expression."
(($ <primcall> _ 'make-prompt-tag (or () ((?
constant-expression?))))
#t)
(_ #f)))
- (define (find-definition x n-aliases)
- (cond
- ((lexical-ref? x)
- (cond
- ((lookup (lexical-ref-gensym x))
- => (lambda (op)
- (let ((y (or (operand-residual-value op)
- (visit-operand op counter 'value 10 10))))
- (cond
- ((and (lexical-ref? y)
- (= (lexical-refcount (lexical-ref-gensym x)) 1))
- ;; X is a simple alias for Y. Recurse, regardless of
- ;; the number of aliases we were expecting.
- (find-definition y n-aliases))
- ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
- ;; We found a definition that is aliased the right
- ;; number of times. We still recurse in case it is a
- ;; lexical.
- (values (find-definition y 1)
- op))
- (else
- ;; We can't account for our aliases.
- (values #f #f))))))
- (else
- ;; A formal parameter. Can't say anything about that.
- (values #f #f))))
- ((= n-aliases 1)
- ;; Not a lexical: success, but only if we are looking for an
- ;; unaliased value.
- (values x #f))
- (else (values #f #f))))
(let ((tag (for-value tag))
(body (for-tail body)))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 3ad3727..80c32fe 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,6 +1,6 @@
;;; Tree Intermediate Language
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -44,4 +44,5 @@
#:parser parse-tree-il
#:joiner join
#:compilers `((glil . ,compile-glil))
+ #:for-humans? #f
)
diff --git a/module/language/value/spec.scm b/module/language/value/spec.scm
index 6c6cff9..506b073 100644
--- a/module/language/value/spec.scm
+++ b/module/language/value/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 2013 Free Software 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,4 +26,5 @@
#:title "Values"
#:reader #f
#:printer write
+ #:for-humans? #f
)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index cd811b3..2e875fa 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,28 +1,27 @@
;;; installed-scm-file
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free
Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <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
-;;;;
+;;;;
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
-;;;; This file is based upon stklos.stk from the STk distribution by
-;;;; Erick Gallesio <address@hidden>.
+;;;; This file was based upon stklos.stk from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <address@hidden>.
;;;;
(define-module (oop goops)
diff --git a/module/oop/goops/active-slot.scm b/module/oop/goops/active-slot.scm
index 79aa1b3..4d3bbf7 100644
--- a/module/oop/goops/active-slot.scm
+++ b/module/oop/goops/active-slot.scm
@@ -1,28 +1,27 @@
;;; installed-scm-file
-;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <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
-;;;;
-
+;;;;
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
+
;;;;
-;;;; This file is based upon active-slot.stklos from the STk
-;;;; distribution by Erick Gallesio <address@hidden>.
+;;;; This file was based upon active-slot.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <address@hidden>.
;;;;
(define-module (oop goops active-slot)
diff --git a/module/oop/goops/composite-slot.scm
b/module/oop/goops/composite-slot.scm
index b3f8cc0..bd3eb94 100644
--- a/module/oop/goops/composite-slot.scm
+++ b/module/oop/goops/composite-slot.scm
@@ -1,28 +1,27 @@
;;; installed-scm-file
-;;;; Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <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
-;;;;
+;;;;
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
-;;;; This file is based upon composite-slot.stklos from the STk
-;;;; distribution by Erick Gallesio <address@hidden>.
+;;;; This file was based upon composite-slot.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <address@hidden>.
;;;;
(define-module (oop goops composite-slot)
diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm
index 86b2d2c..52eb299 100644
--- a/module/oop/goops/describe.scm
+++ b/module/oop/goops/describe.scm
@@ -1,28 +1,27 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <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
-;;;;
+;;;;
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
-;;;; This file is based upon describe.stklos from the STk distribution by
-;;;; Erick Gallesio <address@hidden>.
+;;;; This file was based upon describe.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <address@hidden>.
;;;;
(define-module (oop goops describe)
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 05362e0..dda2aea 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -128,6 +128,29 @@
(hashq-ref readables obj))
;;;
+;;; Writer helpers
+;;;
+
+(define (write-component-procedure o file env)
+ "Return #f if circular reference"
+ (cond ((immediate? o) (write o file) #t)
+ ((readable? o) (write (readable-expression o) file) #t)
+ ((excluded? o env) (display #f file) #t)
+ (else
+ (let ((info (object-info o env)))
+ (cond ((not (binding? info)) (write-readably o file env) #t)
+ ((not (eq? (visiting info) #:defined)) #f) ;forward reference
+ (else (display (binding info) file) #t))))))
+
+;;; write-component OBJECT PATCHER FILE ENV
+;;;
+(define-macro (write-component object patcher file env)
+ `(or (write-component-procedure ,object ,file ,env)
+ (begin
+ (display #f ,file)
+ (add-patcher! ,patcher ,env))))
+
+;;;
;;; Strings
;;;
@@ -603,24 +626,6 @@
(pop-ref! env)
(set! (objects env) (cons o (objects env)))))))
-(define (write-component-procedure o file env)
- "Return #f if circular reference"
- (cond ((immediate? o) (write o file) #t)
- ((readable? o) (write (readable-expression o) file) #t)
- ((excluded? o env) (display #f file) #t)
- (else
- (let ((info (object-info o env)))
- (cond ((not (binding? info)) (write-readably o file env) #t)
- ((not (eq? (visiting info) #:defined)) #f) ;forward reference
- (else (display (binding info) file) #t))))))
-
-;;; write-component OBJECT PATCHER FILE ENV
-;;;
-(define-macro (write-component object patcher file env)
- `(or (write-component-procedure ,object ,file ,env)
- (begin
- (display #f ,file)
- (add-patcher! ,patcher ,env))))
;;;
;;; Main engine
diff --git a/module/srfi/srfi-27.scm b/module/srfi/srfi-27.scm
index 9777ace..0794a43 100644
--- a/module/srfi/srfi-27.scm
+++ b/module/srfi/srfi-27.scm
@@ -36,6 +36,8 @@
random-source-make-reals)
#:use-module (srfi srfi-9))
+(cond-expand-provide (current-module) '(srfi-27))
+
(define-record-type :random-source
(%make-random-source state)
random-source?
diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm
index cf67e8a..f11aa84 100644
--- a/module/srfi/srfi-31.scm
+++ b/module/srfi/srfi-31.scm
@@ -21,6 +21,8 @@
(define-module (srfi srfi-31)
#:export (rec))
+(cond-expand-provide (current-module) '(srfi-31))
+
(define-syntax rec
(syntax-rules ()
"Return the given object, defined in a lexical environment where
diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm
index 565b44c..3f654af 100644
--- a/module/srfi/srfi-37.scm
+++ b/module/srfi/srfi-37.scm
@@ -1,6 +1,6 @@
;;; srfi-37.scm --- args-fold
-;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -145,6 +145,9 @@ program-arguments in ARGS, as decided by the OPTIONS'
(let ((result (cadr args)))
(set! args (cddr args))
result))
+ ((pair? args)
+ (set! args (cdr args))
+ #f)
(else #f)))
;; Interpret the short-option at index POSITION in (car ARGS),
diff --git a/module/srfi/srfi-38.scm b/module/srfi/srfi-38.scm
index 874dd90..34cf22e 100644
--- a/module/srfi/srfi-38.scm
+++ b/module/srfi/srfi-38.scm
@@ -32,6 +32,7 @@
#:use-module (srfi srfi-69)
#:use-module (system vm trap-state))
+(cond-expand-provide (current-module) '(srfi-38))
;; A printer that shows all sharing of substructures. Uses the Common
;; Lisp print-circle notation: #n# refers to a previous substructure
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
index 0d54063..661ab0f 100644
--- a/module/srfi/srfi-39.scm
+++ b/module/srfi/srfi-39.scm
@@ -41,6 +41,8 @@
parameterize
current-input-port current-output-port current-error-port))
+(cond-expand-provide (current-module) '(srfi-39))
+
(define (with-parameters* params values thunk)
(let more ((params params)
(values values)
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index 43f5ef6..c6eb00b 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -69,6 +69,7 @@
f64vector? make-f64vector f64vector f64vector-length f64vector-ref
f64vector-set! f64vector->list list->f64vector))
+(cond-expand-provide (current-module) '(srfi-4))
;; Need quasisyntax to do this effectively using syntax-case
(define-macro (define-bytevector-type tag infix size)
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index 39d6350..7f595d6 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-4
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -101,14 +101,14 @@
`(define (,(symbol-append 'any-> tag 'vector) obj)
(cond ((,(symbol-append tag 'vector?) obj) obj)
((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
- ((generalized-vector? obj)
- (let* ((len (generalized-vector-length obj))
+ ((and (array? obj) (eqv? 1 (array-rank obj)))
+ (let* ((len (array-length obj))
(v (,(symbol-append 'make- tag 'vector) len)))
(let lp ((i 0))
(if (< i len)
(begin
(,(symbol-append tag 'vector-set!)
- v i (generalized-vector-ref obj i))
+ v i (array-ref obj i))
(lp (1+ i)))
v))))
(else (scm-error 'wrong-type-arg #f "" '() (list
obj))))))
diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm
new file mode 100644
index 0000000..3589b35
--- /dev/null
+++ b/module/srfi/srfi-41.scm
@@ -0,0 +1,505 @@
+;;; srfi-41.scm -- SRFI 41 streams
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (stream-null stream-cons stream? stream-null? stream-pair?
+ stream-car stream-cdr stream-lambda define-stream
+ list->stream port->stream stream stream->list stream-append
+ stream-concat stream-constant stream-drop stream-drop-while
+ stream-filter stream-fold stream-for-each stream-from
+ stream-iterate stream-length stream-let stream-map
+ stream-match stream-of stream-range stream-ref stream-reverse
+ stream-scan stream-take stream-take-while stream-unfold
+ stream-unfolds stream-zip))
+
+(cond-expand-provide (current-module) '(srfi-41))
+
+;;; Private supporting functions and macros.
+
+(define-syntax-rule (must pred obj func msg args ...)
+ (let ((item obj))
+ (unless (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-not pred obj func msg args ...)
+ (let ((item obj))
+ (when (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-every pred objs func msg args ...)
+ (let ((flunk (remove pred objs)))
+ (unless (null? flunk)
+ (throw 'wrong-type-arg func msg (list args ...) flunk))))
+
+(define-syntax-rule (first-value expr)
+ (receive (first . _) expr
+ first))
+
+(define-syntax-rule (second-value expr)
+ (receive (first second . _) expr
+ second))
+
+(define-syntax-rule (third-value expr)
+ (receive (first second third . _) expr
+ third))
+
+(define-syntax define-syntax*
+ (syntax-rules ()
+ ((_ (name . args) body ...)
+ (define-syntax name (lambda* args body ...)))
+ ((_ name syntax)
+ (define-syntax name syntax))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Here we include a copy of the code of srfi-45.scm (but with renamed
+;; identifiers), in order to create a new promise type that's disjoint
+;; from the promises created by srfi-45. Ideally this should be done
+;; using a 'make-promise-type' macro that instantiates a copy of this
+;; code, but a psyntax bug in Guile 2.0 prevents this from working
+;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the
+;; code.
+
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-record-type stream-promise (make-stream-promise val) stream-promise?
+ (val stream-promise-val stream-promise-val-set!))
+
+(define-record-type stream-value (make-stream-value tag proc) stream-value?
+ (tag stream-value-tag stream-value-tag-set!)
+ (proc stream-value-proc stream-value-proc-set!))
+
+(define-syntax-rule (stream-lazy exp)
+ (make-stream-promise (make-stream-value 'lazy (lambda () exp))))
+
+(define (stream-eager x)
+ (make-stream-promise (make-stream-value 'eager x)))
+
+(define-syntax-rule (stream-delay exp)
+ (stream-lazy (stream-eager exp)))
+
+(define (stream-force promise)
+ (let ((content (stream-promise-val promise)))
+ (case (stream-value-tag content)
+ ((eager) (stream-value-proc content))
+ ((lazy) (let* ((promise* ((stream-value-proc content)))
+ (content (stream-promise-val promise)))
+ (if (not (eqv? (stream-value-tag content) 'eager))
+ (begin (stream-value-tag-set! content
+ (stream-value-tag
(stream-promise-val promise*)))
+ (stream-value-proc-set! content
+ (stream-value-proc
(stream-promise-val promise*)))
+ (stream-promise-val-set! promise* content)))
+ (stream-force promise))))))
+
+;;
+;; End of the copy of the code from srfi-45.scm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Primitive stream functions and macros: (streams primitive)
+
+(define stream? stream-promise?)
+
+(define %stream-null (cons 'stream 'null))
+(define stream-null (stream-eager %stream-null))
+
+(define (stream-null? obj)
+ (and (stream-promise? obj)
+ (eqv? (stream-force obj) %stream-null)))
+
+(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare?
+ (kar stream-kar)
+ (kdr stream-kdr))
+
+(define (stream-pair? obj)
+ (and (stream-promise? obj) (stream-pare? (stream-force obj))))
+
+(define-syntax-rule (stream-cons obj strm)
+ (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))
+
+(define (stream-car strm)
+ (must stream? strm 'stream-car "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-car "null stream")
+ (stream-force (stream-kar pare))))
+
+(define (stream-cdr strm)
+ (must stream? strm 'stream-cdr "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-cdr "null stream")
+ (stream-kdr pare)))
+
+(define-syntax-rule (stream-lambda formals body0 body1 ...)
+ (lambda formals (stream-lazy (begin body0 body1 ...))))
+
+(define* (stream-promise-visit promise #:key on-eager on-lazy)
+ (define content (stream-promise-val promise))
+ (case (stream-value-tag content)
+ ((eager) (on-eager (stream-value-proc content)))
+ ((lazy) (on-lazy (stream-value-proc content)))))
+
+(set-record-type-printer! stream-promise
+ (lambda (strm port)
+ (display "#<stream" port)
+ (let loop ((strm strm))
+ (stream-promise-visit strm
+ #:on-eager (lambda (pare)
+ (cond ((eq? pare %stream-null)
+ (write-char #\> port))
+ (else
+ (write-char #\space port)
+ (stream-promise-visit (stream-kar pare)
+ #:on-eager (cut write <> port)
+ #:on-lazy (lambda (_) (write-char #\? port)))
+ (loop (stream-kdr pare)))))
+ #:on-lazy (lambda (_) (display " ...>" port))))))
+
+;;; Derived stream functions and macros: (streams derived)
+
+(define-syntax-rule (define-stream (name . formal) body0 body1 ...)
+ (define name (stream-lambda formal body0 body1 ...)))
+
+(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...)
+ ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))
+
+(define (list->stream objs)
+ (define (list? x)
+ (or (proper-list? x) (circular-list? x)))
+ (must list? objs 'list->stream "non-list argument")
+ (stream-let recur ((objs objs))
+ (if (null? objs) stream-null
+ (stream-cons (car objs) (recur (cdr objs))))))
+
+(define* (port->stream #:optional (port (current-input-port)))
+ (must input-port? port 'port->stream "non-input-port argument")
+ (stream-let recur ()
+ (let ((c (read-char port)))
+ (if (eof-object? c) stream-null
+ (stream-cons c (recur))))))
+
+(define-syntax stream
+ (syntax-rules ()
+ ((_) stream-null)
+ ((_ x y ...) (stream-cons x (stream y ...)))))
+
+;; Common helper for the various eager-folding functions, such as
+;; stream-fold, stream-drop, stream->list, stream-length, etc.
+(define-inlinable (stream-fold-aux proc base strm limit)
+ (do ((val base (and proc (proc val (stream-car strm))))
+ (strm strm (stream-cdr strm))
+ (limit limit (and limit (1- limit))))
+ ((or (and limit (zero? limit)) (stream-null? strm))
+ (values val strm limit))))
+
+(define stream->list
+ (case-lambda
+ ((strm) (stream->list #f strm))
+ ((n strm)
+ (must stream? strm 'stream->list "non-stream argument")
+ (when n
+ (must integer? n 'stream->list "non-integer count")
+ (must exact? n 'stream->list "inexact count")
+ (must-not negative? n 'stream->list "negative count"))
+ (reverse! (first-value (stream-fold-aux xcons '() strm n))))))
+
+(define (stream-append . strms)
+ (must-every stream? strms 'stream-append "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (null? strms) stream-null
+ (let ((strm (car strms)))
+ (if (stream-null? strm) (recur (cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (cons (stream-cdr strm) (cdr strms)))))))))
+
+(define (stream-concat strms)
+ (must stream? strms 'stream-concat "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (stream-null? strms) stream-null
+ (let ((strm (stream-car strms)))
+ (must stream? strm 'stream-concat "non-stream object in input
stream")
+ (if (stream-null? strm) (recur (stream-cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (stream-cons (stream-cdr strm)
+ (stream-cdr strms)))))))))
+
+(define stream-constant
+ (case-lambda
+ (() stream-null)
+ (objs (list->stream (apply circular-list objs)))))
+
+(define-syntax* (stream-do x)
+ (define (end x)
+ (syntax-case x ()
+ (() #'(if #f #f))
+ ((result) #'result)
+ ((result ...) #'(begin result ...))))
+ (define (var-step v s)
+ (syntax-case s ()
+ (() v)
+ ((e) #'e)
+ (_ (syntax-violation 'stream-do "bad step expression" x s))))
+
+ (syntax-case x ()
+ ((_ ((var init . step) ...)
+ (test result ...)
+ expr ...)
+ (with-syntax ((result (end #'(result ...)))
+ ((step ...) (map var-step #'(var ...) #'(step ...))))
+ #'(stream-let loop ((var init) ...)
+ (if test result
+ (begin
+ expr ...
+ (loop step ...))))))))
+
+(define (stream-drop n strm)
+ (must integer? n 'stream-drop "non-integer argument")
+ (must exact? n 'stream-drop "inexact argument")
+ (must-not negative? n 'stream-drop "negative argument")
+ (must stream? strm 'stream-drop "non-stream argument")
+ (second-value (stream-fold-aux #f #f strm n)))
+
+(define (stream-drop-while pred? strm)
+ (must procedure? pred? 'stream-drop-while "non-procedural argument")
+ (must stream? strm 'stream-drop-while "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm)))
+ ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm)))
+
+(define (stream-filter pred? strm)
+ (must procedure? pred? 'stream-filter "non-procedural argument")
+ (must stream? strm 'stream-filter "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else (recur (stream-cdr strm))))))
+
+(define (stream-fold proc base strm)
+ (must procedure? proc 'stream-fold "non-procedural argument")
+ (must stream? strm 'stream-fold "non-stream argument")
+ (first-value (stream-fold-aux proc base strm #f)))
+
+(define stream-for-each
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must stream? strm 'stream-for-each "non-stream argument")
+ (do ((strm strm (stream-cdr strm)))
+ ((stream-null? strm))
+ (proc (stream-car strm))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must-every stream? strms 'stream-for-each "non-stream argument")
+ (do ((strms strms (map stream-cdr strms)))
+ ((any stream-null? strms))
+ (apply proc (map stream-car strms)))))))
+
+(define* (stream-from first #:optional (step 1))
+ (must number? first 'stream-from "non-numeric starting number")
+ (must number? step 'stream-from "non-numeric step size")
+ (stream-let recur ((first first))
+ (stream-cons first (recur (+ first step)))))
+
+(define (stream-iterate proc base)
+ (must procedure? proc 'stream-iterate "non-procedural argument")
+ (stream-let recur ((base base))
+ (stream-cons base (recur (proc base)))))
+
+(define (stream-length strm)
+ (must stream? strm 'stream-length "non-stream argument")
+ (- -1 (third-value (stream-fold-aux #f #f strm -1))))
+
+(define stream-map
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must stream? strm 'stream-map "non-stream argument")
+ (stream-let recur ((strm strm))
+ (if (stream-null? strm) stream-null
+ (stream-cons (proc (stream-car strm))
+ (recur (stream-cdr strm))))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must-every stream? strms 'stream-map "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (apply proc (map stream-car strms))
+ (recur (map stream-cdr strms)))))))))
+
+(define-syntax* (stream-match x)
+ (define (make-matcher x)
+ (syntax-case x ()
+ (() #'(? stream-null?))
+ (rest (identifier? #'rest) #'rest)
+ ((var . rest) (identifier? #'var)
+ (with-syntax ((next (make-matcher #'rest)))
+ #'(? (negate stream-null?)
+ (= stream-car var)
+ (= stream-cdr next))))))
+ (define (make-guarded x fail)
+ (syntax-case (list x fail) ()
+ (((expr) _) #'expr)
+ (((guard expr) fail) #'(if guard expr (fail)))))
+
+ (syntax-case x ()
+ ((_ strm-expr (pat . expr) ...)
+ (with-syntax (((fail ...) (generate-temporaries #'(pat ...))))
+ (with-syntax (((matcher ...) (map make-matcher #'(pat ...)))
+ ((expr ...) (map make-guarded #'(expr ...) #'(fail ...))))
+ #'(let ((strm strm-expr))
+ (must stream? strm 'stream-match "non-stream argument")
+ (match strm (matcher (=> fail) expr) ...)))))))
+
+(define-syntax-rule (stream-of expr rest ...)
+ (stream-of-aux expr stream-null rest ...))
+
+(define-syntax stream-of-aux
+ (syntax-rules (in is)
+ ((_ expr base)
+ (stream-cons expr base))
+ ((_ expr base (var in stream) rest ...)
+ (stream-let recur ((strm stream))
+ (if (stream-null? strm) base
+ (let ((var (stream-car strm)))
+ (stream-of-aux expr (recur (stream-cdr strm)) rest ...)))))
+ ((_ expr base (var is exp) rest ...)
+ (let ((var exp)) (stream-of-aux expr base rest ...)))
+ ((_ expr base pred? rest ...)
+ (if pred? (stream-of-aux expr base rest ...) base))))
+
+(define* (stream-range first past #:optional step)
+ (must number? first 'stream-range "non-numeric starting number")
+ (must number? past 'stream-range "non-numeric ending number")
+ (when step
+ (must number? step 'stream-range "non-numeric step size"))
+ (let* ((step (or step (if (< first past) 1 -1)))
+ (lt? (if (< 0 step) < >)))
+ (stream-let recur ((first first))
+ (if (lt? first past)
+ (stream-cons first (recur (+ first step)))
+ stream-null))))
+
+(define (stream-ref strm n)
+ (must stream? strm 'stream-ref "non-stream argument")
+ (must integer? n 'stream-ref "non-integer argument")
+ (must exact? n 'stream-ref "inexact argument")
+ (must-not negative? n 'stream-ref "negative argument")
+ (let ((res (stream-drop n strm)))
+ (must-not stream-null? res 'stream-ref "beyond end of stream")
+ (stream-car res)))
+
+(define (stream-reverse strm)
+ (must stream? strm 'stream-reverse "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm))
+ (rev stream-null (stream-cons (stream-car strm) rev)))
+ ((stream-null? strm) rev)))
+
+(define (stream-scan proc base strm)
+ (must procedure? proc 'stream-scan "non-procedural argument")
+ (must stream? strm 'stream-scan "non-stream argument")
+ (stream-let recur ((base base) (strm strm))
+ (if (stream-null? strm) (stream base)
+ (stream-cons base (recur (proc base (stream-car strm))
+ (stream-cdr strm))))))
+
+(define (stream-take n strm)
+ (must stream? strm 'stream-take "non-stream argument")
+ (must integer? n 'stream-take "non-integer argument")
+ (must exact? n 'stream-take "inexact argument")
+ (must-not negative? n 'stream-take "negative argument")
+ (stream-let recur ((n n) (strm strm))
+ (if (or (zero? n) (stream-null? strm)) stream-null
+ (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm))))))
+
+(define (stream-take-while pred? strm)
+ (must procedure? pred? 'stream-take-while "non-procedural argument")
+ (must stream? strm 'stream-take-while "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else stream-null))))
+
+(define (stream-unfold mapper pred? generator base)
+ (must procedure? mapper 'stream-unfold "non-procedural mapper")
+ (must procedure? pred? 'stream-unfold "non-procedural pred?")
+ (must procedure? generator 'stream-unfold "non-procedural generator")
+ (stream-let recur ((base base))
+ (if (pred? base)
+ (stream-cons (mapper base) (recur (generator base)))
+ stream-null)))
+
+(define (stream-unfolds gen seed)
+ (define-stream (generator-stream seed)
+ (receive (next . items) (gen seed)
+ (stream-cons (list->vector items) (generator-stream next))))
+ (define-stream (make-result-stream genstrm index)
+ (define head (vector-ref (stream-car genstrm) index))
+ (define-stream (tail) (make-result-stream (stream-cdr genstrm) index))
+ (match head
+ (() stream-null)
+ (#f (tail))
+ ((item) (stream-cons item (tail)))
+ ((? list? items) (stream-append (list->stream items) (tail)))))
+
+ (must procedure? gen 'stream-unfolds "non-procedural argument")
+ (let ((genstrm (generator-stream seed)))
+ (apply values (list-tabulate (vector-length (stream-car genstrm))
+ (cut make-result-stream genstrm <>)))))
+
+(define (stream-zip strm . rest)
+ (let ((strms (cons strm rest)))
+ (must-every stream? strms 'stream-zip "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (map stream-car strms) (recur (map stream-cdr
strms)))))))
diff --git a/module/srfi/srfi-42.scm b/module/srfi/srfi-42.scm
index 0aaaf8f..c826f6f 100644
--- a/module/srfi/srfi-42.scm
+++ b/module/srfi/srfi-42.scm
@@ -61,4 +61,6 @@
vector-ec
vector-of-length-ec))
+(cond-expand-provide (current-module) '(srfi-42))
+
(include-from-path "srfi/srfi-42/ec.scm")
diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm
index 29b0393..6f7ba7e 100644
--- a/module/srfi/srfi-45.scm
+++ b/module/srfi/srfi-45.scm
@@ -1,6 +1,6 @@
;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person
@@ -25,8 +25,8 @@
;;; Commentary:
-;; This is the code of the reference implementation of SRFI-45, slightly
-;; modified to use SRFI-9.
+;; This is the code of the reference implementation of SRFI-45, modified
+;; to use SRFI-9 and to add 'promise?' to the list of exports.
;; This module is documented in the Guile Reference Manual.
@@ -36,9 +36,13 @@
#:export (delay
lazy
force
- eager)
- #:replace (delay force)
- #:use-module (srfi srfi-9))
+ eager
+ promise?)
+ #:replace (delay force promise?)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu))
+
+(cond-expand-provide (current-module) '(srfi-45))
(define-record-type promise (make-promise val) promise?
(val promise-val promise-val-set!))
@@ -73,3 +77,17 @@
;; (*) These two lines re-fetch and check the original promise in case
;; the first line of the let* caused it to be forced. For an example
;; where this happens, see reentrancy test 3 below.
+
+(define* (promise-visit promise #:key on-eager on-lazy)
+ (define content (promise-val promise))
+ (case (value-tag content)
+ ((eager) (on-eager (value-proc content)))
+ ((lazy) (on-lazy (value-proc content)))))
+
+(set-record-type-printer! promise
+ (lambda (promise port)
+ (promise-visit promise
+ #:on-eager (lambda (value)
+ (format port "#<promise = ~s>" value))
+ #:on-lazy (lambda (proc)
+ (format port "#<promise => ~s>" proc)))))
diff --git a/module/srfi/srfi-67.scm b/module/srfi/srfi-67.scm
index 7a43ee5..6d9d4c5 100644
--- a/module/srfi/srfi-67.scm
+++ b/module/srfi/srfi-67.scm
@@ -83,4 +83,6 @@
#:replace (string-compare string-compare-ci)
#:use-module (srfi srfi-27))
+(cond-expand-provide (current-module) '(srfi-67))
+
(include-from-path "srfi/srfi-67/compare.scm")
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
index df07f75..b9486c4 100644
--- a/module/srfi/srfi-69.scm
+++ b/module/srfi/srfi-69.scm
@@ -88,7 +88,7 @@
#:re-export (string-hash)
#:replace (hash make-hash-table hash-table?))
-(cond-expand-provide (current-module) '(srfi-37))
+(cond-expand-provide (current-module) '(srfi-69))
;;;; Internal helper macros
diff --git a/module/sxml/match.scm b/module/sxml/match.scm
index 84cbce3..2cfe643 100644
--- a/module/sxml/match.scm
+++ b/module/sxml/match.scm
@@ -20,7 +20,8 @@
sxml-match-let
sxml-match-let*)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11))
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 control))
;;; Commentary:
@@ -46,22 +47,6 @@
(define-syntax-rule (void)
*unspecified*)
-(define %call/ec-prompt
- (make-prompt-tag))
-
-(define-syntax-rule (call/ec proc)
- ;; aka. `call-with-escape-continuation'
- (call-with-prompt %call/ec-prompt
- (lambda ()
- (proc (lambda args
- (apply abort-to-prompt
- %call/ec-prompt args))))
- (lambda (_ . args)
- (apply values args))))
-
-(define-syntax-rule (let/ec cont body ...)
- (call/ec (lambda (cont) body ...)))
-
(define (raise-syntax-error x msg obj sub)
(throw 'sxml-match-error x msg obj sub))
diff --git a/module/sxml/simple.scm b/module/sxml/simple.scm
index dcef3b2..703ad91 100644
--- a/module/sxml/simple.scm
+++ b/module/sxml/simple.scm
@@ -1,6 +1,6 @@
;;;; (sxml simple) -- a simple interface to the SSAX parser
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2013 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.
;;;;
@@ -26,16 +26,194 @@
;;; Code:
(define-module (sxml simple)
+ #:use-module (sxml ssax input-parse)
#:use-module (sxml ssax)
#:use-module (sxml transform)
- #:use-module (ice-9 optargs)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-13)
#:export (xml->sxml sxml->xml sxml->string))
-(define* (xml->sxml #:optional (port (current-input-port)))
+;; Helpers from upstream/SSAX.scm.
+;;
+
+; 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)))
+ '())))))))
+
+(define (read-internal-doctype-as-string port)
+ (string-concatenate/shared
+ (let loop ()
+ (let ((fragment
+ (next-token '() '(#\]) "reading internal DOCTYPE" port)))
+ (if (eqv? #\> (peek-next-char port))
+ (begin
+ (read-char port)
+ (cons fragment '()))
+ (cons* fragment "]" (loop)))))))
+
+;; Ideas for the future for this interface:
+;;
+;; * Allow doctypes to provide parsed entities
+;;
+;; * Allow validation (the ELEMENTS value from the DOCTYPE handler
+;; below)
+;;
+;; * Parse internal DTDs
+;;
+;; * Parse external DTDs
+;;
+(define* (xml->sxml #:optional (string-or-port (current-input-port)) #:key
+ (namespaces '())
+ (declare-namespaces? #t)
+ (trim-whitespace? #f)
+ (entities '())
+ (default-entity-handler #f)
+ (doctype-handler #f))
"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 '()))
+argument, @var{string-or-port}, which defaults to the current input
+port."
+ ;; NAMESPACES: alist of PREFIX -> URI. Specifies the symbol prefix
+ ;; that the user wants on elements of a given namespace in the
+ ;; resulting SXML, regardless of the abbreviated namespaces defined in
+ ;; the document by xmlns attributes. If DECLARE-NAMESPACES? is true,
+ ;; these namespaces are treated as if they were declared in the DTD.
+
+ ;; ENTITIES: alist of SYMBOL -> STRING.
+
+ ;; NAMESPACES: list of (DOC-PREFIX . (USER-PREFIX . URI)).
+ ;; A DOC-PREFIX of #f indicates that it comes from the user.
+ ;; Otherwise, prefixes are symbols.
+ (define (munge-namespaces namespaces)
+ (map (lambda (el)
+ (match el
+ ((prefix . uri-string)
+ (cons* (and declare-namespaces? prefix)
+ prefix
+ (ssax:uri-string->symbol uri-string)))))
+ namespaces))
+
+ (define (user-namespaces)
+ (munge-namespaces namespaces))
+
+ (define (user-entities)
+ (if (and default-entity-handler
+ (not (assq '*DEFAULT* entities)))
+ (acons '*DEFAULT* default-entity-handler entities)
+ entities))
+
+ (define (name->sxml name)
+ (match name
+ ((prefix . local-part)
+ (symbol-append prefix (string->symbol ":") local-part))
+ (_ name)))
+
+ (define (doctype-continuation seed)
+ (lambda* (#:key (entities '()) (namespaces '()))
+ (values #f
+ (append entities (user-entities))
+ (append (munge-namespaces namespaces) (user-namespaces))
+ seed)))
+
+ ;; The SEED in this parser is the SXML: initialized to '() at each new
+ ;; level by the fdown handlers; built in reverse by the fhere parsers;
+ ;; and reverse-collected by the fup handlers.
+ (define parser
+ (ssax:make-parser
+ NEW-LEVEL-SEED ; fdown
+ (lambda (elem-gi attributes namespaces expected-content seed)
+ '())
+
+ FINISH-ELEMENT ; fup
+ (lambda (elem-gi attributes namespaces parent-seed seed)
+ (let ((seed (if trim-whitespace?
+ (ssax:reverse-collect-str-drop-ws seed)
+ (ssax:reverse-collect-str seed)))
+ (attrs (attlist-fold
+ (lambda (attr accum)
+ (cons (list (name->sxml (car attr)) (cdr attr))
+ accum))
+ '() attributes)))
+ (acons (name->sxml elem-gi)
+ (if (null? attrs)
+ seed
+ (cons (cons '@ attrs) seed))
+ parent-seed)))
+
+ CHAR-DATA-HANDLER ; fhere
+ (lambda (string1 string2 seed)
+ (if (string-null? string2)
+ (cons string1 seed)
+ (cons* string2 string1 seed)))
+
+ DOCTYPE
+ ;; -> ELEMS ENTITIES NAMESPACES SEED
+ ;;
+ ;; ELEMS is for validation and currently unused.
+ ;;
+ ;; ENTITIES is an alist of parsed entities (symbol -> string).
+ ;;
+ ;; NAMESPACES is as above.
+ ;;
+ ;; SEED builds up the content.
+ (lambda (port docname systemid internal-subset? seed)
+ (call-with-values
+ (lambda ()
+ (cond
+ (doctype-handler
+ (doctype-handler docname systemid
+ (and internal-subset?
+ (read-internal-doctype-as-string port))))
+ (else
+ (when internal-subset?
+ (ssax:skip-internal-dtd port))
+ (values))))
+ (doctype-continuation seed)))
+
+ UNDECL-ROOT
+ ;; This is like the DOCTYPE handler, but for documents that do not
+ ;; have a <!DOCTYPE!> entry.
+ (lambda (elem-gi seed)
+ (call-with-values
+ (lambda ()
+ (if doctype-handler
+ (doctype-handler #f #f #f)
+ (values)))
+ (doctype-continuation seed)))
+
+ PI
+ ((*DEFAULT*
+ . (lambda (port pi-tag seed)
+ (cons
+ (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+ seed))))))
+
+ (let* ((port (if (string? string-or-port)
+ (open-input-string string-or-port)
+ string-or-port))
+ (elements (reverse (parser port '()))))
+ `(*TOP* ,@elements)))
(define check-name
(let ((*good-cache* (make-hash-table)))
diff --git a/module/sxml/ssax.scm b/module/sxml/ssax.scm
index a4de0e3..f750c93 100644
--- a/module/sxml/ssax.scm
+++ b/module/sxml/ssax.scm
@@ -1,6 +1,6 @@
;;;; (sxml ssax) -- the SSAX parser
;;;;
-;;;; Copyright (C) 2009, 2010,2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010,2012,2013 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.
;;;;
@@ -170,17 +170,22 @@
(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 current-ssax-error-port
+ (make-parameter (current-error-port)))
+
+(define *current-ssax-error-port*
+ (parameter-fluid current-ssax-error-port))
(define (with-ssax-error-to-port port thunk)
- (with-fluids ((*current-ssax-error-port* port))
+ (parameterize ((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 (ssax:warn port . args)
+ (with-output-to-port (current-ssax-error-port)
+ (lambda ()
+ (display ";;; SSAX warning: ")
+ (for-each display args)
+ (newline))))
(define (ucscode->string codepoint)
(string (integer->char codepoint)))
diff --git a/module/sxml/upstream/SSAX.scm b/module/sxml/upstream/SSAX.scm
index 776e311..d2b8fd9 100644
--- a/module/sxml/upstream/SSAX.scm
+++ b/module/sxml/upstream/SSAX.scm
@@ -442,6 +442,11 @@
; named-entity-name is currently being expanded. A reference to
; this named-entity-name will be an error: violation of the
; WFC nonrecursion.
+;
+; As an extension to the original SSAX, Guile allows a
+; named-entity-name of *DEFAULT* to indicate a fallback procedure,
+; called as (FALLBACK PORT NAME). The procedure should return a
+; string.
; XML-TOKEN -- a record
@@ -1095,10 +1100,20 @@
(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))))
+ ((assq name ssax:predefined-parsed-entities)
+ => (lambda (decl-entity)
+ (str-handler (cdr decl-entity) "" seed)))
+ ((assq '*DEFAULT* entities) =>
+ (lambda (decl-entity)
+ (let ((fallback (cdr decl-entity))
+ (new-entities (cons (cons name #f) entities)))
+ (cond
+ ((procedure? fallback)
+ (call-with-input-string (fallback port name)
+ (lambda (port) (content-handler port new-entities seed))))
+ (else
+ (parser-error port "[norecursion] broken for " name))))))
+ (else (parser-error port "[wf-entdeclared] broken for " name))))
@@ -1267,6 +1282,14 @@
'((ent . "<&ent1;T;>") (ent1 . "&"))
`((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
(,(string->symbol "Next") . "12<&T;>34")))
+ (test "%tAbc='<&>
'%nNext='12&ent;34' />"
+ `((*DEFAULT* . ,(lambda (port name)
+ (case name
+ ((ent) "<&ent1;T;>")
+ ((ent1) "&")
+ (else (error "unrecognized" name))))))
+ `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+ (,(string->symbol "Next") . "12<&T;>34")))
(assert (failed?
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<&ent1;T;>") (ent1 . "&")) '())))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index f3e4641..c522b74 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -48,7 +48,7 @@
thunk
(lambda () #t))))
-;; (put 'call-with-output-file/atomic 'scheme-indent-function 1)
+;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
(define* (call-with-output-file/atomic filename proc #:optional reference)
(let* ((template (string-append filename ".XXXXXX"))
(tmp (mkstemp! template)))
@@ -57,10 +57,13 @@
(with-throw-handler #t
(lambda ()
(proc tmp)
- (chmod tmp (logand #o0666 (lognot (umask))))
+ ;; Chmodding by name instead of by port allows this chmod to
+ ;; work on systems without fchmod, like MinGW.
+ (chmod template (logand #o0666 (lognot (umask))))
(close-port tmp)
(rename-file template filename))
(lambda args
+ (close-port tmp)
(delete-file template)))))))
(define (ensure-language x)
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 81b43b7..5d927e0 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -25,7 +25,8 @@
language-name language-title language-reader
language-printer language-parser
language-compilers language-decompilers language-evaluator
- language-joiner language-make-default-environment
+ language-joiner language-for-humans?
+ language-make-default-environment
lookup-compilation-order lookup-decompilation-order
invalidate-compilation-cache! default-environment
@@ -49,6 +50,7 @@
(decompilers '())
(evaluator #f)
(joiner #f)
+ (for-humans? #t)
(make-default-environment make-fresh-user-module))
(define-macro (define-language name . spec)
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 304056d..c74ae67 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -1,6 +1,6 @@
;;; Compilation targets
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -55,7 +55,7 @@
(let ((cpu (triplet-cpu target)))
(with-fluids ((%target-type target)
(%target-endianness (cpu-endianness cpu))
- (%target-word-size (cpu-word-size cpu)))
+ (%target-word-size (triplet-pointer-size target)))
(thunk))))
(define (cpu-endianness cpu)
@@ -75,16 +75,30 @@
(else
(error "unknown CPU endianness" cpu)))))
-(define (cpu-word-size cpu)
- "Return the word size for CPU."
- (if (string=? cpu (triplet-cpu %host-type))
- %native-word-size
- (cond ((string-match "^i[0-9]86$" cpu) 4)
- ((string-match "64$" cpu) 8)
- ((string-match "64[lbe][lbe]$" cpu) 8)
- ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4)
- ((string-match "^arm.*" cpu) 4)
- (else (error "unknown CPU word size" cpu)))))
+(define (triplet-pointer-size triplet)
+ "Return the size of pointers in bytes for TRIPLET."
+ (let ((cpu (triplet-cpu triplet)))
+ (cond ((and (string=? cpu (triplet-cpu %host-type))
+ (string=? (triplet-os triplet) (triplet-os %host-type)))
+ %native-word-size)
+
+ ((string-match "^i[0-9]86$" cpu) 4)
+
+ ;; Although GNU config.guess doesn't yet recognize them,
+ ;; Debian (ab)uses the OS part to denote the specific ABI
+ ;; being used: <http://wiki.debian.org/Multiarch/Tuples>.
+ ;; See <http://www.linux-mips.org/wiki/WhatsWrongWithO32N32N64>
+ ;; for details on the MIPS ABIs.
+ ((string-match "^mips64.*-gnuabi64" triplet) 8) ; n64 ABI
+ ((string-match "^mips64" cpu) 4) ; n32 or o32
+
+ ((string-match "^x86_64-.*-gnux32" triplet) 4) ; x32
+
+ ((string-match "64$" cpu) 8)
+ ((string-match "64[lbe][lbe]$" cpu) 8)
+ ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4)
+ ((string-match "^arm.*" cpu) 4)
+ (else (error "unknown CPU word size" cpu)))))
(define (triplet-cpu t)
(substring t 0 (string-index t #\-)))
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index e6e9655..01a71b8 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -25,7 +25,7 @@
float double
short
unsigned-short
- int unsigned-int long unsigned-long size_t
+ int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
int8 uint8
uint16 int16
uint32 int32
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index fdd56cd..215451e 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -350,18 +350,20 @@ Show description/documentation."
(newline))
(define-meta-command (option repl . args)
- "option [KEY VALUE]
+ "option [NAME] [EXP]
List/show/set options."
(pmatch args
(()
(for-each (lambda (spec)
(format #t " ~A~24t~A\n" (car spec) (cadr spec)))
(repl-options repl)))
- ((,key)
- (display (repl-option-ref repl key))
+ ((,name)
+ (display (repl-option-ref repl name))
(newline))
- ((,key ,val)
- (repl-option-set! repl key val))))
+ ((,name ,exp)
+ ;; Would be nice to evaluate in the current language, but the REPL
+ ;; option parser doesn't permit that, currently.
+ (repl-option-set! repl name (eval exp (current-module))))))
(define-meta-command (quit repl)
"quit
@@ -482,14 +484,21 @@ Run the optimizer on a piece of code and print the
result."
(define (guile:disassemble x)
((@ (language assembly disassemble) disassemble) x))
+(define (disassemble-program x)
+ ((@ (system vm disassembler) disassemble-program) x))
+
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
(let ((obj (repl-eval repl (repl-parse repl form))))
- (if (or (program? obj) (objcode? obj))
- (guile:disassemble obj)
- (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
- obj))))
+ (cond
+ ((rtl-program? obj)
+ (disassemble-program obj))
+ ((or (program? obj) (objcode? obj))
+ (guile:disassemble obj))
+ (else
+ (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
+ obj)))))
(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 3f3e785..5da7c48 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,6 +1,7 @@
;;; Repl common routines
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
+;; 2013 Free Software 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,7 +40,7 @@
(define *version*
(format #f "GNU Guile ~A
-Copyright (C) 1995-2012 Free Software Foundation, Inc.
+Copyright (C) 1995-2013 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
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 7d2b7c8..1649556 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -87,12 +87,9 @@
(lambda ()
(let ((ch (flush-leading-whitespace)))
(cond ((eof-object? ch)
- ;; EOF objects are not buffered. It's quite possible
- ;; to peek an EOF then read something else. It's
- ;; strange but it's how it works.
- ch)
+ (read-char)) ; consume the EOF and return it
((eqv? ch #\,)
- (read-char port)
+ (read-char)
meta-command-token)
((read-comment lang port ch)
*unspecified*)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
new file mode 100644
index 0000000..4080110
--- /dev/null
+++ b/module/system/vm/assembler.scm
@@ -0,0 +1,1309 @@
+;;; Guile RTL assembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software 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 assembler)
+ #:use-module (system base target)
+ #:use-module (system vm instruction)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker)
+ #:use-module (system vm objcode)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:export (make-assembler
+ emit-text
+ link-assembly
+ assemble-program))
+
+(define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0)))))
+
+(define-syntax-rule (pack-u8-u24 x y)
+ (logior x (ash y 8)))
+
+(define-syntax-rule (pack-u8-s24 x y)
+ (logior x (ash (cond
+ ((< 0 (- y) #x800000)
+ (+ y #x1000000))
+ ((<= 0 y #xffffff)
+ y)
+ (else (error "out of range" y)))
+ 8)))
+
+(define-syntax-rule (pack-u1-u7-u24 x y z)
+ (logior x (ash y 1) (ash z 8)))
+
+(define-syntax-rule (pack-u8-u12-u12 x y z)
+ (logior x (ash y 8) (ash z 20)))
+
+(define-syntax-rule (pack-u8-u8-u16 x y z)
+ (logior x (ash y 8) (ash z 16)))
+
+(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
+ (logior x (ash y 8) (ash z 16) (ash w 24)))
+
+(define-syntax-rule (check arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x))))
+
+(define-record-type <meta>
+ (%make-meta label properties low-pc high-pc arities)
+ meta?
+ (label meta-label)
+ (properties meta-properties set-meta-properties!)
+ (low-pc meta-low-pc)
+ (high-pc meta-high-pc set-meta-high-pc!)
+ (arities meta-arities set-meta-arities!))
+
+(define (make-meta label properties low-pc)
+ (check label (? symbol?) "symbol")
+ (check properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f '()))
+
+(define (meta-name meta)
+ (assq-ref (meta-properties meta) 'name))
+
+;; Metadata for one <lambda-case>.
+(define-record-type <arity>
+ (make-arity req opt rest kw-indices allow-other-keys?
+ low-pc high-pc)
+ arity?
+ (req arity-req)
+ (opt arity-opt)
+ (rest arity-rest)
+ (kw-indices arity-kw-indices)
+ (allow-other-keys? arity-allow-other-keys?)
+ (low-pc arity-low-pc)
+ (high-pc arity-high-pc set-arity-high-pc!))
+
+(define-syntax *block-size* (identifier-syntax 32))
+
+;; We'll use native endianness when writing bytecode. If we're
+;; targeting a foreign endianness, we byte-swap the bytevector as a
+;; whole instead of conditionalizing each access.
+;;
+;; We write constants using the target endianness, though.
+;;
+(define-record-type <asm>
+ (make-asm cur idx start prev written
+ labels relocs
+ word-size endianness
+ constants inits
+ string-table
+ meta
+ next-section-number)
+ asm?
+ (cur asm-cur set-asm-cur!)
+ (idx asm-idx set-asm-idx!)
+ (start asm-start set-asm-start!)
+ (prev asm-prev set-asm-prev!)
+ (written asm-written set-asm-written!)
+ (labels asm-labels set-asm-labels!)
+ (relocs asm-relocs set-asm-relocs!)
+ (word-size asm-word-size)
+ (endianness asm-endianness)
+ ;; Vhash of object -> label. Order is important.
+ (constants asm-constants set-asm-constants!)
+ (inits asm-inits set-asm-inits!)
+ (string-table asm-string-table set-asm-string-table!)
+ (meta asm-meta set-asm-meta!)
+ (next-section-number asm-next-section-number set-asm-next-section-number!))
+
+(define-inlinable (fresh-block)
+ (make-u32vector *block-size*))
+
+(define* (make-assembler #:key (word-size (target-word-size))
+ (endianness (target-endianness)))
+ (make-asm (fresh-block) 0 0 '() 0
+ '() '()
+ word-size endianness
+ vlist-null '()
+ (make-string-table)
+ '()
+ 1))
+
+(define (intern-string! asm string)
+ (call-with-values
+ (lambda () (string-table-intern (asm-string-table asm) string))
+ (lambda (table idx)
+ (set-asm-string-table! asm table)
+ idx)))
+
+(define-inlinable (asm-pos asm)
+ (+ (asm-idx asm) (asm-written asm)))
+
+(define (allocate-new-block asm)
+ (let ((new (fresh-block)))
+ (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm)))
+ (set-asm-written! asm (asm-pos asm))
+ (set-asm-cur! asm new)
+ (set-asm-idx! asm 0)))
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (u32-set! buf n val)
+ (bytevector-u32-native-set! buf (* n 4) val))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-set! buf n val)
+ (bytevector-s32-native-set! buf (* n 4) val))
+
+(define-inlinable (emit asm u32)
+ (u32-set! (asm-cur asm) (asm-idx asm) u32)
+ (set-asm-idx! asm (1+ (asm-idx asm)))
+ (if (= (asm-idx asm) *block-size*)
+ (allocate-new-block asm)))
+
+(define-inlinable (make-reloc type label base word)
+ (list type label base word))
+
+(define-inlinable (reset-asm-start! asm)
+ (set-asm-start! asm (asm-pos asm)))
+
+(define (emit-exported-label asm label)
+ (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
+
+(define (record-label-reference asm label)
+ (let* ((start (asm-start asm))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 'x8-s24 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+(define* (record-far-label-reference asm label #:optional (offset 0))
+ (let* ((start (- (asm-start asm) offset))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 's32 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+(eval-when (expand compile load eval)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
+
+(define-syntax assembler
+ (lambda (x)
+ (define-syntax op-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ asm name ((type arg ...) code ...) clause ...)
+ #`(if (eq? name 'type)
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...)
+ code ...))
+ (op-case asm name clause ...)))
+ ((_ asm name)
+ #'(error "unmatched name" 'name)))))
+
+ (define (pack-first-word asm opcode type)
+ (with-syntax ((opcode opcode))
+ (op-case
+ asm type
+ ((U8_X24)
+ (emit asm opcode))
+ ((U8_U24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((U8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((U8_R24 rest)
+ (emit asm (pack-u8-u24 opcode (list rest)))
+ (for-each (lambda (x) (emit asm x)) rest))
+ ((U8_U8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((U8_U8_U8_U8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
+ (op-case
+ asm type
+ ((U8_U24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((U8_L24 a label)
+ (record-label-reference asm label)
+ (emit asm a))
+ ((U8_R24 rest)
+ (emit asm (pack-u8-u24 a (length rest)))
+ (for-each (lambda (x) (emit asm x)) rest))
+ ((U8_U8_I16 a b imm)
+ (emit asm (pack-u8-u8-u16 a b (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 a b c)))
+ ((U8_U8_U8_U8 a b c d)
+ (emit asm (pack-u8-u8-u8-u8 a b c d)))
+ ((U32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (object-address imm)))
+ (unless (zero? (ash val -32))
+ (error "FIXME: enable truncation of negative fixnums when
cross-compiling"))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (emit asm (ash (object-address imm) -32))
+ (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+ ((B32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((S32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((L32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((LO32 label offset)
+ (record-far-label-reference asm label
+ (* offset (/ (asm-word-size asm) 4)))
+ (emit asm 0))
+ ((X8_U24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 0 a b)))
+ ((X8_R24 rest)
+ (emit asm (pack-u8-u24 0 (length rest)))
+ (for-each (lambda (x) (emit asm x)) rest))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_U7_L24 a b label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm
+ (syntax->datum #'opcode)
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (unless (asm? asm) (error "not an asm"))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm)))))))
+
+(define assemblers (make-hash-table))
+
+(define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
+ (let ((emit (assembler name opcode arg ...)))
+ (hashq-set! assemblers 'name emit)
+ emit)))))))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (rtl-instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(visit-opcodes define-assembler)
+
+(define-inlinable (immediate? x)
+ (not (zero? (logand (object-address x) 6))))
+
+(define-record-type <stringbuf>
+ (make-stringbuf string)
+ stringbuf?
+ (string stringbuf-string))
+
+(define-record-type <static-procedure>
+ (make-static-procedure code)
+ static-procedure?
+ (code static-procedure-code))
+
+;; Used for cells that cache the module that was current when a toplevel
+;; closure was created, or for toplevel refs within a procedure.
+(define-record-type <cache-cell>
+ (make-cache-cell scope key)
+ cache-cell?
+ (scope cache-cell-scope)
+ (key cache-cell-key))
+
+(define (statically-allocatable? x)
+ (or (pair? x) (vector? x) (string? x) (stringbuf? x) (static-procedure? x)))
+
+(define (intern-constant asm obj)
+ (define (recur obj)
+ (intern-constant asm obj))
+ (define (field dst n obj)
+ (let ((src (recur obj)))
+ (if src
+ (list (if (statically-allocatable? obj)
+ `(make-non-immediate 0 ,src)
+ `(static-ref 0 ,src))
+ `(static-set! 0 ,dst ,n))
+ '())))
+ (define (intern obj label)
+ (cond
+ ((pair? obj)
+ (append (field label 0 (car obj))
+ (field label 1 (cdr obj))))
+ ((vector? obj)
+ (let lp ((i 0) (inits '()))
+ (if (< i (vector-length obj))
+ (lp (1+ i)
+ (append-reverse (field label (1+ i) (vector-ref obj i))
+ inits))
+ (reverse inits))))
+ ((stringbuf? obj) '())
+ ((static-procedure? obj)
+ `((make-non-immediate 0 ,label)
+ (link-procedure! 0 ,(static-procedure-code obj))))
+ ((cache-cell? obj) '())
+ ((symbol? obj)
+ `((make-non-immediate 0 ,(recur (symbol->string obj)))
+ (string->symbol 0 0)
+ (static-set! 0 ,label 0)))
+ ((string? obj)
+ `((make-non-immediate 0 ,(recur (make-stringbuf obj)))
+ (static-set! 0 ,label 1)))
+ ((keyword? obj)
+ `((static-ref 0 ,(recur (keyword->symbol obj)))
+ (symbol->keyword 0 0)
+ (static-set! 0 ,label 0)))
+ ((number? obj)
+ `((make-non-immediate 0 ,(recur (number->string obj)))
+ (string->number 0 0)
+ (static-set! 0 ,label 0)))
+ (else
+ (error "don't know how to intern" obj))))
+ (cond
+ ((immediate? obj) #f)
+ ((vhash-assoc obj (asm-constants asm)) => cdr)
+ (else
+ ;; Note that calling intern may mutate asm-constants and
+ ;; asm-constant-inits.
+ (let* ((label (gensym "constant"))
+ (inits (intern obj label)))
+ (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
+ (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
+ label))))
+
+;; Returns a label.
+(define (emit-non-immediate asm obj)
+ (when (immediate? obj)
+ (error "expected a non-immediate" obj))
+ (intern-constant asm obj))
+
+;; Returns a label. Resolutions of the same key within the same scope
+;; share a cell.
+(define (emit-cache-cell asm scope key)
+ (intern-constant asm (make-cache-cell scope key)))
+
+;; Return the label of the cell that holds the module for a scope.
+(define (emit-module-cache-cell asm scope)
+ (emit-cache-cell asm scope #t))
+
+(define-syntax define-macro-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body body* ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
+ (let ((emit (lambda (arg ...) body body* ...)))
+ (hashq-set! assemblers 'name emit)
+ emit)))))))
+
+(define-macro-assembler (load-constant asm dst obj)
+ (cond
+ ((immediate? obj)
+ (let ((bits (object-address obj)))
+ (cond
+ ((and (< dst 256) (zero? (ash bits -16)))
+ (emit-make-short-immediate asm dst obj))
+ ((zero? (ash bits -32))
+ (emit-make-long-immediate asm dst obj))
+ (else
+ (emit-make-long-long-immediate asm dst obj)))))
+ ((statically-allocatable? obj)
+ (emit-make-non-immediate asm dst (emit-non-immediate asm obj)))
+ (else
+ (emit-static-ref asm dst (emit-non-immediate asm obj)))))
+
+(define-macro-assembler (load-static-procedure asm dst label)
+ (let ((loc (intern-constant asm (make-static-procedure label))))
+ (emit-make-non-immediate asm dst loc)))
+
+(define-macro-assembler (begin-program asm label properties)
+ (emit-label asm label)
+ (let ((meta (make-meta label properties (asm-start asm))))
+ (set-asm-meta! asm (cons meta (asm-meta asm)))))
+
+(define-macro-assembler (end-program asm)
+ (let ((meta (car (asm-meta asm))))
+ (set-meta-high-pc! meta (asm-start asm))
+ (set-meta-arities! meta (reverse (meta-arities meta)))))
+
+(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+ (emit-begin-opt-arity asm req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (check req ((? symbol?) ...) "list of symbols")
+ (check opt ((? symbol?) ...) "list of symbols")
+ (check rest (or #f (? symbol?)) "#f or symbol")
+ (check kw-indices (((? symbol?) . (? integer?)) ...)
+ "alist of symbol -> integer")
+ (check allow-other-keys? (? boolean?) "boolean")
+ (check nlocals (? integer?) "integer")
+ (check alternate (or #f (? symbol?)) "#f or symbol")
+ (let* ((meta (car (asm-meta asm)))
+ (arity (make-arity req opt rest kw-indices allow-other-keys?
+ (asm-start asm) #f))
+ (nreq (length req))
+ (nopt (length opt))
+ (rest? (->bool rest)))
+ (set-meta-arities! meta (cons arity (meta-arities meta)))
+ (cond
+ ((or allow-other-keys? (pair? kw-indices))
+ (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
+ nlocals alternate))
+ ((or rest? (pair? opt))
+ (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
+ (else
+ (emit-standard-prelude asm nreq nlocals alternate)))))
+
+(define-macro-assembler (end-arity asm)
+ (let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-high-pc! arity (asm-start asm))))
+
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-reserve-locals asm nlocals))
+ ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
+ (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
+ (else
+ (emit-assert-nargs-ee asm nreq)
+ (emit-reserve-locals asm nlocals))))
+
+(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (else
+ (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-reserve-locals asm nlocals))
+
+(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
+ allow-other-keys? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (let ((ntotal (fold (lambda (kw ntotal)
+ (match kw
+ (((? keyword?) . idx)
+ (max (1+ idx) ntotal))))
+ (+ nreq nopt) kw-indices)))
+ ;; FIXME: port 581f410f
+ (emit-bind-kwargs asm nreq
+ (pack-flags allow-other-keys? rest?)
+ (+ nreq nopt)
+ ntotal
+ kw-indices)
+ (emit-reserve-locals asm nlocals)))
+
+(define-macro-assembler (label asm sym)
+ (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
+
+(define-macro-assembler (cache-current-module! asm tmp scope)
+ (let ((mod-label (emit-module-cache-cell asm scope)))
+ (emit-current-module asm tmp)
+ (emit-static-set! asm tmp mod-label 0)))
+
+(define-macro-assembler (cached-toplevel-ref asm dst scope sym)
+ (let ((sym-label (emit-non-immediate asm sym))
+ (mod-label (emit-module-cache-cell asm scope))
+ (cell-label (emit-cache-cell asm scope sym)))
+ (emit-toplevel-ref asm dst cell-label mod-label sym-label)))
+
+(define-macro-assembler (cached-toplevel-set! asm src scope sym)
+ (let ((sym-label (emit-non-immediate asm sym))
+ (mod-label (emit-module-cache-cell asm scope))
+ (cell-label (emit-cache-cell asm scope sym)))
+ (emit-toplevel-set! asm src cell-label mod-label sym-label)))
+
+(define-macro-assembler (cached-module-ref asm dst module-name public? sym)
+ (let* ((sym-label (emit-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (intern-constant asm key))
+ (cell-label (emit-cache-cell asm key sym)))
+ (emit-module-ref asm dst cell-label mod-name-label sym-label)))
+
+(define-macro-assembler (cached-module-set! asm src module-name public? sym)
+ (let* ((sym-label (emit-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (emit-non-immediate asm key))
+ (cell-label (emit-cache-cell asm key sym)))
+ (emit-module-set! asm src cell-label mod-name-label sym-label)))
+
+(define (emit-text asm instructions)
+ (for-each (lambda (inst)
+ (apply (or (hashq-ref assemblers (car inst))
+ (error 'bad-instruction inst))
+ asm
+ (cdr inst)))
+ instructions))
+
+(define (process-relocs buf relocs labels)
+ (fold
+ (lambda (reloc tail)
+ (let ((abs (assq-ref labels (cadr reloc)))
+ (dst (+ (caddr reloc) (cadddr reloc))))
+ (case (car reloc)
+ ((s32)
+ (if abs
+ (let ((rel (- abs (caddr reloc))))
+ (s32-set! buf dst rel)
+ tail)
+ (cons (make-linker-reloc
+ 'rel32/4 (* dst 4) (cadddr reloc) (cadr reloc))
+ tail)))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ (let ((rel (- abs (caddr reloc)))
+ (u32 (u32-ref buf dst)))
+ (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel))
+ tail))
+ (else (error "what" reloc)))))
+ '()
+ relocs))
+
+(define (process-labels labels)
+ (map (lambda (pair)
+ (make-linker-symbol (car pair) (* (cdr pair) 4)))
+ labels))
+
+(define (swap-bytes! buf)
+ (unless (zero? (modulo (bytevector-length buf) 4))
+ (error "unexpected length"))
+ (let ((byte-len (bytevector-length buf)))
+ (let lp ((pos 0))
+ (unless (= pos byte-len)
+ (bytevector-u32-set!
+ buf pos
+ (bytevector-u32-ref buf pos (endianness big))
+ (endianness little))
+ (lp (+ pos 4))))))
+
+(define (next-section-number! asm)
+ (let ((n (asm-next-section-number asm)))
+ (set-asm-next-section-number! asm (1+ n))
+ n))
+
+(define (make-object asm name bv relocs labels . kwargs)
+ (let ((name-idx (intern-string! asm (symbol->string name))))
+ (make-linker-object (apply make-elf-section
+ #:index (next-section-number! asm)
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (cons (make-linker-symbol name 0) labels))))
+
+(define (link-text-object asm)
+ (let ((buf (make-u32vector (asm-pos asm))))
+ (let lp ((pos 0) (prev (reverse (asm-prev asm))))
+ (if (null? prev)
+ (let ((byte-size (* (asm-idx asm) 4)))
+ (bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
+ (unless (eq? (asm-endianness asm) (native-endianness))
+ (swap-bytes! buf))
+ (make-object asm '.rtl-text
+ buf
+ (process-relocs buf (asm-relocs asm)
+ (asm-labels asm))
+ (process-labels (asm-labels asm))))
+ (let ((len (* *block-size* 4)))
+ (bytevector-copy! (car prev) 0 buf pos len)
+ (lp (+ pos len) (cdr prev)))))))
+
+(define (link-dynamic-section asm text ro rw rw-init)
+ (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
+ (let* ((endianness (asm-endianness asm))
+ (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
+ (set-uword!
+ (lambda (i uword)
+ (%set-uword! bv (* i word-size) uword endianness)))
+ (relocs '())
+ (set-label!
+ (lambda (i label)
+ (set! relocs (cons (make-linker-reloc 'reloc-type
+ (* i word-size) 0 label)
+ relocs))
+ (%set-uword! bv (* i word-size) 0 endianness))))
+ (set-uword! 0 DT_GUILE_RTL_VERSION)
+ (set-uword! 1 #x02020000)
+ (set-uword! 2 DT_GUILE_ENTRY)
+ (set-label! 3 '.rtl-text)
+ (cond
+ (rw
+ ;; Add roots to GC.
+ (set-uword! 4 DT_GUILE_GC_ROOT)
+ (set-label! 5 '.data)
+ (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
+ (set-uword! 7 (bytevector-length (linker-object-bv rw)))
+ (cond
+ (rw-init
+ (set-uword! 8 DT_INIT) ; constants
+ (set-label! 9 rw-init)
+ (set-uword! 10 DT_NULL)
+ (set-uword! 11 0))
+ (else
+ (set-uword! 8 DT_NULL)
+ (set-uword! 9 0))))
+ (else
+ (set-uword! 4 DT_NULL)
+ (set-uword! 5 0)))
+ (make-object asm '.dynamic bv relocs '()
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
+ (case (asm-word-size asm)
+ ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
+ ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
+ (else (error "bad word size" asm))))
+
+(define (link-shstrtab asm)
+ (intern-string! asm ".shstrtab")
+ (make-object asm '.shstrtab
+ (link-string-table (asm-string-table asm))
+ '() '()
+ #:type SHT_STRTAB #:flags 0))
+
+(define (write-immediate asm buf pos x)
+ (let ((val (object-address x))
+ (endianness (asm-endianness asm)))
+ (case (asm-word-size asm)
+ ((4) (bytevector-u32-set! buf pos val endianness))
+ ((8) (bytevector-u64-set! buf pos val endianness))
+ (else (error "bad word size" asm)))))
+
+(define (emit-init-constants asm)
+ (let ((inits (asm-inits asm)))
+ (and (not (null? inits))
+ (let ((label (gensym "init-constants")))
+ (emit-text asm
+ `((begin-program ,label ())
+ (assert-nargs-ee/locals 0 1)
+ ,@(reverse inits)
+ (load-constant 0 ,*unspecified*)
+ (return 0)
+ (end-program)))
+ label))))
+
+(define (link-data asm data name)
+ (define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+ (define tc7-vector 13)
+ (define tc7-narrow-stringbuf 39)
+ (define tc7-wide-stringbuf (+ 39 #x400))
+ (define tc7-ro-string (+ 21 #x200))
+ (define tc7-rtl-program 69)
+
+ (let ((word-size (asm-word-size asm))
+ (endianness (asm-endianness asm)))
+ (define (byte-length x)
+ (cond
+ ((stringbuf? x)
+ (let ((x (stringbuf-string x)))
+ (+ (* 2 word-size)
+ (case (string-bytes-per-char x)
+ ((1) (1+ (string-length x)))
+ ((4) (* (1+ (string-length x)) 4))
+ (else (error "bad string bytes per char" x))))))
+ ((static-procedure? x)
+ (* 2 word-size))
+ ((string? x)
+ (* 4 word-size))
+ ((pair? x)
+ (* 2 word-size))
+ ((vector? x)
+ (* (1+ (vector-length x)) word-size))
+ (else
+ word-size)))
+
+ (define (write-constant-reference buf pos x)
+ ;; The asm-inits will fix up any reference to a non-immediate.
+ (write-immediate asm buf pos (if (immediate? x) x #f)))
+
+ (define (write buf pos obj)
+ (cond
+ ((stringbuf? obj)
+ (let* ((x (stringbuf-string obj))
+ (len (string-length x))
+ (tag (if (= (string-bytes-per-char x) 1)
+ tc7-narrow-stringbuf
+ tc7-wide-stringbuf)))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4) len endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8) len endianness))
+ (else
+ (error "bad word size" asm)))
+ (let ((pos (+ pos (* word-size 2))))
+ (case (string-bytes-per-char x)
+ ((1)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u8 (char->integer (string-ref x i))))
+ (bytevector-u8-set! buf (+ pos i) u8)
+ (lp (1+ i)))
+ (bytevector-u8-set! buf (+ pos i) 0))))
+ ((4)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u32 (char->integer (string-ref x i))))
+ (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
+ (lp (1+ i)))
+ (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
+ (else (error "bad string bytes per char" x))))))
+
+ ((static-procedure? obj)
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-rtl-program endianness)
+ (bytevector-u32-set! buf (+ pos 4) 0 endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-rtl-program endianness)
+ (bytevector-u64-set! buf (+ pos 8) 0 endianness))
+ (else (error "bad word size"))))
+
+ ((cache-cell? obj)
+ (write-immediate asm buf pos #f))
+
+ ((string? obj)
+ (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 4) #f) ; stringbuf
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness)
+ (bytevector-u32-set! buf (+ pos 12) (string-length obj)
endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 8) #f) ; stringbuf
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness)
+ (bytevector-u64-set! buf (+ pos 24) (string-length obj)
endianness))
+ (else (error "bad word size")))))
+
+ ((pair? obj)
+ (write-constant-reference buf pos (car obj))
+ (write-constant-reference buf (+ pos word-size) (cdr obj)))
+
+ ((vector? obj)
+ (let* ((len (vector-length obj))
+ (tag (logior tc7-vector (ash len 8))))
+ (case word-size
+ ((4) (bytevector-u32-set! buf pos tag endianness))
+ ((8) (bytevector-u64-set! buf pos tag endianness))
+ (else (error "bad word size")))
+ (let lp ((i 0))
+ (when (< i (vector-length obj))
+ (let ((pos (+ pos word-size (* i word-size)))
+ (elt (vector-ref obj i)))
+ (write-constant-reference buf pos elt)
+ (lp (1+ i)))))))
+
+ ((symbol? obj)
+ (write-immediate asm buf pos #f))
+
+ ((keyword? obj)
+ (write-immediate asm buf pos #f))
+
+ ((number? obj)
+ (write-immediate asm buf pos #f))
+
+ (else
+ (error "unrecognized object" obj))))
+
+ (cond
+ ((vlist-null? data) #f)
+ (else
+ (let* ((byte-len (vhash-fold (lambda (k v len)
+ (+ (byte-length k) (align len 8)))
+ 0 data))
+ (buf (make-bytevector byte-len 0)))
+ (let lp ((i 0) (pos 0) (labels '()))
+ (if (< i (vlist-length data))
+ (let* ((pair (vlist-ref data i))
+ (obj (car pair))
+ (obj-label (cdr pair)))
+ (write buf pos obj)
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (cons (make-linker-symbol obj-label pos) labels)))
+ (make-object asm name buf '() labels))))))))
+
+;; Hummm
+;;
+(define (link-constants asm)
+ ;; Possibly three sections: one containing shareable read-only data,
+ ;; one containing data that might be written to, and one text section
+ ;; to initialize the pointers in the rwdata.
+ ;;
+ (define (shareable? x)
+ (cond
+ ((stringbuf? x) #t)
+ ((pair? x)
+ (and (immediate? (car x)) (immediate? (cdr x))))
+ ((vector? x)
+ (let lp ((i 0))
+ (or (= i (vector-length x))
+ (and (immediate? (vector-ref x i))
+ (lp (1+ i))))))
+ (else #f)))
+ (let* ((constants (asm-constants asm))
+ (len (vlist-length constants)))
+ (let lp ((i 0)
+ (ro vlist-null)
+ (rw vlist-null))
+ (if (= i len)
+ (values (link-data asm ro '.rodata)
+ (link-data asm rw '.data)
+ (emit-init-constants asm))
+ (let ((pair (vlist-ref constants i)))
+ (if (shareable? (car pair))
+ (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
+ (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
+
+(define (link-symtab text-section asm)
+ (let* ((endianness (asm-endianness asm))
+ (word-size (asm-word-size asm))
+ (size (elf-symbol-len word-size))
+ (meta (reverse (asm-meta asm)))
+ (n (length meta))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* n size) 0)))
+ (define (intern-string! name)
+ (call-with-values
+ (lambda () (string-table-intern strtab
+ (if name (symbol->string name) "")))
+ (lambda (table idx)
+ (set! strtab table)
+ idx)))
+ (for-each
+ (lambda (meta n)
+ (let ((name (intern-string! (meta-name meta))))
+ (write-elf-symbol bv (* n size) endianness word-size
+ (make-elf-symbol
+ #:name name
+ ;; Symbol value and size are measured in
+ ;; bytes, not u32s.
+ #:value (* 4 (meta-low-pc meta))
+ #:size (* 4 (- (meta-high-pc meta)
+ (meta-low-pc meta)))
+ #:type STT_FUNC
+ #:visibility STV_HIDDEN
+ #:shndx (elf-section-index text-section)))))
+ meta (iota n))
+ (let ((strtab (make-object asm '.strtab
+ (link-string-table strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.symtab
+ bv
+ '() '()
+ #:type SHT_SYMTAB #:flags 0 #:entsize size
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
+;;; The .guile.arities section describes the arities that a function can
+;;; have. It is in two parts: a sorted array of headers describing
+;;; basic arities, and an array of links out to a string table (and in
+;;; the case of keyword arguments, to the data section) for argument
+;;; names. The whole thing is prefixed by a uint32 indicating the
+;;; offset of the end of the headers array.
+;;;
+;;; The arity headers array is a packed array of structures of the form:
+;;;
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+;;;
+;;; All of the offsets and addresses are 32 bits. We can expand in the
+;;; future to use 64-bit offsets if appropriate, but there are other
+;;; aspects of RTL that constrain us to a total image that fits in 32
+;;; bits, so for the moment we'll simplify the problem space.
+;;;
+;;; The following flags values are defined:
+;;;
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;;
+;;; Functions with a single arity specify their number of required and
+;;; optional arguments in nreq and nopt, and do not have the
+;;; is-case-lambda? flag set. Their "offset" member links to an array
+;;; of pointers into the associated .guile.arities.strtab string table,
+;;; identifying the argument names. This offset is relative to the
+;;; start of the .guile.arities section. Links for required arguments
+;;; are first, in order, as uint32 values. Next follow the optionals,
+;;; then the rest link if has-rest? is set, then a link to the "keyword
+;;; indices" literal if has-keyword-args? is set. Unlike the other
+;;; links, the kw-indices link points into the data section, and is
+;;; relative to the ELF image as a whole.
+;;;
+;;; Functions with no arities have no arities information present in the
+;;; .guile.arities section.
+;;;
+;;; Functions with multiple arities are preceded by a header with
+;;; is-case-lambda? set. All other fields are 0, except low-pc and
+;;; high-pc which should be the bounds of the whole function. Headers
+;;; for the individual arities follow. In this way the whole headers
+;;; array is sorted in increasing low-pc order, and case-lambda clauses
+;;; are contained within the [low-pc, high-pc] of the case-lambda
+;;; header.
+
+;; Length of the prefix to the arities section, in bytes.
+(define arities-prefix-len 4)
+
+;; Length of an arity header, in bytes.
+(define arity-header-len (* 6 4))
+
+;; The offset of "offset" within arity header, in bytes.
+(define arity-header-offset-offset (* 2 4))
+
+(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
+ has-keyword-args? is-case-lambda?)
+ (logior (if has-rest? (ash 1 0) 0)
+ (if allow-other-keys? (ash 1 1) 0)
+ (if has-keyword-args? (ash 1 2) 0)
+ (if is-case-lambda? (ash 1 3) 0)))
+
+(define (meta-arities-size meta)
+ (define (lambda-size arity)
+ (+ arity-header-len
+ (* 4 ;; name pointers
+ (+ (length (arity-req arity))
+ (length (arity-opt arity))
+ (if (arity-rest arity) 1 0)
+ (if (pair? (arity-kw-indices arity)) 1 0)))))
+ (define (case-lambda-size arities)
+ (fold +
+ arity-header-len ;; case-lambda header
+ (map lambda-size arities))) ;; the cases
+ (match (meta-arities meta)
+ (() 0)
+ ((arity) (lambda-size arity))
+ (arities (case-lambda-size arities))))
+
+(define (write-arity-headers metas bv endianness)
+ (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
+ (bytevector-u32-set! bv pos low-pc endianness)
+ (bytevector-u32-set! bv (+ pos 4) high-pc endianness)
+ (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
+ (bytevector-u32-set! bv (+ pos 12) flags endianness)
+ (bytevector-u32-set! bv (+ pos 16) nreq endianness)
+ (bytevector-u32-set! bv (+ pos 20) nopt endianness))
+ (define (write-arity-header pos arity)
+ (write-arity-header* pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ (pack-arity-flags (arity-rest arity)
+ (arity-allow-other-keys? arity)
+ (pair? (arity-kw-indices arity))
+ #f)
+ (length (arity-req arity))
+ (length (arity-opt arity))))
+ (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+ (match metas
+ (()
+ ;; Fill in the prefix.
+ (bytevector-u32-set! bv 0 pos endianness)
+ (values pos (reverse offsets)))
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos offsets))
+ ((arity)
+ (write-arity-header pos arity)
+ (lp metas
+ (+ pos arity-header-len)
+ (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (arities
+ ;; Write a case-lambda header, then individual arities.
+ ;; The case-lambda header's offset link is 0.
+ (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
+ (pack-arity-flags #f #f #f #t) 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (offsets offsets))
+ (match arities
+ (() (lp metas pos offsets))
+ ((arity . arities)
+ (write-arity-header pos arity)
+ (lp* arities
+ (+ pos arity-header-len)
+ (acons arity
+ (+ pos arity-header-offset-offset)
+ offsets)))))))))))
+
+(define (write-arity-links asm bv pos arity-offset-pairs intern-string!)
+ (define (write-symbol sym pos)
+ (bytevector-u32-set! bv pos (intern-string! sym) (asm-endianness asm))
+ (+ pos 4))
+ (define (write-kw-indices pos kw-indices)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (make-linker-reloc 'abs32/1 pos 0
+ (intern-constant asm kw-indices)))
+ (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
+ (match pairs
+ (()
+ (unless (= pos (bytevector-length bv))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length bv)))
+ relocs)
+ (((arity . offset) . pairs)
+ (bytevector-u32-set! bv offset pos (asm-endianness asm))
+ (let ((pos (fold write-symbol
+ pos
+ (append (arity-req arity)
+ (arity-opt arity)
+ (cond
+ ((arity-rest arity) => list)
+ (else '()))))))
+ (match (arity-kw-indices arity)
+ (() (lp pos pairs relocs))
+ (kw-indices
+ (lp (+ pos 4)
+ pairs
+ (cons (write-kw-indices pos kw-indices) relocs)))))))))
+
+(define (link-arities asm)
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (size (fold (lambda (meta size)
+ (+ size (meta-arities-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (bv (make-bytevector size 0)))
+ (define (intern-string! name)
+ (call-with-values
+ (lambda () (string-table-intern strtab (symbol->string name)))
+ (lambda (table idx)
+ (set! strtab table)
+ idx)))
+ (let ((kw-indices-relocs
+ (call-with-values
+ (lambda ()
+ (write-arity-headers metas bv endianness))
+ (lambda (pos arity-offset-pairs)
+ (write-arity-links asm bv pos arity-offset-pairs
+ intern-string!)))))
+ (let ((strtab (make-object asm '.guile.arities.strtab
+ (link-string-table strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.arities
+ bv
+ kw-indices-relocs '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab)))))
+
+;;;
+;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
+;;; values. Pc and str are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; str is an index into the associated .guile.docstrs.strtab string
+;;; table section.
+;;;
+
+;; The size of a docstrs entry, in bytes.
+(define docstr-size 8)
+
+(define (link-docstrs asm)
+ (define (find-docstrings)
+ (filter-map (lambda (meta)
+ (define (is-documentation? pair)
+ (eq? (car pair) 'documentation))
+ (let* ((props (meta-properties meta))
+ (tail (find-tail is-documentation? props)))
+ (and tail
+ (not (find-tail is-documentation? (cdr tail)))
+ (string? (cdar tail))
+ (cons (meta-low-pc meta) (cdar tail)))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (docstrings (find-docstrings))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* (length docstrings) docstr-size) 0)))
+ (define (intern-string! name)
+ (call-with-values
+ (lambda () (string-table-intern strtab name))
+ (lambda (table idx)
+ (set! strtab table)
+ idx)))
+ (fold (lambda (pair pos)
+ (match pair
+ ((pc . string)
+ (bytevector-u32-set! bv pos pc endianness)
+ (bytevector-u32-set! bv (+ pos 4) (intern-string! string)
+ endianness)
+ (+ pos docstr-size))))
+ 0
+ docstrings)
+ (let ((strtab (make-object asm '.guile.docstrs.strtab
+ (link-string-table strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.docstrs
+ bv
+ '() '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values. Pc and addr are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first. (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+ (define (assoc-remove-one alist key value-pred)
+ (match alist
+ (() '())
+ ((((? (lambda (x) (eq? x key))) . value) . alist)
+ (if (value-pred value)
+ alist
+ (acons key value alist)))
+ (((k . v) . alist)
+ (acons k v (assoc-remove-one alist key value-pred)))))
+ (define (props-without-name-or-docstring meta)
+ (assoc-remove-one
+ (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+ 'documentation
+ string?))
+ (define (find-procprops)
+ (filter-map (lambda (meta)
+ (let ((props (props-without-name-or-docstring meta)))
+ (and (pair? props)
+ (cons (meta-low-pc meta) props))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (procprops (find-procprops))
+ (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+ (let lp ((procprops procprops) (pos 0) (relocs '()))
+ (match procprops
+ (()
+ (make-object asm '.guile.procprops
+ bv
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (((pc . props) . procprops)
+ (bytevector-u32-set! bv pos pc endianness)
+ (lp procprops
+ (+ pos procprops-size)
+ (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+ (intern-constant asm props))
+ relocs)))))))
+
+(define (link-objects asm)
+ (let*-values (;; Link procprops before constants, because it probably
+ ;; interns more constants.
+ ((procprops) (link-procprops asm))
+ ((ro rw rw-init) (link-constants asm))
+ ;; Link text object after constants, so that the
+ ;; constants initializer gets included.
+ ((text) (link-text-object asm))
+ ((dt) (link-dynamic-section asm text ro rw rw-init))
+ ((symtab strtab) (link-symtab (linker-object-section text)
asm))
+ ((arities arities-strtab) (link-arities asm))
+ ((docstrs docstrs-strtab) (link-docstrs asm))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ ((shstrtab) (link-shstrtab asm)))
+ (filter identity
+ (list text ro rw dt symtab strtab arities arities-strtab
+ docstrs docstrs-strtab procprops shstrtab))))
+
+(define (link-assembly asm)
+ (link-elf (link-objects asm)))
+
+(define (assemble-program instructions)
+ (let ((asm (make-assembler)))
+ (emit-text asm instructions)
+ (load-thunk-from-memory
+ (link-elf (link-objects asm) #:page-aligned? #f))))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
new file mode 100644
index 0000000..0e38810
--- /dev/null
+++ b/module/system/vm/debug.scm
@@ -0,0 +1,386 @@
+;;; Guile RTL disassembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software 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 debug)
+ #:use-module (system vm elf)
+ #:use-module (system vm objcode)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:export (<debug-context>
+ debug-context-image
+ find-debug-context
+ u32-offset->addr
+
+ <program-debug-info>
+ program-debug-info-name
+ program-debug-info-context
+ program-debug-info-image
+ program-debug-info-offset
+ program-debug-info-addr
+ program-debug-info-u32-offset
+ program-debug-info-u32-offset-end
+ find-program-debug-info
+
+ arity?
+ arity-low-pc
+ arity-high-pc
+ arity-nreq
+ arity-nopt
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-is-case-lambda?
+ arity-arguments-alist
+ find-program-arities
+ program-minimum-arity
+
+ find-program-docstring
+
+ find-program-properties))
+
+(define-record-type <debug-context>
+ (make-debug-context elf base text-base)
+ debug-context?
+ (elf debug-context-elf)
+ (base debug-context-base)
+ (text-base debug-context-text-base))
+
+(define (debug-context-image context)
+ (elf-bytes (debug-context-elf context)))
+
+(define (u32-offset->addr offset context)
+ (+ (debug-context-base context) (* offset 4)))
+
+(define-record-type <program-debug-info>
+ (make-program-debug-info context name offset size)
+ program-debug-info?
+ (context program-debug-info-context)
+ (name program-debug-info-name)
+ (offset program-debug-info-offset)
+ (size program-debug-info-size))
+
+(define (program-debug-info-addr pdi)
+ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi))
+ (debug-context-base (program-debug-info-context pdi))))
+
+(define (program-debug-info-image pdi)
+ (debug-context-image (program-debug-info-context pdi)))
+
+(define (program-debug-info-u32-offset pdi)
+ ;; OFFSET is in bytes from the beginning of the text section. TEXT-BASE
+ ;; is in bytes from the beginning of the image. Return OFFSET as a u32
+ ;; index from the start of the image.
+ (/ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (program-debug-info-u32-offset-end pdi)
+ ;; Return the end position as a u32 index from the start of the image.
+ (/ (+ (program-debug-info-size pdi)
+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (find-debug-context addr)
+ (let* ((bv (find-mapped-elf-image addr))
+ (elf (parse-elf bv))
+ (base (pointer-address (bytevector->pointer (elf-bytes elf))))
+ (text-base (elf-section-offset
+ (or (elf-section-by-name elf ".rtl-text")
+ (error "ELF object has no text section")))))
+ (make-debug-context elf base text-base)))
+
+(define (find-elf-symbol elf text-offset)
+ (and=>
+ (elf-section-by-name elf ".symtab")
+ (lambda (symtab)
+ (let ((len (elf-symbol-table-len symtab))
+ (strtab (elf-section elf (elf-section-link symtab))))
+ ;; The symbols should be sorted, but maybe somehow that fails
+ ;; (for example if multiple objects are relinked together). So,
+ ;; a modicum of tolerance.
+ (define (bisect)
+ ;; FIXME: Implement.
+ #f)
+ (define (linear-search)
+ (let lp ((n 0))
+ (and (< n len)
+ (let ((sym (elf-symbol-table-ref elf symtab n strtab)))
+ (if (and (<= (elf-symbol-value sym) text-offset)
+ (< text-offset (+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ sym
+ (lp (1+ n)))))))
+ (or (bisect) (linear-search))))))
+
+(define* (find-program-debug-info addr #:optional
+ (context (find-debug-context addr)))
+ (cond
+ ((find-elf-symbol (debug-context-elf context)
+ (- addr
+ (debug-context-base context)
+ (debug-context-text-base context)))
+ => (lambda (sym)
+ (make-program-debug-info context
+ (and=> (elf-symbol-name sym)
+ ;; The name might be #f if
+ ;; the string table was
+ ;; stripped somehow.
+ (lambda (x)
+ (and (string? x)
+ (not (string-null? x))
+ (string->symbol x))))
+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ (else #f)))
+
+(define-record-type <arity>
+ (make-arity context base header-offset)
+ arity?
+ (context arity-context)
+ (base arity-base)
+ (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+
+(define (arity-low-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+
+(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
+
+(define (arity-nreq arity)
+ (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+ (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-flags arity)
+ (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags
arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags
arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+ (let ((elf (debug-context-elf (arity-context arity))))
+ (cond
+ ((elf-section-by-name elf ".guile.arities")
+ =>
+ (lambda (sec)
+ (let* ((strtab (elf-section elf (elf-section-link sec)))
+ (bv (elf-bytes elf))
+ (strtab-offset (elf-section-offset strtab)))
+ (lambda (n)
+ (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+ (else (error "couldn't find arities section")))))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (%load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header)))
+ (define (load-symbol idx)
+ (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (define (load-symbols skip n)
+ (let lp ((n n) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n)
+ (cons (load-symbol (+ skip (1- n))) out)))))
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (define (load-non-immediate idx)
+ (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+ (and (not (is-case-lambda? flags))
+ `((required . ,(load-symbols 0 nreq))
+ (optional . ,(load-symbols nreq nopt))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
+ (keyword . ,(if (has-keyword-args? flags)
+ (load-non-immediate
+ (+ nreq nopt (if (has-rest? flags) 1 0)))
+ '()))
+ (allow-other-keys? . ,(allow-other-keys? flags))))))
+
+(define (find-first-arity context base addr)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context)))
+ (headers-start (+ base arities-prefix-len))
+ (headers-end (+ base (bytevector-u32-native-ref bv base))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos headers-start))
+ (cond
+ ((>= pos headers-end) #f)
+ ((< text-offset (arity-low-pc* bv pos))
+ (lp (+ pos arity-header-len)))
+ ((< (arity-high-pc* bv pos) text-offset)
+ #f)
+ (else
+ (make-arity context base pos))))))
+
+(define (read-sub-arities context base outer-header-offset)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (headers-end (+ base (bytevector-u32-native-ref bv base)))
+ (low-pc (arity-low-pc* bv outer-header-offset))
+ (high-pc (arity-high-pc* bv outer-header-offset)))
+ (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+ (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+ (lp (+ pos arity-header-len)
+ (cons (make-arity context base pos) out))
+ (reverse out)))))
+
+(define* (find-program-arities addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ ;; FIXME: Handle case-lambda arities.
+ (cond
+ ((not first) '())
+ ((arity-is-case-lambda? first)
+ (read-sub-arities context base (arity-header-offset first)))
+ (else (list first)))))))
+
+(define* (program-minimum-arity addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (if (arity-is-case-lambda? first)
+ (list 0 0 #t) ;; FIXME: be more precise.
+ (list (arity-nreq first)
+ (arity-nopt first)
+ (arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs")
+ (lambda (sec)
+ ;; struct docstr {
+ ;; uint32_t pc;
+ ;; uint32_t str;
+ ;; }
+ (define docstr-len 8)
+ (let* ((start (elf-section-offset sec))
+ (end (+ start (elf-section-size sec)))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) #f)
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos docstr-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ #f)
+ (else
+ (let ((strtab (elf-section (debug-context-elf context)
+ (elf-section-link sec)))
+ (idx (bytevector-u32-native-ref bv (+ pos 4))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
+
+(define* (find-program-properties addr #:optional
+ (context (find-debug-context addr)))
+ (define (add-name-and-docstring props)
+ (define (maybe-acons k v tail)
+ (if v (acons k v tail) tail))
+ (let ((name (and=> (find-program-debug-info addr context)
+ program-debug-info-name))
+ (docstring (find-program-docstring addr context)))
+ (maybe-acons 'name name
+ (maybe-acons 'documentation docstring props))))
+ (add-name-and-docstring
+ (cond
+ ((elf-section-by-name (debug-context-elf context) ".guile.procprops")
+ => (lambda (sec)
+ ;; struct procprop {
+ ;; uint32_t pc;
+ ;; uint32_t offset;
+ ;; }
+ (define procprop-len 8)
+ (let* ((start (elf-section-offset sec))
+ (end (+ start (elf-section-size sec)))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (define (unpack-scm addr)
+ (pointer->scm (make-pointer addr)))
+ (define (load-non-immediate offset)
+ (unpack-scm (+ (debug-context-base context) offset)))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) '())
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos procprop-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ '())
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4))))))))))))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
new file mode 100644
index 0000000..123026c
--- /dev/null
+++ b/module/system/vm/disassembler.scm
@@ -0,0 +1,341 @@
+;;; Guile RTL disassembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software 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 disassembler)
+ #:use-module (system vm instruction)
+ #:use-module (system vm debug)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:export (disassemble-program))
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (rtl-instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(eval-when (expand compile load eval)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
+
+(define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+
+(define (unpack-s24 s)
+ (if (zero? (logand s (ash 1 23)))
+ s
+ (- s (ash 1 24))))
+
+(define (unpack-s32 s)
+ (if (zero? (logand s (ash 1 31)))
+ s
+ (- s (ash 1 32))))
+
+(define-syntax disassembler
+ (lambda (x)
+ (define (parse-first-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'())
+ ((U8_U24)
+ #'((ash word -8)))
+ ((U8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((U8_R24)
+ #'(#:rest (ash word -8)))
+ ((U8_U8_I16)
+ #'((logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ (else
+ (error "bad kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'((logand word #ff)))
+ ((U8_U24)
+ #'((logand word #xff)
+ (ash word -8)))
+ ((U8_L24)
+ #'((logand word #xff)
+ (unpack-s24 (ash word -8))))
+ ((U8_R24)
+ #'((logand word #xff)
+ #:rest (ash word -8)))
+ ((U8_U8_I16)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand word #xff)
+ (logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ ((U32)
+ #'(word))
+ ((I32)
+ #'(word))
+ ((A32)
+ #'(word))
+ ((B32)
+ #'(word))
+ ((N32)
+ #'((unpack-s32 word)))
+ ((S32)
+ #'((unpack-s32 word)))
+ ((L32)
+ #'((unpack-s32 word)))
+ ((LO32)
+ #'((unpack-s32 word)))
+ ((X8_U24)
+ #'((ash word -8)))
+ ((X8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((X8_R24)
+ #'(#:rest (ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
+ (unpack-s24 (ash word -8))))
+ ((B1_U7_L24)
+ #'((not (zero? (logand word #x1)))
+ (logand (ash word -1) #x7f)
+ (unpack-s24 (ash word -8))))
+ (else
+ (error "bad kind" type)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (let ((vars (generate-temporaries #'(word* ...))))
+ (with-syntax (((word* ...) vars)
+ ((n ...) (map 1+ (iota (length #'(word* ...)))))
+ ((asm ...)
+ (parse-first-word #'first (syntax->datum #'word0)))
+ (((asm* ...) ...)
+ (map (lambda (word type)
+ (parse-tail-word word type))
+ vars
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (buf offset first)
+ (let ((word* (u32-ref buf (+ offset n)))
+ ...)
+ (values (+ 1 (length '(word* ...)))
+ (list 'name asm ... asm* ... ...))))))))))
+
+(define (disasm-invalid buf offset first)
+ (error "bad instruction" (logand first #xff) first buf offset))
+
+(define disassemblers (make-vector 256 disasm-invalid))
+
+(define-syntax define-disassembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode arg ...)
+ (with-syntax ((parse (id-append #'name #'parse- #'name)))
+ #'(let ((parse (disassembler name opcode arg ...)))
+ (vector-set! disassemblers opcode parse)))))))
+
+(visit-opcodes define-disassembler)
+
+;; -> len list
+(define (disassemble-one buf offset)
+ (let ((first (u32-ref buf offset)))
+ (call-with-values
+ (lambda ()
+ ((vector-ref disassemblers (logand first #xff)) buf offset first))
+ (lambda (len list)
+ (match list
+ ((head ... #:rest rest)
+ (let lp ((n 0) (rhead (reverse head)))
+ (if (= n rest)
+ (values (+ len n) (reverse rhead))
+ (lp (1+ n)
+ (cons (u32-ref buf (+ offset len n)) rhead)))))
+ (_ (values len list)))))))
+
+(define (code-annotation code len offset start labels context)
+ ;; FIXME: Print names for register loads and stores that correspond to
+ ;; access to named locals.
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+
+ (match code
+ (((or 'br
+ 'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
+ 'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
+ 'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
+ 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
+ (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('prompt tag flags handler)
+ ;; The H is for handler.
+ (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
+ (((or 'make-short-immediate 'make-long-immediate) _ imm)
+ (list "~S" (unpack-scm imm)))
+ (('make-long-long-immediate _ high low)
+ (list "~S" (unpack-scm (logior (ash high 32) low))))
+ (('assert-nargs-ee/locals nargs locals)
+ (list "~a arg~:p, ~a local~:p" nargs locals))
+ (('tail-call nargs proc)
+ (list "~a arg~:p" nargs))
+ (('make-closure dst target free ...)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info #:addr addr #:context context)))
+ ;; FIXME: Disassemble embedded closures as well.
+ (list "~A at 0x~X"
+ (or (and pdi (program-debug-info-name pdi))
+ "(anonymous procedure)")
+ addr)))
+ (('make-non-immediate dst target)
+ (list "address@hidden" (reference-scm target)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "address@hidden" (dereference-scm target)))
+ (('link-procedure! src target)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info #:addr addr #:context context)))
+ (list "~A at 0x~X"
+ (or (and pdi (program-debug-info-name pdi))
+ "(anonymous procedure)")
+ addr)))
+ (('resolve-module dst name public)
+ (list "~a" (if (zero? public) "private" "public")))
+ (((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset)
+ (list "`~A'" (dereference-scm sym-offset)))
+ (((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ (list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name)
+ (dereference-scm sym-offset))))
+ (('load-typed-array dst type shape target len)
+ (let ((addr (u32-offset->addr (+ offset target) context)))
+ (list "~a bytes from #x~X" len addr)))
+ (_ #f)))
+
+(define (compute-labels bv start end)
+ (let ((labels (make-vector (- end start) #f)))
+ (define (add-label! pos header)
+ (unless (vector-ref labels (- pos start))
+ (vector-set! labels (- pos start) header)))
+
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (match elt
+ ((inst arg ...)
+ (case inst
+ ((br
+ br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
+ br-if-true br-if-null br-if-nil br-if-pair br-if-struct
+ br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
+ br-if-= br-if-< br-if-<= br-if-> br-if->=)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "L"))))
+ ((prompt)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "H"))))
+ ((call call/values)
+ (let* ((MVRA (+ offset len))
+ (RA (+ MVRA 1)))
+ (add-label! MVRA "MVRA")
+ (add-label! RA "RA"))))))
+ (lp (+ offset len))))))
+ (let lp ((offset start) (n 1))
+ (when (< offset end)
+ (let* ((pos (- offset start))
+ (label (vector-ref labels pos)))
+ (if label
+ (begin
+ (vector-set! labels
+ pos
+ (string->symbol
+ (string-append label (number->string n))))
+ (lp (1+ offset) (1+ n)))
+ (lp (1+ offset) n)))))
+ labels))
+
+(define (print-info port addr label info extra src)
+ (when label
+ (format port "~A:\n" label))
+ (format port "address@hidden address@hidden;; address@hidden@[~61t at
~a~]\n"
+ addr info extra src))
+
+(define (disassemble-buffer port bv start end context)
+ (let ((labels (compute-labels bv start end)))
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (let ((pos (- offset start))
+ (annotation (code-annotation elt len offset start labels
+ context)))
+ (print-info port pos (vector-ref labels pos) elt annotation #f)
+ (lp (+ offset len)))))))))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (cond
+ ((find-program-debug-info #:program program)
+ => (lambda (pdi)
+ (format port "Disassembly of ~S at #x~X:\n\n" program
+ (program-debug-info-addr pdi))
+ (disassemble-buffer port
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values))
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
index 9e5a0db..0d09287 100644
--- a/module/system/vm/dwarf.scm
+++ b/module/system/vm/dwarf.scm
@@ -1,6 +1,6 @@
;;; Guile DWARF reader and writer
-;; Copyright (C) 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
;; Parts of this file were derived from sysdeps/generic/dwarf2.h, from
;; the GNU C Library. That file is available under the LGPL version 2
@@ -25,6 +25,48 @@
;;;; 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:
+;;
+;; DWARF is a flexible format for describing compiled programs. It is
+;; used by Guile to record source positions, describe local variables,
+;; function arities, and other function metadata.
+;;
+;; Structurally, DWARF describes a tree of data. Each node in the tree
+;; is a debugging information entry ("DIE"). Each DIE has a "tag",
+;; possible a set of attributes, and possibly some child DIE nodes.
+;; That's basically it!
+;;
+;; The DIE nodes are contained in the .debug_info section of an ELF
+;; file. Attributes within the DIE nodes link them to mapped ranges of
+;; the ELF file (.rtl_text, .data, etc.).
+;;
+;; A .debug_info section logically contains a series of debugging
+;; "contributions", one for each compilation unit. Each contribution is
+;; prefixed by a header and contains a single DIE element whose tag is
+;; "compilation-unit". That node usually contains child nodes, for
+;; example of type "subprogram".
+;;
+;; Since usually one will end up producing many DIE nodes with the same
+;; tag and attribute types, DIE nodes are defined by referencing a known
+;; shape, and then filling in the values. The shapes are defined in the
+;; form of "abbrev" entries, which specify a specific combination of a
+;; tag and an ordered set of attributes, with corresponding attribute
+;; representations ("forms"). Abbrevs are written out to a separate
+;; section, .debug_abbrev. Abbrev nodes also specify whether the
+;; corresponding DIE node has children or not. When a DIE is written
+;; into the .debug_info section, it references one of the abbrevs in
+;; .debug_abbrev. You need the abbrev in order to parse the DIE.
+;;
+;; For completeness, the other sections that DWARF uses are .debug_str,
+;; .debug_loc, .debug_pubnames, .debug_aranges, .debug_frame, and
+;; .debug_line. These are described in section 6 of the DWARF 3.0
+;; specification, at http://dwarfstd.org/.
+;;
+;; This DWARF module is currently capable of parsing all of DWARF 2.0
+;; and parts of DWARF 3.0. For Guile's purposes, we also use DWARF as
+;; the format for our own debugging information. The DWARF generator is
+;; fairly minimal, and is not intended to be complete.
+;;
;;; Code:
(define-module (system vm dwarf)
@@ -650,6 +692,10 @@
(aranges-start meta-aranges-start)
(aranges-end meta-aranges-end))
+;; A context represents a namespace. The root context is the
+;; compilation unit. DIE nodes of type class-type, structure-type, or
+;; namespace may form child contexts.
+;;
(define-record-type <dwarf-context>
(make-dwarf-context bv word-size endianness meta
abbrevs
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 040b274..5167459 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -1,6 +1,6 @@
;;; Guile ELF reader and writer
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013 Free Software 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,6 +16,19 @@
;;;; 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 module to read and write Executable and Linking Format (ELF)
+;;; files.
+;;;
+;;; This module exports a number of record types that represent the
+;;; various parts that make up ELF files. Fundamentally this is the
+;;; main header, the segment headers (program headers), and the section
+;;; headers. It also exports bindings for symbolic constants and
+;;; utilities to parse and write special kinds of ELF sections.
+;;;
+;;; See elf(5) for more information on ELF.
+;;;
;;; Code:
(define-module (system vm elf)
@@ -27,30 +40,53 @@
#:use-module (ice-9 vlist)
#:export (has-elf-header?
- make-elf elf?
+ (make-elf* . make-elf)
+ elf?
elf-bytes elf-word-size elf-byte-order
elf-abi elf-type elf-machine-type
elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx
+ elf-header-len elf-header-shoff-offset
+ write-elf-header
+
(make-elf-segment* . make-elf-segment)
elf-segment?
+ elf-segment-index
elf-segment-type elf-segment-offset elf-segment-vaddr
elf-segment-paddr elf-segment-filesz elf-segment-memsz
elf-segment-flags elf-segment-align
+ elf-program-header-len write-elf-program-header
+
+ PT_NULL PT_LOAD PT_DYNAMIC PT_INTERP PT_NOTE PT_SHLIB
+ PT_PHDR PT_TLS PT_NUM PT_LOOS PT_GNU_EH_FRAME PT_GNU_STACK
+ PT_GNU_RELRO
+
+ PF_R PF_W PF_X
+
(make-elf-section* . make-elf-section)
elf-section?
+ elf-section-index
elf-section-name elf-section-type elf-section-flags
elf-section-addr elf-section-offset elf-section-size
elf-section-link elf-section-info elf-section-addralign
elf-section-entsize
- make-elf-symbol elf-symbol?
+ elf-section-header-len elf-section-header-addr-offset
+ elf-section-header-offset-offset
+ write-elf-section-header
+
+ (make-elf-symbol* . make-elf-symbol)
+ elf-symbol?
elf-symbol-name elf-symbol-value elf-symbol-size
elf-symbol-info elf-symbol-other elf-symbol-shndx
elf-symbol-binding elf-symbol-type elf-symbol-visibility
+ elf-symbol-len write-elf-symbol
+
+ SHN_UNDEF
+
SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB
SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY
@@ -72,6 +108,8 @@
DT_GUILE_RTL_VERSION DT_HIGUILE DT_LOOS DT_HIOS DT_LOPROC
DT_HIPROC
+ string-table-ref
+
STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU
STB_HIOS STB_LOPROC STB_HIPROC
@@ -85,27 +123,11 @@
parse-elf
elf-segment elf-segments
- elf-section elf-sections elf-sections-by-name
- elf-symbol-table-ref
+ elf-section elf-sections elf-section-by-name elf-sections-by-name
+ elf-symbol-table-len elf-symbol-table-ref
parse-elf-note
- elf-note-name elf-note-desc elf-note-type
-
- (make-string-table . make-elf-string-table)
- (string-table-intern . elf-string-table-intern)
- (link-string-table . link-elf-string-table)
-
- (make-reloc . make-elf-reloc)
- (make-symbol . make-elf-symbol)
-
- (make-object . make-elf-object)
- (object? . elf-object?)
- (object-section . elf-object-section)
- (object-bv . elf-object-bv)
- (object-relocs . elf-object-relocs)
- (object-symbols . elf-object-symbols)
-
- link-elf))
+ elf-note-name elf-note-desc elf-note-type))
;; #define EI_NIDENT 16
@@ -133,6 +155,11 @@
((4) elf32-header-len)
((8) elf64-header-len)
(else (error "invalid word size" word-size))))
+(define (elf-header-shoff-offset word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 40)
+ (else (error "bad word size" word-size))))
(define ELFCLASS32 1) ; 32-bit objects
(define ELFCLASS64 2) ; 64-bit objects
@@ -242,6 +269,26 @@
(shnum elf-shnum)
(shstrndx elf-shstrndx))
+(define* (make-elf* #:key (bytes #f)
+ (byte-order (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE)
+ (entry 0)
+ (phoff (elf-header-len word-size))
+ (shoff -1)
+ (flags 0)
+ (ehsize (elf-header-len word-size))
+ (phentsize (elf-program-header-len word-size))
+ (phnum 0)
+ (shentsize (elf-section-header-len word-size))
+ (shnum 0)
+ (shstrndx SHN_UNDEF))
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx))
+
(define (parse-elf32 bv byte-order)
(make-elf bv 4 byte-order
(bytevector-u8-ref bv 7)
@@ -276,28 +323,27 @@
(bytevector-u8-set! bv 14 0)
(bytevector-u8-set! bv 15 0))
-(define (write-elf32 bv byte-order abi type machine-type
- entry phoff shoff flags ehsize phentsize phnum
- shentsize shnum shstrndx)
- (write-elf-ident bv ELFCLASS32
- (case byte-order
- ((little) ELFDATA2LSB)
- ((big) ELFDATA2MSB)
- (else (error "unknown endianness" byte-order)))
- abi)
- (bytevector-u16-set! bv 16 type byte-order)
- (bytevector-u16-set! bv 18 machine-type byte-order)
- (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
- (bytevector-u32-set! bv 24 entry byte-order)
- (bytevector-u32-set! bv 28 phoff byte-order)
- (bytevector-u32-set! bv 32 shoff byte-order)
- (bytevector-u32-set! bv 36 flags byte-order)
- (bytevector-u16-set! bv 40 ehsize byte-order)
- (bytevector-u16-set! bv 42 phentsize byte-order)
- (bytevector-u16-set! bv 44 phnum byte-order)
- (bytevector-u16-set! bv 46 shentsize byte-order)
- (bytevector-u16-set! bv 48 shnum byte-order)
- (bytevector-u16-set! bv 50 shstrndx byte-order))
+(define (write-elf32-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS32
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
+ (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))
(define (parse-elf64 bv byte-order)
(make-elf bv 8 byte-order
@@ -315,28 +361,27 @@
(bytevector-u16-ref bv 60 byte-order)
(bytevector-u16-ref bv 62 byte-order)))
-(define (write-elf64 bv byte-order abi type machine-type
- entry phoff shoff flags ehsize phentsize phnum
- shentsize shnum shstrndx)
- (write-elf-ident bv ELFCLASS64
- (case byte-order
- ((little) ELFDATA2LSB)
- ((big) ELFDATA2MSB)
- (else (error "unknown endianness" byte-order)))
- abi)
- (bytevector-u16-set! bv 16 type byte-order)
- (bytevector-u16-set! bv 18 machine-type byte-order)
- (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
- (bytevector-u64-set! bv 24 entry byte-order)
- (bytevector-u64-set! bv 32 phoff byte-order)
- (bytevector-u64-set! bv 40 shoff byte-order)
- (bytevector-u32-set! bv 48 flags byte-order)
- (bytevector-u16-set! bv 52 ehsize byte-order)
- (bytevector-u16-set! bv 54 phentsize byte-order)
- (bytevector-u16-set! bv 56 phnum byte-order)
- (bytevector-u16-set! bv 58 shentsize byte-order)
- (bytevector-u16-set! bv 60 shnum byte-order)
- (bytevector-u16-set! bv 62 shstrndx byte-order))
+(define (write-elf64-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS64
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
+ (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))
(define (parse-elf bv)
(cond
@@ -354,28 +399,12 @@
(else
(error "Invalid ELF" bv))))
-(define* (write-elf-header bv #:key
- (byte-order (target-endianness))
- (word-size (target-word-size))
- (abi ELFOSABI_STANDALONE)
- (type ET_DYN)
- (machine-type EM_NONE)
- (entry 0)
- (phoff (elf-header-len word-size))
- (shoff -1)
- (flags 0)
- (ehsize (elf-header-len word-size))
- (phentsize (elf-program-header-len word-size))
- (phnum 0)
- (shentsize (elf-section-header-len word-size))
- (shnum 0)
- (shstrndx SHN_UNDEF))
- ((case word-size
- ((4) write-elf32)
- ((8) write-elf64)
- (else (error "unknown word size" word-size)))
- bv byte-order abi type machine-type entry phoff shoff
- flags ehsize phentsize phnum shentsize shnum shstrndx))
+(define* (write-elf-header bv elf)
+ ((case (elf-word-size elf)
+ ((4) write-elf32-header)
+ ((8) write-elf64-header)
+ (else (error "unknown word size" (elf-word-size elf))))
+ bv elf))
;;
;; Segment types
@@ -402,8 +431,9 @@
(define PF_R (ash 1 2)) ; Segment is readable
(define-record-type <elf-segment>
- (make-elf-segment type offset vaddr paddr filesz memsz flags align)
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align)
elf-segment?
+ (index elf-segment-index)
(type elf-segment-type)
(offset elf-segment-offset)
(vaddr elf-segment-vaddr)
@@ -413,11 +443,11 @@
(flags elf-segment-flags)
(align elf-segment-align))
-(define* (make-elf-segment* #:key (type PT_LOAD) (offset 0) (vaddr 0)
+(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr
0)
(paddr 0) (filesz 0) (memsz filesz)
(flags (logior PF_W PF_R))
(align 8))
- (make-elf-segment type offset vaddr paddr filesz memsz flags align))
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align))
;; typedef struct {
;; uint32_t p_type;
@@ -430,9 +460,10 @@
;; uint32_t p_align;
;; } Elf32_Phdr;
-(define (parse-elf32-program-header bv offset byte-order)
+(define (parse-elf32-program-header index bv offset byte-order)
(if (<= (+ offset 32) (bytevector-length bv))
- (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u32-ref bv (+ offset 8) byte-order)
(bytevector-u32-ref bv (+ offset 12) byte-order)
@@ -466,9 +497,10 @@
;; NB: position of `flags' is different!
-(define (parse-elf64-program-header bv offset byte-order)
+(define (parse-elf64-program-header index bv offset byte-order)
(if (<= (+ offset 56) (bytevector-length bv))
- (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u64-ref bv (+ offset 8) byte-order)
(bytevector-u64-ref bv (+ offset 16) byte-order)
(bytevector-u64-ref bv (+ offset 24) byte-order)
@@ -519,8 +551,10 @@
(lp (1- n) (cons (elf-segment elf (1- n)) out)))))
(define-record-type <elf-section>
- (make-elf-section name type flags addr offset size link info addralign
entsize)
+ (make-elf-section index name type flags
+ addr offset size link info addralign entsize)
elf-section?
+ (index elf-section-index)
(name elf-section-name)
(type elf-section-type)
(flags elf-section-flags)
@@ -532,10 +566,10 @@
(addralign elf-section-addralign)
(entsize elf-section-entsize))
-(define* (make-elf-section* #:key (name 0) (type SHT_PROGBITS)
+(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type
SHT_PROGBITS)
(flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
(link 0) (info 0) (addralign 8) (entsize 0))
- (make-elf-section name type flags addr offset size link info addralign
+ (make-elf-section index name type flags addr offset size link info addralign
entsize))
;; typedef struct {
@@ -551,9 +585,10 @@
;; uint32_t sh_entsize;
;; } Elf32_Shdr;
-(define (parse-elf32-section-header bv offset byte-order)
+(define (parse-elf32-section-header index bv offset byte-order)
(if (<= (+ offset 40) (bytevector-length bv))
- (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u32-ref bv (+ offset 8) byte-order)
(bytevector-u32-ref bv (+ offset 12) byte-order)
@@ -597,9 +632,22 @@
((8) 64)
(else (error "bad word size" word-size))))
-(define (parse-elf64-section-header bv offset byte-order)
+(define (elf-section-header-addr-offset word-size)
+ (case word-size
+ ((4) 12)
+ ((8) 16)
+ (else (error "bad word size" word-size))))
+
+(define (elf-section-header-offset-offset word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf64-section-header index bv offset byte-order)
(if (<= (+ offset 64) (bytevector-length bv))
- (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u64-ref bv (+ offset 8) byte-order)
(bytevector-u64-ref bv (+ offset 16) byte-order)
@@ -630,6 +678,7 @@
((4) parse-elf32-section-header)
((8) parse-elf64-section-header)
(else (error "unhandled pointer size")))
+ n
(elf-bytes elf)
(+ (elf-shoff elf) (* n (elf-shentsize elf)))
(elf-byte-order elf)))
@@ -747,6 +796,17 @@
(utf8->string out))
(lp (1+ end)))))
+(define (elf-section-by-name elf name)
+ (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf)))))
+ (let lp ((n (elf-shnum elf)))
+ (and (> n 0)
+ (let ((section (elf-section elf (1- n))))
+ (if (equal? (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ name)
+ section
+ (lp (1- n))))))))
+
(define (elf-sections-by-name elf)
(let* ((sections (elf-sections elf))
(off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
@@ -766,6 +826,13 @@
(other elf-symbol-other)
(shndx elf-symbol-shndx))
+(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
+ (binding STB_LOCAL) (type STT_NOTYPE)
+ (info (logior (ash binding 4) type))
+ (visibility STV_DEFAULT) (other visibility)
+ (shndx SHN_UNDEF))
+ (make-elf-symbol name value size info other shndx))
+
;; typedef struct {
;; uint32_t st_name;
;; Elf32_Addr st_value;
@@ -775,6 +842,12 @@
;; uint16_t st_shndx;
;; } Elf32_Sym;
+(define (elf-symbol-len word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
(define (parse-elf32-symbol bv offset stroff byte-order)
(if (<= (+ offset 16) (bytevector-length bv))
(make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
@@ -788,6 +861,14 @@
(bytevector-u16-ref bv (+ offset 14) byte-order))
(error "corrupt ELF (offset out of range)" offset)))
+(define (write-elf32-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))
+
;; typedef struct {
;; uint32_t st_name;
;; unsigned char st_info;
@@ -810,6 +891,28 @@
(bytevector-u16-ref bv (+ offset 6) byte-order))
(error "corrupt ELF (offset out of range)" offset)))
+(define (write-elf64-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))
+
+(define (write-elf-symbol bv offset byte-order word-size sym)
+ ((case word-size
+ ((4) write-elf32-symbol)
+ ((8) write-elf64-symbol)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order sym))
+
+(define (elf-symbol-table-len section)
+ (let ((len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (and (not (zero? entsize)) (zero? (modulo len entsize)))
+ (error "bad symbol table" section))
+ (/ len entsize)))
+
(define* (elf-symbol-table-ref elf section n #:optional strtab)
(let ((bv (elf-bytes elf))
(byte-order (elf-byte-order elf))
@@ -902,354 +1005,3 @@
(bytevector-copy! bv (+ offset 12) name 0 (1- namesz))
(bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz)
(make-elf-note (utf8->string name) desc type)))))
-
-
-
-
-;;;
-;;; All of that was the parser. Now, on to a linker.
-;;;
-
-;; A relocation records a reference to a symbol. When the symbol is
-;; resolved to an address, the reloc location will be updated to point
-;; to the address.
-;;
-;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
-;; Rel32/4 is a relative signed offset in 32-bit units. Either can have
-;; an arbitrary addend as well.
-;;
-(define-record-type <reloc>
- (make-reloc type loc addend symbol)
- reloc?
- (type reloc-type) ;; rel32/4, abs32/1, abs64/1
- (loc reloc-loc)
- (addend reloc-addend)
- (symbol reloc-symbol))
-
-;; A symbol is an association between a name and an address. The
-;; address is always in regard to some particular address space. When
-;; objects come into the linker, their symbols live in the object
-;; address space. When the objects are allocated into ELF segments, the
-;; symbols will be relocated into memory address space, corresponding to
-;; the position the ELF will be loaded at.
-;;
-(define-record-type <symbol>
- (make-symbol name address)
- symbol?
- (name symbol-name)
- (address symbol-address))
-
-(define-record-type <object>
- (make-object section bv relocs symbols)
- object?
- (section object-section)
- (bv object-bv)
- (relocs object-relocs)
- (symbols object-symbols))
-
-(define (make-string-table)
- '(("" 0 #vu8())))
-
-(define (string-table-length table)
- (let ((last (car table)))
- ;; The + 1 is for the trailing NUL byte.
- (+ (cadr last) (bytevector-length (caddr last)) 1)))
-
-(define (string-table-intern table str)
- (cond
- ((assoc str table)
- => (lambda (ent)
- (values table (cadr ent))))
- (else
- (let* ((next (string-table-length table)))
- (values (cons (list str next (string->utf8 str))
- table)
- next)))))
-
-(define (link-string-table table)
- (let ((out (make-bytevector (string-table-length table) 0)))
- (for-each
- (lambda (ent)
- (let ((bytes (caddr ent)))
- (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
- table)
- out))
-
-(define (segment-kind section)
- (let ((flags (elf-section-flags section)))
- (cons (cond
- ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
- ((zero? (logand SHF_ALLOC flags)) PT_NOTE)
- (else PT_LOAD))
- (logior (if (zero? (logand SHF_ALLOC flags))
- 0
- PF_R)
- (if (zero? (logand SHF_EXECINSTR flags))
- 0
- PF_X)
- (if (zero? (logand SHF_WRITE flags))
- 0
- PF_W)))))
-
-(define (group-by-cars ls)
- (let lp ((in ls) (k #f) (group #f) (out '()))
- (cond
- ((null? in)
- (reverse!
- (if group
- (cons (cons k (reverse! group)) out)
- out)))
- ((and group (equal? k (caar in)))
- (lp (cdr in) k (cons (cdar in) group) out))
- (else
- (lp (cdr in) (caar in) (list (cdar in))
- (if group
- (cons (cons k (reverse! group)) out)
- out))))))
-
-(define (collate-objects-into-segments objects)
- (group-by-cars
- (stable-sort!
- (map (lambda (o)
- (cons (segment-kind (object-section o)) o))
- objects)
- (lambda (x y)
- (let ((x-type (caar x)) (y-type (caar y))
- (x-flags (cdar x)) (y-flags (cdar y))
- (x-section (object-section (cdr x)))
- (y-section (object-section (cdr y))))
- (cond
- ((not (equal? x-flags y-flags))
- (< x-flags y-flags))
- ((not (equal? x-type y-type))
- (< x-type y-type))
- ((not (equal? (elf-section-type x-section)
- (elf-section-type y-section)))
- (cond
- ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
- ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
- (else (< (elf-section-type x-section)
- (elf-section-type y-section)))))
- (else
- (< (elf-section-size x-section)
- (elf-section-size y-section)))))))))
-
-(define (align address alignment)
- (+ address
- (modulo (- alignment (modulo address alignment)) alignment)))
-
-(define (fold1 proc ls s0)
- (let lp ((ls ls) (s0 s0))
- (if (null? ls)
- s0
- (lp (cdr ls) (proc (car ls) s0)))))
-
-(define (fold2 proc ls s0 s1)
- (let lp ((ls ls) (s0 s0) (s1 s1))
- (if (null? ls)
- (values s0 s1)
- (receive (s0 s1) (proc (car ls) s0 s1)
- (lp (cdr ls) s0 s1)))))
-
-(define (fold4 proc ls s0 s1 s2 s3)
- (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3))
- (if (null? ls)
- (values s0 s1 s2 s3)
- (receive (s0 s1 s2 s3) (proc (car ls) s0 s1 s2 s3)
- (lp (cdr ls) s0 s1 s2 s3)))))
-
-(define (fold5 proc ls s0 s1 s2 s3 s4)
- (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3) (s4 s4))
- (if (null? ls)
- (values s0 s1 s2 s3 s4)
- (receive (s0 s1 s2 s3 s4) (proc (car ls) s0 s1 s2 s3 s4)
- (lp (cdr ls) s0 s1 s2 s3 s4)))))
-
-(define (relocate-section-header sec fileaddr memaddr)
- (make-elf-section (elf-section-name sec) (elf-section-type sec)
- (elf-section-flags sec) memaddr
- fileaddr (elf-section-size sec)
- (elf-section-link sec) (elf-section-info sec)
- (elf-section-addralign sec) (elf-section-entsize sec)))
-
-(define *page-size* 4096)
-
-;; Adds object symbols to global table, relocating them from object
-;; address space to memory address space.
-(define (add-symbols symbols offset symtab)
- (fold1 (lambda (symbol symtab)
- (let ((name (symbol-name symbol))
- (addr (symbol-address symbol)))
- (vhash-consq name (make-symbol name (+ addr offset)) symtab)))
- symbols
- symtab))
-
-(define (alloc-segment type flags objects fileaddr memaddr symtab alignment)
- (let* ((loadable? (not (zero? flags)))
- (alignment (fold1 (lambda (o alignment)
- (lcm (elf-section-addralign (object-section o))
- alignment))
- objects
- alignment))
- (fileaddr (align fileaddr alignment))
- (memaddr (align memaddr alignment)))
- (receive (objects fileend memend symtab)
- (fold4 (lambda (o out fileaddr memaddr symtab)
- (let* ((section (object-section o))
- (fileaddr
- (if (= (elf-section-type section) SHT_NOBITS)
- fileaddr
- (align fileaddr (elf-section-addralign section))))
- (memaddr
- (align memaddr (elf-section-addralign section))))
- (values
- (cons (make-object (relocate-section-header section
fileaddr
- memaddr)
- (object-bv o)
- (object-relocs o)
- (object-symbols o))
- out)
- (if (= (elf-section-type section) SHT_NOBITS)
- fileaddr
- (+ fileaddr (elf-section-size section)))
- (+ memaddr (elf-section-size section))
- (add-symbols (object-symbols o) memaddr symtab))))
- objects '() fileaddr memaddr symtab)
- (values
- (make-elf-segment* #:type type #:offset fileaddr
- #:vaddr (if loadable? memaddr 0)
- #:filesz (- fileend fileaddr)
- #:memsz (if loadable? (- memend memaddr) 0)
- #:flags flags #:align alignment)
- (reverse objects)
- symtab))))
-
-(define (process-reloc reloc bv file-offset mem-offset symtab endianness)
- (let ((ent (vhash-assq (reloc-symbol reloc) symtab)))
- (unless ent
- (error "Undefined symbol" (reloc-symbol reloc)))
- (let* ((file-loc (+ (reloc-loc reloc) file-offset))
- (mem-loc (+ (reloc-loc reloc) mem-offset))
- (addr (symbol-address (cdr ent))))
- (case (reloc-type reloc)
- ((rel32/4)
- (let ((diff (- addr mem-loc)))
- (unless (zero? (modulo diff 4))
- (error "Bad offset" reloc symbol mem-offset))
- (bytevector-s32-set! bv file-loc
- (+ (/ diff 4) (reloc-addend reloc))
- endianness)))
- ((abs32/1)
- (bytevector-u32-set! bv file-loc addr endianness))
- ((abs64/1)
- (bytevector-u64-set! bv file-loc addr endianness))
- (else
- (error "bad reloc type" reloc))))))
-
-(define (write-object bv o symtab endianness)
- (let* ((section (object-section o))
- (offset (elf-section-offset section))
- (addr (elf-section-addr section))
- (len (elf-section-size section))
- (bytes (object-bv o))
- (relocs (object-relocs o)))
- (if (not (= (elf-section-type section) SHT_NOBITS))
- (begin
- (if (not (= (elf-section-size section) (bytevector-length bytes)))
- (error "unexpected length" section bytes))
- (bytevector-copy! bytes 0 bv offset len)
- (for-each (lambda (reloc)
- (process-reloc reloc bv offset addr symtab endianness))
- relocs)))))
-
-(define (compute-sections-by-name seglists)
- (let lp ((in (apply append (map cdr seglists)))
- (n 1) (out '()) (shstrtab #f))
- (if (null? in)
- (fold1 (lambda (x tail)
- (cond
- ((false-if-exception
- (string-table-ref shstrtab (car x)))
- => (lambda (str) (acons str (cdr x) tail)))
- (else tail)))
- out '())
- (let* ((section (object-section (car in)))
- (bv (object-bv (car in)))
- (name (elf-section-name section)))
- (lp (cdr in) (1+ n) (acons name n out)
- (or shstrtab
- (and (= (elf-section-type section) SHT_STRTAB)
- (equal? (false-if-exception
- (string-table-ref bv name))
- ".shstrtab")
- bv)))))))
-
-;; Given a list of section-header/bytevector pairs, collate the sections
-;; into segments, allocate the segments, allocate the ELF bytevector,
-;; and write the segments into the bytevector, relocating as we go.
-;;
-(define* (link-elf objects #:key
- (page-aligned? #t)
- (endianness (target-endianness))
- (word-size (target-word-size)))
- (let* ((seglists (collate-objects-into-segments objects))
- (sections-by-name (compute-sections-by-name seglists))
- (nsegments (length seglists))
- (nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
- (program-headers-offset (elf-header-len word-size))
- (fileaddr (+ program-headers-offset
- (* nsegments (elf-program-header-len word-size))))
- (memaddr 0))
- (receive (out fileend memend symtab _)
- (fold5
- (lambda (x out fileaddr memaddr symtab prev-flags)
- (let ((type (caar x))
- (flags (cdar x))
- (objects (cdr x)))
- (receive (segment objects symtab)
- (alloc-segment type flags objects fileaddr memaddr symtab
- (if (and page-aligned?
- (not (= flags prev-flags)))
- *page-size*
- 8))
- (values
- (cons (cons segment objects) out)
- (+ (elf-segment-offset segment) (elf-segment-filesz segment))
- (if (zero? (elf-segment-memsz segment))
- memaddr
- (+ (elf-segment-vaddr segment)
- (elf-segment-memsz segment)))
- symtab
- flags))))
- seglists '() fileaddr memaddr vlist-null 0)
- (let* ((out (reverse! out))
- (section-table-offset (+ (align fileend word-size)))
- (fileend (+ section-table-offset
- (* nsections (elf-section-header-len word-size))))
- (bv (make-bytevector fileend 0)))
- (write-elf-header bv #:byte-order endianness #:word-size word-size
- #:phoff program-headers-offset #:phnum nsegments
- #:shoff section-table-offset #:shnum nsections
- #:shstrndx (or (assoc-ref sections-by-name
".shstrtab")
- SHN_UNDEF))
- (write-elf-section-header bv section-table-offset
- endianness word-size
- (make-elf-section* #:type SHT_NULL #:flags 0
- #:addralign 0))
- (fold2 (lambda (x phidx shidx)
- (write-elf-program-header
- bv (+ program-headers-offset
- (* (elf-program-header-len word-size) phidx))
- endianness word-size (car x))
- (values
- (1+ phidx)
- (fold1 (lambda (o shidx)
- (write-object bv o symtab endianness)
- (write-elf-section-header
- bv (+ section-table-offset
- (* (elf-section-header-len word-size) shidx))
- endianness word-size (object-section o))
- (1+ shidx))
- (cdr x) shidx)))
- out 0 1)
- bv))))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
new file mode 100644
index 0000000..8407462
--- /dev/null
+++ b/module/system/vm/linker.scm
@@ -0,0 +1,537 @@
+;;; Guile ELF linker
+
+;; Copyright (C) 2011, 2012, 2013 Free Software 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:
+;;;
+;;; A linker combines several linker objects into an executable or a
+;;; loadable library.
+;;;
+;;; There are several common formats for libraries out there. Since
+;;; Guile includes its own linker and loader, we are free to choose any
+;;; format, or make up our own.
+;;;
+;;; There are essentially two requirements for a linker format:
+;;; libraries should be able to be loaded with the minimal amount of
+;;; work; and they should support introspection in some way, in order to
+;;; enable good debugging.
+;;;
+;;; These requirements are somewhat at odds, as loading should not have
+;;; to stumble over features related to introspection. It so happens
+;;; that a lot of smart people have thought about this situation, and
+;;; the ELF format embodies the outcome of their thinking. Guile uses
+;;; ELF as its format, regardless of the platform's native library
+;;; format. It's not inconceivable that Guile could interoperate with
+;;; the native dynamic loader at some point, but it's not a near-term
+;;; goal.
+;;;
+;;; Guile's linker takes a list of objects, sorts them according to
+;;; similarity from the perspective of the loader, then writes them out
+;;; into one big bytevector in ELF format.
+;;;
+;;; It is often the case that different parts of a library need to refer
+;;; to each other. For example, program text may need to refer to a
+;;; constant from writable memory. When the linker places sections
+;;; (linker objects) into specific locations in the linked bytevector,
+;;; it needs to fix up those references. This process is called
+;;; /relocation/. References needing relocations are recorded in
+;;; "linker-reloc" objects, and collected in a list in each
+;;; "linker-object". The actual definitions of the references are
+;;; stored in "linker-symbol" objects, also collected in a list in each
+;;; "linker-object".
+;;;
+;;; By default, the ELF files created by the linker include some padding
+;;; so that different parts of the file can be loaded in with different
+;;; permissions. For example, some parts of the file are read-only and
+;;; thus can be shared between processes. Some parts of the file don't
+;;; need to be loaded at all. However this padding can be too much for
+;;; interactive compilation, when the code is never written out to disk;
+;;; in that case, pass #:page-aligned? #f to `link-elf'.
+;;;
+;;; Code:
+
+(define-module (system vm linker)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (system vm elf)
+ #:export (make-linker-reloc
+ make-linker-symbol
+
+ make-linker-object
+ linker-object?
+ linker-object-section
+ linker-object-bv
+ linker-object-relocs
+ (linker-object-symbols* . linker-object-symbols)
+
+ make-string-table
+ string-table-intern
+ link-string-table
+
+ link-elf))
+
+;; A relocation records a reference to a symbol. When the symbol is
+;; resolved to an address, the reloc location will be updated to point
+;; to the address.
+;;
+;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
+;; Rel32/4 is a relative signed offset in 32-bit units. Either can have
+;; an arbitrary addend as well.
+;;
+(define-record-type <linker-reloc>
+ (make-linker-reloc type loc addend symbol)
+ linker-reloc?
+ (type linker-reloc-type) ;; rel32/4, abs32/1, abs64/1
+ (loc linker-reloc-loc)
+ (addend linker-reloc-addend)
+ (symbol linker-reloc-symbol))
+
+;; A symbol is an association between a name and an address. The
+;; address is always in regard to some particular address space. When
+;; objects come into the linker, their symbols live in the object
+;; address space. When the objects are allocated into ELF segments, the
+;; symbols will be relocated into memory address space, corresponding to
+;; the position the ELF will be loaded at.
+;;
+(define-record-type <linker-symbol>
+ (make-linker-symbol name address)
+ linker-symbol?
+ (name linker-symbol-name)
+ (address linker-symbol-address))
+
+(define-record-type <linker-object>
+ (%make-linker-object section bv relocs symbols)
+ linker-object?
+ (section linker-object-section)
+ (bv linker-object-bv)
+ (relocs linker-object-relocs)
+ (symbols linker-object-symbols))
+
+;; Hide a symbol to the beginning of the section in the symbols.
+(define (make-linker-object section bv relocs symbols)
+ (%make-linker-object section bv relocs
+ (cons (make-linker-symbol (gensym "*section*") 0)
+ symbols)))
+(define (linker-object-section-symbol object)
+ (car (linker-object-symbols object)))
+(define (linker-object-symbols* object)
+ (cdr (linker-object-symbols object)))
+
+(define (make-string-table)
+ '(("" 0 #vu8())))
+
+(define (string-table-length table)
+ (let ((last (car table)))
+ ;; The + 1 is for the trailing NUL byte.
+ (+ (cadr last) (bytevector-length (caddr last)) 1)))
+
+(define (string-table-intern table str)
+ (cond
+ ((assoc str table)
+ => (lambda (ent)
+ (values table (cadr ent))))
+ (else
+ (let* ((next (string-table-length table)))
+ (values (cons (list str next (string->utf8 str))
+ table)
+ next)))))
+
+(define (link-string-table table)
+ (let ((out (make-bytevector (string-table-length table) 0)))
+ (for-each
+ (lambda (ent)
+ (let ((bytes (caddr ent)))
+ (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
+ table)
+ out))
+
+(define (segment-kind section)
+ (let ((flags (elf-section-flags section)))
+ (cons (cond
+ ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+ ;; Sections without SHF_ALLOC don't go in segments.
+ ((zero? flags) #f)
+ (else PT_LOAD))
+ (logior (if (zero? (logand SHF_ALLOC flags))
+ 0
+ PF_R)
+ (if (zero? (logand SHF_EXECINSTR flags))
+ 0
+ PF_X)
+ (if (zero? (logand SHF_WRITE flags))
+ 0
+ PF_W)))))
+
+(define (count-segments objects)
+ (length
+ (fold1 (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (and (car kind) (not (member kind kinds)))
+ (cons kind kinds)
+ kinds)))
+ objects
+ ;; We know there will be at least one segment, containing at
+ ;; least the header and segment table.
+ (list (cons PT_LOAD PF_R)))))
+
+(define (group-by-cars ls)
+ (let lp ((in ls) (k #f) (group #f) (out '()))
+ (cond
+ ((null? in)
+ (reverse!
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))
+ ((and group (equal? k (caar in)))
+ (lp (cdr in) k (cons (cdar in) group) out))
+ (else
+ (lp (cdr in) (caar in) (list (cdar in))
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out))))))
+
+(define (collate-objects-into-segments objects)
+ (group-by-cars
+ (stable-sort!
+ (map (lambda (o)
+ (cons (segment-kind (linker-object-section o)) o))
+ objects)
+ (lambda (x y)
+ (let* ((x-kind (car x)) (y-kind (car y))
+ (x-type (car x-kind)) (y-type (car y-kind))
+ (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
+ (x-section (linker-object-section (cdr x)))
+ (y-section (linker-object-section (cdr y))))
+ (cond
+ ((not (equal? x-kind y-kind))
+ (cond
+ ((and x-type y-type)
+ (cond
+ ((not (equal? x-flags y-flags))
+ (< x-flags y-flags))
+ (else
+ (< x-type y-type))))
+ (else
+ (not y-type))))
+ ((not (equal? (elf-section-type x-section)
+ (elf-section-type y-section)))
+ (cond
+ ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
+ ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
+ (else (< (elf-section-type x-section)
+ (elf-section-type y-section)))))
+ (else
+ ;; Leave them in the initial order. This allows us to ensure
+ ;; that the ELF header is written first.
+ #f)))))))
+
+(define (align address alignment)
+ (if (zero? alignment)
+ address
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment))))
+
+(define (fold1 proc ls s0)
+ (let lp ((ls ls) (s0 s0))
+ (if (null? ls)
+ s0
+ (lp (cdr ls) (proc (car ls) s0)))))
+
+(define (fold3 proc ls s0 s1 s2)
+ (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2))
+ (if (null? ls)
+ (values s0 s1 s2)
+ (receive (s0 s1 s2) (proc (car ls) s0 s1 s2)
+ (lp (cdr ls) s0 s1 s2)))))
+
+(define (relocate-section-header sec addr)
+ (make-elf-section #:index (elf-section-index sec)
+ #:name (elf-section-name sec)
+ #:type (elf-section-type sec)
+ #:flags (elf-section-flags sec)
+ #:addr addr
+ #:offset addr
+ #:size (elf-section-size sec)
+ #:link (elf-section-link sec)
+ #:info (elf-section-info sec)
+ #:addralign (elf-section-addralign sec)
+ #:entsize (elf-section-entsize sec)))
+
+(define *page-size* 4096)
+
+;; Adds object symbols to global table, relocating them from object
+;; address space to memory address space.
+(define (add-symbols symbols offset symtab)
+ (fold1 (lambda (symbol symtab)
+ (let ((name (linker-symbol-name symbol))
+ (addr (linker-symbol-address symbol)))
+ (when (vhash-assq name symtab)
+ (error "duplicate symbol" name))
+ (vhash-consq name (make-linker-symbol name (+ addr offset))
symtab)))
+ symbols
+ symtab))
+
+(define (alloc-objects write-segment-header!
+ phidx type flags objects addr symtab alignment)
+ (let* ((alignment (fold1 (lambda (o alignment)
+ (lcm (elf-section-addralign
+ (linker-object-section o))
+ alignment))
+ objects
+ alignment))
+ (addr (align addr alignment)))
+ (receive (objects endaddr symtab)
+ (fold3 (lambda (o out addr symtab)
+ (let* ((section (linker-object-section o))
+ (addr (align addr (elf-section-addralign section))))
+ (values
+ (cons (make-linker-object
+ (relocate-section-header section addr)
+ (linker-object-bv o)
+ (linker-object-relocs o)
+ (linker-object-symbols o))
+ out)
+ (+ addr (elf-section-size section))
+ (add-symbols (linker-object-symbols o) addr symtab))))
+ objects
+ '() addr symtab)
+ (when type
+ (write-segment-header!
+ (make-elf-segment #:index phidx #:type type
+ #:offset addr #:vaddr addr
+ #:filesz (- endaddr addr) #:memsz (- endaddr addr)
+ #:flags flags #:align alignment)))
+ (values endaddr
+ (reverse objects)
+ symtab))))
+
+(define (process-reloc reloc bv file-offset mem-offset symtab endianness)
+ (let ((ent (vhash-assq (linker-reloc-symbol reloc) symtab)))
+ (unless ent
+ (error "Undefined symbol" (linker-reloc-symbol reloc)))
+ (let* ((file-loc (+ (linker-reloc-loc reloc) file-offset))
+ (mem-loc (+ (linker-reloc-loc reloc) mem-offset))
+ (addr (linker-symbol-address (cdr ent))))
+ (case (linker-reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- addr mem-loc)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol mem-offset))
+ (bytevector-s32-set! bv file-loc
+ (+ (/ diff 4) (linker-reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv file-loc addr endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv file-loc addr endianness))
+ (else
+ (error "bad reloc type" reloc))))))
+
+(define (write-linker-object bv o symtab endianness)
+ (let* ((section (linker-object-section o))
+ (offset (elf-section-offset section))
+ (addr (elf-section-addr section))
+ (len (elf-section-size section))
+ (bytes (linker-object-bv o))
+ (relocs (linker-object-relocs o)))
+ (if (not (= (elf-section-type section) SHT_NOBITS))
+ (begin
+ (if (not (= len (bytevector-length bytes)))
+ (error "unexpected length" section bytes))
+ (bytevector-copy! bytes 0 bv offset len)
+ (for-each (lambda (reloc)
+ (process-reloc reloc bv offset addr symtab endianness))
+ relocs)))))
+
+(define (find-shstrndx objects)
+ (or-map (lambda (object)
+ (let* ((section (linker-object-section object))
+ (bv (linker-object-bv object))
+ (name (elf-section-name section)))
+ (and (= (elf-section-type section) SHT_STRTAB)
+ (equal? (false-if-exception (string-table-ref bv name))
+ ".shstrtab")
+ (elf-section-index section))))
+ objects))
+
+(define (add-elf-objects objects endianness word-size)
+ (define phoff (elf-header-len word-size))
+ (define phentsize (elf-program-header-len word-size))
+ (define shentsize (elf-section-header-len word-size))
+ (define shnum (+ (length objects) 3))
+ (define reloc-kind
+ (case word-size
+ ((4) 'abs32/1)
+ ((8) 'abs64/1)
+ (else (error "bad word size" word-size))))
+
+ ;; ELF requires that the first entry in the section table be of type
+ ;; SHT_NULL.
+ ;;
+ (define (make-null-section)
+ (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
+ #:flags 0 #:addralign 0)
+ #vu8() '() '()))
+
+ ;; The ELF header and the segment table.
+ ;;
+ (define (make-header phnum index shoff-label)
+ (let* ((header (make-elf #:byte-order endianness #:word-size word-size
+ #:phoff phoff #:phnum phnum #:phentsize phentsize
+ #:shoff 0 #:shnum shnum #:shentsize shentsize
+ #:shstrndx (or (find-shstrndx objects)
SHN_UNDEF)))
+ (shoff-reloc (make-linker-reloc reloc-kind
+ (elf-header-shoff-offset word-size)
+ 0
+ shoff-label))
+ (size (+ phoff (* phnum phentsize)))
+ (bv (make-bytevector size 0)))
+ (write-elf-header bv header)
+ ;; Leave the segment table uninitialized; it will be filled in
+ ;; later by calls to the write-segment-header! closure.
+ (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
+ #:flags SHF_ALLOC #:size size)
+ bv
+ (list shoff-reloc)
+ '())))
+
+ ;; The section table.
+ ;;
+ (define (make-footer objects shoff-label)
+ (let* ((size (* shentsize shnum))
+ (bv (make-bytevector size 0))
+ (section-table (make-elf-section #:index (length objects)
+ #:type SHT_PROGBITS
+ #:flags 0
+ #:size size)))
+ (define (write-and-reloc section-label section relocs)
+ (let ((offset (* shentsize (elf-section-index section))))
+ (write-elf-section-header bv offset endianness word-size section)
+ (if (= (elf-section-type section) SHT_NULL)
+ relocs
+ (cons* (make-linker-reloc
+ reloc-kind
+ (+ offset (elf-section-header-addr-offset word-size))
+ 0
+ section-label)
+ (make-linker-reloc
+ reloc-kind
+ (+ offset (elf-section-header-offset-offset word-size))
+ 0
+ section-label)
+ relocs))))
+ (let ((relocs (fold1 (lambda (object relocs)
+ (write-and-reloc
+ (linker-symbol-name
+ (linker-object-section-symbol object))
+ (linker-object-section object)
+ relocs))
+ objects
+ (write-and-reloc shoff-label section-table '()))))
+ (%make-linker-object section-table bv relocs
+ (list (make-linker-symbol shoff-label 0))))))
+
+ (let* ((null-section (make-null-section))
+ (objects (cons null-section objects))
+
+ (shoff (gensym "*section-table*"))
+ (header (make-header (count-segments objects) (length objects) shoff))
+ (objects (cons header objects))
+
+ (footer (make-footer objects shoff))
+ (objects (cons footer objects)))
+
+ ;; The header includes the segment table, which needs offsets and
+ ;; sizes of the segments. Normally we would use relocs to rewrite
+ ;; these values, but there is no reloc type that would allow us to
+ ;; compute size. Such a reloc would need to take the difference
+ ;; between two symbols, and it's probably a bad idea architecturally
+ ;; to create one.
+ ;;
+ ;; So instead we return a closure to patch up the segment table.
+ ;; Normally we'd shy away from such destructive interfaces, but it's
+ ;; OK as we create the header section ourselves.
+ ;;
+ (define (write-segment-header! segment)
+ (let ((bv (linker-object-bv header))
+ (offset (+ phoff (* (elf-segment-index segment) phentsize))))
+ (write-elf-program-header bv offset endianness word-size segment)))
+
+ (values write-segment-header! objects)))
+
+;; objects ::= list of <linker-object>
+;;
+;; => 3 values:
+;; file size
+;; objects with allocated memory address and file offset
+;; symbol table
+;;
+(define (allocate-elf objects page-aligned? endianness word-size)
+ (receive (write-segment-header! objects)
+ (add-elf-objects objects endianness word-size)
+ (let lp ((seglists (collate-objects-into-segments objects))
+ (objects '())
+ (phidx 0)
+ (addr 0)
+ (symtab vlist-null)
+ (prev-flags 0))
+ (match seglists
+ ((((type . flags) objs-in ...) seglists ...)
+ (receive (addr objs-out symtab)
+ (alloc-objects write-segment-header!
+ phidx type flags objs-in addr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags))
+ ;; Allow sections that are not in
+ ;; loadable segments to share pages
+ ;; with PF_R segments.
+ (not (and (not type) (= PF_R
prev-flags))))
+ *page-size*
+ 8))
+ (lp seglists
+ (fold1 cons objs-out objects)
+ (if type (1+ phidx) phidx)
+ addr
+ symtab
+ flags)))
+ (()
+ (values addr
+ (reverse objects)
+ symtab))))))
+
+;; Given a list of linker objects, collate the objects into segments,
+;; allocate the segments, allocate the ELF bytevector, and write the
+;; segments into the bytevector, relocating as we go.
+;;
+(define* (link-elf objects #:key
+ (page-aligned? #t)
+ (endianness (target-endianness))
+ (word-size (target-word-size)))
+ (receive (size objects symtab)
+ (allocate-elf objects page-aligned? endianness word-size)
+ (let ((bv (make-bytevector size 0)))
+ (for-each
+ (lambda (object)
+ (write-linker-object bv object symtab endianness))
+ objects)
+ bv)))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index f939a55..e2a93d7 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -1,6 +1,6 @@
;;; Guile VM object code
-;; Copyright (C) 2001, 2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 2012, 2013 Free Software 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,7 +22,8 @@
#:export (objcode? objcode-meta
bytecode->objcode objcode->bytecode
load-thunk-from-file load-thunk-from-memory
- word-size byte-order))
+ word-size byte-order
+ find-mapped-elf-image))
(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 47dc927..267e373 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -22,6 +22,7 @@
#:use-module (system base pmatch)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
+ #:use-module (system vm debug)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -44,6 +45,7 @@
program-meta
program-objcode program? program-objects
+ rtl-program? rtl-program-code
program-module program-base
program-free-variables
program-num-free-variables
@@ -52,6 +54,25 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
+;; These procedures are called by programs.c.
+(define (rtl-program-name program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (and=> (find-program-debug-info (rtl-program-code program))
+ program-debug-info-name))
+(define (rtl-program-documentation program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-docstring (rtl-program-code program)))
+(define (rtl-program-minimum-arity program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (program-minimum-arity (rtl-program-code program)))
+(define (rtl-program-properties program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-properties (rtl-program-code program)))
+
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -267,25 +288,38 @@
1+
0)))
+(define (program-arguments-alists prog)
+ (cond
+ ((rtl-program? prog)
+ (map arity-arguments-alist
+ (find-program-arities (rtl-program-code prog))))
+ ((program? prog)
+ (map (lambda (arity) (arity->arguments-alist prog arity))
+ (or (program-arities prog) '())))
+ (else (error "expected a program" prog))))
+
(define (write-program prog port)
- (format port "#<procedure ~a~a>"
- (or (procedure-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)
- (if s "<current input>" "<unknown port>"))
- (source:line-for-user s) (source:column s))))
- (number->string (object-address prog) 16))
- (let ((arities (program-arities prog)))
- (if (or (not arities) (null? arities))
- ""
- (string-append
- " " (string-join (map (lambda (a)
- (object->string
- (arguments-alist->lambda-list
- (arity->arguments-alist prog a))))
- arities)
- " | "))))))
+ (define (program-identity-string)
+ (or (procedure-name prog)
+ (and=> (and (program? prog) (program-source prog 0))
+ (lambda (s)
+ (format #f "~a at ~a:~a:~a"
+ (number->string (object-address prog) 16)
+ (or (source:file s)
+ (if s "<current input>" "<unknown port>"))
+ (source:line-for-user s) (source:column s))))
+ (number->string (object-address prog) 16)))
+ (define (program-formals-string)
+ (let ((arguments (program-arguments-alists prog)))
+ (if (null? arguments)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments-alist->lambda-list a)))
+ arguments)
+ " | ")))))
+
+ (format port "#<procedure ~a~a>"
+ (program-identity-string) (program-formals-string)))
diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
deleted file mode 100644
index 0f8b391..0000000
--- a/module/system/vm/rtl.scm
+++ /dev/null
@@ -1,979 +0,0 @@
-;;; Guile VM program functions
-
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software 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 rtl)
- #:use-module (system base target)
- #:use-module (system vm instruction)
- #:use-module (system vm elf)
- #:use-module (system vm program)
- #:use-module (system vm objcode)
- #:use-module (rnrs bytevectors)
- #:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-4)
- #:use-module (srfi srfi-9)
- #:export (make-assembler
- emit-text
- link-assembly
- assemble-program))
-
-(define-syntax-rule (pack-u8-u24 x y)
- (logior x (ash y 8)))
-
-(define-syntax-rule (pack-u8-s24 x y)
- (logior x (ash (cond
- ((< 0 (- y) #x800000)
- (+ y #x1000000))
- ((<= 0 y #xffffff)
- y)
- (else (error "out of range" y)))
- 8)))
-
-(define-syntax-rule (pack-u1-u7-u24 x y z)
- (logior x (ash y 1) (ash z 8)))
-
-(define-syntax-rule (pack-u8-u12-u12 x y z)
- (logior x (ash y 8) (ash z 20)))
-
-(define-syntax-rule (pack-u8-u8-u16 x y z)
- (logior x (ash y 8) (ash z 16)))
-
-(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
- (logior x (ash y 8) (ash z 16) (ash w 24)))
-
-(define-record-type <meta>
- (make-meta name low-pc high-pc)
- meta?
- (name meta-name)
- (low-pc meta-low-pc)
- (high-pc meta-high-pc set-meta-high-pc!))
-
-(define-syntax *block-size* (identifier-syntax 32))
-
-;; We'll use native endianness when writing bytecode. If we're
-;; targeting a foreign endianness, we byte-swap the bytevector as a
-;; whole instead of conditionalizing each access.
-;;
-;; We write constants using the target endianness, though.
-;;
-(define-record-type <asm>
- (make-asm cur idx start prev written
- labels relocs
- word-size endianness
- constants inits
- string-table
- meta)
- asm?
- (cur asm-cur set-asm-cur!)
- (idx asm-idx set-asm-idx!)
- (start asm-start set-asm-start!)
- (prev asm-prev set-asm-prev!)
- (written asm-written set-asm-written!)
- (labels asm-labels set-asm-labels!)
- (relocs asm-relocs set-asm-relocs!)
- (word-size asm-word-size)
- (endianness asm-endianness)
- ;; Vhash of object -> label. Order is important.
- (constants asm-constants set-asm-constants!)
- (inits asm-inits set-asm-inits!)
- (string-table asm-string-table set-asm-string-table!)
- (meta asm-meta set-asm-meta!))
-
-(define-inlinable (fresh-block)
- (make-u32vector *block-size*))
-
-(define* (make-assembler #:key (word-size (target-word-size))
- (endianness (target-endianness)))
- (make-asm (fresh-block) 0 0 '() 0
- '() '()
- word-size endianness
- vlist-null '()
- (make-elf-string-table)
- '()))
-
-(define (intern-string! asm string)
- (call-with-values
- (lambda () (elf-string-table-intern (asm-string-table asm) string))
- (lambda (table idx)
- (set-asm-string-table! asm table)
- idx)))
-
-(define-inlinable (asm-pos asm)
- (+ (asm-idx asm) (asm-written asm)))
-
-(define (allocate-new-block asm)
- (let ((new (fresh-block)))
- (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm)))
- (set-asm-written! asm (asm-pos asm))
- (set-asm-cur! asm new)
- (set-asm-idx! asm 0)))
-
-(define-syntax-rule (u32-ref buf n)
- (bytevector-u32-native-ref buf (* n 4)))
-
-(define-syntax-rule (u32-set! buf n val)
- (bytevector-u32-native-set! buf (* n 4) val))
-
-(define-syntax-rule (s32-ref buf n)
- (bytevector-s32-native-ref buf (* n 4)))
-
-(define-syntax-rule (s32-set! buf n val)
- (bytevector-s32-native-set! buf (* n 4) val))
-
-(define-inlinable (emit asm u32)
- (u32-set! (asm-cur asm) (asm-idx asm) u32)
- (set-asm-idx! asm (1+ (asm-idx asm)))
- (if (= (asm-idx asm) *block-size*)
- (allocate-new-block asm)))
-
-(define-inlinable (make-reloc type label base word)
- (list type label base word))
-
-(define-inlinable (reset-asm-start! asm)
- (set-asm-start! asm (+ (asm-idx asm) (asm-written asm))))
-
-(define (emit-exported-label asm label)
- (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
-
-(define (record-label-reference asm label)
- (let* ((start (asm-start asm))
- (pos (asm-pos asm))
- (reloc (make-reloc 'x8-s24 label start (- pos start))))
- (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
-
-(define* (record-far-label-reference asm label #:optional (offset 0))
- (let* ((start (- (asm-start asm) offset))
- (pos (asm-pos asm))
- (reloc (make-reloc 's32 label start (- pos start))))
- (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
-
-(eval-when (expand compile load eval)
- (define (id-append ctx a b)
- (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
-
-(define-syntax assembler
- (lambda (x)
- (define-syntax op-case
- (lambda (x)
- (syntax-case x ()
- ((_ asm name ((type arg ...) code ...) clause ...)
- #`(if (eq? name 'type)
- (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
- #'((arg ...)
- code ...))
- (op-case asm name clause ...)))
- ((_ asm name)
- #'(error "unmatched name" 'name)))))
-
- (define (pack-first-word asm opcode type)
- (with-syntax ((opcode opcode))
- (op-case
- asm type
- ((U8_X24)
- (emit asm opcode))
- ((U8_U24 arg)
- (emit asm (pack-u8-u24 opcode arg)))
- ((U8_L24 label)
- (record-label-reference asm label)
- (emit asm opcode))
- ((U8_R24 rest)
- (emit asm (pack-u8-u24 opcode (list rest)))
- (for-each (lambda (x) (emit asm x)) rest))
- ((U8_U8_I16 a imm)
- (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
- ((U8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 opcode a b)))
- ((U8_U8_U8_U8 a b c)
- (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
-
- (define (pack-tail-word asm type)
- (op-case
- asm type
- ((U8_U24 a b)
- (emit asm (pack-u8-u24 a b)))
- ((U8_L24 a label)
- (record-label-reference asm label)
- (emit asm a))
- ((U8_R24 rest)
- (emit asm (pack-u8-u24 a (length rest)))
- (for-each (lambda (x) (emit asm x)) rest))
- ((U8_U8_I16 a b imm)
- (emit asm (pack-u8-u8-u16 a b (object-address imm))))
- ((U8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 a b c)))
- ((U8_U8_U8_U8 a b c d)
- (emit asm (pack-u8-u8-u8-u8 a b c d)))
- ((U32 a)
- (emit asm a))
- ((I32 imm)
- (let ((val (object-address imm)))
- (unless (zero? (ash val -32))
- (error "FIXME: enable truncation of negative fixnums when
cross-compiling"))
- (emit asm val)))
- ((A32 imm)
- (unless (= (asm-word-size asm) 8)
- (error "make-long-immediate unavailable for this target"))
- (emit asm (ash (object-address imm) -32))
- (emit asm (logand (object-address imm) (1- (ash 1 32)))))
- ((B32))
- ((N32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((S32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((L32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((LO32 label offset)
- (record-far-label-reference asm label
- (* offset (/ (asm-word-size asm) 4)))
- (emit asm 0))
- ((X8_U24 a)
- (emit asm (pack-u8-u24 0 a)))
- ((X8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 0 a b)))
- ((X8_R24 rest)
- (emit asm (pack-u8-u24 0 (length rest)))
- (for-each (lambda (x) (emit asm x)) rest))
- ((X8_L24 label)
- (record-label-reference asm label)
- (emit asm 0))
- ((U1_X7_L24 a label)
- (record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 a 0 0)))
- ((U1_U7_L24 a b label)
- (record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 a b 0)))))
-
- (syntax-case x ()
- ((_ name opcode word0 word* ...)
- (with-syntax ((((formal0 ...)
- code0 ...)
- (pack-first-word #'asm
- (syntax->datum #'opcode)
- (syntax->datum #'word0)))
- ((((formal* ...)
- code* ...) ...)
- (map (lambda (word) (pack-tail-word #'asm word))
- (syntax->datum #'(word* ...)))))
- #'(lambda (asm formal0 ... formal* ... ...)
- (unless (asm? asm) (error "not an asm"))
- code0 ...
- code* ... ...
- ))))))
-
-(define assemblers (make-hash-table))
-
-(define-syntax define-assembler
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode arg ...)
- (with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(define emit
- (let ((emit (assembler name opcode arg ...)))
- (hashq-set! assemblers 'name emit)
- emit)))))))
-
-(define-syntax visit-opcodes
- (lambda (x)
- (syntax-case x ()
- ((visit-opcodes macro arg ...)
- (with-syntax (((inst ...)
- (map (lambda (x) (datum->syntax #'macro x))
- (rtl-instruction-list))))
- #'(begin
- (macro arg ... . inst)
- ...))))))
-
-(visit-opcodes define-assembler)
-
-(define-syntax disassembler
- (lambda (x)
- (define (parse-first-word exp type)
- #`(let ((word #,exp))
- #,(case type
- ((U8_X24)
- #'(list))
- ((U8_U24)
- #'(list (ash word -8)))
- ((U8_L24)
- ;; Fixme: translate back to label
- #'(list (ash word -8)))
- ((U8_R24)
- ;; FIXME: parse rest instructions correctly
- #'(list (ash word -8)))
- ((U8_U8_I16)
- #'(list (logand (ash word -8) #xff)
- (ash word -16)))
- ((U8_U12_U12)
- #'(list (logand (ash word -8) #xfff)
- (ash word -20)))
- ((U8_U8_U8_U8)
- #'(list (logand (ash word -8) #xff)
- (logand (ash word -16) #xff)
- (ash word -24)))
- (else
- (error "bad kind" type)))))
-
- (define (parse-tail-word buf offset n type)
- #`(let ((word (u32-ref #,buf (+ #,offset #,n))))
- #,(case type
- ((U8_X24)
- #'(list (logand word #ff)))
- ((U8_U24)
- #'(list (logand word #xff)
- (ash word -8)))
- ((U8_L24)
- ;; Fixme: translate back to label
- #'(list (logand word #xff)
- (ash word -8)))
- ((U8_R24)
- ;; FIXME: parse rest instructions correctly
- #'(list (logand word #xff)
- (ash word -8)))
- ((U8_U8_I16)
- ;; FIXME: immediates
- #'(list (logand word #xff)
- (logand (ash word -8) #xff)
- (ash word -16)))
- ((U8_U12_U12)
- #'(list (logand word #xff)
- (logand (ash word -8) #xfff)
- (ash word -20)))
- ((U8_U8_U8_U8)
- #'(list (logand word #xff)
- (logand (ash word -8) #xff)
- (logand (ash word -16) #xff)
- (ash word -24)))
- ((U32)
- #'(list word))
- ((I32)
- ;; FIXME: immediates
- #'(list word))
- ((A32)
- ;; FIXME: long immediates
- #'(list word))
- ((B32)
- ;; FIXME: long immediates
- #'(list word))
- ((N32)
- ;; FIXME: non-immediate
- #'(list word))
- ((S32)
- ;; FIXME: indirect access
- #'(list word))
- ((L32)
- ;; FIXME: offset
- #'(list word))
- ((LO32)
- ;; FIXME: offset
- #'(list word))
- ((X8_U24)
- #'(list (ash word -8)))
- ((X8_U12_U12)
- #'(list (logand (ash word -8) #xfff)
- (ash word -20)))
- ((X8_R24)
- ;; FIXME: rest
- #'(list (ash word -8)))
- ((X8_L24)
- ;; FIXME: label
- #'(list (ash word -8)))
- ((U1_X7_L24)
- ;; FIXME: label
- #'(list (logand word #x1)
- (ash word -8)))
- ((U1_U7_L24)
- ;; FIXME: label
- #'(list (logand word #x1)
- (logand (ash word -1) #x7f)
- (ash word -8)))
- (else
- (error "bad kind" type)))))
-
- (syntax-case x ()
- ((_ name opcode word0 word* ...)
- (with-syntax ((asm
- (parse-first-word #'first
- (syntax->datum #'word0)))
- ((asm* ...)
- (map (lambda (word n)
- (parse-tail-word #'buf #'offset (1+ n)
- word))
- (syntax->datum #'(word* ...))
- (iota (length #'(word* ...))))))
- #'(lambda (buf offset first)
- (values (+ 1 (length '(word* ...)))
- (cons 'name (append asm asm* ...)))))))))
-
-(define (disasm-invalid buf offset first)
- (error "bad instruction" (logand first #xff) first buf offset))
-
-(define disassemblers (make-vector 256 disasm-invalid))
-
-(define-syntax define-disassembler
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode arg ...)
- (with-syntax ((parse (id-append #'name #'parse- #'name)))
- #'(let ((parse (disassembler name opcode arg ...)))
- (vector-set! disassemblers opcode parse)))))))
-
-(visit-opcodes define-disassembler)
-
-;; -> len list
-(define (disassemble-one buf offset)
- (let ((first (u32-ref buf offset)))
- ((vector-ref disassemblers (logand first #xff)) buf offset first)))
-
-;; -> list
-(define* (disassemble-buffer buf #:optional
- (offset 0)
- (end (u32vector-length buf)))
-
- (let ((locals (u32-ref buf offset))
- (meta (s32-ref buf (1+ offset))))
- (let lp ((offset (+ offset 2))
- (out '()))
- (if (< offset end)
- (call-with-values (lambda () (disassemble-one buf offset))
- (lambda (len elt)
- (lp (+ offset len) (cons elt out))))
- (cons* locals meta (reverse out))))))
-
-(define-inlinable (immediate? x)
- (not (zero? (logand (object-address x) 6))))
-
-(define-record-type <stringbuf>
- (make-stringbuf string)
- stringbuf?
- (string stringbuf-string))
-
-(define-record-type <static-procedure>
- (make-static-procedure code)
- static-procedure?
- (code static-procedure-code))
-
-;; Used for cells that cache the module that was current when a toplevel
-;; closure was created, or for toplevel refs within a procedure.
-(define-record-type <cache-cell>
- (make-cache-cell scope key)
- cache-cell?
- (scope cache-cell-scope)
- (key cache-cell-key))
-
-(define (statically-allocatable? x)
- (or (pair? x) (vector? x) (string? x) (stringbuf? x) (static-procedure? x)))
-
-(define (intern-constant asm obj)
- (define (recur obj)
- (intern-constant asm obj))
- (define (field dst n obj)
- (let ((src (recur obj)))
- (if src
- (list (if (statically-allocatable? obj)
- `(make-non-immediate 0 ,src)
- `(static-ref 0 ,src))
- `(static-set! 0 ,dst ,n))
- '())))
- (define (intern obj label)
- (cond
- ((pair? obj)
- (append (field label 0 (car obj))
- (field label 1 (cdr obj))))
- ((vector? obj)
- (let lp ((i 0) (inits '()))
- (if (< i (vector-length obj))
- (lp (1+ i)
- (append-reverse (field label (1+ i) (vector-ref obj i))
- inits))
- (reverse inits))))
- ((stringbuf? obj) '())
- ((static-procedure? obj)
- `((make-non-immediate 0 ,label)
- (link-procedure! 0 ,(static-procedure-code obj))))
- ((cache-cell? obj) '())
- ((symbol? obj)
- `((make-non-immediate 0 ,(recur (symbol->string obj)))
- (string->symbol 0 0)
- (static-set! 0 ,label 0)))
- ((string? obj)
- `((make-non-immediate 0 ,(recur (make-stringbuf obj)))
- (static-set! 0 ,label 1)))
- ((keyword? obj)
- `((static-ref 0 ,(recur (keyword->symbol obj)))
- (symbol->keyword 0 0)
- (static-set! 0 ,label 0)))
- ((number? obj)
- `((make-non-immediate 0 ,(recur (number->string obj)))
- (string->number 0 0)
- (static-set! 0 ,label 0)))
- (else
- (error "don't know how to intern" obj))))
- (cond
- ((immediate? obj) #f)
- ((vhash-assoc obj (asm-constants asm)) => cdr)
- (else
- ;; Note that calling intern may mutate asm-constants and
- ;; asm-constant-inits.
- (let* ((label (gensym "constant"))
- (inits (intern obj label)))
- (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
- (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
- label))))
-
-;; Returns a label.
-(define (emit-non-immediate asm obj)
- (when (immediate? obj)
- (error "expected a non-immediate" obj))
- (intern-constant asm obj))
-
-;; Returns a label. Resolutions of the same key within the same scope
-;; share a cell.
-(define (emit-cache-cell asm scope key)
- (intern-constant asm (make-cache-cell scope key)))
-
-;; Return the label of the cell that holds the module for a scope.
-(define (emit-module-cache-cell asm scope)
- (emit-cache-cell asm scope #t))
-
-(define-syntax define-macro-assembler
- (lambda (x)
- (syntax-case x ()
- ((_ (name arg ...) body body* ...)
- (with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(define emit
- (let ((emit (lambda (arg ...) body body* ...)))
- (hashq-set! assemblers 'name emit)
- emit)))))))
-
-(define-macro-assembler (load-constant asm dst obj)
- (cond
- ((immediate? obj)
- (let ((bits (object-address obj)))
- (cond
- ((and (< dst 256) (zero? (ash bits -16)))
- (emit-make-short-immediate asm dst obj))
- ((zero? (ash bits -32))
- (emit-make-long-immediate asm dst obj))
- (else
- (emit-make-long-long-immediate asm dst obj)))))
- ((statically-allocatable? obj)
- (emit-make-non-immediate asm dst (emit-non-immediate asm obj)))
- (else
- (emit-static-ref asm dst (emit-non-immediate asm obj)))))
-
-(define-macro-assembler (load-static-procedure asm dst label)
- (let ((loc (intern-constant asm (make-static-procedure label))))
- (emit-make-non-immediate asm dst loc)))
-
-(define-macro-assembler (begin-program asm label)
- (emit-label asm label)
- (let ((meta (make-meta label (asm-start asm) #f)))
- (set-asm-meta! asm (cons meta (asm-meta asm)))))
-
-(define-macro-assembler (end-program asm)
- (set-meta-high-pc! (car (asm-meta asm)) (asm-start asm)))
-
-(define-macro-assembler (label asm sym)
- (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
-
-(define-macro-assembler (cache-current-module! asm tmp scope)
- (let ((mod-label (emit-module-cache-cell asm scope)))
- (emit-current-module asm tmp)
- (reset-asm-start! asm)
- (emit-static-set! asm tmp mod-label 0)))
-
-(define-macro-assembler (cached-toplevel-ref asm dst scope sym)
- (let ((sym-label (emit-non-immediate asm sym))
- (mod-label (emit-module-cache-cell asm scope))
- (cell-label (emit-cache-cell asm scope sym)))
- (emit-toplevel-ref asm dst cell-label mod-label sym-label)))
-
-(define-macro-assembler (cached-toplevel-set! asm src scope sym)
- (let ((sym-label (emit-non-immediate asm sym))
- (mod-label (emit-module-cache-cell asm scope))
- (cell-label (emit-cache-cell asm scope sym)))
- (emit-toplevel-set! asm src cell-label mod-label sym-label)))
-
-(define-macro-assembler (cached-module-ref asm dst module-name public? sym)
- (let* ((sym-label (emit-non-immediate asm sym))
- (key (cons public? module-name))
- (mod-name-label (intern-constant asm key))
- (cell-label (emit-cache-cell asm key sym)))
- (emit-module-ref asm dst cell-label mod-name-label sym-label)))
-
-(define-macro-assembler (cached-module-set! asm src module-name public? sym)
- (let* ((sym-label (emit-non-immediate asm sym))
- (key (cons public? module-name))
- (mod-name-label (emit-non-immediate asm key))
- (cell-label (emit-cache-cell asm key sym)))
- (emit-module-set! asm src cell-label mod-name-label sym-label)))
-
-(define (emit-text asm instructions)
- (for-each (lambda (inst)
- (reset-asm-start! asm)
- (apply (or (hashq-ref assemblers (car inst))
- (error 'bad-instruction inst))
- asm
- (cdr inst)))
- instructions))
-
-(define (process-relocs buf relocs labels)
- (fold
- (lambda (reloc tail)
- (let ((abs (assq-ref labels (cadr reloc)))
- (dst (+ (caddr reloc) (cadddr reloc))))
- (case (car reloc)
- ((s32)
- (if abs
- (let ((rel (- abs (caddr reloc))))
- (s32-set! buf dst rel)
- tail)
- (cons (make-elf-reloc 'rel32/4 (* dst 4) (cadddr reloc) (cadr
reloc))
- tail)))
- ((x8-s24)
- (unless abs
- (error "unbound near relocation" reloc))
- (let ((rel (- abs (caddr reloc)))
- (u32 (u32-ref buf dst)))
- (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel))
- tail))
- (else (error "what" reloc)))))
- '()
- relocs))
-
-(define (process-labels labels)
- (map (lambda (pair)
- (make-elf-symbol (car pair) (* (cdr pair) 4)))
- labels))
-
-(define (swap-bytes! buf)
- (unless (zero? (modulo (bytevector-length buf) 4))
- (error "unexpected length"))
- (let ((byte-len (bytevector-length buf)))
- (let lp ((pos 0))
- (unless (= pos byte-len)
- (bytevector-u32-set!
- buf pos
- (bytevector-u32-ref buf pos (endianness big))
- (endianness little))
- (lp (+ pos 4))))))
-
-(define (make-object asm name bv relocs labels . kwargs)
- (let ((name-idx (intern-string! asm (symbol->string name))))
- (make-elf-object (apply make-elf-section
- #:name name-idx
- #:size (bytevector-length bv)
- kwargs)
- bv relocs
- (cons (make-elf-symbol name 0) labels))))
-
-(define (link-text-object asm)
- (let ((buf (make-u32vector (asm-pos asm))))
- (let lp ((pos 0) (prev (reverse (asm-prev asm))))
- (if (null? prev)
- (let ((byte-size (* (asm-idx asm) 4)))
- (bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
- (unless (eq? (asm-endianness asm) (native-endianness))
- (swap-bytes! buf))
- (make-object asm '.rtl-text
- buf
- (process-relocs buf (asm-relocs asm)
- (asm-labels asm))
- (process-labels (asm-labels asm))))
- (let ((len (* *block-size* 4)))
- (bytevector-copy! (car prev) 0 buf pos len)
- (lp (+ pos len) (cdr prev)))))))
-
-(define (link-dynamic-section asm text ro rw rw-init)
- (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
- (let* ((endianness (asm-endianness asm))
- (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
- (set-uword!
- (lambda (i uword)
- (%set-uword! bv (* i word-size) uword endianness)))
- (relocs '())
- (set-label!
- (lambda (i label)
- (set! relocs (cons (make-elf-reloc 'reloc-type
- (* i word-size) 0 label)
- relocs))
- (%set-uword! bv (* i word-size) 0 endianness))))
- (set-uword! 0 DT_GUILE_RTL_VERSION)
- (set-uword! 1 #x02020000)
- (set-uword! 2 DT_GUILE_ENTRY)
- (set-label! 3 '.rtl-text)
- (cond
- (rw
- ;; Add roots to GC.
- (set-uword! 4 DT_GUILE_GC_ROOT)
- (set-label! 5 '.data)
- (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
- (set-uword! 7 (bytevector-length (elf-object-bv rw)))
- (cond
- (rw-init
- (set-uword! 8 DT_INIT) ; constants
- (set-label! 9 rw-init)
- (set-uword! 10 DT_NULL)
- (set-uword! 11 0))
- (else
- (set-uword! 8 DT_NULL)
- (set-uword! 9 0))))
- (else
- (set-uword! 4 DT_NULL)
- (set-uword! 5 0)))
- (make-object asm '.dynamic bv relocs '()
- #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
- (case (asm-word-size asm)
- ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
- ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
- (else (error "bad word size" asm))))
-
-(define (link-string-table asm)
- (intern-string! asm ".shstrtab")
- (make-object asm '.shstrtab
- (link-elf-string-table (asm-string-table asm))
- '() '()
- #:type SHT_STRTAB #:flags 0))
-
-(define (write-immediate asm buf pos x)
- (let ((val (object-address x))
- (endianness (asm-endianness asm)))
- (case (asm-word-size asm)
- ((4) (bytevector-u32-set! buf pos val endianness))
- ((8) (bytevector-u64-set! buf pos val endianness))
- (else (error "bad word size" asm)))))
-
-(define (emit-init-constants asm)
- (let ((inits (asm-inits asm)))
- (and (not (null? inits))
- (let ((label (gensym "init-constants")))
- (emit-text asm
- `((begin-program ,label)
- (assert-nargs-ee/locals 0 1)
- ,@(reverse inits)
- (load-constant 0 ,*unspecified*)
- (return 0)
- (end-program)))
- label))))
-
-(define (link-data asm data name)
- (define (align address alignment)
- (+ address
- (modulo (- alignment (modulo address alignment)) alignment)))
-
- (define tc7-vector 13)
- (define tc7-narrow-stringbuf 39)
- (define tc7-wide-stringbuf (+ 39 #x400))
- (define tc7-ro-string (+ 21 #x200))
- (define tc7-rtl-program 69)
-
- (let ((word-size (asm-word-size asm))
- (endianness (asm-endianness asm)))
- (define (byte-length x)
- (cond
- ((stringbuf? x)
- (let ((x (stringbuf-string x)))
- (+ (* 2 word-size)
- (case (string-bytes-per-char x)
- ((1) (1+ (string-length x)))
- ((4) (* (1+ (string-length x)) 4))
- (else (error "bad string bytes per char" x))))))
- ((static-procedure? x)
- (* 2 word-size))
- ((string? x)
- (* 4 word-size))
- ((pair? x)
- (* 2 word-size))
- ((vector? x)
- (* (1+ (vector-length x)) word-size))
- (else
- word-size)))
-
- (define (write-constant-reference buf pos x)
- ;; The asm-inits will fix up any reference to a non-immediate.
- (write-immediate asm buf pos (if (immediate? x) x #f)))
-
- (define (write buf pos obj)
- (cond
- ((stringbuf? obj)
- (let* ((x (stringbuf-string obj))
- (len (string-length x))
- (tag (if (= (string-bytes-per-char x) 1)
- tc7-narrow-stringbuf
- tc7-wide-stringbuf)))
- (case word-size
- ((4)
- (bytevector-u32-set! buf pos tag endianness)
- (bytevector-u32-set! buf (+ pos 4) len endianness))
- ((8)
- (bytevector-u64-set! buf pos tag endianness)
- (bytevector-u64-set! buf (+ pos 8) len endianness))
- (else
- (error "bad word size" asm)))
- (let ((pos (+ pos (* word-size 2))))
- (case (string-bytes-per-char x)
- ((1)
- (let lp ((i 0))
- (if (< i len)
- (let ((u8 (char->integer (string-ref x i))))
- (bytevector-u8-set! buf (+ pos i) u8)
- (lp (1+ i)))
- (bytevector-u8-set! buf (+ pos i) 0))))
- ((4)
- (let lp ((i 0))
- (if (< i len)
- (let ((u32 (char->integer (string-ref x i))))
- (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
- (lp (1+ i)))
- (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
- (else (error "bad string bytes per char" x))))))
-
- ((static-procedure? obj)
- (case word-size
- ((4)
- (bytevector-u32-set! buf pos tc7-rtl-program endianness)
- (bytevector-u32-set! buf (+ pos 4) 0 endianness))
- ((8)
- (bytevector-u64-set! buf pos tc7-rtl-program endianness)
- (bytevector-u64-set! buf (+ pos 8) 0 endianness))
- (else (error "bad word size"))))
-
- ((cache-cell? obj)
- (write-immediate asm buf pos #f))
-
- ((string? obj)
- (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
- (case word-size
- ((4)
- (bytevector-u32-set! buf pos tc7-ro-string endianness)
- (write-immediate asm buf (+ pos 4) #f) ; stringbuf
- (bytevector-u32-set! buf (+ pos 8) 0 endianness)
- (bytevector-u32-set! buf (+ pos 12) (string-length obj)
endianness))
- ((8)
- (bytevector-u64-set! buf pos tc7-ro-string endianness)
- (write-immediate asm buf (+ pos 8) #f) ; stringbuf
- (bytevector-u64-set! buf (+ pos 16) 0 endianness)
- (bytevector-u64-set! buf (+ pos 24) (string-length obj)
endianness))
- (else (error "bad word size")))))
-
- ((pair? obj)
- (write-constant-reference buf pos (car obj))
- (write-constant-reference buf (+ pos word-size) (cdr obj)))
-
- ((vector? obj)
- (let* ((len (vector-length obj))
- (tag (logior tc7-vector (ash len 8))))
- (case word-size
- ((4) (bytevector-u32-set! buf pos tag endianness))
- ((8) (bytevector-u64-set! buf pos tag endianness))
- (else (error "bad word size")))
- (let lp ((i 0))
- (when (< i (vector-length obj))
- (let ((pos (+ pos word-size (* i word-size)))
- (elt (vector-ref obj i)))
- (write-constant-reference buf pos elt)
- (lp (1+ i)))))))
-
- ((symbol? obj)
- (write-immediate asm buf pos #f))
-
- ((keyword? obj)
- (write-immediate asm buf pos #f))
-
- ((number? obj)
- (write-immediate asm buf pos #f))
-
- (else
- (error "unrecognized object" obj))))
-
- (cond
- ((vlist-null? data) #f)
- (else
- (let* ((byte-len (vhash-fold (lambda (k v len)
- (+ (byte-length k) (align len 8)))
- 0 data))
- (buf (make-bytevector byte-len 0)))
- (let lp ((i 0) (pos 0) (labels '()))
- (if (< i (vlist-length data))
- (let* ((pair (vlist-ref data i))
- (obj (car pair))
- (obj-label (cdr pair)))
- (write buf pos obj)
- (lp (1+ i)
- (align (+ (byte-length obj) pos) 8)
- (cons (make-elf-symbol obj-label pos) labels)))
- (make-object asm name buf '() labels))))))))
-
-;; Hummm
-;;
-(define (link-constants asm)
- ;; Possibly three sections: one containing shareable read-only data,
- ;; one containing data that might be written to, and one text section
- ;; to initialize the pointers in the rwdata.
- ;;
- (define (shareable? x)
- (cond
- ((stringbuf? x) #t)
- ((pair? x)
- (and (immediate? (car x)) (immediate? (cdr x))))
- ((vector? x)
- (let lp ((i 0))
- (or (= i (vector-length x))
- (and (immediate? (vector-ref x i))
- (lp (1+ i))))))
- (else #f)))
- (let* ((constants (asm-constants asm))
- (len (vlist-length constants)))
- (let lp ((i 0)
- (ro vlist-null)
- (rw vlist-null))
- (if (= i len)
- (values (link-data asm ro '.rodata)
- (link-data asm rw '.data)
- (emit-init-constants asm))
- (let ((pair (vlist-ref constants i)))
- (if (shareable? (car pair))
- (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
- (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
-
-(define (link-objects asm)
- (call-with-values (lambda () (link-constants asm))
- (lambda (ro rw rw-init)
- (let* (;; Link text object after constants, so that the constants
- ;; initializer gets included.
- (text (link-text-object asm))
- (dt (link-dynamic-section asm text ro rw rw-init))
- ;; This needs to be linked last, because linking other
- ;; sections adds entries to the string table.
- (shstrtab (link-string-table asm)))
- (filter identity
- (list text ro rw dt shstrtab))))))
-
-(define (link-assembly asm)
- (link-elf (link-objects asm)))
-
-(define (assemble-program instructions)
- (let ((asm (make-assembler)))
- (emit-text asm instructions)
- (load-thunk-from-memory
- (link-elf (link-objects asm) #:page-aligned? #f))))
diff --git a/module/texinfo.scm b/module/texinfo.scm
index 519db48..91bb46d 100644
--- a/module/texinfo.scm
+++ b/module/texinfo.scm
@@ -1,6 +1,6 @@
;;;; (texinfo) -- parsing of texinfo into SXML
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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>
;;;;
@@ -187,6 +187,7 @@ lambda. Only present for @code{INLINE-ARGS},
@code{EOL-ARGS},
(sample INLINE-TEXT)
(samp INLINE-TEXT)
(code INLINE-TEXT)
+ (math INLINE-TEXT)
(kbd INLINE-TEXT)
(key INLINE-TEXT)
(var INLINE-TEXT)
@@ -215,7 +216,8 @@ lambda. Only present for @code{INLINE-ARGS},
@code{EOL-ARGS},
(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))
+ (pxref INLINE-TEXT-ARGS
+ . (node #:opt name section info-file manual))
(url ALIAS . uref)
(uref INLINE-ARGS . (url #:opt title replacement))
(anchor INLINE-ARGS . (name))
@@ -483,7 +485,7 @@ Examples:
(assert-curr-char '(#\@) "start of the command" port)
(let ((peeked (peek-char port)))
(cond
- ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\}))
+ ((memq peeked '(#\! #\: #\. #\? #\@ #\\ #\{ #\}))
;; @-commands that escape characters
(make-token 'STRING (string (read-char port))))
(else
diff --git a/module/texinfo/docbook.scm b/module/texinfo/docbook.scm
index c5a8d65..f3f993d 100644
--- a/module/texinfo/docbook.scm
+++ b/module/texinfo/docbook.scm
@@ -135,7 +135,7 @@ 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))
+ note itemizedlist informaltable))
(define (inline-command? command)
(not (memq command *sdocbook-block-commands*)))
diff --git a/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm
index 87e43e5..809cdb7 100644
--- a/module/texinfo/plain-text.scm
+++ b/module/texinfo/plain-text.scm
@@ -1,6 +1,6 @@
;;;; (texinfo plain-text) -- rendering stexinfo as plain text
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2013 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
@@ -31,6 +31,7 @@
#:use-module (sxml transform)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
+ #:use-module (ice-9 match)
#:export (stexi->plain-text))
;; The return value is a string.
@@ -95,13 +96,6 @@
(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
@@ -238,6 +232,7 @@
(sample ,code)
(samp ,code)
(code ,code)
+ (math ,passthrough)
(kbd ,code)
(key ,key)
(var ,var)
@@ -254,6 +249,7 @@
(sc ,var)
(copyright ,(lambda args "(C)"))
(result ,(lambda args "==>"))
+ (dots ,(lambda args "..."))
(xref ,ref)
(ref ,ref)
(pxref ,ref)
@@ -295,18 +291,18 @@
(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 "")))
+ (match tree
+ (() "")
+ ((? string?) tree)
+ (((? symbol? tag) body ...)
+ (let ((handler (and (not (ignored? tag))
+ (or (and=> (assq tag tag-handlers) cadr)
+ para))))
+ (if handler
+ (apply handler tree)
+ "")))
+ ((tree ...)
+ (string-concatenate (map-in-order stexi->plain-text tree)))
+ (_ "")))
;;; arch-tag: f966c3f6-3b46-4790-bbf9-3ad27e4917c2
diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm
index 1436ad5..d0c6f50 100644
--- a/module/texinfo/serialize.scm
+++ b/module/texinfo/serialize.scm
@@ -1,6 +1,6 @@
;;;; (texinfo serialize) -- rendering stexinfo as texinfo
;;;;
-;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2012, 2013 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
@@ -185,7 +185,8 @@
(define (wrap strings)
(fill-string (string-concatenate strings)
- #:line-width 72))
+ #:line-width 72
+ #:break-long-words? #f))
(define (paragraph exp lp command type formals args accum)
(list* "\n\n"
diff --git a/module/texinfo/string-utils.scm b/module/texinfo/string-utils.scm
index 7675149..22f969c 100644
--- a/module/texinfo/string-utils.scm
+++ b/module/texinfo/string-utils.scm
@@ -1,6 +1,6 @@
;;;; (texinfo string-utils) -- text filling and wrapping
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2013 Free Software Foundation, Inc.
;;;; Copyright (C) 2003 Richard Todd
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -262,6 +262,13 @@ the default value for @var{num} is 1.
;; did not find non-ws... only ws at end of the string...
(reverse ans))))))
+(define (end-of-sentence? str)
+ "Return #t when STR likely denotes the end of sentence."
+ (let ((len (string-length str)))
+ (and (> len 1)
+ (eqv? #\. (string-ref str (- len 1)))
+ (not (eqv? #\. (string-ref str (- len 2)))))))
+
(define* (make-text-wrapper #:key
(line-width 80)
(expand-tabs? #t)
@@ -352,7 +359,11 @@ returns a list of strings, where each element of the list
is one line."
length-left)
(loop ans
(cdr words)
- (string-append line next-word)
+ (if (and collapse-whitespace?
+ (end-of-sentence? line))
+ ;; Add an extra space after the period.
+ (string-append line " " next-word)
+ (string-append line next-word))
(+ count 1)))
;; ok, it didn't fit...is there already at least one word on the
line?
diff --git a/module/web/client.scm b/module/web/client.scm
index 9fbb25b..7d5ea49 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -248,10 +248,10 @@ pass it as PORT. The port will be closed at the end of
the
request unless KEEP-ALIVE? is true. Any extra headers in the
alist HEADERS will be added to the request.
-If BODY is not #f, a message body will also be sent with the HTTP
+If BODY is not â#fâ, a message body will also be sent with the HTTP
request. If BODY is a string, it is encoded according to the
content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be
-a bytevector, or #f for no body. Although it's allowed to send a
+a bytevector, or â#fâ for no body. Although it's allowed to send a
message body along with any request, usually only POST and PUT requests
have bodies. See âhttp-putâ and âhttp-postâ documentation, for more.
@@ -317,7 +317,7 @@ This function is similar to âhttp-getâ, except it uses
the \"HEAD\"
method. See âhttp-getâ for full documentation on the various keyword
arguments that are accepted by this function.
-Returns two values: the resulting response, and #f. Responses to HEAD
+Returns two values: the resulting response, and â#fâ. Responses to HEAD
requests do not have a body. The second value is only returned so that
other procedures can treat all of the http-foo verbs identically.")
diff --git a/module/web/http.scm b/module/web/http.scm
index c79d57d..35169ef 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -167,7 +167,7 @@ The default writer is âdisplayâ."
(define *eof* (call-with-input-string "" read))
(define (read-header port)
- "Reads one HTTP header from PORT. Returns two values: the header
+ "Read one HTTP header from PORT. Return two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.
@@ -220,7 +220,7 @@ as an ordered alist."
(define (write-headers headers port)
"Write the given header alist to PORT. Doesn't write the final
address@hidden, as the user might want to add another header."
+â\\r\\nâ, as the user might want to add another header."
(let lp ((headers headers))
(if (pair? headers)
(begin
@@ -702,29 +702,50 @@ as an ordered alist."
(else (bad))))
(else (bad))))))
+;; "GMT" | "+" 4DIGIT | "-" 4DIGIT
+;;
+;; RFC 2616 requires date values to use "GMT", but recommends accepting
+;; the others as they are commonly generated by e.g. RFC 822 sources.
+(define (parse-zone-offset str start)
+ (let ((s (substring str start)))
+ (define (bad)
+ (bad-header-component 'zone-offset s))
+ (cond
+ ((string=? s "GMT")
+ 0)
+ ((string-match? s ".dddd")
+ (let ((sign (case (string-ref s 0)
+ ((#\+) +1)
+ ((#\-) -1)
+ (else (bad))))
+ (hours (parse-non-negative-integer s 1 3))
+ (minutes (parse-non-negative-integer s 3 5)))
+ (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich
+ (else (bad)))))
+
;; RFC 822, updated by RFC 1123
;;
;; Sun, 06 Nov 1994 08:49:37 GMT
;; 01234567890123456789012345678
;; 0 1 2
-(define (parse-rfc-822-date str)
+(define (parse-rfc-822-date str space zone-offset)
;; We could verify the day of the week but we don't.
- (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
+ (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
(let ((date (parse-non-negative-integer str 5 7))
(month (parse-month str 8 11))
(year (parse-non-negative-integer str 12 16))
(hour (parse-non-negative-integer str 17 19))
(minute (parse-non-negative-integer str 20 22))
(second (parse-non-negative-integer str 23 25)))
- (make-date 0 second minute hour date month year 0)))
- ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
+ (make-date 0 second minute hour date month year zone-offset)))
+ ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
(let ((date (parse-non-negative-integer str 5 6))
(month (parse-month str 7 10))
(year (parse-non-negative-integer str 11 15))
(hour (parse-non-negative-integer str 16 18))
(minute (parse-non-negative-integer str 19 21))
(second (parse-non-negative-integer str 22 24)))
- (make-date 0 second minute hour date month year 0)))
+ (make-date 0 second minute hour date month year zone-offset)))
(else
(bad-header 'date str) ; prevent tail call
#f)))
@@ -733,10 +754,10 @@ as an ordered alist."
;; Sunday, 06-Nov-94 08:49:37 GMT
;; 0123456789012345678901
;; 0 1 2
-(define (parse-rfc-850-date str comma)
+(define (parse-rfc-850-date str comma space zone-offset)
;; We could verify the day of the week but we don't.
- (let ((tail (substring str (1+ comma))))
- (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
+ (let ((tail (substring str (1+ comma) space)))
+ (if (not (string-match? tail " dd-aaa-dd dd:dd:dd"))
(bad-header 'date str))
(let ((date (parse-non-negative-integer tail 1 3))
(month (parse-month tail 4 7))
@@ -750,7 +771,7 @@ as an ordered alist."
(cond ((< (+ then 50) now) (+ then 100))
((< (+ now 50) then) (- then 100))
(else then)))
- 0))))
+ zone-offset))))
;; ANSI C's asctime() format
;; Sun Nov 6 08:49:37 1994
@@ -770,13 +791,23 @@ as an ordered alist."
(second (parse-non-negative-integer str 17 19)))
(make-date 0 second minute hour date month year 0)))
+;; Convert all date values to GMT time zone, as per RFC 2616 appendix C.
+(define (normalize-date date)
+ (if (zero? (date-zone-offset date))
+ date
+ (time-utc->date (date->time-utc date) 0)))
+
(define (parse-date str)
- (if (string-suffix? " GMT" str)
- (let ((comma (string-index str #\,)))
- (cond ((not comma) (bad-header 'date str))
- ((= comma 3) (parse-rfc-822-date str))
- (else (parse-rfc-850-date str comma))))
- (parse-asctime-date str)))
+ (let* ((space (string-rindex str #\space))
+ (zone-offset (and space (false-if-exception
+ (parse-zone-offset str (1+ space))))))
+ (normalize-date
+ (if zone-offset
+ (let ((comma (string-index str #\,)))
+ (cond ((not comma) (bad-header 'date str))
+ ((= comma 3) (parse-rfc-822-date str space zone-offset))
+ (else (parse-rfc-850-date str comma space zone-offset))))
+ (parse-asctime-date str)))))
(define (write-date date port)
(define (display-digits n digits port)
@@ -971,7 +1002,7 @@ as an ordered alist."
(define *known-versions* '())
(define* (parse-http-version str #:optional (start 0) (end (string-length
str)))
- "Parse an HTTP version from STR, returning it as a major-minor
+ "Parse an HTTP version from STR, returning it as a majorâminor
pair. For example, âHTTP/1.1â parses as the pair of integers,
â(1 . 1)â."
(or (let lp ((known *known-versions*))
@@ -1628,18 +1659,32 @@ treated specially, and is just returned as a plain
string."
;;
(declare-header! "Host"
(lambda (str)
- (let ((colon (string-index str #\:)))
- (if colon
- (cons (substring str 0 colon)
- (parse-non-negative-integer str (1+ colon)))
- (cons str #f))))
+ (let* ((rbracket (string-index str #\]))
+ (colon (string-index str #\: (or rbracket 0)))
+ (host (cond
+ (rbracket
+ (unless (eqv? (string-ref str 0) #\[)
+ (bad-header 'host str))
+ (substring str 1 rbracket))
+ (colon
+ (substring str 0 colon))
+ (else
+ str)))
+ (port (and colon
+ (parse-non-negative-integer str (1+ colon)))))
+ (cons host port)))
(lambda (val)
(and (pair? val)
(string? (car val))
(or (not (cdr val))
(non-negative-integer? (cdr val)))))
(lambda (val port)
- (display (car val) port)
+ (if (string-index (car val) #\:)
+ (begin
+ (display #\[ port)
+ (display (car val) port)
+ (display #\] port))
+ (display (car val) port))
(if (cdr val)
(begin
(display #\: port)
diff --git a/module/web/response.scm b/module/web/response.scm
index 7e14f4d..570a2d7 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -267,19 +267,32 @@ closes PORT, unless KEEP-ALIVE? is true."
(define* (response-body-port r #:key (decode? #t) (keep-alive? #t))
"Return an input port from which the body of R can be read. The
encoding of the returned port is set according to R's âcontent-typeâ
-header, when it's textual, except if DECODE? is #f. Return #f when no
-body is available.
+header, when it's textual, except if DECODE? is â#fâ. Return #f when
+no body is available.
-When KEEP-ALIVE? is #f, closing the returned port also closes R's
+When KEEP-ALIVE? is â#fâ, closing the returned port also closes R's
response port."
(define port
- (if (member '(chunked) (response-transfer-encoding r))
- (make-chunked-input-port (response-port r)
- #:keep-alive? keep-alive?)
- (let ((len (response-content-length r)))
- (and len
- (make-delimited-input-port (response-port r)
- len keep-alive?)))))
+ (cond
+ ((member '(chunked) (response-transfer-encoding r))
+ (make-chunked-input-port (response-port r)
+ #:keep-alive? keep-alive?))
+ ((response-content-length r)
+ => (lambda (len)
+ (make-delimited-input-port (response-port r)
+ len keep-alive?)))
+ ((response-must-not-include-body? r)
+ #f)
+ ((or (memq 'close (response-connection r))
+ (and (equal? (response-version r) '(1 . 0))
+ (not (memq 'keep-alive (response-connection r)))))
+ (response-port r))
+ (else
+ ;; Here we have a message with no transfer encoding, no
+ ;; content-length, and a response that won't necessarily be closed
+ ;; by the server. Not much we can do; assume that the client
+ ;; knows how to handle it.
+ (response-port r))))
(when (and decode? port)
(match (response-content-type r)
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 25406b3..7fe0100 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -53,8 +53,8 @@
(query uri-query)
(fragment uri-fragment))
-(define (absolute-uri? x)
- (and (uri? x) (uri-scheme x) #t))
+(define (absolute-uri? obj)
+ (and (uri? obj) (uri-scheme obj) #t))
(define (uri-error message . args)
(throw 'uri-error message args))
@@ -309,17 +309,16 @@ serialization."
which should be the name of a character encoding.
Note that this function should not generally be applied to a full URI
-string. For paths, use split-and-decode-uri-path instead. For query
+string. For paths, use âsplit-and-decode-uri-pathâ instead. For query
strings, split the query on â&â and â=â boundaries, and decode
the components separately.
-Note also that percent-encoded strings encode @emph{bytes}, not
-characters. There is no guarantee that a given byte sequence is a valid
-string encoding. Therefore this routine may signal an error if the
-decoded bytes are not valid for the given encoding. Pass â#fâ for
-ENCODING if you want decoded bytes as a bytevector directly.
address@hidden, âset-port-encoding!â}, for more information on
-character encodings.
+Note also that percent-encoded strings encode _bytes_, not characters.
+There is no guarantee that a given byte sequence is a valid string
+encoding. Therefore this routine may signal an error if the decoded
+bytes are not valid for the given encoding. Pass â#fâ for ENCODING if
+you want decoded bytes as a bytevector directly. âset-port-encoding!â,
+for more information on character encodings.
Returns a string of the decoded characters, or a bytevector if
ENCODING was â#fâ."
@@ -380,11 +379,10 @@ ENCODING was â#fâ."
UNESCAPED-CHARS.
The default character set includes alphanumerics from ASCII, as well as
-the special characters @samp{-}, @samp{.}, @samp{_}, and @samp{~}. Any
-other character will be percent-encoded, by writing out the character to
-a bytevector within the given ENCODING, then encoding each byte as
-â%HHâ, where HH is the hexadecimal representation of
-the byte."
+the special characters â-â, â.â, â_â, and â~â. Any other
character will
+be percent-encoded, by writing out the character to a bytevector within
+the given ENCODING, then encoding each byte as â%HHâ, where HH is the
+hexadecimal representation of the byte."
(define (needs-escaped? ch)
(not (char-set-contains? unescaped-chars ch)))
(if (string-index str needs-escaped?)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 213025b..fad64b7 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -133,6 +133,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-37.test \
tests/srfi-38.test \
tests/srfi-39.test \
+ tests/srfi-41.test \
tests/srfi-42.test \
tests/srfi-45.test \
tests/srfi-60.test \
diff --git a/test-suite/standalone/Makefile.am
b/test-suite/standalone/Makefile.am
index daa3d07..5c0c6a7 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-## 2011, 2012 Free Software Foundation, Inc.
+## 2011, 2012, 2013 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -31,12 +31,13 @@ BUILT_SOURCES =
EXTRA_DIST =
TESTS_ENVIRONMENT = \
+ top_srcdir="$(top_srcdir)" \
srcdir="$(srcdir)" \
builddir="$(builddir)" \
@LOCALCHARSET_TESTS_ENVIRONMENT@ \
GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
-## Check for headers in $(srcdir) and bulid dir before $(CPPFLAGS), which
+## Check for headers in $(srcdir) and build dir before $(CPPFLAGS), which
## may point us to an old, installed version of guile.
AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
@@ -88,6 +89,10 @@ TESTS += test-command-line-encoding
check_SCRIPTS += test-command-line-encoding2
TESTS += test-command-line-encoding2
+check_SCRIPTS += test-language
+TESTS += test-language
+EXTRA_DIST += test-language.el test-language.js
+
# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
@@ -199,6 +204,13 @@ test_scm_values_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-scm-values
TESTS += test-scm-values
+# test-scm-c-bind-keyword-arguments
+test_scm_c_bind_keyword_arguments_SOURCES = test-scm-c-bind-keyword-arguments.c
+test_scm_c_bind_keyword_arguments_CFLAGS = ${test_cflags}
+test_scm_c_bind_keyword_arguments_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-scm-c-bind-keyword-arguments
+TESTS += test-scm-c-bind-keyword-arguments
+
if HAVE_SHARED_LIBRARIES
# test-extensions
@@ -246,4 +258,10 @@ EXTRA_DIST += test-with-guile-module.c
test-scm-with-guile.c
endif
+test_smob_mark_SOURCES = test-smob-mark.c
+test_smob_mark_CFLAGS = ${test_cflags}
+test_smob_mark_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-smob-mark
+TESTS += test-smob-mark
+
EXTRA_DIST += ${check_SCRIPTS}
diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi
index ad68660..0a91f63 100755
--- a/test-suite/standalone/test-ffi
+++ b/test-suite/standalone/test-ffi
@@ -170,6 +170,21 @@ exec guile -q -s "$0" "$@"
(+ -1 2000 -30000 40000000000))
;;
+;; More than ten arguments
+;;
+(define f-sum-many
+ (pointer->procedure int64 (dynamic-func "test_ffi_sum_many" lib)
+ (list uint8 uint16 uint32 uint64
+ int8 int16 int32 int64
+ int8 int16 int32 int64)))
+(test (f-sum-many 255 65535 4294967295 1844674407370955161
+ -1 2000 -30000 40000000000
+ 5 -6000 70000 -80000000000)
+ (+ 255 65535 4294967295 1844674407370955161
+ -1 2000 -30000 40000000000
+ 5 -6000 70000 -80000000000))
+
+;;
;; Structs
;;
(define f-sum-struct
diff --git a/test-suite/standalone/test-ffi-lib.c
b/test-suite/standalone/test-ffi-lib.c
index 37d6e43..f265339 100644
--- a/test-suite/standalone/test-ffi-lib.c
+++ b/test-suite/standalone/test-ffi-lib.c
@@ -194,6 +194,23 @@ scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
}
+scm_t_int64 test_ffi_sum_many (scm_t_uint8 a, scm_t_uint16 b,
+ scm_t_uint32 c, scm_t_uint64 d,
+ scm_t_int8 e, scm_t_int16 f,
+ scm_t_int32 g, scm_t_int64 h,
+ scm_t_int8 i, scm_t_int16 j,
+ scm_t_int32 k, scm_t_int64 l);
+scm_t_int64 test_ffi_sum_many (scm_t_uint8 a, scm_t_uint16 b,
+ scm_t_uint32 c, scm_t_uint64 d,
+ scm_t_int8 e, scm_t_int16 f,
+ scm_t_int32 g, scm_t_int64 h,
+ scm_t_int8 i, scm_t_int16 j,
+ scm_t_int32 k, scm_t_int64 l)
+{
+ return l + k + j + i + h + g + f + e + d + c + b + a;
+}
+
+
struct foo
{
scm_t_int8 a;
diff --git a/test-suite/standalone/test-language
b/test-suite/standalone/test-language
new file mode 100755
index 0000000..59ed82b
--- /dev/null
+++ b/test-suite/standalone/test-language
@@ -0,0 +1,25 @@
+#!/bin/sh
+
+set -e
+
+# Make sure that code passed as `-c' or `-l' is evaluted using the
+# right language.
+
+# The default language in effect until `--language' is encountered is
+# Scheme.
+guile -c "(exit (= 3 (apply + '(1 2))))" --language=elisp
+! guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null
+
+guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)"
+guile --language=ecmascript -c '(function (x) { return x * x; })(2);'
+
+# Same with `-l'.
+guile --no-auto-compile -l "$top_srcdir/module/ice-9/q.scm" -c 1
+guile --no-auto-compile \
+ -l "$top_srcdir/module/ice-9/q.scm" \
+ --language=elisp \
+ -l "$srcdir/test-language.el" \
+ --language=ecmascript \
+ -l "$srcdir/test-language.js" \
+ --language=scheme \
+ -c 1
diff --git a/test-suite/standalone/test-language.el
b/test-suite/standalone/test-language.el
new file mode 100644
index 0000000..c1f09cc
--- /dev/null
+++ b/test-suite/standalone/test-language.el
@@ -0,0 +1,11 @@
+;; Sample Elisp code for `test-language'.
+
+(defun fib (n)
+ "Anything but a fib."
+ (if (<= n 1)
+ n
+ (+ (fib (- n 1))
+ (fib (- n 2)))))
+
+(or (= 13 (fib 7))
+ (error "Something's wrong!"))
diff --git a/test-suite/standalone/test-language.js
b/test-suite/standalone/test-language.js
new file mode 100644
index 0000000..c8de366
--- /dev/null
+++ b/test-suite/standalone/test-language.js
@@ -0,0 +1,12 @@
+/* Sample ECMAscript code for `test-language'. */
+
+function fib (n)
+{
+ if (n <= 1)
+ return n;
+ else
+ return fib (n - 1) + fib (n - 2);
+}
+
+if (fib (7) != 13)
+ error ("Something's wrong!");
diff --git a/test-suite/standalone/test-pthread-create-secondary.c
b/test-suite/standalone/test-pthread-create-secondary.c
index e145fa5..14ea240 100644
--- a/test-suite/standalone/test-pthread-create-secondary.c
+++ b/test-suite/standalone/test-pthread-create-secondary.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2011, 2013 Free Software 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,15 +30,20 @@
#include <gc/gc.h>
-/* Up to GC 7.2alpha5, calling `GC_INIT' from a secondary thread would
+/* Currently, calling `GC_INIT' from a secondary thread is only
+ supported on some systems, notably Linux-based systems (and not on
+ FreeBSD, for instance.)
+
+ Up to GC 7.2alpha5, calling `GC_INIT' from a secondary thread would
lead to a segfault. This was fixed in BDW-GC on 2011-04-16 by Ivan
Maidanski. See <http://thread.gmane.org/gmane.lisp.guile.bugs/5340>
for details. */
-#if (GC_VERSION_MAJOR > 7) \
- || ((GC_VERSION_MAJOR == 7) && (GC_VERSION_MINOR > 2)) \
- || ((GC_VERSION_MAJOR == 7) && (GC_VERSION_MINOR == 2) \
- && (GC_ALPHA_VERSION > 5))
+#if defined __linux__ \
+ && (GC_VERSION_MAJOR > 7 \
+ || (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR > 2) \
+ || (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR == 2 \
+ && GC_ALPHA_VERSION > 5))
static void *
do_something (void *arg)
@@ -73,7 +78,7 @@ main (int argc, char *argv[])
}
-#else /* GC < 7.2 */
+#else /* Linux && GC < 7.2alpha5 */
int
main (int argc, char *argv[])
diff --git a/test-suite/standalone/test-round.c
b/test-suite/standalone/test-round.c
index f1458af..150c881 100644
--- a/test-suite/standalone/test-round.c
+++ b/test-suite/standalone/test-round.c
@@ -25,7 +25,16 @@
#include <stdio.h>
#if HAVE_FENV_H
-#include <fenv.h>
+# if defined __GNUC__ && defined __GLIBC__
+/* In Glibc 2.17, <bits/fenv.h> defines `feraiseexcept' as an inline
+ without declaring it first, so ignore the warning. */
+# pragma GCC diagnostic push
+# pragma GCC diagnostic ignored "-Wmissing-prototypes"
+# endif
+# include <fenv.h>
+# if defined __GNUC__ && defined __GLIBC__
+# pragma GCC diagnostic pop
+# endif
#elif defined HAVE_MACHINE_FPU_H
/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>.
On NetBSD, this header has to be included along with <sys/types.h>. */
diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
new file mode 100644
index 0000000..6fcf821
--- /dev/null
+++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c
@@ -0,0 +1,201 @@
+/* Copyright (C) 2013 Free Software 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.h>
+
+#include <assert.h>
+
+static SCM
+error_handler (void *data, SCM key, SCM args)
+{
+ SCM expected_args = scm_list_n (scm_from_utf8_string ("test"),
+ scm_from_utf8_string ((char *) data),
+ SCM_EOL, SCM_BOOL_F,
+ SCM_UNDEFINED);
+
+ assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error")));
+ assert (scm_is_true (scm_equal_p (args, expected_args)));
+
+ return SCM_BOOL_T;
+}
+
+static SCM
+test_unrecognized_keyword (void *data)
+{
+ SCM k_foo = scm_from_utf8_keyword ("foo");
+ SCM k_bar = scm_from_utf8_keyword ("bar");
+ SCM k_baz = scm_from_utf8_keyword ("baz");
+ SCM arg_foo, arg_bar;
+
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (k_foo, SCM_EOL,
+ k_baz, SCM_BOOL_T,
+ SCM_UNDEFINED),
+ SCM_ALLOW_NON_KEYWORD_ARGUMENTS,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (0);
+}
+
+static SCM
+test_invalid_keyword (void *data)
+{
+ SCM k_foo = scm_from_utf8_keyword ("foo");
+ SCM k_bar = scm_from_utf8_keyword ("bar");
+ SCM arg_foo, arg_bar;
+
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (k_foo, SCM_EOL,
+ SCM_INUM0, SCM_INUM1,
+ SCM_UNDEFINED),
+ SCM_ALLOW_OTHER_KEYS,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (0);
+}
+
+static SCM
+test_odd_length (void *data)
+{
+ SCM k_foo = scm_from_utf8_keyword ("foo");
+ SCM k_bar = scm_from_utf8_keyword ("bar");
+ SCM arg_foo, arg_bar;
+
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (k_foo, SCM_EOL,
+ SCM_INUM0,
+ SCM_UNDEFINED),
+ SCM_ALLOW_OTHER_KEYS,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (0);
+}
+
+static void
+test_scm_c_bind_keyword_arguments ()
+{
+ SCM k_foo = scm_from_utf8_keyword ("foo");
+ SCM k_bar = scm_from_utf8_keyword ("bar");
+ SCM k_baz = scm_from_utf8_keyword ("baz");
+ SCM arg_foo, arg_bar;
+
+ /* All kwargs provided. */
+ arg_foo = SCM_INUM0;
+ arg_bar = SCM_INUM1;
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (k_bar, SCM_EOL,
+ k_foo, SCM_BOOL_T,
+ SCM_UNDEFINED),
+ 0,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (scm_is_eq (arg_foo, SCM_BOOL_T));
+ assert (scm_is_eq (arg_bar, SCM_EOL));
+
+ /* Some kwargs provided. */
+ arg_foo = SCM_INUM0;
+ arg_bar = SCM_INUM1;
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (k_bar, SCM_EOL,
+ SCM_UNDEFINED),
+ 0,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (scm_is_eq (arg_foo, SCM_INUM0));
+ assert (scm_is_eq (arg_bar, SCM_EOL));
+
+ /* No kwargs provided. */
+ arg_foo = SCM_INUM0;
+ arg_bar = SCM_INUM1;
+ scm_c_bind_keyword_arguments ("test",
+ SCM_EOL,
+ 0,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (scm_is_eq (arg_foo, SCM_INUM0));
+ assert (scm_is_eq (arg_bar, SCM_INUM1));
+
+ /* Other kwargs provided, when allowed. */
+ arg_foo = SCM_INUM0;
+ arg_bar = SCM_INUM1;
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (k_foo, SCM_EOL,
+ k_baz, SCM_BOOL_T,
+ SCM_UNDEFINED),
+ SCM_ALLOW_OTHER_KEYS,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (scm_is_eq (arg_foo, SCM_EOL));
+ assert (scm_is_eq (arg_bar, SCM_INUM1));
+
+ /* Other non-kwargs provided, when allowed. */
+ arg_foo = SCM_INUM0;
+ arg_bar = SCM_INUM1;
+ scm_c_bind_keyword_arguments ("test",
+ scm_list_n (SCM_BOOL_F,
+ k_foo, SCM_EOL,
+ SCM_INUM0,
+ k_bar, SCM_BOOL_T,
+ SCM_INUM1,
+ SCM_UNDEFINED),
+ SCM_ALLOW_NON_KEYWORD_ARGUMENTS,
+ k_foo, &arg_foo,
+ k_bar, &arg_bar,
+ SCM_UNDEFINED);
+ assert (scm_is_eq (arg_foo, SCM_EOL));
+ assert (scm_is_eq (arg_bar, SCM_BOOL_T));
+
+ /* Test unrecognized keyword error. */
+ scm_internal_catch (SCM_BOOL_T,
+ test_unrecognized_keyword, NULL,
+ error_handler, "Unrecognized keyword");
+
+ /* Test invalid keyword error. */
+ scm_internal_catch (SCM_BOOL_T,
+ test_invalid_keyword, NULL,
+ error_handler, "Invalid keyword");
+
+ /* Test odd length error. */
+ scm_internal_catch (SCM_BOOL_T,
+ test_odd_length, NULL,
+ error_handler, "Odd length of keyword argument list");
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_scm_c_bind_keyword_arguments ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
diff --git a/test-suite/standalone/test-smob-mark.c
b/test-suite/standalone/test-smob-mark.c
new file mode 100644
index 0000000..d9db9a6
--- /dev/null
+++ b/test-suite/standalone/test-smob-mark.c
@@ -0,0 +1,133 @@
+/* Copyright (C) 2013 Free Software 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 <assert.h>
+#include <libguile.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define SMOBS_COUNT (10000)
+
+struct x_tag
+{
+ SCM scm_value;
+ int c_value;
+};
+
+typedef struct x_tag x_t;
+
+unsigned int mark_call_count = 0;
+
+static scm_t_bits x_tag;
+static SCM make_x (void);
+static SCM mark_x (SCM x);
+static int print_x (SCM x, SCM port, scm_print_state * pstate);
+static size_t free_x (SCM x);
+static void init_smob_type (void);
+static void test_scm_smob_mark (void);
+
+static SCM
+make_x ()
+{
+ static int i = 0;
+ SCM s_x;
+ x_t *c_x;
+
+ i++;
+ c_x = (x_t *) scm_gc_malloc (sizeof (x_t), "x");
+ c_x->scm_value = scm_from_int (i);
+ c_x->c_value = i;
+ SCM_NEWSMOB (s_x, x_tag, c_x);
+ return s_x;
+}
+
+static SCM
+mark_x (SCM x)
+{
+ x_t *c_x;
+ c_x = (x_t *) SCM_SMOB_DATA (x);
+ scm_gc_mark (c_x->scm_value);
+ mark_call_count++;
+ return SCM_BOOL_F;
+}
+
+static size_t
+free_x (SCM x)
+{
+ x_t *c_x;
+ c_x = (x_t *) SCM_SMOB_DATA (x);
+ scm_gc_free (c_x, sizeof (x_t), "x");
+ c_x = NULL;
+ return 0;
+}
+
+static int
+print_x (SCM x, SCM port, scm_print_state * pstate SCM_UNUSED)
+{
+ x_t *c_x = (x_t *) SCM_SMOB_DATA (x);
+ scm_puts ("#<x ", port);
+ if (c_x == (x_t *) NULL)
+ scm_puts ("(freed)", port);
+ else
+ scm_write (c_x->scm_value, port);
+ scm_puts (">", port);
+
+ return 1;
+}
+
+static void
+test_scm_smob_mark ()
+{
+ int i;
+ mark_call_count = 0;
+ for (i = 0; i < SMOBS_COUNT; i++)
+ make_x ();
+ scm_gc ();
+ if (mark_call_count < SMOBS_COUNT)
+ {
+ fprintf (stderr, "FAIL: SMOB mark function called for each SMOB\n");
+ exit (EXIT_FAILURE);
+ }
+}
+
+static void
+init_smob_type ()
+{
+ x_tag = scm_make_smob_type ("x", sizeof (x_t));
+ scm_set_smob_free (x_tag, free_x);
+ scm_set_smob_print (x_tag, print_x);
+ scm_set_smob_mark (x_tag, mark_x);
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ init_smob_type ();
+ test_scm_smob_mark ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 7517b4e..e25df78 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -1,6 +1,6 @@
;;;; test-suite/lib.scm --- generic support for testing
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
-;;;; 2011, 2012 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013 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
@@ -469,13 +469,18 @@
(with-test-prefix* prefix (lambda () body ...)))))
(define-syntax c&e
- (syntax-rules (pass-if pass-if-exception)
+ (syntax-rules (pass-if pass-if-equal pass-if-exception)
"Run the given tests both with the evaluator and the compiler/VM."
((_ (pass-if test-name exp))
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
(pass-if (string-append test-name " (compile)")
(compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-equal test-name val exp))
+ (begin (pass-if-equal (string-append test-name " (eval)") val
+ (primitive-eval 'exp))
+ (pass-if-equal (string-append test-name " (compile)") val
+ (compile 'exp #:to 'value #:env (current-module)))))
((_ (pass-if-exception test-name exc exp))
(begin (pass-if-exception (string-append test-name " (eval)")
exc (primitive-eval 'exp))
diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test
index e74d376..30a0257 100644
--- a/test-suite/tests/00-socket.test
+++ b/test-suite/tests/00-socket.test
@@ -1,7 +1,7 @@
;;;; 00-socket.test --- test socket functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;;;; 2011, 2012 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -339,7 +339,7 @@
(if (not server-pid)
(throw 'unresolved)
(let ((status (cdr (waitpid server-pid))))
- (eq? 0 (status:exit-val status)))))
+ (eqv? 0 (status:exit-val status)))))
(false-if-exception (delete-file path))
@@ -412,7 +412,7 @@
(if (not server-pid)
(throw 'unresolved)
(let ((status (cdr (waitpid server-pid))))
- (eq? 0 (status:exit-val status)))))
+ (eqv? 0 (status:exit-val status)))))
(false-if-exception (delete-file path))
@@ -445,6 +445,14 @@
(lambda args
(let ((errno (system-error-errno args)))
(cond ((= errno EADDRINUSE) (throw 'unresolved))
+
+ ;; On Linux-based systems, when `ipv6' support is
+ ;; missing (for instance, `ipv6' is loaded and
+ ;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set
+ ;; to 1), the socket call above succeeds but
+ ;; bind(2) fails like this.
+ ((= errno EADDRNOTAVAIL) (throw 'unresolved))
+
(else (apply throw args)))))))
(pass-if "bind/sockaddr"
@@ -459,6 +467,7 @@
(lambda args
(let ((errno (system-error-errno args)))
(cond ((= errno EADDRINUSE) (throw 'unresolved))
+ ((= errno EADDRNOTAVAIL) (throw 'unresolved))
(else (apply throw args))))))))
(pass-if "listen"
@@ -508,7 +517,7 @@
(if (not server-pid)
(throw 'unresolved)
(let ((status (cdr (waitpid server-pid))))
- (eq? 0 (status:exit-val status)))))
+ (eqv? 0 (status:exit-val status)))))
#t)))
diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test
index 699c10e..0ed5d22 100644
--- a/test-suite/tests/alist.test
+++ b/test-suite/tests/alist.test
@@ -124,8 +124,8 @@
(pass-if "assoc-ref"
(let ((x (assoc-ref b "one")))
(and (list? x)
- (eq? (car x) 2)
- (eq? (cadr x) 3))))
+ (eqv? (car x) 2)
+ (eqv? (cadr x) 3))))
(pass-if-not "assoc-ref not" (assoc-ref a 'testing))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index f13b1a2..0b3d57c 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -1,6 +1,6 @@
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
-;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation,
Inc.
+;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -228,26 +228,6 @@
(array->list b))))
;;;
-;;; generalized-vector->list
-;;;
-
-(with-test-prefix "generalized-vector->list"
- (pass-if-equal '(1 2 3) (generalized-vector->list #s16(1 2 3)))
- (pass-if-equal '(1 2 3) (generalized-vector->list #(1 2 3)))
- (pass-if-equal '() (generalized-vector->list #()))
-
- (pass-if-equal "http://bugs.gnu.org/12465 - ok"
- '(3 4)
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2)))
- (generalized-vector->list b)))
- (pass-if-equal "http://bugs.gnu.org/12465 - bad"
- '(2 4)
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (i) (list i 1)) 2)))
- (generalized-vector->list b))))
-
-;;;
;;; array-fill!
;;;
@@ -311,7 +291,55 @@
(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))))
+ (pass-if "5/8" (array-fill! a 5/8) #t)))
+
+ (with-test-prefix "noncompact"
+ (let* ((a (make-array 0 3 3))
+ (b (make-shared-array a (lambda (i) (list i i)) 3)))
+ (array-fill! b 9)
+ (pass-if
+ (and (equal? b #(9 9 9))
+ (equal? a #2((9 0 0) (0 9 0) (0 0 9))))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (pass-if "rank 2"
+ (let ((a #2((1 2) (3 4)))
+ (b (make-array 0 2 2))
+ (c (make-array 0 2 2))
+ (d (make-array 0 2 2))
+ (e (make-array 0 2 2)))
+ (array-copy! a b)
+ (array-copy! a (transpose-array c 1 0))
+ (array-copy! (transpose-array a 1 0) d)
+ (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+ (and (equal? a #2((1 2) (3 4)))
+ (equal? b #2((1 2) (3 4)))
+ (equal? c #2((1 3) (2 4)))
+ (equal? d #2((1 3) (2 4)))
+ (equal? e #2((1 2) (3 4))))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99)))))
+
;;;
;;; array-in-bounds?
@@ -451,7 +479,7 @@
(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
+ (pass-if-exception "two indexes" exception:wrong-num-indices
(array-set! a 'y 6 7))))
(with-test-prefix "two dim"
@@ -649,6 +677,4 @@
(pass-if (equal? (array-row array 1)
#u32(2 3)))
(pass-if (equal? (array-ref (array-row array 1) 0)
- 2))
- (pass-if (equal? (generalized-vector-ref (array-row array 1) 0)
2))))
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index ddbe2ee..688e752 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -1,6 +1,6 @@
;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -134,6 +134,9 @@
(define (native-cpu)
(with-target %host-type target-cpu))
+(define (native-os)
+ (with-target %host-type target-os))
+
(define (native-word-size)
((@ (system foreign) sizeof) '*))
@@ -154,7 +157,8 @@
;; actually has a 32-bit user-land, for instance (see
;; <http://www.debian.org/ports/sparc/#sparc64bit>
;; for details.)
- (if (string=? (native-cpu) (target-cpu))
+ (if (and (string=? (native-cpu) (target-cpu))
+ (string=? (native-os) (target-os)))
(native-word-size)
word-size))
(b (compile-bytecode
@@ -187,6 +191,13 @@
(test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
(test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
+ (endianness little) 4)
+ (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
+ (endianness little) 8)
+ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
+ (endianness little) 4)
+
(pass-if-exception "unknown target"
exception:miscellaneous-error
(call-with-values (lambda ()
diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test
index c16fb4d..4e32c61 100644
--- a/test-suite/tests/bitvectors.test
+++ b/test-suite/tests/bitvectors.test
@@ -1,6 +1,6 @@
;;;; bitvectors.test --- tests guile's bitvectors -*- scheme -*-
;;;;
-;;;; Copyright 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright 2010, 2011, 2013 Free Software 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,7 +22,6 @@
(with-test-prefix "predicates"
(pass-if (bitvector? #*1010101010))
- (pass-if (generalized-vector? #*1010101010))
(pass-if (uniform-vector? #*1010101010))
(pass-if (array? #*1010101010)))
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
index 4ba5012..67fc680 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,6 +1,6 @@
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -589,42 +589,42 @@
(with-input-from-string "#vu8(0 256)" read)))
-(with-test-prefix "Generalized Vectors"
+(with-test-prefix "Arrays"
- (pass-if "generalized-vector?"
- (generalized-vector? #vu8(1 2 3)))
+ (pass-if "array?"
+ (array? #vu8(1 2 3)))
- (pass-if "generalized-vector-length"
+ (pass-if "array-length"
(equal? (iota 16)
- (map generalized-vector-length
+ (map array-length
(map make-bytevector (iota 16)))))
- (pass-if "generalized-vector-ref"
+ (pass-if "array-ref"
(let ((bv #vu8(255 127)))
- (and (= 255 (generalized-vector-ref bv 0))
- (= 127 (generalized-vector-ref bv 1)))))
+ (and (= 255 (array-ref bv 0))
+ (= 127 (array-ref bv 1)))))
- (pass-if-exception "generalized-vector-ref [index out-of-range]"
+ (pass-if-exception "array-ref [index out-of-range]"
exception:out-of-range
(let ((bv #vu8(1 2)))
- (generalized-vector-ref bv 2)))
+ (array-ref bv 2)))
- (pass-if "generalized-vector-set!"
+ (pass-if "array-set!"
(let ((bv (make-bytevector 2)))
- (generalized-vector-set! bv 0 255)
- (generalized-vector-set! bv 1 77)
+ (array-set! bv 255 0)
+ (array-set! bv 77 1)
(equal? '(255 77)
(bytevector->u8-list bv))))
- (pass-if-exception "generalized-vector-set! [index out-of-range]"
+ (pass-if-exception "array-set! [index out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
- (generalized-vector-set! bv 2 0)))
+ (array-set! bv 0 2)))
- (pass-if-exception "generalized-vector-set! [value out-of-range]"
+ (pass-if-exception "array-set! [value out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
- (generalized-vector-set! bv 0 256)))
+ (array-set! bv 256 0)))
(pass-if "array-type"
(eq? 'vu8 (array-type #vu8())))
diff --git a/test-suite/tests/coding.test b/test-suite/tests/coding.test
index 4152af8..a8a415f 100644
--- a/test-suite/tests/coding.test
+++ b/test-suite/tests/coding.test
@@ -1,6 +1,6 @@
;;;; coding.test --- test suite for coding declarations. -*- mode: scheme -*-
;;;;
-;;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -40,65 +40,65 @@
;; relies on the opportunistic filling of the input buffer, which
;; doesn't happen after a seek.
(let* ((port (open-input-file name))
- (res (port-encoding port)))
+ (res (file-encoding port)))
(close-port port)
res))))
(with-test-prefix "block comments"
- (pass-if "first line"
- (equal? (scan-coding "#! coding: iso-8859-1 !#")
- "ISO-8859-1"))
-
- (pass-if "first line no whitespace"
- (equal? (scan-coding "#!coding:iso-8859-1!#")
- "ISO-8859-1"))
-
- (pass-if "second line"
- (equal? (scan-coding "#! \n coding: iso-8859-1 !#")
- "ISO-8859-1"))
-
- (pass-if "second line no whitespace"
- (equal? (scan-coding "#!\ncoding:iso-8859-1!#")
- "ISO-8859-1"))
-
- (pass-if "third line"
- (equal? (scan-coding "#! \n coding: iso-8859-1 \n !#")
- "ISO-8859-1"))
-
- (pass-if "third line no whitespace"
- (equal? (scan-coding "#!\ncoding:iso-8859-1\n!#")
- "ISO-8859-1")))
-
-(with-test-prefix "line comments"
- (pass-if "first line, no whitespace, no nl"
- (equal? (scan-coding ";coding:iso-8859-1")
- "ISO-8859-1"))
-
- (pass-if "first line, whitespace, no nl"
- (equal? (scan-coding "; coding: iso-8859-1 ")
- "ISO-8859-1"))
-
- (pass-if "first line, no whitespace, nl"
- (equal? (scan-coding ";coding:iso-8859-1\n")
- "ISO-8859-1"))
-
- (pass-if "first line, whitespace, nl"
- (equal? (scan-coding "; coding: iso-8859-1 \n")
- "ISO-8859-1"))
-
- (pass-if "second line, no whitespace, no nl"
- (equal? (scan-coding "\n;coding:iso-8859-1")
- "ISO-8859-1"))
-
- (pass-if "second line, whitespace, no nl"
- (equal? (scan-coding "\n; coding: iso-8859-1 ")
- "ISO-8859-1"))
-
- (pass-if "second line, no whitespace, nl"
- (equal? (scan-coding "\n;coding:iso-8859-1\n")
- "ISO-8859-1"))
-
- (pass-if "second line, whitespace, nl"
- (equal? (scan-coding "\n; coding: iso-8859-1 \n")
- "ISO-8859-1")))
+ (pass-if-equal "first line"
+ "ISO-8859-1"
+ (scan-coding "#! coding: iso-8859-1 !#"))
+
+ (pass-if-equal "first line no whitespace"
+ "ISO-8859-1"
+ (scan-coding "#!coding:iso-8859-1!#"))
+
+ (pass-if-equal "second line"
+ "ISO-8859-1"
+ (scan-coding "#! \n coding: iso-8859-1 !#"))
+
+ (pass-if-equal "second line no whitespace"
+ "ISO-8859-1"
+ (scan-coding "#!\ncoding:iso-8859-1!#"))
+
+ (pass-if-equal "third line"
+ "ISO-8859-1"
+ (scan-coding "#! \n coding: iso-8859-1 \n !#"))
+
+ (pass-if-equal "third line no whitespace"
+ "ISO-8859-1"
+ (scan-coding "#!\ncoding:iso-8859-1\n!#")))
+
+(with-test-prefix "line comment"
+ (pass-if-equal "first line, no whitespace, no nl"
+ "ISO-8859-1"
+ (scan-coding ";coding:iso-8859-1"))
+
+ (pass-if-equal "first line, whitespace, no nl"
+ "ISO-8859-1"
+ (scan-coding "; coding: iso-8859-1 "))
+
+ (pass-if-equal "first line, no whitespace, nl"
+ "ISO-8859-1"
+ (scan-coding ";coding:iso-8859-1\n"))
+
+ (pass-if-equal "first line, whitespace, nl"
+ "ISO-8859-1"
+ (scan-coding "; coding: iso-8859-1 \n"))
+
+ (pass-if-equal "second line, no whitespace, no nl"
+ "ISO-8859-1"
+ (scan-coding "\n;coding:iso-8859-1"))
+
+ (pass-if-equal "second line, whitespace, no nl"
+ "ISO-8859-1"
+ (scan-coding "\n; coding: iso-8859-1 "))
+
+ (pass-if-equal "second line, no whitespace, nl"
+ "ISO-8859-1"
+ (scan-coding "\n;coding:iso-8859-1\n"))
+
+ (pass-if-equal "second line, whitespace, nl"
+ "ISO-8859-1"
+ (scan-coding "\n; coding: iso-8859-1 \n")))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 1c30b9c..5b292c4 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; control.test --- test suite for delimited continuations
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +20,7 @@
(define-module (test-suite test-control)
#:use-module (ice-9 control)
#:use-module (system vm vm)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (test-suite lib))
@@ -77,7 +78,32 @@
(abort 'foo 'bar 'baz)
(error "unexpected exit"))
(lambda (k . args)
- args)))))
+ args))))
+
+ (pass-if-equal "call/ec" '(0 1 2) ; example from the manual
+ (let ((prefix
+ (lambda (x lst)
+ (call/ec
+ (lambda (return)
+ (fold (lambda (element prefix)
+ (if (equal? element x)
+ (return (reverse prefix))
+ (cons element prefix)))
+ '()
+ lst))))))
+ (prefix 'a '(0 1 2 a 3 4 5))))
+
+ (pass-if-equal "let/ec" '(0 1 2)
+ (let ((prefix
+ (lambda (x lst)
+ (let/ec return
+ (fold (lambda (element prefix)
+ (if (equal? element x)
+ (return (reverse prefix))
+ (cons element prefix)))
+ '()
+ lst)))))
+ (prefix 'a '(0 1 2 a 3 4 5)))))
;;; And the case in which the compiler has to reify the continuation.
(with-test-prefix/c&e "reified continuations"
diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test
index f15499c..17036f9 100644
--- a/test-suite/tests/ecmascript.test
+++ b/test-suite/tests/ecmascript.test
@@ -80,6 +80,7 @@
(with-test-prefix "compiler"
(ecompile "true;" #t)
+ (ecompile "if (3 > 2) true; else false;" #t)
(ecompile "2 + 2;" 4)
(ecompile "\"hello\";" "hello")
(ecompile "var test = { bar: 1 };")
diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test
index 41800fd..baf8546 100644
--- a/test-suite/tests/elisp.test
+++ b/test-suite/tests/elisp.test
@@ -124,8 +124,8 @@
(with-fluids* (cons f (cons g #nil))
'(3 4)
(lambda ()
- (and (eq? (fluid-ref f) 3)
- (eq? (fluid-ref g) 4))))))
+ (and (eqv? (fluid-ref f) 3)
+ (eqv? (fluid-ref g) 4))))))
(pass-if "append!"
(let ((a (copy-tree '(1 2 3)))
@@ -150,11 +150,11 @@
'(5 4 3 2 1))) ; Ditto.
(pass-if "list-ref"
- (eq? (list-ref '(0 1 2 3 4 . #nil) 4) 4))
+ (eqv? (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))
+ (eqv? (list-ref '(0 1 2 3 4 . #nil) 6) 6))
(pass-if "list-set!"
(let ((l (copy-tree '(0 1 2 3 4 . #nil))))
diff --git a/test-suite/tests/encoding-iso88591.test
b/test-suite/tests/encoding-iso88591.test
index f7bec5e..8265ff1 100644
--- a/test-suite/tests/encoding-iso88591.test
+++ b/test-suite/tests/encoding-iso88591.test
@@ -106,16 +106,16 @@
(with-test-prefix "string length"
(pass-if "última"
- (eq? (string-length s1) 6))
+ (eqv? (string-length s1) 6))
(pass-if "cédula"
- (eq? (string-length s2) 6))
+ (eqv? (string-length s2) 6))
(pass-if "años"
- (eq? (string-length s3) 4))
+ (eqv? (string-length s3) 4))
(pass-if "¿Cómo?"
- (eq? (string-length s4) 6)))
+ (eqv? (string-length s4) 6)))
(with-test-prefix "internal encoding"
@@ -168,7 +168,7 @@
(pass-if "1"
(let ((á 1)
(ñ 2))
- (eq? (+ á ñ) 3))))
+ (eqv? (+ á ñ) 3))))
(with-test-prefix "output errors"
diff --git a/test-suite/tests/encoding-iso88597.test
b/test-suite/tests/encoding-iso88597.test
index f116194..a577b2a 100644
--- a/test-suite/tests/encoding-iso88597.test
+++ b/test-suite/tests/encoding-iso88597.test
@@ -95,16 +95,16 @@
(with-test-prefix "string length"
(pass-if "s1"
- (eq? (string-length s1) 4))
+ (eqv? (string-length s1) 4))
(pass-if "s2"
- (eq? (string-length s2) 3))
+ (eqv? (string-length s2) 3))
(pass-if "s3"
- (eq? (string-length s3) 8))
+ (eqv? (string-length s3) 8))
(pass-if "s4"
- (eq? (string-length s4) 3)))
+ (eqv? (string-length s4) 3)))
(with-test-prefix "internal encoding"
@@ -157,7 +157,7 @@
(pass-if "1"
(let ((á 1)
(ñ 2))
- (eq? (+ á ñ) 3))))
+ (eqv? (+ á ñ) 3))))
(with-test-prefix "output errors"
diff --git a/test-suite/tests/encoding-utf8.test
b/test-suite/tests/encoding-utf8.test
index 966a04d..1de3fa7 100644
--- a/test-suite/tests/encoding-utf8.test
+++ b/test-suite/tests/encoding-utf8.test
@@ -126,16 +126,16 @@
(with-test-prefix "string length"
(pass-if "última"
- (eq? (string-length s1) 6))
+ (eqv? (string-length s1) 6))
(pass-if "cédula"
- (eq? (string-length s2) 6))
+ (eqv? (string-length s2) 6))
(pass-if "años"
- (eq? (string-length s3) 4))
+ (eqv? (string-length s3) 4))
(pass-if "ç¾
çé"
- (eq? (string-length s4) 3)))
+ (eqv? (string-length s4) 3)))
(with-test-prefix "internal encoding"
@@ -188,7 +188,7 @@
(pass-if "1"
(let ((è¥å·é¾ä¹ä» 1)
(ñ 2))
- (eq? (+ è¥å·é¾ä¹ä» ñ) 3))))
+ (eqv? (+ è¥å·é¾ä¹ä» ñ) 3))))
(if (defined? 'setlocale)
(setlocale LC_ALL oldlocale))
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index a6bfb6e..049c9a2 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -1,6 +1,6 @@
;;;; filesys.test --- test file system functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2006, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,7 +18,10 @@
(define-module (test-suite test-filesys)
#:use-module (test-suite lib)
- #:use-module (test-suite guile-test))
+ #:use-module (test-suite guile-test)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors))
(define (test-file)
(data-file-name "filesys-test.tmp"))
@@ -125,5 +128,98 @@
(close-port port)
(eqv? 5 (stat:size st))))))
+(with-test-prefix "sendfile"
+
+ (let* ((file (search-path %load-path "ice-9/boot-9.scm"))
+ (len (stat:size (stat file)))
+ (ref (call-with-input-file file get-bytevector-all)))
+
+ (pass-if-equal "file" (cons len ref)
+ (let* ((result (call-with-input-file file
+ (lambda (input)
+ (call-with-output-file (test-file)
+ (lambda (output)
+ (sendfile output input len 0))))))
+ (out (call-with-input-file (test-file) get-bytevector-all)))
+ (cons result out)))
+
+ (pass-if-equal "file with offset"
+ (cons (- len 777) (call-with-input-file file
+ (lambda (input)
+ (seek input 777 SEEK_SET)
+ (get-bytevector-all input))))
+ (let* ((result (call-with-input-file file
+ (lambda (input)
+ (call-with-output-file (test-file)
+ (lambda (output)
+ (sendfile output input (- len 777) 777))))))
+ (out (call-with-input-file (test-file) get-bytevector-all)))
+ (cons result out)))
+
+ (pass-if-equal "file with offset past the end"
+ (cons (- len 777) (call-with-input-file file
+ (lambda (input)
+ (seek input 777 SEEK_SET)
+ (get-bytevector-all input))))
+ (let* ((result (call-with-input-file file
+ (lambda (input)
+ (call-with-output-file (test-file)
+ (lambda (output)
+ (sendfile output input len 777))))))
+ (out (call-with-input-file (test-file) get-bytevector-all)))
+ (cons result out)))
+
+ (pass-if-equal "file with offset near the end"
+ (cons 77 (call-with-input-file file
+ (lambda (input)
+ (seek input (- len 77) SEEK_SET)
+ (get-bytevector-all input))))
+ (let* ((result (call-with-input-file file
+ (lambda (input)
+ (call-with-output-file (test-file)
+ (lambda (output)
+ (sendfile output input len (- len 77)))))))
+ (out (call-with-input-file (test-file) get-bytevector-all)))
+ (cons result out)))
+
+ (pass-if-equal "pipe" (cons len ref)
+ (if (provided? 'threads)
+ (let* ((in+out (pipe))
+ (child (call-with-new-thread
+ (lambda ()
+ (call-with-input-file file
+ (lambda (input)
+ (let ((result (sendfile (cdr in+out)
+ (fileno input)
+ len 0)))
+ (close-port (cdr in+out))
+ result)))))))
+ (let ((out (get-bytevector-all (car in+out))))
+ (close-port (car in+out))
+ (cons (join-thread child) out)))
+ (throw 'unresolved)))
+
+ (pass-if-equal "pipe with offset"
+ (cons (- len 777) (call-with-input-file file
+ (lambda (input)
+ (seek input 777 SEEK_SET)
+ (get-bytevector-all input))))
+ (if (provided? 'threads)
+ (let* ((in+out (pipe))
+ (child (call-with-new-thread
+ (lambda ()
+ (call-with-input-file file
+ (lambda (input)
+ (let ((result (sendfile (cdr in+out)
+ (fileno input)
+ (- len 777)
+ 777)))
+ (close-port (cdr in+out))
+ result)))))))
+ (let ((out (get-bytevector-all (car in+out))))
+ (close-port (car in+out))
+ (cons (join-thread child) out)))
+ (throw 'unresolved)))))
+
(delete-file (test-file))
(delete-file (test-symlink))
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 9ed846c..9ad9e81 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -18,7 +18,8 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-fluids)
- :use-module (test-suite lib))
+ :use-module (test-suite lib)
+ :use-module (system base compile))
(define exception:syntax-error
@@ -78,16 +79,31 @@
(not (fluid-ref a))))))
(with-test-prefix "with-fluids with duplicate fluid"
+ ;; These tests must be compiled, because the evaluator
+ ;; effectively transforms (with-fluids ((a 1) (b 2)) ...)
+ ;; into (with-fluids ((a 1)) (with-fluids ((b 2)) ...))
+
(pass-if "last value wins"
- (with-fluids ((a 1)
- (a 2))
- (eqv? (fluid-ref a) 2)))
+ (compile '(with-fluids ((a 1)
+ (a 2)
+ (a 3))
+ (eqv? (fluid-ref a) 3))
+ #:env (current-module)))
+ (pass-if "remove the duplicate, not the last binding"
+ (compile '(with-fluids ((a 1)
+ (a 2)
+ (a 3)
+ (b 4))
+ (eqv? (fluid-ref b) 4))
+ #:env (current-module)))
+
(pass-if "original value restored"
- (and (with-fluids ((a 1)
- (a 2))
- (eqv? (fluid-ref a) 2))
- (eqv? (fluid-ref a) #f))))
+ (compile '(and (with-fluids ((a 1)
+ (a 2))
+ (eqv? (fluid-ref a) 2))
+ (eqv? (fluid-ref a) #f))
+ #:env (current-module))))
(pass-if "fluid values are thread-local"
(if (provided? 'threads)
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 7c5ecd6..9d615ce 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -1,6 +1,6 @@
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -68,15 +68,22 @@
(equal? (make-pointer 123) (make-pointer 123)))
(pass-if "equal? modulo finalizer"
- (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
- (equal? (make-pointer 123)
- (make-pointer 123 finalizer))))
+ (let ((finalizer (false-if-exception
+ (dynamic-func "scm_is_pair" (dynamic-link)))))
+ (if (not finalizer)
+ (throw 'unresolved) ; Windows or a static build
+ (equal? (make-pointer 123)
+ (make-pointer 123 finalizer)))))
(pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
- (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
+ (let ((finalizer (false-if-exception
+ (dynamic-func "scm_is_pair" (dynamic-link))))
(ptr (make-pointer 123)))
- (set-pointer-finalizer! ptr finalizer)
- (equal? (make-pointer 123) ptr)))
+ (if (not finalizer)
+ (throw 'unresolved) ; Windows or a static build
+ (begin
+ (set-pointer-finalizer! ptr finalizer)
+ (equal? (make-pointer 123) ptr)))))
(pass-if "not equal?"
(not (equal? (make-pointer 123) (make-pointer 456)))))
diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test
index b8bacb2..a398aff 100644
--- a/test-suite/tests/future.test
+++ b/test-suite/tests/future.test
@@ -2,7 +2,7 @@
;;;;
;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012, 2013 Free Software 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,8 +22,7 @@
#:use-module (test-suite lib)
#:use-module (ice-9 futures)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (system base compile))
+ #:use-module (srfi srfi-26))
(define specific-exception-key (gensym))
@@ -98,11 +97,8 @@
(touch (future (1+ (touch (future (1+ (touch (future 0)))))))))
(pass-if-equal "loop" (map - (iota 1000))
- ;; Compile to avoid stack overflows.
- (compile '(let loop ((list (iota 1000)))
- (if (null? list)
- '()
- (cons (- (car list))
- (touch (future (loop (cdr list)))))))
- #:to 'value
- #:env (current-module))))
+ (let loop ((list (iota 1000)))
+ (if (null? list)
+ '()
+ (cons (- (car list))
+ (touch (future (loop (cdr list)))))))))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index a969752..04f3539 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -1,6 +1,6 @@
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
-;;;; 2011, 2012 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -101,4 +101,4 @@
(guardian))
;; Prevent the optimizer from propagating f.
#:opts '(#:partial-eval? #f))))
- (equal? l '(foo)))))
+ (maybe-gc-flakiness (equal? l '(foo))))))
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index bcdfe91..3bd4004 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -134,7 +134,7 @@
(with-output-to-string
(lambda () (write table)))))))
- ;; 1 and 1 are equal? and eqv? and eq?
+ ;; 1 and 1 are equal? and eqv? (but not necessarily eq?)
(pass-if (equal? 'foo
(let ((table (make-hash-table)))
(hash-set! table 1 'foo)
@@ -143,12 +143,8 @@
(let ((table (make-hash-table)))
(hashv-set! table 1 'foo)
(hashv-ref table 1))))
- (pass-if (equal? 'foo
- (let ((table (make-hash-table)))
- (hashq-set! table 1 'foo)
- (hashq-ref table 1))))
- ;; 1/2 and 2/4 are equal? and eqv? but not eq?
+ ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?)
(pass-if (equal? 'foo
(let ((table (make-hash-table)))
(hash-set! table 1/2 'foo)
@@ -157,10 +153,6 @@
(let ((table (make-hash-table)))
(hashv-set! table 1/2 'foo)
(hashv-ref table 2/4))))
- (pass-if (equal? #f
- (let ((table (make-hash-table)))
- (hashq-set! table 1/2 'foo)
- (hashq-ref table 2/4))))
;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
(pass-if (equal? 'foo
@@ -292,3 +284,19 @@
exception:wrong-type-arg
(hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo
'bar))
)
+
+
+;;;
+;;; hash-count
+;;;
+
+(with-test-prefix "hash-count"
+ (let ((table (make-hash-table)))
+ (hashq-set! table 'foo "bar")
+ (hashq-set! table 'braz "zonk")
+ (hashq-create-handle! table 'frob #f)
+
+ (pass-if (equal? 3 (hash-count (const #t) table)))
+
+ (pass-if (equal? 2 (hash-count (lambda (k v)
+ (string? v)) table)))))
diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test
index ef08dd4..ad65b73 100644
--- a/test-suite/tests/i18n.test
+++ b/test-suite/tests/i18n.test
@@ -255,30 +255,30 @@
(with-test-prefix "character mapping"
(pass-if "char-locale-downcase"
- (and (eq? #\a (char-locale-downcase #\A))
- (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
+ (and (eqv? #\a (char-locale-downcase #\A))
+ (eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
(pass-if "char-locale-upcase"
- (and (eq? #\Z (char-locale-upcase #\z))
- (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
+ (and (eqv? #\Z (char-locale-upcase #\z))
+ (eqv? #\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")))))
+ (and (eqv? #\T (char-locale-titlecase #\t))
+ (eqv? #\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")))))
+ (and (eqv? #\762 (char-locale-titlecase #\763))
+ (eqv? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
(pass-if "char-locale-upcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
- (eq? #\Ä° (char-locale-upcase #\i %turkish-utf8-locale)))))
+ (eqv? #\Ä° (char-locale-upcase #\i %turkish-utf8-locale)))))
(pass-if "char-locale-downcase Turkish"
(under-turkish-utf8-locale-or-unresolved
(lambda ()
- (eq? #\i (char-locale-downcase #\Ä° %turkish-utf8-locale))))))
+ (eqv? #\i (char-locale-downcase #\Ä° %turkish-utf8-locale))))))
(with-test-prefix "string mapping"
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index 79e3c98..fb54061 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -345,7 +345,7 @@
(set-module-binder! m (lambda args (set! invoked? #t) #f))
(module-define! m 'something 2)
(and invoked?
- (eq? (module-ref m 'something) 2))))
+ (eqv? (module-ref m 'something) 2))))
(pass-if "honored (ref)"
(let ((m (make-module))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 66aa01a..eca4536 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1,5 +1,6 @@
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010, 2011,
+;;;; 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -46,15 +47,35 @@
;; the usual 53.
;;
(define dbl-mant-dig
- (let more ((i 1)
- (d 2.0))
- (if (> i 1024)
- (error "Oops, cannot determine number of bits in mantissa of inexact"))
- (let* ((sum (+ 1.0 d))
- (diff (- sum d)))
- (if (= diff 1.0)
- (more (1+ i) (* 2.0 d))
- i))))
+ (do ((prec 0 (+ prec 1))
+ (eps 1.0 (/ eps 2.0)))
+ ((begin (when (> prec 1000000)
+ (error "Unable to determine dbl-mant-dig"))
+ (= 1.0 (+ 1.0 eps)))
+ prec)))
+
+(define dbl-epsilon
+ (expt 0.5 (- dbl-mant-dig 1)))
+
+(define dbl-epsilon-exact
+ (expt 1/2 (- dbl-mant-dig 1)))
+
+(define dbl-min-exp
+ (do ((x 1.0 (/ x 2.0))
+ (y (+ 1.0 dbl-epsilon) (/ y 2.0))
+ (e 2 (- e 1)))
+ ((begin (when (< e -100000000)
+ (error "Unable to determine dbl-min-exp"))
+ (= x y))
+ e)))
+
+(define dbl-max-exp
+ (do ((x 1.0 (* x 2.0))
+ (e 0 (+ e 1)))
+ ((begin (when (> e 100000000)
+ (error "Unable to determine dbl-max-exp"))
+ (inf? x))
+ e)))
;; like ash, but working on a flonum
(define (ash-flo x n)
@@ -201,71 +222,6 @@
(eqv? -2305843009213693953 (1- -2305843009213693952))))
;;;
-;;; ash
-;;;
-
-(with-test-prefix "ash"
-
- (pass-if "documented?"
- (documented? ash))
-
- (pass-if (eqv? 0 (ash 0 0)))
- (pass-if (eqv? 0 (ash 0 1)))
- (pass-if (eqv? 0 (ash 0 1000)))
- (pass-if (eqv? 0 (ash 0 -1)))
- (pass-if (eqv? 0 (ash 0 -1000)))
-
- (pass-if (eqv? 1 (ash 1 0)))
- (pass-if (eqv? 2 (ash 1 1)))
- (pass-if (eqv? 340282366920938463463374607431768211456 (ash 1 128)))
- (pass-if (eqv? 0 (ash 1 -1)))
- (pass-if (eqv? 0 (ash 1 -1000)))
-
- (pass-if (eqv? -1 (ash -1 0)))
- (pass-if (eqv? -2 (ash -1 1)))
- (pass-if (eqv? -340282366920938463463374607431768211456 (ash -1 128)))
- (pass-if (eqv? -1 (ash -1 -1)))
- (pass-if (eqv? -1 (ash -1 -1000)))
-
- (pass-if (eqv? -3 (ash -3 0)))
- (pass-if (eqv? -6 (ash -3 1)))
- (pass-if (eqv? -1020847100762815390390123822295304634368 (ash -3 128)))
- (pass-if (eqv? -2 (ash -3 -1)))
- (pass-if (eqv? -1 (ash -3 -1000)))
-
- (pass-if (eqv? -6 (ash -23 -2)))
-
- (pass-if (eqv? most-positive-fixnum (ash most-positive-fixnum 0)))
- (pass-if (eqv? (* 2 most-positive-fixnum) (ash most-positive-fixnum 1)))
- (pass-if (eqv? (* 4 most-positive-fixnum) (ash most-positive-fixnum 2)))
- (pass-if
- (eqv? (* most-positive-fixnum 340282366920938463463374607431768211456)
- (ash most-positive-fixnum 128)))
- (pass-if (eqv? (quotient most-positive-fixnum 2)
- (ash most-positive-fixnum -1)))
- (pass-if (eqv? 0 (ash most-positive-fixnum -1000)))
-
- (let ((mpf4 (quotient most-positive-fixnum 4)))
- (pass-if (eqv? (* 2 mpf4) (ash mpf4 1)))
- (pass-if (eqv? (* 4 mpf4) (ash mpf4 2)))
- (pass-if (eqv? (* 8 mpf4) (ash mpf4 3))))
-
- (pass-if (eqv? most-negative-fixnum (ash most-negative-fixnum 0)))
- (pass-if (eqv? (* 2 most-negative-fixnum) (ash most-negative-fixnum 1)))
- (pass-if (eqv? (* 4 most-negative-fixnum) (ash most-negative-fixnum 2)))
- (pass-if
- (eqv? (* most-negative-fixnum 340282366920938463463374607431768211456)
- (ash most-negative-fixnum 128)))
- (pass-if (eqv? (quotient-floor most-negative-fixnum 2)
- (ash most-negative-fixnum -1)))
- (pass-if (eqv? -1 (ash most-negative-fixnum -1000)))
-
- (let ((mnf4 (quotient-floor most-negative-fixnum 4)))
- (pass-if (eqv? (* 2 mnf4) (ash mnf4 1)))
- (pass-if (eqv? (* 4 mnf4) (ash mnf4 2)))
- (pass-if (eqv? (* 8 mnf4) (ash mnf4 3)))))
-
-;;;
;;; exact?
;;;
@@ -1428,21 +1384,39 @@
(lambda (n radix)
(string->number (number->string n radix) radix))))
+ (define (test num)
+ (pass-if-equal (list num 'pos)
+ num
+ (num->str->num num 10))
+ (pass-if-equal (list num 'neg)
+ (- num)
+ (num->str->num (- num) 10)))
+
(pass-if (documented? number->string))
(pass-if (string=? (number->string 0) "0"))
(pass-if (string=? (number->string 171) "171"))
(pass-if (= (+ fixnum-max 1) (num->str->num (+ fixnum-max 1) 10)))
(pass-if (= (- fixnum-min 1) (num->str->num (- fixnum-min 1) 10)))
- (pass-if (= (inf) (num->str->num (inf) 10)))
- (pass-if (= 1.3 (num->str->num 1.3 10)))
- ;; XXX - some results depend on whether Guile is compiled optimzed
- ;; or not. It is clearly undesirable to have number->string to be
- ;; influenced by this.
+ (test (inf))
+ (test 1.3)
+ (test (acos -1)) ; pi
+ (test (exp 1)) ; e
+ (test (/ 3.0))
+ (test (/ 7.0))
+ (test 2.2250738585072011e-308)
+ (test 2.2250738585072012e-308)
+
+ ;; Largest finite inexact
+ (test (* (- (expt 2.0 dbl-mant-dig) 1)
+ (expt 2.0 (- dbl-max-exp dbl-mant-dig))))
+
+ (pass-if (string=? "0.0" (number->string 0.0)))
+ (pass-if (or (eqv? 0.0 -0.0)
+ (string=? "-0.0" (number->string -0.0))))
(pass-if (string=? (number->string 35.25 36) "z.9"))
- (pass-if (or (string=? (number->string 0.25 2) "0.01")
- (string=? (number->string 0.25 2) "0.010")))
+ (pass-if (string=? (number->string 0.25 2) "0.01"))
(pass-if (string=? (number->string 255.0625 16) "ff.1"))
(pass-if (string=? (number->string (/ 1 3) 3) "1/10"))
@@ -1456,26 +1430,65 @@
(pass-if (string=? (number->string 35 36) "z"))
(pass-if (= (num->str->num 35 36) 35))
+ (pass-if (string=? (number->string 12342342340000.0) "1.234234234e13"))
+ (pass-if (string=? (number->string 1234234234000.0) "1234234234000.0"))
+ (pass-if (string=? (number->string 1240000.0) "1240000.0"))
+
+ (with-test-prefix "powers of radix"
+ (for-each
+ (lambda (radix)
+ (for-each (lambda (k)
+ (let ((val (exact->inexact (expt radix k)))
+ (str (if (<= -3 k 6)
+ (assoc-ref '((-3 . "0.001")
+ (-2 . "0.01")
+ (-1 . "0.1")
+ ( 0 . "1.0")
+ ( 1 . "10.0")
+ ( 2 . "100.0")
+ ( 3 . "1000.0")
+ ( 4 . "10000.0")
+ ( 5 . "100000.0")
+ ( 6 . "1000000.0"))
+ k)
+ (string-append "1.0e"
+ (number->string k radix)))))
+ (pass-if-equal (list radix k 'pos)
+ str
+ (number->string val radix))
+ (pass-if-equal (list radix k 'neg)
+ (string-append "-" str)
+ (number->string (- val) radix))))
+ (iota 41 -20)))
+ (iota 35 2)))
+
+ (with-test-prefix "multiples of smallest inexact"
+ (for-each (lambda (k)
+ (let ((val (* k (expt 2.0 (- dbl-min-exp dbl-mant-dig)))))
+ (test val)))
+ (iota 40 1)))
+
+ (with-test-prefix "one plus multiples of epsilon"
+ (for-each (lambda (k)
+ (let ((val (+ 1.0 (* k dbl-epsilon))))
+ (test val)))
+ (iota 40 1)))
+
+ (with-test-prefix "one minus multiples of 1/2 epsilon"
+ (for-each (lambda (k)
+ (let ((val (- 1.0 (* k 1/2 dbl-epsilon))))
+ (test val)))
+ (iota 40 1)))
+
;; Before Guile 2.0.1, even in the presence of a #e forced exactness
;; specifier, negative exponents were applied inexactly and then
;; later coerced to exact, yielding an incorrect fraction.
(pass-if (eqv? (string->number "#e1e-10") 1/10000000000))
- ;; Numeric conversion from decimal is not precise, in its current
- ;; implementation, so 11.333... and 1.324... can't be expected to
- ;; reliably come out to precise values. These tests did actually work
- ;; for a while, but something in gcc changed, affecting the conversion
- ;; code.
- ;;
- ;; (pass-if (or (string=? (number->string 11.33333333333333333 12)
- ;; "B.4")
- ;; (string=? (number->string 11.33333333333333333 12)
- ;; "B.400000000000009")))
- ;; (pass-if (or (string=? (number->string 1.324e44 16)
- ;; "5.EFE0A14FAFEe24")
- ;; (string=? (number->string 1.324e44 16)
- ;; "5.EFE0A14FAFDF8e24")))
- ))
+ (pass-if (string=? (number->string 11.33333333333333333 12)
+ "b.4"))
+ (pass-if (string=? (number->string 1.324e44 16)
+ "5.efe0a14fafdf8e24"))))
;;;
;;; string->number
@@ -1493,7 +1506,9 @@
"#o.2" "3.4q" "15.16e17q" "18.19e+q" ".q" ".17#18" "10q" "#b2"
"#b3" "#b4" "#b5" "#b6" "#b7" "#b8" "#b9" "#ba" "#bb" "#bc"
"#bd" "#be" "#bf" "#q" "#b#b1" "#o#o1" "#d#d1" "#x#x1" "#e#e1"
- "#i#i1" "address@hidden"))
+ "#i#i1" "address@hidden" "3/0" "0/0" "4+3/0i" "4/0-3i" "2+0/0i"
+ "nan.0" "inf.0" "#e+nan.0" "#e+inf.0" "#e-inf.0"
+ "address@hidden" "address@hidden"))
#t)
(pass-if "valid number strings"
@@ -1532,6 +1547,14 @@
("1/1" 1) ("1/2" 1/2) ("-1/2" -1/2) ("1#/1" 10.0)
("10/1#" 1.0) ("1#/1#" 1.0) ("#e9/10" 9/10) ("#e10/1#" 1)
("#i6/8" 0.75) ("#i1/1" 1.0)
+ ;; Infinities and NaNs:
+ ("+inf.0" ,(inf)) ("-inf.0" ,(- (inf)))
+ ("+Inf.0" ,(inf)) ("-Inf.0" ,(- (inf)))
+ ("+InF.0" ,(inf)) ("-InF.0" ,(- (inf)))
+ ("+INF.0" ,(inf)) ("-INF.0" ,(- (inf)))
+ ("#i+InF.0" ,(inf)) ("#i-InF.0" ,(- (inf)))
+ ("+nan.0" ,(nan)) ("-nan.0" ,(nan))
+ ("#i+nan.0" ,(nan)) ("#i-nan.0" ,(nan))
;; Decimal numbers:
;; * <uinteger 10> <suffix>
("1e2" 100.0) ("1E2" 100.0) ("1s2" 100.0) ("1S2" 100.0)
@@ -3913,21 +3936,17 @@
;;;
(with-test-prefix "exact->inexact"
-
+
+ ;; Test "(exact->inexact n)", expect "want".
+ (define (test name n want)
+ (with-test-prefix name
+ (pass-if-equal "pos" want (exact->inexact n))
+ (pass-if-equal "neg" (- want) (exact->inexact (- n)))))
+
;; Test "(exact->inexact n)", expect "want".
;; "i" is a index, for diagnostic purposes.
(define (try-i i n want)
- (with-test-prefix (list i n want)
- (with-test-prefix "pos"
- (let ((got (exact->inexact n)))
- (pass-if "inexact?" (inexact? got))
- (pass-if (list "=" got) (= want got))))
- (set! n (- n))
- (set! want (- want))
- (with-test-prefix "neg"
- (let ((got (exact->inexact n)))
- (pass-if "inexact?" (inexact? got))
- (pass-if (list "=" got) (= want got))))))
+ (test (list i n want) n want))
(with-test-prefix "2^i, no round"
(do ((i 0 (1+ i))
@@ -4000,7 +4019,155 @@
;; convert the num and den to doubles, resulting in infs.
(pass-if "frac big/big, exceeding double"
(let ((big (ash 1 4096)))
- (= 1.0 (exact->inexact (/ (1+ big) big))))))
+ (= 1.0 (exact->inexact (/ (1+ big) big)))))
+
+ (test "round up to odd"
+ ;; =====================================================
+ ;; 11111111111111111111111111111111111111111111111111000101 ->
+ ;; 11111111111111111111111111111111111111111111111111001000
+ (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b000101)
+ (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b001000))
+
+ (test "round down to odd"
+ ;; =====================================================
+ ;; 11111111111111111111111111111111111111111111111111001011 ->
+ ;; 11111111111111111111111111111111111111111111111111001000
+ (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b001011)
+ (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b001000))
+
+ (test "round tie up to even"
+ ;; =====================================================
+ ;; 11111111111111111111111111111111111111111111111111011100 ->
+ ;; 11111111111111111111111111111111111111111111111111100000
+ (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b011100)
+ (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b100000))
+
+ (test "round tie down to even"
+ ;; =====================================================
+ ;; 11111111111111111111111111111111111111111111111111000100 ->
+ ;; 11111111111111111111111111111111111111111111111111000000
+ (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b000100)
+ (+ (expt 2.0 (+ dbl-mant-dig 3)) -64 #b000000))
+
+ (test "round tie up to next power of two"
+ ;; =====================================================
+ ;; 11111111111111111111111111111111111111111111111111111100 ->
+ ;; 100000000000000000000000000000000000000000000000000000000
+ (+ (expt 2 (+ dbl-mant-dig 3)) -64 #b111100)
+ (expt 2.0 (+ dbl-mant-dig 3)))
+
+ (test "miniscule value rounds to zero of appropriate sign"
+ (expt 17 (- dbl-min-exp dbl-mant-dig))
+ 0.0)
+
+ (test "smallest inexact"
+ (expt 2 (- dbl-min-exp dbl-mant-dig))
+ (expt 2.0 (- dbl-min-exp dbl-mant-dig)))
+
+ (test "1/2 smallest inexact rounds down to zero"
+ (* 1/2 (expt 2 (- dbl-min-exp dbl-mant-dig)))
+ 0.0)
+
+ (test "just over 1/2 smallest inexact rounds up"
+ (+ (* 1/2 (expt 2 (- dbl-min-exp dbl-mant-dig)))
+ (expt 7 (- dbl-min-exp dbl-mant-dig)))
+ (expt 2.0 (- dbl-min-exp dbl-mant-dig)))
+
+ (test "3/2 smallest inexact rounds up to twice smallest inexact"
+ (* 3/2 (expt 2 (- dbl-min-exp dbl-mant-dig)))
+ (* 2.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig))))
+
+ (test "just under 3/2 smallest inexact rounds down"
+ (- (* 3/2 (expt 2 (- dbl-min-exp dbl-mant-dig)))
+ (expt 11 (- dbl-min-exp dbl-mant-dig)))
+ (expt 2.0 (- dbl-min-exp dbl-mant-dig)))
+
+ (test "5/2 smallest inexact rounds down to twice smallest inexact"
+ (* 5/2 (expt 2 (- dbl-min-exp dbl-mant-dig)))
+ (* 2.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig))))
+
+ (test "just over 5/2 smallest inexact rounds up"
+ (+ (* 5/2 (expt 2 (- dbl-min-exp dbl-mant-dig)))
+ (expt 13 (- dbl-min-exp dbl-mant-dig)))
+ (* 3.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig))))
+
+ (test "one plus dbl-epsilon"
+ (+ 1 dbl-epsilon-exact)
+ (+ 1.0 dbl-epsilon))
+
+ (test "one plus 1/2 dbl-epsilon rounds down to 1.0"
+ (+ 1 (* 1/2 dbl-epsilon-exact))
+ 1.0)
+
+ (test "just over one plus 1/2 dbl-epsilon rounds up"
+ (+ 1
+ (* 1/2 dbl-epsilon-exact)
+ (expt 13 (- dbl-min-exp dbl-mant-dig)))
+ (+ 1.0 dbl-epsilon))
+
+ (test "one plus 3/2 dbl-epsilon rounds up"
+ (+ 1 (* 3/2 dbl-epsilon-exact))
+ (+ 1.0 (* 2.0 dbl-epsilon)))
+
+ (test "just under one plus 3/2 dbl-epsilon rounds down"
+ (+ 1
+ (* 3/2 dbl-epsilon-exact)
+ (- (expt 17 (- dbl-min-exp dbl-mant-dig))))
+ (+ 1.0 dbl-epsilon))
+
+ (test "one plus 5/2 dbl-epsilon rounds down"
+ (+ 1 (* 5/2 dbl-epsilon-exact))
+ (+ 1.0 (* 2.0 dbl-epsilon)))
+
+ (test "just over one plus 5/2 dbl-epsilon rounds up"
+ (+ 1
+ (* 5/2 dbl-epsilon-exact)
+ (expt 13 (- dbl-min-exp dbl-mant-dig)))
+ (+ 1.0 (* 3.0 dbl-epsilon)))
+
+ (test "largest finite inexact"
+ (* (- (expt 2 dbl-mant-dig) 1)
+ (expt 2 (- dbl-max-exp dbl-mant-dig)))
+ (* (- (expt 2.0 dbl-mant-dig) 1)
+ (expt 2.0 (- dbl-max-exp dbl-mant-dig))))
+
+ (test "largest finite inexact plus 1/2 epsilon rounds up to infinity"
+ (* (+ (expt 2 dbl-mant-dig) -1 1/2)
+ (expt 2 (- dbl-max-exp dbl-mant-dig)))
+ (inf))
+
+ (test "largest finite inexact plus just under 1/2 epsilon rounds down"
+ (* (+ (expt 2 dbl-mant-dig) -1 1/2
+ (- (expt 13 (- dbl-min-exp dbl-mant-dig))))
+ (expt 2 (- dbl-max-exp dbl-mant-dig)))
+ (* (- (expt 2.0 dbl-mant-dig) 1)
+ (expt 2.0 (- dbl-max-exp dbl-mant-dig))))
+
+ (test "1/2 largest finite inexact"
+ (* (- (expt 2 dbl-mant-dig) 1)
+ (expt 2 (- dbl-max-exp dbl-mant-dig 1)))
+ (* (- (expt 2.0 dbl-mant-dig) 1)
+ (expt 2.0 (- dbl-max-exp dbl-mant-dig 1))))
+
+ (test "1/2 largest finite inexact plus 1/2 epsilon rounds up to next power
of two"
+ (* (+ (expt 2 dbl-mant-dig) -1 1/2)
+ (expt 2 (- dbl-max-exp dbl-mant-dig 1)))
+ (expt 2.0 (- dbl-max-exp 1)))
+
+ (test "1/2 largest finite inexact plus just over 1/2 epsilon rounds up to
next power of two"
+ (* (+ (expt 2 dbl-mant-dig) -1 1/2
+ (expt 13 (- dbl-min-exp dbl-mant-dig)))
+ (expt 2 (- dbl-max-exp dbl-mant-dig 1)))
+ (expt 2.0 (- dbl-max-exp 1)))
+
+ (test "1/2 largest finite inexact plus just under 1/2 epsilon rounds down"
+ (* (+ (expt 2 dbl-mant-dig) -1 1/2
+ (- (expt 13 (- dbl-min-exp dbl-mant-dig))))
+ (expt 2 (- dbl-max-exp dbl-mant-dig 1)))
+ (* (- (expt 2.0 dbl-mant-dig) 1)
+ (expt 2.0 (- dbl-max-exp dbl-mant-dig 1))))
+
+ )
;;;
;;; expt
@@ -4044,6 +4211,9 @@
(pass-if (eqv? -0.125 (expt -2 -3.0)))
(pass-if (eqv? -0.125 (expt -2.0 -3.0)))
(pass-if (eqv? 0.25 (expt 2.0 -2.0)))
+ (pass-if (eqv? 32/243 (expt 2/3 5)))
+ (pass-if (eqv? 243/32 (expt 2/3 -5)))
+ (pass-if (eqv? 32 (expt 1/2 -5)))
(pass-if (test-eqv? (* -1.0+0.0i 12398 12398) (expt +12398i 2.0)))
(pass-if (eqv-loosely? +i (expt -1 0.5)))
(pass-if (eqv-loosely? +i (expt -1 1/2)))
@@ -4272,6 +4442,13 @@
;;;
(with-test-prefix "inexact->exact"
+
+ ;; Test "(inexact->exact f)", expect "want".
+ (define (test name f want)
+ (with-test-prefix name
+ (pass-if-equal "pos" want (inexact->exact f))
+ (pass-if-equal "neg" (- want) (inexact->exact (- f)))))
+
(pass-if (documented? inexact->exact))
(pass-if-exception "+inf" exception:out-of-range
@@ -4282,13 +4459,55 @@
(pass-if-exception "nan" exception:out-of-range
(inexact->exact +nan.0))
-
- (with-test-prefix "2.0**i to exact and back"
+
+ (test "0.0" 0.0 0)
+ (test "small even integer" 72.0 72)
+ (test "small odd integer" 73.0 73)
+
+ (test "largest inexact odd integer"
+ (- (expt 2.0 dbl-mant-dig) 1)
+ (- (expt 2 dbl-mant-dig) 1))
+
+ (test "largest inexact odd integer - 1"
+ (- (expt 2.0 dbl-mant-dig) 2)
+ (- (expt 2 dbl-mant-dig) 2))
+
+ (test "largest inexact odd integer + 3"
+ (+ (expt 2.0 dbl-mant-dig) 2)
+ (+ (expt 2 dbl-mant-dig) 2))
+
+ (test "largest inexact odd integer * 2^48"
+ (* (expt 2.0 48) (- (expt 2.0 dbl-mant-dig) 1))
+ (* (expt 2 48) (- (expt 2 dbl-mant-dig) 1)))
+
+ (test "largest inexact odd integer / 2^48"
+ (* (expt 0.5 48) (- (expt 2.0 dbl-mant-dig) 1))
+ (* (expt 1/2 48) (- (expt 2 dbl-mant-dig) 1)))
+
+ (test "largest finite inexact"
+ (* (- (expt 2.0 dbl-mant-dig) 1)
+ (expt 2.0 (- dbl-max-exp dbl-mant-dig)))
+ (* (- (expt 2 dbl-mant-dig) 1)
+ (expt 2 (- dbl-max-exp dbl-mant-dig))))
+
+ (test "smallest inexact"
+ (expt 2.0 (- dbl-min-exp dbl-mant-dig))
+ (expt 2 (- dbl-min-exp dbl-mant-dig)))
+
+ (test "smallest inexact * 2"
+ (* 2.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig)))
+ (* 2 (expt 2 (- dbl-min-exp dbl-mant-dig))))
+
+ (test "smallest inexact * 3"
+ (* 3.0 (expt 2.0 (- dbl-min-exp dbl-mant-dig)))
+ (* 3 (expt 2 (- dbl-min-exp dbl-mant-dig))))
+
+ (with-test-prefix "2.0**i to exact"
(do ((i 0 (1+ i))
- (n 1.0 (* 2.0 n)))
+ (n 1 (* 2 n))
+ (f 1.0 (* 2.0 f)))
((> i 100))
- (pass-if (list i n)
- (= n (inexact->exact (exact->inexact n)))))))
+ (test (list i n) f n))))
;;;
;;; integer-expt
@@ -4317,6 +4536,9 @@
(pass-if (eqv? -1/8 (integer-expt -2 -3)))
(pass-if (eqv? -0.125 (integer-expt -2.0 -3)))
(pass-if (eqv? 0.25 (integer-expt 2.0 -2)))
+ (pass-if (eqv? 32/243 (integer-expt 2/3 5)))
+ (pass-if (eqv? 243/32 (integer-expt 2/3 -5)))
+ (pass-if (eqv? 32 (integer-expt 1/2 -5)))
(pass-if (test-eqv? (* -1.0+0.0i 12398 12398) (integer-expt +12398.0i 2))))
@@ -4619,7 +4841,80 @@
(pass-if-exception "two args" exception:wrong-num-args
(sqrt 123 456))
- (pass-if (eqv? 0.0 (sqrt 0)))
+ (pass-if (eqv? 0 (sqrt 0)))
+ (pass-if (eqv? 1 (sqrt 1)))
+ (pass-if (eqv? 2 (sqrt 4)))
+ (pass-if (eqv? 3 (sqrt 9)))
+ (pass-if (eqv? 4 (sqrt 16)))
+ (pass-if (eqv? fixnum-max (sqrt (expt fixnum-max 2))))
+ (pass-if (eqv? (+ 1 fixnum-max) (sqrt (expt (+ 1 fixnum-max) 2))))
+ (pass-if (eqv? (expt 10 400) (sqrt (expt 10 800))))
+ (pass-if (eqv? (/ (expt 10 1000)
+ (expt 13 1000))
+ (sqrt (/ (expt 10 2000)
+ (expt 13 2000)))))
+
+ (with-test-prefix "exact sqrt"
+
+ (define (test root)
+ (pass-if (list root 'exact)
+ (eqv? root (sqrt (expt root 2))))
+ (pass-if (list root '*2)
+ (let ((r (sqrt (* 2 (expt root 2)))))
+ (and (inexact? r)
+ (eqv-loosely? (* (sqrt 2) root) r))))
+ (pass-if (list root '-1)
+ (let ((r (sqrt (- (expt root 2) 1))))
+ (and (inexact? r)
+ (eqv-loosely? root r))))
+ (pass-if (list root '+1)
+ (let ((r (sqrt (+ (expt root 2) 1))))
+ (and (inexact? r)
+ (eqv-loosely? root r))))
+ (pass-if (list root 'negative)
+ (eqv-loosely? (* +i root) (sqrt (- (expt root 2))))))
+
+ (test (exact-integer-sqrt (+ -1 (expt 2 (+ 2 dbl-mant-dig)))))
+ (test (exact-integer-sqrt (+ -1 (expt 2 (+ 1 dbl-mant-dig)))))
+ (test (exact-integer-sqrt (+ -1 (expt 2 (+ 0 dbl-mant-dig)))))
+ (test (exact-integer-sqrt (+ -1 (expt 2 (+ -1 dbl-mant-dig)))))
+ (test (exact-integer-sqrt (+ -1 (expt 2 (+ -2 dbl-mant-dig)))))
+
+ ;; largest finite inexact
+ (test (* (- (expt 2 dbl-mant-dig) 1)
+ (expt 2 (- dbl-max-exp dbl-mant-dig)))))
+
+ (pass-if-equal "smallest inexact"
+ (expt 2.0 (- dbl-min-exp dbl-mant-dig))
+ (sqrt (/ (+ -1 (expt 2 (* 2 (- dbl-mant-dig dbl-min-exp)))))))
+
+ (with-test-prefix "extreme ratios"
+ (define-syntax-rule (test want x)
+ (pass-if 'x
+ (let ((got (sqrt x)))
+ (and (inexact? got)
+ (test-eqv? 1.0 (/ want got))))))
+ (test 1.511139943175573e176 (/ (expt 3 2001) (expt 2 2001)))
+ (test 2.1370746022826034e176 (/ (expt 3 2001) (expt 2 2000)))
+ (test 8.724570529756128e175 (/ (expt 3 2000) (expt 2 2001)))
+ (test 6.6175207962444435e-177 (/ (expt 2 2001) (expt 3 2001)))
+ (test 1.1461882239239027e-176 (/ (expt 2 2001) (expt 3 2000)))
+ (test 4.679293829667447e-177 (/ (expt 2 2000) (expt 3 2001))))
+
+ (pass-if (eqv? (/ (expt 2 1000)
+ (expt 3 1000))
+ (sqrt (/ (expt 2 2000)
+ (expt 3 2000)))))
+
+ (pass-if (eqv? (/ (expt 3 1000)
+ (expt 2 1000))
+ (sqrt (/ (expt 3 2000)
+ (expt 2 2000)))))
+
+ (pass-if (eqv? +4i (sqrt -16)))
+ (pass-if (eqv-loosely? +1.0e150i (sqrt #e-1e300)))
+ (pass-if (eqv-loosely? +0.7071i (sqrt -1/2)))
+
(pass-if (eqv? 0.0 (sqrt 0.0)))
(pass-if (eqv? 1.0 (sqrt 1.0)))
(pass-if (eqv-loosely? 2.0 (sqrt 4.0)))
@@ -4898,3 +5193,52 @@
round-quotient
round-remainder
valid-round-answer?)))
+
+;;;
+;;; ash
+;;; round-ash
+;;;
+
+(let ()
+ (define (test-ash-variant name ash-variant round-variant)
+ (with-test-prefix name
+ (define (test n count)
+ (pass-if (list n count)
+ (eqv? (ash-variant n count)
+ (round-variant (* n (expt 2 count))))))
+
+ (pass-if "documented?"
+ (documented? ash-variant))
+
+ (for-each (lambda (n)
+ (for-each (lambda (count) (test n count))
+ '(-1000 -3 -2 -1 0 1 2 3 1000)))
+ (list 0 1 3 23 -1 -3 -23
+ fixnum-max
+ (1+ fixnum-max)
+ (1- fixnum-max)
+ (* fixnum-max 4)
+ (quotient fixnum-max 4)
+ fixnum-min
+ (1+ fixnum-min)
+ (1- fixnum-min)
+ (* fixnum-min 4)
+ (quotient fixnum-min 4)))
+
+ (do ((count -2 (1- count))
+ (vals '(1 3 5 7 9 11)
+ (map (lambda (n) (* 2 n)) vals)))
+ ((> (car vals) (* 2 fixnum-max)) 'done)
+ (for-each (lambda (n)
+ (test n count)
+ (test (- n) count))
+ vals))
+
+ ;; Test rounding
+ (for-each (lambda (base)
+ (for-each (lambda (offset) (test (+ base offset) -3))
+ '(#b11001 #b11100 #b11101 #b10001 #b10100
#b10101)))
+ (list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min)))))
+
+ (test-ash-variant 'ash ash floor)
+ (test-ash-variant 'round-ash round-ash round))
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 396fdec..16a4533 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -221,7 +221,36 @@
(equal? (transmogrify quote)
10)))
+(with-test-prefix/c&e "case-lambda"
+ (pass-if-exception "no clauses, no args" exception:wrong-num-args
+ ((case-lambda)))
+
+ (pass-if-exception "no clauses, args" exception:wrong-num-args
+ ((case-lambda) 1))
+
+ (pass-if "docstring"
+ (equal? "docstring test"
+ (procedure-documentation
+ (case-lambda
+ "docstring test"
+ (() 0)
+ ((x) 1))))))
+
(with-test-prefix/c&e "case-lambda*"
+ (pass-if-exception "no clauses, no args" exception:wrong-num-args
+ ((case-lambda*)))
+
+ (pass-if-exception "no clauses, args" exception:wrong-num-args
+ ((case-lambda*) 1))
+
+ (pass-if "docstring"
+ (equal? "docstring test"
+ (procedure-documentation
+ (case-lambda*
+ "docstring test"
+ (() 0)
+ ((x) 1)))))
+
(pass-if "unambiguous"
((case-lambda*
((a b) #t)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index f3f3b41..ecc5dd1 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <address@hidden> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -25,6 +25,7 @@
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language glil)
+ #:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
(define peval
@@ -836,6 +837,153 @@
(call (toplevel top) (lexical x _)))))))
(pass-if-peval
+ ;; The inliner sees through a `let'.
+ ((let ((a 10)) (lambda (b) (* b 2))) 30)
+ (const 60))
+
+ (pass-if-peval
+ ((lambda ()
+ (define (const x) (lambda (_) x))
+ (let ((v #f))
+ ((const #t) v))))
+ (const #t))
+
+ (pass-if-peval
+ ;; Applications of procedures with rest arguments can get inlined.
+ ((lambda (x y . z)
+ (list x y z))
+ 1 2 3 4)
+ (let (z) (_) ((primcall list (const 3) (const 4)))
+ (primcall list (const 1) (const 2) (lexical z _))))
+
+ (pass-if-peval
+ ;; Unmutated lists can get inlined.
+ (let ((args (list 2 3)))
+ (apply (lambda (x y z w)
+ (list x y z w))
+ 0 1 args))
+ (primcall list (const 0) (const 1) (const 2) (const 3)))
+
+ (pass-if-peval
+ ;; However if the list might have been mutated, it doesn't propagate.
+ (let ((args (list 2 3)))
+ (foo! args)
+ (apply (lambda (x y z w)
+ (list x y z w))
+ 0 1 args))
+ (let (args) (_) ((primcall list (const 2) (const 3)))
+ (seq
+ (call (toplevel foo!) (lexical args _))
+ (primcall @apply
+ (lambda ()
+ (lambda-case
+ (((x y z w) #f #f #f () (_ _ _ _))
+ (primcall list
+ (lexical x _) (lexical y _)
+ (lexical z _) (lexical w _)))))
+ (const 0)
+ (const 1)
+ (lexical args _)))))
+
+ (pass-if-peval
+ ;; Here the `args' that gets built by the application of the lambda
+ ;; takes more than effort "10" to visit. Test that we fall back to
+ ;; the source expression of the operand, which is still a call to
+ ;; `list', so the inlining still happens.
+ (lambda (bv offset n)
+ (let ((x (bytevector-ieee-single-native-ref
+ bv
+ (+ offset 0)))
+ (y (bytevector-ieee-single-native-ref
+ bv
+ (+ offset 4))))
+ (let ((args (list x y)))
+ (@apply
+ (lambda (bv offset x y)
+ (bytevector-ieee-single-native-set!
+ bv
+ (+ offset 0)
+ x)
+ (bytevector-ieee-single-native-set!
+ bv
+ (+ offset 4)
+ y))
+ bv
+ offset
+ args))))
+ (lambda ()
+ (lambda-case
+ (((bv offset n) #f #f #f () (_ _ _))
+ (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 0)))
+ (primcall bytevector-ieee-single-native-ref
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 4))))
+ (seq
+ (primcall bytevector-ieee-single-native-set!
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 0))
+ (lexical x _))
+ (primcall bytevector-ieee-single-native-set!
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 4))
+ (lexical y _))))))))
+
+ (pass-if-peval
+ ;; Here we ensure that non-constant expressions are not copied.
+ (lambda ()
+ (let ((args (list (foo!))))
+ (@apply
+ (lambda (z x)
+ (list z x))
+ ;; This toplevel ref might raise an unbound variable exception.
+ ;; The effects of `(foo!)' must be visible before this effect.
+ z
+ args)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (let (_) (_) ((call (toplevel foo!)))
+ (let (z) (_) ((toplevel z))
+ (primcall 'list
+ (lexical z _)
+ (lexical _ _))))))))
+
+ (pass-if-peval
+ ;; Rest args referenced more than once are not destructured.
+ (lambda ()
+ (let ((args (list 'foo)))
+ (set-car! args 'bar)
+ (@apply
+ (lambda (z x)
+ (list z x))
+ z
+ args)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (let (args) (_)
+ ((primcall list (const foo)))
+ (seq
+ (primcall set-car! (lexical args _) (const bar))
+ (primcall @apply
+ (lambda . _)
+ (toplevel z)
+ (lexical args _))))))))
+
+ (pass-if-peval
+ ;; Let-values inlining, even with consumers with rest args.
+ (call-with-values (lambda () (values 1 2))
+ (lambda args
+ (apply list args)))
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)
(primcall cons (const 1) (const '#nil)))
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index bfd7da7..2818be0 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -1,25 +1,23 @@
;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2010, 2011, 2013 Free Software 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-ice-9-popen)
- #:use-module (test-suite lib)
- #:use-module (ice-9 popen))
-
+ #:use-module (test-suite lib))
;; read from PORT until eof is reached, return what's read as a string
(define (read-string-to-eof port)
@@ -37,176 +35,178 @@
thunk
restore-signals))
+(define-syntax-rule (if-supported body ...)
+ (if (provided? 'fork)
+ (begin body ...)))
+
+(if-supported
+ (use-modules (ice-9 popen))
+
+
+ ;;
+ ;; open-input-pipe
+ ;;
+
+ (with-test-prefix "open-input-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (open-input-pipe))
+
+ (pass-if "port?"
+ (port? (open-input-pipe "echo hello")))
+
+ (pass-if "echo hello"
+ (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))
+
+ ;; exercise file descriptor setups when stdin is the same as stderr
+ (pass-if "stdin==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-input-from-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-input-pipe "echo hello"))))))
+ #t)
+
+ ;; exercise file descriptor setups when stdout is the same as stderr
+ (pass-if "stdout==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-output-to-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-input-pipe "echo hello"))))))
+ #t)
+
+ (pass-if "open-input-pipe process gets (current-input-port) as stdin"
+ (let* ((p2c (pipe))
+ (port (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe "read line && echo $line")))))
+ (display "hello\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (let ((result (eq? (read port) 'hello)))
+ (close-port (cdr p2c))
+ (close-pipe port)
+ result)))
+
+ ;; After the child closes stdout (which it indicates here by writing
+ ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
+ ;; and earlier a duplicate of stdout existed in the child, meaning
+ ;; eof was not seen.
+ ;;
+ ;; Note that the objective here is to test that the parent sees EOF
+ ;; while the child is still alive. (It is obvious that the parent
+ ;; must see EOF once the child has died.) The use of the `p2c'
+ ;; pipe, and `echo closed' and `read' in the child, allows us to be
+ ;; sure that we are testing what the parent sees at a point where
+ ;; the child has closed stdout but is still alive.
+ (pass-if "no duplicate"
+ (let* ((c2p (pipe))
+ (p2c (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe
+ "exec 1>/dev/null; echo closed 1>&2; exec
2>/dev/null; read REPLY")))))))
+ (close-port (cdr c2p)) ;; write side
+ (let ((result (eof-object? (read-char port))))
+ (display "hello!\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (close-pipe port)
+ result))))
+
+ ;;
+ ;; open-output-pipe
+ ;;
+
+ (with-test-prefix "open-output-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (open-output-pipe))
+
+ (pass-if "port?"
+ (port? (open-output-pipe "exit 0")))
+
+ ;; exercise file descriptor setups when stdin is the same as stderr
+ (pass-if "stdin==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-input-from-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-output-pipe "exit 0"))))))
+ #t)
+
+ ;; exercise file descriptor setups when stdout is the same as stderr
+ (pass-if "stdout==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-output-to-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-output-pipe "exit 0"))))))
+ #t)
+
+ ;; After the child closes stdin (which it indicates here by writing
+ ;; "closed" to stderr), the parent should see a broken pipe. We
+ ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
+ ;; and earlier a duplicate of stdin existed in the child, preventing
+ ;; the broken pipe occurring.
+ ;;
+ ;; Note that the objective here is to test that the parent sees a
+ ;; broken pipe while the child is still alive. (It is obvious that
+ ;; the parent will see a broken pipe once the child has died.) The
+ ;; use of the `c2p' pipe, and the repeated `echo closed' in the
+ ;; child, allows us to be sure that we are testing what the parent
+ ;; sees at a point where the child has closed stdin but is still
+ ;; alive.
+ ;;
+ ;; Note that `with-epipe' must apply only to the parent and not to
+ ;; the child process; we rely on the child getting SIGPIPE, to
+ ;; terminate it (and avoid leaving a zombie).
+ (pass-if "no duplicate"
+ (let* ((c2p (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (open-output-pipe
+ (string-append "exec guile --no-auto-compile -s \""
+ (getenv "TEST_SUITE_DIR")
+ "/tests/popen-child.scm\""))))))
+ (close-port (cdr c2p)) ;; write side
+ (with-epipe
+ (lambda ()
+ (let ((result
+ (and (char? (read-char (car c2p))) ;; wait for child to do
its thing
+ (catch 'system-error
+ (lambda ()
+ (write-char #\x port)
+ (force-output port)
+ #f)
+ (lambda (key name fmt args errno-list)
+ (= (car errno-list) EPIPE))))))
+ ;; Now close our reading end of the pipe. This should give
+ ;; the child a broken pipe and so allow it to exit.
+ (close-port (car c2p))
+ (close-pipe port)
+ result))))))
+
+ ;;
+ ;; close-pipe
+ ;;
+
+ (with-test-prefix "close-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (close-pipe))
-;;
-;; open-input-pipe
-;;
-
-(with-test-prefix "open-input-pipe"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (open-input-pipe))
-
- (pass-if "port?"
- (port? (open-input-pipe "echo hello")))
-
- (pass-if "echo hello"
- (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))
-
- ;; exercise file descriptor setups when stdin is the same as stderr
- (pass-if "stdin==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-input-from-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-input-pipe "echo hello"))))))
- #t)
-
- ;; exercise file descriptor setups when stdout is the same as stderr
- (pass-if "stdout==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-output-to-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-input-pipe "echo hello"))))))
- #t)
-
- (pass-if "open-input-pipe process gets (current-input-port) as stdin"
- (let* ((p2c (pipe))
- (port (with-input-from-port (car p2c)
- (lambda ()
- (open-input-pipe "read line && echo $line")))))
- (display "hello\n" (cdr p2c))
- (force-output (cdr p2c))
- (let ((result (eq? (read port) 'hello)))
- (close-port (cdr p2c))
- (close-pipe port)
- result)))
-
- ;; After the child closes stdout (which it indicates here by writing
- ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
- ;; and earlier a duplicate of stdout existed in the child, meaning
- ;; eof was not seen.
- ;;
- ;; Note that the objective here is to test that the parent sees EOF
- ;; while the child is still alive. (It is obvious that the parent
- ;; must see EOF once the child has died.) The use of the `p2c'
- ;; pipe, and `echo closed' and `read' in the child, allows us to be
- ;; sure that we are testing what the parent sees at a point where
- ;; the child has closed stdout but is still alive.
- (pass-if "no duplicate"
- (let* ((c2p (pipe))
- (p2c (pipe))
- (port (with-error-to-port (cdr c2p)
- (lambda ()
- (with-input-from-port (car p2c)
- (lambda ()
- (open-input-pipe
- "exec 1>/dev/null; echo closed 1>&2; exec
2>/dev/null; read REPLY")))))))
- (close-port (cdr c2p)) ;; write side
- (let ((result (eof-object? (read-char port))))
- (display "hello!\n" (cdr p2c))
- (force-output (cdr p2c))
- (close-pipe port)
- result)))
-
- )
-
-;;
-;; open-output-pipe
-;;
-
-(with-test-prefix "open-output-pipe"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (open-output-pipe))
-
- (pass-if "port?"
- (port? (open-output-pipe "exit 0")))
-
- ;; exercise file descriptor setups when stdin is the same as stderr
- (pass-if "stdin==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-input-from-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-output-pipe "exit 0"))))))
- #t)
-
- ;; exercise file descriptor setups when stdout is the same as stderr
- (pass-if "stdout==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-output-to-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-output-pipe "exit 0"))))))
- #t)
-
- ;; After the child closes stdin (which it indicates here by writing
- ;; "closed" to stderr), the parent should see a broken pipe. We
- ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
- ;; and earlier a duplicate of stdin existed in the child, preventing
- ;; the broken pipe occurring.
- ;;
- ;; Note that the objective here is to test that the parent sees a
- ;; broken pipe while the child is still alive. (It is obvious that
- ;; the parent will see a broken pipe once the child has died.) The
- ;; use of the `c2p' pipe, and the repeated `echo closed' in the
- ;; child, allows us to be sure that we are testing what the parent
- ;; sees at a point where the child has closed stdin but is still
- ;; alive.
- ;;
- ;; Note that `with-epipe' must apply only to the parent and not to
- ;; the child process; we rely on the child getting SIGPIPE, to
- ;; terminate it (and avoid leaving a zombie).
- (pass-if "no duplicate"
- (let* ((c2p (pipe))
- (port (with-error-to-port (cdr c2p)
- (lambda ()
- (open-output-pipe
- (string-append "exec guile --no-auto-compile -s \""
- (getenv "TEST_SUITE_DIR")
- "/tests/popen-child.scm\""))))))
- (close-port (cdr c2p)) ;; write side
- (with-epipe
- (lambda ()
- (let ((result
- (and (char? (read-char (car c2p))) ;; wait for child to do its
thing
- (catch 'system-error
- (lambda ()
- (write-char #\x port)
- (force-output port)
- #f)
- (lambda (key name fmt args errno-list)
- (= (car errno-list) EPIPE))))))
- ;; Now close our reading end of the pipe. This should give
- ;; the child a broken pipe and so allow it to exit.
- (close-port (car c2p))
- (close-pipe port)
- result)))))
-
- )
-
-;;
-;; close-pipe
-;;
-
-(with-test-prefix "close-pipe"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (close-pipe))
-
- (pass-if "exit 0"
- (let ((st (close-pipe (open-output-pipe "exit 0"))))
- (and (status:exit-val st)
- (= 0 (status:exit-val st)))))
-
- (pass-if "exit 1"
- (let ((st (close-pipe (open-output-pipe "exit 1"))))
- (and (status:exit-val st)
- (= 1 (status:exit-val st))))))
+ (pass-if "exit 0"
+ (let ((st (close-pipe (open-output-pipe "exit 0"))))
+ (and (status:exit-val st)
+ (= 0 (status:exit-val st)))))
+ (pass-if "exit 1"
+ (let ((st (close-pipe (open-output-pipe "exit 1"))))
+ (and (status:exit-val st)
+ (= 1 (status:exit-val st)))))))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 613d269..65c87da 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -2,7 +2,7 @@
;;;; Jim Blandy <address@hidden> --- May 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
-;;;; 2011, 2012 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013 Free Software 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,12 @@
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (rnrs bytevectors)
- #:use-module ((rnrs io ports) #:select (open-bytevector-input-port)))
+ #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port
+ open-bytevector-output-port
+ put-bytevector
+ get-bytevector-n
+ get-bytevector-all
+ unget-bytevector)))
(define (display-line . args)
(for-each display args)
@@ -269,13 +274,12 @@
(delete-file filename)
(string=? line2 binary-test-string)))))
-;; open-file honors file coding declarations
-(pass-if "file: open-file honors coding declarations"
+;; open-file ignores file coding declaration by default
+(pass-if "file: open-file ignores coding declaration by default"
(with-fluids ((%default-port-encoding "UTF-8"))
(let* ((filename (test-file))
(port (open-output-file filename))
(test-string "â¬100"))
- (set-port-encoding! port "ISO-8859-15")
(write-line ";; coding: iso-8859-15" port)
(write-line test-string port)
(close-port port)
@@ -286,6 +290,287 @@
(delete-file filename)
(string=? line2 test-string)))))
+;; open-input-file with guess-encoding honors coding declaration
+(pass-if "file: open-input-file with guess-encoding honors coding declaration"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let* ((filename (test-file))
+ (port (open-output-file filename))
+ (test-string "â¬100"))
+ (set-port-encoding! port "iso-8859-15")
+ (write-line ";; coding: iso-8859-15" port)
+ (write-line test-string port)
+ (close-port port)
+ (let* ((in-port (open-input-file filename
+ #:guess-encoding #t))
+ (line1 (read-line in-port))
+ (line2 (read-line in-port)))
+ (close-port in-port)
+ (delete-file filename)
+ (string=? line2 test-string)))))
+
+(with-test-prefix "keyword arguments for file openers"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let ((filename (test-file)))
+
+ (with-test-prefix "write #:encoding"
+
+ (pass-if-equal "open-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (let ((port (open-file filename "w"
+ #:encoding "UTF-16LE")))
+ (display "test" port)
+ (close-port port))
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "open-output-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (let ((port (open-output-file filename
+ #:encoding "UTF-16LE")))
+ (display "test" port)
+ (close-port port))
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "call-with-output-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (call-with-output-file filename
+ (lambda (port)
+ (display "test" port))
+ #:encoding "UTF-16LE")
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "with-output-to-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (with-output-to-file filename
+ (lambda ()
+ (display "test"))
+ #:encoding "UTF-16LE")
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "with-error-to-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (with-error-to-file
+ filename
+ (lambda ()
+ (display "test" (current-error-port)))
+ #:encoding "UTF-16LE")
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv)))
+
+ (with-test-prefix "write #:binary"
+
+ (pass-if-equal "open-output-file"
+ "ISO-8859-1"
+ (let* ((port (open-output-file filename #:binary #t))
+ (enc (port-encoding port)))
+ (close-port port)
+ enc))
+
+ (pass-if-equal "call-with-output-file"
+ "ISO-8859-1"
+ (call-with-output-file filename port-encoding #:binary #t))
+
+ (pass-if-equal "with-output-to-file"
+ "ISO-8859-1"
+ (with-output-to-file filename
+ (lambda () (port-encoding (current-output-port)))
+ #:binary #t))
+
+ (pass-if-equal "with-error-to-file"
+ "ISO-8859-1"
+ (with-error-to-file
+ filename
+ (lambda () (port-encoding (current-error-port)))
+ #:binary #t)))
+
+ (with-test-prefix "read #:encoding"
+
+ (pass-if-equal "open-file read #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (let* ((port (open-file filename "r" #:encoding "UTF-16LE"))
+ (str (read-string port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "open-input-file #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (let* ((port (open-input-file filename #:encoding "UTF-16LE"))
+ (str (read-string port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "call-with-input-file #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (call-with-input-file filename
+ read-string
+ #:encoding "UTF-16LE"))
+
+ (pass-if-equal "with-input-from-file #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (with-input-from-file filename
+ read-string
+ #:encoding "UTF-16LE")))
+
+ (with-test-prefix "read #:binary"
+
+ (pass-if-equal "open-input-file"
+ "ISO-8859-1"
+ (let* ((port (open-input-file filename #:binary #t))
+ (enc (port-encoding port)))
+ (close-port port)
+ enc))
+
+ (pass-if-equal "call-with-input-file"
+ "ISO-8859-1"
+ (call-with-input-file filename port-encoding #:binary #t))
+
+ (pass-if-equal "with-input-from-file"
+ "ISO-8859-1"
+ (with-input-from-file filename
+ (lambda () (port-encoding (current-input-port)))
+ #:binary #t)))
+
+ (with-test-prefix "#:guess-encoding with coding declaration"
+
+ (pass-if-equal "open-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-file filename "r"
+ #:guess-encoding #t
+ #:encoding "UTF-16LE"))
+ (str (begin (read-line port)
+ (read-line port)
+ (read-line port))))
+ (close-port port)
+ str))
+
+ (pass-if-equal "open-input-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-input-file filename
+ #:guess-encoding #t
+ #:encoding "UTF-16LE"))
+ (str (begin (read-line port)
+ (read-line port)
+ (read-line port))))
+ (close-port port)
+ str))
+
+ (pass-if-equal "call-with-input-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (call-with-input-file filename
+ (lambda (port)
+ (read-line port)
+ (read-line port)
+ (read-line port))
+ #:guess-encoding #t
+ #:encoding "UTF-16LE"))
+
+ (pass-if-equal "with-input-from-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (with-input-from-file filename
+ (lambda ()
+ (read-line)
+ (read-line)
+ (read-line))
+ #:guess-encoding #t
+ #:encoding "UTF-16LE")))
+
+ (with-test-prefix "#:guess-encoding without coding declaration"
+
+ (pass-if-equal "open-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda () (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-file filename "r"
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15"))
+ (str (read-line port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "open-input-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda () (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-input-file filename
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15"))
+ (str (read-line port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "call-with-input-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda () (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (call-with-input-file filename
+ read-line
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15"))
+
+ (pass-if-equal "with-input-from-file"
+ "â¬100"
+ (with-output-to-file filename
+ (lambda () (write-line "â¬100"))
+ #:encoding "ISO-8859-15")
+ (with-input-from-file filename
+ read-line
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15")))
+
+ (delete-file filename))))
+
;;; ungetting characters and strings.
(with-input-from-string "walk on the moon\nmoon"
(lambda ()
@@ -482,7 +767,7 @@
(display str))))
#f) ; so the test really fails here
(lambda (key subr message errno port chr)
- (and (eq? chr #\Ä)
+ (and (eqv? chr #\Ä)
(string? (strerror errno)))))))
(pass-if "wrong encoding, substitute"
@@ -548,12 +833,12 @@
((_ port (proc -> error))
(if (eq? 'substitute
(port-conversion-strategy port))
- (eq? (proc port) #\?)
+ (eqv? (proc port) #\?)
(decoding-error? port (proc port))))
((_ port (proc -> eof))
(eof-object? (proc port)))
((_ port (proc -> char))
- (eq? (proc port) char))))
+ (eqv? (proc port) char))))
(make-checks
(syntax-rules ()
((_ port check ...)
@@ -918,7 +1203,9 @@
(pass-if-exception "set-port-encoding!, wrong encoding"
exception:miscellaneous-error
- (set-port-encoding! (open-input-string "") "does-not-exist"))
+ (let ((p (open-input-string "")))
+ (set-port-encoding! p "does-not-exist")
+ (read p)))
(pass-if-exception "%default-port-encoding, wrong encoding"
exception:miscellaneous-error
@@ -1110,6 +1397,90 @@
(char-ready?))))))
+;;;; pending-eof behavior
+
+(with-test-prefix "pending EOF behavior"
+ ;; Make a test port that will produce the given sequence. Each
+ ;; element of 'lst' may be either a character or #f (which means EOF).
+ (define (test-soft-port . lst)
+ (make-soft-port
+ (vector (lambda (c) #f) ; write char
+ (lambda (s) #f) ; write string
+ (lambda () #f) ; flush
+ (lambda () ; read char
+ (let ((c (car lst)))
+ (set! lst (cdr lst))
+ c))
+ (lambda () #f)) ; close
+ "rw"))
+
+ (define (call-with-port p proc)
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (proc p))
+ (lambda () (close-port p))))
+
+ (define (call-with-test-file str proc)
+ (let ((filename (test-file)))
+ (dynamic-wind
+ (lambda () (call-with-output-file filename
+ (lambda (p) (display str p))))
+ (lambda () (call-with-input-file filename proc))
+ (lambda () (delete-file (test-file))))))
+
+ (pass-if "peek-char does not swallow EOF (soft port)"
+ (call-with-port (test-soft-port #\a #f #\b)
+ (lambda (p)
+ (and (char=? #\a (peek-char p))
+ (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (eof-object? (read-char p))
+ (char=? #\b (peek-char p))
+ (char=? #\b (read-char p))))))
+
+ (pass-if "unread clears pending EOF (soft port)"
+ (call-with-port (test-soft-port #\a #f #\b)
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "unread clears pending EOF (string port)"
+ (call-with-input-string "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "unread clears pending EOF (file port)"
+ (call-with-test-file
+ "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "seek clears pending EOF (string port)"
+ (call-with-input-string "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (seek p 0 SEEK_SET)
+ (char=? #\a (read-char p)))))))
+
+ (pass-if "seek clears pending EOF (file port)"
+ (call-with-test-file
+ "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (seek p 0 SEEK_SET)
+ (char=? #\a (read-char p))))))))
+
+
;;;; Close current-input-port, and make sure everyone can handle it.
(with-test-prefix "closing current-input-port"
@@ -1136,7 +1507,7 @@
(display "This is GNU Guile.\nWelcome." p)))
(call-with-input-file (test-file)
(lambda (p)
- (and (eq? #\T (read-char p))
+ (and (eqv? #\T (read-char p))
(let ((line (port-line p))
(col (port-column p)))
(and (= line 0) (= col 1)
@@ -1149,6 +1520,286 @@
+(pass-if-equal "unget-bytevector"
+ #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
+ 1 2 3 4 251 253 254 255)
+ (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
+ (unget-bytevector port #vu8(200 201 202 203))
+ (unget-bytevector port #vu8(20 21 22 23 24))
+ (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
+ (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
+ (unget-bytevector port #vu8(10 11))
+ (get-bytevector-all port)))
+
+
+
+(with-test-prefix "unicode byte-order marks (BOMs)"
+
+ (define (bv-read-test* encoding bv proc)
+ (let ((port (open-bytevector-input-port bv)))
+ (set-port-encoding! port encoding)
+ (proc port)))
+
+ (define (bv-read-test encoding bv)
+ (bv-read-test* encoding bv read-string))
+
+ (define (bv-write-test* encoding proc)
+ (call-with-values
+ (lambda () (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (set-port-encoding! port encoding)
+ (proc port)
+ (get-bytevector))))
+
+ (define (bv-write-test encoding str)
+ (bv-write-test* encoding
+ (lambda (p)
+ (display str p))))
+
+ (pass-if-equal "BOM not discarded from Latin-1 stream"
+ "\xEF\xBB\xBF\x61"
+ (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM not discarded from Latin-2 stream"
+ "\u010F\u0165\u017C\x61"
+ (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-16BE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-16LE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
+
+ (pass-if-equal "BOM not discarded from UTF-32BE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-32LE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00)))
+
+ (pass-if-equal "BOM not written to UTF-8 stream"
+ #vu8(#x61)
+ (bv-write-test "UTF-8" "a"))
+
+ (pass-if-equal "BOM not written to UTF-16BE stream"
+ #vu8(#x00 #x61)
+ (bv-write-test "UTF-16BE" "a"))
+
+ (pass-if-equal "BOM not written to UTF-16LE stream"
+ #vu8(#x61 #x00)
+ (bv-write-test "UTF-16LE" "a"))
+
+ (pass-if-equal "BOM not written to UTF-32BE stream"
+ #vu8(#x00 #x00 #x00 #x61)
+ (bv-write-test "UTF-32BE" "a"))
+
+ (pass-if-equal "BOM not written to UTF-32LE stream"
+ #vu8(#x61 #x00 #x00 #x00)
+ (bv-write-test "UTF-32LE" "a"))
+
+ (pass-if "Don't read from the port unless user asks to"
+ (let* ((p (make-soft-port
+ (vector
+ (lambda (c) #f) ; write char
+ (lambda (s) #f) ; write string
+ (lambda () #f) ; flush
+ (lambda () (throw 'fail)) ; read char
+ (lambda () #f))
+ "rw")))
+ (set-port-encoding! p "UTF-16")
+ (display "abc" p)
+ (set-port-encoding! p "UTF-32")
+ (display "def" p)
+ #t))
+
+ ;; TODO: test that input and output streams are independent when
+ ;; appropriate, and linked when appropriate.
+
+ (pass-if-equal "BOM discarded from start of UTF-8 stream"
+ "a"
+ (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
+ '(#\a "a")
+ (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
+ "\uFEFFa"
+ (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
+ "\uFEFFb"
+ (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
+ (lambda (p)
+ (seek p 1 SEEK_SET)
+ (read-string p))))
+
+ (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
+ "a\uFEFFb"
+ (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
+
+ (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
+ #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
+ (bv-write-test "UTF-16" "ab"))
+
+ (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
+ #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
+ (bv-write-test* "UTF-16"
+ (lambda (p)
+ (display "ab" p)
+ (set-port-encoding! p "UTF-16")
+ (display "cd" p))))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
+ "a"
+ (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to
0"
+ '(#\a "a")
+ (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
+ "\uFEFFa"
+ (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
+ "\uFEFFa"
+ (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
+ (lambda (p)
+ (seek p 2 SEEK_SET)
+ (read-string p))))
+
+ (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
+ "a\uFEFFb"
+ (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
+ "a"
+ (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to
0"
+ '(#\a "a")
+ (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
+ "\uFEFFa"
+ (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
+ "a"
+ (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to
0"
+ '(#\a "a")
+ (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
+ "\uFEFFa"
+ (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
+ "\uFEFFa"
+ (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)
+ (lambda (p)
+ (seek p 4 SEEK_SET)
+ (read-string p))))
+
+ (pass-if-equal "BOM discarded within UTF-16 stream (BE) after
set-port-encoding!"
+ "ab"
+ (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-16")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after
set-port-encoding!"
+ "ab"
+ (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-16")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM discarded within UTF-32 stream (BE) after
set-port-encoding!"
+ "ab"
+ (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x62)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-32")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after
set-port-encoding!"
+ "ab"
+ (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
+ #xFF #xFE #x00 #x00
+ #x62 #x00 #x00 #x00)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-32")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
+ "a\uFEFFb"
+ (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x62)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
+ "a"
+ (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to
0"
+ '(#\a "a")
+ (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
+ "\uFEFFa"
+ (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
+ #xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00))))
+
+
+
(define-syntax-rule (with-load-path path body ...)
(let ((new path)
(old %load-path))
@@ -1162,33 +1813,35 @@
(with-test-prefix "%file-port-name-canonicalization"
- (pass-if "absolute file name & empty %load-path entry"
+ (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
;; of "/dev/null". See
;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
;; for a discussion.
- (equal? "/dev/null"
- (with-load-path (cons "" (delete "/" %load-path))
- (with-fluids ((%file-port-name-canonicalization 'relative))
- (port-filename (open-input-file "/dev/null"))))))
-
- (pass-if "relative canonicalization with /"
- (equal? "dev/null"
- (with-load-path (cons "/" %load-path)
- (with-fluids ((%file-port-name-canonicalization 'relative))
- (port-filename (open-input-file "/dev/null"))))))
-
- (pass-if "relative canonicalization from ice-9"
- (equal? "ice-9/q.scm"
- (with-fluids ((%file-port-name-canonicalization 'relative))
- (port-filename
- (open-input-file (%search-load-path "ice-9/q.scm"))))))
-
- (pass-if "absolute canonicalization from ice-9"
- (equal? (string-append (assoc-ref %guile-build-info 'top_srcdir)
- "/module/ice-9/q.scm")
- (with-fluids ((%file-port-name-canonicalization 'absolute))
- (port-filename (open-input-file (%search-load-path
"ice-9/q.scm")))))))
+ (with-load-path (cons "" (delete "/" %load-path))
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null")))))
+
+ (pass-if-equal "relative canonicalization with /" "dev/null"
+ (with-load-path (cons "/" %load-path)
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null")))))
+
+ (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm"
+ ;; If an entry in %LOAD-PATH is not canonical, then
+ ;; `scm_i_relativize_path' is unable to do its job.
+ (if (equal? (map canonicalize-path %load-path) %load-path)
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename
+ (open-input-file (%search-load-path "ice-9/q.scm"))))
+ (throw 'unresolved)))
+
+ (pass-if-equal "absolute canonicalization from ice-9"
+ (canonicalize-path
+ (string-append (assoc-ref %guile-build-info 'top_srcdir)
+ "/module/ice-9/q.scm"))
+ (with-fluids ((%file-port-name-canonicalization 'absolute))
+ (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
(delete-file (test-file))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 3e36cca..4b756cc 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -163,30 +163,6 @@
(equal? (bytevector->u8-list bv)
(map char->integer (string->list str))))))
- (pass-if "get-bytevector-some [only-some]"
- (let* ((str "GNU Guile")
- (index 0)
- (port (make-soft-port
- (vector #f #f #f
- (lambda ()
- (if (>= index (string-length str))
- (eof-object)
- (let ((c (string-ref str index)))
- (set! index (+ index 1))
- c)))
- (lambda () #t)
- (lambda ()
- ;; Number of readily available octets: falls to
- ;; zero after 4 octets have been read.
- (- 4 (modulo index 5))))
- "r"))
- (bv (get-bytevector-some port)))
- (and (bytevector? bv)
- (= index 4)
- (= (bytevector-length bv) index)
- (equal? (bytevector->u8-list bv)
- (map char->integer (string->list "GNU "))))))
-
(pass-if "get-bytevector-all"
(let* ((str "GNU Guile")
(index 0)
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 5b99f72..7c3142d 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -1,6 +1,6 @@
;;;; ramap.test --- test array mapping functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -227,31 +227,65 @@
(with-test-prefix "array-for-each"
+ (with-test-prefix "1 source"
+ (pass-if-equal "noncompact array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "vector"
+ '(3 2 1 0)
+ (let* ((a #(0 1 2 3))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
+ (pass-if-equal "shared array"
+ '(3 2 1 0)
+ (let* ((a #2((0 1) (2 3)))
+ (a' (make-shared-array a
+ (lambda (x)
+ (list (quotient x 4)
+ (modulo x 4)))
+ 4))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a')
+ l)))
+
(with-test-prefix "3 sources"
- (pass-if "noncompact arrays 1"
+ (pass-if-equal "noncompact arrays 1"
+ '((3 3 3) (2 2 2))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
(array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
- (equal? l '((3 3 3) (2 2 2)))))
-
- (pass-if "noncompact arrays 2"
+ l))
+
+ (pass-if-equal "noncompact arrays 2"
+ '((3 3 3) (2 2 1))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
(array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
- (equal? l '((3 3 3) (2 2 1)))))
-
- (pass-if "noncompact arrays 3"
+ l))
+
+ (pass-if-equal "noncompact arrays 3"
+ '((3 3 3) (2 1 1))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
(array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
- (equal? l '((3 3 3) (2 1 1)))))
-
- (pass-if "noncompact arrays 4"
+ l))
+
+ (pass-if-equal "noncompact arrays 4"
+ '((3 2 3) (1 0 2))
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
(array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- (equal? l '((3 2 3) (1 0 2)))))))
+ l))))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 219407c..6e377ba 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -18,17 +18,19 @@
(define-module (tests rtl)
#:use-module (test-suite lib)
- #:use-module (system vm rtl))
+ #:use-module (system vm assembler))
(define-syntax-rule (assert-equal val expr)
(let ((x val))
(pass-if (object->string x) (equal? expr x))))
(define (return-constant val)
- (assemble-program `((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 ,val)
(return 0)
+ (end-arity)
(end-program))))
(define-syntax-rule (assert-constants val ...)
@@ -61,15 +63,19 @@
(with-test-prefix "static procedure"
(assert-equal 42
- (((assemble-program `((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 bar)
(return 0)
+ (end-arity)
(end-program)
- (begin-program bar)
- (assert-nargs-ee/locals 0 1)
+ (begin-program bar
+ ((name . bar)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 42)
(return 0)
+ (end-arity)
(end-program)))))))
(with-test-prefix "loop"
@@ -79,8 +85,9 @@
;; 0: limit
;; 1: n
;; 2: accum
- '((begin-program countdown)
- (assert-nargs-ee/locals 1 2)
+ '((begin-program countdown
+ ((name . countdown)))
+ (begin-standard-arity (x) 3 #f)
(br fix-body)
(label loop-head)
(br-if-= 1 0 out)
@@ -93,6 +100,7 @@
(br loop-head)
(label out)
(return 2)
+ (end-arity)
(end-program)))))
(sumto 1000))))
@@ -103,20 +111,24 @@
;; 0: elt
;; 1: tail
;; 2: head
- '((begin-program make-accum)
- (assert-nargs-ee/locals 0 2)
+ '((begin-program make-accum
+ ((name . make-accum)))
+ (begin-standard-arity () 2 #f)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
(return 1)
+ (end-arity)
(end-program)
- (begin-program accum)
- (assert-nargs-ee/locals 1 2)
+ (begin-program accum
+ ((name . accum)))
+ (begin-standard-arity (x) 3 #f)
(free-ref 1 0)
(box-ref 2 1)
(add 2 2 0)
(box-set! 1 2)
(return 2)
+ (end-arity)
(end-program)))))
(let ((accum (make-accum)))
(accum 1)
@@ -127,23 +139,27 @@
(assert-equal 42
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
- (assert-nargs-ee/locals 1 0)
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 1 #f)
(call 1 0 ())
(return 1) ;; MVRA from call
(return 1) ;; RA from call
+ (end-arity)
(end-program)))))
(call (lambda () 42))))
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
- (assert-nargs-ee/locals 1 1)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
(load-constant 1 3)
(call 2 0 (1))
(return 2) ;; MVRA from call
(return 2) ;; RA from call
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -151,20 +167,24 @@
(assert-equal 3
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
- (assert-nargs-ee/locals 1 0)
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 1 #f)
(tail-call 0 0)
+ (end-arity)
(end-program)))))
(call (lambda () 3))))
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
- (assert-nargs-ee/locals 1 1)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
(tail-call 1 1)
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -172,17 +192,21 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
- (begin-program sqrt-trampoline)
- (assert-nargs-ee/locals 1 1)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 2 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -193,19 +217,23 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
- (begin-program top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
(cached-toplevel-set! 0 top-incrementor *top-val*)
(return/values 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
@@ -214,16 +242,20 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
- (begin-program sqrt-trampoline)
- (assert-nargs-ee/locals 1 1)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 2 #f)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -232,18 +264,126 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
- (begin-program top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
(cached-module-set! 0 (tests rtl) #f *top-val*)
(return 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
+
+(with-test-prefix "procedure name"
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "simply procedure arity"
+ (pass-if-equal "#<procedure foo ()>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+ (pass-if-equal "#<procedure foo (x y)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity (x y) 2 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-opt-arity (x) (y) z 3 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure docstrings"
+ (pass-if-equal "qux qux"
+ (procedure-documentation
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure properties"
+ ;; No properties.
+ (pass-if-equal '()
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ())
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; Name and docstring (which actually don't go out to procprops).
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; A property that actually needs serialization.
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; Procedure-name still works in this case.
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 6d725dc..5e4cb27 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -65,17 +65,17 @@
(pass-if "condition-ref"
(let* ((ct (make-condition-type 'chbouib &condition '(a b)))
(c (make-condition ct 'b 1 'a 0)))
- (and (eq? (condition-ref c 'a) 0)
- (eq? (condition-ref c 'b) 1))))
+ (and (eqv? (condition-ref c 'a) 0)
+ (eqv? (condition-ref c 'b) 1))))
(pass-if "condition-ref with inheritance"
(let* ((top (make-condition-type 'foo &condition '(a b)))
(ct (make-condition-type 'bar top '(c d)))
(c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
- (and (eq? (condition-ref c 'a) 0)
- (eq? (condition-ref c 'b) 1)
- (eq? (condition-ref c 'c) 2)
- (eq? (condition-ref c 'd) 3))))
+ (and (eqv? (condition-ref c 'a) 0)
+ (eqv? (condition-ref c 'b) 1)
+ (eqv? (condition-ref c 'c) 2)
+ (eqv? (condition-ref c 'd) 3))))
(pass-if "extract-condition"
(let* ((ct (make-condition-type 'chbouib &condition '(a b)))
@@ -149,8 +149,8 @@
(let ((c (make-condition &chbouib 'one 1 'two 2)))
(and (condition? c)
(chbouib? c)
- (eq? (chbouib-one c) 1)
- (eq? (chbouib-two c) 2))))
+ (eqv? (chbouib-one c) 1)
+ (eqv? (chbouib-two c) 2))))
m)))
(pass-if "condition"
diff --git a/test-suite/tests/srfi-37.test b/test-suite/tests/srfi-37.test
index 1f739c5..5a39750 100644
--- a/test-suite/tests/srfi-37.test
+++ b/test-suite/tests/srfi-37.test
@@ -1,6 +1,6 @@
;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2013 Free Software 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,4 +105,26 @@
(lambda (opt name arg k) #f)
'()))))
+ (pass-if-equal "short option with optional argument omitted" 'good
+ ;; This would trigger an infinite loop in Guile up to 2.0.7.
+ ;; See <http://bugs.gnu.org/13176>.
+ (args-fold '("-I")
+ (list (option '(#\I) #f #t
+ (lambda (opt name arg value)
+ (and (eqv? name #\I) (not arg)
+ 'good))))
+ (lambda _ (error "unrecognized"))
+ (const #f)
+ #f))
+
+ (pass-if-equal "short option with optional argument provided"
+ "the-argument"
+ (args-fold '("-I" "the-argument")
+ (list (option '(#\I) #f #t
+ (lambda (opt name arg result)
+ (and (eqv? name #\I) arg))))
+ (lambda _ (error "unrecognized"))
+ (const #f)
+ #f))
+
)
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 033e39f..9b76c7a 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, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -438,24 +438,24 @@
(pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
(c32vector? #c32(+inf.0 -inf.0 +nan.0)))
- (pass-if "generalized-vector-ref"
+ (pass-if "array-ref"
(let ((v (c32vector 1+1i)))
(= (c32vector-ref v 0)
- (generalized-vector-ref v 0))))
+ (array-ref v 0))))
- (pass-if "generalized-vector-set!"
+ (pass-if "array-set!"
(let ((x 1+1i)
(v (c32vector 0)))
- (generalized-vector-set! v 0 x)
- (= x (generalized-vector-ref v 0))))
+ (array-set! v x 0)
+ (= x (array-ref v 0))))
- (pass-if-exception "generalized-vector-ref, out-of-range"
+ (pass-if-exception "array-ref, out-of-range"
exception:out-of-range
- (generalized-vector-ref (c32vector 1.0) 1))
+ (array-ref (c32vector 1.0) 1))
- (pass-if-exception "generalized-vector-set!, out-of-range"
+ (pass-if-exception "array-set!, out-of-range"
exception:out-of-range
- (generalized-vector-set! (c32vector 1.0) 1 2.0)))
+ (array-set! (c32vector 1.0) 2.0 1)))
(with-test-prefix "c64 vectors"
@@ -497,24 +497,24 @@
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
(c64vector? #c64(+inf.0 -inf.0 +nan.0)))
- (pass-if "generalized-vector-ref"
+ (pass-if "array-ref"
(let ((v (c64vector 1+1i)))
(= (c64vector-ref v 0)
- (generalized-vector-ref v 0))))
+ (array-ref v 0))))
- (pass-if "generalized-vector-set!"
+ (pass-if "array-set!"
(let ((x 1+1i)
(v (c64vector 0)))
- (generalized-vector-set! v 0 x)
- (= x (generalized-vector-ref v 0))))
+ (array-set! v x 0)
+ (= x (array-ref v 0))))
- (pass-if-exception "generalized-vector-ref, out-of-range"
+ (pass-if-exception "array-ref, out-of-range"
exception:out-of-range
- (generalized-vector-ref (c64vector 1.0) 1))
+ (array-ref (c64vector 1.0) 1))
- (pass-if-exception "generalized-vector-set!, out-of-range"
+ (pass-if-exception "array-set!, out-of-range"
exception:out-of-range
- (generalized-vector-set! (c64vector 1.0) 1 2.0)))
+ (array-set! (c64vector 1.0) 2.0 1)))
(with-test-prefix "accessing uniform vectors of different types"
diff --git a/test-suite/tests/srfi-41.test b/test-suite/tests/srfi-41.test
new file mode 100644
index 0000000..f2e0864
--- /dev/null
+++ b/test-suite/tests/srfi-41.test
@@ -0,0 +1,680 @@
+;;; srfi-41.test -- test suite for SRFI 41
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (test-srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-31)
+ #:use-module (srfi srfi-41)
+ #:use-module (test-suite lib))
+
+(define-stream (qsort lt? strm)
+ (if (stream-null? strm) stream-null
+ (let ((x (stream-car strm))
+ (xs (stream-cdr strm)))
+ (stream-append
+ (qsort lt? (stream-filter (cut lt? <> x) xs))
+ (stream x)
+ (qsort lt? (stream-filter (cut (negate lt?) <> x) xs))))))
+
+(define-stream (isort lt? strm)
+ (define-stream (insert strm x)
+ (stream-match strm
+ (() (stream x))
+ ((y . ys) (if (lt? y x)
+ (stream-cons y (insert ys x))
+ (stream-cons x strm)))))
+ (stream-fold insert stream-null strm))
+
+(define-stream (stream-merge lt? . strms)
+ (stream-let loop ((strms strms))
+ (cond ((null? strms) stream-null)
+ ((null? (cdr strms)) (car strms))
+ (else (stream-let merge ((xx (car strms))
+ (yy (loop (cdr strms))))
+ (stream-match xx
+ (() yy)
+ ((x . xs)
+ (stream-match yy
+ (() xx)
+ ((y . ys)
+ (if (lt? y x)
+ (stream-cons y (merge xx ys))
+ (stream-cons x (merge xs yy))))))))))))
+
+(define-stream (msort lt? strm)
+ (let* ((n (quotient (stream-length strm) 2))
+ (ts (stream-take n strm))
+ (ds (stream-drop n strm)))
+ (if (zero? n) strm
+ (stream-merge lt? (msort < ts) (msort < ds)))))
+
+(define-stream (stream-unique eql? strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (stream-car strm)
+ (stream-unique eql?
+ (stream-drop-while (cut eql? (stream-car strm) <>) strm)))))
+
+(define nats
+ (stream-cons 1
+ (stream-map 1+ nats)))
+
+(define hamming
+ (stream-unique =
+ (stream-cons 1
+ (stream-merge <
+ (stream-map (cut * 2 <>) hamming)
+ (stream-merge <
+ (stream-map (cut * 3 <>) hamming)
+ (stream-map (cut * 5 <>) hamming))))))
+
+(define primes (let ()
+ (define-stream (next base mult strm)
+ (let ((first (stream-car strm))
+ (rest (stream-cdr strm)))
+ (cond ((< first mult)
+ (stream-cons first
+ (next base mult rest)))
+ ((< mult first)
+ (next base (+ base mult) strm))
+ (else (next base
+ (+ base mult) rest)))))
+ (define-stream (sift base strm)
+ (next base (+ base base) strm))
+ (stream-let sieve ((strm (stream-from 2)))
+ (let ((first (stream-car strm))
+ (rest (stream-cdr strm)))
+ (stream-cons first (sieve (sift first rest)))))))
+
+(define strm123 (stream 1 2 3))
+
+(define (stream-equal? s1 s2)
+ (cond ((and (stream-null? s1) (stream-null? s2)) #t)
+ ((or (stream-null? s1) (stream-null? s2)) #f)
+ ((equal? (stream-car s1) (stream-car s2))
+ (stream-equal? (stream-cdr s1) (stream-cdr s2)))
+ (else #f)))
+
+(with-test-prefix "stream-null"
+ (pass-if "is a stream" (stream? stream-null))
+ (pass-if "is a null stream" (stream-null? stream-null))
+ (pass-if "is not a stream pair" (not (stream-pair? stream-null))))
+
+(with-test-prefix "stream-cons"
+ (pass-if "is a stream" (stream? (stream-cons 1 stream-null)))
+ (pass-if "is not a null stream" (not (stream-null? (stream-cons 1
stream-null))))
+ (pass-if "is a stream pair" (stream-pair? (stream-cons 1 stream-null))))
+
+(with-test-prefix "stream?"
+ (pass-if "is true for null stream" (stream? stream-null))
+ (pass-if "is true for stream pair" (stream? (stream-cons 1 stream-null)))
+ (pass-if "is false for non-stream" (not (stream? "four"))))
+
+(with-test-prefix "stream-null?"
+ (pass-if "is true for null stream" (stream-null? stream-null))
+ (pass-if "is false for stream pair" (not (stream-null? (stream-cons 1
stream-null))))
+ (pass-if "is false for non-stream" (not (stream-null? "four"))))
+
+(with-test-prefix "stream-pair?"
+ (pass-if "is false for null stream" (not (stream-pair? stream-null)))
+ (pass-if "is true for stream pair" (stream-pair? (stream-cons 1
stream-null)))
+ (pass-if "is false for non-stream" (not (stream-pair? "four"))))
+
+(with-test-prefix "stream-car"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream")
+ (stream-car "four"))
+ (pass-if-exception "throws for null stream"
+ '(wrong-type-arg . "null stream")
+ (stream-car stream-null))
+ (pass-if "returns first of stream" (eqv? (stream-car strm123) 1)))
+
+(with-test-prefix "stream-cdr"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream")
+ (stream-cdr "four"))
+ (pass-if-exception "throws for null stream"
+ '(wrong-type-arg . "null stream")
+ (stream-cdr stream-null))
+ (pass-if "returns rest of stream" (eqv? (stream-car (stream-cdr strm123))
2)))
+
+(with-test-prefix "stream-lambda"
+ (pass-if "returns correct result"
+ (stream-equal?
+ ((rec double (stream-lambda (strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (double (stream-cdr strm))))))
+ strm123)
+ (stream 2 4 6))))
+
+(with-test-prefix "define-stream"
+ (pass-if "returns correct result"
+ (stream-equal?
+ (let ()
+ (define-stream (double strm)
+ (if (stream-null? strm) stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (double (stream-cdr strm)))))
+ (double strm123))
+ (stream 2 4 6))))
+
+(with-test-prefix "list->stream"
+ (pass-if-exception "throws for non-list"
+ '(wrong-type-arg . "non-list argument")
+ (list->stream "four"))
+ (pass-if "returns empty stream for empty list"
+ (stream-null? (list->stream '())))
+ (pass-if "returns stream with same content as given list"
+ (stream-equal? (list->stream '(1 2 3)) strm123)))
+
+(with-test-prefix "port->stream"
+ (pass-if-exception "throws for non-input-port"
+ '(wrong-type-arg . "non-input-port argument")
+ (port->stream "four"))
+ (call-with-input-string "Hello, world!"
+ (lambda (p)
+ (pass-if-equal "reads input string correctly"
+ "Hello, world!"
+ (list->string (stream->list (port->stream p)))))))
+
+(with-test-prefix "stream"
+ (pass-if-equal "with empty stream"
+ '()
+ (stream->list (stream)))
+ (pass-if-equal "with one-element stream"
+ '(1)
+ (stream->list (stream 1)))
+ (pass-if-equal "with three-element stream"
+ '(1 2 3)
+ (stream->list strm123)))
+
+(with-test-prefix "stream->list"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream->list '()))
+ (pass-if-exception "throws for non-integer count"
+ '(wrong-type-arg . "non-integer count")
+ (stream->list "four" strm123))
+ (pass-if-exception "throws for negative count"
+ '(wrong-type-arg . "negative count")
+ (stream->list -1 strm123))
+ (pass-if-equal "returns empty list for empty stream"
+ '()
+ (stream->list (stream)))
+ (pass-if-equal "without count"
+ '(1 2 3)
+ (stream->list strm123))
+ (pass-if-equal "with count longer than stream"
+ '(1 2 3)
+ (stream->list 5 strm123))
+ (pass-if-equal "with count shorter than stream"
+ '(1 2 3)
+ (stream->list 3 (stream-from 1))))
+
+(with-test-prefix "stream-append"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-append "four"))
+ (pass-if "with one stream"
+ (stream-equal? (stream-append strm123) strm123))
+ (pass-if "with two streams"
+ (stream-equal? (stream-append strm123 strm123) (stream 1 2 3 1 2
3)))
+ (pass-if "with three streams"
+ (stream-equal? (stream-append strm123 strm123 strm123)
+ (stream 1 2 3 1 2 3 1 2 3)))
+ (pass-if "append with null is noop"
+ (stream-equal? (stream-append strm123 stream-null) strm123))
+ (pass-if "prepend with null is noop"
+ (stream-equal? (stream-append stream-null strm123) strm123)))
+
+(with-test-prefix "stream-concat"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-concat "four"))
+ (pass-if "with one stream"
+ (stream-equal? (stream-concat (stream strm123)) strm123))
+ (pass-if "with two streams"
+ (stream-equal? (stream-concat (stream strm123 strm123))
+ (stream 1 2 3 1 2 3))))
+
+(with-test-prefix "stream-constant"
+ (pass-if "circular stream of 1 has >100 elements"
+ (eqv? (stream-ref (stream-constant 1) 100) 1))
+ (pass-if "circular stream of 2 has >100 elements"
+ (eqv? (stream-ref (stream-constant 1 2) 100) 1))
+ (pass-if "circular stream of 3 repeats after 3"
+ (eqv? (stream-ref (stream-constant 1 2 3) 3) 1))
+ (pass-if "circular stream of 1 repeats at 1"
+ (stream-equal? (stream-take 8 (stream-constant 1))
+ (stream 1 1 1 1 1 1 1 1)))
+ (pass-if "circular stream of 2 repeats at 2"
+ (stream-equal? (stream-take 8 (stream-constant 1 2))
+ (stream 1 2 1 2 1 2 1 2)))
+ (pass-if "circular stream of 3 repeats at 3"
+ (stream-equal? (stream-take 8 (stream-constant 1 2 3))
+ (stream 1 2 3 1 2 3 1 2))))
+
+(with-test-prefix "stream-drop"
+ (pass-if-exception "throws for non-integer count"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-drop "four" strm123))
+ (pass-if-exception "throws for negative count"
+ '(wrong-type-arg . "negative argument")
+ (stream-drop -1 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-drop 2 "four"))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-drop 0 stream-null)))
+ (pass-if "returns same stream when count is zero"
+ (eq? (stream-drop 0 strm123) strm123))
+ (pass-if "returns dropped-by-one stream when count is one"
+ (stream-equal? (stream-drop 1 strm123) (stream 2 3)))
+ (pass-if "returns null if count is longer than stream"
+ (stream-null? (stream-drop 5 strm123))))
+
+(with-test-prefix "stream-drop-while"
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-drop-while "four" strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-drop-while odd? "four"))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-drop-while odd? stream-null)))
+ (pass-if "returns dropped stream when first element matches"
+ (stream-equal? (stream-drop-while odd? strm123) (stream 2 3)))
+ (pass-if "returns whole stream when first element doesn't match"
+ (stream-equal? (stream-drop-while even? strm123) strm123))
+ (pass-if "returns empty stream if all elements match"
+ (stream-null? (stream-drop-while positive? strm123)))
+ (pass-if "return whole stream if no elements match"
+ (stream-equal? (stream-drop-while negative? strm123) strm123)))
+
+(with-test-prefix "stream-filter"
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-filter "four" strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-filter odd? '()))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-filter odd? (stream))))
+ (pass-if "filters out even numbers"
+ (stream-equal? (stream-filter odd? strm123) (stream 1 3)))
+ (pass-if "filters out odd numbers"
+ (stream-equal? (stream-filter even? strm123) (stream 2)))
+ (pass-if "returns all elements if predicate matches all"
+ (stream-equal? (stream-filter positive? strm123) strm123))
+ (pass-if "returns null if predicate matches none"
+ (stream-null? (stream-filter negative? strm123)))
+ (pass-if "all elements of an odd-filtered stream are odd"
+ (every odd? (stream->list 10 (stream-filter odd? (stream-from 0)))))
+ (pass-if "no elements of an odd-filtered stream are even"
+ (not (any even? (stream->list 10 (stream-filter odd? (stream-from
0)))))))
+
+(with-test-prefix "stream-fold"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-fold "four" 0 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-fold + 0 '()))
+ (pass-if "returns the correct result" (eqv? (stream-fold + 0 strm123) 6)))
+
+(with-test-prefix "stream-for-each"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-for-each "four" strm123))
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-for-each display))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-for-each display "four"))
+ (pass-if "function is called for stream elements"
+ (eqv? (let ((sum 0))
+ (stream-for-each (lambda (x)
+ (set! sum (+ sum x)))
+ strm123)
+ sum)
+ 6)))
+
+(with-test-prefix "stream-from"
+ (pass-if-exception "throws for non-numeric start"
+ '(wrong-type-arg . "non-numeric starting number")
+ (stream-from "four"))
+ (pass-if-exception "throws for non-numeric step"
+ '(wrong-type-arg . "non-numeric step size")
+ (stream-from 1 "four"))
+ (pass-if "works for default values"
+ (eqv? (stream-ref (stream-from 0) 100) 100))
+ (pass-if "works for non-default start and step"
+ (eqv? (stream-ref (stream-from 1 2) 100) 201))
+ (pass-if "works for negative step"
+ (eqv? (stream-ref (stream-from 0 -1) 100) -100)))
+
+(with-test-prefix "stream-iterate"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-iterate "four" 0))
+ (pass-if "returns correct iterated stream with 1+"
+ (stream-equal? (stream-take 3 (stream-iterate 1+ 1)) strm123))
+ (pass-if "returns correct iterated stream with exact-integer-sqrt"
+ (stream-equal? (stream-take 5 (stream-iterate exact-integer-sqrt
65536))
+ (stream 65536 256 16 4 2))))
+
+(with-test-prefix "stream-length"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-length "four"))
+ (pass-if "returns 0 for empty stream" (zero? (stream-length (stream))))
+ (pass-if "returns correct stream length" (eqv? (stream-length strm123) 3)))
+
+(with-test-prefix "stream-let"
+ (pass-if "returns correct result"
+ (stream-equal?
+ (stream-let loop ((strm strm123))
+ (if (stream-null? strm)
+ stream-null
+ (stream-cons (* 2 (stream-car strm))
+ (loop (stream-cdr strm)))))
+ (stream 2 4 6))))
+
+(with-test-prefix "stream-map"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-map "four" strm123))
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-map odd?))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-map odd? "four"))
+ (pass-if "works for one stream"
+ (stream-equal? (stream-map - strm123) (stream -1 -2 -3)))
+ (pass-if "works for two streams"
+ (stream-equal? (stream-map + strm123 strm123) (stream 2 4 6)))
+ (pass-if "returns finite stream for finite first stream"
+ (stream-equal? (stream-map + strm123 (stream-from 1)) (stream 2 4
6)))
+ (pass-if "returns finite stream for finite last stream"
+ (stream-equal? (stream-map + (stream-from 1) strm123) (stream 2 4
6)))
+ (pass-if "works for three streams"
+ (stream-equal? (stream-map + strm123 strm123 strm123) (stream 3 6
9))))
+
+(with-test-prefix "stream-match"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-match '(1 2 3) (_ 'ok)))
+ (pass-if-exception "throws when no pattern matches"
+ '(match-error . "no matching pattern")
+ (stream-match strm123 (() 42)))
+ (pass-if-equal "matches empty stream correctly"
+ 'ok
+ (stream-match stream-null (() 'ok)))
+ (pass-if-equal "matches non-empty stream correctly"
+ 'ok
+ (stream-match strm123 (() 'no) (else 'ok)))
+ (pass-if-equal "matches stream of one element"
+ 1
+ (stream-match (stream 1) (() 'no) ((a) a)))
+ (pass-if-equal "matches wildcard"
+ 'ok
+ (stream-match (stream 1) (() 'no) ((_) 'ok)))
+ (pass-if-equal "matches stream of three elements"
+ '(1 2 3)
+ (stream-match strm123 ((a b c) (list a b c))))
+ (pass-if-equal "matches first element with wildcard rest"
+ 1
+ (stream-match strm123 ((a . _) a)))
+ (pass-if-equal "matches first two elements with wildcard rest"
+ '(1 2)
+ (stream-match strm123 ((a b . _) (list a b))))
+ (pass-if-equal "rest variable matches as stream"
+ '(1 2 3)
+ (stream-match strm123 ((a b . c) (list a b (stream-car c)))))
+ (pass-if-equal "rest variable can match whole stream"
+ '(1 2 3)
+ (stream-match strm123 (s (stream->list s))))
+ (pass-if-equal "successful guard match"
+ 'ok
+ (stream-match strm123 ((a . _) (= a 1) 'ok)))
+ (pass-if-equal "unsuccessful guard match"
+ 'no
+ (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)))
+ (pass-if-equal "unsuccessful guard match with two variables"
+ 'no
+ (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)))
+ (pass-if-equal "successful guard match with two variables"
+ 'yes
+ (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no))))
+
+(with-test-prefix "stream-of"
+ (pass-if "all 3 clause types work"
+ (stream-equal? (stream-of (+ y 6)
+ (x in (stream-range 1 6))
+ (odd? x)
+ (y is (* x x)))
+ (stream 7 15 31)))
+ (pass-if "using two streams creates cartesian product"
+ (stream-equal? (stream-of (* x y)
+ (x in (stream-range 1 4))
+ (y in (stream-range 1 5)))
+ (stream 1 2 3 4 2 4 6 8 3 6 9 12)))
+ (pass-if "using no clauses returns just the expression"
+ (stream-equal? (stream-of 1) (stream 1))))
+
+(with-test-prefix "stream-range"
+ (pass-if-exception "throws for non-numeric start"
+ '(wrong-type-arg . "non-numeric starting number")
+ (stream-range "four" 0))
+ (pass-if-exception "throws for non-numeric end"
+ '(wrong-type-arg . "non-numeric ending number")
+ (stream-range 0 "four"))
+ (pass-if-exception "throws for non-numeric step"
+ '(wrong-type-arg . "non-numeric step size")
+ (stream-range 1 2 "three"))
+ (pass-if "returns increasing range if start < end"
+ (stream-equal? (stream-range 0 5) (stream 0 1 2 3 4)))
+ (pass-if "returns decreasing range if start > end"
+ (stream-equal? (stream-range 5 0) (stream 5 4 3 2 1)))
+ (pass-if "returns increasing range of step 2"
+ (stream-equal? (stream-range 0 5 2) (stream 0 2 4)))
+ (pass-if "returns decreasing range of step 2"
+ (stream-equal? (stream-range 5 0 -2) (stream 5 3 1)))
+ (pass-if "returns empty range if start is past end value"
+ (stream-null? (stream-range 0 1 -1))))
+
+(with-test-prefix "stream-ref"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-ref '() 4))
+ (pass-if-exception "throws for non-integer index"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-ref nats 3.5))
+ (pass-if-exception "throws for negative index"
+ '(wrong-type-arg . "negative argument")
+ (stream-ref nats -3))
+ (pass-if-exception "throws if index goes past end of stream"
+ '(wrong-type-arg . "beyond end of stream")
+ (stream-ref strm123 5))
+ (pass-if-equal "returns first element when index = 0"
+ 1
+ (stream-ref nats 0))
+ (pass-if-equal "returns second element when index = 1"
+ 2
+ (stream-ref nats 1))
+ (pass-if-equal "returns third element when index = 2"
+ 3
+ (stream-ref nats 2)))
+
+(with-test-prefix "stream-reverse"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-reverse '()))
+ (pass-if "returns null when given null"
+ (stream-null? (stream-reverse (stream))))
+ (pass-if "returns (3 2 1) for (1 2 3)"
+ (stream-equal? (stream-reverse strm123) (stream 3 2 1))))
+
+(with-test-prefix "stream-scan"
+ (pass-if-exception "throws for invalid function"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-scan "four" 0 strm123))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-scan + 0 '()))
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-scan + 0 strm123) (stream 0 1 3 6))))
+
+(with-test-prefix "stream-take"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-take 5 "four"))
+ (pass-if-exception "throws for non-integer index"
+ '(wrong-type-arg . "non-integer argument")
+ (stream-take "four" strm123))
+ (pass-if-exception "throws for negative index"
+ '(wrong-type-arg . "negative argument")
+ (stream-take -4 strm123))
+ (pass-if "returns null for empty stream"
+ (stream-null? (stream-take 5 stream-null)))
+ (pass-if "using 0 index returns null for empty stream"
+ (stream-null? (stream-take 0 stream-null)))
+ (pass-if "using 0 index returns null for non-empty stream"
+ (stream-null? (stream-take 0 strm123)))
+ (pass-if "returns first 2 elements of stream"
+ (stream-equal? (stream-take 2 strm123) (stream 1 2)))
+ (pass-if "returns whole stream when index is same as length"
+ (stream-equal? (stream-take 3 strm123) strm123))
+ (pass-if "returns whole stream when index exceeds length"
+ (stream-equal? (stream-take 5 strm123) strm123)))
+
+(with-test-prefix "stream-take-while"
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-take-while odd? "four"))
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural argument")
+ (stream-take-while "four" strm123))
+ (pass-if "returns stream up to first non-matching item"
+ (stream-equal? (stream-take-while odd? strm123) (stream 1)))
+ (pass-if "returns empty stream if first item doesn't match"
+ (stream-null? (stream-take-while even? strm123)))
+ (pass-if "returns whole stream if every item matches"
+ (stream-equal? (stream-take-while positive? strm123) strm123))
+ (pass-if "return empty stream if no item matches"
+ (stream-null? (stream-take-while negative? strm123))))
+
+(with-test-prefix "stream-unfold"
+ (pass-if-exception "throws for invalid mapper"
+ '(wrong-type-arg . "non-procedural mapper")
+ (stream-unfold "four" odd? + 0))
+ (pass-if-exception "throws for invalid predicate"
+ '(wrong-type-arg . "non-procedural pred?")
+ (stream-unfold + "four" + 0))
+ (pass-if-exception "throws for invalid generator"
+ '(wrong-type-arg . "non-procedural generator")
+ (stream-unfold + odd? "four" 0))
+
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-unfold (cut expt <> 2) (cut < <> 10) 1+ 0)
+ (stream 0 1 4 9 16 25 36 49 64 81))))
+
+(with-test-prefix "stream-unfolds"
+ (pass-if "returns the correct result"
+ (stream-equal? (stream-unfolds
+ (lambda (x)
+ (receive (n s) (car+cdr x)
+ (if (zero? n)
+ (values 'dummy '())
+ (values
+ (cons (- n 1) (stream-cdr s))
+ (list (stream-car s))))))
+ (cons 5 (stream-from 0)))
+ (stream 0 1 2 3 4)))
+ (pass-if "handles returns of multiple elements correctly"
+ (stream-equal? (stream-take 16 (stream-unfolds
+ (lambda (n)
+ (values (1+ n) (iota n)))
+ 1))
+ (stream 0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0)))
+ (receive (p np)
+ (stream-unfolds (lambda (x)
+ (receive (n p) (car+cdr x)
+ (if (= n (stream-car p))
+ (values (cons (1+ n) (stream-cdr p))
+ (list n) #f)
+ (values (cons (1+ n) p)
+ #f (list n)))))
+ (cons 1 primes))
+ (pass-if "returns first stream correctly"
+ (stream-equal? (stream-take 15 p)
+ (stream 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)))
+ (pass-if "returns second stream correctly"
+ (stream-equal? (stream-take 15 np)
+ (stream 1 4 6 8 9 10 12 14 15 16 18 20 21 22
24)))))
+
+(with-test-prefix "stream-zip"
+ (pass-if-exception "throws if given no streams" exception:wrong-num-args
+ (stream-zip))
+ (pass-if-exception "throws for non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-zip "four"))
+ (pass-if-exception "throws if any argument is non-stream"
+ '(wrong-type-arg . "non-stream argument")
+ (stream-zip strm123 "four"))
+ (pass-if "returns null when given null as any argument"
+ (stream-null? (stream-zip strm123 stream-null)))
+ (pass-if "returns single-element lists when given one stream"
+ (stream-equal? (stream-zip strm123) (stream '(1) '(2) '(3))))
+ (pass-if "returns double-element lists when given two streams"
+ (stream-equal? (stream-zip strm123 strm123)
+ (stream '(1 1) '(2 2) '(3 3))))
+ (pass-if "returns finite stream if at least one given stream is"
+ (stream-equal? (stream-zip strm123 (stream-from 1))
+ (stream '(1 1) '(2 2) '(3 3))))
+ (pass-if "returns triple-element lists when given three streams"
+ (stream-equal? (stream-zip strm123 strm123 strm123)
+ (stream '(1 1 1) '(2 2 2) '(3 3 3)))))
+
+(with-test-prefix "other tests"
+ (pass-if-equal "returns biggest prime under 1000"
+ 997
+ (stream-car
+ (stream-reverse (stream-take-while (cut < <> 1000) primes))))
+
+ (pass-if "quicksort returns same result as insertion sort"
+ (stream-equal? (qsort < (stream 3 1 5 2 4))
+ (isort < (stream 2 5 1 4 3))))
+
+ (pass-if "merge sort returns same result as insertion sort"
+ (stream-equal? (msort < (stream 3 1 5 2 4))
+ (isort < (stream 2 5 1 4 3))))
+
+ ;; http://www.research.att.com/~njas/sequences/A051037
+ (pass-if-equal "returns 1000th Hamming number"
+ 51200000
+ (stream-ref hamming 999)))
diff --git a/test-suite/tests/srfi-45.test b/test-suite/tests/srfi-45.test
index 573eea0..e9fd029 100644
--- a/test-suite/tests/srfi-45.test
+++ b/test-suite/tests/srfi-45.test
@@ -1,6 +1,7 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;; Copyright André van Tonder. All Rights Reserved.
+;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
@@ -258,3 +259,10 @@
;; Commented out since it takes too long
#;
(test-equal 300000000 (force (times3 100000000))) ;==> bounded space
+
+
+;======================================================================
+; Test promise? predicate (non-standard Guile extension)
+
+(pass-if "promise? predicate"
+ (promise? (delay 1)))
diff --git a/test-suite/tests/sxml.simple.test
b/test-suite/tests/sxml.simple.test
index 623f13e..e52ba31 100644
--- a/test-suite/tests/sxml.simple.test
+++ b/test-suite/tests/sxml.simple.test
@@ -1,6 +1,6 @@
;;;; sxml.simple.test --- (sxml simple) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +20,8 @@
#:use-module (test-suite lib)
#:use-module (sxml simple))
+(define parser-error '(parser-error . ""))
+
(define %xml-sample
;; An XML sample without any space in between tags, to make it easier.
(string-append "<?xml version='1.0' encoding='utf-8'?>"
@@ -50,3 +52,84 @@
(lambda ()
(sxml->xml
(xml->sxml (open-input-string %xml-sample))))))))))
+
+(with-test-prefix "namespaces"
+ (pass-if-equal
+ (xml->sxml "<foo xmlns=\"http://example.org/ns1\";>text</foo>")
+ '(*TOP* (http://example.org/ns1:foo "text")))
+
+ (pass-if-equal
+ (xml->sxml "<foo xmlns=\"http://example.org/ns1\";>text</foo>"
+ #:namespaces '((ns1 . "http://example.org/ns1";)))
+ '(*TOP* (ns1:foo "text")))
+
+ (pass-if-equal
+ (xml->sxml "<foo xmlns:bar=\"http://example.org/ns2\";><bar:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2";)))
+ '(*TOP* (foo (ns2:baz))))
+
+ (pass-if-equal
+ (xml->sxml "<foo><ns2:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2";)))
+ '(*TOP* (foo (ns2:baz))))
+
+ (pass-if-exception "namespace undeclared" parser-error
+ (xml->sxml "<foo><ns2:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2";))
+ #:declare-namespaces? #f)))
+
+(with-test-prefix "whitespace"
+ (pass-if-equal
+ (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>")
+ '(*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n")))
+
+ (pass-if-equal
+ (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>"
+ #:trim-whitespace? #t)
+ '(*TOP* (foo (bar " Alfie the parrot! ")))))
+
+(with-test-prefix "parsed entities"
+ (pass-if-equal
+ '(*TOP* (foo "&"))
+ (xml->sxml "<foo>&</foo>"))
+
+ (pass-if-exception "nbsp undefined" parser-error
+ (xml->sxml "<foo> </foo>"))
+
+ (pass-if-equal
+ '(*TOP* (foo "\xA0"))
+ (xml->sxml "<foo> </foo>"
+ #:entities '((nbsp . "\xA0"))))
+
+ (pass-if-equal
+ '(*TOP* (foo "\xA0"))
+ (xml->sxml "<foo> </foo>"))
+
+ (let ((ents '()))
+ (pass-if-equal
+ (xml->sxml "<foo> &foo;</foo>"
+ #:default-entity-handler
+ (lambda (port name)
+ (case name
+ ((nbsp) "\xa0")
+ (else
+ (set! ents (cons name ents))
+ "qux"))))
+ '(*TOP* (foo "\xa0 qux")))
+
+ (pass-if-equal
+ ents
+ '(foo))))
+
+(with-test-prefix "doctype handlers"
+ (define (handle-foo docname systemid internal-subset)
+ (case docname
+ ((foo)
+ (values #:entities '((greets . "<i>Hello, world!</i>"))))
+ (else
+ (values))))
+
+ (pass-if-equal
+ (xml->sxml "<!DOCTYPE foo><p>&greets;</p>"
+ #:doctype-handler handle-foo)
+ '(*TOP* (p (i "Hello, world!")))))
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 0e81f65..ee64467 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, 2010, 2011 Free Software Foundation,
Inc.
+;;;; Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -239,3 +239,38 @@
((odd? x) (not (even? x)))))
(even? 10))
(current-module))))
+
+(define-module (test-suite test-syncase-3)
+ #:autoload (test-syncase-3-does-not-exist) (baz))
+
+(define-module (test-suite test-syncase)) ;; back to main module
+
+(pass-if "missing autoloads do not foil psyntax"
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (eval '(if #f (baz) #t)
+ (resolve-module '(test-suite test-syncase-3)))))
+
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+ (define-syntax syntax-type
+ (lambda (x)
+ (syntax-case x ()
+ ((_ id resolve?)
+ (call-with-values
+ (lambda ()
+ (syntax-local-binding
+ #'id
+ #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+ (lambda (type value)
+ (with-syntax ((type (datum->syntax #'id type)))
+ #''type)))))))
+
+ (define-syntax-parameter foo
+ (syntax-rules ()))
+
+ (pass-if "syntax-parameters (resolved)"
+ (equal? (syntax-type foo #t) 'macro))
+
+ (pass-if "syntax-parameters (unresolved)"
+ (equal? (syntax-type foo #f) 'syntax-parameter)))
diff --git a/test-suite/tests/texinfo.serialize.test
b/test-suite/tests/texinfo.serialize.test
index 95e26b8..554390c 100644
--- a/test-suite/tests/texinfo.serialize.test
+++ b/test-suite/tests/texinfo.serialize.test
@@ -1,6 +1,6 @@
;;;; texinfo.serialize.test -*- scheme -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -103,7 +103,7 @@
"@iftex
This is only for tex.
-Note. Foo.
+Note. Foo.
@end iftex
diff --git a/test-suite/tests/texinfo.string-utils.test
b/test-suite/tests/texinfo.string-utils.test
index ad19df8..4f2e4c5 100644
--- a/test-suite/tests/texinfo.string-utils.test
+++ b/test-suite/tests/texinfo.string-utils.test
@@ -1,6 +1,6 @@
;;;; texinfo.string-utils.test -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2009, 2010, 2013 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
@@ -109,6 +109,13 @@ to using the function `set-language-environment'.
variable should be set only with M-x customize, which is equivalent to using
the function `set-language-environment'.")))
+ (with-test-prefix "two spaces after end of sentence"
+ (pass-if-equal "This is a sentence. There should be two spaces before."
+ (fill-string "This is a sentence. There should be two spaces before."))
+
+ (pass-if-equal "This is version 2.0..."
+ (fill-string "This is version 2.0...")))
+
(with-test-prefix "test-no-word-break"
(pass-if (equal? "thisisalongword
blah
diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test
index 8a4b593..2cb4a71 100644
--- a/test-suite/tests/texinfo.test
+++ b/test-suite/tests/texinfo.test
@@ -1,6 +1,6 @@
;;;; texinfo.test -*- scheme -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -56,24 +56,24 @@
str
(lambda (port) (texinfo:read-verbatim-body port consumer '())))))
- (pass-if (equal? '()
- (read-verbatim-body-from-string "@end verbatim\n")))
+ (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 address@hidden verbatim\n"))
- (pass-if (equal? '("@end verbatim " " NL\n")
- (read-verbatim-body-from-string "@end verbatim
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))
@@ -84,8 +84,8 @@
(lambda (port) (texinfo:read-arguments port #\}))))
(define (test str expected-res)
- (pass-if (equal? expected-res
- (read-arguments-from-string str))))
+ (pass-if-equal expected-res
+ (read-arguments-from-string str)))
(test "}" '())
(test "foo}" '("foo"))
@@ -111,20 +111,20 @@
(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-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"))))
+ (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))
@@ -149,8 +149,8 @@
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))))))
+ (pass-if-equal expected-data result)
+ (pass-if-equal expected-token token)))))
;; add some newline-related tests here
(test "" #t #f '() eof-object)
@@ -167,8 +167,8 @@
(with-test-prefix "test-texinfo->stexinfo"
(define (test str expected-res)
- (pass-if (equal? expected-res
- (call-with-input-string str texi->stexi))))
+ (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)
@@ -177,9 +177,8 @@
(test (string-append "foo bar address@hidden " title "\n" str)
expected-res))
(define (test-body str expected-res)
- (pass-if str
- (equal? expected-res
- (cddr (try-with-title "zog" str)))))
+ (pass-if-equal str expected-res
+ (cddr (try-with-title "zog" str))))
(define (list-intersperse src-l elem)
(if (null? src-l) src-l
@@ -417,4 +416,9 @@
(name "foo")
(arguments "bar " (code "baz"))))
(para "text that should be in a para")))
+ (test-body "@pxref{Locales, @code{setlocale}}"
+ '((para (pxref (% (node "Locales")
+ (name (code "setlocale")))))))
+ (test-body "Like this---e.g.@:, at colon."
+ '((para "Like this---e.g.:, at colon.")))
)
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index be722fc..8178120 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -1,6 +1,6 @@
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012 Free Software
Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -86,7 +86,12 @@
(equal? (par-map fibo (iota 13))
(map fibo (iota 13))))
#:to 'value
- #:env (current-module))))
+ #:env (current-module)))
+
+ (pass-if-equal "long list" (map 1+ (iota 10000))
+ ;; In Guile 2.0.7, this would trigger a stack overflow.
+ ;; See <http://bugs.gnu.org/13188>.
+ (par-map 1+ (iota 10000))))
;;
;; par-for-each
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index c344795..2ed15c7 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, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -702,6 +702,22 @@
#:opts '(#:partial-eval? #f)))))
+(define (sum . args)
+ (apply + args))
+
+(with-test-prefix "many args"
+ (pass-if "call with > 256 args"
+ (equal? (compile `(1+ (sum ,@(iota 1000)))
+ #:env (current-module))
+ (1+ (apply sum (iota 1000)))))
+
+ (pass-if "tail call with > 256 args"
+ (equal? (compile `(sum ,@(iota 1000))
+ #:env (current-module))
+ (apply sum (iota 1000)))))
+
+
+
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
@@ -1415,11 +1431,11 @@
(number? (string-contains (car w)
"wrong number of arguments")))))
- (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
+ (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
(null? (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) some-port
- "~&~3_~~ ~\n~12they~%")
+ "~&~3_~~ ~\n~12they~% ~!~|~/~q")
#:opts %opts-w-format
#:to 'assembly)))))
@@ -1687,6 +1703,31 @@
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "~^"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "~^, too few args"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected at least 1, got 0")))))
+
+ (pass-if "parameters: +,-,#, and '"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) some-port
+ "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "complex 1"
(let ((w (call-with-warnings
(lambda ()
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index d9bbbeb..dc54ffa 100644
--- a/test-suite/tests/vlist.test
+++ b/test-suite/tests/vlist.test
@@ -287,12 +287,12 @@
;; using the supplied hash procedure, which could lead to
;; inconsistencies.
(let* ((s "hello")
- (vh (fold vhash-consq
- (vhash-consq s "world" vlist-null)
+ (vh (fold vhash-consv
+ (vhash-consv s "world" vlist-null)
(iota 300)
(iota 300))))
- (and (vhash-assq s vh)
- (pair? (vhash-assq s (vhash-delete 123 vh eq? hashq))))))
+ (and (vhash-assv s vh)
+ (pair? (vhash-assv s (vhash-delete 123 vh eqv? hashv))))))
(pass-if "vhash-fold"
(let* ((keys '(a b c d e f g d h i))
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 97f5559..b2c5c2c 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -85,6 +85,113 @@
#t
(error "unexpected exception" component arg))))))))
+(define-syntax pass-if-read-request-line
+ (syntax-rules ()
+ ((_ str expected-method expected-uri expected-version)
+ (pass-if str
+ (equal? (call-with-values
+ (lambda ()
+ (read-request-line (open-input-string
+ (string-append str "\r\n"))))
+ list)
+ (list 'expected-method
+ expected-uri
+ 'expected-version))))))
+
+(define-syntax pass-if-write-request-line
+ (syntax-rules ()
+ ((_ expected-str method uri version)
+ (pass-if expected-str
+ (equal? (string-append expected-str "\r\n")
+ (call-with-output-string
+ (lambda (port)
+ (write-request-line 'method uri 'version port))))))))
+
+(define-syntax pass-if-read-response-line
+ (syntax-rules ()
+ ((_ str expected-version expected-code expected-phrase)
+ (pass-if str
+ (equal? (call-with-values
+ (lambda ()
+ (read-response-line (open-input-string
+ (string-append str "\r\n"))))
+ list)
+ (list 'expected-version
+ expected-code
+ expected-phrase))))))
+
+(define-syntax pass-if-write-response-line
+ (syntax-rules ()
+ ((_ expected-str version code phrase)
+ (pass-if expected-str
+ (equal? (string-append expected-str "\r\n")
+ (call-with-output-string
+ (lambda (port)
+ (write-response-line 'version code phrase port))))))))
+
+(with-test-prefix "read-request-line"
+ (pass-if-read-request-line "GET / HTTP/1.1"
+ GET
+ (build-uri 'http
+ #:path "/")
+ (1 . 1))
+ (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html
HTTP/1.1"
+ GET
+ (build-uri 'http
+ #:host "www.w3.org"
+ #:path "/pub/WWW/TheProject.html")
+ (1 . 1))
+ (pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
+ GET
+ (build-uri 'http
+ #:path "/pub/WWW/TheProject.html")
+ (1 . 1))
+ (pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
+ HEAD
+ (build-uri 'http
+ #:path "/etc/hosts"
+ #:query "foo=bar")
+ (1 . 1)))
+
+(with-test-prefix "write-request-line"
+ (pass-if-write-request-line "GET / HTTP/1.1"
+ GET
+ (build-uri 'http
+ #:path "/")
+ (1 . 1))
+ ;;; FIXME: Test fails due to scheme, host always being removed.
+ ;;; However, it should be supported to request these be present, and
+ ;;; that is possible with absolute/relative URI support.
+ ;; (pass-if-write-request-line "GET
http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1"
+ ;; GET
+ ;; (build-uri 'http
+ ;; #:host "www.w3.org"
+ ;; #:path "/pub/WWW/TheProject.html")
+ ;; (1 . 1))
+ (pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
+ GET
+ (build-uri 'http
+ #:path "/pub/WWW/TheProject.html")
+ (1 . 1))
+ (pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
+ HEAD
+ (build-uri 'http
+ #:path "/etc/hosts"
+ #:query "foo=bar")
+ (1 . 1)))
+
+(with-test-prefix "read-response-line"
+ (pass-if-read-response-line "HTTP/1.0 404 Not Found"
+ (1 . 0) 404 "Not Found")
+ (pass-if-read-response-line "HTTP/1.1 200 OK"
+ (1 . 1) 200 "OK"))
+
+(with-test-prefix "write-response-line"
+ (pass-if-write-response-line "HTTP/1.0 404 Not Found"
+ (1 . 0) 404 "Not Found")
+ (pass-if-write-response-line "HTTP/1.1 200 OK"
+ (1 . 1) 200 "OK"))
+
(with-test-prefix "general headers"
(pass-if-parse cache-control "no-transform" '(no-transform))
@@ -109,6 +216,9 @@
(pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse date "Tue, 15 Nov 1994 16:12:31 +0800"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
(pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
(string->date "Wed, 7 Sep 2011 11:25:00 +0000"
"~a,~e ~b ~Y ~H:~M:~S ~z"))
@@ -180,6 +290,10 @@
(pass-if-parse from "address@hidden" "address@hidden")
(pass-if-parse host "qux" '("qux" . #f))
(pass-if-parse host "qux:80" '("qux" . 80))
+ (pass-if-parse host "[2001:db8::1]" '("2001:db8::1" . #f))
+ (pass-if-parse host "[2001:db8::1]:80" '("2001:db8::1" . 80))
+ (pass-if-parse host "[::ffff:192.0.2.1]" '("::ffff:192.0.2.1" . #f))
+ (pass-if-round-trip "Host: [2001:db8::1]\r\n")
(pass-if-parse if-match "\"xyzzy\", W/\"qux\""
'(("xyzzy" . #t) ("qux" . #f)))
(pass-if-parse if-match "*" '*)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-114-g69e653e,
Noah Lavine <=