Parent Directory | Revision Log | Patch
revision 68 by dashley, Mon Oct 31 16:18:20 2016 UTC | revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC | |
---|---|---|
# | Line 1 | Line 1 |
1 | //$Header$ | //$Header$ |
2 | //------------------------------------------------------------------------------------------------- | //------------------------------------------------------------------------------------------------- |
3 | //This file is part of "David T. Ashley's Shared Source Code", a set of shared components | //This file is part of "David T. Ashley's Shared Source Code", a set of shared components |
4 | //integrated into many of David T. Ashley's projects. | //integrated into many of David T. Ashley's projects. |
5 | //------------------------------------------------------------------------------------------------- | //------------------------------------------------------------------------------------------------- |
6 | //This source code and any program in which it is compiled/used is provided under the MIT License, | //This source code and any program in which it is compiled/used is provided under the MIT License, |
7 | //reproduced below. | //reproduced below. |
8 | //------------------------------------------------------------------------------------------------- | //------------------------------------------------------------------------------------------------- |
9 | //Permission is hereby granted, free of charge, to any person obtaining a copy of | //Permission is hereby granted, free of charge, to any person obtaining a copy of |
10 | //this software and associated documentation files(the "Software"), to deal in the | //this software and associated documentation files(the "Software"), to deal in the |
11 | //Software without restriction, including without limitation the rights to use, | //Software without restriction, including without limitation the rights to use, |
12 | //copy, modify, merge, publish, distribute, sublicense, and / or sell copies of the | //copy, modify, merge, publish, distribute, sublicense, and / or sell copies of the |
13 | //Software, and to permit persons to whom the Software is furnished to do so, | //Software, and to permit persons to whom the Software is furnished to do so, |
14 | //subject to the following conditions : | //subject to the following conditions : |
15 | // | // |
16 | //The above copyright notice and this permission notice shall be included in all | //The above copyright notice and this permission notice shall be included in all |
17 | //copies or substantial portions of the Software. | //copies or substantial portions of the Software. |
18 | // | // |
19 | //THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | //THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR |
20 | //IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, | //IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, |
21 | //FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE | //FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE |
22 | //AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER | //AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER |
23 | //LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | //LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, |
24 | //OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | //OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE |
25 | //SOFTWARE. | //SOFTWARE. |
26 | //------------------------------------------------------------------------------------------------- | //------------------------------------------------------------------------------------------------- |
27 | #define MODULE_ARBLENINTS | #define MODULE_ARBLENINTS |
28 | ||
29 | #include <assert.h> | #include <assert.h> |
30 | #include <string.h> | #include <string.h> |
31 | ||
32 | #include "tcl.h" | #include "tcl.h" |
33 | #include "tcldecls.h" | #include "tcldecls.h" |
34 | ||
35 | #include "arblenints.h" | #include "arblenints.h" |
36 | #include "bstrfunc.h" | #include "bstrfunc.h" |
37 | #include "extninit.h" | #include "extninit.h" |
38 | #include "gmp_ints.h" | #include "gmp_ints.h" |
39 | #include "gmp_rats.h" | #include "gmp_rats.h" |
40 | #include "gmp_ralg.h" | #include "gmp_ralg.h" |
41 | #include "intfunc.h" | #include "intfunc.h" |
42 | #include "tclalloc.h" | #include "tclalloc.h" |
43 | ||
44 | ||
45 | //Handles the "cfbrapab" subextension. | //Handles the "cfbrapab" subextension. |
46 | //08/16/01: Visual inspection OK. | //08/16/01: Visual inspection OK. |
47 | static | static |
48 | int ARBLENINTS_cfbrapab_handler(ClientData dummy, | int ARBLENINTS_cfbrapab_handler(ClientData dummy, |
49 | Tcl_Interp *interp, | Tcl_Interp *interp, |
50 | int objc, | int objc, |
51 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
52 | { | { |
53 | Tcl_Obj *rv; | Tcl_Obj *rv; |
54 | ||
55 | //We must have at least two additional arguments | //We must have at least two additional arguments |
56 | //to this extension. | //to this extension. |
57 | if (objc < 4) | if (objc < 4) |
58 | { | { |
59 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
60 | 2, | 2, |
61 | objv, | objv, |
62 | "srn uint_kmax ?uint_hmax? ?options?"); | "srn uint_kmax ?uint_hmax? ?options?"); |
63 | return(TCL_ERROR); | return(TCL_ERROR); |
64 | } | } |
65 | else | else |
66 | { | { |
67 | char *input_arg; | char *input_arg; |
68 | int failure, first_dashed_parameter; | int failure, first_dashed_parameter; |
69 | char *string_result; | char *string_result; |
70 | int string_result_n_allocd; | int string_result_n_allocd; |
71 | int chars_reqd; | int chars_reqd; |
72 | int i; | int i; |
73 | int pred_option_specified = 0; | int pred_option_specified = 0; |
74 | int succ_option_specified = 0; | int succ_option_specified = 0; |
75 | int neversmaller_option_specified = 0; | int neversmaller_option_specified = 0; |
76 | int neverlarger_option_specified = 0; | int neverlarger_option_specified = 0; |
77 | int n_option_specified = 0; | int n_option_specified = 0; |
78 | unsigned n = 0; | unsigned n = 0; |
79 | ||
80 | GMP_RATS_mpq_struct q_rn; | GMP_RATS_mpq_struct q_rn; |
81 | GMP_INTS_mpz_struct z_kmax; | GMP_INTS_mpz_struct z_kmax; |
82 | GMP_INTS_mpz_struct z_hmax; | GMP_INTS_mpz_struct z_hmax; |
83 | ||
84 | //Allocate dynamic memory. | //Allocate dynamic memory. |
85 | GMP_RATS_mpq_init(&q_rn); | GMP_RATS_mpq_init(&q_rn); |
86 | GMP_INTS_mpz_init(&z_kmax); | GMP_INTS_mpz_init(&z_kmax); |
87 | GMP_INTS_mpz_init(&z_hmax); | GMP_INTS_mpz_init(&z_hmax); |
88 | ||
89 | //Grab a pointer to the string representation of | //Grab a pointer to the string representation of |
90 | //the first input argument. The storage does not belong to us. | //the first input argument. The storage does not belong to us. |
91 | input_arg = Tcl_GetString(objv[2]); | input_arg = Tcl_GetString(objv[2]); |
92 | assert(input_arg != NULL); | assert(input_arg != NULL); |
93 | ||
94 | //Try to parse our first input string as a rational number. | //Try to parse our first input string as a rational number. |
95 | //If we are not successful in this, must abort. | //If we are not successful in this, must abort. |
96 | GMP_RATS_mpq_set_all_format_rat_num(input_arg, | GMP_RATS_mpq_set_all_format_rat_num(input_arg, |
97 | &failure, | &failure, |
98 | &q_rn); | &q_rn); |
99 | ||
100 | if (failure) | if (failure) |
101 | { | { |
102 | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); |
103 | Tcl_AppendToObj(rv, input_arg, -1); | Tcl_AppendToObj(rv, input_arg, -1); |
104 | ||
105 | Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1); |
106 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
107 | ||
108 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
109 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
110 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
111 | ||
112 | return(TCL_ERROR); | return(TCL_ERROR); |
113 | } | } |
114 | ||
115 | //Try to parse our next argument as an integer, which | //Try to parse our next argument as an integer, which |
116 | //will be KMAX. This must be specified. | //will be KMAX. This must be specified. |
117 | // | // |
118 | //Get string pointer. Storage does not belong to us. | //Get string pointer. Storage does not belong to us. |
119 | input_arg = Tcl_GetString(objv[3]); | input_arg = Tcl_GetString(objv[3]); |
120 | assert(input_arg != NULL); | assert(input_arg != NULL); |
121 | ||
122 | //Try to convert KMAX to an integer. Fatal if an error, | //Try to convert KMAX to an integer. Fatal if an error, |
123 | //and fatal if the argument is zero or negative. | //and fatal if the argument is zero or negative. |
124 | GMP_INTS_mpz_set_general_int(&z_kmax, &failure, input_arg); | GMP_INTS_mpz_set_general_int(&z_kmax, &failure, input_arg); |
125 | ||
126 | //If there was a parse failure or if the integer is zero | //If there was a parse failure or if the integer is zero |
127 | //or negative, must flag error. | //or negative, must flag error. |
128 | if (failure || GMP_INTS_mpz_is_neg(&z_kmax) || GMP_INTS_mpz_is_zero(&z_kmax)) | if (failure || GMP_INTS_mpz_is_neg(&z_kmax) || GMP_INTS_mpz_is_zero(&z_kmax)) |
129 | { | { |
130 | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); |
131 | Tcl_AppendToObj(rv, input_arg, -1); | Tcl_AppendToObj(rv, input_arg, -1); |
132 | Tcl_AppendToObj(rv, "\" is not a recognized positive integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized positive integer.", -1); |
133 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
134 | ||
135 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
136 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
137 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
138 | ||
139 | return(TCL_ERROR); | return(TCL_ERROR); |
140 | } | } |
141 | ||
142 | //We need to look for HMAX as the next parameter, if it exists. | //We need to look for HMAX as the next parameter, if it exists. |
143 | //The way we will figure this out is by whether the | //The way we will figure this out is by whether the |
144 | //parameter begins with a "-" or not. | //parameter begins with a "-" or not. |
145 | if (objc >= 5) | if (objc >= 5) |
146 | { | { |
147 | input_arg = Tcl_GetString(objv[4]); | input_arg = Tcl_GetString(objv[4]); |
148 | assert(input_arg != NULL); | assert(input_arg != NULL); |
149 | ||
150 | if (input_arg[0] == '-') | if (input_arg[0] == '-') |
151 | { | { |
152 | first_dashed_parameter = 4; | first_dashed_parameter = 4; |
153 | } | } |
154 | else | else |
155 | { | { |
156 | first_dashed_parameter = 5; | first_dashed_parameter = 5; |
157 | } | } |
158 | } | } |
159 | else | else |
160 | { | { |
161 | first_dashed_parameter = 4; | first_dashed_parameter = 4; |
162 | } | } |
163 | ||
164 | //If there is another parameter and it | //If there is another parameter and it |
165 | //doesn't begin with a dash, try to parse | //doesn't begin with a dash, try to parse |
166 | //it as HMAX. We don't explicitly record whether | //it as HMAX. We don't explicitly record whether |
167 | //HMAX is specified, because zero is a signal | //HMAX is specified, because zero is a signal |
168 | //when calculating Farey neighbors that HMAX isn't | //when calculating Farey neighbors that HMAX isn't |
169 | //to be considered. | //to be considered. |
170 | if ((objc >= 5) && (first_dashed_parameter == 5)) | if ((objc >= 5) && (first_dashed_parameter == 5)) |
171 | { | { |
172 | //Get string pointer. Storage does not belong to us. | //Get string pointer. Storage does not belong to us. |
173 | input_arg = Tcl_GetString(objv[4]); | input_arg = Tcl_GetString(objv[4]); |
174 | assert(input_arg != NULL); | assert(input_arg != NULL); |
175 | ||
176 | //Try to convert HMAX to an integer. Fatal if an error, | //Try to convert HMAX to an integer. Fatal if an error, |
177 | //and fatal if the argument is zero or negative. | //and fatal if the argument is zero or negative. |
178 | GMP_INTS_mpz_set_general_int(&z_hmax, &failure, input_arg); | GMP_INTS_mpz_set_general_int(&z_hmax, &failure, input_arg); |
179 | ||
180 | //If there was a parse failure or if the integer is zero | //If there was a parse failure or if the integer is zero |
181 | //or negative, must flag error. | //or negative, must flag error. |
182 | if (failure || GMP_INTS_mpz_is_neg(&z_hmax) || GMP_INTS_mpz_is_zero(&z_hmax)) | if (failure || GMP_INTS_mpz_is_neg(&z_hmax) || GMP_INTS_mpz_is_zero(&z_hmax)) |
183 | { | { |
184 | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); |
185 | Tcl_AppendToObj(rv, input_arg, -1); | Tcl_AppendToObj(rv, input_arg, -1); |
186 | Tcl_AppendToObj(rv, "\" is not a recognized positive integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized positive integer.", -1); |
187 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
188 | ||
189 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
190 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
191 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
192 | ||
193 | return(TCL_ERROR); | return(TCL_ERROR); |
194 | } | } |
195 | } | } |
196 | ||
197 | //Process all of the dashed command-line arguments. | //Process all of the dashed command-line arguments. |
198 | //This involves iterating through all of the | //This involves iterating through all of the |
199 | //parameters and processing them. | //parameters and processing them. |
200 | for (i=first_dashed_parameter; i<objc; i++) | for (i=first_dashed_parameter; i<objc; i++) |
201 | { | { |
202 | input_arg = Tcl_GetString(objv[i]); | input_arg = Tcl_GetString(objv[i]); |
203 | assert(input_arg != NULL); | assert(input_arg != NULL); |
204 | ||
205 | if (!strcmp("-pred", input_arg)) | if (!strcmp("-pred", input_arg)) |
206 | { | { |
207 | pred_option_specified = 1; | pred_option_specified = 1; |
208 | } | } |
209 | else if (!strcmp("-succ", input_arg)) | else if (!strcmp("-succ", input_arg)) |
210 | { | { |
211 | succ_option_specified = 1; | succ_option_specified = 1; |
212 | } | } |
213 | else if (!strcmp("-neversmaller", input_arg)) | else if (!strcmp("-neversmaller", input_arg)) |
214 | { | { |
215 | neversmaller_option_specified = 1; | neversmaller_option_specified = 1; |
216 | } | } |
217 | else if (!strcmp("-neverlarger", input_arg)) | else if (!strcmp("-neverlarger", input_arg)) |
218 | { | { |
219 | neverlarger_option_specified = 1; | neverlarger_option_specified = 1; |
220 | } | } |
221 | else if (!strcmp("-n", input_arg)) | else if (!strcmp("-n", input_arg)) |
222 | { | { |
223 | n_option_specified = 1; | n_option_specified = 1; |
224 | ||
225 | //If -n was specified, there must be a following | //If -n was specified, there must be a following |
226 | //parameter which supplies the integer. First | //parameter which supplies the integer. First |
227 | //check for existence of an additional parameter. | //check for existence of an additional parameter. |
228 | if (i >= (objc - 1)) | if (i >= (objc - 1)) |
229 | { | { |
230 | rv = Tcl_NewStringObj("arbint cfbrapab: -n option specified without following integer.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: -n option specified without following integer.", -1); |
231 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
232 | ||
233 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
234 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
235 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
236 | ||
237 | return(TCL_ERROR); | return(TCL_ERROR); |
238 | } | } |
239 | ||
240 | //We have at least one additional parameter. Try | //We have at least one additional parameter. Try |
241 | //to parse out the next parameter as the integer | //to parse out the next parameter as the integer |
242 | //we need for n. | //we need for n. |
243 | i++; | i++; |
244 | ||
245 | input_arg = Tcl_GetString(objv[i]); | input_arg = Tcl_GetString(objv[i]); |
246 | assert(input_arg != NULL); | assert(input_arg != NULL); |
247 | ||
248 | GMP_INTS_mpz_parse_into_uint32(&n, &failure, input_arg); | GMP_INTS_mpz_parse_into_uint32(&n, &failure, input_arg); |
249 | ||
250 | //If the parse was unsuccessful, terminate. | //If the parse was unsuccessful, terminate. |
251 | if (failure) | if (failure) |
252 | { | { |
253 | rv = Tcl_NewStringObj("arbint cfbrapab: -n option followed by invalid integer.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: -n option followed by invalid integer.", -1); |
254 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
255 | ||
256 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
257 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
258 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
259 | ||
260 | return(TCL_ERROR); | return(TCL_ERROR); |
261 | } | } |
262 | ||
263 | //Clip the integer into a 24-bit quantity. | //Clip the integer into a 24-bit quantity. |
264 | n &= 0x00FFFFFF; | n &= 0x00FFFFFF; |
265 | } | } |
266 | else | else |
267 | { | { |
268 | //Unrecognized option. Crash out. | //Unrecognized option. Crash out. |
269 | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1); |
270 | Tcl_AppendToObj(rv, input_arg, -1); | Tcl_AppendToObj(rv, input_arg, -1); |
271 | Tcl_AppendToObj(rv, "\" is not a recognized option.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized option.", -1); |
272 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
273 | ||
274 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
275 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
276 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
277 | ||
278 | return(TCL_ERROR); | return(TCL_ERROR); |
279 | } | } |
280 | } | } |
281 | ||
282 | //Look for any mutually exclusive options. Give a catchall if any of | //Look for any mutually exclusive options. Give a catchall if any of |
283 | //them specified. Because we set them all to 1, addition is the easiest | //them specified. Because we set them all to 1, addition is the easiest |
284 | //way to do this. | //way to do this. |
285 | if ((pred_option_specified + succ_option_specified + neversmaller_option_specified | if ((pred_option_specified + succ_option_specified + neversmaller_option_specified |
286 | + neverlarger_option_specified + n_option_specified) > 1) | + neverlarger_option_specified + n_option_specified) > 1) |
287 | { | { |
288 | rv = Tcl_NewStringObj("arbint cfbrapab: -pred, -succ, -neversmaller, -neverlarger, and -n are mutually exclusive options.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: -pred, -succ, -neversmaller, -neverlarger, and -n are mutually exclusive options.", -1); |
289 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
290 | ||
291 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
292 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
293 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
294 | ||
295 | return(TCL_ERROR); | return(TCL_ERROR); |
296 | } | } |
297 | ||
298 | //Split into cases based on what we're doing. This is wasteful of code, | //Split into cases based on what we're doing. This is wasteful of code, |
299 | //but this is a PC application, not an embedded application. In all cases | //but this is a PC application, not an embedded application. In all cases |
300 | //create a hard error if something goes wrong. Any anomalies should trash | //create a hard error if something goes wrong. Any anomalies should trash |
301 | //a script. | //a script. |
302 | if (!pred_option_specified && !succ_option_specified && !n_option_specified) | if (!pred_option_specified && !succ_option_specified && !n_option_specified) |
303 | { | { |
304 | //This is the traditional best approximation case, with the possibility of | //This is the traditional best approximation case, with the possibility of |
305 | //the -neverlarger or -neversmaller being specified. This is the most messy | //the -neverlarger or -neversmaller being specified. This is the most messy |
306 | //of all the cases. We must gather neighbors and figure out which is closer, | //of all the cases. We must gather neighbors and figure out which is closer, |
307 | //and if there is a tie, which has the smaller magnitude. It is fairly | //and if there is a tie, which has the smaller magnitude. It is fairly |
308 | //messy. | //messy. |
309 | GMP_RALG_fab_neighbor_collection_struct neighbor_data; | GMP_RALG_fab_neighbor_collection_struct neighbor_data; |
310 | GMP_RATS_mpq_struct left_neigh, right_neigh, diff_left, diff_right, closer_neighbor; | GMP_RATS_mpq_struct left_neigh, right_neigh, diff_left, diff_right, closer_neighbor; |
311 | int dist_cmp; | int dist_cmp; |
312 | int mag_cmp; | int mag_cmp; |
313 | ||
314 | //Allocate inner dynamic variables. | //Allocate inner dynamic variables. |
315 | GMP_RATS_mpq_init(&left_neigh); | GMP_RATS_mpq_init(&left_neigh); |
316 | GMP_RATS_mpq_init(&right_neigh); | GMP_RATS_mpq_init(&right_neigh); |
317 | GMP_RATS_mpq_init(&diff_left); | GMP_RATS_mpq_init(&diff_left); |
318 | GMP_RATS_mpq_init(&diff_right); | GMP_RATS_mpq_init(&diff_right); |
319 | GMP_RATS_mpq_init(&closer_neighbor); | GMP_RATS_mpq_init(&closer_neighbor); |
320 | ||
321 | //Form up the neighbor data. We're only looking for up to one neighbor on each | //Form up the neighbor data. We're only looking for up to one neighbor on each |
322 | //side. | //side. |
323 | GMP_RALG_consecutive_fab_terms( | GMP_RALG_consecutive_fab_terms( |
324 | &q_rn, | &q_rn, |
325 | &z_kmax, | &z_kmax, |
326 | &z_hmax, | &z_hmax, |
327 | 1, | 1, |
328 | 1, | 1, |
329 | &neighbor_data | &neighbor_data |
330 | ); | ); |
331 | ||
332 | //If there was an error or we couldn't get any neighbors to play with, give | //If there was an error or we couldn't get any neighbors to play with, give |
333 | //an error return. As long as we have one neighbor on either side, we can definitely | //an error return. As long as we have one neighbor on either side, we can definitely |
334 | //complete. | //complete. |
335 | if (neighbor_data.error || (!neighbor_data.equality && (!neighbor_data.n_left_out || !neighbor_data.n_right_out))) | if (neighbor_data.error || (!neighbor_data.equality && (!neighbor_data.n_left_out || !neighbor_data.n_right_out))) |
336 | { | { |
337 | rv = Tcl_NewStringObj("arbint cfbrapab: unable to form neighbors.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: unable to form neighbors.", -1); |
338 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
339 | ||
340 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
341 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
342 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
343 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
344 | ||
345 | GMP_RATS_mpq_clear(&left_neigh); | GMP_RATS_mpq_clear(&left_neigh); |
346 | GMP_RATS_mpq_clear(&right_neigh); | GMP_RATS_mpq_clear(&right_neigh); |
347 | GMP_RATS_mpq_clear(&diff_left); | GMP_RATS_mpq_clear(&diff_left); |
348 | GMP_RATS_mpq_clear(&diff_right); | GMP_RATS_mpq_clear(&diff_right); |
349 | GMP_RATS_mpq_clear(&closer_neighbor); | GMP_RATS_mpq_clear(&closer_neighbor); |
350 | ||
351 | return(TCL_ERROR); | return(TCL_ERROR); |
352 | } | } |
353 | ||
354 | if (neighbor_data.equality) | if (neighbor_data.equality) |
355 | { | { |
356 | //The equality case takes precedence, always. | //The equality case takes precedence, always. |
357 | GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.norm_rn)); | GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.norm_rn)); |
358 | } | } |
359 | else | else |
360 | { | { |
361 | //The boolean test somewhat above guaranteed that we have both left | //The boolean test somewhat above guaranteed that we have both left |
362 | //and right neighbors. We can assume this. | //and right neighbors. We can assume this. |
363 | GMP_RATS_mpq_copy(&left_neigh, &(neighbor_data.lefts[0].neighbor)); | GMP_RATS_mpq_copy(&left_neigh, &(neighbor_data.lefts[0].neighbor)); |
364 | GMP_RATS_mpq_copy(&right_neigh, &(neighbor_data.rights[0].neighbor)); | GMP_RATS_mpq_copy(&right_neigh, &(neighbor_data.rights[0].neighbor)); |
365 | ||
366 | GMP_RATS_mpq_sub(&diff_left, &left_neigh, &(neighbor_data.norm_rn)); | GMP_RATS_mpq_sub(&diff_left, &left_neigh, &(neighbor_data.norm_rn)); |
367 | GMP_RATS_mpq_sub(&diff_right, &right_neigh, &(neighbor_data.norm_rn)); | GMP_RATS_mpq_sub(&diff_right, &right_neigh, &(neighbor_data.norm_rn)); |
368 | GMP_INTS_mpz_abs(&(diff_left.num)); | GMP_INTS_mpz_abs(&(diff_left.num)); |
369 | GMP_INTS_mpz_abs(&(diff_right.num)); | GMP_INTS_mpz_abs(&(diff_right.num)); |
370 | dist_cmp = GMP_RATS_mpq_cmp(&diff_left, &diff_right, NULL); | dist_cmp = GMP_RATS_mpq_cmp(&diff_left, &diff_right, NULL); |
371 | ||
372 | //If we have a tie on the distance, will need to revert to magnitude of the neighbors. | //If we have a tie on the distance, will need to revert to magnitude of the neighbors. |
373 | GMP_INTS_mpz_abs(&(left_neigh.num)); | GMP_INTS_mpz_abs(&(left_neigh.num)); |
374 | GMP_INTS_mpz_abs(&(right_neigh.num)); | GMP_INTS_mpz_abs(&(right_neigh.num)); |
375 | mag_cmp = GMP_RATS_mpq_cmp(&left_neigh, &right_neigh, NULL); | mag_cmp = GMP_RATS_mpq_cmp(&left_neigh, &right_neigh, NULL); |
376 | ||
377 | if (!neversmaller_option_specified | if (!neversmaller_option_specified |
378 | && | && |
379 | (neverlarger_option_specified || (dist_cmp < 0) || ((dist_cmp==0) && (mag_cmp < 0)))) | (neverlarger_option_specified || (dist_cmp < 0) || ((dist_cmp==0) && (mag_cmp < 0)))) |
380 | { | { |
381 | GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.lefts[0].neighbor)); | GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.lefts[0].neighbor)); |
382 | } | } |
383 | else | else |
384 | { | { |
385 | GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.rights[0].neighbor)); | GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.rights[0].neighbor)); |
386 | } | } |
387 | } | } |
388 | ||
389 | //Stuff our variable of choice into a string ... | //Stuff our variable of choice into a string ... |
390 | chars_reqd = INTFUNC_max( | chars_reqd = INTFUNC_max( |
391 | GMP_INTS_mpz_size_in_base_10(&(closer_neighbor.num)), | GMP_INTS_mpz_size_in_base_10(&(closer_neighbor.num)), |
392 | GMP_INTS_mpz_size_in_base_10(&(closer_neighbor.den)) | GMP_INTS_mpz_size_in_base_10(&(closer_neighbor.den)) |
393 | ); | ); |
394 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
395 | assert(string_result != NULL); | assert(string_result != NULL); |
396 | ||
397 | GMP_INTS_mpz_to_string(string_result, &(closer_neighbor.num)); | GMP_INTS_mpz_to_string(string_result, &(closer_neighbor.num)); |
398 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
399 | Tcl_AppendToObj(rv, "/", -1); | Tcl_AppendToObj(rv, "/", -1); |
400 | GMP_INTS_mpz_to_string(string_result, &(closer_neighbor.den)); | GMP_INTS_mpz_to_string(string_result, &(closer_neighbor.den)); |
401 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
402 | ||
403 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
404 | ||
405 | //Deallocate variables, make normal return. | //Deallocate variables, make normal return. |
406 | TclpFree(string_result); | TclpFree(string_result); |
407 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
408 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
409 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
410 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
411 | ||
412 | GMP_RATS_mpq_clear(&left_neigh); | GMP_RATS_mpq_clear(&left_neigh); |
413 | GMP_RATS_mpq_clear(&right_neigh); | GMP_RATS_mpq_clear(&right_neigh); |
414 | GMP_RATS_mpq_clear(&diff_left); | GMP_RATS_mpq_clear(&diff_left); |
415 | GMP_RATS_mpq_clear(&diff_right); | GMP_RATS_mpq_clear(&diff_right); |
416 | GMP_RATS_mpq_clear(&closer_neighbor); | GMP_RATS_mpq_clear(&closer_neighbor); |
417 | ||
418 | return(TCL_OK); | return(TCL_OK); |
419 | } | } |
420 | else if (n_option_specified) | else if (n_option_specified) |
421 | { | { |
422 | char sbuf[50]; | char sbuf[50]; |
423 | //Static buffer just to stage 32-bit integers. | //Static buffer just to stage 32-bit integers. |
424 | ||
425 | //Multiple neighbors. Must iterate through. | //Multiple neighbors. Must iterate through. |
426 | ||
427 | GMP_RALG_fab_neighbor_collection_struct neighbor_data; | GMP_RALG_fab_neighbor_collection_struct neighbor_data; |
428 | ||
429 | //Form up the neighbor data. | //Form up the neighbor data. |
430 | GMP_RALG_consecutive_fab_terms( | GMP_RALG_consecutive_fab_terms( |
431 | &q_rn, | &q_rn, |
432 | &z_kmax, | &z_kmax, |
433 | &z_hmax, | &z_hmax, |
434 | n, | n, |
435 | n, | n, |
436 | &neighbor_data | &neighbor_data |
437 | ); | ); |
438 | ||
439 | //If there was an error forming up the neighbor data, create a hard error. | //If there was an error forming up the neighbor data, create a hard error. |
440 | if (neighbor_data.error) | if (neighbor_data.error) |
441 | { | { |
442 | rv = Tcl_NewStringObj("arbint cfbrapab: unable to form neighbors.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: unable to form neighbors.", -1); |
443 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
444 | ||
445 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
446 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
447 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
448 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
449 | ||
450 | return(TCL_ERROR); | return(TCL_ERROR); |
451 | } | } |
452 | ||
453 | //Allocate a default buffer of 10K for the ASCII representation of integers. | //Allocate a default buffer of 10K for the ASCII representation of integers. |
454 | //In the vast majority of cases, there will be only one allocation, because it | //In the vast majority of cases, there will be only one allocation, because it |
455 | //takes a mean integer to exceed 10K. However, the logic allows it to grow. | //takes a mean integer to exceed 10K. However, the logic allows it to grow. |
456 | string_result_n_allocd = 10000; | string_result_n_allocd = 10000; |
457 | string_result = TclpAlloc(sizeof(char) * string_result_n_allocd); | string_result = TclpAlloc(sizeof(char) * string_result_n_allocd); |
458 | assert(string_result != NULL); | assert(string_result != NULL); |
459 | ||
460 | //Start off with a return value of the null string. | //Start off with a return value of the null string. |
461 | rv = Tcl_NewStringObj("", -1); | rv = Tcl_NewStringObj("", -1); |
462 | ||
463 | //Loop through, spitting out the left neighbors. | //Loop through, spitting out the left neighbors. |
464 | for (i = neighbor_data.n_left_out-1; i >= 0; i--) | for (i = neighbor_data.n_left_out-1; i >= 0; i--) |
465 | { | { |
466 | //The protocol here is everyone spits out one space before | //The protocol here is everyone spits out one space before |
467 | //they print anything. Must skip this on first loop iteration. | //they print anything. Must skip this on first loop iteration. |
468 | if (i != neighbor_data.n_left_out-1) | if (i != neighbor_data.n_left_out-1) |
469 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
470 | ||
471 | //The index will be the negative of the iteration variable minus one. | //The index will be the negative of the iteration variable minus one. |
472 | sprintf(sbuf, "%d", -i - 1); | sprintf(sbuf, "%d", -i - 1); |
473 | Tcl_AppendToObj(rv, sbuf, -1); | Tcl_AppendToObj(rv, sbuf, -1); |
474 | ||
475 | //Force the buffer to have enough space for the components of the rational | //Force the buffer to have enough space for the components of the rational |
476 | //number. | //number. |
477 | chars_reqd = INTFUNC_max( | chars_reqd = INTFUNC_max( |
478 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[i].neighbor.num)), | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[i].neighbor.num)), |
479 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[i].neighbor.den)) | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[i].neighbor.den)) |
480 | ); | ); |
481 | if (chars_reqd > string_result_n_allocd) | if (chars_reqd > string_result_n_allocd) |
482 | { | { |
483 | string_result_n_allocd = chars_reqd; | string_result_n_allocd = chars_reqd; |
484 | string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd); | string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd); |
485 | assert(string_result != NULL); | assert(string_result != NULL); |
486 | } | } |
487 | ||
488 | //Print the rational number out to the Tcl object. | //Print the rational number out to the Tcl object. |
489 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
490 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[i].neighbor.num)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[i].neighbor.num)); |
491 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
492 | Tcl_AppendToObj(rv, "/", -1); | Tcl_AppendToObj(rv, "/", -1); |
493 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[i].neighbor.den)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[i].neighbor.den)); |
494 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
495 | } | } |
496 | ||
497 | //Spit out the equality case if appropriate. | //Spit out the equality case if appropriate. |
498 | if (neighbor_data.equality) | if (neighbor_data.equality) |
499 | { | { |
500 | if (neighbor_data.n_left_out) | if (neighbor_data.n_left_out) |
501 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
502 | ||
503 | Tcl_AppendToObj(rv, "0", -1); | Tcl_AppendToObj(rv, "0", -1); |
504 | ||
505 | //Force the buffer to have enough space for the components of the rational | //Force the buffer to have enough space for the components of the rational |
506 | //number. | //number. |
507 | chars_reqd = INTFUNC_max( | chars_reqd = INTFUNC_max( |
508 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.norm_rn.num)), | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.norm_rn.num)), |
509 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.norm_rn.den)) | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.norm_rn.den)) |
510 | ); | ); |
511 | if (chars_reqd > string_result_n_allocd) | if (chars_reqd > string_result_n_allocd) |
512 | { | { |
513 | string_result_n_allocd = chars_reqd; | string_result_n_allocd = chars_reqd; |
514 | string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd); | string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd); |
515 | assert(string_result != NULL); | assert(string_result != NULL); |
516 | } | } |
517 | ||
518 | //Print the rational number out to the Tcl object. | //Print the rational number out to the Tcl object. |
519 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
520 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.norm_rn.num)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.norm_rn.num)); |
521 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
522 | Tcl_AppendToObj(rv, "/", -1); | Tcl_AppendToObj(rv, "/", -1); |
523 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.norm_rn.den)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.norm_rn.den)); |
524 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
525 | } | } |
526 | ||
527 | //Loop through, spitting out the right neighbors. | //Loop through, spitting out the right neighbors. |
528 | for (i = 0; i < neighbor_data.n_right_out; i++) | for (i = 0; i < neighbor_data.n_right_out; i++) |
529 | { | { |
530 | //The protocol here is everyone spits out one space before | //The protocol here is everyone spits out one space before |
531 | //they print anything. Must skip this on first loop iteration. | //they print anything. Must skip this on first loop iteration. |
532 | if (neighbor_data.n_left_out || neighbor_data.equality || i) | if (neighbor_data.n_left_out || neighbor_data.equality || i) |
533 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
534 | ||
535 | //The index will be the iteration variable plus one. | //The index will be the iteration variable plus one. |
536 | sprintf(sbuf, "%d", i+1); | sprintf(sbuf, "%d", i+1); |
537 | Tcl_AppendToObj(rv, sbuf, -1); | Tcl_AppendToObj(rv, sbuf, -1); |
538 | ||
539 | //Force the buffer to have enough space for the components of the rational | //Force the buffer to have enough space for the components of the rational |
540 | //number. | //number. |
541 | chars_reqd = INTFUNC_max( | chars_reqd = INTFUNC_max( |
542 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[i].neighbor.num)), | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[i].neighbor.num)), |
543 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[i].neighbor.den)) | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[i].neighbor.den)) |
544 | ); | ); |
545 | if (chars_reqd > string_result_n_allocd) | if (chars_reqd > string_result_n_allocd) |
546 | { | { |
547 | string_result_n_allocd = chars_reqd; | string_result_n_allocd = chars_reqd; |
548 | string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd); | string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd); |
549 | assert(string_result != NULL); | assert(string_result != NULL); |
550 | } | } |
551 | ||
552 | //Print the rational number out to the Tcl object. | //Print the rational number out to the Tcl object. |
553 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
554 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[i].neighbor.num)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[i].neighbor.num)); |
555 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
556 | Tcl_AppendToObj(rv, "/", -1); | Tcl_AppendToObj(rv, "/", -1); |
557 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[i].neighbor.den)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[i].neighbor.den)); |
558 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
559 | } | } |
560 | ||
561 | //Set up for a normal return. | //Set up for a normal return. |
562 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
563 | ||
564 | TclpFree(string_result); | TclpFree(string_result); |
565 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
566 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
567 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
568 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
569 | ||
570 | return(TCL_OK); | return(TCL_OK); |
571 | } | } |
572 | else if (pred_option_specified) | else if (pred_option_specified) |
573 | { | { |
574 | //Simple predecessor case. | //Simple predecessor case. |
575 | ||
576 | GMP_RALG_fab_neighbor_collection_struct neighbor_data; | GMP_RALG_fab_neighbor_collection_struct neighbor_data; |
577 | ||
578 | //Form up the neighbor data. | //Form up the neighbor data. |
579 | GMP_RALG_consecutive_fab_terms( | GMP_RALG_consecutive_fab_terms( |
580 | &q_rn, | &q_rn, |
581 | &z_kmax, | &z_kmax, |
582 | &z_hmax, | &z_hmax, |
583 | 1, | 1, |
584 | 0, | 0, |
585 | &neighbor_data | &neighbor_data |
586 | ); | ); |
587 | ||
588 | //If there was an error forming up the neighbor data or there are no left neighbors, | //If there was an error forming up the neighbor data or there are no left neighbors, |
589 | //create a hard error. | //create a hard error. |
590 | if (neighbor_data.error || !neighbor_data.n_left_out) | if (neighbor_data.error || !neighbor_data.n_left_out) |
591 | { | { |
592 | rv = Tcl_NewStringObj("arbint cfbrapab: unable to find predecessor.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: unable to find predecessor.", -1); |
593 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
594 | ||
595 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
596 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
597 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
598 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
599 | ||
600 | return(TCL_ERROR); | return(TCL_ERROR); |
601 | } | } |
602 | ||
603 | //The test above confirmed that we have at least one left neighbor calculated. | //The test above confirmed that we have at least one left neighbor calculated. |
604 | //We can dump it to a string and finish up. | //We can dump it to a string and finish up. |
605 | chars_reqd = INTFUNC_max( | chars_reqd = INTFUNC_max( |
606 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[0].neighbor.num)), | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[0].neighbor.num)), |
607 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[0].neighbor.den)) | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.lefts[0].neighbor.den)) |
608 | ); | ); |
609 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
610 | assert(string_result != NULL); | assert(string_result != NULL); |
611 | ||
612 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[0].neighbor.num)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[0].neighbor.num)); |
613 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
614 | Tcl_AppendToObj(rv, "/", -1); | Tcl_AppendToObj(rv, "/", -1); |
615 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[0].neighbor.den)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[0].neighbor.den)); |
616 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
617 | ||
618 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
619 | ||
620 | TclpFree(string_result); | TclpFree(string_result); |
621 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
622 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
623 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
624 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
625 | ||
626 | return(TCL_OK); | return(TCL_OK); |
627 | } | } |
628 | else if (succ_option_specified) | else if (succ_option_specified) |
629 | { | { |
630 | //Simple successor. | //Simple successor. |
631 | ||
632 | GMP_RALG_fab_neighbor_collection_struct neighbor_data; | GMP_RALG_fab_neighbor_collection_struct neighbor_data; |
633 | ||
634 | //Form up the neighbor data. | //Form up the neighbor data. |
635 | GMP_RALG_consecutive_fab_terms( | GMP_RALG_consecutive_fab_terms( |
636 | &q_rn, | &q_rn, |
637 | &z_kmax, | &z_kmax, |
638 | &z_hmax, | &z_hmax, |
639 | 0, | 0, |
640 | 1, | 1, |
641 | &neighbor_data | &neighbor_data |
642 | ); | ); |
643 | ||
644 | //If there was an error forming up the neighbor data or there are no right neighbors, | //If there was an error forming up the neighbor data or there are no right neighbors, |
645 | //create a hard error. | //create a hard error. |
646 | if (neighbor_data.error || !neighbor_data.n_right_out) | if (neighbor_data.error || !neighbor_data.n_right_out) |
647 | { | { |
648 | rv = Tcl_NewStringObj("arbint cfbrapab: unable to find successor.", -1); | rv = Tcl_NewStringObj("arbint cfbrapab: unable to find successor.", -1); |
649 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
650 | ||
651 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
652 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
653 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
654 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
655 | ||
656 | return(TCL_ERROR); | return(TCL_ERROR); |
657 | } | } |
658 | ||
659 | //The test above confirmed that we have at least one right neighbor calculated. | //The test above confirmed that we have at least one right neighbor calculated. |
660 | //We can dump it to a string and finish up. | //We can dump it to a string and finish up. |
661 | chars_reqd = INTFUNC_max( | chars_reqd = INTFUNC_max( |
662 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[0].neighbor.num)), | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[0].neighbor.num)), |
663 | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[0].neighbor.den)) | GMP_INTS_mpz_size_in_base_10(&(neighbor_data.rights[0].neighbor.den)) |
664 | ); | ); |
665 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
666 | assert(string_result != NULL); | assert(string_result != NULL); |
667 | ||
668 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[0].neighbor.num)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[0].neighbor.num)); |
669 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
670 | Tcl_AppendToObj(rv, "/", -1); | Tcl_AppendToObj(rv, "/", -1); |
671 | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[0].neighbor.den)); | GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[0].neighbor.den)); |
672 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
673 | ||
674 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
675 | ||
676 | TclpFree(string_result); | TclpFree(string_result); |
677 | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); | GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data); |
678 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
679 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
680 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
681 | ||
682 | return(TCL_OK); | return(TCL_OK); |
683 | } | } |
684 | ||
685 | //Free up all dynamic memory. | //Free up all dynamic memory. |
686 | GMP_RATS_mpq_clear(&q_rn); | GMP_RATS_mpq_clear(&q_rn); |
687 | GMP_INTS_mpz_clear(&z_kmax); | GMP_INTS_mpz_clear(&z_kmax); |
688 | GMP_INTS_mpz_clear(&z_hmax); | GMP_INTS_mpz_clear(&z_hmax); |
689 | ||
690 | //Return | //Return |
691 | return(TCL_OK); | return(TCL_OK); |
692 | } | } |
693 | } | } |
694 | ||
695 | ||
696 | //Handles the "cfratnum" subextension. | //Handles the "cfratnum" subextension. |
697 | //08/07/01: Visually inspected, OK. | //08/07/01: Visually inspected, OK. |
698 | static | static |
699 | int ARBLENINTS_cfratnum_handler(ClientData dummy, | int ARBLENINTS_cfratnum_handler(ClientData dummy, |
700 | Tcl_Interp *interp, | Tcl_Interp *interp, |
701 | int objc, | int objc, |
702 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
703 | { | { |
704 | Tcl_Obj *rv; | Tcl_Obj *rv; |
705 | ||
706 | //We must have exactly one additional argument | //We must have exactly one additional argument |
707 | //to this function, which is the rational number | //to this function, which is the rational number |
708 | //whose continued fraction decomposition is to be | //whose continued fraction decomposition is to be |
709 | //calculated. | //calculated. |
710 | if (objc != 3) | if (objc != 3) |
711 | { | { |
712 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
713 | 2, | 2, |
714 | objv, | objv, |
715 | "urn"); | "urn"); |
716 | return(TCL_ERROR); | return(TCL_ERROR); |
717 | } | } |
718 | else | else |
719 | { | { |
720 | char *input_arg; | char *input_arg; |
721 | int failure; | int failure; |
722 | unsigned chars_reqd; | unsigned chars_reqd; |
723 | char *string_result; | char *string_result; |
724 | int n_string_result; | int n_string_result; |
725 | int i; | int i; |
726 | GMP_RATS_mpq_struct rn; | GMP_RATS_mpq_struct rn; |
727 | GMP_RALG_cf_app_struct decomp; | GMP_RALG_cf_app_struct decomp; |
728 | ||
729 | //In this function, we are going to return a string | //In this function, we are going to return a string |
730 | //result formed by starting with a string and then | //result formed by starting with a string and then |
731 | //concatenating to it again and again. We start | //concatenating to it again and again. We start |
732 | //off believing that 10,000 characters of space is enough, | //off believing that 10,000 characters of space is enough, |
733 | //but we may need to revise upward and reallocate. | //but we may need to revise upward and reallocate. |
734 | //A 10,000 character block is chosen because it is quick | //A 10,000 character block is chosen because it is quick |
735 | //to allocate and most times won't go beyond that. | //to allocate and most times won't go beyond that. |
736 | n_string_result = 10000; | n_string_result = 10000; |
737 | string_result = TclpAlloc(sizeof(char) * n_string_result); | string_result = TclpAlloc(sizeof(char) * n_string_result); |
738 | assert(string_result != NULL); | assert(string_result != NULL); |
739 | ||
740 | //We will need a rational number to hold the return value | //We will need a rational number to hold the return value |
741 | //from the parsing function. Allocate that now. | //from the parsing function. Allocate that now. |
742 | GMP_RATS_mpq_init(&rn); | GMP_RATS_mpq_init(&rn); |
743 | ||
744 | //Grab a pointer to the string representation of | //Grab a pointer to the string representation of |
745 | //the input argument. The storage does not belong to us. | //the input argument. The storage does not belong to us. |
746 | input_arg = Tcl_GetString(objv[2]); | input_arg = Tcl_GetString(objv[2]); |
747 | assert(input_arg != NULL); | assert(input_arg != NULL); |
748 | ||
749 | //Try to parse our input string as a rational number. | //Try to parse our input string as a rational number. |
750 | //If we are not successful in this, must abort. | //If we are not successful in this, must abort. |
751 | GMP_RATS_mpq_set_all_format_rat_num(input_arg, | GMP_RATS_mpq_set_all_format_rat_num(input_arg, |
752 | &failure, | &failure, |
753 | &rn); | &rn); |
754 | ||
755 | if (failure) | if (failure) |
756 | { | { |
757 | rv = Tcl_NewStringObj("arbint cfratnum: \"", -1); | rv = Tcl_NewStringObj("arbint cfratnum: \"", -1); |
758 | Tcl_AppendToObj(rv, input_arg, -1); | Tcl_AppendToObj(rv, input_arg, -1); |
759 | ||
760 | Tcl_AppendToObj(rv, "\" is not a recognized non-negative rational number.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized non-negative rational number.", -1); |
761 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
762 | ||
763 | TclpFree(string_result); | TclpFree(string_result); |
764 | GMP_RATS_mpq_clear(&rn); | GMP_RATS_mpq_clear(&rn); |
765 | ||
766 | return(TCL_ERROR); | return(TCL_ERROR); |
767 | } | } |
768 | ||
769 | //OK, we have a rational number, but there is a possibility | //OK, we have a rational number, but there is a possibility |
770 | //it is negative, which is a no-no. Normalize the signs | //it is negative, which is a no-no. Normalize the signs |
771 | //for easier testing. | //for easier testing. |
772 | GMP_RATS_mpq_normalize_sign(&rn); | GMP_RATS_mpq_normalize_sign(&rn); |
773 | if (GMP_INTS_mpz_is_neg(&(rn.num))) | if (GMP_INTS_mpz_is_neg(&(rn.num))) |
774 | { | { |
775 | rv = Tcl_NewStringObj("arbint cfratnum: \"", -1); | rv = Tcl_NewStringObj("arbint cfratnum: \"", -1); |
776 | Tcl_AppendToObj(rv, input_arg, -1); | Tcl_AppendToObj(rv, input_arg, -1); |
777 | ||
778 | Tcl_AppendToObj(rv, "\" is negative.", -1); | Tcl_AppendToObj(rv, "\" is negative.", -1); |
779 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
780 | ||
781 | TclpFree(string_result); | TclpFree(string_result); |
782 | GMP_RATS_mpq_clear(&rn); | GMP_RATS_mpq_clear(&rn); |
783 | ||
784 | return(TCL_ERROR); | return(TCL_ERROR); |
785 | } | } |
786 | ||
787 | //OK, we have a rational number. Form the continued fraction | //OK, we have a rational number. Form the continued fraction |
788 | //decomposition of it. The function called is set up so that | //decomposition of it. The function called is set up so that |
789 | //one must deallocate, even in an error condition. | //one must deallocate, even in an error condition. |
790 | GMP_RALG_cfdecomp_init(&decomp, | GMP_RALG_cfdecomp_init(&decomp, |
791 | &failure, | &failure, |
792 | &(rn.num), | &(rn.num), |
793 | &(rn.den)); | &(rn.den)); |
794 | ||
795 | //If we failed in the decomposition (don't know why that would | //If we failed in the decomposition (don't know why that would |
796 | //happen) use the general error flag "NAN". | //happen) use the general error flag "NAN". |
797 | if (failure) | if (failure) |
798 | { | { |
799 | rv = Tcl_NewStringObj("NAN", -1); | rv = Tcl_NewStringObj("NAN", -1); |
800 | ||
801 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
802 | ||
803 | TclpFree(string_result); | TclpFree(string_result); |
804 | GMP_RATS_mpq_clear(&rn); | GMP_RATS_mpq_clear(&rn); |
805 | GMP_RALG_cfdecomp_destroy(&decomp); | GMP_RALG_cfdecomp_destroy(&decomp); |
806 | ||
807 | return(TCL_ERROR); | return(TCL_ERROR); |
808 | } | } |
809 | ||
810 | //OK, that really is the last error we could have. | //OK, that really is the last error we could have. |
811 | //Iterate, adding the partial quotients and convergents | //Iterate, adding the partial quotients and convergents |
812 | //to the string which we'll return. We need to watch out | //to the string which we'll return. We need to watch out |
813 | //for running over our 10K buffer. | //for running over our 10K buffer. |
814 | rv = Tcl_NewStringObj("", -1); | rv = Tcl_NewStringObj("", -1); |
815 | for (i=0; i<decomp.n; i++) | for (i=0; i<decomp.n; i++) |
816 | { | { |
817 | //Partial quotient. | //Partial quotient. |
818 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.a[i])); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.a[i])); |
819 | if (chars_reqd > (unsigned)n_string_result) | if (chars_reqd > (unsigned)n_string_result) |
820 | { | { |
821 | n_string_result = chars_reqd; | n_string_result = chars_reqd; |
822 | string_result = TclpRealloc(string_result, | string_result = TclpRealloc(string_result, |
823 | sizeof(char) * n_string_result); | sizeof(char) * n_string_result); |
824 | } | } |
825 | GMP_INTS_mpz_to_string(string_result, &(decomp.a[i])); | GMP_INTS_mpz_to_string(string_result, &(decomp.a[i])); |
826 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
827 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
828 | ||
829 | //Numerator of convergent. | //Numerator of convergent. |
830 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.p[i])); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.p[i])); |
831 | if (chars_reqd > (unsigned)n_string_result) | if (chars_reqd > (unsigned)n_string_result) |
832 | { | { |
833 | n_string_result = chars_reqd; | n_string_result = chars_reqd; |
834 | string_result = TclpRealloc(string_result, | string_result = TclpRealloc(string_result, |
835 | sizeof(char) * n_string_result); | sizeof(char) * n_string_result); |
836 | } | } |
837 | GMP_INTS_mpz_to_string(string_result, &(decomp.p[i])); | GMP_INTS_mpz_to_string(string_result, &(decomp.p[i])); |
838 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
839 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
840 | ||
841 | //Denominator of convergent. | //Denominator of convergent. |
842 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.q[i])); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.q[i])); |
843 | if (chars_reqd > (unsigned)n_string_result) | if (chars_reqd > (unsigned)n_string_result) |
844 | { | { |
845 | n_string_result = chars_reqd; | n_string_result = chars_reqd; |
846 | string_result = TclpRealloc(string_result, | string_result = TclpRealloc(string_result, |
847 | sizeof(char) * n_string_result); | sizeof(char) * n_string_result); |
848 | } | } |
849 | GMP_INTS_mpz_to_string(string_result, &(decomp.q[i])); | GMP_INTS_mpz_to_string(string_result, &(decomp.q[i])); |
850 | Tcl_AppendToObj(rv, string_result, -1); | Tcl_AppendToObj(rv, string_result, -1); |
851 | if (i != (decomp.n - 1)) //No space after last number. | if (i != (decomp.n - 1)) //No space after last number. |
852 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
853 | } | } |
854 | ||
855 | //Assign the result to be the return value. | //Assign the result to be the return value. |
856 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
857 | ||
858 | //Free up all dynamic memory. | //Free up all dynamic memory. |
859 | TclpFree(string_result); | TclpFree(string_result); |
860 | GMP_RATS_mpq_clear(&rn); | GMP_RATS_mpq_clear(&rn); |
861 | GMP_RALG_cfdecomp_destroy(&decomp); | GMP_RALG_cfdecomp_destroy(&decomp); |
862 | ||
863 | //Return | //Return |
864 | return(TCL_OK); | return(TCL_OK); |
865 | } | } |
866 | } | } |
867 | ||
868 | ||
869 | //Handles the "commanate" subextension. | //Handles the "commanate" subextension. |
870 | //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this | //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this |
871 | //from memory an intuition as far as how to set return results and so forth. | //from memory an intuition as far as how to set return results and so forth. |
872 | static | static |
873 | int ARBLENINTS_commanate_handler(ClientData dummy, | int ARBLENINTS_commanate_handler(ClientData dummy, |
874 | Tcl_Interp *interp, | Tcl_Interp *interp, |
875 | int objc, | int objc, |
876 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
877 | { | { |
878 | Tcl_Obj *rv; | Tcl_Obj *rv; |
879 | ||
880 | //We must have one and exactly one additional argument | //We must have one and exactly one additional argument |
881 | //to this function, which is the string we want to | //to this function, which is the string we want to |
882 | //commanate. | //commanate. |
883 | if (objc != 3) | if (objc != 3) |
884 | { | { |
885 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
886 | 2, | 2, |
887 | objv, | objv, |
888 | "sint"); | "sint"); |
889 | return(TCL_ERROR); | return(TCL_ERROR); |
890 | } | } |
891 | else | else |
892 | { | { |
893 | char *string_arg; | char *string_arg; |
894 | ||
895 | //Grab a pointer to the string representation of | //Grab a pointer to the string representation of |
896 | //the input argument. The storage does not belong to us. | //the input argument. The storage does not belong to us. |
897 | string_arg = Tcl_GetString(objv[2]); | string_arg = Tcl_GetString(objv[2]); |
898 | assert(string_arg != NULL); | assert(string_arg != NULL); |
899 | ||
900 | //Try to parse the string as one of the error tags. | //Try to parse the string as one of the error tags. |
901 | //If it is one of those, it isn't an error, but don't | //If it is one of those, it isn't an error, but don't |
902 | //want to touch the string. | //want to touch the string. |
903 | if (GMP_INTS_identify_nan_string(string_arg) >= 0) | if (GMP_INTS_identify_nan_string(string_arg) >= 0) |
904 | { | { |
905 | rv = Tcl_NewStringObj(string_arg, -1); | rv = Tcl_NewStringObj(string_arg, -1); |
906 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
907 | return(TCL_OK); | return(TCL_OK); |
908 | } | } |
909 | //Try to parse it as a signed integer with commas already. | //Try to parse it as a signed integer with commas already. |
910 | //If it already has commas, there is no need to add any. | //If it already has commas, there is no need to add any. |
911 | else if (BSTRFUNC_is_sint_w_commas(string_arg)) | else if (BSTRFUNC_is_sint_w_commas(string_arg)) |
912 | { | { |
913 | //This is already an acceptable commanated signed integer. Send it | //This is already an acceptable commanated signed integer. Send it |
914 | //back as the return value. | //back as the return value. |
915 | rv = Tcl_NewStringObj(string_arg, -1); | rv = Tcl_NewStringObj(string_arg, -1); |
916 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
917 | return(TCL_OK); | return(TCL_OK); |
918 | } | } |
919 | //Try to parse the argument as a signed integer without commas. | //Try to parse the argument as a signed integer without commas. |
920 | //If it is one of those, commanate it and return it. | //If it is one of those, commanate it and return it. |
921 | else if (BSTRFUNC_is_sint_wo_commas(string_arg)) | else if (BSTRFUNC_is_sint_wo_commas(string_arg)) |
922 | { | { |
923 | size_t len; | size_t len; |
924 | char *buffer; | char *buffer; |
925 | ||
926 | len = strlen(string_arg); | len = strlen(string_arg); |
927 | buffer = TclpAlloc(((sizeof(char) * 4 * len) / 3) + 10); | buffer = TclpAlloc(((sizeof(char) * 4 * len) / 3) + 10); |
928 | strcpy(buffer, string_arg); | strcpy(buffer, string_arg); |
929 | BSTRFUNC_commanate(buffer); | BSTRFUNC_commanate(buffer); |
930 | rv = Tcl_NewStringObj(buffer, -1); | rv = Tcl_NewStringObj(buffer, -1); |
931 | TclpFree(buffer); | TclpFree(buffer); |
932 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
933 | return(TCL_OK); | return(TCL_OK); |
934 | } | } |
935 | else | else |
936 | { | { |
937 | //Error case. Must give error message. | //Error case. Must give error message. |
938 | rv = Tcl_NewStringObj("arbint commanate: \"", -1); | rv = Tcl_NewStringObj("arbint commanate: \"", -1); |
939 | Tcl_AppendToObj(rv, string_arg, -1); | Tcl_AppendToObj(rv, string_arg, -1); |
940 | Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1); |
941 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
942 | return(TCL_ERROR); | return(TCL_ERROR); |
943 | } | } |
944 | } | } |
945 | } | } |
946 | ||
947 | ||
948 | //Handles the "const" subextension. | //Handles the "const" subextension. |
949 | //08/17/01: Visual inspection OK. | //08/17/01: Visual inspection OK. |
950 | static | static |
951 | int ARBLENINTS_const_handler(ClientData dummy, | int ARBLENINTS_const_handler(ClientData dummy, |
952 | Tcl_Interp *interp, | Tcl_Interp *interp, |
953 | int objc, | int objc, |
954 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
955 | { | { |
956 | //Table of constants used. | //Table of constants used. |
957 | static struct | static struct |
958 | { | { |
959 | char *tag; | char *tag; |
960 | //The symbolic tag used to identify the number. | //The symbolic tag used to identify the number. |
961 | char *desc; | char *desc; |
962 | //The full description of the number. It must consist | //The full description of the number. It must consist |
963 | //of a string with lines no longer than about 70 chars, | //of a string with lines no longer than about 70 chars, |
964 | //separated by newlines, and indented by 6 spaces. | //separated by newlines, and indented by 6 spaces. |
965 | char *minmant; | char *minmant; |
966 | //The minimum mantissa or minimum representation. | //The minimum mantissa or minimum representation. |
967 | //May not be empty or NULL. | //May not be empty or NULL. |
968 | char *mantrem; | char *mantrem; |
969 | //The remaining mantissa or remaining portion of | //The remaining mantissa or remaining portion of |
970 | //number. May be empty, but may not be NULL. | //number. May be empty, but may not be NULL. |
971 | char *exp; | char *exp; |
972 | //The exponent portion, if any, or NULL otherwise. | //The exponent portion, if any, or NULL otherwise. |
973 | int deflen; | int deflen; |
974 | //The default number of digits for the constant | //The default number of digits for the constant |
975 | //if none is specified. | //if none is specified. |
976 | int digit_count_offset; | int digit_count_offset; |
977 | //The offset to go from string length of mantissa | //The offset to go from string length of mantissa |
978 | //portions to number of digits. Cheap way to adjust | //portions to number of digits. Cheap way to adjust |
979 | //for - sign and decimal point. | //for - sign and decimal point. |
980 | } tbl[] = | } tbl[] = |
981 | { | { |
982 | //e--the transcendental number e. | //e--the transcendental number e. |
983 | { | { |
984 | //tag | //tag |
985 | "e", | "e", |
986 | //desc | //desc |
987 | " Historically significant transcendental constant. Digits obtained\n" | " Historically significant transcendental constant. Digits obtained\n" |
988 | " from http://fermi.udw.ac.za/physics/e.html on 08/17/01.", | " from http://fermi.udw.ac.za/physics/e.html on 08/17/01.", |
989 | //minmant | //minmant |
990 | "2.7", | "2.7", |
991 | //mantrem | //mantrem |
992 | "182818284590452353602874713526624977572470936999595749669676277240766303535" | "182818284590452353602874713526624977572470936999595749669676277240766303535" |
993 | "475945713821785251664274274663919320030599218174135966290435729003342952605956" | "475945713821785251664274274663919320030599218174135966290435729003342952605956" |
994 | "307381323286279434907632338298807531952510190115738341879307021540891499348841" | "307381323286279434907632338298807531952510190115738341879307021540891499348841" |
995 | "675092447614606680822648001684774118537423454424371075390777449920695517027618" | "675092447614606680822648001684774118537423454424371075390777449920695517027618" |
996 | "386062613313845830007520449338265602976067371132007093287091274437470472306969" | "386062613313845830007520449338265602976067371132007093287091274437470472306969" |
997 | "772093101416928368190255151086574637721112523897844250569536967707854499699679" | "772093101416928368190255151086574637721112523897844250569536967707854499699679" |
998 | "468644549059879316368892300987931277361782154249992295763514822082698951936680" | "468644549059879316368892300987931277361782154249992295763514822082698951936680" |
999 | "331825288693984964651058209392398294887933203625094431173012381970684161403970" | "331825288693984964651058209392398294887933203625094431173012381970684161403970" |
1000 | "198376793206832823764648042953118023287825098194558153017567173613320698112509" | "198376793206832823764648042953118023287825098194558153017567173613320698112509" |
1001 | "961818815930416903515988885193458072738667385894228792284998920868058257492796" | "961818815930416903515988885193458072738667385894228792284998920868058257492796" |
1002 | "104841984443634632449684875602336248270419786232090021609902353043699418491463" | "104841984443634632449684875602336248270419786232090021609902353043699418491463" |
1003 | "140934317381436405462531520961836908887070167683964243781405927145635490613031" | "140934317381436405462531520961836908887070167683964243781405927145635490613031" |
1004 | "07208510383750510115747704171898610687396965521267154688957035035", | "07208510383750510115747704171898610687396965521267154688957035035", |
1005 | //exp | //exp |
1006 | NULL, | NULL, |
1007 | //deflen | //deflen |
1008 | 30, | 30, |
1009 | //digit_count_offset | //digit_count_offset |
1010 | 1 | 1 |
1011 | }, | }, |
1012 | //g_metric | //g_metric |
1013 | { | { |
1014 | //tag | //tag |
1015 | "g_si", | "g_si", |
1016 | //desc | //desc |
1017 | " Gravitational acceleration in SI units, meters per second**2.\n" | " Gravitational acceleration in SI units, meters per second**2.\n" |
1018 | " Obtained from NIST Special Publication 811 on 08/17/01.", | " Obtained from NIST Special Publication 811 on 08/17/01.", |
1019 | //minmant | //minmant |
1020 | "9.80665", | "9.80665", |
1021 | //mantrem | //mantrem |
1022 | "", | "", |
1023 | //exp | //exp |
1024 | NULL, | NULL, |
1025 | //deflen | //deflen |
1026 | 30, | 30, |
1027 | //digit_count_offset | //digit_count_offset |
1028 | 1 | 1 |
1029 | }, | }, |
1030 | //in2m | //in2m |
1031 | { | { |
1032 | //tag | //tag |
1033 | "in2m", | "in2m", |
1034 | //desc | //desc |
1035 | " Multiplicative conversion factor from inches to meters.\n" | " Multiplicative conversion factor from inches to meters.\n" |
1036 | " Obtained from NIST Special Publication 811 on 08/17/01.", | " Obtained from NIST Special Publication 811 on 08/17/01.", |
1037 | //minmant | //minmant |
1038 | "2.54", | "2.54", |
1039 | //mantrem | //mantrem |
1040 | "", | "", |
1041 | //exp | //exp |
1042 | "e-2", | "e-2", |
1043 | //deflen | //deflen |
1044 | 30, | 30, |
1045 | //digit_count_offset | //digit_count_offset |
1046 | 1 | 1 |
1047 | }, | }, |
1048 | //mi2km | //mi2km |
1049 | { | { |
1050 | //tag | //tag |
1051 | "mi2km", | "mi2km", |
1052 | //desc | //desc |
1053 | " Multiplicative conversion factor from miles to kilometers.\n" | " Multiplicative conversion factor from miles to kilometers.\n" |
1054 | " Obtained from NIST Special Publication 811 on 08/17/01.", | " Obtained from NIST Special Publication 811 on 08/17/01.", |
1055 | //minmant | //minmant |
1056 | "1.609344", | "1.609344", |
1057 | //mantrem | //mantrem |
1058 | "", | "", |
1059 | //exp | //exp |
1060 | NULL, | NULL, |
1061 | //deflen | //deflen |
1062 | 30, | 30, |
1063 | //digit_count_offset | //digit_count_offset |
1064 | 1 | 1 |
1065 | }, | }, |
1066 | //pi--the transcendental number PI. | //pi--the transcendental number PI. |
1067 | { | { |
1068 | //tag | //tag |
1069 | "pi", | "pi", |
1070 | //desc | //desc |
1071 | " Transcendental constant supplying ratio of a circle's circumference\n" | " Transcendental constant supplying ratio of a circle's circumference\n" |
1072 | " to its diameter. Digits obtained from http://www.joyofpi.com/\n" | " to its diameter. Digits obtained from http://www.joyofpi.com/\n" |
1073 | " pi.htm on 08/17/01.", | " pi.htm on 08/17/01.", |
1074 | //minmant | //minmant |
1075 | "3.14", | "3.14", |
1076 | //mantrem | //mantrem |
1077 | "15926535897932384626433832795028841971" | "15926535897932384626433832795028841971" |
1078 | "6939937510582097494459230781640628620899" | "6939937510582097494459230781640628620899" |
1079 | "8628034825342117067982148086513282306647" | "8628034825342117067982148086513282306647" |
1080 | "0938446095505822317253594081284811174502" | "0938446095505822317253594081284811174502" |
1081 | "8410270193852110555964462294895493038196" | "8410270193852110555964462294895493038196" |
1082 | "4428810975665933446128475648233786783165" | "4428810975665933446128475648233786783165" |
1083 | "2712019091456485669234603486104543266482" | "2712019091456485669234603486104543266482" |
1084 | "1339360726024914127372458700660631558817" | "1339360726024914127372458700660631558817" |
1085 | "4881520920962829254091715364367892590360" | "4881520920962829254091715364367892590360" |
1086 | "0113305305488204665213841469519415116094" | "0113305305488204665213841469519415116094" |
1087 | "3305727036575959195309218611738193261179" | "3305727036575959195309218611738193261179" |
1088 | "3105118548074462379962749567351885752724" | "3105118548074462379962749567351885752724" |
1089 | "8912279381830119491298336733624406566430" | "8912279381830119491298336733624406566430" |
1090 | "8602139494639522473719070217986094370277" | "8602139494639522473719070217986094370277" |
1091 | "0539217176293176752384674818467669405132" | "0539217176293176752384674818467669405132" |
1092 | "0005681271452635608277857713427577896091" | "0005681271452635608277857713427577896091" |
1093 | "7363717872146844090122495343014654958537" | "7363717872146844090122495343014654958537" |
1094 | "1050792279689258923542019956112129021960" | "1050792279689258923542019956112129021960" |
1095 | "8640344181598136297747713099605187072113" | "8640344181598136297747713099605187072113" |
1096 | "4999999837297804995105973173281609631859" | "4999999837297804995105973173281609631859" |
1097 | "5024459455346908302642522308253344685035" | "5024459455346908302642522308253344685035" |
1098 | "2619311881710100031378387528865875332083" | "2619311881710100031378387528865875332083" |
1099 | "8142061717766914730359825349042875546873" | "8142061717766914730359825349042875546873" |
1100 | "1159562863882353787593751957781857780532" | "1159562863882353787593751957781857780532" |
1101 | "1712268066130019278766111959092164201989" | "1712268066130019278766111959092164201989" |
1102 | "3809525720106548586327886593615338182796" | "3809525720106548586327886593615338182796" |
1103 | "8230301952035301852968995773622599413891" | "8230301952035301852968995773622599413891" |
1104 | "2497217752834791315155748572424541506959" | "2497217752834791315155748572424541506959" |
1105 | "5082953311686172785588907509838175463746" | "5082953311686172785588907509838175463746" |
1106 | "4939319255060400927701671139009848824012", | "4939319255060400927701671139009848824012", |
1107 | //exp | //exp |
1108 | NULL, | NULL, |
1109 | //deflen | //deflen |
1110 | 30, | 30, |
1111 | //digit_count_offset | //digit_count_offset |
1112 | 1 | 1 |
1113 | }, | }, |
1114 | //sqrt5--the square root of 5. | //sqrt5--the square root of 5. |
1115 | { | { |
1116 | //tag | //tag |
1117 | "sqrt5", | "sqrt5", |
1118 | //desc | //desc |
1119 | " The square root of 5. Digits obtained from\n" | " The square root of 5. Digits obtained from\n" |
1120 | " http://home.earthlink.net/~maryski/sqrt51000000.txt on 08/17/01.", | " http://home.earthlink.net/~maryski/sqrt51000000.txt on 08/17/01.", |
1121 | //minmant | //minmant |
1122 | "2.236", | "2.236", |
1123 | //mantrem | //mantrem |
1124 | "0679774997896964091736687312762354406183596115257242708972454105209256378048" | "0679774997896964091736687312762354406183596115257242708972454105209256378048" |
1125 | "99414414408378782274969508176150773783504253267724447073863586360121533452708866" | "99414414408378782274969508176150773783504253267724447073863586360121533452708866" |
1126 | "77817319187916581127664532263985658053576135041753378500342339241406444208643253" | "77817319187916581127664532263985658053576135041753378500342339241406444208643253" |
1127 | "90972525926272288762995174024406816117759089094984923713907297288984820886415426" | "90972525926272288762995174024406816117759089094984923713907297288984820886415426" |
1128 | "89894099131693577019748678884425089754132956183176921499977424801530434115035957" | "89894099131693577019748678884425089754132956183176921499977424801530434115035957" |
1129 | "66833251249881517813940800056242085524354223555610630634282023409333198293395974" | "66833251249881517813940800056242085524354223555610630634282023409333198293395974" |
1130 | "63522712013417496142026359047378855043896870611356600457571399565955669569175645" | "63522712013417496142026359047378855043896870611356600457571399565955669569175645" |
1131 | "78221952500060539231234005009286764875529722056766253666074485853505262330678494" | "78221952500060539231234005009286764875529722056766253666074485853505262330678494" |
1132 | "63342224231763727702663240768010444331582573350589309813622634319868647194698997" | "63342224231763727702663240768010444331582573350589309813622634319868647194698997" |
1133 | "01808189524264459620345221411922329125981963258111041704958070481204034559949435" | "01808189524264459620345221411922329125981963258111041704958070481204034559949435" |
1134 | "06855551855572512388641655010262436312571024449618789424682903404474716115455723" | "06855551855572512388641655010262436312571024449618789424682903404474716115455723" |
1135 | "20173767659046091852957560357798439805415538077906439363972302875606299948221385" | "20173767659046091852957560357798439805415538077906439363972302875606299948221385" |
1136 | "21773485924535151210463455550407072278724215347787529112121211843317893351910380", | "21773485924535151210463455550407072278724215347787529112121211843317893351910380", |
1137 | //exp | //exp |
1138 | NULL, | NULL, |
1139 | //deflen | //deflen |
1140 | 30, | 30, |
1141 | //digit_count_offset | //digit_count_offset |
1142 | 1 | 1 |
1143 | }, | }, |
1144 | }; | }; |
1145 | ||
1146 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1147 | //Value that will be returned to caller. | //Value that will be returned to caller. |
1148 | int i; | int i; |
1149 | //Iteration variable. | //Iteration variable. |
1150 | int tbl_idx; | int tbl_idx; |
1151 | //Index into lookup table, of -1 if not found. | //Index into lookup table, of -1 if not found. |
1152 | int ndigits; | int ndigits; |
1153 | //The number of digits to supply. | //The number of digits to supply. |
1154 | int result_code; | int result_code; |
1155 | //Return value from Tcl library function. | //Return value from Tcl library function. |
1156 | ||
1157 | //We must have either one or two additional arguments. | //We must have either one or two additional arguments. |
1158 | if ((objc != 3) && (objc != 4)) | if ((objc != 3) && (objc != 4)) |
1159 | { | { |
1160 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1161 | 2, | 2, |
1162 | objv, | objv, |
1163 | "constant_tag ?ndigits?"); | "constant_tag ?ndigits?"); |
1164 | return(TCL_ERROR); | return(TCL_ERROR); |
1165 | } | } |
1166 | else | else |
1167 | { | { |
1168 | char *string_arg; | char *string_arg; |
1169 | ||
1170 | //Grab a pointer to the string representation of | //Grab a pointer to the string representation of |
1171 | //the input argument. The storage does not belong to us. | //the input argument. The storage does not belong to us. |
1172 | string_arg = Tcl_GetString(objv[2]); | string_arg = Tcl_GetString(objv[2]); |
1173 | assert(string_arg != NULL); | assert(string_arg != NULL); |
1174 | ||
1175 | //Try to look up the string argument in the table. | //Try to look up the string argument in the table. |
1176 | tbl_idx = -1; | tbl_idx = -1; |
1177 | for (i=0; i<sizeof(tbl)/sizeof(tbl[0]); i++) | for (i=0; i<sizeof(tbl)/sizeof(tbl[0]); i++) |
1178 | { | { |
1179 | if (!strcmp(string_arg, tbl[i].tag)) | if (!strcmp(string_arg, tbl[i].tag)) |
1180 | { | { |
1181 | tbl_idx = i; | tbl_idx = i; |
1182 | break; | break; |
1183 | } | } |
1184 | } | } |
1185 | ||
1186 | //If the tag was not found in the table, print a hostile | //If the tag was not found in the table, print a hostile |
1187 | //message and abort. | //message and abort. |
1188 | if (tbl_idx == -1) | if (tbl_idx == -1) |
1189 | { | { |
1190 | char buf[100]; | char buf[100]; |
1191 | ||
1192 | //Error case. Must give error message. | //Error case. Must give error message. |
1193 | //Must also list the constants available. | //Must also list the constants available. |
1194 | rv = Tcl_NewStringObj("arbint const: \"", -1); | rv = Tcl_NewStringObj("arbint const: \"", -1); |
1195 | Tcl_AppendToObj(rv, string_arg, -1); | Tcl_AppendToObj(rv, string_arg, -1); |
1196 | Tcl_AppendToObj(rv, "\" is not a recognized constant.\n", -1); | Tcl_AppendToObj(rv, "\" is not a recognized constant.\n", -1); |
1197 | ||
1198 | Tcl_AppendToObj(rv, "Available constants are:\n", -1); | Tcl_AppendToObj(rv, "Available constants are:\n", -1); |
1199 | ||
1200 | for (i=0; i<sizeof(tbl)/sizeof(tbl[0]); i++) | for (i=0; i<sizeof(tbl)/sizeof(tbl[0]); i++) |
1201 | { | { |
1202 | Tcl_AppendToObj(rv, " ", -1); | Tcl_AppendToObj(rv, " ", -1); |
1203 | Tcl_AppendToObj(rv, tbl[i].tag, -1); | Tcl_AppendToObj(rv, tbl[i].tag, -1); |
1204 | sprintf(buf, " (%d digits available)\n", | sprintf(buf, " (%d digits available)\n", |
1205 | strlen(tbl[i].minmant) + strlen(tbl[i].mantrem) - tbl[i].digit_count_offset); | strlen(tbl[i].minmant) + strlen(tbl[i].mantrem) - tbl[i].digit_count_offset); |
1206 | Tcl_AppendToObj(rv, buf, -1); | Tcl_AppendToObj(rv, buf, -1); |
1207 | Tcl_AppendToObj(rv, tbl[i].desc, -1); | Tcl_AppendToObj(rv, tbl[i].desc, -1); |
1208 | if (i != (sizeof(tbl)/sizeof(tbl[0]) - 1)) | if (i != (sizeof(tbl)/sizeof(tbl[0]) - 1)) |
1209 | Tcl_AppendToObj(rv, "\n", -1); | Tcl_AppendToObj(rv, "\n", -1); |
1210 | } | } |
1211 | ||
1212 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1213 | return(TCL_ERROR); | return(TCL_ERROR); |
1214 | } | } |
1215 | ||
1216 | //Make assertions about the string pointers. | //Make assertions about the string pointers. |
1217 | assert(tbl[tbl_idx].tag != NULL); | assert(tbl[tbl_idx].tag != NULL); |
1218 | assert(tbl[tbl_idx].desc != NULL); | assert(tbl[tbl_idx].desc != NULL); |
1219 | assert(tbl[tbl_idx].minmant != NULL); | assert(tbl[tbl_idx].minmant != NULL); |
1220 | assert(tbl[tbl_idx].mantrem != NULL); | assert(tbl[tbl_idx].mantrem != NULL); |
1221 | ||
1222 | //Assume the default number of digits by default. | //Assume the default number of digits by default. |
1223 | ndigits = tbl[tbl_idx].deflen; | ndigits = tbl[tbl_idx].deflen; |
1224 | ||
1225 | //If there is an additional parameter, try to interpret | //If there is an additional parameter, try to interpret |
1226 | //that as the number of digits. | //that as the number of digits. |
1227 | if (objc == 4) | if (objc == 4) |
1228 | { | { |
1229 | //SetIntFromAny(interp, objPtr) | //SetIntFromAny(interp, objPtr) |
1230 | result_code = Tcl_GetIntFromObj(NULL, objv[3], &ndigits); | result_code = Tcl_GetIntFromObj(NULL, objv[3], &ndigits); |
1231 | ||
1232 | if (result_code != TCL_OK) | if (result_code != TCL_OK) |
1233 | { | { |
1234 | //Could not obtain an integer. Use hostile error | //Could not obtain an integer. Use hostile error |
1235 | //message and abort. | //message and abort. |
1236 | string_arg = Tcl_GetString(objv[3]); | string_arg = Tcl_GetString(objv[3]); |
1237 | assert(string_arg != NULL); | assert(string_arg != NULL); |
1238 | ||
1239 | rv = Tcl_NewStringObj("arbint const: \"", -1); | rv = Tcl_NewStringObj("arbint const: \"", -1); |
1240 | Tcl_AppendToObj(rv, string_arg, -1); | Tcl_AppendToObj(rv, string_arg, -1); |
1241 | Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1); |
1242 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1243 | return(TCL_ERROR); | return(TCL_ERROR); |
1244 | } | } |
1245 | } | } |
1246 | ||
1247 | //Ndigits may be corrupt. We have to be careful below to not | //Ndigits may be corrupt. We have to be careful below to not |
1248 | //allow any funny stuff. | //allow any funny stuff. |
1249 | rv = Tcl_NewStringObj(tbl[tbl_idx].minmant, -1); | rv = Tcl_NewStringObj(tbl[tbl_idx].minmant, -1); |
1250 | ndigits = ndigits - strlen(tbl[tbl_idx].minmant) + tbl[tbl_idx].digit_count_offset; | ndigits = ndigits - strlen(tbl[tbl_idx].minmant) + tbl[tbl_idx].digit_count_offset; |
1251 | if (ndigits > 0) | if (ndigits > 0) |
1252 | { | { |
1253 | if (ndigits >= (int)strlen(tbl[tbl_idx].mantrem)) | if (ndigits >= (int)strlen(tbl[tbl_idx].mantrem)) |
1254 | { | { |
1255 | Tcl_AppendToObj(rv, tbl[tbl_idx].mantrem, -1); | Tcl_AppendToObj(rv, tbl[tbl_idx].mantrem, -1); |
1256 | } | } |
1257 | else | else |
1258 | { | { |
1259 | Tcl_AppendToObj(rv, tbl[tbl_idx].mantrem, ndigits); | Tcl_AppendToObj(rv, tbl[tbl_idx].mantrem, ndigits); |
1260 | } | } |
1261 | } | } |
1262 | ||
1263 | //Append the exponent portion. | //Append the exponent portion. |
1264 | if (tbl[tbl_idx].exp) | if (tbl[tbl_idx].exp) |
1265 | Tcl_AppendToObj(rv, tbl[tbl_idx].exp, -1); | Tcl_AppendToObj(rv, tbl[tbl_idx].exp, -1); |
1266 | ||
1267 | //Default successful return. | //Default successful return. |
1268 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1269 | return(TCL_OK); | return(TCL_OK); |
1270 | } | } |
1271 | } | } |
1272 | ||
1273 | ||
1274 | //Handles the "decommanate" subextension. | //Handles the "decommanate" subextension. |
1275 | //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this | //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this |
1276 | //from memory an intuition as far as how to set return results and so forth. | //from memory an intuition as far as how to set return results and so forth. |
1277 | static | static |
1278 | int ARBLENINTS_decommanate_handler(ClientData dummy, | int ARBLENINTS_decommanate_handler(ClientData dummy, |
1279 | Tcl_Interp *interp, | Tcl_Interp *interp, |
1280 | int objc, | int objc, |
1281 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
1282 | { | { |
1283 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1284 | ||
1285 | //We must have one and exactly one additional argument | //We must have one and exactly one additional argument |
1286 | //to this function, which is the string we want to | //to this function, which is the string we want to |
1287 | //decommanate. | //decommanate. |
1288 | if (objc != 3) | if (objc != 3) |
1289 | { | { |
1290 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1291 | 2, | 2, |
1292 | objv, | objv, |
1293 | "sint"); | "sint"); |
1294 | return(TCL_ERROR); | return(TCL_ERROR); |
1295 | } | } |
1296 | else | else |
1297 | { | { |
1298 | char *string_arg; | char *string_arg; |
1299 | ||
1300 | //Grab a pointer to the string representation of | //Grab a pointer to the string representation of |
1301 | //the input argument. The storage does not belong to us. | //the input argument. The storage does not belong to us. |
1302 | string_arg = Tcl_GetString(objv[2]); | string_arg = Tcl_GetString(objv[2]); |
1303 | assert(string_arg != NULL); | assert(string_arg != NULL); |
1304 | ||
1305 | //Try to parse the string as one of the error tags. | //Try to parse the string as one of the error tags. |
1306 | //If it is one of those, it isn't an error, but don't | //If it is one of those, it isn't an error, but don't |
1307 | //want to touch the string. | //want to touch the string. |
1308 | if (GMP_INTS_identify_nan_string(string_arg) >= 0) | if (GMP_INTS_identify_nan_string(string_arg) >= 0) |
1309 | { | { |
1310 | rv = Tcl_NewStringObj(string_arg, -1); | rv = Tcl_NewStringObj(string_arg, -1); |
1311 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1312 | return(TCL_OK); | return(TCL_OK); |
1313 | } | } |
1314 | //Try to parse it as a signed integer without commas. | //Try to parse it as a signed integer without commas. |
1315 | //If it has no commas, there is no need to decommanate it. | //If it has no commas, there is no need to decommanate it. |
1316 | else if (BSTRFUNC_is_sint_wo_commas(string_arg)) | else if (BSTRFUNC_is_sint_wo_commas(string_arg)) |
1317 | { | { |
1318 | //This is already an acceptable commanated signed integer. Send it | //This is already an acceptable commanated signed integer. Send it |
1319 | //back as the return value. | //back as the return value. |
1320 | rv = Tcl_NewStringObj(string_arg, -1); | rv = Tcl_NewStringObj(string_arg, -1); |
1321 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1322 | return(TCL_OK); | return(TCL_OK); |
1323 | } | } |
1324 | //Try to parse the argument as a signed integer with commas. | //Try to parse the argument as a signed integer with commas. |
1325 | //If it is one of those, decommanate it and return it. | //If it is one of those, decommanate it and return it. |
1326 | else if (BSTRFUNC_is_sint_w_commas(string_arg)) | else if (BSTRFUNC_is_sint_w_commas(string_arg)) |
1327 | { | { |
1328 | size_t len; | size_t len; |
1329 | char *buffer; | char *buffer; |
1330 | ||
1331 | len = strlen(string_arg); | len = strlen(string_arg); |
1332 | buffer = TclpAlloc(sizeof(char) * len + 1); | buffer = TclpAlloc(sizeof(char) * len + 1); |
1333 | strcpy(buffer, string_arg); | strcpy(buffer, string_arg); |
1334 | BSTRFUNC_decommanate(buffer); | BSTRFUNC_decommanate(buffer); |
1335 | rv = Tcl_NewStringObj(buffer, -1); | rv = Tcl_NewStringObj(buffer, -1); |
1336 | TclpFree(buffer); | TclpFree(buffer); |
1337 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1338 | return(TCL_OK); | return(TCL_OK); |
1339 | } | } |
1340 | else | else |
1341 | { | { |
1342 | //Error case. Must give error message. | //Error case. Must give error message. |
1343 | rv = Tcl_NewStringObj("arbint decommanate: \"", -1); | rv = Tcl_NewStringObj("arbint decommanate: \"", -1); |
1344 | Tcl_AppendToObj(rv, string_arg, -1); | Tcl_AppendToObj(rv, string_arg, -1); |
1345 | Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1); |
1346 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1347 | return(TCL_ERROR); | return(TCL_ERROR); |
1348 | } | } |
1349 | } | } |
1350 | } | } |
1351 | ||
1352 | ||
1353 | //Handles the "intadd" subextension. | //Handles the "intadd" subextension. |
1354 | //08/06/01: Visual inspection OK. | //08/06/01: Visual inspection OK. |
1355 | static | static |
1356 | int ARBLENINTS_intadd_handler(ClientData dummy, | int ARBLENINTS_intadd_handler(ClientData dummy, |
1357 | Tcl_Interp *interp, | Tcl_Interp *interp, |
1358 | int objc, | int objc, |
1359 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
1360 | { | { |
1361 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1362 | ||
1363 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
1364 | //to this function, which are the integers whose | //to this function, which are the integers whose |
1365 | //sum is to be calculated. | //sum is to be calculated. |
1366 | if (objc != 4) | if (objc != 4) |
1367 | { | { |
1368 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1369 | 2, | 2, |
1370 | objv, | objv, |
1371 | "sint sint"); | "sint sint"); |
1372 | return(TCL_ERROR); | return(TCL_ERROR); |
1373 | } | } |
1374 | else | else |
1375 | { | { |
1376 | GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result; | GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result; |
1377 | char *add_arg1, *add_arg2; | char *add_arg1, *add_arg2; |
1378 | int failure1, failure2; | int failure1, failure2; |
1379 | unsigned chars_reqd; | unsigned chars_reqd; |
1380 | char *string_result; | char *string_result; |
1381 | int i, j; | int i, j; |
1382 | ||
1383 | //Allocate space for the arbitrary-length integer result. | //Allocate space for the arbitrary-length integer result. |
1384 | GMP_INTS_mpz_init(&arb_arg1); | GMP_INTS_mpz_init(&arb_arg1); |
1385 | GMP_INTS_mpz_init(&arb_arg2); | GMP_INTS_mpz_init(&arb_arg2); |
1386 | GMP_INTS_mpz_init(&arb_result); | GMP_INTS_mpz_init(&arb_result); |
1387 | ||
1388 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
1389 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
1390 | add_arg1 = Tcl_GetString(objv[2]); | add_arg1 = Tcl_GetString(objv[2]); |
1391 | assert(add_arg1 != NULL); | assert(add_arg1 != NULL); |
1392 | add_arg2 = Tcl_GetString(objv[3]); | add_arg2 = Tcl_GetString(objv[3]); |
1393 | assert(add_arg2 != NULL); | assert(add_arg2 != NULL); |
1394 | ||
1395 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
1396 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
1397 | //a binary operation. | //a binary operation. |
1398 | i = GMP_INTS_identify_nan_string(add_arg1); | i = GMP_INTS_identify_nan_string(add_arg1); |
1399 | j = GMP_INTS_identify_nan_string(add_arg2); | j = GMP_INTS_identify_nan_string(add_arg2); |
1400 | ||
1401 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
1402 | { | { |
1403 | const char *p; | const char *p; |
1404 | ||
1405 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
1406 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
1407 | //we do. | //we do. |
1408 | if (i > j) | if (i > j) |
1409 | ; | ; |
1410 | else | else |
1411 | i = j; | i = j; |
1412 | ||
1413 | //i now contains the max. | //i now contains the max. |
1414 | switch (i) | switch (i) |
1415 | { | { |
1416 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
1417 | break; | break; |
1418 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
1419 | break; | break; |
1420 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
1421 | break; | break; |
1422 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
1423 | break; | break; |
1424 | default: | default: |
1425 | assert(0); | assert(0); |
1426 | break; | break; |
1427 | } | } |
1428 | ||
1429 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
1430 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1431 | ||
1432 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1433 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
1434 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1435 | ||
1436 | return(TCL_OK); | return(TCL_OK); |
1437 | } | } |
1438 | ||
1439 | //Try to convert both strings into arbitrary integers. | //Try to convert both strings into arbitrary integers. |
1440 | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, add_arg1); | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, add_arg1); |
1441 | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, add_arg2); | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, add_arg2); |
1442 | ||
1443 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
1444 | //message. It is possible that both arguments failed the parse, | //message. It is possible that both arguments failed the parse, |
1445 | //but only return one in the error message. | //but only return one in the error message. |
1446 | if (failure1 || failure2) | if (failure1 || failure2) |
1447 | { | { |
1448 | rv = Tcl_NewStringObj("arbint intadd: \"", -1); | rv = Tcl_NewStringObj("arbint intadd: \"", -1); |
1449 | if (failure1) | if (failure1) |
1450 | Tcl_AppendToObj(rv, add_arg1, -1); | Tcl_AppendToObj(rv, add_arg1, -1); |
1451 | else | else |
1452 | Tcl_AppendToObj(rv, add_arg2, -1); | Tcl_AppendToObj(rv, add_arg2, -1); |
1453 | ||
1454 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
1455 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1456 | ||
1457 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1458 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
1459 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1460 | ||
1461 | return(TCL_ERROR); | return(TCL_ERROR); |
1462 | } | } |
1463 | ||
1464 | //Calculate the sum. | //Calculate the sum. |
1465 | GMP_INTS_mpz_add(&arb_result, &arb_arg1, &arb_arg2); | GMP_INTS_mpz_add(&arb_result, &arb_arg1, &arb_arg2); |
1466 | ||
1467 | //Figure out the number of characters required for | //Figure out the number of characters required for |
1468 | //the output string. | //the output string. |
1469 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); |
1470 | ||
1471 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
1472 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
1473 | assert(string_result != NULL); | assert(string_result != NULL); |
1474 | ||
1475 | //Make the conversion to a character string. | //Make the conversion to a character string. |
1476 | GMP_INTS_mpz_to_string(string_result, &arb_result); | GMP_INTS_mpz_to_string(string_result, &arb_result); |
1477 | ||
1478 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
1479 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
1480 | ||
1481 | //Deallocate the string. | //Deallocate the string. |
1482 | TclpFree(string_result); | TclpFree(string_result); |
1483 | ||
1484 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
1485 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1486 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
1487 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1488 | ||
1489 | //Assign the result to be the return value. | //Assign the result to be the return value. |
1490 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1491 | ||
1492 | //Return | //Return |
1493 | return(TCL_OK); | return(TCL_OK); |
1494 | } | } |
1495 | } | } |
1496 | ||
1497 | ||
1498 | //08/01/01: Visual inspection and some unit testing, OK. | //08/01/01: Visual inspection and some unit testing, OK. |
1499 | //Handles the "intcmp" subextension. | //Handles the "intcmp" subextension. |
1500 | static | static |
1501 | int ARBLENINTS_intcmp_handler(ClientData dummy, | int ARBLENINTS_intcmp_handler(ClientData dummy, |
1502 | Tcl_Interp *interp, | Tcl_Interp *interp, |
1503 | int objc, | int objc, |
1504 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
1505 | { | { |
1506 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1507 | ||
1508 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
1509 | //to this function, which are the integers to be compared. | //to this function, which are the integers to be compared. |
1510 | if (objc != 4) | if (objc != 4) |
1511 | { | { |
1512 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1513 | 2, | 2, |
1514 | objv, | objv, |
1515 | "sint sint"); | "sint sint"); |
1516 | return(TCL_ERROR); | return(TCL_ERROR); |
1517 | } | } |
1518 | else | else |
1519 | { | { |
1520 | GMP_INTS_mpz_struct arb_arg1, arb_arg2; | GMP_INTS_mpz_struct arb_arg1, arb_arg2; |
1521 | char *cmp_arg1, *cmp_arg2; | char *cmp_arg1, *cmp_arg2; |
1522 | int failure1, failure2; | int failure1, failure2; |
1523 | int i, j, compare_result; | int i, j, compare_result; |
1524 | ||
1525 | //Allocate space for the arbitrary-length integer result. | //Allocate space for the arbitrary-length integer result. |
1526 | GMP_INTS_mpz_init(&arb_arg1); | GMP_INTS_mpz_init(&arb_arg1); |
1527 | GMP_INTS_mpz_init(&arb_arg2); | GMP_INTS_mpz_init(&arb_arg2); |
1528 | ||
1529 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
1530 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
1531 | cmp_arg1 = Tcl_GetString(objv[2]); | cmp_arg1 = Tcl_GetString(objv[2]); |
1532 | assert(cmp_arg1 != NULL); | assert(cmp_arg1 != NULL); |
1533 | cmp_arg2 = Tcl_GetString(objv[3]); | cmp_arg2 = Tcl_GetString(objv[3]); |
1534 | assert(cmp_arg2 != NULL); | assert(cmp_arg2 != NULL); |
1535 | ||
1536 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
1537 | //We cannot compare NAN tags. If either is a NAN tag, we must signal an | //We cannot compare NAN tags. If either is a NAN tag, we must signal an |
1538 | //error. | //error. |
1539 | i = GMP_INTS_identify_nan_string(cmp_arg1); | i = GMP_INTS_identify_nan_string(cmp_arg1); |
1540 | j = GMP_INTS_identify_nan_string(cmp_arg2); | j = GMP_INTS_identify_nan_string(cmp_arg2); |
1541 | ||
1542 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
1543 | { | { |
1544 | rv = Tcl_NewStringObj("arbint intcmp: cannot compare NAN symbolic tags.", -1); | rv = Tcl_NewStringObj("arbint intcmp: cannot compare NAN symbolic tags.", -1); |
1545 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1546 | ||
1547 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1548 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
1549 | ||
1550 | return(TCL_ERROR); | return(TCL_ERROR); |
1551 | } | } |
1552 | ||
1553 | //Try to convert both strings into arbitrary integers. | //Try to convert both strings into arbitrary integers. |
1554 | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, cmp_arg1); | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, cmp_arg1); |
1555 | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, cmp_arg2); | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, cmp_arg2); |
1556 | ||
1557 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
1558 | //message. It is possible that both arguments failed the parse, | //message. It is possible that both arguments failed the parse, |
1559 | //but only return one in the error message. | //but only return one in the error message. |
1560 | if (failure1 || failure2) | if (failure1 || failure2) |
1561 | { | { |
1562 | rv = Tcl_NewStringObj("arbint intcmp: \"", -1); | rv = Tcl_NewStringObj("arbint intcmp: \"", -1); |
1563 | if (failure1) | if (failure1) |
1564 | Tcl_AppendToObj(rv, cmp_arg1, -1); | Tcl_AppendToObj(rv, cmp_arg1, -1); |
1565 | else | else |
1566 | Tcl_AppendToObj(rv, cmp_arg2, -1); | Tcl_AppendToObj(rv, cmp_arg2, -1); |
1567 | ||
1568 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
1569 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1570 | ||
1571 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1572 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
1573 | ||
1574 | return(TCL_ERROR); | return(TCL_ERROR); |
1575 | } | } |
1576 | ||
1577 | //Calculate the compare result. | //Calculate the compare result. |
1578 | compare_result = GMP_INTS_mpz_cmp(&arb_arg1, &arb_arg2); | compare_result = GMP_INTS_mpz_cmp(&arb_arg1, &arb_arg2); |
1579 | ||
1580 | //Assign the return value based on the result. | //Assign the return value based on the result. |
1581 | if (compare_result < 0) | if (compare_result < 0) |
1582 | rv = Tcl_NewStringObj("-1", -1); | rv = Tcl_NewStringObj("-1", -1); |
1583 | else if (compare_result == 0) | else if (compare_result == 0) |
1584 | rv = Tcl_NewStringObj("0", -1); | rv = Tcl_NewStringObj("0", -1); |
1585 | else | else |
1586 | rv = Tcl_NewStringObj("1", -1); | rv = Tcl_NewStringObj("1", -1); |
1587 | ||
1588 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
1589 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1590 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
1591 | ||
1592 | //Assign the result to be the return value. | //Assign the result to be the return value. |
1593 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1594 | ||
1595 | //Return | //Return |
1596 | return(TCL_OK); | return(TCL_OK); |
1597 | } | } |
1598 | } | } |
1599 | ||
1600 | ||
1601 | //Handles the "intdiv" subextension. | //Handles the "intdiv" subextension. |
1602 | //07/31/01: Visually inspected, OK. | //07/31/01: Visually inspected, OK. |
1603 | static | static |
1604 | int ARBLENINTS_intdiv_handler(ClientData dummy, | int ARBLENINTS_intdiv_handler(ClientData dummy, |
1605 | Tcl_Interp *interp, | Tcl_Interp *interp, |
1606 | int objc, | int objc, |
1607 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
1608 | { | { |
1609 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1610 | ||
1611 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
1612 | //to this function, which are the integers whose | //to this function, which are the integers whose |
1613 | //integer quotient is to be calculated. | //integer quotient is to be calculated. |
1614 | if (objc != 4) | if (objc != 4) |
1615 | { | { |
1616 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1617 | 2, | 2, |
1618 | objv, | objv, |
1619 | "sint sint"); | "sint sint"); |
1620 | return(TCL_ERROR); | return(TCL_ERROR); |
1621 | } | } |
1622 | else | else |
1623 | { | { |
1624 | GMP_INTS_mpz_struct arb_dividend, arb_divisor, arb_quotient, arb_remainder; | GMP_INTS_mpz_struct arb_dividend, arb_divisor, arb_quotient, arb_remainder; |
1625 | char *dividend_arg1, *divisor_arg2; | char *dividend_arg1, *divisor_arg2; |
1626 | int failure1, failure2; | int failure1, failure2; |
1627 | unsigned chars_reqd; | unsigned chars_reqd; |
1628 | char *string_result; | char *string_result; |
1629 | int i, j; | int i, j; |
1630 | ||
1631 | //Allocate space for the arbitrary-length integer arguments and results. | //Allocate space for the arbitrary-length integer arguments and results. |
1632 | GMP_INTS_mpz_init(&arb_dividend); | GMP_INTS_mpz_init(&arb_dividend); |
1633 | GMP_INTS_mpz_init(&arb_divisor); | GMP_INTS_mpz_init(&arb_divisor); |
1634 | GMP_INTS_mpz_init(&arb_quotient); | GMP_INTS_mpz_init(&arb_quotient); |
1635 | GMP_INTS_mpz_init(&arb_remainder); | GMP_INTS_mpz_init(&arb_remainder); |
1636 | ||
1637 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
1638 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
1639 | dividend_arg1 = Tcl_GetString(objv[2]); | dividend_arg1 = Tcl_GetString(objv[2]); |
1640 | assert(dividend_arg1 != NULL); | assert(dividend_arg1 != NULL); |
1641 | divisor_arg2 = Tcl_GetString(objv[3]); | divisor_arg2 = Tcl_GetString(objv[3]); |
1642 | assert(divisor_arg2 != NULL); | assert(divisor_arg2 != NULL); |
1643 | ||
1644 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
1645 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
1646 | //a binary operation. | //a binary operation. |
1647 | i = GMP_INTS_identify_nan_string(dividend_arg1); | i = GMP_INTS_identify_nan_string(dividend_arg1); |
1648 | j = GMP_INTS_identify_nan_string(divisor_arg2); | j = GMP_INTS_identify_nan_string(divisor_arg2); |
1649 | ||
1650 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
1651 | { | { |
1652 | const char *p; | const char *p; |
1653 | ||
1654 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
1655 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
1656 | //we do. | //we do. |
1657 | if (i > j) | if (i > j) |
1658 | ; | ; |
1659 | else | else |
1660 | i = j; | i = j; |
1661 | ||
1662 | //i now contains the max. | //i now contains the max. |
1663 | switch (i) | switch (i) |
1664 | { | { |
1665 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
1666 | break; | break; |
1667 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
1668 | break; | break; |
1669 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
1670 | break; | break; |
1671 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
1672 | break; | break; |
1673 | default: | default: |
1674 | assert(0); | assert(0); |
1675 | break; | break; |
1676 | } | } |
1677 | ||
1678 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
1679 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1680 | ||
1681 | GMP_INTS_mpz_clear(&arb_dividend); | GMP_INTS_mpz_clear(&arb_dividend); |
1682 | GMP_INTS_mpz_clear(&arb_divisor); | GMP_INTS_mpz_clear(&arb_divisor); |
1683 | GMP_INTS_mpz_clear(&arb_quotient); | GMP_INTS_mpz_clear(&arb_quotient); |
1684 | GMP_INTS_mpz_clear(&arb_remainder); | GMP_INTS_mpz_clear(&arb_remainder); |
1685 | ||
1686 | return(TCL_OK); | return(TCL_OK); |
1687 | } | } |
1688 | ||
1689 | //Try to convert both strings into arbitrary integers. | //Try to convert both strings into arbitrary integers. |
1690 | GMP_INTS_mpz_set_general_int(&arb_dividend, &failure1, dividend_arg1); | GMP_INTS_mpz_set_general_int(&arb_dividend, &failure1, dividend_arg1); |
1691 | GMP_INTS_mpz_set_general_int(&arb_divisor, &failure2, divisor_arg2); | GMP_INTS_mpz_set_general_int(&arb_divisor, &failure2, divisor_arg2); |
1692 | ||
1693 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
1694 | //message. It is possible that both arguments failed the parse, | //message. It is possible that both arguments failed the parse, |
1695 | //but only return one in the error message. | //but only return one in the error message. |
1696 | if (failure1 || failure2) | if (failure1 || failure2) |
1697 | { | { |
1698 | rv = Tcl_NewStringObj("arbint intdiv: \"", -1); | rv = Tcl_NewStringObj("arbint intdiv: \"", -1); |
1699 | if (failure1) | if (failure1) |
1700 | Tcl_AppendToObj(rv, dividend_arg1, -1); | Tcl_AppendToObj(rv, dividend_arg1, -1); |
1701 | else | else |
1702 | Tcl_AppendToObj(rv, divisor_arg2, -1); | Tcl_AppendToObj(rv, divisor_arg2, -1); |
1703 | ||
1704 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
1705 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1706 | ||
1707 | GMP_INTS_mpz_clear(&arb_dividend); | GMP_INTS_mpz_clear(&arb_dividend); |
1708 | GMP_INTS_mpz_clear(&arb_divisor); | GMP_INTS_mpz_clear(&arb_divisor); |
1709 | GMP_INTS_mpz_clear(&arb_quotient); | GMP_INTS_mpz_clear(&arb_quotient); |
1710 | GMP_INTS_mpz_clear(&arb_remainder); | GMP_INTS_mpz_clear(&arb_remainder); |
1711 | ||
1712 | return(TCL_ERROR); | return(TCL_ERROR); |
1713 | } | } |
1714 | ||
1715 | //Calculate the quotient. | //Calculate the quotient. |
1716 | GMP_INTS_mpz_tdiv_qr(&arb_quotient, &arb_remainder, &arb_dividend, &arb_divisor); | GMP_INTS_mpz_tdiv_qr(&arb_quotient, &arb_remainder, &arb_dividend, &arb_divisor); |
1717 | ||
1718 | //Figure out the number of characters required for | //Figure out the number of characters required for |
1719 | //the output string. | //the output string. |
1720 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_quotient); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_quotient); |
1721 | ||
1722 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
1723 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
1724 | assert(string_result != NULL); | assert(string_result != NULL); |
1725 | ||
1726 | //Make the conversion to a character string. | //Make the conversion to a character string. |
1727 | GMP_INTS_mpz_to_string(string_result, &arb_quotient); | GMP_INTS_mpz_to_string(string_result, &arb_quotient); |
1728 | ||
1729 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
1730 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
1731 | ||
1732 | //Deallocate the string. | //Deallocate the string. |
1733 | TclpFree(string_result); | TclpFree(string_result); |
1734 | ||
1735 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
1736 | GMP_INTS_mpz_clear(&arb_dividend); | GMP_INTS_mpz_clear(&arb_dividend); |
1737 | GMP_INTS_mpz_clear(&arb_divisor); | GMP_INTS_mpz_clear(&arb_divisor); |
1738 | GMP_INTS_mpz_clear(&arb_quotient); | GMP_INTS_mpz_clear(&arb_quotient); |
1739 | GMP_INTS_mpz_clear(&arb_remainder); | GMP_INTS_mpz_clear(&arb_remainder); |
1740 | ||
1741 | //Assign the result to be the return value. | //Assign the result to be the return value. |
1742 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1743 | ||
1744 | //Return | //Return |
1745 | return(TCL_OK); | return(TCL_OK); |
1746 | } | } |
1747 | } | } |
1748 | ||
1749 | ||
1750 | //08/01/01: Visually inspected. | //08/01/01: Visually inspected. |
1751 | //Handles the "intexp" subextension. | //Handles the "intexp" subextension. |
1752 | static | static |
1753 | int ARBLENINTS_intexp_handler(ClientData dummy, | int ARBLENINTS_intexp_handler(ClientData dummy, |
1754 | Tcl_Interp *interp, | Tcl_Interp *interp, |
1755 | int objc, | int objc, |
1756 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
1757 | { | { |
1758 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1759 | ||
1760 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
1761 | //to this function, which are the integers used to | //to this function, which are the integers used to |
1762 | //calculate the exponential. | //calculate the exponential. |
1763 | if (objc != 4) | if (objc != 4) |
1764 | { | { |
1765 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1766 | 2, | 2, |
1767 | objv, | objv, |
1768 | "sint uint32"); | "sint uint32"); |
1769 | return(TCL_ERROR); | return(TCL_ERROR); |
1770 | } | } |
1771 | else | else |
1772 | { | { |
1773 | GMP_INTS_mpz_struct arb_arg1, arb_result; | GMP_INTS_mpz_struct arb_arg1, arb_result; |
1774 | unsigned arg2; | unsigned arg2; |
1775 | char *str_arg1, *str_arg2; | char *str_arg1, *str_arg2; |
1776 | int failure1, failure2; | int failure1, failure2; |
1777 | unsigned chars_reqd; | unsigned chars_reqd; |
1778 | char *string_result; | char *string_result; |
1779 | int i, j; | int i, j; |
1780 | ||
1781 | //Allocate space for the arbitrary-length integers. | //Allocate space for the arbitrary-length integers. |
1782 | GMP_INTS_mpz_init(&arb_arg1); | GMP_INTS_mpz_init(&arb_arg1); |
1783 | GMP_INTS_mpz_init(&arb_result); | GMP_INTS_mpz_init(&arb_result); |
1784 | ||
1785 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
1786 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
1787 | str_arg1 = Tcl_GetString(objv[2]); | str_arg1 = Tcl_GetString(objv[2]); |
1788 | assert(str_arg1 != NULL); | assert(str_arg1 != NULL); |
1789 | str_arg2 = Tcl_GetString(objv[3]); | str_arg2 = Tcl_GetString(objv[3]); |
1790 | assert(str_arg2 != NULL); | assert(str_arg2 != NULL); |
1791 | ||
1792 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
1793 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
1794 | //a binary operation. | //a binary operation. |
1795 | i = GMP_INTS_identify_nan_string(str_arg1); | i = GMP_INTS_identify_nan_string(str_arg1); |
1796 | j = GMP_INTS_identify_nan_string(str_arg2); | j = GMP_INTS_identify_nan_string(str_arg2); |
1797 | ||
1798 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
1799 | { | { |
1800 | const char *p; | const char *p; |
1801 | ||
1802 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
1803 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
1804 | //we do. | //we do. |
1805 | if (i > j) | if (i > j) |
1806 | ; | ; |
1807 | else | else |
1808 | i = j; | i = j; |
1809 | ||
1810 | //i now contains the max. | //i now contains the max. |
1811 | switch (i) | switch (i) |
1812 | { | { |
1813 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
1814 | break; | break; |
1815 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
1816 | break; | break; |
1817 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
1818 | break; | break; |
1819 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
1820 | break; | break; |
1821 | default: | default: |
1822 | assert(0); | assert(0); |
1823 | break; | break; |
1824 | } | } |
1825 | ||
1826 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
1827 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1828 | ||
1829 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1830 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1831 | ||
1832 | return(TCL_OK); | return(TCL_OK); |
1833 | } | } |
1834 | ||
1835 | //Try to convert the first string into arbitrary integers. | //Try to convert the first string into arbitrary integers. |
1836 | //The first string can be anything, including zero or a negative | //The first string can be anything, including zero or a negative |
1837 | //arugument. | //arugument. |
1838 | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, str_arg1); | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, str_arg1); |
1839 | ||
1840 | //If the conversion of the first string did not go alright, | //If the conversion of the first string did not go alright, |
1841 | //print error message and abort. | //print error message and abort. |
1842 | if (failure1) | if (failure1) |
1843 | { | { |
1844 | rv = Tcl_NewStringObj("arbint intexp: \"", -1); | rv = Tcl_NewStringObj("arbint intexp: \"", -1); |
1845 | Tcl_AppendToObj(rv, str_arg1, -1); | Tcl_AppendToObj(rv, str_arg1, -1); |
1846 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
1847 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1848 | ||
1849 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1850 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1851 | ||
1852 | return(TCL_ERROR); | return(TCL_ERROR); |
1853 | } | } |
1854 | ||
1855 | ||
1856 | //Try to convert the second string into an unsigned 32-bit | //Try to convert the second string into an unsigned 32-bit |
1857 | //integer. | //integer. |
1858 | GMP_INTS_mpz_parse_into_uint32(&arg2, &failure2, str_arg2); | GMP_INTS_mpz_parse_into_uint32(&arg2, &failure2, str_arg2); |
1859 | ||
1860 | //If the conversion of the second string did not go alright, | //If the conversion of the second string did not go alright, |
1861 | //print error message and abort. | //print error message and abort. |
1862 | if (failure2) | if (failure2) |
1863 | { | { |
1864 | rv = Tcl_NewStringObj("arbint intexp: \"", -1); | rv = Tcl_NewStringObj("arbint intexp: \"", -1); |
1865 | Tcl_AppendToObj(rv, str_arg2, -1); | Tcl_AppendToObj(rv, str_arg2, -1); |
1866 | Tcl_AppendToObj(rv, "\" is not a recognized unsigned 32-bit integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized unsigned 32-bit integer.", -1); |
1867 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1868 | ||
1869 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1870 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1871 | ||
1872 | return(TCL_ERROR); | return(TCL_ERROR); |
1873 | } | } |
1874 | ||
1875 | //Calculate the exponential. | //Calculate the exponential. |
1876 | GMP_INTS_mpz_pow_ui(&arb_result, &arb_arg1, arg2); | GMP_INTS_mpz_pow_ui(&arb_result, &arb_arg1, arg2); |
1877 | ||
1878 | //Figure out the number of characters required for | //Figure out the number of characters required for |
1879 | //the output string. | //the output string. |
1880 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); |
1881 | ||
1882 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
1883 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
1884 | assert(string_result != NULL); | assert(string_result != NULL); |
1885 | ||
1886 | //Make the conversion to a character string. | //Make the conversion to a character string. |
1887 | GMP_INTS_mpz_to_string(string_result, &arb_result); | GMP_INTS_mpz_to_string(string_result, &arb_result); |
1888 | ||
1889 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
1890 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
1891 | ||
1892 | //Deallocate the string. | //Deallocate the string. |
1893 | TclpFree(string_result); | TclpFree(string_result); |
1894 | ||
1895 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
1896 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
1897 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1898 | ||
1899 | //Assign the result to be the return value. | //Assign the result to be the return value. |
1900 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1901 | ||
1902 | //Return | //Return |
1903 | return(TCL_OK); | return(TCL_OK); |
1904 | } | } |
1905 | } | } |
1906 | ||
1907 | ||
1908 | //Handles the "intfac" subextension. | //Handles the "intfac" subextension. |
1909 | //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this | //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this |
1910 | //from memory an intuition as far as how to set return results and so forth. | //from memory an intuition as far as how to set return results and so forth. |
1911 | static | static |
1912 | int ARBLENINTS_intfac_handler(ClientData dummy, | int ARBLENINTS_intfac_handler(ClientData dummy, |
1913 | Tcl_Interp *interp, | Tcl_Interp *interp, |
1914 | int objc, | int objc, |
1915 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
1916 | { | { |
1917 | Tcl_Obj *rv; | Tcl_Obj *rv; |
1918 | ||
1919 | //We must have one and exactly one additional argument | //We must have one and exactly one additional argument |
1920 | //to this function, which is the integer whose | //to this function, which is the integer whose |
1921 | //factorial is to be evaluated. | //factorial is to be evaluated. |
1922 | if (objc != 3) | if (objc != 3) |
1923 | { | { |
1924 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
1925 | 2, | 2, |
1926 | objv, | objv, |
1927 | "uint32"); | "uint32"); |
1928 | return(TCL_ERROR); | return(TCL_ERROR); |
1929 | } | } |
1930 | else | else |
1931 | { | { |
1932 | GMP_INTS_mpz_struct arb_result; | GMP_INTS_mpz_struct arb_result; |
1933 | char *fac_arg; | char *fac_arg; |
1934 | int failure; | int failure; |
1935 | unsigned fac_ui_arg; | unsigned fac_ui_arg; |
1936 | unsigned chars_reqd; | unsigned chars_reqd; |
1937 | char *string_result; | char *string_result; |
1938 | int i; | int i; |
1939 | ||
1940 | //Allocate space for the arbitrary-length integer result. | //Allocate space for the arbitrary-length integer result. |
1941 | GMP_INTS_mpz_init(&arb_result); | GMP_INTS_mpz_init(&arb_result); |
1942 | ||
1943 | //Grab a pointer to the string representation of | //Grab a pointer to the string representation of |
1944 | //the input argument. The storage does not belong to us. | //the input argument. The storage does not belong to us. |
1945 | fac_arg = Tcl_GetString(objv[2]); | fac_arg = Tcl_GetString(objv[2]); |
1946 | assert(fac_arg != NULL); | assert(fac_arg != NULL); |
1947 | ||
1948 | //Try to interpret the string as one of the NAN tags. | //Try to interpret the string as one of the NAN tags. |
1949 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
1950 | //a unary operation. | //a unary operation. |
1951 | if ((i = GMP_INTS_identify_nan_string(fac_arg)) >= 0) | if ((i = GMP_INTS_identify_nan_string(fac_arg)) >= 0) |
1952 | { | { |
1953 | const char *p; | const char *p; |
1954 | ||
1955 | switch (i) | switch (i) |
1956 | { | { |
1957 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
1958 | break; | break; |
1959 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
1960 | break; | break; |
1961 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
1962 | break; | break; |
1963 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
1964 | break; | break; |
1965 | default: | default: |
1966 | assert(0); | assert(0); |
1967 | break; | break; |
1968 | } | } |
1969 | ||
1970 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
1971 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1972 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1973 | return(TCL_OK); | return(TCL_OK); |
1974 | } | } |
1975 | ||
1976 | //Try to convert the string to a UINT32 using all | //Try to convert the string to a UINT32 using all |
1977 | //known methods. | //known methods. |
1978 | GMP_INTS_mpz_parse_into_uint32(&fac_ui_arg, &failure, fac_arg); | GMP_INTS_mpz_parse_into_uint32(&fac_ui_arg, &failure, fac_arg); |
1979 | ||
1980 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
1981 | //message. | //message. |
1982 | if (failure) | if (failure) |
1983 | { | { |
1984 | rv = Tcl_NewStringObj("arbint intfac: \"", -1); | rv = Tcl_NewStringObj("arbint intfac: \"", -1); |
1985 | Tcl_AppendToObj(rv, fac_arg, -1); | Tcl_AppendToObj(rv, fac_arg, -1); |
1986 | Tcl_AppendToObj(rv, "\" is not a recognized 32-bit unsigned integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized 32-bit unsigned integer.", -1); |
1987 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
1988 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
1989 | return(TCL_ERROR); | return(TCL_ERROR); |
1990 | } | } |
1991 | ||
1992 | //Calculate the factorial. | //Calculate the factorial. |
1993 | GMP_INTS_mpz_fac_ui(&arb_result, fac_ui_arg); | GMP_INTS_mpz_fac_ui(&arb_result, fac_ui_arg); |
1994 | ||
1995 | //Figure out the number of characters required for | //Figure out the number of characters required for |
1996 | //the output string. | //the output string. |
1997 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); |
1998 | ||
1999 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
2000 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
2001 | assert(string_result != NULL); | assert(string_result != NULL); |
2002 | ||
2003 | //Make the conversion to a character string. | //Make the conversion to a character string. |
2004 | GMP_INTS_mpz_to_string(string_result, &arb_result); | GMP_INTS_mpz_to_string(string_result, &arb_result); |
2005 | ||
2006 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
2007 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
2008 | ||
2009 | //Deallocate the string. | //Deallocate the string. |
2010 | TclpFree(string_result); | TclpFree(string_result); |
2011 | ||
2012 | //Deallocate space for the arbitrary-length integer. | //Deallocate space for the arbitrary-length integer. |
2013 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2014 | ||
2015 | //Assign the result to be the return value. | //Assign the result to be the return value. |
2016 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2017 | ||
2018 | //Return | //Return |
2019 | return(TCL_OK); | return(TCL_OK); |
2020 | } | } |
2021 | } | } |
2022 | ||
2023 | ||
2024 | //Handles the "intgcd" subextension. | //Handles the "intgcd" subextension. |
2025 | //08/06/01: Visual inspection OK. | //08/06/01: Visual inspection OK. |
2026 | static | static |
2027 | int ARBLENINTS_intgcd_handler(ClientData dummy, | int ARBLENINTS_intgcd_handler(ClientData dummy, |
2028 | Tcl_Interp *interp, | Tcl_Interp *interp, |
2029 | int objc, | int objc, |
2030 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
2031 | { | { |
2032 | Tcl_Obj *rv; | Tcl_Obj *rv; |
2033 | ||
2034 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
2035 | //to this function, which are the integers whose | //to this function, which are the integers whose |
2036 | //gcd is to be calculated. | //gcd is to be calculated. |
2037 | if (objc != 4) | if (objc != 4) |
2038 | { | { |
2039 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
2040 | 2, | 2, |
2041 | objv, | objv, |
2042 | "sint sint"); | "sint sint"); |
2043 | return(TCL_ERROR); | return(TCL_ERROR); |
2044 | } | } |
2045 | else | else |
2046 | { | { |
2047 | GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result; | GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result; |
2048 | char *gcd_arg1, *gcd_arg2; | char *gcd_arg1, *gcd_arg2; |
2049 | int failure1, failure2; | int failure1, failure2; |
2050 | unsigned chars_reqd; | unsigned chars_reqd; |
2051 | char *string_result; | char *string_result; |
2052 | int i, j; | int i, j; |
2053 | ||
2054 | //Allocate space for the arbitrary-length integer result. | //Allocate space for the arbitrary-length integer result. |
2055 | GMP_INTS_mpz_init(&arb_arg1); | GMP_INTS_mpz_init(&arb_arg1); |
2056 | GMP_INTS_mpz_init(&arb_arg2); | GMP_INTS_mpz_init(&arb_arg2); |
2057 | GMP_INTS_mpz_init(&arb_result); | GMP_INTS_mpz_init(&arb_result); |
2058 | ||
2059 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
2060 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
2061 | gcd_arg1 = Tcl_GetString(objv[2]); | gcd_arg1 = Tcl_GetString(objv[2]); |
2062 | assert(gcd_arg1 != NULL); | assert(gcd_arg1 != NULL); |
2063 | gcd_arg2 = Tcl_GetString(objv[3]); | gcd_arg2 = Tcl_GetString(objv[3]); |
2064 | assert(gcd_arg2 != NULL); | assert(gcd_arg2 != NULL); |
2065 | ||
2066 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
2067 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
2068 | //a binary operation. | //a binary operation. |
2069 | i = GMP_INTS_identify_nan_string(gcd_arg1); | i = GMP_INTS_identify_nan_string(gcd_arg1); |
2070 | j = GMP_INTS_identify_nan_string(gcd_arg2); | j = GMP_INTS_identify_nan_string(gcd_arg2); |
2071 | ||
2072 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
2073 | { | { |
2074 | const char *p; | const char *p; |
2075 | ||
2076 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
2077 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
2078 | //we do. | //we do. |
2079 | if (i > j) | if (i > j) |
2080 | ; | ; |
2081 | else | else |
2082 | i = j; | i = j; |
2083 | ||
2084 | //i now contains the max. | //i now contains the max. |
2085 | switch (i) | switch (i) |
2086 | { | { |
2087 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
2088 | break; | break; |
2089 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
2090 | break; | break; |
2091 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
2092 | break; | break; |
2093 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
2094 | break; | break; |
2095 | default: | default: |
2096 | assert(0); | assert(0); |
2097 | break; | break; |
2098 | } | } |
2099 | ||
2100 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
2101 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2102 | ||
2103 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2104 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2105 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2106 | ||
2107 | return(TCL_OK); | return(TCL_OK); |
2108 | } | } |
2109 | ||
2110 | //Try to convert both strings into arbitrary integers. | //Try to convert both strings into arbitrary integers. |
2111 | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, gcd_arg1); | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, gcd_arg1); |
2112 | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, gcd_arg2); | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, gcd_arg2); |
2113 | ||
2114 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
2115 | //message. It is possible that both arguments failed the parse, | //message. It is possible that both arguments failed the parse, |
2116 | //but only return one in the error message. | //but only return one in the error message. |
2117 | if (failure1 || failure2) | if (failure1 || failure2) |
2118 | { | { |
2119 | rv = Tcl_NewStringObj("arbint intgcd: \"", -1); | rv = Tcl_NewStringObj("arbint intgcd: \"", -1); |
2120 | if (failure1) | if (failure1) |
2121 | Tcl_AppendToObj(rv, gcd_arg1, -1); | Tcl_AppendToObj(rv, gcd_arg1, -1); |
2122 | else | else |
2123 | Tcl_AppendToObj(rv, gcd_arg2, -1); | Tcl_AppendToObj(rv, gcd_arg2, -1); |
2124 | ||
2125 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
2126 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2127 | ||
2128 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2129 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2130 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2131 | ||
2132 | return(TCL_ERROR); | return(TCL_ERROR); |
2133 | } | } |
2134 | ||
2135 | //Calculate the gcd. | //Calculate the gcd. |
2136 | GMP_INTS_mpz_gcd(&arb_result, &arb_arg1, &arb_arg2); | GMP_INTS_mpz_gcd(&arb_result, &arb_arg1, &arb_arg2); |
2137 | ||
2138 | //Figure out the number of characters required for | //Figure out the number of characters required for |
2139 | //the output string. | //the output string. |
2140 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); |
2141 | ||
2142 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
2143 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
2144 | assert(string_result != NULL); | assert(string_result != NULL); |
2145 | ||
2146 | //Make the conversion to a character string. | //Make the conversion to a character string. |
2147 | GMP_INTS_mpz_to_string(string_result, &arb_result); | GMP_INTS_mpz_to_string(string_result, &arb_result); |
2148 | ||
2149 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
2150 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
2151 | ||
2152 | //Deallocate the string. | //Deallocate the string. |
2153 | TclpFree(string_result); | TclpFree(string_result); |
2154 | ||
2155 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
2156 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2157 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2158 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2159 | ||
2160 | //Assign the result to be the return value. | //Assign the result to be the return value. |
2161 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2162 | ||
2163 | //Return | //Return |
2164 | return(TCL_OK); | return(TCL_OK); |
2165 | } | } |
2166 | } | } |
2167 | ||
2168 | ||
2169 | //Handles the "intlcm" subextension. | //Handles the "intlcm" subextension. |
2170 | //08/10/01: Visual inspection OK. | //08/10/01: Visual inspection OK. |
2171 | static | static |
2172 | int ARBLENINTS_intlcm_handler(ClientData dummy, | int ARBLENINTS_intlcm_handler(ClientData dummy, |
2173 | Tcl_Interp *interp, | Tcl_Interp *interp, |
2174 | int objc, | int objc, |
2175 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
2176 | { | { |
2177 | Tcl_Obj *rv; | Tcl_Obj *rv; |
2178 | ||
2179 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
2180 | //to this function, which are the integers whose | //to this function, which are the integers whose |
2181 | //lcm is to be calculated. | //lcm is to be calculated. |
2182 | if (objc != 4) | if (objc != 4) |
2183 | { | { |
2184 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
2185 | 2, | 2, |
2186 | objv, | objv, |
2187 | "sint sint"); | "sint sint"); |
2188 | return(TCL_ERROR); | return(TCL_ERROR); |
2189 | } | } |
2190 | else | else |
2191 | { | { |
2192 | GMP_INTS_mpz_struct arb_arg1, arb_arg2, gcd, remainder, arb_result; | GMP_INTS_mpz_struct arb_arg1, arb_arg2, gcd, remainder, arb_result; |
2193 | char *lcm_arg1, *lcm_arg2; | char *lcm_arg1, *lcm_arg2; |
2194 | int failure1, failure2; | int failure1, failure2; |
2195 | unsigned chars_reqd; | unsigned chars_reqd; |
2196 | char *string_result; | char *string_result; |
2197 | int i, j; | int i, j; |
2198 | ||
2199 | //Allocate space for the arbitrary-length integers. | //Allocate space for the arbitrary-length integers. |
2200 | GMP_INTS_mpz_init(&arb_arg1); | GMP_INTS_mpz_init(&arb_arg1); |
2201 | GMP_INTS_mpz_init(&arb_arg2); | GMP_INTS_mpz_init(&arb_arg2); |
2202 | GMP_INTS_mpz_init(&gcd); | GMP_INTS_mpz_init(&gcd); |
2203 | GMP_INTS_mpz_init(&remainder); | GMP_INTS_mpz_init(&remainder); |
2204 | GMP_INTS_mpz_init(&arb_result); | GMP_INTS_mpz_init(&arb_result); |
2205 | ||
2206 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
2207 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
2208 | lcm_arg1 = Tcl_GetString(objv[2]); | lcm_arg1 = Tcl_GetString(objv[2]); |
2209 | assert(lcm_arg1 != NULL); | assert(lcm_arg1 != NULL); |
2210 | lcm_arg2 = Tcl_GetString(objv[3]); | lcm_arg2 = Tcl_GetString(objv[3]); |
2211 | assert(lcm_arg2 != NULL); | assert(lcm_arg2 != NULL); |
2212 | ||
2213 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
2214 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
2215 | //a binary operation. | //a binary operation. |
2216 | i = GMP_INTS_identify_nan_string(lcm_arg1); | i = GMP_INTS_identify_nan_string(lcm_arg1); |
2217 | j = GMP_INTS_identify_nan_string(lcm_arg2); | j = GMP_INTS_identify_nan_string(lcm_arg2); |
2218 | ||
2219 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
2220 | { | { |
2221 | const char *p; | const char *p; |
2222 | ||
2223 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
2224 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
2225 | //we do. | //we do. |
2226 | if (i > j) | if (i > j) |
2227 | ; | ; |
2228 | else | else |
2229 | i = j; | i = j; |
2230 | ||
2231 | //i now contains the max. | //i now contains the max. |
2232 | switch (i) | switch (i) |
2233 | { | { |
2234 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
2235 | break; | break; |
2236 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
2237 | break; | break; |
2238 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
2239 | break; | break; |
2240 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
2241 | break; | break; |
2242 | default: | default: |
2243 | assert(0); | assert(0); |
2244 | break; | break; |
2245 | } | } |
2246 | ||
2247 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
2248 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2249 | ||
2250 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2251 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2252 | GMP_INTS_mpz_clear(&gcd); | GMP_INTS_mpz_clear(&gcd); |
2253 | GMP_INTS_mpz_clear(&remainder); | GMP_INTS_mpz_clear(&remainder); |
2254 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2255 | ||
2256 | return(TCL_OK); | return(TCL_OK); |
2257 | } | } |
2258 | ||
2259 | //Try to convert both strings into arbitrary integers. | //Try to convert both strings into arbitrary integers. |
2260 | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, lcm_arg1); | GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, lcm_arg1); |
2261 | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, lcm_arg2); | GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, lcm_arg2); |
2262 | ||
2263 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
2264 | //message. It is possible that both arguments failed the parse, | //message. It is possible that both arguments failed the parse, |
2265 | //but only return one in the error message. | //but only return one in the error message. |
2266 | if (failure1 || failure2) | if (failure1 || failure2) |
2267 | { | { |
2268 | rv = Tcl_NewStringObj("arbint intlcm: \"", -1); | rv = Tcl_NewStringObj("arbint intlcm: \"", -1); |
2269 | if (failure1) | if (failure1) |
2270 | Tcl_AppendToObj(rv, lcm_arg1, -1); | Tcl_AppendToObj(rv, lcm_arg1, -1); |
2271 | else | else |
2272 | Tcl_AppendToObj(rv, lcm_arg2, -1); | Tcl_AppendToObj(rv, lcm_arg2, -1); |
2273 | ||
2274 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
2275 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2276 | ||
2277 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2278 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2279 | GMP_INTS_mpz_clear(&gcd); | GMP_INTS_mpz_clear(&gcd); |
2280 | GMP_INTS_mpz_clear(&remainder); | GMP_INTS_mpz_clear(&remainder); |
2281 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2282 | ||
2283 | return(TCL_ERROR); | return(TCL_ERROR); |
2284 | } | } |
2285 | ||
2286 | //Adjust errant arguments. | //Adjust errant arguments. |
2287 | if (GMP_INTS_mpz_is_neg(&arb_arg1)) | if (GMP_INTS_mpz_is_neg(&arb_arg1)) |
2288 | GMP_INTS_mpz_negate(&arb_arg1); | GMP_INTS_mpz_negate(&arb_arg1); |
2289 | else if (GMP_INTS_mpz_is_zero(&arb_arg1)) | else if (GMP_INTS_mpz_is_zero(&arb_arg1)) |
2290 | GMP_INTS_mpz_set_ui(&arb_arg1, 1); | GMP_INTS_mpz_set_ui(&arb_arg1, 1); |
2291 | if (GMP_INTS_mpz_is_neg(&arb_arg2)) | if (GMP_INTS_mpz_is_neg(&arb_arg2)) |
2292 | GMP_INTS_mpz_negate(&arb_arg2); | GMP_INTS_mpz_negate(&arb_arg2); |
2293 | else if (GMP_INTS_mpz_is_zero(&arb_arg2)) | else if (GMP_INTS_mpz_is_zero(&arb_arg2)) |
2294 | GMP_INTS_mpz_set_ui(&arb_arg2, 1); | GMP_INTS_mpz_set_ui(&arb_arg2, 1); |
2295 | ||
2296 | //Calculate the gcd. | //Calculate the gcd. |
2297 | GMP_INTS_mpz_gcd(&gcd, &arb_arg1, &arb_arg2); | GMP_INTS_mpz_gcd(&gcd, &arb_arg1, &arb_arg2); |
2298 | ||
2299 | //Calculate the lcm. | //Calculate the lcm. |
2300 | GMP_INTS_mpz_mul(&arb_arg1, &arb_arg1, &arb_arg2); | GMP_INTS_mpz_mul(&arb_arg1, &arb_arg1, &arb_arg2); |
2301 | GMP_INTS_mpz_tdiv_qr(&arb_result, &remainder, | GMP_INTS_mpz_tdiv_qr(&arb_result, &remainder, |
2302 | &arb_arg1, &gcd); | &arb_arg1, &gcd); |
2303 | ||
2304 | //Figure out the number of characters required for | //Figure out the number of characters required for |
2305 | //the output string. | //the output string. |
2306 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result); |
2307 | ||
2308 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
2309 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
2310 | assert(string_result != NULL); | assert(string_result != NULL); |
2311 | ||
2312 | //Make the conversion to a character string. | //Make the conversion to a character string. |
2313 | GMP_INTS_mpz_to_string(string_result, &arb_result); | GMP_INTS_mpz_to_string(string_result, &arb_result); |
2314 | ||
2315 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
2316 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
2317 | ||
2318 | //Deallocate the string. | //Deallocate the string. |
2319 | TclpFree(string_result); | TclpFree(string_result); |
2320 | ||
2321 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
2322 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2323 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2324 | GMP_INTS_mpz_clear(&gcd); | GMP_INTS_mpz_clear(&gcd); |
2325 | GMP_INTS_mpz_clear(&remainder); | GMP_INTS_mpz_clear(&remainder); |
2326 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2327 | ||
2328 | //Assign the result to be the return value. | //Assign the result to be the return value. |
2329 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2330 | ||
2331 | //Return | //Return |
2332 | return(TCL_OK); | return(TCL_OK); |
2333 | } | } |
2334 | } | } |
2335 | ||
2336 | ||
2337 | //Handles the "intmod" subextension. | //Handles the "intmod" subextension. |
2338 | //08/06/01: Visual inspection OK. | //08/06/01: Visual inspection OK. |
2339 | static | static |
2340 | int ARBLENINTS_intmod_handler(ClientData dummy, | int ARBLENINTS_intmod_handler(ClientData dummy, |
2341 | Tcl_Interp *interp, | Tcl_Interp *interp, |
2342 | int objc, | int objc, |
2343 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
2344 | { | { |
2345 | Tcl_Obj *rv; | Tcl_Obj *rv; |
2346 | ||
2347 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
2348 | //to this function, which are the integers whose | //to this function, which are the integers whose |
2349 | //integer quotient is to be calculated. | //integer quotient is to be calculated. |
2350 | if (objc != 4) | if (objc != 4) |
2351 | { | { |
2352 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
2353 | 2, | 2, |
2354 | objv, | objv, |
2355 | "sint sint"); | "sint sint"); |
2356 | return(TCL_ERROR); | return(TCL_ERROR); |
2357 | } | } |
2358 | else | else |
2359 | { | { |
2360 | GMP_INTS_mpz_struct arb_dividend, arb_divisor, arb_quotient, arb_remainder; | GMP_INTS_mpz_struct arb_dividend, arb_divisor, arb_quotient, arb_remainder; |
2361 | char *dividend_arg1, *divisor_arg2; | char *dividend_arg1, *divisor_arg2; |
2362 | int failure1, failure2; | int failure1, failure2; |
2363 | unsigned chars_reqd; | unsigned chars_reqd; |
2364 | char *string_result; | char *string_result; |
2365 | int i, j; | int i, j; |
2366 | ||
2367 | //Allocate space for the arbitrary-length integer arguments and results. | //Allocate space for the arbitrary-length integer arguments and results. |
2368 | GMP_INTS_mpz_init(&arb_dividend); | GMP_INTS_mpz_init(&arb_dividend); |
2369 | GMP_INTS_mpz_init(&arb_divisor); | GMP_INTS_mpz_init(&arb_divisor); |
2370 | GMP_INTS_mpz_init(&arb_quotient); | GMP_INTS_mpz_init(&arb_quotient); |
2371 | GMP_INTS_mpz_init(&arb_remainder); | GMP_INTS_mpz_init(&arb_remainder); |
2372 | ||
2373 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
2374 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
2375 | dividend_arg1 = Tcl_GetString(objv[2]); | dividend_arg1 = Tcl_GetString(objv[2]); |
2376 | assert(dividend_arg1 != NULL); | assert(dividend_arg1 != NULL); |
2377 | divisor_arg2 = Tcl_GetString(objv[3]); | divisor_arg2 = Tcl_GetString(objv[3]); |
2378 | assert(divisor_arg2 != NULL); | assert(divisor_arg2 != NULL); |
2379 | ||
2380 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
2381 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
2382 | //a binary operation. | //a binary operation. |
2383 | i = GMP_INTS_identify_nan_string(dividend_arg1); | i = GMP_INTS_identify_nan_string(dividend_arg1); |
2384 | j = GMP_INTS_identify_nan_string(divisor_arg2); | j = GMP_INTS_identify_nan_string(divisor_arg2); |
2385 | ||
2386 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
2387 | { | { |
2388 | const char *p; | const char *p; |
2389 | ||
2390 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
2391 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
2392 | //we do. | //we do. |
2393 | if (i > j) | if (i > j) |
2394 | ; | ; |
2395 | else | else |
2396 | i = j; | i = j; |
2397 | ||
2398 | //i now contains the max. | //i now contains the max. |
2399 | switch (i) | switch (i) |
2400 | { | { |
2401 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
2402 | break; | break; |
2403 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
2404 | break; | break; |
2405 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
2406 | break; | break; |
2407 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
2408 | break; | break; |
2409 | default: | default: |
2410 | assert(0); | assert(0); |
2411 | break; | break; |
2412 | } | } |
2413 | ||
2414 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
2415 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2416 | ||
2417 | GMP_INTS_mpz_clear(&arb_dividend); | GMP_INTS_mpz_clear(&arb_dividend); |
2418 | GMP_INTS_mpz_clear(&arb_divisor); | GMP_INTS_mpz_clear(&arb_divisor); |
2419 | GMP_INTS_mpz_clear(&arb_quotient); | GMP_INTS_mpz_clear(&arb_quotient); |
2420 | GMP_INTS_mpz_clear(&arb_remainder); | GMP_INTS_mpz_clear(&arb_remainder); |
2421 | ||
2422 | return(TCL_OK); | return(TCL_OK); |
2423 | } | } |
2424 | ||
2425 | //Try to convert both strings into arbitrary integers. | //Try to convert both strings into arbitrary integers. |
2426 | GMP_INTS_mpz_set_general_int(&arb_dividend, &failure1, dividend_arg1); | GMP_INTS_mpz_set_general_int(&arb_dividend, &failure1, dividend_arg1); |
2427 | GMP_INTS_mpz_set_general_int(&arb_divisor, &failure2, divisor_arg2); | GMP_INTS_mpz_set_general_int(&arb_divisor, &failure2, divisor_arg2); |
2428 | ||
2429 | //If there was a parse failure, we have to return an error | //If there was a parse failure, we have to return an error |
2430 | //message. It is possible that both arguments failed the parse, | //message. It is possible that both arguments failed the parse, |
2431 | //but only return one in the error message. | //but only return one in the error message. |
2432 | if (failure1 || failure2) | if (failure1 || failure2) |
2433 | { | { |
2434 | rv = Tcl_NewStringObj("arbint intmod: \"", -1); | rv = Tcl_NewStringObj("arbint intmod: \"", -1); |
2435 | if (failure1) | if (failure1) |
2436 | Tcl_AppendToObj(rv, dividend_arg1, -1); | Tcl_AppendToObj(rv, dividend_arg1, -1); |
2437 | else | else |
2438 | Tcl_AppendToObj(rv, divisor_arg2, -1); | Tcl_AppendToObj(rv, divisor_arg2, -1); |
2439 | ||
2440 | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); | Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1); |
2441 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2442 | ||
2443 | GMP_INTS_mpz_clear(&arb_dividend); | GMP_INTS_mpz_clear(&arb_dividend); |
2444 | GMP_INTS_mpz_clear(&arb_divisor); | GMP_INTS_mpz_clear(&arb_divisor); |
2445 | GMP_INTS_mpz_clear(&arb_quotient); | GMP_INTS_mpz_clear(&arb_quotient); |
2446 | GMP_INTS_mpz_clear(&arb_remainder); | GMP_INTS_mpz_clear(&arb_remainder); |
2447 | ||
2448 | return(TCL_ERROR); | return(TCL_ERROR); |
2449 | } | } |
2450 | ||
2451 | //Calculate the quotient and remainder. | //Calculate the quotient and remainder. |
2452 | GMP_INTS_mpz_tdiv_qr(&arb_quotient, &arb_remainder, &arb_dividend, &arb_divisor); | GMP_INTS_mpz_tdiv_qr(&arb_quotient, &arb_remainder, &arb_dividend, &arb_divisor); |
2453 | ||
2454 | //Figure out the number of characters required for | //Figure out the number of characters required for |
2455 | //the output string. | //the output string. |
2456 | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_remainder); | chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_remainder); |
2457 | ||
2458 | //Allocate space for the conversion result. | //Allocate space for the conversion result. |
2459 | string_result = TclpAlloc(sizeof(char) * chars_reqd); | string_result = TclpAlloc(sizeof(char) * chars_reqd); |
2460 | assert(string_result != NULL); | assert(string_result != NULL); |
2461 | ||
2462 | //Make the conversion to a character string. | //Make the conversion to a character string. |
2463 | GMP_INTS_mpz_to_string(string_result, &arb_remainder); | GMP_INTS_mpz_to_string(string_result, &arb_remainder); |
2464 | ||
2465 | //Assign the string result to a Tcl object. | //Assign the string result to a Tcl object. |
2466 | rv = Tcl_NewStringObj(string_result, -1); | rv = Tcl_NewStringObj(string_result, -1); |
2467 | ||
2468 | //Deallocate the string. | //Deallocate the string. |
2469 | TclpFree(string_result); | TclpFree(string_result); |
2470 | ||
2471 | //Deallocate space for the arbitrary-length integers. | //Deallocate space for the arbitrary-length integers. |
2472 | GMP_INTS_mpz_clear(&arb_dividend); | GMP_INTS_mpz_clear(&arb_dividend); |
2473 | GMP_INTS_mpz_clear(&arb_divisor); | GMP_INTS_mpz_clear(&arb_divisor); |
2474 | GMP_INTS_mpz_clear(&arb_quotient); | GMP_INTS_mpz_clear(&arb_quotient); |
2475 | GMP_INTS_mpz_clear(&arb_remainder); | GMP_INTS_mpz_clear(&arb_remainder); |
2476 | ||
2477 | //Assign the result to be the return value. | //Assign the result to be the return value. |
2478 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2479 | ||
2480 | //Return | //Return |
2481 | return(TCL_OK); | return(TCL_OK); |
2482 | } | } |
2483 | } | } |
2484 | ||
2485 | ||
2486 | //Handles the "intmul" subextension. | //Handles the "intmul" subextension. |
2487 | //08/06/01: Visual inspection OK. | //08/06/01: Visual inspection OK. |
2488 | static | static |
2489 | int ARBLENINTS_intmul_handler(ClientData dummy, | int ARBLENINTS_intmul_handler(ClientData dummy, |
2490 | Tcl_Interp *interp, | Tcl_Interp *interp, |
2491 | int objc, | int objc, |
2492 | Tcl_Obj *objv[]) | Tcl_Obj *objv[]) |
2493 | { | { |
2494 | Tcl_Obj *rv; | Tcl_Obj *rv; |
2495 | ||
2496 | //We must have two and exactly two additional arguments | //We must have two and exactly two additional arguments |
2497 | //to this function, which are the integers whose | //to this function, which are the integers whose |
2498 | //product is to be calculated. | //product is to be calculated. |
2499 | if (objc != 4) | if (objc != 4) |
2500 | { | { |
2501 | Tcl_WrongNumArgs(interp, | Tcl_WrongNumArgs(interp, |
2502 | 2, | 2, |
2503 | objv, | objv, |
2504 | "sint sint"); | "sint sint"); |
2505 | return(TCL_ERROR); | return(TCL_ERROR); |
2506 | } | } |
2507 | else | else |
2508 | { | { |
2509 | GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result; | GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result; |
2510 | char *mul_arg1, *mul_arg2; | char *mul_arg1, *mul_arg2; |
2511 | int failure1, failure2; | int failure1, failure2; |
2512 | unsigned chars_reqd; | unsigned chars_reqd; |
2513 | char *string_result; | char *string_result; |
2514 | int i, j; | int i, j; |
2515 | ||
2516 | //Allocate space for the arbitrary-length integer result. | //Allocate space for the arbitrary-length integer result. |
2517 | GMP_INTS_mpz_init(&arb_arg1); | GMP_INTS_mpz_init(&arb_arg1); |
2518 | GMP_INTS_mpz_init(&arb_arg2); | GMP_INTS_mpz_init(&arb_arg2); |
2519 | GMP_INTS_mpz_init(&arb_result); | GMP_INTS_mpz_init(&arb_result); |
2520 | ||
2521 | //Grab pointers to the string representation of | //Grab pointers to the string representation of |
2522 | //the input arguments. The storage does not belong to us. | //the input arguments. The storage does not belong to us. |
2523 | mul_arg1 = Tcl_GetString(objv[2]); | mul_arg1 = Tcl_GetString(objv[2]); |
2524 | assert(mul_arg1 != NULL); | assert(mul_arg1 != NULL); |
2525 | mul_arg2 = Tcl_GetString(objv[3]); | mul_arg2 = Tcl_GetString(objv[3]); |
2526 | assert(mul_arg2 != NULL); | assert(mul_arg2 != NULL); |
2527 | ||
2528 | //Try to interpret either of the strings as one of the NAN tags. | //Try to interpret either of the strings as one of the NAN tags. |
2529 | //If it is one, return the appropriate result for | //If it is one, return the appropriate result for |
2530 | //a binary operation. | //a binary operation. |
2531 | i = GMP_INTS_identify_nan_string(mul_arg1); | i = GMP_INTS_identify_nan_string(mul_arg1); |
2532 | j = GMP_INTS_identify_nan_string(mul_arg2); | j = GMP_INTS_identify_nan_string(mul_arg2); |
2533 | ||
2534 | if ((i >= 0) || (j >= 0)) | if ((i >= 0) || (j >= 0)) |
2535 | { | { |
2536 | const char *p; | const char *p; |
2537 | ||
2538 | //Find the max of i and j. This isn't a scientific way to tag the | //Find the max of i and j. This isn't a scientific way to tag the |
2539 | //result, but will be OK. Some information is lost no matter what | //result, but will be OK. Some information is lost no matter what |
2540 | //we do. | //we do. |
2541 | if (i > j) | if (i > j) |
2542 | ; | ; |
2543 | else | else |
2544 | i = j; | i = j; |
2545 | ||
2546 | //i now contains the max. | //i now contains the max. |
2547 | switch (i) | switch (i) |
2548 | { | { |
2549 | case 0: p = GMP_INTS_supply_nan_string(2); | case 0: p = GMP_INTS_supply_nan_string(2); |
2550 | break; | break; |
2551 | case 1: p = GMP_INTS_supply_nan_string(3); | case 1: p = GMP_INTS_supply_nan_string(3); |
2552 | break; | break; |
2553 | case 2: p = GMP_INTS_supply_nan_string(2); | case 2: p = GMP_INTS_supply_nan_string(2); |
2554 | break; | break; |
2555 | case 3: p = GMP_INTS_supply_nan_string(3); | case 3: p = GMP_INTS_supply_nan_string(3); |
2556 | break; | break; |
2557 | default: | default: |
2558 | assert(0); | assert(0); |
2559 | break; | break; |
2560 | } | } |
2561 | ||
2562 | rv = Tcl_NewStringObj(p, -1); | rv = Tcl_NewStringObj(p, -1); |
2563 | Tcl_SetObjResult(interp, rv); | Tcl_SetObjResult(interp, rv); |
2564 | ||
2565 | GMP_INTS_mpz_clear(&arb_arg1); | GMP_INTS_mpz_clear(&arb_arg1); |
2566 | GMP_INTS_mpz_clear(&arb_arg2); | GMP_INTS_mpz_clear(&arb_arg2); |
2567 | GMP_INTS_mpz_clear(&arb_result); | GMP_INTS_mpz_clear(&arb_result); |
2568 | ||
2569 |