diff options
| author | Jed Barber <jjbarber@y7mail.com> | 2017-02-13 18:27:13 +1100 |
|---|---|---|
| committer | Jed Barber <jjbarber@y7mail.com> | 2017-02-13 18:27:13 +1100 |
| commit | 2b8b55de4a18757e8d6769e458c84f7c1df1e261 (patch) | |
| tree | cbd62219babccc04e57fa7708f88385a7f6413d3 | |
| parent | 2b842cb65ce29071d5786bdecc834c026d1f2db2 (diff) | |
Swapped out crypto package for something smaller, revised other code and readme/notes slightly
28 files changed, 2203 insertions, 5091 deletions
@@ -10,7 +10,7 @@ preference deduplication isn't worth it unless there exists some linear dedupe a future direction ---------------- -better commented code, because I'm going to have to maintain this later +revise and better comment code, because I'm going to have to maintain this later util to list paper ids that fit specific criteria to doublecheck potential errors @@ -25,6 +25,4 @@ are they correct now? it's a bit murky with how the AEC records transfers in DOP does the AEC use truncated values or exact ratios for transfer values? does the AEC check for candidates having quota when transfers are only partially done? -REPLACE CRYPTO BIGNUM PACKAGES WITH OWN IMPLEMENTATION - @@ -43,8 +43,11 @@ verbose on the distribution of preferences, and doesn't do bulk exclusions. -Support for bignums (all source files from the 'crypto' package) was obtained from +Support for bignum support (the Multi_Precision_Integers package) was obtained from - https://github.com/cforler/Ada-Crypto-Library + https://sourceforge.net/projects/mathpaqs/ + +Those source files are licensed under the MIT license. All other source is licensed +under CC0. diff --git a/src/bundles-containers.adb b/src/bundles-containers.adb index 8ba0d30..029d7c0 100644 --- a/src/bundles-containers.adb +++ b/src/bundles-containers.adb @@ -20,24 +20,15 @@ package body Bundles.Containers is use type Bundle_Maps.Cursor; use type Bundle_Vectors.Vector; - procedure Update_Bundle - (B : in out Bundle) is - begin - Add (B, Item); - end Update_Bundle; - - procedure Update_Vector - (C : in Candidates.CandidateID; - V : in out Bundle_Vectors.Vector) is - begin - V.Update_Element (V.First_Index, Update_Bundle'Access); - end Update_Vector; - Place : Candidates.CandidateID := Item (Given_Prefs.Preference_Range'First); Current_Cursor : Bundle_Maps.Cursor := BMap.Find (Place); begin if Current_Cursor /= Bundle_Maps.No_Element then - BMap.Update_Element (Current_Cursor, Update_Vector'Access); + declare + Vec_Ref : Bundle_Maps.Reference_Type := BMap.Reference (Current_Cursor); + begin + Add (Vec_Ref.Reference (Vec_Ref.First_Index), Item); + end; else declare New_Bundle : Bundle := Empty_Bundle; diff --git a/src/crypto-asymmetric-prime_tables.ads b/src/crypto-asymmetric-prime_tables.ads deleted file mode 100644 index 66eba8e..0000000 --- a/src/crypto-asymmetric-prime_tables.ads +++ /dev/null @@ -1,193 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - - -with Crypto.Types; -use Crypto.Types; - -package Crypto.Asymmetric.Prime_Tables is - - One_Digit_Primes : constant array(Natural range <>) of Natural := - (2, 3, 5, 7); - - Two_Digit_Primes : constant array(Natural range <>) of Natural := - (11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, - 53, 59, 61, 67, 71, 73, 79, 83, 89, 97); - - Three_Digit_Primes : constant array(Natural range <>) of Natural := - ( 101, 103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157, 163, - 167, 173, 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, 233, - 239, 241, 251, 257, 263, 269, 271, 277, 281, 283, 293, 307, 311, - 313, 317, 331, 337, 347, 349, 353, 359, 367, 373, 379, 383, 389, - 397, 401, 409, 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, - 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, 547, 557, 563, - 569, 571, 577, 587, 593, 599, 601, 607, 613, 617, 619, 631, 641, - 643, 647, 653, 659, 661, 673, 677, 683, 691, 701, 709, 719, 727, - 733, 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, - 823, 827, 829, 839, 853, 857, 859, 863, 877, 881, 883, 887, 907, - 911, 919, 929, 937, 941, 947, 953, 967, 971, 977, 983, 991, 997); - - - Four_Digit_Primes : constant array(Natural range <>) of Natural := - ( 1009, 1013, 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, - 1069, 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, - 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, 1229, - 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, 1297, 1301, - 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, 1381, 1399, 1409, - 1423, 1427, 1429, 1433, 1439, 1447, 1451, 1453, 1459, 1471, 1481, - 1483, 1487, 1489, 1493, 1499, 1511, 1523, 1531, 1543, 1549, 1553, - 1559, 1567, 1571, 1579, 1583, 1597, 1601, 1607, 1609, 1613, 1619, - 1621, 1627, 1637, 1657, 1663, 1667, 1669, 1693, 1697, 1699, 1709, - 1721, 1723, 1733, 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, - 1801, 1811, 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, - 1889, 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, - 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, 2063, - 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, 2131, 2137, - 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, 2221, 2237, 2239, - 2243, 2251, 2267, 2269, 2273, 2281, 2287, 2293, 2297, 2309, 2311, - 2333, 2339, 2341, 2347, 2351, 2357, 2371, 2377, 2381, 2383, 2389, - 2393, 2399, 2411, 2417, 2423, 2437, 2441, 2447, 2459, 2467, 2473, - 2477, 2503, 2521, 2531, 2539, 2543, 2549, 2551, 2557, 2579, 2591, - 2593, 2609, 2617, 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, - 2683, 2687, 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, - 2741, 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, - 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, 2909, - 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, 3001, 3011, - 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, 3083, 3089, 3109, - 3119, 3121, 3137, 3163, 3167, 3169, 3181, 3187, 3191, 3203, 3209, - 3217, 3221, 3229, 3251, 3253, 3257, 3259, 3271, 3299, 3301, 3307, - 3313, 3319, 3323, 3329, 3331, 3343, 3347, 3359, 3361, 3371, 3373, - 3389, 3391, 3407, 3413, 3433, 3449, 3457, 3461, 3463, 3467, 3469, - 3491, 3499, 3511, 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, - 3559, 3571, 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, - 3643, 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, - 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, 3823, - 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, 3911, 3917, - 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, 4001, 4003, 4007, - 4013, 4019, 4021, 4027, 4049, 4051, 4057, 4073, 4079, 4091, 4093, - 4099, 4111, 4127, 4129, 4133, 4139, 4153, 4157, 4159, 4177, 4201, - 4211, 4217, 4219, 4229, 4231, 4241, 4243, 4253, 4259, 4261, 4271, - 4273, 4283, 4289, 4297, 4327, 4337, 4339, 4349, 4357, 4363, 4373, - 4391, 4397, 4409, 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, - 4483, 4493, 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, - 4583, 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, - 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, 4759, - 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, 4861, 4871, - 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, 4943, 4951, 4957, - 4967, 4969, 4973, 4987, 4993, 4999, 5003, 5009, 5011, 5021, 5023, - 5039, 5051, 5059, 5077, 5081, 5087, 5099, 5101, 5107, 5113, 5119, - 5147, 5153, 5167, 5171, 5179, 5189, 5197, 5209, 5227, 5231, 5233, - 5237, 5261, 5273, 5279, 5281, 5297, 5303, 5309, 5323, 5333, 5347, - 5351, 5381, 5387, 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, - 5441, 5443, 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, - 5521, 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, - 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, 5701, - 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, 5801, 5807, - 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, 5861, 5867, 5869, - 5879, 5881, 5897, 5903, 5923, 5927, 5939, 5953, 5981, 5987, 6007, - 6011, 6029, 6037, 6043, 6047, 6053, 6067, 6073, 6079, 6089, 6091, - 6101, 6113, 6121, 6131, 6133, 6143, 6151, 6163, 6173, 6197, 6199, - 6203, 6211, 6217, 6221, 6229, 6247, 6257, 6263, 6269, 6271, 6277, - 6287, 6299, 6301, 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, - 6361, 6367, 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, - 6473, 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, - 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, 6679, - 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, 6763, 6779, - 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, 6841, 6857, 6863, - 6869, 6871, 6883, 6899, 6907, 6911, 6917, 6947, 6949, 6959, 6961, - 6967, 6971, 6977, 6983, 6991, 6997, 7001, 7013, 7019, 7027, 7039, - 7043, 7057, 7069, 7079, 7103, 7109, 7121, 7127, 7129, 7151, 7159, - 7177, 7187, 7193, 7207, 7211, 7213, 7219, 7229, 7237, 7243, 7247, - 7253, 7283, 7297, 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, - 7393, 7411, 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, - 7499, 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, - 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, 7649, - 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, 7727, 7741, - 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, 7841, 7853, 7867, - 7873, 7877, 7879, 7883, 7901, 7907, 7919, 7927, 7933, 7937, 7949, - 7951, 7963, 7993, 8009, 8011, 8017, 8039, 8053, 8059, 8069, 8081, - 8087, 8089, 8093, 8101, 8111, 8117, 8123, 8147, 8161, 8167, 8171, - 8179, 8191, 8209, 8219, 8221, 8231, 8233, 8237, 8243, 8263, 8269, - 8273, 8287, 8291, 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, - 8377, 8387, 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, - 8501, 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, - 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, 8681, - 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, 8747, 8753, - 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831, 8837, 8839, 8849, - 8861, 8863, 8867, 8887, 8893, 8923, 8929, 8933, 8941, 8951, 8963, - 8969, 8971, 8999, 9001, 9007, 9011, 9013, 9029, 9041, 9043, 9049, - 9059, 9067, 9091, 9103, 9109, 9127, 9133, 9137, 9151, 9157, 9161, - 9173, 9181, 9187, 9199, 9203, 9209, 9221, 9227, 9239, 9241, 9257, - 9277, 9281, 9283, 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, - 9371, 9377, 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, - 9439, 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, - 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, 9643, - 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733, 9739, 9743, - 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, 9817, 9829, 9833, - 9839, 9851, 9857, 9859, 9871, 9883, 9887, 9901, 9907, 9923, 9929, - 9931, 9941, 9949, 9967, 9973); - - - -- binary field squaring tables - - T8 : constant array (0..15) of Byte := - (0, 1, 4, 5, 16, 17, 20, 21, 64, 65, 68, 69, 80, 81, 84, 85); - - T16 : constant array (Byte) of DByte := - ( - 0, 1, 4, 5, 16, 17, 20, 21, - 64, 65, 68, 69, 80, 81, 84, 85, - 256, 257, 260, 261, 272, 273, 276, 277, - 320, 321, 324, 325, 336, 337, 340, 341, - 1024, 1025, 1028, 1029, 1040, 1041, 1044, 1045, - 1088, 1089, 1092, 1093, 1104, 1105, 1108, 1109, - 1280, 1281, 1284, 1285, 1296, 1297, 1300, 1301, - 1344, 1345, 1348, 1349, 1360, 1361, 1364, 1365, - 4096, 4097, 4100, 4101, 4112, 4113, 4116, 4117, - 4160, 4161, 4164, 4165, 4176, 4177, 4180, 4181, - 4352, 4353, 4356, 4357, 4368, 4369, 4372, 4373, - 4416, 4417, 4420, 4421, 4432, 4433, 4436, 4437, - 5120, 5121, 5124, 5125, 5136, 5137, 5140, 5141, - 5184, 5185, 5188, 5189, 5200, 5201, 5204, 5205, - 5376, 5377, 5380, 5381, 5392, 5393, 5396, 5397, - 5440, 5441, 5444, 5445, 5456, 5457, 5460, 5461, - 16384, 16385, 16388, 16389, 16400, 16401, 16404, 16405, - 16448, 16449, 16452, 16453, 16464, 16465, 16468, 16469, - 16640, 16641, 16644, 16645, 16656, 16657, 16660, 16661, - 16704, 16705, 16708, 16709, 16720, 16721, 16724, 16725, - 17408, 17409, 17412, 17413, 17424, 17425, 17428, 17429, - 17472, 17473, 17476, 17477, 17488, 17489, 17492, 17493, - 17664, 17665, 17668, 17669, 17680, 17681, 17684, 17685, - 17728, 17729, 17732, 17733, 17744, 17745, 17748, 17749, - 20480, 20481, 20484, 20485, 20496, 20497, 20500, 20501, - 20544, 20545, 20548, 20549, 20560, 20561, 20564, 20565, - 20736, 20737, 20740, 20741, 20752, 20753, 20756, 20757, - 20800, 20801, 20804, 20805, 20816, 20817, 20820, 20821, - 21504, 21505, 21508, 21509, 21520, 21521, 21524, 21525, - 21568, 21569, 21572, 21573, 21584, 21585, 21588, 21589, - 21760, 21761, 21764, 21765, 21776, 21777, 21780, 21781, - 21824, 21825, 21828, 21829, 21840, 21841, 21844, 21845 - ); - - - - end Crypto.Asymmetric.Prime_Tables; diff --git a/src/crypto-asymmetric.ads b/src/crypto-asymmetric.ads deleted file mode 100644 index 34fbc30..0000000 --- a/src/crypto-asymmetric.ads +++ /dev/null @@ -1,32 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - ---with Crypto; - -package Crypto.Asymmetric is - - Invalid_Public_Key_Error : exception; - Invalid_Private_Key_Error : exception; - Plaintext_Too_Long_Error : exception; - Decrypt_Error : exception; - -end Crypto.Asymmetric; diff --git a/src/crypto-types-big_numbers-binfield_utils.adb b/src/crypto-types-big_numbers-binfield_utils.adb deleted file mode 100644 index 5835b6d..0000000 --- a/src/crypto-types-big_numbers-binfield_utils.adb +++ /dev/null @@ -1,319 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - - --- Most algorithms based on Kankerson, Menezes and Vanstones --- "Guide to Elliptic Curve Cryptograpyh" (ISBN: 0-387-95273-x) - - --- f(z) = 2^m + r(z) --- R is the binary representation of r(z) - -with Crypto.Asymmetric.Prime_Tables; - - -separate(Crypto.Types.Big_Numbers) - -package body Binfield_Utils is - - function B_Mod(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned; - - function "xor"(Left, Right: D_Big_Unsigned) return D_Big_Unsigned; - - procedure Set_Last_Index(X : in out D_Big_Unsigned); - - --------------------------------------------------------------------------- - - pragma Optimize (Time); - use Crypto.Asymmetric.Prime_Tables; - - -- compute: a(z) + b(z) mod f(z) - function B_Add(Left,Right : Big_Unsigned) return Big_Unsigned is - N : constant Natural := Natural'Max(Left.Last_Index, Right.Last_Index); - C : Big_Unsigned; - begin - for I in 0..N loop - C.Number(I) := Left.Number(i) xor Right.Number(I); - end loop; - - for I in reverse 0..N loop - if C.Number(I) /= 0 then - C.Last_Index :=I; - exit; - end if; - end loop; - - return C; - end B_Add; - - --------------------------------------------------------------------------- - - - -- compute: a(z) - b(z) mod f(z) - -- in binary field is -a = a. so a - b = a + (-b) = a + b - function B_Sub(Left,Right : Big_Unsigned) return Big_Unsigned is - begin - return B_Add(Left,Right); - end B_Sub; - - - --------------------------------------------------------------------------- - - -- compute: a(z)* z mod f(Z) - function B_Mult(A, F : Big_Unsigned) - return Big_Unsigned is - C : Big_Unsigned; - M : constant Positive := Bit_Length(F)-1; - N : Natural:= M/Word'Size; - begin - C := Shift_Left(A,1); - - if C.Last_Index = N then - N:=M mod Word'Size; - - if (Shift_Right(C.Number(C.Last_Index),N)) = 1 then - C := B_Add(C,F); - end if; - end if; - return C; - - end B_Mult; - - --------------------------------------------------------------------------- - - - --Algorithm 2.34: Right to left comb method for polynominal multiplication - -- compute: a(z)*b(z) mod f(Z) - function B_Mult(Left, Right, F : Big_Unsigned) return Big_Unsigned is - C : D_Big_Unsigned; - B : Big_Unsigned := Right; - -- N : constant Natural := Bit_Length(F); - begin - for K in 0..Word'Size-1 loop - for J in 0..Left.Last_Index loop - if (Shift_Right(Left.Number(J),K) and 1) = 1 then - -- add B to C{i} - for I in J..(J+B.Last_Index) loop - C.Number(I) := C.Number(I) xor B.Number(I-J); - end loop; - end if; - end loop; - if K /= Word'Size-1 then - B:=B_Mult(B,F); - end if; - end loop; - - Set_Last_Index(C); - - return B_Mod(C,F); - - end B_Mult; - - --------------------------------------------------------------------------- - - -- Algorithm 2.39: Polynominal squaring (with wordlength W=8) - -- compute a(z)**2 mod f(z) on a 8 bit processor - -- function B_Square8(A, F : Big_Unsigned) return Big_Unsigned is - -- C : D_Big_Unsigned; - -- L : Natural; - -- begin - -- for I in 0..A.Last_Index loop - -- L := 2*I; - -- C.Number(L) := Word(T8(Natural(A.Number(I) and 15))); - -- L:= L+1; - -- C.Number(L) := - -- Word(T8(Natural(Shift_Right(A.Number(I),4) and 15))); - -- end loop; - - -- Set_Last_Index(C); - - -- return B_Mod(C,F); - -- end B_Square8; - - ------------------------------------------------------------------------- - - -- Algorithm 2.39: Polynominal squaring (with word length W=n*8 for n=>0) - -- compute a(z)**2 mod f(z) - function B_Square(A, F : Big_Unsigned) return Big_Unsigned is - K : constant Natural := Word'Size/8; - N : constant Natural := K/2-1; - --M : constant Natural := Bit_Length(F); - L : Natural; - C : D_Big_Unsigned; - begin - for I in 0..A.Last_Index loop - L := 2*I; - for J in reverse 0..N loop - C.Number(L) := Shift_Left(C.Number(L),16) xor - Word(T16(Byte(Shift_Right(A.Number(I),8*J) and 255))); - end loop; - L:= L+1; - for J in reverse K/2..K-1 loop - C.Number(L) := Shift_Left(C.Number(L),16) xor - Word(T16(Byte(Shift_Right(A.Number(I),8*J) and 255))); - end loop; - end loop; - Set_Last_Index(C); - - return B_Mod(C,F); - end B_Square; - --------------------------------------------------------------------------- - - -- It' my own secret "blow and cut" technic. ;-) - -- compute left(z) mod right(z) - function B_Mod(Left, Right : Big_Unsigned) return Big_Unsigned is - A : Natural := Bit_Length(Left); - B : constant Natural := Bit_Length(Right); - Result : Big_Unsigned; - begin - if A < B or B=0 then - Result.Last_Index := Left.Last_Index; - Result.Number(0..Left.Last_Index) := Left.Number(0..Left.Last_Index); - else - while A >= B loop - Result := Shift_Left(Right,A-B) xor Right; - A := Bit_Length(Result); - end loop; - end if; - return Result; - end B_Mod; - - - - -------------------------------------------------------------------------- - - -- Algorithm 2.49: Binary algorithm for inversion in F_{2^m} - -- computes a(z)^{-1} - function B_Inverse(X, F : Big_Unsigned) return Big_Unsigned is - U : Big_Unsigned := X; - V : Big_Unsigned := F; - G1 : Big_Unsigned := Big_Unsigned_One; - G2 : Big_Unsigned; - begin - if X = Big_Unsigned_Zero or F = Big_Unsigned_Zero then - return F; - end if; - - while U /= Big_Unsigned_One and V /= Big_Unsigned_One loop - - while Is_Even(U) loop - U := Shift_Right(U,1); - if Is_Even(G1) then - G1 := Shift_Right(G1,1); - else - G1 := Shift_Right(B_Add(G1,F),1); - end if; - end loop; - - while Is_Even(V) loop - V := Shift_Right(V,1); - if Is_Even(G2) then - G2 := Shift_Right(G2,1); - else - G2 := Shift_Right(B_Add(G2,F),1); - end if; - end loop; - - if Bit_Length(U) > Bit_Length(V) then - U := B_Add(U,V); - G1 := B_Add(G1,G2); - else - V := B_Add(V,U); - G2 := B_Add(G2,G1); - end if; - end loop; - if U = Big_Unsigned_One then - return G1; - else - return G2; - end if; - end B_Inverse; - - -------------------------------------------------------------------------- - - function B_Div(Left, Right, F : Big_Unsigned) return Big_Unsigned is - R : constant Big_Unsigned := B_Inverse(Right, F); - begin - return B_Mult(Left,R,F); - end B_Div; - - -------------------------------------------------------------------------- - -------------------------------------------------------------------------- - - function B_Mod(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned is - A : Natural := Bit_Length(Left); - B : constant Natural := Bit_Length(Right); - Result : Big_Unsigned; - begin - if A < B or B=0 then - Result.Last_Index := Left.Last_Index; - Result.Number(0..Left.Last_Index) := Left.Number(0..Left.Last_Index); - else - declare - T : D_Big_Unsigned := Left; - Z : D_Big_Unsigned; - begin - Z.Last_Index := Right.Last_Index; - Z.Number(0..Right.Last_Index) := Right.Number(0..Right.Last_Index); - while A >= B loop - T := Shift_Left(Z,A-B) xor T; - A := Bit_Length(T); - end loop; - Result.Last_Index := T.Last_Index; - Result.Number(0..T.Last_Index) := T.Number(0..T.Last_Index); - end; - end if; - return Result; - end B_Mod; - - - -------------------------------------------------------------------------- - - function "xor"(Left, Right: D_Big_Unsigned) return D_Big_Unsigned is - Result : D_Big_Unsigned; - M : constant Natural:= Natural'Max(Left.Last_Index, Right.Last_Index); - begin - for I in 0..M loop - Result.Number(I) := Left.Number(I) xor Right.Number(I); - end loop; - Set_Last_Index(Result); - - return Result; - end "xor"; - - - -------------------------------------------------------------------------- - - procedure Set_Last_Index(X : in out D_Big_Unsigned) is - begin - for I in reverse 0..D_Max_Length loop - if X.Number(I) /= 0 then - X.Last_Index :=I; - exit; - end if; - end loop; - end Set_Last_Index; pragma Inline(Set_Last_Index); - -end Binfield_Utils; diff --git a/src/crypto-types-big_numbers-mod_utils.adb b/src/crypto-types-big_numbers-mod_utils.adb deleted file mode 100644 index 3c02df1..0000000 --- a/src/crypto-types-big_numbers-mod_utils.adb +++ /dev/null @@ -1,741 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Crypto.Types.Random; -with Crypto.Asymmetric.Prime_Tables; ---with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; -with Ada.Text_IO; - -separate(Crypto.Types.Big_Numbers) - -package body Mod_Utils is - - pragma Optimize (Time); - use Crypto.Asymmetric.Prime_Tables; - - - --------------------------------------------------------------------------- - - function Patch(Item, N : Big_Unsigned) - return Big_Unsigned is - Diff : constant Big_Unsigned:=((Big_Unsigned_Last - N) + 1) mod N; - begin - return Add(Item,Diff,N); - end Patch; pragma Inline(Patch); - - --------------------------------------------------------------------------- - - function Add(Left, Right, N : Big_Unsigned) return Big_Unsigned is - L : constant Big_Unsigned := Left mod N; - R : constant Big_Unsigned := Right mod N; - Result : constant Big_Unsigned := L + R; - begin - if Result < Max(L,R) then - return Patch(Result,N); - else return - Result mod N; - end if; - end Add; - - --------------------------------------------------------------------------- - - function Sub(Left, Right, N : Big_Unsigned) return Big_Unsigned is - L : constant Big_Unsigned := Left mod N; - R : constant Big_Unsigned := Right mod N; - begin - if R > L then - return N - R + L; - else return L-R; - end if; - end Sub; - - --------------------------------------------------------------------------- - - function Div(Left, Right, N : Big_Unsigned) return Big_Unsigned is - begin - return Mult(Left,Inverse(Right,N),N); - end Div; pragma Inline(Div); - - - --------------------------------------------------------------------------- - - --from Erik-Zenners handout "Zahlentheoretische Algorithmen" - function Pow(Base, Exponent, N : Big_Unsigned) return Big_Unsigned is - L : constant Big_Unsigned := Base mod N; - R : constant Big_Unsigned := Exponent; - Result : Big_Unsigned := Big_Unsigned_One; - begin - if L = Big_Unsigned_Zero or L = Big_Unsigned_One then - return L; - elsif R = Big_Unsigned_Zero then return Big_Unsigned_One; - else - -- Square_And_Muliply - for I in reverse 0..Bit_Length(R)-1 loop - Result := Mult(Result,Result,N); - if (Shift_Right(R, I) mod 2) = Big_Unsigned_One then - Result := Mult(Result,L,N); - end if; - end loop; - return Result mod N; - end if; - end Pow; - - --------------------------------------------------------------------------- - - --based on Erik-Zenners handout "Zahlentheoretische Algorithmen" - -- (ext. Euklid) - -- This function returns Big_unsigned_Zero if X have no inverse mod n - function Inverse(X, N : Big_Unsigned) return Big_Unsigned is - B : Big_Unsigned := X mod N; - A : Big_Unsigned := N; - begin - -- if gcd(A,B) /= 1 then A have no inverse mod B - if B = Big_Unsigned_Zero or A = Big_Unsigned_Zero or - Gcd(A,B) /= Big_Unsigned_One then - return Big_Unsigned_Zero; - end if; - - declare - T : Big_Unsigned := Big_Unsigned_One; - Tstrich, Tempt : Big_Unsigned; - Q, R : Big_Unsigned; - begin - loop - Big_Div(A,B,Q,R); - if(R = Big_Unsigned_Zero) then - return T; - end if; - - A:=B; - B:=R; - - Tempt:=T; - - T:=Sub(Tstrich,Mult(Q,T,N),N); - - Tstrich:=Tempt; - end loop; - end; - end Inverse; - - --------------------------------------------------------------------------- - - function Get_Random(N : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - Random.Read(Result.Number); - - for I in reverse 0..N.Last_Index loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - return Result mod N ; - end Get_Random; - - --------------------------------------------------------------------------- - - -- this function returns true if X is a Mersenne prim number - function Lucas_Lehmer_Test(X : Big_Unsigned) return Boolean is - Is_Mp : Boolean := false; - begin - - if X.Last_Index = 0 then - for I in 2..Word'Size-1 loop - if X.Number(0) = Shift_Left(2,I)-1 then - Is_Mp := True; - exit; - end if; - end loop; - if Is_Mp = False then return False; - end if; - else - for I in 0..X.Last_Index loop - if X.Number(I) /= Word'Last then return False; - end if; - end loop; - end if; - - declare - P : constant Word := Word(Bit_Length(X)-1); - S : Big_Unsigned := Big_Unsigned_Two+2; --S(1) = 4; - begin - for I in 2..P-1 loop - S := (Mult(S,S,X) - 2) mod X; - end loop; - - if S = Big_Unsigned_Zero then return True; - else return False; - end if; - end; - end Lucas_Lehmer_Test; - - --------------------------------------------------------------------------- - - --from Erik-Zenners handout "Zahlentheoretische Algorithmen" - function Is_Miller_Rabin_Witness(Wit, X : Big_Unsigned) return Boolean is - - B : constant Big_Unsigned := X-1; - Result : Big_Unsigned := Big_Unsigned_One; - Root : Big_Unsigned; - begin - for I in reverse 0..Bit_Length(B)-1 loop - Root := Result; - Result := Mult(Result, Result, X); - if ((Result = Big_Unsigned_One) and - (Root /= Big_Unsigned_One and Root /= B)) then return True; - elsif (Shift_Right(B,I) mod 2) = Big_Unsigned_One then - Result := Mult(Result, Wit, X); - end if; - end loop; - if Result /= Big_Unsigned_One then return True; - else return False; - end if; - end Is_Miller_Rabin_Witness; - - --------------------------------------------------------------------------- - - -- Test if Wit is a witness for N - -- If Wit is a wittness then N is no prime - function Is_Simple_Witness(Wit, N : Big_Unsigned) return Boolean is - begin - -- is Wit a "Miller-Rabin"-witness - if (Wit /= (N-Big_Unsigned_One)) and (Wit /= Big_Unsigned_One) and - Mult(Wit,Wit,N) = Big_Unsigned_One then return True; - - elsif Gcd(Wit,N) /= Big_Unsigned_One then return True; - - -- is Wit a "Fermat-Witness" - -- elsif Pow(Wit,N-1,N) /= Big_Unsigned_One then return True; - else return False; - end if; - end Is_Simple_Witness; - - --------------------------------------------------------------------------- - - - -- Returns true if N passes the specified number of Miller-Rabin tests. - function Passed_Miller_Rabin_Test(X : Big_Unsigned; S : Positive) - return Boolean is - Witness : Big_Unsigned; - begin - -- Do the tests - for I in 1..S loop - -- Generate a uniform random on (1, X) - loop - Witness := Get_Random(X); - exit when Witness > Big_Unsigned_One; - end loop; - if Is_Miller_Rabin_Witness(Witness, X) then - return False; - end if; - end loop; - return true; - end Passed_Miller_Rabin_Test; - - --------------------------------------------------------------------------- - - function Pass_Prime_Test(X : Big_Unsigned; Status : Hardness) - return Boolean is - Rounds : Natural; - X_Bit_Size : constant Natural := Bit_Length(X); - begin - if X < Big_Unsigned_Two then return False; - elsif Is_Even(X) then - if X = Big_Unsigned_Two then return True; - else return False; - end if; - end if; - - --X is odd - - for I in One_Digit_Primes'First+1..One_Digit_Primes'Last loop - if X = Word(One_Digit_Primes(I)) then return true; - elsif X mod Word(One_Digit_Primes(I)) = Big_Unsigned_Zero then - return False; - end if; - end loop; - - for I in Two_Digit_Primes'Range loop - if X = Word(Two_Digit_Primes(I)) then return true; - elsif X mod Word(Two_Digit_Primes(I)) = Big_Unsigned_Zero then - return False; - end if; - end loop; - - if Lucas_Lehmer_Test(X) then - return True; - end if; - - for I in Three_Digit_Primes'Range loop - if X = Word(Three_Digit_Primes(I)) then return true; - elsif X mod Word(Three_Digit_Primes(I)) = Big_Unsigned_Zero then - return False; - end if; - end loop; - - -- The relationship between the certainty and the number of rounds - -- we perform is given in the draft standard ANSI X9.80, "PRIME - -- NUMBER GENERATION, PRIMALITY TESTING, AND PRIMALITY CERTIFICATES". - -- Comment: - -- I don't have a look on this paper. =:) I borrowed this - -- "algorithmen" from the j2sdk1.4.1 library (java/math/BigInteger.java) - -- If you have the permission to send me the draft standard ANSI X9.80 - -- then send it, please! - -- I'm a student. I have no money for ANSI or IEEE drafts. :-( - -- It's right to require money to read a draft? - -- This really really sucks! SCNR! - - if (X_Bit_Size < 100) then Rounds := 50; - elsif (X_Bit_Size < 256) then Rounds := 27; - elsif (X_Bit_Size < 512) then Rounds := 15; - elsif (X_Bit_Size < 768) then Rounds := 8; - elsif (X_Bit_Size < 1024) then Rounds := 4; - else Rounds := 2; - end if; - - declare - Witness : Big_Unsigned; - begin - if Status = Weak then - for I in 1..Rounds loop - loop - Witness := Get_Random(X); - exit when Witness > Big_Unsigned_Two; - end loop; - if Is_Simple_Witness(Witness,X) then return False; - end if; - end loop; - else - for I in 1..Rounds loop - loop - Witness := Get_Random(X); - exit when Witness > Big_Unsigned_Two; - end loop; - if Is_Miller_Rabin_Witness(Witness,X) then return False; - end if; - end loop; - end if; - end; - return True; - end Pass_Prime_Test; - - --------------------------------------------------------------------------- - - - function Is_Prime(X : Big_Unsigned) return Boolean is - begin - return Pass_Prime_Test(X, Strong); - end Is_Prime; pragma Inline (Is_Prime); - - --------------------------------------------------------------------------- - - -- This function is faster then Is_prime but a lot of no strong pseudo - -- primes pass this test - function Looks_Like_A_Prime(X : Big_Unsigned) return Boolean is - begin - return Pass_Prime_Test(X, Weak); - end Looks_Like_A_Prime; pragma Inline(Looks_Like_A_Prime); - - --------------------------------------------------------------------------- - - function Get_Prime(N : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned := Get_Random(N); - begin - if N <= Big_Unsigned_Two then - raise Constraint_Error; - end if; - - -- make sure that Result is odd - Result.Number(0) := Result.Number(0) or 1; - loop - if Is_Prime(Result) then return Result; - else Result := (Result+2) mod N ; - end if; - end loop; - end Get_Prime; - - - --------------------------------------------------------------------------- - - - function "mod"(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned; - - --------------------------------------------------------------------------- - - -- Result = Left * Right (mod N) - function Mult(Left, Right, N : Big_Unsigned) return Big_Unsigned is - T : DWord; - Carry : Word := 0; - R : D_Big_Unsigned; - begin - for I in 0..Left.Last_Index loop - for J in 0..Right.Last_Index loop - T := DWord(Left.Number(I)) * DWord(Right.Number(J)) - + DWord(R.Number(I+J)) + DWord(Carry); - - R.Number(I+J) := Word(T and DWord(Word'Last)); - - Carry:= Word(Shift_Right(T,Word'Size)); - end loop; - R.Number(I+Right.Last_Index+1) := Carry + - R.Number(I+Right.Last_Index+1); - Carry := 0; - end loop; - - for I in reverse 0..D_Max_Length loop - if R.Number(I) /= 0 then - R.Last_Index := I; - exit; - end if; - end loop; - return R mod N; - end Mult; - - --------------------------------------------------------------------------- - - - -- Returns a probability N-bit prime (Result). - function Get_N_Bit_Prime(N : Positive) return Big_Unsigned is - J : Big_Unsigned := Get_Random(Shift_Left(Big_Unsigned_One,N-2)); - Index : constant Natural := (N-1)/Word'Size; - Amount : constant Natural := (N-1) mod Word'Size; - Result : Big_Unsigned := Shift_Left(J,1); - - begin - if N = 1 or N > Size then - raise Constraint_Error; - end if; - - loop - -- Make sure that Result is an odd - Set_Least_Significant_Bit (Result); - - -- Make sure that Result is a N-Bit-Number; - Result.Number (Index) := Result.Number (Index) or - Shift_Left (Word (1), Amount); - - if Amount = 0 then - Result.Last_Index := Index; - end if; - - if Is_Prime(Result) then - return Result; - else - Result:=Result-2; - if Is_Prime(Result) then - return Result; - end if; - end if; - - J := Get_Random (Shift_Left (Big_Unsigned_One, N - 2)); - Result := Shift_Left (J, 1); - end loop; - - end Get_N_Bit_Prime; - - --------------------------------------------------------------------------- - - -- computes the jacobi-symbol - -- return value: - -- 0 : if X mod N = 0 - -- 1 : if X is a quadratic resuide mod N - -- -1 : if X is a quadratic non-resuide mod N - - function Jacobi(X, N : Big_Unsigned) return Integer is - A : Big_Unsigned := X mod N; - begin - - if Is_Even(N) then - raise Constraint_Error; - end if; - - if N = Big_Unsigned_One then return 1; - elsif A = Big_Unsigned_Zero then return 0; - elsif A = Big_Unsigned_One then return 1; - end if; - - while (A mod 4) = Big_Unsigned_Zero loop - exit when (A mod 4) = Big_Unsigned_Zero; - A := Shift_Right(A,2); - end loop; - - if Is_Even(A) then - if (N mod 8 = 1) or (N mod 8 = 7) then - return Jacobi(Shift_Right(A,1),N); - else return -1*Jacobi(Shift_Right(A,1),N); - end if; - else - if (A mod 4 = 1) or (N mod 4 = 1) then - return Jacobi(N mod A, A); - else return -1*Jacobi(N mod A, A); - end if; - end if; - end Jacobi; - - ---------------------------------------------------------------------------- - -----------------------------DOUBLE_SIZE------------------------------------ - ---------------------------------------------------------------------------- - - --only needed for multiplication mod N - --here we need 2*Size-bit numbers to avoid an overflow because - --if one of our provisional result t > BIG_Unsigned_Last - --then there ist no well known algortihm to compute the - -- result of an multiplication mod m - - -- same algorithm for D_Big_Unsigned as for Big_Unsigned - - function "="(Left, Right : D_Big_Unsigned) return Boolean is - begin - if Left.Last_Index = Right.Last_Index then - for I in 0..Left.Last_Index loop - if Left.Number(I) /= Right.Number(I) then return False; - end if; - end loop; - else return False; - end if; - return True; - end"="; - - ---------------------------------------------------------------------------- - - function Shift_Left(Value : D_Big_Unsigned; Amount : Natural) - return D_Big_Unsigned is - begin - if Amount >= (D_Max_Length+1)*Word'Size or - Value = D_Big_Unsigned_Zero - then return D_Big_Unsigned_Zero; - elsif Amount = 0 then return Value; - end if; - - declare - Result : D_Big_Unsigned; - Temp : DLimbs :=(others => 0); - L : constant Natural := Amount mod Word'Size; - R : constant Natural := Word'Size-L; - M : constant Natural := Amount/Word'Size; - begin - Temp(0) := Shift_Left(Value.Number(0), L); - - for I in 1..Value.Last_Index loop - Temp(I) := Shift_Right(Value.Number(I-1), R) + - Shift_Left(Value.Number(I), L); - end loop; - - if Value.Last_Index /= D_Max_Length then - Temp(Value.Last_Index+1):= - Shift_Right(Value.Number(Value.Last_Index), R); - end if; - - for I in Temp'Range loop - if (I+M) > D_Max_Length then - exit; - end if; - Result.Number(I+M):= Temp(I); - end loop; - - for I in reverse 0..D_Max_Length loop - if Result.Number(I) /=0 then - Result.Last_Index:=I; - exit; - end if; - end loop; - return Result; - end; - end Shift_Left; pragma Inline (Shift_Left); - - --------------------------------------------------------------------------- - - - function Bit_Length(X : D_Big_Unsigned) return Natural is - begin - if X = D_Big_Unsigned_Zero then - return 0; - end if; - - for I in reverse 0..Word'Size-1 loop - if Shift_Left(1,I) <= X.Number(X.Last_Index) then - return Word'Size * X.Last_Index + I + 1 ; - end if; - end loop; - return X.Last_Index * Word'Size; - end Bit_Length; pragma Inline (Bit_Length); - - - --------------------------------------------------------------------------- - - function "<"(Left, Right : D_Big_Unsigned) return Boolean is - begin - if Left.Last_Index < Right.Last_Index then return True; - elsif Left.Last_Index > Right.Last_Index then return False; - else - for I in reverse 0..Left.Last_Index loop - if Left.Number(I) < Right.Number(I) then return True; - elsif Left.Number(I) > Right.Number(I) then return False; - end if; - end loop; - end if; - return False; - end "<"; pragma Inline ("<"); - - --------------------------------------------------------------------------- - - function ">"(Left, Right : D_Big_Unsigned) return Boolean is - begin - return Right < Left; - end ">"; pragma Inline (">"); - - - - --------------------------------------------------------------------------- - - function ">="(Left, Right : D_Big_Unsigned) return Boolean is - begin - return not(Left < Right); - end ">="; pragma Inline (">="); - - --------------------------------------------------------------------------- - - function "+"(Left, Right : D_Big_Unsigned) return D_Big_Unsigned; - - function "-"(Left, Right : D_Big_Unsigned) return D_Big_Unsigned is - begin - if Left = Right then return D_Big_Unsigned_Zero; - elsif Left = Right+D_Big_Unsigned_One then return D_Big_Unsigned_One; - elsif Left+D_Big_Unsigned_One = Right then return D_Big_Unsigned_Last; - - -- add the modulus if Right > Left - elsif Right > Left then - return D_Big_Unsigned_Last - Right + Left + D_Big_Unsigned_One; - else - declare - Result : D_Big_Unsigned; - Carry : Word:=0; - begin - -- Remember Left > Right - for I in 0..Left.Last_Index loop - Result.Number(I) := Left.Number(I) - Right.Number(I) - Carry; - if (Right.Number(I) > Left.Number(I)) or - (Carry= 1 and Right.Number(I) = Left.Number(I)) - then Carry :=1; - else Carry :=0; - end if; - if Result.Number(I) /= 0 then - Result.Last_Index := I; - end if; - end loop; - return Result; - end; - end if; - end "-"; - - - --------------------------------------------------------------------------- - - function "mod"(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned is - begin - if Left.Last_Index <= Max_Length then - declare - L : Big_Unsigned; - begin - L.Last_Index := Left.Last_Index; - L.Number(0..Left.Last_Index) := Left.Number(0..Left.Last_Index); - return L mod Right; - end; - end if; - - if Right = Big_Unsigned_Zero then raise Division_By_Zero; - --elsif Right = Big_Unsigned_One then return Big_Unsigned_Zero; - end if; - - -- Now, there is only the case where (Left > Right), (Right /= 0) - -- and |Left|>|Right|. - - declare - Remainder : D_Big_Unsigned:=Left; - Temp_Right, R : D_Big_Unsigned; - Result : Big_Unsigned; - Diff: Natural; - - begin - Temp_Right.Last_Index := Right.Last_Index; - Temp_Right.Number(0..Right.Last_Index) := - Right.Number(0..Right.Last_Index); - R:=Temp_Right; - - while(Remainder >= R) loop - Diff := Bit_Length(Remainder) - Bit_Length(R); - if Diff = 0 then - Remainder := Remainder-R; - exit; - else Diff:=Diff-1; - end if; - Temp_Right := Shift_Left(R, Diff); - Remainder := Remainder-Temp_Right; - end loop; - - Result.Last_Index := Remainder.Last_Index; - Result.Number(0..Result.Last_Index) := - Remainder.Number(0..Result.Last_Index); - return Result; - end; - end "mod"; - - --------------------------------------------------------------------------- - - function "+"(Left, Right : D_Big_Unsigned) return D_Big_Unsigned is - Result : D_Big_Unsigned; - M : constant Natural := Natural'Max(Left.Last_Index, Right.Last_Index); - Temp : Word; - Carry : Word :=0; - begin - - for I in 0..M loop - Temp :=Carry; - Result.Number(I) := Left.Number(I) + Right.Number(I) +Temp; - if Result.Number(I) < Word'Max(Left.Number(I), Right.Number(I)) - then Carry := 1; - else Carry := 0; - end if; - end loop; - - if Carry =1 and M < Max_Length then - Result.Number(M+1) := 1; - Result.Last_Index := M+1; - else - -- Set Result.Last_Index - for I in reverse 0..M loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - --------------------------------------------------------------------------- - -end Mod_Utils; diff --git a/src/crypto-types-big_numbers-utils.adb b/src/crypto-types-big_numbers-utils.adb deleted file mode 100644 index 313ce9b..0000000 --- a/src/crypto-types-big_numbers-utils.adb +++ /dev/null @@ -1,704 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - ---with Ada.Integer_Text_IO; ---with Ada.Strings.Unbounded.Text_IO; -with Crypto.Types.Random; - -SEPARATE(Crypto.Types.Big_Numbers) - -package body Utils is - - pragma Optimize (Time); - - --------------------------------------------------------------------------- - - procedure Swap(X, Y : in out Big_Unsigned) is - Temp : constant Big_Unsigned := X; - begin - X := Y; - Y := Temp; - end Swap; pragma Inline (Swap); - - --------------------------------------------------------------------------- - - procedure Set_Least_Significant_Bit(X : in out Big_Unsigned) is - begin - X.Number(0) := X.Number(0) or 1; - end Set_Least_Significant_Bit; pragma Inline(Set_Least_Significant_Bit); - - --------------------------------------------------------------------------- - - function Is_Odd(X : Big_Unsigned) return Boolean is - begin - if (X.Number(0) and 1) = 1 then return True; - else return False; - end if; - end Is_Odd; pragma Inline(Is_Odd); - - --------------------------------------------------------------------------- - - function Is_Even(X : Big_Unsigned) return Boolean is - begin - if (X.Number(0) and 1) = 0 then return True; - else return False; - end if; - end Is_Even; pragma Inline(Is_Even); - - --------------------------------------------------------------------------- - - procedure Set_Most_Significant_Bit(X : in out Big_Unsigned) is - begin - X.Last_Index := Max_Length; - X.Number(Max_Length) := X.Number(Max_Length) or - Shift_Left(Word(1), Word'Size-1); - end Set_Most_Significant_Bit; pragma Inline(Set_Most_Significant_Bit); - - - --------------------------------------------------------------------------- - - function Bit_Length(X : Big_Unsigned) return Natural is - begin - if X = Big_Unsigned_Zero then - return 0; - end if; - - for I in reverse 0..Word'Size-1 loop - if Shift_Left(1,I) <= X.Number(X.Last_Index) then - return Word'Size * X.Last_Index + I + 1 ; - end if; - end loop; - return X.Last_Index * Word'Size; - end Bit_Length; pragma Inline(Bit_Length); - - --------------------------------------------------------------------------- - - function Lowest_Set_Bit(X : Big_Unsigned) return Natural is - begin - if X = Big_Unsigned_Zero then - raise Is_Zero_Error; - end if; - - for I in 0..X.Last_Index loop - if X.Number(I) /= 0 then - for J in 0..Word'Size-1 loop - if (Shift_Right(X.Number(I),J) and 1) = 1 then - return I*Word'Size+J+1; - end if; - end loop; - end if; - end loop; - return Size+1; --X = Big_unsgned_Zero = 2**(Size+1) - end Lowest_Set_Bit; pragma Inline (Lowest_Set_Bit); - - - --------------------------------------------------------------------------- - - - procedure Inc(X : in out Big_Unsigned) is - begin - if X = Big_Unsigned_Last then - X := Big_Unsigned_Zero; - else - X.Number(0) := X.Number(0) + 1; - for I in 0..X.Last_Index loop - if X.Number(I) /= 0 then - exit; - else X.Number(I+1) := X. Number(I+1) + 1; - end if; - end loop; - - -- if an mod_type overflow occure then we have some extra work do - if X.Number(X.Last_Index) = 0 then - X.Last_Index := X.Last_Index + 1; - end if; - end if; - end Inc; pragma Inline(Inc); - - --------------------------------------------------------------------------- - - procedure Dec(X : in out Big_Unsigned) is - begin - if X = Big_Unsigned_Zero then - X := Big_Unsigned_Last; - else - X.Number(0) := X.Number(0) - 1; - for I in 0..X.Last_Index loop - if X.Number(I) /= Word'Last then - exit; - else X.Number(I+1) := X.Number(I+1) - 1; - end if; - end loop; - - - -- check if we must dec the Last_index too - if X.Number(X.Last_Index) = 0 and X.Last_Index /= 0 then - X.Last_Index := X.Last_Index - 1; - end if; - end if; - end Dec; pragma Inline(Dec); - - --------------------------------------------------------------------------- - - function Shift_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - begin - if Amount >= (Max_Length+1)*Word'Size or Value = Big_Unsigned_Zero - then return Big_Unsigned_Zero; - elsif Amount = 0 then return Value; - end if; - - declare - Result : Big_Unsigned; - Temp : Limbs:=(others => 0); - L : constant Natural := Amount mod Word'Size; - R : constant Natural := Word'Size-L; - M : constant Natural := Amount/Word'Size; - begin - Temp(0) := Shift_Left(Value.Number(0), L); - --- for I in 1..Value.Last_Index loop --- Temp(I) := Shift_Right(Value.Number(I-1), R) + --- Shift_Left(Value.Number(I), L); --- end loop; - for I in 1..Value.Last_Index loop - Temp(I) := Shift_Right(Value.Number(I-1), R) xor - Shift_Left(Value.Number(I), L); - end loop; - - if Value.Last_Index /= Max_Length then - Temp(Value.Last_Index+1):= - Shift_Right(Value.Number(Value.Last_Index), R); - end if; - - for I in Temp'Range loop - if (I+M) > Max_Length then - exit; - end if; - Result.Number(I+M):= Temp(I); - end loop; - for I in reverse 0..Max_Length loop - if Result.Number(I) /=0 then - Result.Last_Index:=I; - exit; - end if; - end loop; - return Result; - end; - end Shift_Left; -- pragma Inline (Shift_Left); - - --------------------------------------------------------------------------- - - function Shift_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - begin - if Amount >= (Max_Length+1)*Word'Size or Value = Big_Unsigned_Zero - then return Big_Unsigned_Zero; - elsif Amount = 0 then return Value; - end if; - - declare - Result : Big_Unsigned:=Big_Unsigned_Zero; - Temp : Limbs :=(others => 0); - R : constant Natural := Amount mod Word'Size; - L : constant Natural := Word'Size-R; - M : constant Natural := Amount/Word'Size; - begin - Temp(Value.Last_Index) := - Shift_Right(Value.Number(Value.Last_Index), R); - --- for I in reverse 0..Value.Last_Index-1 loop --- Temp(I) := Shift_Left(Value.Number(I+1), L) + --- Shift_Right(Value.Number(I), R); --- end loop; - for I in reverse 0..Value.Last_Index-1 loop - Temp(I) := Shift_Left(Value.Number(I+1), L) xor - Shift_Right(Value.Number(I), R); - end loop; - - for I in reverse Temp'Range loop - if (I-M) < 0 then - exit; - end if; - Result.Number(I-M):= Temp(I); - end loop; - - for I in reverse 0..Value.Last_Index loop - if Result.Number(I) /= 0 or I = 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - return Result; - end; - end Shift_Right; --pragma Inline (Shift_Right); - - - --------------------------------------------------------------------------- - - function Rotate_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - L : constant Natural := Amount mod Size; - begin - if Value = Big_Unsigned_Last then - return Big_Unsigned_Last; - end if; - return Shift_Left(Value,L) xor Shift_Right(Value, Size-L); - end Rotate_Left; pragma Inline (Rotate_Left); - - --------------------------------------------------------------------------- - - function Rotate_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - R : constant Natural := Amount mod Size; - begin - if Value = Big_Unsigned_Last then - return Big_Unsigned_Last; - end if; - return Shift_Right(Value,R) xor Shift_Left(Value, Size-R); - end Rotate_Right; pragma Inline (Rotate_Right); - - --------------------------------------------------------------------------- - - function Gcd(Left, Right : Big_Unsigned) return Big_Unsigned is - A : Big_Unsigned := Max(Left,Right); - B : Big_Unsigned := Min(Left,Right); - R : Big_Unsigned; - begin - while B /= Big_Unsigned_Zero loop - R := A mod B; - A := B; - B := R; - end loop; - return A; - end Gcd; pragma Inline (Gcd); - - --------------------------------------------------------------------------- - - function Get_Random return Big_Unsigned is - Result : Big_Unsigned; - begin - Random.Read(Result.Number); - return Result; - end Get_Random; pragma Inline (Get_Random); - - --------------------------------------------------------------------------- - - function Length_In_Bytes(X : Big_Unsigned) return Natural is - Len : constant Natural := Bit_Length(X); - begin - if Len mod Byte'Size = 0 then return (Len / Byte'Size); - else return (Len / Byte'Size) + 1; - end if; - end Length_In_Bytes; pragma Inline (Length_In_Bytes); - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(X : Word) return Big_Unsigned is - Result : constant Big_Unsigned := - (Last_Index => 0, Number => (0 => X, OTHERS => 0)); - begin - return Result; - end To_Big_Unsigned; pragma Inline (To_Big_Unsigned); - - - function To_Words(X : Big_Unsigned) return Words is - begin - return X.Number(0..X.Last_Index); - end To_Words; pragma Inline (To_Words); - - - --------------------------------------------------------------------------- - - function Max(Left, Right : Integer) return Integer is - begin - if Left < Right then - return Right; - else - return Left; - end if; - end Max; - - - --------------------------------------------------------------------------- - - function To_Bytes(X : Big_Unsigned) return Bytes is - L : constant Natural := Max(Length_In_Bytes(X)-1,0); - M : constant Natural := 3; --(Word'Size / Byte'Size) - 1; - E : constant Integer := ((L+1) mod 4) - 1; - B : Bytes(0..L); - begin - for I in 0..X.Last_Index-1 loop - for J in 0..M loop - B(L-I*(M+1)-J) := Byte(Shift_Right(X.Number(I), J*Byte'Size) and - Word(Byte'Last)); - end loop; - end loop; - - if E >= 0 then - for I in 0..E loop - B(I) := Byte(Shift_Right(X.Number(X.Last_Index), (E-I)*Byte'Size) - and Word(Byte'Last)); - end loop; - else - for J in 0..M loop - B(M-J) := Byte(Shift_Right(X.Number(X.Last_Index), J*Byte'Size) - and Word(Byte'Last)); - end loop; - end if; - - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(X : Words) return Big_Unsigned is - Result : Big_Unsigned; - begin - if X'Length > Max_Length then - raise Constraint_Error; - else - Result.Number(0..X'Last-X'First) := X; - end if; - - for I in reverse 0..Max_Length loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - - return Result; - end To_Big_Unsigned; - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(X : Bytes) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural := Word'Size / Byte'Size; -- Bytes per Word - Shift_Amount, counter : Natural:=0; - begin - if X'Length*Byte'Size > Size then - raise Constraint_Error; - end if; - - for I in reverse X'Range loop - Result.Number(Counter/M) := Result.Number(Counter/M) or - Shift_Left(Word(X(I)), Shift_Amount*Byte'Size); - Shift_Amount := (Shift_Amount + 1) mod M; - Counter:=Counter+1; - end loop; - - for I in reverse 0..Max_Length loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - - return Result; - - end To_Big_Unsigned; - - --------------------------------------------------------------------------- - - procedure Big_Div(Dividend, Divisor : in Big_Unsigned; - Quotient, Remainder : out Big_Unsigned) is - Last_Divisor : constant Natural := Divisor.Last_Index; - begin - if (Last_Divisor = 0) then - case Divisor.Number(0) is - when 0 => raise Division_By_Zero; - when 1 => Quotient := Dividend; - Remainder := Big_Unsigned_Zero; - return; - when others => declare - Temp_Remainder : Word; - Temp_Divisor : constant Word := Divisor.Number(0); - begin - -- We use the function Short_Div, which is faster. - -- See below for the implementation of Short_Div. - Short_Div(Dividend, Temp_Divisor, Quotient, Temp_Remainder); - Remainder := (Last_Index => 0, - Number => (Temp_Remainder, others => 0)); - return; - end; - end case; - - elsif (Dividend < Divisor) then - Quotient := Big_Unsigned_Zero; - Remainder := Dividend; - return; - - elsif Dividend = Big_Unsigned_Zero then - Quotient := Big_Unsigned_Zero; - Remainder := Big_Unsigned_Zero; - return; - - elsif (Bit_Length(Dividend) = Bit_Length(Divisor)) then - -- Dividend > Divisor and Divisor /= 0 and - -- |Dividend|=|Divisor| => Dividend/Divisor=1 - Quotient:=Big_Unsigned_One; - Remainder:=Dividend-Divisor; - return; - end if; - - -- Now, there is only the case where (Dividend > Divisor), (Divisor /= 0) - -- and |Dividend|>|Divisor|. - - declare - Temp_Divisor: Big_Unsigned :=Divisor; - Diff: Natural; - begin - Remainder:= Dividend; - Quotient:=Big_Unsigned_Zero; - - while(Remainder >= Divisor) loop - Diff := Bit_Length(Remainder) - Bit_Length(Divisor); - if Diff = 0 then - Quotient:=Quotient+1; - Remainder:=Remainder-Divisor; - return; - else Diff:=Diff-1; - end if; - Temp_Divisor := Shift_Left(Divisor, Diff); - Remainder := Remainder-Temp_Divisor; - Quotient := Quotient + Shift_Left(Big_Unsigned_One, Diff); - end loop; - end; - end Big_Div; - - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - procedure Short_Div(Dividend : in Big_Unsigned; - Divisor : in Word; - Quotient : out Big_Unsigned; - Remainder : out Word) is - begin - - -- simple cases - if (Dividend < Divisor) then - Remainder := Dividend.Number(0); - Quotient := Big_Unsigned_Zero; - return; - elsif (Divisor = 0) then - raise Division_By_Zero; - elsif (Divisor = 1) then - Quotient := Dividend; - Remainder := 0; - return; - elsif (Dividend = Divisor) then - Quotient := Big_Unsigned_One; - Remainder := 0; - return; - end if; - - declare - Last_Dividend : constant Natural := Dividend.Last_Index; - Temp_Quotient : Big_Unsigned; - Carry : Largest_Unsigned := 0; - Temp : Largest_Unsigned; - Temp_Divisor : constant Largest_Unsigned := - Largest_Unsigned(Divisor); - - begin - for I in reverse 0..Last_Dividend loop - Temp := Largest_Unsigned(Dividend.Number(I)) - + Shift_Left(Carry, Word'Size); - Temp_Quotient.Number(I) := Word(Temp / Temp_Divisor); - Carry := Temp mod Temp_Divisor; - end loop; - - if (Last_Dividend > 0) and then - (Temp_Quotient.Number(Last_Dividend) = 0) then - Temp_Quotient.Last_Index := Last_Dividend - 1; - else - Temp_Quotient.Last_Index := Last_Dividend; - end if; - Quotient := Temp_Quotient; - Remainder := Word(Carry); - end; - end Short_Div; - - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --- package IIO renames Ada.Integer_Text_IO; --- package UIO renames Ada.Strings.Unbounded.Text_IO; - - --------------------------------------------------------------------------- - - function To_String(Item : Big_Unsigned; - Base : Number_Base := 10) return String is - S : Unbounded_String := Null_Unbounded_String; - Remainder : Word:=0; - Temp_Item : Big_Unsigned := Item; - Trans : constant array(Word range 0..15) of Character := - ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); - Base_Img : constant String := Base'Img; - begin - if Item = Big_Unsigned_Zero then - if Base = 10 then return "0"; - else - S := "#0#" & S; - S := Base_Img & S; - return Slice(S,2,Length(S)); - end if; - else - if Base /= 10 then - S := "#" & S; - end if; - while (Temp_Item /= Big_Unsigned_Zero) loop - Short_Div(Temp_Item, Word(Base), Temp_Item, Remainder); - S := Trans(Remainder) & S; - end loop; - if Base /= 10 then - S := "#" & S; - S := Base_Img & S; - return Slice(S,2,Length(S)); - end if; - end if; - return To_String(S); - end To_String; - - --------------------------------------------------------------------------- - - procedure Put(Item : in Big_Unsigned; Base : in Number_Base := 10) is - begin - Put(To_String(Item, Base)); - end Put; --pragma Inline(Put); - - --------------------------------------------------------------------------- - - procedure Put_Line(Item : in Big_Unsigned; Base : in Number_Base := 10) is - begin - Put(To_String(Item, Base)); New_Line; - end Put_Line; --pragma Inline(Put_Line); - - --------------------------------------------------------------------------- - - function Get_Digit(C : Character) return Word is - begin - case C is - when '0'..'9' => return Character'Pos(C) - Character'Pos('0'); - when 'A'..'F' => return Character'Pos(C) - Character'Pos('A') + 10; - when others => raise Conversion_Error; - end case; - end Get_Digit; pragma Inline(Get_Digit); - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(S : String) return Big_Unsigned is - Fence_Count: Natural := 0; - Temp : Unbounded_String := Null_Unbounded_String; - M_B : Natural:=0; - begin - if S'Length = 0 then - raise Conversion_Error; - else - for I in reverse S'Range loop - case S(I) is - when '0' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,0); - when '1' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,1); - when '2' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,2); - when '3' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,3); - when '4' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,4); - when '5' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,5); - when '6' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,6); - when '7' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,7); - when '8' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,8); - when '9' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,9); - when 'a' | 'A' => Temp:= 'A' & Temp; M_B:=Natural'Max(M_B,11); - when 'b' | 'B' => Temp:= 'B' & Temp; M_B:=Natural'Max(M_B,12); - when 'c' | 'C' => Temp:= 'C' & Temp; M_B:=Natural'Max(M_B,13); - when 'd' | 'D' => Temp:= 'D' & Temp; M_B:=Natural'Max(M_B,14); - when 'e' | 'E' => Temp:= 'E' & Temp; M_B:=Natural'Max(M_B,15); - when 'f' | 'F' => Temp:= 'F' & Temp; M_B:=Natural'Max(M_B,16); - when '_' | ' ' => null; - when '#' => Fence_Count := Fence_Count+1; Temp:= S(I) & Temp; - when others => raise Conversion_Error; - end case; - end loop; - end if; - - declare - Result : Big_Unsigned; - S2 : constant String := To_String(Temp); - begin - - -- Base = 10 - if Fence_Count = 0 then - if M_B > 10 then - raise Conversion_Error; - end if; - for I in S2'Range loop - Result := Result * 10 + Get_Digit(S2(I)); - end loop; - return Result; - - -- Base /= 10 - -- check fences and size (Min_Size=|2#0#|=4) - elsif Fence_Count /= 2 or S2(S2'Last) /= '#' or S2(S2'First) = '#' - or S2'Length < 4 then - raise Conversion_Error; - end if; - - declare - Base : Number_Base; - begin - --Compute and check Base - if S2(S2'First+1) /= '#' then - if S2(S2'First+2) /= '#' then - raise Conversion_Error; - end if; - Base := Number_Base(Get_Digit(S2(S2'First)) * 10 - + Get_Digit(S2(S2'First+1))); - else Base := Number_Base(Get_Digit(S2(S2'First))); - end if; - - -- Check if all Characters are valid to the base - if M_B > Base then - raise Conversion_Error; - end if; - - --Time to compute the Big_Unsigned - if Base > 10 then - for I in S2'First+3..S2'Last-1 loop - Result := Result * Word(Base) + Get_Digit(S2(I)); - end loop; - else - for I in S2'First+2..S2'Last-1 loop - Result := Result * Word(Base) + Get_Digit(S2(I)); - end loop; - end if; - return Result; - end; - end; - end To_Big_Unsigned; - - --------------------------------------------------------------------------- - - end Utils; - diff --git a/src/crypto-types-big_numbers.adb b/src/crypto-types-big_numbers.adb deleted file mode 100644 index b69e55b..0000000 --- a/src/crypto-types-big_numbers.adb +++ /dev/null @@ -1,921 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; - -package body Crypto.Types.Big_Numbers is - - -- package MIO is new Ada.Text_Io.Modular_IO (Word); - - --------------------------------------------------------------------------- - -----------------------SEPARATED_BODYS------------------------------------- - --------------------------------------------------------------------------- - - package body Utils is separate; - use Utils; - - package body Mod_Utils is separate; - use Mod_Utils; - - package body Binfield_Utils is separate; - use Binfield_Utils; - - --------------------------------------------------------------------------- - ---------------------------COMPARE_FUNCTIONS-------------------------------- - --------------------------------------------------------------------------- - - - --------------------------------------------------------------------------- - -- compare: Big_Unsigned with Big_Unsigned -- - --------------------------------------------------------------------------- - - - function "="(Left, Right : Big_Unsigned) return Boolean is - begin - if Left.Last_Index = Right.Last_Index then - for I in 0..Left.Last_Index loop - if Left.Number(I) /= Right.Number(I) then return False; - end if; - end loop; - else return False; - end if; - return True; - end "="; - - --------------------------------------------------------------------------- - - function "<"(Left, Right : Big_Unsigned) return Boolean is - begin - if Left.Last_Index < Right.Last_Index then return True; - elsif Left.Last_Index > Right.Last_Index then return False; - else - for I in reverse 0..Left.Last_Index loop - if Left.Number(I) < Right.Number(I) then return True; - elsif Left.Number(I) > Right.Number(I) then return False; - end if; - end loop; - end if; - return False; - end "<"; - - --------------------------------------------------------------------------- - - function ">"(Left, Right : Big_Unsigned) return Boolean is - begin - return Right < Left; - end ">"; - - --------------------------------------------------------------------------- - - function "<="(Left, Right : Big_Unsigned) return Boolean is - begin - return not (Right < Left); - end "<="; - - - --------------------------------------------------------------------------- - - - function ">="(Left, Right : Big_Unsigned) return Boolean is - begin - return not (Left < Right); - end ">="; - - --------------------------------------------------------------------------- - - function Min(X, Y : in Big_Unsigned) return Big_Unsigned is - begin - if (X < Y) then return X; - else return Y; - end if; - end Min; - - --------------------------------------------------------------------------- - - function Max(X, Y : in Big_Unsigned) return Big_Unsigned is - begin - if (X < Y) then return Y; - else return X; - end if; - end Max; - - - --------------------------------------------------------------------------- - -- compare: Big_Unsigned with Word -- - --------------------------------------------------------------------------- - - - function "="(Left : Big_Unsigned; Right : Word) return Boolean is - begin - if Left.Last_Index=0 and Left.Number(0) = Right then return True; - else return False; - end if; - end "="; - - --------------------------------------------------------------------------- - - function "="(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return Right = Left; - end "="; - - --------------------------------------------------------------------------- - - function "<"(Left : Big_Unsigned; Right : Word) return Boolean is - begin - if Left.Last_Index > 0 then return False; - else return Left.Number(Left.Last_Index) < Right; - end if; - end "<"; - - --------------------------------------------------------------------------- - - function "<"(Left : Word; Right : Big_Unsigned) return Boolean is - begin - if Right.Last_Index > 0 then return True; - else return Left < Right.Number(Right.Last_Index); - end if; - end "<"; - - --------------------------------------------------------------------------- - - function ">"(Left : Big_Unsigned; Right : Word) return Boolean is - begin - return Right < Left; - end ">"; - - --------------------------------------------------------------------------- - - function ">"(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return Right < Left; - end ">"; - - --------------------------------------------------------------------------- - - function "<="(Left : Big_Unsigned; Right : Word) return Boolean is - begin - return not (Right < Left); - end "<="; - - --------------------------------------------------------------------------- - - function "<="(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return not (Right < Left); - end "<="; - - --------------------------------------------------------------------------- - - function ">="(Left : Big_Unsigned; Right : Word) return Boolean is - begin - return not (Left < Right); - end ">="; - - --------------------------------------------------------------------------- - - function ">="(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return not (Left < Right); - end ">="; - - - --------------------------------------------------------------------------- - ----------------------------BASE_FUNCTIONS--------------------------------- - --------------------------------------------------------------------------- ---============================================================================-- - - function "+"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - L : constant Natural := Natural'Max( Bit_Length(Left), Bit_Length(Right)); - begin - if L + 1 <= Word'Size then - Result.Number(0) := Left.Number(0) + Right.Number(0); - else - - declare - Carry : Big_Unsigned; - Temp : Big_Unsigned; - begin - Carry := Left and Right; - Result := Left xor Right; - Carry := Shift_Left(Carry,1); - loop - Temp := Result and Carry; - Result := Result xor Carry; - Carry := Temp; - Carry := Shift_Left(Carry,1); - exit when Carry = Big_Unsigned_Zero; - end loop; - end; - end if; - - return Result; - end "+"; - --- function "+"(Left, Right : Big_Unsigned) return Big_Unsigned is --- Result: Big_Unsigned; --- Carry : Big_Unsigned; --- Temp : Big_Unsigned; --- begin --- Carry := Left and Right; --- Result := Left xor Right; --- Carry := Shift_Left(Carry,1); --- --ADA Do_While --- loop --- Temp := Result and Carry; --- Result := Result xor Carry; --- Carry := Temp; --- Carry := Shift_Left(Carry,1); --- exit when Carry = Big_Unsigned_Zero; --- end loop; --- return Result; --- end "+"; --------------------------------------------------------------------------------- --- function "+"(Left, Right : Big_Unsigned) return Big_Unsigned is --- Result : Big_Unsigned; --- M : constant Natural := Natural'Max(Left.Last_Index, Right.Last_Index); --- Temp : Word; --- Carry : Word :=0; --- begin --- for I in 0..M loop --- Temp :=Carry; --- Result.Number(I) := Left.Number(I) + Right.Number(I) +Temp; --- if Result.Number(I) < Word'Max(Left.Number(I), Right.Number(I)) --- then Carry := 1; --- else Carry := 0; --- end if; --- end loop; - --- if Carry =1 and M < Max_Length then --- Result.Number(M+1) := 1; --- Result.Last_Index := M+1; --- else --- -- Set Result.Last_Index --- for I in reverse 0..M loop --- if Result.Number(I) /= 0 then --- Result.Last_Index := I; --- return Result; --- end if; --- end loop; --- end if; --- return Result; --- end "+"; ---============================================================================-- - --------------------------------------------------------------------------- - - function "+"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Big_Right : Constant Big_Unsigned := - (Last_Index => 0, Number => (0 => Right, OTHERS => 0)); - begin - return Left + Big_Right; - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - Big_Left : constant Big_Unsigned := (Last_Index => 0, Number => (0 => Left, OTHERS => 0)); - begin - return Big_Left + Right; - end "+"; - - --------------------------------------------------------------------------- - - function "-"(Left, Right : Big_Unsigned) return Big_Unsigned is - begin - -- Add the modulus if Right > Left - if Right > Left then - return Big_Unsigned_Last - Right + Left + 1; --- raise Big_Unsigned_Negative; -- RSA does not run - else - declare - Result : Big_Unsigned; - Carry : Word:=0; - begin - -- Remember: Left => Right - for I in 0..Left.Last_Index loop - Result.Number(I) := Left.Number(I) - Right.Number(I) - Carry; - if (Right.Number(I) > Left.Number(I)) or - (Carry= 1 and Right.Number(I) = Left.Number(I)) - then Carry :=1; - else Carry :=0; - end if; - if Result.Number(I) /= 0 then - Result.Last_Index := I; - end if; - end loop; - return Result; - end; - end if; - end "-"; - - --------------------------------------------------------------------------- - - function "-"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Big_Right : constant Big_Unsigned := (Last_Index => 0, Number => (0 => Right, OTHERS => 0)); - begin - return Left - Big_Right; - end "-"; - - --------------------------------------------------------------------------- - - function "-"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - Big_Left : constant Big_Unsigned := (Last_Index => 0, Number => (0 => Left, OTHERS => 0)); - begin - return Big_Left - Right; - end "-"; - - --------------------------------------------------------------------------- - - function "-"(X : Big_Unsigned) return Big_Unsigned is - begin - if X /= Big_Unsigned_Zero then - return Big_Unsigned_Last-X-1; - else - return X; - end if; - end "-"; - - --------------------------------------------------------------------------- ---============================================================================-- - - function "*"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned ; - L : constant Natural := Bit_Length(Left)+Bit_Length(Right); - begin - if L <= Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - elsif L > 2800 and L <= 3600 then - Result := Karatsuba_P(Left, Right); - elsif L > 3600 then - Result := Toom_Cook_P(Left, Right); - else - declare - Temp : Big_Unsigned; - begin - for I in reverse 0..Left.Last_Index loop - Temp := Left.Number(I) * Right; - Temp := Shift_Left(Temp, (I*Word'Size)); - Result := Result + Temp; - end loop; - end; - end if; - return Result; - end "*"; --------------------------------------------------------------------------------- - - function Russ (Left,Right : Big_Unsigned)return Big_Unsigned is - Result : Big_Unsigned ; - begin - if Bit_Length(Left)+Bit_Length(Right) <= Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - AA : Big_Unsigned := Left; - BB : Big_Unsigned := Right; - begin - while AA > Big_Unsigned_Zero loop - if (AA and Big_Unsigned_One) = 1 then - Result := Result + BB; - AA := AA - 1; - end if; - AA := Shift_Right(AA, 1); - BB := Shift_Left(BB, 1); - end loop; - end; - end if; - return Result; - end Russ; - --------------------------------------------------------------------------------- - - function Karatsuba (Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - Left_1, Left_2 : Big_Unsigned; - Right_1, Right_2 : Big_Unsigned; - P_1, P_2 : Big_Unsigned; - N : constant Natural := Natural'Max( Bit_Length(Left) - , Bit_Length(Right))/2; - begin - Left_1 := Shift_Right(Left, N); - Left_2 := Left - Shift_Left( Left_1, N ); - Right_1 := Shift_Right(Right, N); - Right_2 := Right - Shift_Left( Right_1, N ); - - P_1 := Left_1 * Right_1; - P_2 := Left_2 * Right_2; - Result := Shift_Left(P_1, 2*N) - + Shift_Left(((Left_1 + Left_2)*(Right_1 + Right_2)) - P_1 - P_2, N) - + P_2; - end; - end if; - return Result; - end Karatsuba; - - --------------------------------------------------------------------------------- - - function Karatsuba_P (Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - Left_1, Left_2 : Big_Unsigned:= Big_Unsigned_Zero; - Right_1, Right_2 : Big_Unsigned:= Big_Unsigned_Zero; - P_1, P_2, P_3 : Big_Unsigned:= Big_Unsigned_Zero; - N : constant Natural := Natural'Max( Bit_Length(Left), - Bit_Length(Right))/2; - ----------------------------------------------------------------------- - task type Karatsuba_Task_Type is - entry Input (Left, Right : in Big_Unsigned); - entry Output(Result : out Big_Unsigned); - end Karatsuba_Task_Type; - task body Karatsuba_Task_Type is - X : Big_Unsigned; - Left_Local : Big_Unsigned; - Right_Local : Big_Unsigned; - begin - accept Input (Left, Right : Big_Unsigned) do - Left_Local := Left; - Right_Local := Right; - end Input; - --- X := Karatsuba(Left_Local, Right_Local); - X := Left_Local * Right_Local; - - accept Output(Result : out Big_Unsigned) do - Result := X; - end Output; - end Karatsuba_Task_Type; - Task_1 : Karatsuba_Task_Type; - Task_2 : Karatsuba_Task_Type; - Task_3 : Karatsuba_Task_Type; - ----------------------------------------------------------------------- - begin - Left_1 := Shift_Right(Left, N); - Left_2 := Left - Shift_Left( Left_1, N ); - Right_1 := Shift_Right(Right, N); - Right_2 := Right - Shift_Left( Right_1, N ); - - Task_1.Input(Left_1, Right_1); - Task_2.Input(Left_2, Right_2); - Task_3.Input((Left_1 + Left_2), (Right_1 + Right_2)); - - Task_1.Output(Result => P_1); - Task_2.Output(Result => P_2); - Task_3.Output(Result => P_3); - - Result := Shift_Left(P_1, 2*N) - + Shift_Left((P_3 - P_1 - P_2), N) - + P_2; - end; - end if; - return Result; - end Karatsuba_P; - - ----------------------------------------------------------------------- - - function Toom_Cook(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - - declare - knuth_1 : Array (1..5) of Big_Unsigned; - knuth_2 : Array (1..4) of Big_Unsigned; - knuth_3 : Array (1..3) of Big_Unsigned; - knuth_4 : Array (1..2) of Big_Unsigned; - knuth_5_1 : Big_Unsigned; - L, R : Array (0..3) of Big_Unsigned; - F_Left, F_Right : Array (2..4) of Big_Unsigned; - Z : Array (0..4) of Big_Unsigned; - Length : constant Natural := Natural'Max( Bit_Length(Left) , - Bit_Length(Right) ); - N : constant Natural := Length / 3; - DN : constant Natural := 2 * N; - - begin - - -- SPLITTING ............................................................. - - L(0) := Shift_Right( Left, DN); - L(1) := Shift_Right( Left, N ) - Shift_Left( L(0), N ); - L(2) := Left - Shift_Left( L(0), DN ) - Shift_Left( L(1), N ); - R(0) := Shift_Right( Right, DN); - R(1) := Shift_Right( Right, N ) - Shift_Left( R(0), N ); - R(2) := Right - Shift_Left( R(0), DN ) - Shift_Left( R(1), N ); - - F_Left(2) := Shift_Left(L(0),2) + Shift_Left(L(1),1) + L(2); - F_Right(2) := Shift_Left(R(0),2) + Shift_Left(R(1),1) + R(2); - F_Left(3) := (Shift_Left(L(0),3) + L(0)) + (Shift_Left(L(1),1)+L(1)) + L(2); - F_Right(3) := (Shift_Left(R(0),3) + R(0)) + (Shift_Left(R(1),1)+R(1)) + R(2); - F_Left(4) := Shift_Left(L(0),4) + Shift_Left(L(1),2) + L(2); - F_Right(4) := Shift_Left(R(0),4) + Shift_Left(R(1),2) + R(2); - - -- INTERPOLATION with POINTWISE MULT ..................................... - - knuth_1(1) := L(2)* R(2); - knuth_1(2) := (L(0) + L(1) + L(2)) * (R(0) + R(1) + R(2)); - knuth_1(3) := F_Left(2) * F_Right(2); - knuth_1(4) := F_Left(3) * F_Right(3); - knuth_1(5) := F_Left(4) * F_Right(4); - - knuth_2(1) := knuth_1(2) - knuth_1(1); - knuth_2(2) := knuth_1(3) - knuth_1(2); - knuth_2(3) := knuth_1(4) - knuth_1(3); - knuth_2(4) := knuth_1(5) - knuth_1(4); - knuth_3(1) := Shift_Right((knuth_2(2) - knuth_2(1)),1); - knuth_3(2) := Shift_Right((knuth_2(3) - knuth_2(2)),1); - knuth_3(3) := Shift_Right((knuth_2(4) - knuth_2(3)),1); - knuth_4(1) := (knuth_3(2) - knuth_3(1)) / 3; - knuth_4(2) := (knuth_3(3) - knuth_3(2)) / 3; - knuth_5_1 := Shift_Right(knuth_4(2) - knuth_4(1),2); - - Z(0) := knuth_5_1; - Z(1) := knuth_4(1); - Z(2) := knuth_3(1); - Z(3) := knuth_2(1); - Z(4) := knuth_1(1); - - -- RECOMPOSITION ............................................................ - - knuth_1(1) := Z(1) - (Z(0) + Shift_Left(Z(0),1)); - knuth_1(2) := knuth_1(1) - (Shift_Left(Z(0),1)); - knuth_1(3) := knuth_1(2) - Z(0); - knuth_2(1) := Z(2) - (Shift_Left(knuth_1(1),1)); - knuth_2(2) := knuth_2(1) - knuth_1(2); - knuth_3(1) := Z(3) - knuth_2(1); - - Result := Shift_Left( Z(0), DN*2) - + Shift_Left(knuth_1(3), DN+N) - + Shift_Left(knuth_2(2), DN) - + Shift_Left(knuth_3(1), N) - + Z(4); - end; - end if; - return Result; - end Toom_Cook; - --------------------------------------------------------------------------------- - - function Toom_Cook_P(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - knuth_1 : Array (1..5) of Big_Unsigned; - knuth_2 : Array (1..4) of Big_Unsigned; - knuth_3 : Array (1..3) of Big_Unsigned; - knuth_4 : Array (1..2) of Big_Unsigned; - knuth_5_1 : Big_Unsigned; - L, R : Array (0..3) of Big_Unsigned; - F_Left, F_Right : Array (2..4) of Big_Unsigned; - Z : Array (0..4) of Big_Unsigned; - - Length : constant Natural := Natural'Max(Bit_Length(Left) , - Bit_Length(Right) ); - N : constant Natural := Length / 3; - DN : constant Natural := 2 * N; - - task type Toom_Cook_Task_Type is - entry Input (Left, Right : in Big_Unsigned); - entry Output(Result : out Big_Unsigned); - end Toom_Cook_Task_Type; - task body Toom_Cook_Task_Type is - X : Big_Unsigned; - Left_Local : Big_Unsigned; - Right_Local : Big_Unsigned; - begin - accept Input (Left, Right : Big_Unsigned) do - Left_Local := Left; - Right_Local := Right; - end Input; - - X := Left_Local * Right_Local; - - accept Output(Result : out Big_Unsigned) do - Result := X; - end Output; - end Toom_Cook_Task_Type; - - Task_1 : Toom_Cook_Task_Type; - Task_2 : Toom_Cook_Task_Type; - Task_3 : Toom_Cook_Task_Type; - Task_4 : Toom_Cook_Task_Type; - Task_5 : Toom_Cook_Task_Type; - - begin - -- SPLITTING ............................................................. - L(0) := Shift_Right( Left, DN); - L(1) := Shift_Right( Left, N ) - Shift_Left( L(0), N ); - L(2) := Left - Shift_Left( L(0), DN ) - Shift_Left( L(1), N ); - R(0) := Shift_Right( Right, DN); - R(1) := Shift_Right( Right, N ) - Shift_Left( R(0), N ); - R(2) := Right - Shift_Left( R(0), DN ) - Shift_Left( R(1), N ); - -- EVALUATION ............................................................ - F_Left(2) := Shift_Left(L(0),2) + Shift_Left(L(1),1) + L(2); - F_Right(2) := Shift_Left(R(0),2) + Shift_Left(R(1),1) + R(2); - F_Left(3) := (Shift_Left(L(0),3) + L(0)) - + (Shift_Left(L(1),1)+L(1)) + L(2); - F_Right(3) := (Shift_Left(R(0),3) + R(0)) - + (Shift_Left(R(1),1)+R(1)) + R(2); - F_Left(4) := Shift_Left(L(0),4) + Shift_Left(L(1),2) + L(2); - F_Right(4) := Shift_Left(R(0),4) + Shift_Left(R(1),2) + R(2); - -- INTERPOLATION with POINTWISE MULT ..................................... - Task_1.Input( L(2), R(2) ); - Task_2.Input(L(0) + L(1) + L(2), R(0) + R(1) + R(2)); - Task_3.Input(F_Left(2), F_Right(2)); - Task_4.Input(F_Left(3), F_Right(3)); - Task_5.Input(F_Left(4), F_Right(4)); - Task_1.Output(Result => knuth_1(1)); - Task_2.Output(Result => knuth_1(2)); - Task_3.Output(Result => knuth_1(3)); - Task_4.Output(Result => knuth_1(4)); - Task_5.Output(Result => knuth_1(5)); - - knuth_2(1) := knuth_1(2) - knuth_1(1); - knuth_2(2) := knuth_1(3) - knuth_1(2); - knuth_2(3) := knuth_1(4) - knuth_1(3); - knuth_2(4) := knuth_1(5) - knuth_1(4); - knuth_3(1) := Shift_Right((knuth_2(2) - knuth_2(1)),1); - knuth_3(2) := Shift_Right((knuth_2(3) - knuth_2(2)),1); - knuth_3(3) := Shift_Right((knuth_2(4) - knuth_2(3)),1); - knuth_4(1) := (knuth_3(2) - knuth_3(1)) / 3; - knuth_4(2) := (knuth_3(3) - knuth_3(2)) / 3; - knuth_5_1 := Shift_Right(knuth_4(2) - knuth_4(1),2); - - Z(0) := knuth_5_1; - Z(1) := knuth_4(1); - Z(2) := knuth_3(1); - Z(3) := knuth_2(1); - Z(4) := knuth_1(1); - -- RECOMPOSITION ......................................................... - knuth_1(1) := Z(1) - (Z(0) + Shift_Left(Z(0),1)); - knuth_1(2) := knuth_1(1) - (Shift_Left(Z(0),1)); - knuth_1(3) := knuth_1(2) - Z(0); - knuth_2(1) := Z(2) - (Shift_Left(knuth_1(1),1)); - knuth_2(2) := knuth_2(1) - knuth_1(2); - knuth_3(1) := Z(3) - knuth_2(1); - - Result := Shift_Left( Z(0), DN*2) - + Shift_Left(knuth_1(3), DN+N) - + Shift_Left(knuth_2(2), DN) - + Shift_Left(knuth_3(1), N) - + Z(4); - end; - end if; - return Result; - end Toom_Cook_P; - ---============================================================================-- - --------------------------------------------------------------------------- - - function "*"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - begin - if Right = 0 or Left = Big_Unsigned_Zero then return Big_Unsigned_Zero; - elsif Right = 1 then return Left; - end if; - - declare - Result : Big_Unsigned; - begin - for I in 0..Word'Size loop - if (Shift_Right(Right,I) mod 2) = 1 then - Result:= Result + Shift_Left(Left,I); - end if; - end loop; - return Result; - end; - end "*"; - - --------------------------------------------------------------------------- - - function "*"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - begin - return Right * Left; - end "*"; - - --------------------------------------------------------------------------- - - function "**"(Left, Right : Big_Unsigned) return Big_Unsigned is - begin - if Left = Big_Unsigned_Zero or Left = Big_Unsigned_One then - return Left; - end if; - - -- Square_And_Multiply - declare - Result : Big_Unsigned := Big_Unsigned_One; - begin - for I in reverse 0..Bit_Length(Right)-1 loop - Result := Result * Result; - if (Shift_Right(Right, I) mod 2) = Big_Unsigned_One then - Result := Result * Left; - end if; - end loop; - return Result; - end; - end "**"; - - --------------------------------------------------------------------------- - - - function "/"(Left, Right : Big_Unsigned) return Big_Unsigned is - Q : Big_Unsigned; - R : Big_Unsigned; - begin - Big_Div(Left,Right,Q,R); - return Q; - end "/"; - - --------------------------------------------------------------------------- - - function "/"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - Big_Left: constant Big_Unsigned := - (Last_Index => 0, Number => (0=> Left, others => 0)); - Q : Big_Unsigned; - R : Big_Unsigned; - begin - Big_Div(Big_Left,Right,Q,R); - return Q; - end "/"; - - --------------------------------------------------------------------------- - - function "/"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Q : Big_Unsigned; - R : Word; - begin - Short_Div(Left,Right,Q,R); - return Q; - end "/"; - - - --------------------------------------------------------------------------- - - function "mod"(Left, Right : Big_Unsigned) return Big_Unsigned is - Q : Big_Unsigned; - R : Big_Unsigned; - begin - Big_Div(Left,Right,Q,R); - return R; - end "mod"; - - - - --------------------------------------------------------------------------- - - function "mod"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Q : Big_Unsigned; - R : Word; - begin - Short_Div(Left,Right,Q,R); - declare - Result: constant Big_Unsigned := - (Last_Index => 0, Number => (0 => R, others => 0)); - begin - return Result; - end; - end "mod"; - - --------------------------------------------------------------------------- - - -- This is a helper function - -- This procedure computes/adjust the Last_Index of B - procedure Last_Index(B : in out Big_Unsigned; M : in M_Len:=Max_Length) is - begin - for I in reverse 0..M loop - if B.Number(I) /= 0 then - B.Last_Index := I; - exit; - end if; - end loop; - end Last_Index; pragma Inline (Last_Index); - - --------------------------------------------------------------------------- - - - function "xor"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural:= Natural'Max(Left.Last_Index, Right.Last_Index); - begin - -- xor - for I in 0..M loop - Result.Number(I) := Left.Number(I) xor Right.Number(I); - end loop; - - -- compute the Last_Index - Last_Index(Result,M); - - return Result; - - end "xor"; - - --------------------------------------------------------------------------- - - function "and"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural:= Natural'Min(Left.Last_Index, Right.Last_Index); - begin - - --and - for I in 0..M loop - Result.Number(I) := Left.Number(I) and Right.Number(I); - end loop; - - -- compute last index - Last_Index(Result, M); - - return Result; - end "and"; - - --------------------------------------------------------------------------- - - - function "and"(Left : Big_Unsigned; Right : Word) return Big_Unsigned - is - Result : Big_Unsigned; - begin - - Result.Number(0) := Left.Number(0) and Right; - - -- compute last index - Last_Index(Result, 0); - - return Result; - end "and"; - - --------------------------------------------------------------------------- - - function "and"(Left : Word; Right : Big_Unsigned) return Big_Unsigned - is - Result : Big_Unsigned; - begin - - Result.Number(0) := Left and Right.Number(0); - - -- compute last index - Last_Index(Result, 0); - - return Result; - end "and"; - - --------------------------------------------------------------------------- - - - function "or"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural:= Natural'Max(Left.Last_Index, Right.Last_Index); - begin - -- or - for I in 0..M loop - Result.Number(I) := Left.Number(I) or Right.Number(I); - end loop; - - -- compute last index - Last_Index(Result, M); - - return Result; - end "or"; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - -begin - if Size mod Word'Size /= 0 then - Put("Size must be a multiple of " & Word'Image(Word'Size)); - raise Constraint_Size_Error; - end if; -end Crypto.Types.Big_Numbers; diff --git a/src/crypto-types-big_numbers.ads b/src/crypto-types-big_numbers.ads deleted file mode 100644 index f75ad6b..0000000 --- a/src/crypto-types-big_numbers.ads +++ /dev/null @@ -1,399 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - --- With this packet you can generate (unsigned) n-Bit Numbers (Big_Unsigned). --- You can only create k*m Bit-Numbers where 1 < k < 2**32 and m is the --- size of a CPU-Word. For further informations read the ACL documentation. - --- The look and feel is "borrowed" from J. Delcourt BIG_NUMBER package. --- First I want to use Delcourts package directly, but then I decided to --- rewrite it completly form scratch. ;-) - -with System; - -with Crypto.Types; -use Crypto.Types; - -generic - Size : Positive; - -package Crypto.Types.Big_Numbers is - - type Big_Unsigned is private; - subtype Number_Base is Integer range 2 .. 16; - - -- Do not use this type. This one is only needed for internal purpose. - type D_Big_Unsigned is private; - - --------------------------------------------------------------------------- - ---------------------------Constants--------------------------------------- - --------------------------------------------------------------------------- - - -- A few constants - Big_Unsigned_Zero : constant Big_Unsigned; -- 0 - Big_Unsigned_One : constant Big_Unsigned; -- 1 - Big_Unsigned_Two : constant Big_Unsigned; -- 2 - Big_Unsigned_Three : constant Big_Unsigned; -- 3 - Big_Unsigned_Four : constant Big_Unsigned; -- 4 - Big_Unsigned_Ten : constant Big_Unsigned; -- 10 - Big_Unsigned_Sixteen : constant Big_Unsigned; -- 16 - Big_Unsigned_First : constant Big_Unsigned; -- 0 - Big_Unsigned_Last : constant Big_Unsigned; -- "Big_Unsigned'Last" - - --------------------------------------------------------------------------- - ----------------------------Compare---------------------------------------- - --------------------------------------------------------------------------- - - -- compare: Big Unsigned with Big_Unsigned - function "="(Left, Right : Big_Unsigned) return Boolean; - function "<"(Left, Right : Big_Unsigned) return Boolean; - function ">"(Left, Right : Big_Unsigned) return Boolean; - - function "<="(Left, Right : Big_Unsigned) return Boolean; - function ">="(Left, Right : Big_Unsigned) return Boolean; - - function Min(X, Y : in Big_Unsigned) return Big_Unsigned; - function Max(X, Y : in Big_Unsigned) return Big_Unsigned; - - -- compare: Big Unsigned with Word - function "="(Left : Big_Unsigned; Right : Word) return Boolean; - function "="(Left : Word; Right : Big_Unsigned) return Boolean; - - function "<"(Left : Big_Unsigned; Right : Word) return Boolean; - function "<"(Left : Word; Right : Big_Unsigned) return Boolean; - - function ">"(Left : Big_Unsigned; Right : Word) return Boolean; - function ">"(Left : Word; Right : Big_Unsigned) return Boolean; - - function "<="(Left : Big_Unsigned; Right : Word) return Boolean; - function "<="(Left : Word; Right : Big_Unsigned) return Boolean; - - function ">="(Left : Big_Unsigned; Right : Word) return Boolean; - function ">="(Left : Word; Right : Big_Unsigned) return Boolean; - - - --------------------------------------------------------------------------- - -----------------------------Basic----------------------------------------- - --------------------------------------------------------------------------- - - function "+"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "+"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "+"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "-"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "-"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "-"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "-"(X : Big_Unsigned) return Big_Unsigned; - - function "*"(Left, Right : Big_Unsigned) return Big_Unsigned; ---============================================================================-- - function Russ (Left, Right : Big_Unsigned) return Big_Unsigned; - function Karatsuba (Left, Right : Big_Unsigned) return Big_Unsigned; - function Karatsuba_P (Left, Right : Big_Unsigned) return Big_Unsigned; --- function Karatsuba_Prot (Left, Right : Big_Unsigned) return Big_Unsigned; - function Toom_Cook (Left, Right : Big_Unsigned) return Big_Unsigned; - function Toom_Cook_P (Left, Right : Big_Unsigned) return Big_Unsigned; ---============================================================================-- - function "*"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "*"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "/"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "/"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "/"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "xor"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "or" (Left, Right : Big_Unsigned) return Big_Unsigned; - - function "and"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "and"(Left: Big_Unsigned; Right: Word) return Big_Unsigned; - function "and"(Left: Word; Right: Big_Unsigned) return Big_Unsigned; - - function "**"(Left, Right : Big_Unsigned) return Big_Unsigned; - - function "mod"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "mod"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - - --------------------------------------------------------------------------- - ----------------------------Utils------------------------------------------ - --------------------------------------------------------------------------- - - package Utils is - - procedure Swap(X, Y : in out Big_Unsigned); - - procedure Set_Least_Significant_Bit(X : in out Big_Unsigned); - procedure Set_Most_Significant_Bit(X : in out Big_Unsigned); - - -- Returns true if X is odd . - function Is_Odd(X : Big_Unsigned) return Boolean; - - -- Returns true if X is even. - function Is_Even(X : Big_Unsigned) return Boolean; - - - -- Caution: All operations are mod Big_unsigned_Last+1. - -- X = Big_unsigned_Zero - -- Inc(X) - -- X = Big_Unsigned_Last - -- Dec(X) - -- X = Big_unsigned_Zero - procedure Inc(X : in out Big_Unsigned); - procedure Dec(X : in out Big_Unsigned); - - function To_Big_Unsigned(X : Word) return Big_Unsigned; - - - function Shift_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Shift_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Rotate_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Rotate_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Get_Random return Big_Unsigned; - - function Bit_Length(X : Big_Unsigned) return Natural; - - function Lowest_Set_Bit(X : Big_Unsigned) return Natural; - - function Length_In_Bytes(X : Big_Unsigned) return Natural; - - function Gcd(Left, Right : Big_Unsigned) return Big_Unsigned; - - function To_Bytes(X : Big_Unsigned) return Bytes; - - function To_Big_Unsigned(X : Bytes) return Big_Unsigned; - - function To_Words(X : Big_Unsigned) return Words; - - function To_Big_Unsigned(X : Words) return Big_Unsigned; - - function To_String(Item : Big_Unsigned; - Base : Number_Base := 10) return String; - - function To_Big_Unsigned(S : String) return Big_Unsigned; - - procedure Put(Item : in Big_Unsigned; Base : in Number_Base := 10); - - procedure Put_Line(Item : in Big_Unsigned; Base : in Number_Base := 10); - - - procedure Big_Div(Dividend, Divisor : in Big_Unsigned; - Quotient, Remainder : out Big_Unsigned); - - procedure Short_Div(Dividend : in Big_Unsigned; - Divisor : in Word; - Quotient : out Big_Unsigned; - Remainder : out Word); - end Utils; - - --------------------------------------------------------------------------- - --------------------------Mod_Utils---------------------------------------- - --------------------------------------------------------------------------- - - package Mod_Utils is - -- All operations in this package are mod N - - function Add (Left, Right, N : Big_Unsigned) return Big_Unsigned; - function Sub (Left, Right, N : Big_Unsigned) return Big_Unsigned; - function Div (Left, Right, N : Big_Unsigned) return Big_Unsigned; - function Mult(Left, Right, N : Big_Unsigned) return Big_Unsigned; --- function Barrett(Left, Right, M : Big_Unsigned) return Big_Unsigned; --- function Mult_School(Left, Right, N : Big_Unsigned) return Big_Unsigned; - - function Pow (Base, Exponent, N : Big_Unsigned) return Big_Unsigned; - - -- Returns a random Big_Unsigned mod N - function Get_Random (N : Big_Unsigned) return Big_Unsigned; - - function Inverse (X, N : Big_Unsigned) return Big_Unsigned; - - - -- This function returns with an overwhelming probability a prim - function Get_Prime(N : Big_Unsigned) return Big_Unsigned; - - -- This function returns with an overwhelming probability a n-bit prim - function Get_N_Bit_Prime(N : Positive) return Big_Unsigned; - - -- This function returns true if X is a prim and - -- with an overwhelming probability false if X is not prime - -- The change that a snowball survive one day in hell are greater that - -- this function returns true if X is no prim. - -- functionality: - -- 1. Test if a one digit prime (2,3,5,7) divides X - -- 2. Test if a two digit prime number divides X - -- 3. Test if X is a "Lucas-Lehmer" prime - -- 4. Test if a three digit prime number divides X - -- 5. compute N random Big_Unsigneds and test if one - -- of those is an Miller-Rabin wittness ( 1 < N < 51) - -- (N depends on the Bit_Length of X). - function Is_Prime(X : Big_Unsigned) return Boolean; - - - -- a weaker but faster prime test - function Looks_Like_A_Prime(X : Big_Unsigned) return Boolean; - - - -- Returns only true if X passed n iterations of the - -- Miller-Rabin tests. This test is taken from the DSA spec (NIST FIPS - -- 186-2).The execution time of this function is proportional - -- to the value of this parameter. - -- The probability that a pseudoprim pass this test is < (1/(2**(2*S))) - function Passed_Miller_Rabin_Test(X : Big_Unsigned; - S : Positive) return Boolean; - - function Jacobi(X, N : Big_Unsigned) return Integer; - - - -- internal functions for Binfield_Utils. Please, DON'T use them. - function Shift_Left(Value : D_Big_Unsigned; Amount : Natural) - return D_Big_Unsigned; - function Bit_Length(X : D_Big_Unsigned) return Natural; - end Mod_Utils; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - package Binfield_Utils is - - -- binary field operations - -- F is the irreducible polynom with f(z)=2^m + r(z) - -- Remember all operations are in GF(2^m) - - function B_Add(Left,Right : Big_Unsigned) return Big_Unsigned; - function B_Sub(Left,Right : Big_Unsigned) return Big_Unsigned; - - function B_Mult(Left, Right, F : Big_Unsigned) return Big_Unsigned; - function B_Div (Left, Right, F : Big_Unsigned) return Big_Unsigned; - - function B_Square(A, F : Big_Unsigned) return Big_Unsigned; - - function B_Mod(Left, Right : Big_Unsigned) return Big_Unsigned; - - function B_Inverse(X, F : Big_Unsigned) return Big_Unsigned; - - end Binfield_Utils; - - --------------------------------------------------------------------------- - -----------------------------Exceptions------------------------------------ - --------------------------------------------------------------------------- - - Constraint_Size_Error : exception; - Division_By_Zero : exception; - Conversion_Error : exception; - Is_Zero_Error : exception; - --- Big_Unsigned_Overflow : exception; --- Big_Unsigned_Negative : exception; - - --------------------------------------------------------------------------- - --------------------------------PRIVATE------------------------------------ - --------------------------------------------------------------------------- - -private - type Largest_Unsigned is mod System.Max_Binary_Modulus; - - Max_Length : Natural := (Size/Word'Size)-1; - D_Max_Length : Positive := 2*Max_Length+1; - - subtype Limbs is Words(0..Max_Length); - subtype DLimbs is Words(0..D_Max_Length); - - subtype M_Len is Natural range Limbs'Range; - - -- This is our Big_Unsigned - -- It represents a Size*Word'Size-bit number - -- Last_Index is the Number of the last slice who - -- contains the most significant bit of the current number. - -- Ex.: - -- Word'Size = 24 - -- Our Big_Unsigned A is equal to 2**100-7 - -- Big_Unsignesd_Last = 2**240-1 - -- So only Slice 0-4 contains a part of the current 99-Bit number (2**100-7) - -- In this case A.Last_Index = 4 because A.X(5)=...=A.X(9)=0 - - type Big_Unsigned is record - Last_Index : Natural:=0; - Number : Limbs:=(others => 0); - end record; - - type D_Big_Unsigned is record - Last_Index : Natural:=0; - Number : DLimbs:=(others => 0); - end record; - - -- prime test - type Hardness is (Weak, Strong); - - - -- Constants definitions - Big_Unsigned_Zero : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (OTHERS => 0)); - Big_Unsigned_One : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 1, OTHERS => 0)); - Big_Unsigned_Two : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 2, OTHERS => 0)); - Big_Unsigned_Three : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 3, OTHERS => 0)); - Big_Unsigned_Four : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 4, OTHERS => 0)); - Big_Unsigned_Ten : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 10, OTHERS => 0)); - Big_Unsigned_Sixteen : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 16, OTHERS => 0)); - Big_Unsigned_First : CONSTANT Big_Unsigned := - Big_Unsigned_Zero; - Big_Unsigned_Last : CONSTANT Big_Unsigned := - (Last_Index => Max_Length, Number => (OTHERS => Word'Last)); - - - D_Big_Unsigned_Zero : CONSTANT D_Big_Unsigned := - (Last_Index => 0, Number => (OTHERS => 0)); - D_Big_Unsigned_One : CONSTANT D_Big_Unsigned := - (Last_Index => 0, Number => (0 => 1, OTHERS => 0)); - D_Big_Unsigned_Last : CONSTANT D_Big_Unsigned := - (Last_Index => D_Max_Length, Number => (OTHERS => Word'Last)); - - -- Shifting - - function Shift_Left (Value : Largest_Unsigned; Amount : Natural) - return Largest_Unsigned; - function Shift_Right (Value : Largest_Unsigned; Amount : Natural) - return Largest_Unsigned; - - - - --pragma Inline("-", "/", "**", "mod", "xor", "and", "or"); - pragma Inline("=", "<", ">", "<=", ">=", Min, Max); - pragma Import (Intrinsic, Shift_Left); - pragma Import (Intrinsic, Shift_Right); - - pragma Optimize (Time); - -end Crypto.Types.Big_Numbers; diff --git a/src/crypto-types-random.adb b/src/crypto-types-random.adb deleted file mode 100644 index 4eb6aca..0000000 --- a/src/crypto-types-random.adb +++ /dev/null @@ -1,72 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. ---with Ada.Numerics.Discrete_Random; - -with Crypto; -with Crypto.Types.Random_Source.File; - -package body Crypto.Types.Random is - Dev_Random : Crypto.Types.Random_Source.File.Random_Source_File; - - Rnd_Src : aliased Crypto.Types.Random_Source.Random_Source'Class - := Crypto.Types.Random_Source.Random_Source'Class(Dev_Random); - - procedure Set(Source : in Crypto.Types.Random_Source.Random_Source'Class) is - begin - Rnd_Src := Source; - end Set; - - procedure Read(B : out Byte) is - begin - Rnd_Src.Read(B); - end Read; - - procedure Read(Byte_Array : out Bytes) is - begin - Rnd_Src.Read(Byte_Array); - end Read; - - procedure Read(B : out B_Block128) is - begin - Rnd_Src.Read(B); - end Read; - - procedure Read(W : out Word) is - begin - Rnd_Src.Read(W); - end Read; - - procedure Read(Word_Array : out Words) is - begin - Rnd_Src.Read(Word_Array); - end Read; - - procedure Read(D : out DWord) is - begin - Rnd_Src.Read(D); - end Read; - - procedure Read(DWord_Array : out DWords) is - begin - Rnd_Src.Read(DWord_Array); - end Read; -end Crypto.Types.Random; diff --git a/src/crypto-types-random.ads b/src/crypto-types-random.ads deleted file mode 100644 index a3e0b37..0000000 --- a/src/crypto-types-random.ads +++ /dev/null @@ -1,41 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Crypto.Types.Random_Source; -use Crypto.Types; - -package Crypto.Types.Random is - procedure Set(Source : in Crypto.Types.Random_Source.Random_Source'Class); - - procedure Read(B : out Byte); - procedure Read(Byte_Array : out Bytes); - procedure Read(B : out B_Block128); - - procedure Read(W : out Word); - procedure Read(Word_Array : out Words); - - procedure Read(D : out DWord); - procedure Read(DWord_Array : out DWords); - - pragma Inline (Read); - pragma Optimize (Time); -end Crypto.Types.Random; diff --git a/src/crypto-types-random_source-file.adb b/src/crypto-types-random_source-file.adb deleted file mode 100644 index e665990..0000000 --- a/src/crypto-types-random_source-file.adb +++ /dev/null @@ -1,144 +0,0 @@ -package body Crypto.Types.Random_Source.File is - use Ada.Strings.Unbounded; - use Ada.Streams.Stream_IO; - - --------------------------------------------------------------------------- - ------------------------ Initialization ----------------------------------- - --------------------------------------------------------------------------- - - - procedure Initialize(This : in out Random_Source_File) is - Path : constant String := "/dev/random"; - Mode : constant File_Mode := In_File; - begin - if This.Source_File = null then - This.Source_File := new Ada.Streams.Stream_IO.File_Type; - end if; - if not Is_Open(This.Source_File.all) then - Open(This.Source_File.all, Mode, Path, "shared=yes"); - This.Source_Path := To_Unbounded_String(Path); - end if; - end Initialize; - - --------------------------------------------------------------------------- - - procedure Initialize(This : in out Random_Source_File; - File_Path : in String) is - Mode : constant File_Mode := In_File; - begin - if Is_Open(This.Source_File.all) then - Close(This.Source_File.all); - end if; - if not Is_Open(This.Source_File.all) then - Open(This.Source_File.all, Mode, File_Path, "shared=yes"); - This.Source_Path := To_Unbounded_String(File_Path); - end if; - end Initialize; - - --------------------------------------------------------------------------- - ------------------------------- Read Byte --------------------------------- - --------------------------------------------------------------------------- - - - procedure Read(This : in out Random_Source_File; B : out Byte) is - - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Byte'Read(Stream(This.Source_File.all), B); - end if; - end Read; - - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; Byte_Array : out Bytes) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Bytes'Read(Stream(This.Source_File.all), Byte_Array); - end if; - end Read; - - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; B : out B_Block128) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - B_Block128'Read(Stream(This.Source_File.all), B); - end if; - end Read; - - --------------------------------------------------------------------------- - ------------------------------- Read Word --------------------------------- - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; W : out Word) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Word'Read(Stream(This.Source_File.all), W); - end if; - end Read; - - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; Word_Array : out Words) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Words'Read(Stream(This.Source_File.all), Word_Array); - end if; - end Read; - - --------------------------------------------------------------------------- - ------------------------------- Read DWord -------------------------------- - --------------------------------------------------------------------------- - - - procedure Read(This : in out Random_Source_File; D : out DWord) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - DWord'Read(Stream(This.Source_File.all), D); - end if; - end Read; - - procedure Read(This : in out Random_Source_File; DWord_Array : out DWords) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - DWords'Read(Stream(This.Source_File.all), DWord_Array); - end if; - end Read; - - - --------------------------------------------------------------------------- - ------------------------------- Finalize ---------------------------------- - --------------------------------------------------------------------------- - - procedure Finalize(This : in out Random_Source_File) is - begin - if Is_Open(This.Source_File.all) then - Close(This.Source_File.all); - end if; - end Finalize; - - --------------------------------------------------------------------------- - --------------------------- Path_Starts_With ------------------------------ - --------------------------------------------------------------------------- - - function Path_Starts_With(This : Random_Source_File; S : String) return Boolean is - Path : constant String := To_String(This.Source_Path); - begin - return Path(Path'First..S'Last) = S; - end; - -end Crypto.Types.Random_Source.File; diff --git a/src/crypto-types-random_source-file.ads b/src/crypto-types-random_source-file.ads deleted file mode 100644 index 8a3e960..0000000 --- a/src/crypto-types-random_source-file.ads +++ /dev/null @@ -1,50 +0,0 @@ -with Ada.Streams.Stream_IO; -with Ada.Strings.Unbounded; - -package Crypto.Types.Random_Source.File is - package Rnd renames Crypto.Types.Random_Source; - - type Random_Source_File is new Rnd.Random_Source with private; - type Random_Source_File_Access is access Random_Source_File; - - Overriding - procedure Finalize(This : in out Random_Source_File); - - Overriding - procedure Initialize(This : in out Random_Source_File); - - procedure Initialize(This : in out Random_Source_File; - File_Path : in String); - Overriding - procedure Read(This : in out Random_Source_File; B : out Byte); - - Overriding - procedure Read(This : in out Random_Source_File; Byte_Array : out Bytes); - - Overriding - procedure Read(This : in out Random_Source_File; B : out B_Block128); - - Overriding - procedure Read(This : in out Random_Source_File; W : out Word); - - Overriding - Procedure Read(This : in out Random_Source_File; Word_Array : out Words); - - Overriding - procedure Read(This : in out Random_Source_File; D : out DWord); - - Overriding - procedure Read(This : in out Random_Source_File; DWord_Array : out DWords); -private - type File_Access is access Ada.Streams.Stream_IO.File_Type; - - type Random_Source_File is new Rnd.Random_Source with - record - Source_Path : Ada.Strings.Unbounded.Unbounded_String; - Source_File : File_Access; - end record; - - function Path_Starts_With(This : Random_Source_File; S : String) - return Boolean; - -end Crypto.Types.Random_Source.File; diff --git a/src/crypto-types-random_source.adb b/src/crypto-types-random_source.adb deleted file mode 100644 index 5fd4dbb..0000000 --- a/src/crypto-types-random_source.adb +++ /dev/null @@ -1,55 +0,0 @@ -package body Crypto.Types.Random_Source is - - procedure Read(This : in out Random_Source; Byte_Array : out Bytes) is - begin - for I in Byte_Array'Range loop - Read(Random_Source'class(This),Byte_Array(I)); - end loop; - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; B : out B_Block128) is - begin - for I in B'Range loop - Read(Random_Source'class(This),B(I)); - end loop; - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; W : out Word) is - B : Byte_Word; - begin - This.Read(Bytes(B)); - W := To_Word(B); - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; Word_Array : out Words) is - begin - for I in Word_Array'Range loop - This.Read(Word_Array(I)); - end loop; - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; D : out DWord) is - B : Byte_DWord; - begin - This.Read(Bytes(B)); - D := To_DWord(B); - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; DWord_Array : out DWords) is - begin - for I in DWord_Array'Range loop - This.Read(DWord_Array(I)); - end loop; - end Read; - -end Crypto.Types.Random_Source; diff --git a/src/crypto-types-random_source.ads b/src/crypto-types-random_source.ads deleted file mode 100644 index 9ad55f6..0000000 --- a/src/crypto-types-random_source.ads +++ /dev/null @@ -1,27 +0,0 @@ -with Ada.Finalization; - -package Crypto.Types.Random_Source is - use Crypto.Types; - package Fin renames Ada.Finalization; - - type Random_Source is abstract new Fin.Controlled with null record; - type Random_Source_Access is access Random_Source; - - Random_Source_Read_Error : exception; - - procedure Initialize (This: in out Random_Source) is abstract; - - procedure Read(This : in out Random_Source; B : out Byte) is abstract; - - procedure Read(This : in out Random_Source; Byte_Array : out Bytes); - - procedure Read(This : in out Random_Source; B : out B_Block128); - - procedure Read(This : in out Random_Source; W : out Word); - procedure Read(This : in out Random_Source; Word_Array : out Words); - - procedure Read(This : in out Random_Source; D : out DWord); - procedure Read(This : in out Random_Source; DWord_Array : out DWords); - - pragma Inline(Read); -end Crypto.Types.Random_Source; diff --git a/src/crypto-types.adb b/src/crypto-types.adb deleted file mode 100644 index ac9afc2..0000000 --- a/src/crypto-types.adb +++ /dev/null @@ -1,944 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Ada.Unchecked_Conversion; - ---pragma Elaborate_All(Generic_Mod_Aux); - -package body Crypto.Types is - - package body Generic_Mod_Aux is - function "xor"(Left, Right : T_A) return T_A is - Result : T_A(0..Left'Length-1); - begin - if Left'Length /= Right'Length then - raise Constraint_Error; - end if; - for I in 0..Left'Length-1 loop - Result(I) := Left(Left'First+I) xor Right(Right'First+I); - end loop; - return Result; - end "xor"; - - ------------------------------------------------------------------------ - - function "xor"(Left : T_A; Right : T) return T_A is - Result : T_A := Left; - begin - Result(Result'Last) := Left(Result'Last) xor Right; - return Result; - end "xor"; - - ------------------------------------------------------------------------ - - function "xor"(Left : T; Right : T_A) return T_A is - begin - return Right xor Left; - end "xor"; - - - ------------------------------------------------------------------------ - - function "and"(Left, Right : T_A) return T_A is - Result : T_A(0..Left'Length-1); - begin - - if Left'Length /= Right'Length then - raise Constraint_Error; - end if; - for I in 0..Left'Length-1 loop - Result(I) := Left(Left'First+I) and Right(Right'First+I); - end loop; - return Result; - end "and"; - - ------------------------------------------------------------------------ - function "+"(Left : T_A; Right : T) return T_A is - Result: T_A(Left'Range) := Left; - begin - Result(Left'Last) := Left(Left'Last) + Right; - - -- overflow? - if Result(Left'Last) < Left(Left'Last) then - for I in reverse Left'First..Left'Last-1 loop - Result(I):=Result(I)+1; - if Result(I) /= 0 then - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - - ------------------------------------------------------------------------ - function "+"(Left : T; Right : T_A) return T_A is - begin - return Right + Left; - end "+"; - ------------------------------------------------------------------------ - - function Is_Zero(Item : T_A) return Boolean is - begin - for I in Item'Range loop - if Item(I) /= 0 then return False; - end if; - end loop; - return True; - end Is_Zero; - ------------------------------------------------------------------------- - - function Left_Part(Block : in T_A) return T_A is - Len : constant Natural := ((Block'Length+1)/2)-1; - Left : constant T_A(0..Len) := Block(Block'First..(Block'First+Len)); - begin - return Left; - end Left_Part; - - ------------------------------------------------------------------------ - - function Right_Part(Block : in T_A) return T_A is - Len : constant Natural := Block'Length/2; - Right : constant T_A(0..Len-1) := Block(Block'Last-Len+1..Block'Last); - begin - return Right; - end Right_Part; - - ------------------------------------------------------------------------ - - function Shift_Left(Value : T_A; Amount : Natural) return T_A is - Result : T_A(Value'Range) := (others => 0); - L : constant Natural := Amount mod T'Size; - M : constant Natural := Value'First+(Amount/T'Size); - begin - if Amount >= Value'Size then - return Result; - elsif Amount = 0 then - return Value; - end if; - Result(Value'Last-M) := Shift_Left(Value(Value'Last),L); - - for I in reverse Value'First..Value'Last-(M+1) loop - Result(I) := Shift_Left(Value(I),L) - xor Shift_Right(Value(I+1),T'Size-L); - end loop; - return Result; - end Shift_Left; - ------------------------------------------------------------------------- - function Shift_Right(Value : T_A; Amount : Natural) return T_A is - Result : T_A(Value'Range) := (others => 0); - L : constant Natural := Amount mod T'Size; - M : constant Natural := Value'First+(Amount/T'Size); - begin - if Amount >= Value'Size then - return Result; - elsif Amount = 0 then - return Value; - end if; - Result(Value'Last-M) := Shift_Right(Value(Value'Last),L); - - for I in reverse Value'First..Value'Last-(M+1) loop - Result(I) := Shift_Right(Value(I),L) - xor Shift_Left(Value(I+1),T'Size-L); - end loop; - return Result; - end Shift_Right; - - end Generic_Mod_Aux; - - - function Cast is new Ada.Unchecked_Conversion (Byte_Word, Word); - function Cast is new Ada.Unchecked_Conversion (Word, Byte_Word); - function DCast is new Ada.Unchecked_Conversion (Byte_DWord, DWord); - function DCast is new Ada.Unchecked_Conversion (DWord, Byte_DWord); - pragma Inline (Cast, DCast); - - - package Aux_Byte is new Generic_Mod_Aux(Byte,Bytes); - package Aux_Word is new Generic_Mod_Aux(Word,Words); - package Aux_DWord is new Generic_Mod_Aux(Dword,DWords); - - --------------------------------------------------------------------------- - - function To_Word(A,B,C,D : Character) return Word is - begin - return Cast((Byte(Character'Pos(D)), Byte(Character'Pos(C)), - Byte(Character'Pos(B)), Byte(Character'Pos(A)))); - end To_Word; - - --------------------------------------------------------------------------- - - function To_Word(A,B,C,D : Byte) return Word is - begin - return Cast((D, C, B, A)); - end To_Word; - - --------------------------------------------------------------------------- - - function To_Word (X : Byte_Word) return Word is - begin - return Cast((X(3), X(2), X(1), X(0))); - end To_Word; - - --------------------------------------------------------------------------- - - function R_To_Word (X : Byte_Word) return Word is - begin - return Cast(X); - end R_To_Word; - - --------------------------------------------------------------------------- - - function To_Bytes (X : Word) return Byte_Word is - begin - return (Cast(X)(3), Cast(X)(2), Cast(X)(1), Cast(X)(0)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function R_To_Bytes (X : Word) return Byte_Word is - begin - return Cast(X); - end R_To_Bytes; - - --------------------------------------------------------------------------- - - function Byte0 (W : Word) return Byte is - begin - return Cast(W)(3); - end Byte0; - - --------------------------------------------------------------------------- - - function Byte1 (W : Word) return Byte is - begin - return Cast(W)(2); - end Byte1; - - --------------------------------------------------------------------------- - - function Byte2 (W : Word) return Byte is - begin - return Cast(W)(1); - end Byte2; - - --------------------------------------------------------------------------- - - function Byte3 (W : Word) return Byte is - begin - return Cast(W)(0); - end Byte3; - - --------------------------------------------------------------------------- - - function To_DWord (X : Byte_DWord) return DWord is - begin - return DCast((X(7), X(6), X(5), X(4), X(3), X(2), X(1), X(0))); - end To_DWord; - - --------------------------------------------------------------------------- - - function R_To_DWord (X : Byte_DWord) return DWord is - begin - return DCast(X); - end R_To_DWord; - - --------------------------------------------------------------------------- - - function To_Bytes (X : DWord) return Byte_DWord is - begin - return (DCast(X)(7), DCast(X)(6), DCast(X)(5), DCast(X)(4), - DCast(X)(3), DCast(X)(2), DCast(X)(1), DCast(X)(0)); - - end To_Bytes; - - --------------------------------------------------------------------------- - - function R_To_Bytes (X : DWord) return Byte_DWord is - begin - return DCast(X); - end R_To_Bytes; - - --------------------------------------------------------------------------- - - function Byte0 (D : DWord) return Byte is - begin - return DCast(D)(7); - end Byte0; - - --------------------------------------------------------------------------- - function Byte1 (D : DWord) return Byte is - begin - return DCast(D)(6); - end Byte1; - - --------------------------------------------------------------------------- - - function Byte2 (D : DWord) return Byte is - begin - return DCast(D)(5); - end Byte2; - - --------------------------------------------------------------------------- - - function Byte3 (D : DWord) return Byte is - begin - return DCast(D)(4); - end Byte3; - - --------------------------------------------------------------------------- - - function Byte4 (D : DWord) return Byte is - begin - return DCast(D)(3); - end Byte4; - - --------------------------------------------------------------------------- - - function Byte5 (D : DWord) return Byte is - begin - return DCast(D)(2); - end Byte5; - - --------------------------------------------------------------------------- - - function Byte6 (D : DWord) return Byte is - begin - return DCast(D)(1); - end Byte6; - - --------------------------------------------------------------------------- - - function Byte7 (D : DWord) return Byte is - begin - return DCast(D)(0); - end Byte7; - - --------------------------------------------------------------------------- - - - function "xor"(Left, Right : Bytes) return Bytes is - begin - return Aux_Byte."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left : Bytes; Right : Byte) return Bytes is - begin - return Aux_Byte."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : Bytes; Right : Byte) return Bytes is - begin - return Aux_Byte."+"(Left,Right); - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Byte; Right : Bytes) return Bytes is - begin - return Right + Left; - end "+"; - - --------------------------------------------------------------------------- - - function "and"(Left, Right : Bytes) return Bytes is - begin - return Aux_Byte."and"(Left,Right); - end "and"; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - function "xor"(Left, Right : Words) return Words is - begin - return Aux_Word."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : Words; Right : Word) return Words is - - begin - return Aux_Word."+"(Left,Right); - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Word; Right : Words) return Words is - begin - return Right + Left; - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Words; Right : Byte) return Words is - Result: Words(Left'Range) := Left; - begin - Result(Left'Last) := Left(Left'Last) + Word(Right); - - -- overflow? - if Result(Left'Last) < Left(Left'Last) then - for I in reverse Left'First..Left'Last-1 loop - Result(I):=Result(I)+1; - if Result(I) /= 0 then - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DWords) return DWords is - begin - return Aux_DWord."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : DWords; Right : DWord) return DWords is - begin - return Aux_DWord."+"(Left,Right); - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : DWord; Right : DWords) return DWords is - begin - return Right + Left; - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : DWords; Right : Byte) return DWords is - Result: DWords(Left'Range) := Left; - begin - Result(Left'Last) := Left(Left'Last) + DWord(Right); - - -- overflow? - if Result(Left'Last) < Left(Left'Last) then - for I in reverse Left'First..Left'Last-1 loop - Result(I):=Result(I)+1; - if Result(I) /= 0 then - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - --------------------------------------------------------------------------- - - function To_Words(Byte_Array : Bytes) return Words is - L : constant Natural := - Natural(Float'Ceiling(Float(Byte_Array'Length)/4.0))-1; - W : Words(0..L) := (others => 0); - N : Integer := Byte_Array'First; - S : Natural :=24; - begin - - for I in 0..(Byte_Array'Length/4)-1 loop - W(I) := To_Word(Byte_Array(N..N+3)); - N := N+4; - end loop; - - for I in 1..(Byte_Array'Length mod 4) loop - W(L):= W(L) or Shift_Left(Word(Byte_Array(N)),S); - N := N+1; - S := S-8; - end loop; - - return W; - end To_Words; - - --------------------------------------------------------------------------- - - function To_Bytes(Word_Array : Words) return Bytes is - B : Bytes(1..Word_Array'Length*4); - C : Natural := 1; - begin - for I in Word_Array'Range loop - B(C..C+3) := To_Bytes(Word_Array(I)); - C:=C+4; - end loop; - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_DWords(Byte_Array : Bytes) return DWords is - L : constant Natural := - Natural(Float'Ceiling(Float(Byte_Array'Length)/8.0))-1; - W : DWords(0..L):=(others => 0); - N : Natural := Byte_Array'First; - S : Natural := 56; - begin - - for I in 0..(Byte_Array'Length/8)-1 loop - W(I) := To_DWord(Byte_Array(N..N+7)); - N := N+8; - end loop; - - for I in 1..(Byte_Array'Length mod 8) loop - W(L):= W(L) or Shift_Left(DWord(Byte_Array(N)),S); - N := N+1; - S := S-8; - end loop; - - return W; - end To_DWords; - - --------------------------------------------------------------------------- - - - function To_Bytes(DWord_Array : DWords) return Bytes is - B : Bytes(1..DWord_Array'Length*8); - C : Natural := 1; - begin - for I in DWord_Array'Range loop - B(C..C+7) := To_Bytes(DWord_Array(I)); - C:=C+8; - end loop; - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Hex(B : Byte) return Hex_Byte is - S : constant String := "0123456789ABCDEF"; - H : Hex_Byte; - begin - H(2) := S(Natural(B and 15)+1); - H(1) := S(Natural(Shift_Right(B,4)+1)); - return H; - end To_Hex; - - --------------------------------------------------------------------------- - - function To_Hex(W : Word) return Hex_Word is - S : constant String := "0123456789ABCDEF"; - H : Hex_Word; - T : Word := W; - begin - for I in reverse H'Range loop - H(I) := S(Natural(T and 15)+1); - T := Shift_Right(T,4); - end loop; - return H; - end To_Hex; - - --------------------------------------------------------------------------- - - - function To_Hex(D : DWord) return Hex_DWord is - S : constant String := "0123456789ABCDEF"; - H : Hex_DWord; - T : DWord := D; - begin - for I in reverse H'Range loop - H(I) := S(Natural(T and 15)+1); - T := Shift_Right(T,4); - end loop; - - return H; - end To_Hex; - - - function Hex_To_Bytes(Hex : String) return Bytes is - Return_Bytes : Bytes(0..Hex'Length/2 -1); - begin - for I in Return_Bytes'Range loop - case Hex(Hex'First + 2*i) is - when '0' => Return_Bytes(i):=16#00#; - when '1' => Return_Bytes(i):=16#01#; - when '2' => Return_Bytes(i):=16#02#; - when '3' => Return_Bytes(i):=16#03#; - when '4' => Return_Bytes(i):=16#04#; - when '5' => Return_Bytes(i):=16#05#; - when '6' => Return_Bytes(i):=16#06#; - when '7' => Return_Bytes(i):=16#07#; - when '8' => Return_Bytes(i):=16#08#; - when '9' => Return_Bytes(i):=16#09#; - when 'A' => Return_Bytes(i):=16#0A#; - when 'B' => Return_Bytes(i):=16#0B#; - when 'C' => Return_Bytes(i):=16#0C#; - when 'D' => Return_Bytes(i):=16#0D#; - when 'E' => Return_Bytes(i):=16#0E#; - when 'F' => Return_Bytes(i):=16#0F#; - when others => null; - end case; - - case Hex(Hex'First + 2*i + 1) is - when '0' => Return_Bytes(i):= Return_Bytes(i) + 16#00#; - when '1' => Return_Bytes(i):= Return_Bytes(i) + 16#10#; - when '2' => Return_Bytes(i):= Return_Bytes(i) + 16#20#; - when '3' => Return_Bytes(i):= Return_Bytes(i) + 16#30#; - when '4' => Return_Bytes(i):= Return_Bytes(i) + 16#40#; - when '5' => Return_Bytes(i):= Return_Bytes(i) + 16#50#; - when '6' => Return_Bytes(i):= Return_Bytes(i) + 16#60#; - when '7' => Return_Bytes(i):= Return_Bytes(i) + 16#70#; - when '8' => Return_Bytes(i):= Return_Bytes(i) + 16#80#; - when '9' => Return_Bytes(i):= Return_Bytes(i) + 16#90#; - when 'A' => Return_Bytes(i):= Return_Bytes(i) + 16#A0#; - when 'B' => Return_Bytes(i):= Return_Bytes(i) + 16#B0#; - when 'C' => Return_Bytes(i):= Return_Bytes(i) + 16#C0#; - when 'D' => Return_Bytes(i):= Return_Bytes(i) + 16#D0#; - when 'E' => Return_Bytes(i):= Return_Bytes(i) + 16#E0#; - when 'F' => Return_Bytes(i):= Return_Bytes(i) + 16#F0#; - when others => null; - end case; - - end loop; - return Return_Bytes; - end Hex_To_Bytes; - - --------------------------------------------------------------------------- - - function Is_Zero(Byte_Array : Bytes) return Boolean is - begin - return Aux_Byte.Is_Zero(Byte_Array); - end Is_Zero; - - --------------------------------------------------------------------------- - - - function Is_Zero(Word_Array : Words) return Boolean is - begin - return Aux_Word.Is_Zero(Word_Array); - end Is_Zero; - - --------------------------------------------------------------------------- - - function Is_Zero(DWord_Array : Dwords) return Boolean is - begin - return Aux_DWord.Is_Zero(DWord_Array); - end Is_Zero; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - function To_Bytes(Message : String) return Bytes is - B : Bytes(Message'Range); - begin - for I in Message'Range loop - B(I) := Character'Pos(Message(I)); - end loop; - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_String(ASCII : Bytes) return String is - S : String(1..ASCII'Length); - J : Integer:=1; - begin - for I in ASCII'Range loop - S(J) := Character'Val(ASCII(I)); - J:=J+1; - end loop; - return S; - end To_String; - - --------------------------------------------------------------------------- - - function Left_Part(Block : in Bytes) return Bytes is - begin - return Aux_Byte.Left_Part(Block); - end Left_Part; - - --------------------------------------------------------------------------- - - function Right_Part(Block : in Bytes) return Bytes is - begin - return Aux_Byte.Right_Part(Block); - end Right_Part; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block64) return Bytes is - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block128) return Bytes is - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block192) return Bytes is - - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block256) return Bytes is - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(W : W_Block160) return Bytes is - begin - return To_Bytes(Words(W)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(W : W_Block256) return Bytes is - begin - return To_Bytes(Words(W)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(W : W_Block512) return Bytes is - begin - return To_Bytes(Words(W)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block256) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block384) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block512) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block1024) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block8192) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_B_Block64(B : Bytes) return B_Block64 is - begin - return B_Block64(B); - end To_B_Block64; - - --------------------------------------------------------------------------- - - function To_B_Block128(B : Bytes) return B_Block128 is - begin - return B_Block128(B); - end To_B_Block128; - - --------------------------------------------------------------------------- - - function To_B_Block192(B : Bytes) return B_Block192 is - begin - return B_Block192(B); - end To_B_Block192; - - --------------------------------------------------------------------------- - - function To_B_Block256(B : Bytes) return B_Block256 is - begin - return B_Block256(B); - end To_B_Block256; - - --------------------------------------------------------------------------- - - function To_W_Block160(B : Bytes) return W_Block160 is - begin - return W_Block160(To_Words(B)); - end To_W_Block160; - - --------------------------------------------------------------------------- - - function To_W_Block256(B : Bytes) return W_Block256 is - begin - return W_Block256(To_Words(B)); - end To_W_Block256; - - --------------------------------------------------------------------------- - - function To_W_Block512(B : Bytes) return W_Block512 is - begin - return W_Block512(To_Words(B)); - end To_W_Block512; - - --------------------------------------------------------------------------- - - function To_DW_Block256(B : Bytes) return DW_Block256 is - begin - return DW_Block256(To_DWords(B)); - end To_DW_Block256; - - --------------------------------------------------------------------------- - - function To_DW_Block384(B : Bytes) return DW_Block384 is - begin - return DW_Block384(To_DWords(B)); - end To_DW_Block384; - - --------------------------------------------------------------------------- - - function To_DW_Block512(B : Bytes) return DW_Block512 is - begin - return DW_Block512(To_DWords(B)); - end To_DW_Block512; - - --------------------------------------------------------------------------- - - function To_DW_Block1024(B : Bytes) return DW_Block1024 is - begin - return DW_Block1024(To_DWords(B)); - end To_DW_Block1024; - - --------------------------------------------------------------------------- - - function To_DW_Block8192(B : Bytes) return DW_Block8192 is - begin - return DW_Block8192(To_DWords(B)); - end To_DW_Block8192; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : W_Block160) return W_Block160 is - begin - return W_Block160(Words(Left) xor Words(Right)); - end "xor"; - --------------------------------------------------------------------------- - - function "xor"(Left, Right : W_Block256) return W_Block256 is - begin - return W_Block256(Words(Left) xor Words(Right)); - end "xor"; - --------------------------------------------------------------------------- - - function "xor"(Left, Right : W_Block512) return W_Block512 is - begin - return W_Block512(Words(Left) xor Words(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DW_Block512) return DW_Block512 is - begin - return DW_Block512(DWords(Left) xor DWords(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DW_Block1024) return DW_Block1024 is - begin - return DW_Block1024(DWords(Left) xor DWords(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DW_Block8192) return DW_Block8192 is - begin - return DW_Block8192(DWords(Left) xor DWords(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : B_Block128) return B_Block128 is - begin - return B_Block128(Bytes(Left) xor Bytes(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : B_Block64) return B_Block64 is - begin - return B_Block64(Bytes(Left) xor Bytes(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : B_Block128; Right : Byte) return B_Block128 is - begin - return B_Block128(Bytes(Left) + Right); - end "+"; - - --------------------------------------------------------------------------- - - function Shift_Left(Value : Bytes; Amount : Natural) return Bytes is - begin - return Aux_Byte.Shift_Left(Value,Amount); - end Shift_Left; - - --------------------------------------------------------------------------- - - function Shift_Left(Value : B_Block128; Amount :Natural) return B_Block128 is - begin - return B_Block128(Aux_Byte.Shift_Left(Bytes(Value),Amount)); - end Shift_Left; - - ---------------------------------------------------------------------------- - - function Shift_Right(Value : Bytes; Amount : Natural) return Bytes is - begin - return Aux_Byte.Shift_Right(Value,Amount); - end Shift_Right; - - --------------------------------------------------------------------------- - - function Shift_Right(Value : B_Block128; Amount :Natural)return B_Block128 is - begin - return B_Block128(Aux_Byte.Shift_Right(Bytes(Value),Amount)); - end Shift_Right; - - - - - end Crypto.Types; diff --git a/src/crypto-types.ads b/src/crypto-types.ads deleted file mode 100644 index ebcd6dc..0000000 --- a/src/crypto-types.ads +++ /dev/null @@ -1,357 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -package Crypto.Types is - - --------------------------------------------------------------------------- - ---------------------------TYPES------------------------------------------- - --------------------------------------------------------------------------- - - -- primary types; - - type Bit is mod 2; - for Bit'Size use 1; - - type Byte is mod 2 ** 8; - for Byte'Size use 8; - - type DByte is mod 2 ** 16; - for DByte'Size use 16; - - type TByte is mod 2 ** 24 with Size => 24; - - type Word is mod 2 ** 32; - for Word'Size use 32; - - type DWord is mod 2 ** 64; - for DWord'Size use 64; - - --package BIO is new Ada.Text_Io.Modular_IO (Byte); - --package WIO is new Ada.Text_Io.Modular_IO (Word); - --package DIO is new Ada.Text_Io.Modular_IO (DWord); - - -- Arrays of primary types - type Bits is array (Integer range <>) of Bit; - type Bytes is array (Integer range <>) of Byte; - type DBytes is array (Integer range <>) of DByte; - type Words is array (Integer range <>) of Word; - type DWords is array (Integer range <>) of DWord; - - subtype Byte_Word_Range is Natural range 0..3; - subtype Byte_DWord_Range is Natural range 0..7; - - subtype Byte_Word is Bytes (Byte_Word_Range); - subtype Byte_DWord is Bytes (Byte_DWord_Range); - - -- N : #bits - -- byte-blocks (B_BlockN): array of N/8 bytes - subtype B_Block32_Range is Natural range 0..3; - subtype B_Block48_Range is Natural range 0..5; - subtype B_Block56_Range is Natural range 0..6; - subtype B_Block64_Range is Natural range 0..7; - subtype B_Block128_Range is Natural range 0..15; - subtype B_Block160_Range is Natural range 0..19; - subtype B_Block192_Range is Natural range 0..23; - subtype B_Block256_Range is Natural range 0..31; - - type B_Block32 is array(B_Block32_Range) of Byte; - type B_Block48 is array(B_Block48_Range) of Byte; - type B_Block56 is array(B_Block56_Range) of Byte; - type B_Block64 is array(B_Block64_Range) of Byte; - type B_Block128 is array(B_Block128_Range) of Byte; - type B_Block160 is array(B_Block160_Range) of Byte; - type B_Block192 is array(B_Block192_Range) of Byte; - type B_Block256 is array(B_Block256_Range) of Byte; - - - -- word blocks (W_BlockN): array of N/32 Words - subtype W_Block128_Range is Natural range 0..3; - subtype W_Block160_Range is Natural range 0..4; - subtype W_Block192_Range is Natural range 0..5; - subtype W_Block256_Range is Natural range 0..7; - subtype W_Block512_Range is Natural range 0..15; - - type W_Block128 is array(W_Block128_Range) of Word; - type W_Block160 is array(W_Block160_Range) of Word; - type W_Block192 is array(W_Block192_Range) of Word; - type W_Block256 is array(W_Block256_Range) of Word; - type W_Block512 is array(W_Block512_Range) of Word; - - - -- double wordblocks (DW_BlockN): array of N/64 Words - subtype DW_Block128_Range is Natural range 0..1; - subtype DW_Block256_Range is Natural range 0..3; - subtype DW_Block384_Range is Natural range 0..5; - subtype DW_Block512_Range is Natural range 0..7; - subtype DW_Block1024_Range is Natural range 0..15; - subtype DW_Block8192_Range is Natural range 0..127; - - type DW_Block128 is array(DW_Block128_Range) of DWord; - type DW_Block256 is array(DW_Block256_Range) of DWord; - type DW_Block384 is array(DW_Block384_Range) of DWord; - type DW_Block512 is array(DW_Block512_Range) of DWord; - type DW_Block1024 is array(DW_Block1024_Range) of DWord; - type DW_Block8192 is array(DW_Block8192_Range) of DWord; - - - subtype Hex_Byte_Range is Natural range 1..2; - subtype Hex_Word_Range is Natural range 1..8; - subtype Hex_DWord_Range is Natural range 1..16; - - - subtype Hex_Byte is String (Hex_Byte_Range); - subtype Hex_Word is String (Hex_Word_Range); - subtype Hex_DWord is String (Hex_DWord_Range); - - subtype Message_Block_Length256 is Natural range 0 .. 32; - subtype Message_Block_Length512 is Natural range 0 .. 64; - subtype Message_Block_Length1024 is Natural range 0 .. 128; - - - - - - - - --------------------------------------------------------------------------- - ---------------------------FUNCTIONS--------------------------------------- - --------------------------------------------------------------------------- - - function Shift_Left (Value : Byte; Amount : Natural) return Byte; - function Shift_Right (Value : Byte; Amount : Natural) return Byte; - function Rotate_Left (Value : Byte; Amount : Natural) return Byte; - function Rotate_Right (Value : Byte; Amount : Natural) return Byte; - - function Shift_Left (Value : DByte; Amount : Natural) return DByte; - function Shift_Right (Value : DByte; Amount : Natural) return DByte; - function Rotate_Left (Value : DByte; Amount : Natural) return DByte; - function Rotate_Right (Value : DByte; Amount : Natural) return DByte; - - function Shift_Left (Value : Word; Amount : Natural) return Word; - function Shift_Right (Value : Word; Amount : Natural) return Word; - function Rotate_Left (Value : Word; Amount : Natural) return Word; - function Rotate_Right (Value : Word; Amount : Natural) return Word; - - function Shift_Left (Value : DWord; Amount : Natural) return DWord; - function Shift_Right (Value : DWord; Amount : Natural) return DWord; - function Rotate_Left (Value : DWord; Amount : Natural) return DWord; - function Rotate_Right (Value : DWord; Amount : Natural) return DWord; - - pragma Import (Intrinsic, Shift_Left); - pragma Import (Intrinsic, Shift_Right); - - function Shift_Left (Value : Bytes; Amount : Natural) return Bytes; - function Shift_Left (Value : B_Block128; Amount : Natural) return B_Block128; - function Shift_Right(Value : Bytes; Amount : Natural) return Bytes; - function Shift_Right(Value : B_Block128; Amount : Natural) return B_Block128; - - --Operations for Bytes - function "xor"(Left, Right : Bytes) return Bytes; - function "xor"(Left : Bytes; Right : Byte) return Bytes; - function "+"(Left : Bytes; Right : Byte) return Bytes; - function "+"(Left : Byte; Right : Bytes) return Bytes; - function "and"(Left, Right : Bytes) return Bytes; - - - -- Operations for Words - function "xor"(Left, Right : Words) return Words; - function "+"(Left : Words; Right : Word) return Words; - function "+"(Left : Word; Right : Words) return Words; - function "+"(Left : Words; Right : Byte) return Words; - - - -- Operations for DWords - function "xor"(Left, Right : DWords) return DWords; - function "+"(Left : DWords; Right : DWord) return DWords; - function "+"(Left : DWord; Right : DWords) return DWords; - function "+"(Left : DWords; Right : Byte) return DWords; - - -- Bytes to Word - function To_Word (A,B,C,D : Byte) return Word; - function To_Word (X : Byte_Word) return Word; - function R_To_Word (X : Byte_Word) return Word; -- reverse - function To_Words(Byte_Array : Bytes) return Words; - - -- Word to Bytes - function To_Bytes (X : Word) return Byte_Word; - function R_To_Bytes (X : Word) return Byte_Word; --reverse - function To_Bytes(Word_Array : Words) return Bytes; - - --Word = b_0 b_1 b2 b_3 - -- ByteX returns b_n - function Byte0 (W : Word) return Byte; - function Byte1 (W : Word) return Byte; - function Byte2 (W : Word) return Byte; - function Byte3 (W : Word) return Byte; - - -- Bytes to DWord - function To_DWord (X : Byte_DWord) return DWord; - function R_To_DWord (X : Byte_DWord) return DWord; - function To_DWords (Byte_Array : Bytes) return DWords; - - -- DWord to Bytes - function To_Bytes (X : DWord) return Byte_DWord; - function R_To_Bytes (X : DWord) return Byte_DWord; - function To_Bytes (DWord_Array : DWords) return Bytes; - - - --DWord = b_0 b_1 b2 b_3 b_4 b_5 b_6 b_7 - -- ByteX returns b_n - function Byte0 (D : DWord) return Byte; - function Byte1 (D : DWord) return Byte; - function Byte2 (D : DWord) return Byte; - function Byte3 (D : DWord) return Byte; - function Byte4 (D : DWord) return Byte; - function Byte5 (D : DWord) return Byte; - function Byte6 (D : DWord) return Byte; - function Byte7 (D : DWord) return Byte; - - -- To_Word - function To_Word (A,B,C,D : Character) return Word; - - -- String to Bytes - function To_Bytes(Message : String) return Bytes; - - -- Bytes to String - function To_String(ASCII : Bytes) return String; - - - -- To_Hex - function To_Hex(B : Byte) return Hex_Byte; - function To_Hex(W : Word) return Hex_Word; - function To_Hex(D : DWord) return Hex_DWord; - - -- To_Bytes - function Hex_To_Bytes(Hex : String) return Bytes; - - -- Is_Zero - -- returns only true if the "input array" X = (others => 0) - function Is_Zero(Byte_Array : Bytes) return Boolean; - function Is_Zero(Word_Array : Words) return Boolean; - function Is_Zero(DWord_Array : DWords) return Boolean; - - - -- Byte Blocks To Bytes. - -- Needed for generic packages to convert a specific byte block. - function To_Bytes(B : B_Block64) return Bytes; - function To_Bytes(B : B_Block128) return Bytes; - function To_Bytes(B : B_Block192) return Bytes; - function To_Bytes(B : B_Block256) return Bytes; - function To_Bytes(W : W_Block160) return Bytes; - function To_Bytes(W : W_Block256) return Bytes; - function To_Bytes(W : W_Block512) return Bytes; - function To_Bytes(D : DW_Block256) return Bytes; - function To_Bytes(D : DW_Block384) return Bytes; - function To_Bytes(D : DW_Block512) return Bytes; - function To_Bytes(D : DW_Block1024) return Bytes; - function To_Bytes(D : DW_Block8192) return Bytes; - - - -- Bytes To block of Bytes. - -- Needed for generic packages to convert a specific byte block. - function To_B_Block64(B : Bytes) return B_Block64; - function To_B_Block128(B : Bytes) return B_Block128; - function To_B_Block192(B : Bytes) return B_Block192; - function To_B_Block256(B : Bytes) return B_Block256; - - - -- Bytes To block of words. - -- Needed for generic packages to convert a specific byte block. - function To_W_Block160(B : Bytes) return W_Block160; - function To_W_Block256(B : Bytes) return W_Block256; - function To_W_Block512(B : Bytes) return W_Block512; - - - -- Bytes To block of double words. - -- Needed for generic packages to convert a specific byte block. - function To_DW_Block256(B : Bytes) return DW_Block256; - function To_DW_Block384(B : Bytes) return DW_Block384; - function To_DW_Block512(B : Bytes) return DW_Block512; - function To_DW_Block1024(B : Bytes) return DW_Block1024; - function To_DW_Block8192(B : Bytes) return DW_Block8192; - - -- Needed for generic packages to convert a specific byte block. - function "xor"(Left, Right : B_Block64) return B_Block64; - function "xor"(Left, Right : B_Block128) return B_Block128; - function "xor"(Left, Right : W_Block160) return W_Block160; - function "xor"(Left, Right : W_Block256) return W_Block256; - function "xor"(Left, Right : W_Block512) return W_Block512; - function "xor"(Left, Right : DW_Block512) return DW_Block512; - function "xor"(Left, Right : DW_Block1024) return DW_Block1024; - function "xor"(Left, Right : DW_Block8192) return DW_Block8192; - - function "+"(Left : B_Block128; Right : Byte) return B_Block128; - - - -- Splits byte array of length n into a left part of length - -- ceiling(n/2) and a right part of length floor(n/2). - function Left_Part(Block : in Bytes) return Bytes; - function Right_Part(Block : in Bytes) return Bytes; - - - - -- Nested generic package - generic - type T is mod <>; - type T_A is array (Integer range <>) of T; - with function Shift_Left (Value : T; Amount : Natural) return T is <>; - with function Shift_Right (Value : T; Amount : Natural) return T is <>; - - package Generic_Mod_Aux is - function "xor"(Left, Right : T_A) return T_A; - function "xor"(Left : T_A; Right : T) return T_A; - function "xor"(Left : T; Right : T_A) return T_A; - - function "and"(Left, Right : T_A) return T_A; - - function "+"(Left : T_A; Right : T) return T_A; - function "+"(Left : T; Right : T_A) return T_A; - - function Is_Zero(Item : T_A) return Boolean; - - function Left_Part (Block : in T_A) return T_A; - function Right_Part(Block : in T_A) return T_A; - - function Shift_Left(Value : T_A; Amount : Natural) return T_A; - function Shift_Right(Value : T_A; Amount : Natural) return T_A; - end Generic_Mod_Aux; - - - - --------------------------------------------------------------------------- - -------------------------------PRIVATE------------------------------------- - --------------------------------------------------------------------------- - -private - pragma Inline (To_B_Block128,To_B_Block192,To_B_Block256); - pragma Inline ("xor","+"); - pragma Inline (R_To_Bytes, To_Bytes); - pragma Inline (To_Word, Byte0, Byte1, Byte2, Byte3); - pragma Inline (Byte4, Byte5, Byte6, Byte7); - pragma Inline (To_DWord, R_To_DWord); - pragma Inline (Is_Zero); - pragma Inline (Left_Part, Right_Part); - pragma Import (Intrinsic, Rotate_Left); - pragma Import (Intrinsic, Rotate_Right); - - pragma Optimize(Time); -end Crypto.Types; diff --git a/src/crypto.ads b/src/crypto.ads deleted file mode 100644 index 2f0ed3c..0000000 --- a/src/crypto.ads +++ /dev/null @@ -1,25 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - - -package Crypto is -end Crypto; diff --git a/src/multi_precision_integers-check.adb b/src/multi_precision_integers-check.adb new file mode 100644 index 0000000..ac0efc4 --- /dev/null +++ b/src/multi_precision_integers-check.adb @@ -0,0 +1,141 @@ +with Ada.Text_IO; use Ada.Text_IO;
+-- !! will disappear in favour of Ada.Exceptions
+
+with Multi_precision_integers.IO;
+
+package body Multi_precision_integers.Check is
+
+ package IOi renames Multi_precision_integers.IO;
+
+ -- Don't be afraid by the bug reporting tools,
+ -- they are unlikely to pop out of a programme ;-)
+
+ Bug_file: Ada.Text_IO.File_type;
+ Bug_file_name: constant String:= "mupreint.bug";
+
+ -- The flaw detection (DEBUG mode) could suffer from
+ -- a chicken-and-egg problem: e.g. "*" works, but the "/"
+ -- to verify it doesn't !
+
+ Multiply_flawed_div1_has_rest : exception;
+ Multiply_flawed_div1_wrong_quotient : exception;
+ Multiply_flawed_div2_has_rest : exception;
+ Multiply_flawed_div2_wrong_quotient : exception;
+
+ Div_Rem_flawed : exception;
+
+ procedure Open_Bug_Report is
+ begin
+ Create( Bug_file, out_file, Bug_file_name );
+ Put_Line( Bug_file, "Bug in Multi_precision_integers");
+ end Open_Bug_Report;
+
+ procedure Close_Bug_Report is
+ begin
+ Close( Bug_file );
+ -- These console messages can provoke a silent quit in GUI apps,
+ -- so we put them after closing the report.
+ Put_Line( "Bug in Multi_precision_integers !");
+ Put_Line( "For details, read file: " & Bug_file_name);
+ end Close_Bug_Report;
+
+ procedure Test( m: multi_int; test_last: Boolean:= True ) is
+ last_nz: index_int:= 0;
+ Negative_block,
+ Last_index_has_zero,
+ Field_last_outside_range, Field_last_is_negative: exception;
+ begin
+ if m.zero then return; end if; -- 0, nothing to test
+ if m.last_used > m.n then raise Field_last_outside_range; end if;
+ if m.last_used < 0 then raise Field_last_is_negative; end if;
+ for i in 0 .. m.last_used loop
+ if m.blk(i) < 0 then
+ raise Negative_block;
+ end if;
+ if m.blk(i) /= 0 then
+ last_nz:= i;
+ end if;
+ end loop;
+ if test_last and then 0 < last_nz and then last_nz < m.last_used then
+ raise Last_index_has_zero;
+ end if;
+ end Test;
+
+ procedure Check_Multiplication(i1,i2,i3: in multi_int) is
+ jeu: constant:= 5; -- 0 suffit
+ q1: Multi_int( i2.last_used + jeu );
+ r1: Multi_int( i1.last_used + i2.last_used + jeu );
+ q2: Multi_int( jeu );
+ r2: Multi_int( i2.last_used + jeu );
+
+ procedure Bug_Report is
+ begin
+ Open_Bug_Report;
+ Put_Line( Bug_file, "Multiply_and_verify");
+ Put( Bug_file, "i1 ="); IOi.Put_in_blocks(Bug_file, i1); New_Line(Bug_file);
+ Put( Bug_file, "i2 ="); IOi.Put_in_blocks(Bug_file, i2); New_Line(Bug_file);
+ Put( Bug_file, "i3 ="); IOi.Put_in_blocks(Bug_file, i3); New_Line(Bug_file);
+ end Bug_Report;
+
+ begin
+ Test(i1);
+ Test(i2);
+
+ if not (i1.zero or i2.zero) then
+ -- Now we divide i3 by i1, q1 should be = i2
+ Div_Rem_internal_both_export(i3,i1, q1,r1);
+ if not r1.zero then
+ Bug_Report;
+ Close_Bug_Report;
+ raise Multiply_flawed_div1_has_rest;
+ end if;
+ if not Equal( q1, i2 ) then
+ Bug_Report;
+ Put( Bug_file, "q1 ="); IOi.Put_in_blocks(Bug_file, q1); New_Line(Bug_file);
+ Close_Bug_Report;
+ raise Multiply_flawed_div1_wrong_quotient;
+ end if;
+ -- Now we divide q1 by i2, should be = 1
+ Div_Rem_internal_both_export(q1,i2, q2,r2);
+ if not r2.zero then
+ Bug_Report;
+ Close_Bug_Report;
+ raise Multiply_flawed_div2_has_rest;
+ end if;
+ if not Equal( q2, Multi(1) ) then
+ Bug_Report;
+ Put( Bug_file, "q2 ="); IOi.Put_in_blocks(Bug_file, q1); New_Line(Bug_file);
+ Close_Bug_Report;
+ raise Multiply_flawed_div2_wrong_quotient;
+ end if;
+ end if;
+
+ end Check_Multiplication;
+
+ procedure Check_Div_Rem(i1,i2,q,r: in multi_int) is
+
+ procedure Bug_Report is
+ begin
+ Open_Bug_Report;
+ Put_Line( Bug_file, "Div_Rem_and_verify");
+ Put( Bug_file, "i1 ="); IOi.Put_in_blocks(Bug_file, i1); New_Line(Bug_file);
+ Put( Bug_file, "i2 ="); IOi.Put_in_blocks(Bug_file, i2); New_Line(Bug_file);
+ Put( Bug_file, "q ="); IOi.Put_in_blocks(Bug_file, q); New_Line(Bug_file);
+ Put( Bug_file, "r ="); IOi.Put_in_blocks(Bug_file, r); New_Line(Bug_file);
+ end Bug_Report;
+
+ begin
+ Test(i1);
+ Test(i2);
+
+ if not Equal( i1, i2*q + r ) then
+ Bug_Report;
+ Close_Bug_Report;
+ raise Div_Rem_flawed;
+ end if;
+
+ Test(q);
+ Test(r);
+ end Check_Div_Rem;
+
+end Multi_precision_integers.Check;
diff --git a/src/multi_precision_integers-check.ads b/src/multi_precision_integers-check.ads new file mode 100644 index 0000000..60895ea --- /dev/null +++ b/src/multi_precision_integers-check.ads @@ -0,0 +1,12 @@ +package Multi_precision_integers.Check is
+
+ -- check integrity
+ procedure Test (m: Multi_int; test_last: Boolean:= True );
+
+ -- i3 must be = i1 * i2
+ procedure Check_Multiplication (i1, i2,i3: in Multi_int);
+
+ -- i1 must be = i2 * q + r
+ procedure Check_Div_Rem (i1, i2,q,r: in Multi_int);
+
+end Multi_precision_integers.Check;
diff --git a/src/multi_precision_integers-io.adb b/src/multi_precision_integers-io.adb new file mode 100644 index 0000000..ca8f1c2 --- /dev/null +++ b/src/multi_precision_integers-io.adb @@ -0,0 +1,186 @@ +-----------------------------------------------------------------------------
+-- File: muprinio.adb; see specification (muprinio.ads)
+-----------------------------------------------------------------------------
+
+package body Multi_precision_integers.IO is
+
+ package IIO is new Integer_IO( index_int );
+
+ table: constant array(basic_int'(0)..15) of Character:=
+ ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
+
+ -- 15-Feb-2002: Bugfix case i=0. Spotted by Duncan Sands
+
+ function Chiffres_i_non_nul(i: multi_int; base: number_base:= 10) return Natural is
+ nombre: multi_int(i.last_used);
+ la_base : constant basic_int := basic_int(base);
+ nchiffres: Natural:= 1;
+
+ procedure Comptage_rapide( C: Positive ) is
+ test : multi_int(i.n);
+ base_puiss_C: constant multi_int:= Multi( basic_int(base) ) ** C;
+ begin
+ loop
+ Fill(test, nombre / base_puiss_C );
+ exit when test.zero;
+ -- quotient non nul, donc on a au moins C chiffres
+ Fill(nombre, test);
+ nchiffres:= nchiffres + C;
+ end loop;
+ end Comptage_rapide;
+
+ begin
+ Fill(nombre, i);
+ Comptage_rapide( 400 );
+ Comptage_rapide( 20 );
+ loop
+ Fill(nombre, nombre / la_base);
+ exit when nombre.zero;
+ nchiffres:= nchiffres + 1;
+ end loop;
+ return nchiffres;
+ end Chiffres_i_non_nul;
+
+ function Number_of_digits(i: multi_int; base: number_base:= 10) return Natural is
+ begin
+ if i.zero then
+ return 1;
+ else
+ return Chiffres_i_non_nul(i,base);
+ end if;
+ end Number_of_digits;
+
+ function Str(i: multi_int; base: number_base:= 10) return String is
+ res: String(1..1 + Number_of_digits(i,base)):= (others=> 'x');
+ nombre : multi_int(i.n):= i;
+ chiffre: basic_int;
+ la_base: constant basic_int := basic_int(base);
+
+ begin
+ if nombre.zero or else not nombre.neg then
+ res(1):= ' ';
+ else
+ res(1):= '-';
+ end if;
+ nombre.neg:= False;
+
+ -- maintenant nombre et base sont >=0, MOD=REM
+ for k in reverse 2 .. res'Last loop
+ Div_Rem( nombre, la_base, nombre, chiffre );
+ res(k):= table( chiffre );
+ exit when nombre.zero;
+ end loop;
+ return res;
+
+ end Str;
+
+
+-- !!! recursion !!!
+
+ function Val(s: String) return multi_int is
+ formatting_error: exception;
+ begin
+ if s="" then
+ return Multi(0);
+ elsif s(s'First)='-' then
+ return -Val(s(s'First+1..s'Last));
+ elsif s(s'First)='+' then
+ return Val(s(s'First+1..s'Last));
+ elsif s(s'Last) in '0'..'9' then
+ return basic_int'Value(s(s'Last..s'Last)) + 10 *
+ Val(s(s'First..s'Last-1));
+ else
+ raise formatting_error;
+ end if;
+ end Val;
+
+ procedure Put_in_blocks(File : in File_Type;
+ Item : in multi_int) is
+ begin
+ if Item.neg then put(File,'-'); else put(File,'+'); end if;
+ Put(File, " [ ");
+ IIO.Put(File, 1+Item.n , 3);
+ Put(File, " blocks ]: ");
+ Put(File,'{');
+ if Item.n > Item.last_used then
+ IIO.Put(File, Item.n - Item.last_used, 3);
+ Put(File, " unused |");
+ end if;
+ for k in reverse 0 .. Item.last_used loop
+ Put(File, Block_type'Image(Item.blk(k)));
+ if k>0 then Put(File,'|'); end if;
+ end loop;
+ Put(File,'}');
+ end Put_in_blocks;
+
+ procedure Put_in_blocks(Item : in multi_int) is
+ begin
+ Put_in_blocks( Standard_Output, Item );
+ end Put_in_blocks;
+
+ procedure Get(File : in File_Type;
+ Item : out multi_int;
+ Width : in Field := 0) is
+ begin
+ null; -- !!!
+ end Get;
+
+ procedure Get(Item : out multi_int;
+ Width : in Field := 0) is
+
+ begin
+ Get(Standard_Input, Item, Width);
+ end Get;
+
+
+ procedure Put(File : in File_Type;
+ Item : in multi_int;
+ Width : in Field := 0;
+ Base : in Number_Base := Default_Base) is
+
+ begin
+ if Width = 0 then -- No padding required (default)
+ Put(File, Str(Item, Base));
+ else -- Left padding required -> slow
+ declare
+ la_chaine: String(1..Width);
+ begin
+ Put(la_chaine, Item, Base);
+ Put(File, la_chaine);
+ end;
+ end if;
+ end Put;
+
+ procedure Put(Item : in multi_int;
+ Width : in Field := 0;
+ Base : in Number_Base := Default_Base) is
+
+ begin
+ Put(Standard_Output, Item, Width, Base);
+ end Put;
+
+ procedure Get(From : in String;
+ Item : out multi_int;
+ Last : out Positive) is
+ begin
+ Last:= 1;
+ null; -- !!!
+ end Get;
+
+
+ procedure Put(To : out String;
+ Item : in multi_int;
+ Base : in Number_Base := Default_Base) is
+
+ nchiffres: constant Natural:= Number_of_digits(Item, Base);
+ blancs: constant String(To'Range):= (others=> ' ');
+ begin
+ if nchiffres > To'Length then
+ raise Layout_Error;
+ else
+ To:= blancs;
+ To( To'Last - nchiffres .. To'Last ):= Str(Item, Base);
+ end if;
+ end Put;
+
+end Multi_precision_integers.IO;
diff --git a/src/multi_precision_integers-io.ads b/src/multi_precision_integers-io.ads new file mode 100644 index 0000000..1544d3c --- /dev/null +++ b/src/multi_precision_integers-io.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------
+-- File: Multi_precision_integers-IO.ads
+-- Description: Child of package 'Multi_precision_integers: I/O
+-- Date/version: 2006 ; 15-Feb-2002 / 22.XI.1999 / 22.12.1996
+-- Author: Gautier de Montmollin
+------------------------------------------------------------------------------
+with Text_IO; use Text_IO;
+
+package Multi_precision_integers.IO is
+
+ Default_Base: Number_Base := 10;
+
+ -- Returns the number of digits in the specified base:
+ function Number_of_digits(i: Multi_int; base: Number_Base:= 10) return Natural;
+
+ -- Returns the image of i in the specified base:
+ function Str(i: Multi_int; base: Number_Base:= 10) return String;
+
+ -- Returns the value of number in string:
+ function Val(s: String) return Multi_int;
+
+ -- Output to file, in block format:
+ procedure Put_in_blocks(File : in File_Type;
+ Item : in Multi_int);
+
+ -- Output to standard input, in block format:
+ procedure Put_in_blocks(Item : in Multi_int);
+
+ ---- The following mimic the Text_IO.Integer_IO
+
+ -- Get from file:
+ procedure Get(File : in File_Type;
+ Item : out Multi_int;
+ Width : in Field := 0);
+
+ -- Get from standard input:
+ procedure Get(Item : out Multi_int;
+ Width : in Field := 0);
+
+ -- Put to file:
+ procedure Put(File : in File_Type;
+ Item : in Multi_int;
+ Width : in Field := 0;
+ Base : in Number_Base := Default_Base);
+ -- Width=0 : no default formatting, since inpredicatble length
+
+ -- Put to standard output:
+ procedure Put(Item : in Multi_int;
+ Width : in Field := 0;
+ Base : in Number_Base := Default_Base);
+ -- Width=0 : no default formatting, since inpredicatble length
+
+ -- Get from string:
+ procedure Get(From : in String;
+ Item : out Multi_int;
+ Last : out Positive);
+
+ -- Put to string:
+ procedure Put(To : out String;
+ Item : in Multi_int;
+ Base : in Number_Base := Default_Base);
+
+end Multi_precision_integers.IO;
diff --git a/src/multi_precision_integers.adb b/src/multi_precision_integers.adb new file mode 100644 index 0000000..4d8d876 --- /dev/null +++ b/src/multi_precision_integers.adb @@ -0,0 +1,1500 @@ +-----------------------------------------------------------------------------
+-- File: mupreint.adb; see specification (mupreint.ads)
+-----------------------------------------------------------------------------
+-- Aug-2007: - No more generics (Long_Block_type,
+-- Block_type,... always the largest possible idea: J.C.)
+-- - Fixed Basic(...) (based on J.C.'s remarks)
+-- Nov-2006: - Multiply_internal with/without copy of result (automatic
+-- detection of when it is needed)
+-- - Explicit Multiply_internal for Multi_int * Basic_int
+-- - Multiply(multi,basic,multi) available as procedure
+-- - useless zeroing of quotient removed
+-- - useless zeroing of blocks removed for indices
+-- above last possible used in *
+-- 24-Feb-2002: Div_Rem(u, v, v, r) also possible
+-- 23-Feb-2002: DEBUG: +: multiplications are verified by dividing the result
+-- +: divisions are verified by comparing i2*q+r and i1
+-- 15-Feb-2002: "zero" and 1st index in Divide_absolute_normalized
+-- bugs fixed by Duncan Sands (D.S.)
+
+-- To-do/bug symbol: !!
+
+with Multi_precision_integers.Check;
+-- with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+
+package body Multi_precision_integers is
+
+ function Shift_Left
+ (Value : Block_type;
+ Amount : Natural) return Block_type;
+
+ function Shift_Right
+ (Value : Block_type;
+ Amount : Natural) return Block_type;
+
+ function Shift_Left
+ (Value : Long_Block_type;
+ Amount : Natural) return Long_Block_type;
+
+ function Shift_Right
+ (Value : Long_Block_type;
+ Amount : Natural) return Long_Block_type;
+
+ pragma Import (Intrinsic, Shift_Left);
+ pragma Import (Intrinsic, Shift_Right);
+
+ package Check_internal renames Multi_precision_integers.Check;
+
+ -- Internal_error: exception;
+ -- Not_done: exception;
+
+ type compar is (smaller, equal, greater);
+
+ function Min (a,b: Index_int) return Index_int is
+ begin if a < b then return a; else return b; end if; end Min;
+
+ function Max (a,b: Index_int) return Index_int is
+ begin if a > b then return a; else return b; end if; end Max;
+
+ procedure Reduce_last_nonzero ( n: in out Multi_int ) is
+ old_last : constant Index_int:= n.last_used;
+ begin
+ if Debug then Check_internal.Test(n, test_last=> False); end if;
+
+ if n.zero then -- We avoid de-zeroing accidentally
+ return; -- and returning a false non-zero with rubbish :-)
+ end if;
+
+ n.zero := True;
+ for i in 0 .. old_last loop -- after old_last it *is* rubbish anyway.
+ if n.blk(i) /= 0 then
+ n.zero := False;
+ n.last_used := i;
+ end if;
+ end loop;
+ end Reduce_last_nonzero;
+
+ function Compare_absolute (i1, i2: Multi_int) return compar is
+ l1, l2 : Index_int;
+ begin
+ -- On ne compare que ABS(i1) et ABS(i2)
+ l1:= i1.last_used;
+ l2:= i2.last_used;
+ if l1 > l2 then -- i1 a plus de blocs non nuls
+ return greater;
+ elsif l1 < l2 then -- i1 a moins de blocs non nuls
+ return smaller;
+ else -- i1 et i2 ont le meme nb de blocs
+ for i in reverse 0 .. l1 loop -- on parcourt du + signifiant au -
+ if i1.blk(i) > i2.blk(i) then -- <<chiffre>> de i1 plus grand
+ return greater;
+ elsif i1.blk(i) < i2.blk(i) then -- <<chiffre>> de i1 plus petit
+ return smaller;
+ end if;
+ -- M\^emes chiffres -> au suivant!
+ end loop;
+ -- Bon, les 2 nombres sont egaux!
+ return equal;
+ end if;
+ end Compare_absolute;
+
+ ----- Informations, conversions
+
+ function Multi(small: Basic_int) return Multi_int is
+ abss: constant Long_Block_type:= Long_Block_type(abs small);
+ reste: Long_Block_type;
+ negs: constant Boolean:= small < 0;
+ Conversion_overflow : exception;
+
+ begin
+
+ if abss <= Long_Block_type(maxblock) then
+ return Multi_int'
+ ( n=> 0, -- 1 bloc suffit
+ blk=> (0=> Block_type(abss)), -- le bloc contient le nombre
+ neg=> negs,
+ zero=> small = 0,
+ last_used=> 0
+ );
+ else
+ reste:= Shift_Right(abss, Block_type_bits);
+ if reste <= Long_Block_type(maxblock) then
+ return ( n=> 1, -- il faut 2 blocs
+ blk=> (0=> Block_type(abss and maxblock), -- bloc 0
+ 1=> Block_type(reste)), -- bloc 1
+ neg=> negs,
+ zero=> False,
+ last_used=> 1
+ );
+ else
+ if Shift_Right(reste, Block_type_bits) > Long_Block_type(maxblock) then
+ raise Conversion_overflow;
+ end if;
+
+ return ( n=> 2, -- il faut 3 blocs (e.g. 31 bits 15+15+1)
+ blk=> (0=> Block_type(abss and maxblock), -- bloc 0
+ 1=> Block_type(reste and maxblock), -- bloc 1
+ 2=> Block_type(Shift_Right(reste, Block_type_bits)) -- bloc 2
+ ),
+ neg=> negs,
+ zero=> False,
+ last_used=> 2
+ );
+ end if;
+ end if;
+ end Multi;
+
+ zero: constant Multi_int:= Multi(0);
+ one : constant Multi_int:= Multi(1);
+
+ Blocks_Per_Basic : constant Positive :=
+ (Basic_int'Size + Block_type'Size - 1) / Block_type'Size;
+
+ -- Convert Multi_int to Basic_int (when possible, else: Cannot_fit raised)
+ -- 2007:
+ -- - correct code for block sizes smaller than Basic_int
+ -- - fixed usage of negative flag
+ function Basic(large: Multi_int) return Basic_int is
+ type Same_as_Basic_natural is mod 2 ** Basic_int'Size;
+ function Shift_Left
+ (Value : Same_as_Basic_natural;
+ Amount : Natural) return Same_as_Basic_natural;
+ pragma Import (Intrinsic, Shift_Left);
+ result : Same_as_Basic_natural;
+ block_value: Block_type;
+ type Huge_int is mod System.Max_Binary_Modulus;
+ last_bit: Natural;
+ begin
+ if large.zero then -- <- 17-Feb-2002
+ return 0;
+ end if;
+ -- Case: too many blocks (whatever sizes)
+ if 1 + large.last_used > Blocks_Per_Basic then
+ raise Cannot_fit;
+ end if;
+ -- Case: block size and contents larger than basic
+ block_value:= large.blk(large.last_used);
+ if Huge_int(block_value) > Huge_int(Basic_int'Last) then
+ raise Cannot_fit;
+ end if;
+ declare
+ tmp: Block_type:= block_value;
+ begin
+ last_bit:= 0;
+ while tmp /= 0 loop
+ tmp:= tmp / 2;
+ last_bit:= last_bit + 1;
+ end loop;
+ end;
+ result:= Same_as_Basic_natural(block_value);
+ -- If the following loop was on all blocks,
+ -- the shift by Block_type_bits in the loop could do meaningless
+ -- things the case Basic_int'Size <= Block_Type'Size
+ for b in reverse 0 .. large.last_used-1 loop
+ result:= Shift_Left(result, Block_type_bits);
+ -- An overflow is not detected by shifting (it's the way we want it!)
+ -- so we need to detect the overall overflow by locating the
+ -- last bit.
+ last_bit:= last_bit + Block_type_bits;
+ if last_bit > Basic_int'Size - 1 then
+ -- ^ "- 1" because of sign bit in Basic_int
+ raise Cannot_fit;
+ end if;
+ result:= result + Same_as_Basic_natural(large.blk(b));
+ end loop;
+ if large.neg then
+ return -Basic_int(result);
+ else
+ return Basic_int(result);
+ end if;
+ end Basic;
+
+ -- 14-Feb-2002: "zero" bug fixed by Duncan Sands
+ procedure Fill(what: out Multi_int; with_smaller:Multi_int) is
+ l: constant Index_int:= with_smaller.last_used;
+ begin
+ if Debug then Check_internal.Test(with_smaller); end if;
+ what.zero:= with_smaller.zero;
+
+ if with_smaller.zero then
+ return;
+ end if;
+
+ if what.n < l then
+ raise Array_too_small; -- contenant trop petit
+ end if;
+
+ what.blk(0..l):= with_smaller.blk(0..l); -- copy contents
+ what.neg:= with_smaller.neg;
+ what.last_used:= l;
+ end Fill;
+
+ procedure Fill(what:out Multi_int; with_basic: Basic_int) is
+ begin
+ Fill( what, Multi(with_basic) );
+ end Fill;
+
+ function Bits_per_block return Positive is
+ begin
+ return Block_type_bits;
+ end Bits_per_block;
+
+ ---------------------------
+ ----- Unary operators -----
+ ---------------------------
+
+ function "+" (i: Multi_int) return Multi_int is begin return i; end "+";
+
+ procedure Opp(i: in out Multi_int) is
+ begin
+ i.neg:= not i.neg; -- -0 possible, anyway i.zero = True in such a case
+ end Opp;
+
+ function "-" (i: Multi_int) return Multi_int is
+ res: Multi_int(i.n):= i; -- copy + stack :-(
+ begin
+ Opp(res);
+ return res;
+ end "-";
+
+ procedure Abso(i: in out Multi_int) is
+ begin
+ i.neg:= False;
+ end Abso;
+
+ function "Abs" (i: Multi_int) return Multi_int is
+ abs_i: Multi_int(i.n):= i; -- copy + stack :-(
+ begin
+ if Debug then Check_internal.Test(i); end if;
+ abs_i.neg:= False;
+ return abs_i;
+ end "Abs";
+
+ function Sign(i: Multi_int) return Basic_int is
+ begin
+ if i.zero then return 0;
+ elsif i.neg then return -1;
+ else return +1;
+ end if;
+ end Sign;
+
+ function Even(i: Multi_int) return Boolean is
+ begin
+ return i.zero or i.blk(0) mod 2 = 0;
+ end Even;
+
+ function Odd (i: Multi_int) return Boolean is
+ begin
+ return (not i.zero) and i.blk(0) mod 2 = 1;
+ end Odd;
+
+ ----------------------------
+ ----- Binary operators -----
+ ----------------------------
+
+ -- Internal algorithm to add two numbers AS POSITIVE ( > 0 ) !
+
+ procedure Add_absolute(i1,i2: in Multi_int; i3: out Multi_int) is
+ l1: constant Index_int:= i1.last_used;
+ l2: constant Index_int:= i2.last_used;
+ min_ind: constant Index_int:= Min( l1, l2 );
+ max_ind: constant Index_int:= Max( l1, l2 );
+ s: Long_Block_type:= 0;
+ retenue_finale: Block_type;
+ begin
+ if Debug then Check_internal.Test(i1); Check_internal.Test(i2); end if;
+
+ if max_ind > i3.n then
+ raise Result_undersized;
+ end if; -- 17-Feb-2002
+
+ -- (1) On additionne sur le <<support commun>>
+ for ind in 0 .. min_ind loop
+ s:= Long_Block_type(i1.blk(ind)) + Long_Block_type(i2.blk(ind)) +
+ Shift_Right(s, Block_type_bits); -- (retenue)
+ i3.blk(ind):= Block_type(s and maxblock);
+ -- NB: dans un cas de Add(a,b,a) ou Add(a,b,b),
+ -- i1.blk(ind) ou i2.blk(ind) est modifie en meme temps!
+ end loop;
+
+ -- (2) On poursuit au besoin si i1 a plus de blocs...
+ if l1 > min_ind then
+ for ind in min_ind+1 .. max_ind loop
+ s:= Long_Block_type(i1.blk(ind)) +
+ Shift_Right(s, Block_type_bits); -- (retenue)
+ i3.blk(ind):= Block_type(s and maxblock);
+ end loop;
+ -- ... ou bien si i2 en a plus.
+ elsif l2 > min_ind then
+ for ind in min_ind+1 .. max_ind loop
+ s:= Long_Block_type(i2.blk(ind)) +
+ Shift_Right(s, Block_type_bits); -- (retenue)
+ i3.blk(ind):= Block_type(s and maxblock);
+ end loop;
+ end if;
+
+ -- (3) Il peut rester une retenue
+ retenue_finale:= Block_type(Shift_Right(s, Block_type_bits));
+ if retenue_finale /= 0 then
+ if max_ind+1 > i3.n then
+ raise Result_undersized;
+ end if; -- 17-Feb-2002
+ i3.blk(max_ind+1):= retenue_finale;
+ i3.last_used:= max_ind+1;
+ else
+ i3.last_used:= max_ind;
+ end if;
+
+ -- (4) i3 = i1+i2 > 0
+ i3.neg:= False;
+ i3.zero:= False;
+
+ end Add_absolute;
+
+ -- Internal algorithm to subtract two numbers AS POSITIVE ( > 0 ) !
+
+ procedure Sub_absolute(i1,i2: in Multi_int; i3: in out Multi_int;
+ sgn: out Boolean) is
+ l1: constant Index_int:= i1.last_used;
+ l2: constant Index_int:= i2.last_used;
+ max_ind: constant Index_int:= Max( l1, l2 );
+ ai, bi: Long_Block_type;
+ s: Block_type;
+ retenue_finale: Long_Block_type;
+ begin
+ if Debug then Check_internal.Test(i1); Check_internal.Test(i2); end if;
+
+ if max_ind > i3.n then raise Result_undersized; end if; -- 17-Feb-2002
+
+ i3.last_used:= 0;
+ i3.zero:= True;
+ s:= 0;
+
+ -- (1) Soustraction avec retenue
+ for ind in 0 .. max_ind loop
+ if ind <= l1 then
+ ai:= Long_Block_type(i1.blk(ind));
+ else
+ ai:= 0;
+ end if;
+ if ind <= l2 then
+ bi:= Long_Block_type(i2.blk(ind)) + Long_Block_type(s);
+ else
+ bi:= Long_Block_type(s);
+ end if;
+
+ if ai < bi then
+ ai:= ai + cardblock;
+ s:= 1;
+ else
+ s:= 0;
+ end if;
+
+ i3.blk(ind):= Block_type(ai-bi);
+ -- NB: dans un cas de Sub(a,b,a) ou Sub(a,b,b),
+ -- i1.blk(ind) ou i2.blk(ind) est modifie en meme temps!
+
+ if i3.blk(ind) /= 0 then -- au passage, on corrige .last_used et .zero
+ i3.last_used:= ind;
+ i3.zero:= False;
+ end if;
+ end loop;
+
+ -- (2) Traitement de la derni\`ere retenue
+ if s = 0 then
+ i3.neg := False;
+ sgn := False;
+ else
+ i3.neg := True;
+ sgn := True;
+ i3.last_used:= 0;
+ retenue_finale:= 1; -- on fait "9-chaque chiffre" et on ajoute 1 au tout
+ for i in 0 .. max_ind loop
+ retenue_finale:=
+ Long_Block_type(maxblock) -
+ Long_Block_type(i3.blk(i)) + retenue_finale;
+ i3.blk(i):= Block_type(retenue_finale and maxblock);
+ if i3.blk(i) /= 0 then
+ i3.last_used:= i;
+ end if;
+ retenue_finale:= Shift_Right(retenue_finale, Block_type_bits);
+ end loop;
+ end if;
+
+ end Sub_absolute;
+
+ procedure Add(i1,i2: in Multi_int; i3: in out Multi_int) is
+ sgn: Boolean;
+ begin
+ -- (1) Les cas o\`u i1 ou i2 = 0
+ if i1.zero and i2.zero then
+ i3.zero:= True;
+ elsif i1.zero then
+ Fill( i3, i2 );
+ elsif i2.zero then
+ Fill( i3, i1 );
+ -- (2) Maintenant: i1 /= 0 et i2 /= 0; on regarde les signes
+ -- (2.1) Facile: i1 et i2 de m\^eme signe
+ elsif i1.neg = i2.neg then
+ Add_absolute( i1,i2, i3 ); -- On fait comme si i1>0 et i2>0
+ i3.neg:= i1.neg; -- et on met le bon signe
+ -- (2.2) i1 < 0, i2 > 0, donc i3 = i2 - abs(i1)
+ elsif i1.neg and not i2.neg then
+ Sub_absolute( i2,i1, i3, sgn);
+ -- (2.3) i1 > 0, i2 < 0, donc i3 = i1 - abs(i2)
+ elsif i2.neg and not i1.neg then
+ Sub_absolute( i1,i2, i3, sgn );
+ end if;
+ end Add;
+
+ function "+" (i1,i2: Multi_int) return Multi_int is
+ somme: Multi_int( Max(i1.n, i2.n) + 1 );
+ begin
+ Add( i1,i2, somme );
+ return somme;
+ end "+";
+
+ procedure Sub(i1,i2: in Multi_int; i3: in out Multi_int) is
+ sgn: Boolean;
+ begin
+ -- (1) Les cas o\`u i1 ou i2 = 0
+ if i1.zero and i2.zero then i3.zero:= True;
+ elsif i1.zero then Fill( i3, i2 ); i3.neg:= not i2.neg;
+ elsif i2.zero then Fill( i3, i1 );
+
+ -- (2) Maintenant: i1 /= 0 et i2 /= 0; on regarde les signes
+
+ -- (2.1) Facile: i1 et i2 de m\^eme signe
+ elsif i1.neg = i2.neg then
+ Sub_absolute( i1,i2, i3, sgn ); -- On fait comme si i1>0 et i2>0
+ -- et on met le bon signe
+ i3.neg:= i1.neg xor sgn;
+ -- 26-Mar-2002: equivalent a:
+ -- if i1.neg then
+ -- i3.neg:= NOT sgn;
+ -- else
+ -- i3.neg:= sgn;
+ -- end if;
+
+ -- (2.2) i1 < 0, i2 > 0, donc i3 = i1-i2 = - (abs(i1) + abs(i2))
+ elsif i1.neg and not i2.neg then
+ Add_absolute( i1,i2, i3 );
+ i3.neg:= True;
+
+ -- (2.3) i1 > 0, i2 < 0, donc i3 = i1-i2 = i1 + (-i2) = i1 + abs(i2)
+ elsif i2.neg and not i1.neg then
+ Add_absolute( i1,i2, i3 );
+ end if;
+
+ end Sub;
+
+ function "-" (i1,i2: Multi_int) return Multi_int is
+ diff: Multi_int( Max(i1.n, i2.n) + 1); -- +1: retenue possible (add_abs.)
+ begin
+ Sub( i1,i2, diff );
+ return diff;
+ end "-";
+
+ function "+" (i1: Multi_int; i2: Basic_int) return Multi_int is
+ begin return i1 + Multi(i2); end "+";
+
+ function "+" (i1: Basic_int; i2: Multi_int) return Multi_int is
+ begin return Multi(i1) + i2; end "+";
+
+ function "-" (i1: Multi_int; i2: Basic_int) return Multi_int is
+ begin return i1 - Multi(i2); end "-";
+
+ function "-" (i1: Basic_int; i2: Multi_int) return Multi_int is
+ begin return Multi(i1) - i2; end "-";
+
+ ----- Begin of MULTIPLICATION part -----
+
+ -- Added 2006: choice to copy result into i3 or write directly into i3
+ generic
+ copy: Boolean;
+ procedure Multiply_internal_m_m(i1,i2: in Multi_int; i3: in out Multi_int);
+
+ type p_Block_array is access Block_array;
+ procedure Dispose is new Ada.Unchecked_Deallocation(Block_array,p_Block_array);
+
+ -------------------
+ -- Multi * Multi --
+ -------------------
+
+ -- To do: implement a faster algorithm.
+ -- 1) Karatsuba's algorithm
+ -- Ada code for string arithm exists !!
+ -- http://www.csc.liv.ac.uk/~ped/teachadmin/algor/karatsuba.ada
+ -- 2) Better: Schönhage-Strassen algorithm (no Ada code)
+
+ procedure Multiply_internal_m_m(i1,i2: in Multi_int; i3: in out Multi_int) is
+ l1: constant Index_int:= i1.last_used;
+ l2: constant Index_int:= i2.last_used;
+ last_max: constant Index_int:= l1 + l2 + 2;
+ prod,sum_carry,rk,i1j : Long_Block_type;
+ i,k: Index_int;
+ res: p_Block_array;
+ -- res: buffer used in the "copy" variant to avoid
+ -- problems with Multiply(i,j,i) or Multiply(j,i,i)
+ begin
+ if i1.zero or i2.zero then
+ i3.zero:= True;
+ return;
+ end if;
+
+ if last_max > i3.n then
+ raise Result_undersized;
+ end if;
+
+ if copy then
+ res:= new Block_array( 0..last_max );
+ for k in res'Range loop res(k):= 0; end loop;
+ -- Seems slower :-( : res:= new Block_array'( 0..last_max => 0);
+ else
+ for k in 0..last_max loop i3.blk(k):= 0; end loop;
+ -- Slower :-( : i3.blk(0..last_max):= (others => 0);
+ end if;
+
+ i3.zero:= False;
+ i3.last_used:= last_max;
+ -- NB: va changer i1.last_used ou i2.last_used si
+ -- i1 ou i2 et i3 sont les memes
+
+ for j in 0..l1 loop
+ i1j:= Long_Block_type(i1.blk(j));
+ sum_carry:= 0;
+ i:= 0;
+ k:= j;
+ loop
+ if i <= l2 then
+ prod:= i1j * Long_Block_type(i2.blk(i));
+ else
+ exit when sum_carry = 0; -- nothing more to add
+ prod:= 0;
+ end if;
+ if copy then
+ rk:= Long_Block_type(res(k));
+ else
+ rk:= Long_Block_type(i3.blk(k));
+ end if;
+ sum_carry:= rk + prod + sum_carry;
+ if copy then
+ res(k):= Block_type(sum_carry and maxblock); -- somme
+ else
+ i3.blk(k):= Block_type(sum_carry and maxblock); -- somme
+ end if;
+ sum_carry:= Shift_Right(sum_carry, Block_type_bits); -- retenue
+ i:= i + 1;
+ k:= k + 1;
+ end loop;
+ end loop;
+
+ if copy then
+ i3.blk(res'Range):= res.all;
+ Dispose(res);
+ end if;
+
+ Reduce_last_nonzero( i3 );
+
+ i3.neg:= i1.neg /= i2.neg;
+
+ end Multiply_internal_m_m;
+
+ procedure Multiply_internal_copy is
+ new Multiply_internal_m_m( copy => True );
+ procedure Multiply_internal_copy_export(i1,i2: in Multi_int; i3: in out Multi_int)
+ renames Multiply_internal_copy;
+ -- ^ At least GNAT <= GPL 2006 requires the trick with renames...
+ -- ObjectAda 7.2.2 too -> there must be a good reason...
+
+ procedure Multiply_internal_no_copy is
+ new Multiply_internal_m_m( copy => False );
+
+ -------------------
+ -- Multi * Basic --
+ -- added 2006 --
+ -------------------
+
+ generic
+ copy: Boolean;
+ procedure Multiply_internal_m_b(i1: in Multi_int; i2: Basic_int; i3: in out Multi_int);
+
+ procedure Multiply_internal_m_b(i1: in Multi_int; i2: Basic_int; i3: in out Multi_int) is
+ l1: constant Index_int:= i1.last_used;
+ last_max: constant Index_int:= l1 + 2;
+ prod,sum_carry,rk,i2a : Long_Block_type;
+ k: Index_int;
+ res: p_Block_array;
+ -- res: buffer used in the "copy" variant to avoid
+ -- problems with Multiply(i,j,i) or Multiply(j,i,i)
+ begin
+ if i1.zero or i2=0 then
+ i3.zero:= True;
+ return;
+ end if;
+
+ if last_max > i3.n then
+ raise Result_undersized;
+ end if;
+
+ if copy then
+ res:= new Block_array( 0..last_max );
+ for k in res'Range loop res(k):= 0; end loop;
+ -- Seems slower :-( : res:= new Block_array'( 0..last_max => 0);
+ else
+ for k in 0..last_max loop i3.blk(k):= 0; end loop;
+ -- Slower :-( : i3.blk(0..last_max):= (others => 0);
+ end if;
+
+ i3.zero:= False;
+ i3.last_used:= last_max;
+ -- NB: va changer i1.last_used ou i2.last_used si i1 ou i2 et i3 sont les memes
+ i2a:= Long_Block_type(abs i2);
+
+ for j in 0..l1 loop
+ k:= j;
+ sum_carry:= 0;
+ prod:= Long_Block_type(i1.blk(j)) * i2a;
+ loop
+ if copy then
+ rk:= Long_Block_type(res(k));
+ else
+ rk:= Long_Block_type(i3.blk(k));
+ end if;
+ sum_carry:= rk + prod + sum_carry;
+ if copy then
+ res(k):= Block_type(sum_carry and maxblock); -- somme
+ else
+ i3.blk(k):= Block_type(sum_carry and maxblock); -- somme
+ end if;
+ sum_carry:= Shift_Right(sum_carry, Block_type_bits); -- retenue
+ exit when sum_carry = 0; -- nothing more to add
+ prod:= 0;
+ k:= k + 1;
+ end loop;
+ end loop;
+
+ if copy then
+ i3.blk(res'Range):= res.all;
+ Dispose(res);
+ end if;
+
+ Reduce_last_nonzero( i3 );
+
+ i3.neg:= i1.neg /= (i2 < 0);
+
+ end Multiply_internal_m_b;
+
+ procedure Multiply_internal_copy is
+ new Multiply_internal_m_b( copy => True );
+
+ procedure Multiply_internal_no_copy is
+ new Multiply_internal_m_b( copy => False );
+
+ procedure Multiply(i1,i2: in Multi_int; i3: in out Multi_int) is
+ use System;
+ begin
+ if Debug then
+ declare
+ m1: constant Multi_int:= i1;
+ m2: constant Multi_int:= i2;
+ begin
+ Multiply_internal_no_copy(m1,m2,i3);
+ Check_internal.Check_Multiplication(m1,m2,i3);
+ end;
+ else
+ if i1'Address = i3'Address or i2'Address = i3'Address then
+ -- Ada.Text_IO.Put_Line("* with copy");
+ Multiply_internal_copy(i1,i2,i3);
+ else
+ -- Ada.Text_IO.Put_Line("* without copy");
+ Multiply_internal_no_copy(i1,i2,i3);
+ end if;
+ end if;
+ end Multiply;
+
+ procedure Multiply(i1: in Multi_int; i2: Basic_int; i3: in out Multi_int) is
+ use System;
+ begin
+ if Debug then
+ declare
+ m1: constant Multi_int:= i1;
+ m2: constant Basic_int:= i2;
+ begin
+ Multiply_internal_no_copy(m1,m2,i3);
+ Check_internal.Check_Multiplication(m1,Multi(m2),i3);
+ end;
+ else
+ if i1'Address = i3'Address or i2'Address = i3'Address then
+ -- Ada.Text_IO.Put_Line("* with copy");
+ Multiply_internal_copy(i1,i2,i3);
+ else
+ -- Ada.Text_IO.Put_Line("* without copy");
+ Multiply_internal_no_copy(i1,i2,i3);
+ end if;
+ end if;
+ end Multiply;
+
+ function "*" (i1,i2: Multi_int) return Multi_int is
+ begin
+ if i1.zero or i2.zero then
+ return zero;
+ else
+ declare
+ prod: Multi_int( i1.last_used + i2.last_used + 2 );
+ begin
+ Multiply( i1,i2, prod );
+ return prod;
+ end;
+ end if;
+ end "*";
+
+ function "*" (i1: Multi_int; i2: Basic_int) return Multi_int is
+ begin
+ if i1.zero or i2=0 then
+ return zero;
+ else
+ declare
+ prod: Multi_int( i1.last_used + 4 );
+ begin
+ Multiply( i1,i2, prod );
+ return prod;
+ end;
+ end if;
+ end "*";
+
+ function "*" (i1: Basic_int; i2: Multi_int) return Multi_int is
+ begin
+ if i2.zero or i1=0 then
+ return zero;
+ else
+ declare
+ prod: Multi_int( i2.last_used + 4 );
+ begin
+ Multiply( i2,i1, prod );
+ return prod;
+ end;
+ end if;
+ end "*";
+
+ ----- Begin of DIVISION part -----
+
+ -- Interne: Division et reste en 1 coup
+
+ procedure Div_Rem(a,b: Long_Block_type; q,r: out Long_Block_type) is
+ Conflict_with_REM: exception;
+ begin
+ q:= a / b;
+ r:= a - b*q;
+ if Debug and then r /= (a rem b) then
+ raise Conflict_with_REM;
+ end if;
+ end Div_Rem;
+
+ procedure Divide_absolute_normalized ( u: in out Multi_int; -- output: u = r
+ v: in Multi_int;
+ q: in out Multi_int ) is
+ qi: Index_int:= u.last_used - v.last_used - 1; -- was: q.n; D.S. Feb-2002
+ v1: constant Long_Block_type:= Long_Block_type(v.blk(v.last_used ));
+ v2: constant Long_Block_type:= Long_Block_type(v.blk(v.last_used-1));
+
+ vlast : constant Index_int:= v.last_used;
+ v1L : constant Long_Block_type := v1;
+ guess,
+ comparand : Long_Block_type ;
+
+ function Divide_subtract ( ustart: Index_int ) return Block_type is
+ ui : Index_int;
+ carry : Long_Block_type;
+ begin
+ if guess = 0 then
+ return 0;
+ end if;
+ ui:= ustart;
+ carry:= 0;
+
+ -- On soustrait (le chiffre du quotient) * diviseur au dividende
+
+ for vi in 0 .. vlast loop
+ declare
+ prod: constant Long_Block_type := Long_Block_type(v.blk(vi)) * guess + carry;
+ bpro: constant Block_type:= Block_type(prod and maxblock);
+ diff: constant Long_Block_type_signed := Long_Block_type_signed(u.blk(ui)) - Long_Block_type_signed(bpro);
+ begin
+ if diff < 0 then
+ u.blk(ui) := Block_type(diff + cardblock);
+ carry := Shift_Right(prod, Block_type_bits) + 1;
+ else
+ u.blk(ui) := Block_type(diff);
+ carry := Shift_Right(prod, Block_type_bits);
+ end if;
+ ui:= ui + 1;
+ end;
+ end loop;
+
+ if carry = 0 then
+ return Block_type(guess and maxblock);
+ end if;
+
+ declare
+ diff: constant Long_Block_type_signed :=
+ Long_Block_type_signed(u.blk(ui)) - Long_Block_type_signed(carry and maxblock);
+ begin
+ if diff < 0 then
+ u.blk(ui) := Block_type(diff + cardblock); -- carry generated
+ else
+ u.blk(ui) := Block_type(diff);
+ return Block_type(guess and maxblock);
+ end if;
+ end;
+
+ -- Carry was generated
+ declare
+ icarry: Block_type := 0;
+ begin
+ ui := ustart;
+ for vi in 0 .. vlast loop
+ declare
+ sum: constant Long_Block_type :=
+ Long_Block_type(v.blk(vi)) +
+ Long_Block_type(u.blk(ui)) +
+ Long_Block_type(icarry);
+ begin
+ u.blk(ui) := Block_type(sum and maxblock);
+ ui:= ui + 1;
+ icarry := Block_type(Shift_Right(sum, Block_type_bits));
+ end;
+ end loop;
+
+ if icarry = 1 then
+ u.blk(ui) := Block_type((Long_Block_type(u.blk(ui))+1) and maxblock);
+ end if;
+ end;
+
+ return Block_type((guess-1) and maxblock);
+
+ end Divide_subtract;
+
+ is_q_zero: Boolean:= True;
+
+ begin -- Divide_absolute_normalized
+ -- for i in q.blk'Range loop q.blk(i):= 0; end loop;
+ --
+ -- ^ zeroing useless: q.last_used = u.last_used-v.last_used-1
+ -- and q.blk(0..q.last_used) is written below q.blk(qi) := ...
+ -- GM 4-nov-2006
+
+ q.last_used:= qi; -- was: q.n; D.S. Feb-2002
+
+ for j in reverse vlast+1 .. u.last_used loop
+ declare
+ uj : constant Long_Block_type := Long_Block_type(u.blk(j));
+ uj1: constant Long_Block_type := Long_Block_type(u.blk(j-1));
+ uj2: constant Long_Block_type := Long_Block_type(u.blk(j-2));
+ ujL: Long_Block_type;
+ rmL: Long_Block_type;
+ begin
+ ujL := Shift_Left(uj, Block_type_bits) + uj1;
+ Div_Rem( ujL, v1L, guess, rmL );
+ comparand := Shift_Left(rmL, Block_type_bits) + uj2;
+
+ while comparand < v2 * guess loop
+ guess:= guess - 1;
+ comparand:= comparand + Shift_Left(v1L, Block_type_bits);
+ exit when comparand > cardblock * cardblock;
+ end loop;
+
+ q.blk(qi) := Divide_subtract( j - vlast - 1 );
+
+ if q.blk(qi) /= 0 and then is_q_zero then -- n'arrive que 0 ou 1 fois
+ is_q_zero:= False;
+ q.last_used:= qi;
+ end if;
+
+ qi:= qi - 1;
+ end;
+
+ end loop; -- j
+
+ q.zero:= is_q_zero;
+
+ if Debug then Check_internal.Test(q); end if;
+
+ end Divide_absolute_normalized;
+
+ procedure Divide_absolute_big_small ( u: in Multi_int;
+ v: in Long_Block_type;
+ q: out Multi_int;
+ r: out Long_Block_type ) is
+ n: Long_Block_type;
+ Quotient_constraint_error: exception;
+ last_u_nz: constant Index_int:= u.last_used;
+ u_zero: constant Boolean:= u.zero;
+ -- in case u and q are the same variables
+ is_q_zero: Boolean:= True;
+ begin
+ if q.n < last_u_nz then raise Quotient_constraint_error; end if;
+ q.last_used:= 0;
+ q.neg:= False;
+ r:= 0;
+ if not u_zero then
+ for i in reverse 0 .. last_u_nz loop
+ n:= Long_Block_type(u.blk(i)) + Shift_Left(r, Block_type_bits);
+ r:= n mod v;
+ q.blk(i):= Block_type(n / v);
+ if q.blk(i)/= 0 and then is_q_zero then
+ is_q_zero:= False;
+ q.last_used:= i;
+ end if;
+ end loop;
+ q.zero:= is_q_zero;
+ end if;
+ end Divide_absolute_big_small;
+
+ procedure Solve_signs_for_Div_Rem (i1n,i2n: in Boolean; qn,rn: out Boolean) is
+ begin
+ -- Invariant: i1= i2*q+r on cherche (pos) = (pos)*(pos)+(pos)
+
+ if i1n and i2n then -- i1<0; i2<0 (-i1) = (-i2) * q + (-r)
+ qn:= False; -- Quotient > 0
+ -- rn:= True; -- Reste < 0
+ elsif i1n then -- i1<0; i2>0 (-i1) = i2 *(-q) + (-r)
+ qn:= True; -- Quotient < 0
+ -- rn:= True; -- Reste < 0
+ elsif i2n then -- i1>0; i2<0 i1 = (-i2) *(-q) + r
+ qn:= True; -- Quotient < 0
+ -- rn:= False; -- Reste > 0
+ else -- i1>0; i2>0 i1 = i2 * q + r
+ qn:= False; -- Quotient > 0
+ -- rn:= False; -- Reste > 0
+ end if;
+ -- on observe que... "(A rem B) has the sign of A " ARM 4.5.5
+ -- en effet on peut mettre:
+ rn:= i1n;
+ end Solve_signs_for_Div_Rem;
+
+ procedure Div_Rem (i1: in Multi_int; i2: in Basic_int;
+ q : out Multi_int; r: out Basic_int) is
+ i1_neg: constant Boolean:= i1.neg;
+ -- in case i1 and q are the same variables
+ rneg: Boolean;
+ lai2, lr: Long_Block_type;
+ begin
+ if Debug then Check_internal.Test(i1); end if;
+ if i2=0 then raise Division_by_zero; end if;
+
+ if i1.zero then -- 15-Feb-2002: 0/i2
+ q.zero:= True;
+ r:= 0;
+ return;
+ end if;
+
+ lai2:= Long_Block_type(abs i2);
+ Divide_absolute_big_small( i1, lai2, q, lr );
+ r:= Basic_int(lr);
+
+ Solve_signs_for_Div_Rem( i1_neg,i2<0, q.neg, rneg );
+ if rneg then r:= -r; end if;
+
+ end Div_Rem;
+
+ type Div_Rem_mode is (div_only, both);
+
+ generic
+ div_rem_output: Div_Rem_mode;
+ procedure Div_Rem_internal (i1,i2: in Multi_int; q,r: in out Multi_int);
+
+ procedure Div_Rem_internal (i1,i2: in Multi_int; q,r: in out Multi_int) is
+
+ -- Calculate u/v
+
+ procedure Divide_absolute ( u,v: in Multi_int;
+ q,r: in out Multi_int ) is
+ shift: Integer:= 0;
+ v1: Block_type:= v.blk(v.last_used);
+ v_zero, v1_zero: exception;
+ u_work: Multi_int(u.last_used+2);
+ use System;
+
+ procedure Normalization ( source: in Multi_int;
+ target: in out Multi_int ) is
+ carry: Block_type:= 0;
+ tl: constant Index_int:= target.last_used;
+ blk: Block_type;
+ begin
+ for i in 0 .. source.last_used loop
+ blk:= source.blk(i);
+ target.blk(i) := Shift_Left(blk, shift) + carry;
+ carry := Shift_Right(blk, Block_type_bits - shift);
+ end loop;
+ if source.last_used < tl then
+ target.blk(source.last_used+1):= carry;
+ end if;
+ for i in source.last_used+2 .. tl loop
+ target.blk(i):= 0;
+ end loop;
+ end Normalization;
+
+ procedure Unnormalization ( m: in out Multi_int) is
+ carry: Block_type:= 0;
+ blk: Block_type;
+ begin
+ for i in reverse 0 .. m.last_used loop
+ blk:= m.blk(i);
+ m.blk(i) := Shift_Right(blk, shift) + carry;
+ carry := Shift_Left(blk, Block_type_bits - shift);
+ end loop;
+ end Unnormalization;
+
+ begin -- Divide_absolute (multi u / multi v)
+
+ if Debug then
+ if v.zero then raise v_zero; end if;
+ if v1=0 then raise v1_zero; end if;
+ end if;
+
+ -- Calculate shift needed to normalize
+ u_work.last_used:= u_work.n;
+ u_work.zero:= False;
+ while v1 < 2**(Block_type_bits-1) loop
+ shift:= shift + 1;
+ v1:= v1 * 2;
+ end loop;
+ if shift = 0 then -- no shift needed
+ u_work.blk( 0..u.last_used ):= u.blk( 0..u.last_used );
+ u_work.blk( u.last_used+1 .. u_work.last_used):= (0,0);
+ -- Now, u is copied, so a Div_Rem(u, v, u, r) won't crash
+
+ if v'Address = q'Address then
+ declare
+ v_work: Multi_int(v.last_used);
+ begin
+ -- 23-Feb-2002: also copy v, in case of a Div_Rem(u, v, v, r)
+ v_work.blk( 0..v.last_used ):= v.blk( 0..v.last_used );
+ v_work.neg := v.neg;
+ v_work.zero := v.zero;
+ v_work.last_used:= v.last_used;
+ -- Now, u is copied, so a Div_Rem(u, v, v, r) won't crash
+ -- Ada.Text_IO.Put_Line("* divisor with copy");
+ Divide_absolute_normalized( u_work,v_work, q );
+ end;
+ else
+ -- Ada.Text_IO.Put_Line("* divisor without copy");
+ Divide_absolute_normalized( u_work,v, q );
+ end if;
+
+ else -- shift needed
+ declare
+ v_work: Multi_int(v.last_used);
+ begin
+ v_work.last_used:= v_work.n;
+ Normalization( u, u_work );
+ Normalization( v, v_work );
+ Reduce_last_nonzero( v_work );
+
+ Divide_absolute_normalized( u_work,v_work, q );
+ end;
+
+ if div_rem_output /= div_only then
+ Unnormalization( u_work );
+ end if;
+ end if;
+ q.neg:= False; -- check friendly
+ if div_rem_output /= div_only then
+ u_work.neg:= False; -- check friendly
+ Reduce_last_nonzero( u_work );
+ Fill( r, u_work );
+ end if;
+
+ end Divide_absolute;
+
+ l1: constant Index_int:= i1.last_used;
+ l2: constant Index_int:= i2.last_used;
+ rl: Long_Block_type;
+ begin -- Div_Rem_internal
+ if i2.zero then raise Division_by_zero; end if;
+
+ if i1.zero then -- 15-Feb-2002: 0/i2
+ q.zero:= True;
+ r.zero:= True;
+ return;
+ end if;
+
+ if q.n < l1 - l2 then
+ -- 17-Feb-2002
+ raise Quotient_undersized;
+ end if;
+
+ if div_rem_output /= div_only and then r.n < Max( l1, l2 ) then
+ -- 17-Feb-2002
+ raise Remainder_undersized;
+ end if;
+
+ if l2 = 0 then
+ if l1 = 0 then -- On a affaire a une ridicule division d'entiers
+ q.blk(0):= i1.blk(0) / i2.blk(0);
+ if div_rem_output /= div_only then
+ r.blk(0):= Block_type(
+ abs(
+ Long_Block_type_signed(i1.blk(0))
+ - Long_Block_type_signed(i2.blk(0))
+ * Long_Block_type_signed(q.blk(0))
+ )
+ );
+ end if;
+ q.zero:= q.blk(0) = 0;
+ q.last_used:= 0;
+ else -- multi / entier
+ Divide_absolute_big_small( i1, Long_Block_type(i2.blk(0)), q, rl );
+ if div_rem_output /= div_only then
+ r.blk(0):= Block_type(rl);
+ end if;
+ end if;
+ if div_rem_output /= div_only then
+ r.zero:= r.blk(0) = 0;
+ r.last_used:= 0;
+ end if;
+
+ else -- multi / multi
+
+ case Compare_absolute(i2 , i1) is
+
+ when greater =>
+ q.zero:= True; -- q:= 0;
+ q.last_used:= 0;
+ q.neg:= False;
+
+ if div_rem_output /= div_only then
+ Fill( r, i1 ); -- r:= i1, q:=0 car i1 = 0 * i2 (>i1 en v.abs) + r
+ end if;
+ return;
+
+ when equal =>
+ Fill( q, one ); -- Fill( q, Multi(1) );
+ r.zero:= True; -- Fill( r, Multi(0) );
+
+ when smaller => -- cas <<normal>>: diviseur < dividende
+
+ Divide_absolute( i1,i2, q,r );
+
+ end case;
+ end if;
+
+ Solve_signs_for_Div_Rem( i1.neg,i2.neg, q.neg,r.neg );
+ end Div_Rem_internal;
+
+ procedure Div_Rem_internal_div_only is
+ new Div_Rem_internal( div_rem_output => div_only );
+
+ procedure Div_Rem_internal_both is
+ new Div_Rem_internal( div_rem_output => both );
+
+ procedure Div_Rem_internal_both_export(i1,i2: in Multi_int; q,r: in out Multi_int)
+ renames Div_Rem_internal_both;
+
+ procedure Div_Rem (i1,i2: in Multi_int; q,r: out Multi_int) is
+ begin
+ if Debug then
+ declare
+ m1: constant Multi_int:= i1;
+ m2: constant Multi_int:= i2;
+ begin
+ Div_Rem_internal_both(m1,m2,q,r);
+ Check_internal.Check_Div_Rem(m1,m2,q,r);
+ end;
+ else
+ Div_Rem_internal_both(i1,i2,q,r);
+ end if;
+ end Div_Rem;
+
+ procedure Divide (i1,i2: in Multi_int; q: out Multi_int) is
+ begin
+ if Debug then
+ declare
+ m1: constant Multi_int:= i1;
+ m2: constant Multi_int:= i2;
+ r: Multi_int( Max( i1.last_used, i2.last_used) + 2 );
+ begin
+ Div_Rem_internal_both(m1,m2,q,r);
+ Check_internal.Check_Div_Rem(m1,m2,q,r);
+ end;
+ else
+ declare
+ r: Multi_int(0); -- Fake
+ begin
+ Div_Rem_internal_div_only(i1,i2,q,r);
+ end;
+ end if;
+ end Divide;
+
+ function "/" (i1,i2: Multi_int) return Multi_int is
+ q: Multi_int( Max( 0, i1.last_used - i2.last_used + 1) );
+ r: Multi_int( Max( i1.last_used, i2.last_used) + 2 );
+ begin
+ Div_Rem(i1,i2, q,r);
+ return q;
+ end "/";
+
+ function "/" (i1: Multi_int; i2: Basic_int) return Multi_int is
+ q: Multi_int(i1.last_used + 1);
+ r: Basic_int;
+ begin
+ Div_Rem(i1,i2, q,r);
+ return q;
+ end "/";
+
+ function "rem" (i1,i2: Multi_int) return Multi_int is
+ q: Multi_int(Max(0,i1.last_used - i2.last_used + 1));
+ r: Multi_int(Max(i1.last_used,i2.last_used) + 2);
+ begin
+ Div_Rem(i1,i2, q,r);
+ return r;
+ end "rem";
+
+ function "rem" (i1: Multi_int; i2: Basic_int) return Multi_int is
+ begin return i1 rem Multi(i2); end "rem";
+
+ function "rem" (i1: Multi_int; i2: Basic_int) return Basic_int is
+ q: Multi_int(i1.last_used + 1);
+ r: Basic_int;
+ begin
+ Div_Rem(i1,i2, q,r);
+ return r;
+ end "rem";
+
+ function "mod" (i1,i2: Multi_int) return Multi_int is
+ q: Multi_int(Max(0,i1.last_used - i2.last_used + 1));
+ r: Multi_int(Max(i1.last_used,i2.last_used) + 2);
+ begin
+ -- Ada RM, 4.5.5 Multiplying Operators
+ -- (8)
+ -- The signed integer modulus operator is defined such that
+ -- the result of A mod B has the sign of B and an absolute value
+ -- less than the absolute value of B; in addition, for some signed
+ -- integer value N, this result satisfies the relation:
+ -- (9) A = B*N + (A mod B)
+
+ Div_Rem(i1,i2, q,r);
+ if r.zero or else i2.neg = r.neg then -- (A rem B) est nul ou
+ return r; -- a le meme signe que B, donc (A mod B) = (A rem B)
+ else -- signe opposes
+ return i2+r; -- alors (B + (A rem B)) est le bon candidat
+ end if;
+ end "mod";
+
+ function "mod" (i1: Multi_int; i2: Basic_int) return Multi_int is
+ begin return i1 mod Multi(i2); end "mod";
+
+ function "mod" (i1: Multi_int; i2: Basic_int) return Basic_int is
+ r: constant Basic_int:= i1 rem i2;
+ begin
+ if r=0 or else (i2<0) = (r<0) then -- (A rem B) est nul ou
+ return r; -- a le meme signe que B, donc (A mod B) = (A rem B)
+ else -- signe opposes
+ return i2+r; -- alors (B + (A rem B)) est le bon candidat
+ end if;
+ end "mod";
+
+----- End of DIVISION part ------
+
+----- Begin of POWER part -------
+
+ procedure Power (i: Multi_int; n: Natural; ipn: out Multi_int) is
+ max_ipn_last: Index_int; -- 17-Feb-2002
+ begin
+ if i.zero then
+ if n=0 then
+ raise Zero_power_zero;
+ else
+ -- The 0**n = 0 case (17-Feb-2002).
+ ipn.zero:= True; -- 4-Nov-2006, was: Fill( ipn, Multi(0) );
+ return;
+ end if;
+ end if;
+
+ max_ipn_last:= ((1+i.last_used) * Index_int(n)-1)+2;
+ if ipn.n < max_ipn_last then
+ raise Result_undersized;
+ end if;
+
+ case n is
+ when 0 => Fill( ipn, one ); -- the i**0 = 1 case
+ when 1 => Fill( ipn, i); -- the i**1 = i case
+ when others =>
+ declare
+ nn: Natural:= n-1;
+ i0, ii: Multi_int( max_ipn_last );
+ begin
+ Fill(i0, i);
+ Fill(ii, i0 );
+
+ while nn > 0 loop
+ if nn mod 2 = 0 then -- x^(2 c) = (x^2) ^c
+ Mult(i0,i0, i0);
+ nn:= nn / 2;
+ else
+ Mult(i0,ii, ii);
+ nn:= nn - 1;
+ end if;
+ end loop;
+ Fill( ipn, ii);
+ end;
+ end case;
+ end Power;
+
+ function "**" (i: Multi_int; n: Natural) return Multi_int is
+ ipn: Multi_int( (1+i.last_used) * Index_int(n)+2 );
+ begin
+ Power(i,n,ipn);
+ return ipn;
+ end "**";
+
+ procedure Power (i: Multi_int; n: Multi_int; ipn: out Multi_int;
+ modulo: Multi_int) is
+ max_ipn_last: Index_int;
+ begin
+ if i.zero then
+ if n.zero then
+ raise Zero_power_zero;
+ else
+ -- The 0**n = 0 case (17-Feb-2002).
+ ipn.zero:= True; -- 4-Nov-2006, was: Fill( ipn, Multi(0) );
+ return;
+ end if;
+ end if;
+
+ if n.neg then
+ raise Power_negative;
+ end if;
+
+ if modulo.zero or else (i.neg or modulo.neg) then
+ raise Power_modulo_non_positive;
+ end if;
+
+ max_ipn_last:= 2*modulo.last_used+2;
+ if ipn.n < max_ipn_last then
+ raise Result_undersized;
+ end if;
+
+ if n.zero then
+ Fill( ipn, one ); -- the i**0 = 1 case
+ elsif Equal( n, one ) then
+ Fill( ipn, i); -- the i**1 = i case
+ else
+ declare
+ nn: Multi_int(n.n):= n;
+ i0, ii, dummy: Multi_int( max_ipn_last );
+ dummy_b: Basic_int;
+ begin
+ Subtract( nn, one, nn ); -- nn:= nn - 1;
+ Fill(i0, i);
+ Fill(ii, i0 );
+
+ while nn > 0 loop
+ if Even(nn) then -- x^(2 c) = (x^2) ^c
+ Mult(i0,i0, i0);
+ Div_Rem(nn, 2, nn, dummy_b); -- nn:= nn/2
+ Div_Rem(i0,modulo,dummy,i0); -- i0:= i0 mod modulo
+ else
+ Mult(i0,ii, ii);
+ Subtract( nn, one, nn ); -- nn:= nn - 1;
+ Div_Rem(ii,modulo,dummy,ii); -- ii:= ii mod modulo
+ end if;
+ end loop;
+ Fill( ipn, ii);
+ end;
+ end if;
+ end Power;
+
+----- End of POWER part ---------
+
+----- Comparisons
+
+ function Equal (i1,i2: Multi_int) return Boolean is
+ begin
+ if i1.zero and then i2.zero then
+ return True;
+ end if;
+
+ if i1.zero = i2.zero and then
+ i1.neg = i2.neg and then
+ i1.last_used = i2.last_used then
+ return i1.blk(0..i1.last_used) = i2.blk(0..i2.last_used);
+ else
+ return False;
+ end if;
+ end Equal;
+
+ function Equal (i1: Multi_int; i2:Basic_int) return Boolean is
+ begin
+ return Equal( i1, Multi(i2) );
+ end Equal;
+
+ function ">" (i1,i2: Multi_int) return Boolean is
+ begin
+ -- (1) Cas \'evident o\`u: i1 <= i2
+ if (i1.zero or i1.neg) and then -- i1 <= 0 et
+ (i2.zero or not i2.neg) then -- i2 >= 0
+ return False;
+ end if;
+
+ -- (2.1) Cas \'evident o\`u: i1 > i2
+ if ((not i1.zero) and not i1.neg) and then -- i1 > 0 et
+ (i2.zero or i2.neg) then -- i2 <= 0
+ return True;
+ end if;
+
+ -- (2.2) Cas \'evident o\`u: i1 > i2
+ if (i1.zero or not i1.neg) and then -- i1 >= 0 et
+ ((not i2.zero) and i2.neg) then -- i2 < 0
+ return True;
+ end if;
+
+ -- Cas faciles resolus:
+ -- i1 > i2 - 0 +
+ -------------------
+ -- - # F F
+ -- 0 T F F
+ -- + T T #
+
+ -- On a les cas avec "#", o\`u i1 et i2 ont le meme signe
+
+ if i1.neg then
+ return not (Compare_absolute (i1,i2) = greater);
+ else
+ return (Compare_absolute (i1,i2) = greater);
+ end if;
+
+ end ">";
+
+ function ">" (i1: Multi_int; i2:Basic_int) return Boolean is
+ begin
+ return i1 > Multi(i2);
+ end ">";
+
+ function "<" (i1,i2: Multi_int) return Boolean is
+ begin return i2>i1; end "<";
+
+ function "<" (i1: Multi_int; i2:Basic_int) return Boolean is
+ begin
+ return i1 < Multi(i2);
+ end "<";
+
+ function ">=" (i1,i2: Multi_int) return Boolean is
+ begin return not (i2>i1); end ">=";
+
+ function ">=" (i1: Multi_int; i2:Basic_int) return Boolean is
+ begin
+ return i1 >= Multi(i2);
+ end ">=";
+
+ function "<=" (i1,i2: Multi_int) return Boolean is
+ begin return not (i1>i2); end "<=";
+
+ function "<=" (i1: Multi_int; i2:Basic_int) return Boolean is
+ begin
+ return i1 <= Multi(i2);
+ end "<=";
+
+end Multi_precision_integers;
diff --git a/src/multi_precision_integers.ads b/src/multi_precision_integers.ads new file mode 100644 index 0000000..7c8406a --- /dev/null +++ b/src/multi_precision_integers.ads @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------
+-- File: multi_precision_integers.ads
+--
+-- Description: Multiple precision integers package
+--
+-- Date/version: Aug-2007: - No more generics (Long_Block_type,
+-- Block_type,... always the largest possible
+-- idea: J.C.)
+-- - Fixed Basic(...) (based on J.C.'s remarks)
+-- Nov-2006: - unsigned types for blocks
+-- - a block uses 2 bits more
+-- - Ada95+ only
+-- Mar-2002: Bugs fixed related to zero field, division
+-- Nov-1999: - procedures (no stack, less copies !)
+-- - new data structure
+-- Dec-1996: First version (operators only)
+--
+-- Author: G. de Montmollin, Univ. Neuchatel
+--
+-- Thanks to: Duncan Sands, Univ. Paris-Sud, CNRS
+-- Jeffrey R. Carter
+--
+-- Tested on: Intel 586 (32 bit) - Windows 98, NT4+ - GNAT 3.13p+
+-- Intel 586 (32 bit) - Windows 98, NT4+ - ObjectAda 7.2.1+
+-- Alpha-AXP (64 bit) - OpenVMS 7.1 - Compaq Ada
+--
+-- Division algorithm adaptated from BigInt 1.0 library,
+-- by Stephen Adams, that refers to
+-- D. E. Knuth, the Art of computer programming
+-- volume 2, "Seminumerical Algorithms"
+-- section 4.3.1, "Multiple-Precision Arithmetic"
+--
+------------------------------------------------------------------------------
+
+with System;
+
+package Multi_precision_integers is
+
+ -- Integers for array indexing --
+
+ subtype Index_int is Integer;
+
+ -- THE multi-precision integer type --
+
+ type Multi_int (n: Index_int) is private;
+
+ -- Integer type for small values --
+
+ subtype Basic_int is Integer; -- the "normal" signed integer
+
+ ----------------------------------------------------------------
+ -- Debug mode: checks results of arithmetic operations and --
+ -- Multi_int variables' integrity. --
+ -- CAUTION: Debug = True reduces monstruously the performance --
+ ----------------------------------------------------------------
+
+ Debug : constant Boolean:= False;
+
+ ---------------------------------------------
+ ----- Informations, conversions, filling ----
+ ---------------------------------------------
+
+ -- Convert Basic_int to Multi_int
+ function Multi (small: Basic_int) return Multi_int;
+
+ -- Convert Multi_int to Basic_int (when possible, else: Cannot_fit raised)
+ function Basic (large: Multi_int) return Basic_int;
+
+ -- Fill an Multi_int of greater array dimension with a smaller one
+ procedure Fill (what: out Multi_int; with_smaller: Multi_int);
+ procedure Fill (what: out Multi_int; with_basic: Basic_int);
+
+ -- Comparisons
+ function Equal (i1, i2: Multi_int) return Boolean;
+ function Equal (i1 : Multi_int; i2:Basic_int) return Boolean;
+ function ">" (i1, i2: Multi_int) return Boolean;
+ function ">" (i1 : Multi_int; i2:Basic_int) return Boolean;
+ function "<" (i1, i2: Multi_int) return Boolean;
+ function "<" (i1 : Multi_int; i2:Basic_int) return Boolean;
+ function ">=" (i1, i2: Multi_int) return Boolean;
+ function ">=" (i1 : Multi_int; i2:Basic_int) return Boolean;
+ function "<=" (i1, i2: Multi_int) return Boolean;
+ function "<=" (i1 : Multi_int; i2:Basic_int) return Boolean;
+
+ -- Other informations
+ function Bits_per_block return Positive;
+
+ ---------------------------------------------------------------------------
+ -------- Arithmetic operators. ----------
+ -------- For speed, the "procedure" variants should be preferred ----------
+ ---------------------------------------------------------------------------
+
+ ---------------------------
+ ----- Unary operators -----
+ ---------------------------
+
+ procedure Opp (i: in out Multi_int);
+ function "+" (i : Multi_int) return Multi_int;
+ function "-" (i : Multi_int) return Multi_int;
+
+ procedure Abso (i: in out Multi_int);
+ function "ABS" (i : Multi_int) return Multi_int;
+
+ function Sign (i: Multi_int) return Basic_int;
+ function Even (i: Multi_int) return Boolean;
+ function Odd (i : Multi_int) return Boolean;
+
+ ----------------------------
+ ----- Binary operators -----
+ ----------------------------
+
+ ---------------------------
+ -- Addition, subtraction --
+ ---------------------------
+
+ procedure Add (i1,i2: in Multi_int; i3: in out Multi_int);
+
+ function "+" (i1, i2: Multi_int) return Multi_int;
+ function "+" (i1 : Multi_int; i2: Basic_int) return Multi_int;
+ function "+" (i1 : Basic_int; i2: Multi_int) return Multi_int;
+
+ procedure Sub (i1, i2: in Multi_int; i3: in out Multi_int);
+ procedure Subtract (i1,i2: in Multi_int; i3: in out Multi_int)
+ renames Sub;
+
+ function "-" (i1, i2: Multi_int) return Multi_int;
+ function "-" (i1 : Multi_int; i2: Basic_int) return Multi_int;
+ function "-" (i1 : Basic_int; i2: Multi_int) return Multi_int;
+
+ --------------------
+ -- Multiplication --
+ --------------------
+
+ procedure Multiply (i1,i2: in Multi_int; i3: in out Multi_int);
+ procedure Mult (i1, i2: in Multi_int; i3: in out Multi_int)
+ renames Multiply;
+
+ procedure Multiply (i1: in Multi_int; i2: Basic_int; i3: in out Multi_int);
+ procedure Mult (i1 : in Multi_int; i2: Basic_int; i3: in out Multi_int)
+ renames Multiply;
+
+ function "*" (i1, i2: Multi_int) return Multi_int;
+ function "*" (i1 : Multi_int; i2: Basic_int) return Multi_int;
+ function "*" (i1 : Basic_int; i2: Multi_int) return Multi_int;
+
+ -------------------------
+ -- Division, Remainder --
+ -------------------------
+
+ procedure Div_Rem (i1 : in Multi_int; i2: in Basic_int;
+ q : out Multi_int; r : out Basic_int);
+ procedure Div_Rem (i1, i2: in Multi_int; q,r: out Multi_int);
+
+ procedure Divide (i1, i2: in Multi_int; q: out Multi_int);
+
+ function "/" (i1, i2: Multi_int) return Multi_int;
+ function "/" (i1 : Multi_int; i2: Basic_int) return Multi_int;
+ function "Rem" (i1, i2: Multi_int) return Multi_int;
+ function "Rem" (i1 : Multi_int; i2: Basic_int) return Multi_int;
+ function "Rem" (i1 : Multi_int; i2: Basic_int) return Basic_int;
+ function "Mod" (i1, i2: Multi_int) return Multi_int;
+ function "Mod" (i1 : Multi_int; i2: Basic_int) return Multi_int;
+ function "Mod" (i1 : Multi_int; i2: Basic_int) return Basic_int;
+
+ -----------
+ -- Power --
+ -----------
+
+ procedure Power (i : Multi_int; n: Natural; ipn: out Multi_int);
+ function "**" (i : Multi_int; n: Natural) return Multi_int;
+ -- + 26-Mar-2002 :
+ procedure Power (i : Multi_int; n: Multi_int; ipn: out Multi_int;
+ modulo : Multi_int);
+
+ Cannot_fit, Empty_multi_int : exception;
+
+ Array_too_small : exception;
+
+ Result_undersized,
+ Quotient_undersized,
+ Remainder_undersized : exception;
+
+ Division_by_zero : exception;
+
+ Zero_power_zero, Power_negative : exception;
+ Power_modulo_non_positive : exception;
+
+private
+
+ --> Long_Block_type is used for + and * of blocks.
+ -- It is by design
+ -- a/ the largest possible modular integer, and
+ -- b/ twice the size of Block_type defined below.
+ -- With the double of bits (2n) one can store m**2 + 2m without overflow
+ -- where m = 2**n - 1 is the largest value possible on n bits.
+ type Long_Block_type is mod System.Max_Binary_Modulus;
+
+ --> Same size as Long_Block_type, but signed:
+ type Long_Block_type_signed is
+ range -2**(Long_Block_type'Size-1)..2**(Long_Block_type'Size-1)-1;
+
+ --> Block_type: unsigned integer used to store a chunk of a Multi_int.
+ type Block_type is mod 2 ** (Long_Block_type'Size / 2);
+
+ Block_type_bits: constant:= Block_type'Size;
+
+ cardblock: constant:= 2 ** Block_type_bits;
+ -- Number of possible values
+ maxblock: constant:= Block_type'Last;
+ -- NB: GNAT (2006) optimizes out correctly the Block_type(l and maxblock_long)
+ -- to Block_type(l), the latter form being caught when range checks are on.
+
+ type Block_array is array( Index_int range <> ) of Block_type;
+ -- 2006: was "of Basic_int" for obscure reasons...
+
+ type Multi_int(n: Index_int) is record
+ blk: Block_array( 0..n ); -- the n blocks with ABSOLUTE value
+ neg: Boolean; -- negative flag
+ zero: Boolean:=True; -- zero flag (supercedes the other fields)
+ last_used: Index_int; -- the others blocks are supposed 0
+ end record;
+
+ -- NB the `zero' field supercedes EVERY other information (last_used, neg)
+
+ ----------------------------------------------------------------------------
+ -- Format of type Multi_int.blk: ( i_0, i_1, ..., i_k, *, ..., * ) --
+ -- i_0..i_k are >=0 ; others (*) are treated as 0 --
+ ----------------------------------------------------------------------------
+
+ -- Some internal procedures use by check:
+
+ procedure Multiply_internal_copy_export(i1,i2: in Multi_int; i3: in out Multi_int);
+
+ procedure Div_Rem_internal_both_export(i1,i2: in Multi_int; q,r: in out Multi_int);
+
+end Multi_precision_integers;
diff --git a/src/rationals.adb b/src/rationals.adb index 62fe9b9..bc54106 100644 --- a/src/rationals.adb +++ b/src/rationals.adb @@ -1,28 +1,34 @@ with Ada.Strings.Fixed; +with Multi_Precision_Integers.IO; +use Multi_Precision_Integers.IO; package body Rationals is function Reduce - (Numerator, Denominator : in Big_Unsigned) + (Numerator, Denominator : in Multi_Int) return Fraction is - A : Big_Unsigned := Numerator; - B : Big_Unsigned := Denominator; - Temp : Big_Unsigned; + A, B, Temp : Multi_Int (M_Size); + Ret_N, Ret_D : Multi_Int (M_Size); begin + Fill (A, Numerator); + Fill (B, Denominator); + -- Euclid's algorithm loop Temp := A; A := B; - B := Temp mod B; - exit when B = 0; + Fill (B, Temp mod B); + exit when Equal (B, 0); end loop; - return (Num => Numerator / A, - Den => Denominator / A); + + Fill (Ret_N, Numerator / A); + Fill (Ret_D, Denominator / A); + return (Num => Ret_N, Den => Ret_D); end Reduce; @@ -43,7 +49,7 @@ package body Rationals is return Fraction is begin return Reduce - (Left.Num + Left.Den * Utils.To_Big_Unsigned (Word (Right)), + (Left.Num + Left.Den * Multi (Right), Left.Den); end "+"; @@ -53,7 +59,7 @@ package body Rationals is return Fraction is begin return Reduce - (Utils.To_Big_Unsigned (Word (Left)) * Right.Den + Right.Num, + (Multi (Left) * Right.Den + Right.Num, Right.Den); end "+"; @@ -75,7 +81,7 @@ package body Rationals is return Fraction is begin return Reduce - (Left.Num - Left.Den * Utils.To_Big_Unsigned (Word (Right)), + (Left.Num - Left.Den * Multi (Right), Left.Den); end "-"; @@ -85,7 +91,7 @@ package body Rationals is return Fraction is begin return Reduce - (Utils.To_Big_Unsigned (Word (Left)) * Right.Den - Right.Num, + (Multi (Left) * Right.Den - Right.Num, Right.Den); end "-"; @@ -117,7 +123,7 @@ package body Rationals is return Fraction is begin return Reduce - (Left.Num * Utils.To_Big_Unsigned (Word (Right)), + (Left.Num * Multi (Right), Left.Den); end "*"; @@ -127,7 +133,7 @@ package body Rationals is return Fraction is begin return Reduce - (Utils.To_Big_Unsigned (Word (Left)) * Right.Num, + (Multi (Left) * Right.Num, Right.Den); end "*"; @@ -150,7 +156,7 @@ package body Rationals is begin return Reduce (Left.Num, - Left.Den * Utils.To_Big_Unsigned (Word (Right))); + Left.Den * Multi (Right)); end "/"; function "/" @@ -160,14 +166,14 @@ package body Rationals is begin return Reduce (Right.Num, - Utils.To_Big_Unsigned (Word (Left)) * Right.Den); + Multi (Left) * Right.Den); end "/"; function "/" (Left, Right : in Integer) return Fraction is begin - return Reduce (Utils.To_Big_Unsigned (Word (Left)), Utils.To_Big_Unsigned (Word (Right))); + return Reduce (Multi (Left), Multi (Right)); end "/"; @@ -177,8 +183,8 @@ package body Rationals is (Left, Right : in Fraction) return Boolean is begin - return Left.Num = Right.Num and - Left.Den = Right.Den; + return Equal (Left.Num, Right.Num) and + Equal (Left.Den, Right.Den); end "="; function "=" @@ -186,7 +192,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num = Utils.To_Big_Unsigned (Word (Right)) and Left.Den = 1; + return Equal (Left.Num, Right) and Equal (Left.Den, 1); end "="; function "=" @@ -194,7 +200,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) = Right.Num and Right.Den = 1; + return Equal (Right.Num, Left) and Equal (Right.Den, 1); end "="; @@ -212,7 +218,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num <= Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num <= Left.Den * Multi (Right); end "<="; function "<=" @@ -220,7 +226,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den <= Right.Num; + return Multi (Left) * Right.Den <= Right.Num; end "<="; @@ -238,7 +244,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num < Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num < Left.Den * Multi (Right); end "<"; function "<" @@ -246,7 +252,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den < Right.Num; + return Multi (Left) * Right.Den < Right.Num; end "<"; @@ -264,7 +270,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num >= Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num >= Left.Den * Multi (Right); end ">="; function ">=" @@ -272,7 +278,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den >= Right.Num; + return Multi (Left) * Right.Den >= Right.Num; end ">="; @@ -290,7 +296,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num > Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num > Left.Den * Multi (Right); end ">"; function ">" @@ -298,7 +304,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den > Right.Num; + return Multi (Left) * Right.Den > Right.Num; end ">"; @@ -308,31 +314,31 @@ package body Rationals is (Item : in Fraction) return Integer is begin - return Integer (Utils.To_Words (Item.Num)(1)); + return Basic (Item.Num); end Numerator; function Denominator (Item : in Fraction) return Integer is begin - return Integer (Utils.To_Words (Item.Den)(1)); + return Basic (Item.Den); end Denominator; function Floor (Item : in Fraction) return Integer is begin - return Integer (Utils.To_Words (Item.Num / Item.Den)(0)); + return Basic (Item.Num / Item.Den); end Floor; function Ceiling (Item : in Fraction) return Integer is begin - if Item.Num mod Item.Den = 0 then - return Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + if Equal (Item.Num mod Item.Den, 0) then + return Basic (Item.Num / Item.Den); else - return 1 + Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + return 1 + Basic (Item.Num / Item.Den); end if; end Ceiling; @@ -341,9 +347,9 @@ package body Rationals is return Integer is begin if Item.Num mod Item.Den >= Item.Den / 2 then - return 1 + Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + return 1 + Basic (Item.Num / Item.Den); else - return Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + return Basic (Item.Num / Item.Den); end if; end Round; @@ -354,8 +360,7 @@ package body Rationals is (Item : in Fraction) return String is begin - return Utils.To_String (Item.Num) & '/' & - Utils.To_String (Item.Den); + return Str (Item.Num) & '/' & Str (Item.Den); end Image; function Value @@ -369,7 +374,7 @@ package body Rationals is S := Index (Item, "/"); A := Integer'Value (Item (Item'First .. S - 1)); B := Integer'Value (Item (S + 1 .. Item'Last)); - return Reduce (Utils.To_Big_Unsigned (Word (A)), Utils.To_Big_Unsigned (Word (B))); + return Reduce (Multi (A), Multi (B)); end Value; diff --git a/src/rationals.ads b/src/rationals.ads index dfa5897..1f3de5f 100644 --- a/src/rationals.ads +++ b/src/rationals.ads @@ -1,6 +1,6 @@ -private with Crypto.Types.Big_Numbers; +private with Multi_Precision_Integers; package Rationals is @@ -210,14 +210,15 @@ package Rationals is private - package Bignum is new Crypto.Types.Big_Numbers (Size => 128); - use Crypto.Types; - use Bignum; + use Multi_Precision_Integers; + + + M_Size : constant Basic_Int := 4; type Fraction is record - Num : Big_Unsigned := Big_Unsigned_Zero; - Den : Big_Unsigned := Big_Unsigned_One; + Num : Multi_Int (M_Size); + Den : Multi_Int (M_Size); end record; diff --git a/src/stv.adb b/src/stv.adb index 4f8ef5a..10020e6 100644 --- a/src/stv.adb +++ b/src/stv.adb @@ -255,12 +255,12 @@ begin Finish_Time := Simple_Time.Now; Log_Msg := SU.To_Unbounded_String ("Finished election count at " & Simple_Time.To_String (Finish_Time) & ASCII.LF & - Duration'Image (Finish_Time - Start_Time) & " seconds elapsed." & ASCII.LF); + Duration'Image (Finish_Time - Start_Time) & " seconds elapsed."); Open (Log_File, Append_File, SU.To_String (Main_Log)); Put_Line (Log_File, SU.To_String (Log_Msg)); Close (Log_File); if Verbose then - Put_Line (Standard_Error, SU.To_String (Log_Msg)); + Put_Line (Standard_Error, ASCII.LF & SU.To_String (Log_Msg)); end if; |