/[dtapublic]/projs/trunk/shared_source/c_tclxtens_7_5/arblenints.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tclxtens_7_5/arblenints.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 68 - (show annotations) (download)
Mon Oct 31 16:18:20 2016 UTC (6 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 132351 byte(s)
Licensing change.  Header and footer cleanup.  Addition of keyword expansion.
1 //$Header$
2 //-------------------------------------------------------------------------------------------------
3 //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.
5 //-------------------------------------------------------------------------------------------------
6 //This source code and any program in which it is compiled/used is provided under the MIT License,
7 //reproduced below.
8 //-------------------------------------------------------------------------------------------------
9 //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
11 //Software without restriction, including without limitation the rights to use,
12 //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,
14 //subject to the following conditions :
15 //
16 //The above copyright notice and this permission notice shall be included in all
17 //copies or substantial portions of the Software.
18 //
19 //THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
20 //IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
21 //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
23 //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
25 //SOFTWARE.
26 //-------------------------------------------------------------------------------------------------
27 #define MODULE_ARBLENINTS
28
29 #include <assert.h>
30 #include <string.h>
31
32 #include "tcl.h"
33 #include "tcldecls.h"
34
35 #include "arblenints.h"
36 #include "bstrfunc.h"
37 #include "extninit.h"
38 #include "gmp_ints.h"
39 #include "gmp_rats.h"
40 #include "gmp_ralg.h"
41 #include "intfunc.h"
42 #include "tclalloc.h"
43
44
45 //Handles the "cfbrapab" subextension.
46 //08/16/01: Visual inspection OK.
47 static
48 int ARBLENINTS_cfbrapab_handler(ClientData dummy,
49 Tcl_Interp *interp,
50 int objc,
51 Tcl_Obj *objv[])
52 {
53 Tcl_Obj *rv;
54
55 //We must have at least two additional arguments
56 //to this extension.
57 if (objc < 4)
58 {
59 Tcl_WrongNumArgs(interp,
60 2,
61 objv,
62 "srn uint_kmax ?uint_hmax? ?options?");
63 return(TCL_ERROR);
64 }
65 else
66 {
67 char *input_arg;
68 int failure, first_dashed_parameter;
69 char *string_result;
70 int string_result_n_allocd;
71 int chars_reqd;
72 int i;
73 int pred_option_specified = 0;
74 int succ_option_specified = 0;
75 int neversmaller_option_specified = 0;
76 int neverlarger_option_specified = 0;
77 int n_option_specified = 0;
78 unsigned n = 0;
79
80 GMP_RATS_mpq_struct q_rn;
81 GMP_INTS_mpz_struct z_kmax;
82 GMP_INTS_mpz_struct z_hmax;
83
84 //Allocate dynamic memory.
85 GMP_RATS_mpq_init(&q_rn);
86 GMP_INTS_mpz_init(&z_kmax);
87 GMP_INTS_mpz_init(&z_hmax);
88
89 //Grab a pointer to the string representation of
90 //the first input argument. The storage does not belong to us.
91 input_arg = Tcl_GetString(objv[2]);
92 assert(input_arg != NULL);
93
94 //Try to parse our first input string as a rational number.
95 //If we are not successful in this, must abort.
96 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
97 &failure,
98 &q_rn);
99
100 if (failure)
101 {
102 rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1);
103 Tcl_AppendToObj(rv, input_arg, -1);
104
105 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
106 Tcl_SetObjResult(interp, rv);
107
108 GMP_RATS_mpq_clear(&q_rn);
109 GMP_INTS_mpz_clear(&z_kmax);
110 GMP_INTS_mpz_clear(&z_hmax);
111
112 return(TCL_ERROR);
113 }
114
115 //Try to parse our next argument as an integer, which
116 //will be KMAX. This must be specified.
117 //
118 //Get string pointer. Storage does not belong to us.
119 input_arg = Tcl_GetString(objv[3]);
120 assert(input_arg != NULL);
121
122 //Try to convert KMAX to an integer. Fatal if an error,
123 //and fatal if the argument is zero or negative.
124 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
127 //or negative, must flag error.
128 if (failure || GMP_INTS_mpz_is_neg(&z_kmax) || GMP_INTS_mpz_is_zero(&z_kmax))
129 {
130 rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1);
131 Tcl_AppendToObj(rv, input_arg, -1);
132 Tcl_AppendToObj(rv, "\" is not a recognized positive integer.", -1);
133 Tcl_SetObjResult(interp, rv);
134
135 GMP_RATS_mpq_clear(&q_rn);
136 GMP_INTS_mpz_clear(&z_kmax);
137 GMP_INTS_mpz_clear(&z_hmax);
138
139 return(TCL_ERROR);
140 }
141
142 //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
144 //parameter begins with a "-" or not.
145 if (objc >= 5)
146 {
147 input_arg = Tcl_GetString(objv[4]);
148 assert(input_arg != NULL);
149
150 if (input_arg[0] == '-')
151 {
152 first_dashed_parameter = 4;
153 }
154 else
155 {
156 first_dashed_parameter = 5;
157 }
158 }
159 else
160 {
161 first_dashed_parameter = 4;
162 }
163
164 //If there is another parameter and it
165 //doesn't begin with a dash, try to parse
166 //it as HMAX. We don't explicitly record whether
167 //HMAX is specified, because zero is a signal
168 //when calculating Farey neighbors that HMAX isn't
169 //to be considered.
170 if ((objc >= 5) && (first_dashed_parameter == 5))
171 {
172 //Get string pointer. Storage does not belong to us.
173 input_arg = Tcl_GetString(objv[4]);
174 assert(input_arg != NULL);
175
176 //Try to convert HMAX to an integer. Fatal if an error,
177 //and fatal if the argument is zero or negative.
178 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
181 //or negative, must flag error.
182 if (failure || GMP_INTS_mpz_is_neg(&z_hmax) || GMP_INTS_mpz_is_zero(&z_hmax))
183 {
184 rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1);
185 Tcl_AppendToObj(rv, input_arg, -1);
186 Tcl_AppendToObj(rv, "\" is not a recognized positive integer.", -1);
187 Tcl_SetObjResult(interp, rv);
188
189 GMP_RATS_mpq_clear(&q_rn);
190 GMP_INTS_mpz_clear(&z_kmax);
191 GMP_INTS_mpz_clear(&z_hmax);
192
193 return(TCL_ERROR);
194 }
195 }
196
197 //Process all of the dashed command-line arguments.
198 //This involves iterating through all of the
199 //parameters and processing them.
200 for (i=first_dashed_parameter; i<objc; i++)
201 {
202 input_arg = Tcl_GetString(objv[i]);
203 assert(input_arg != NULL);
204
205 if (!strcmp("-pred", input_arg))
206 {
207 pred_option_specified = 1;
208 }
209 else if (!strcmp("-succ", input_arg))
210 {
211 succ_option_specified = 1;
212 }
213 else if (!strcmp("-neversmaller", input_arg))
214 {
215 neversmaller_option_specified = 1;
216 }
217 else if (!strcmp("-neverlarger", input_arg))
218 {
219 neverlarger_option_specified = 1;
220 }
221 else if (!strcmp("-n", input_arg))
222 {
223 n_option_specified = 1;
224
225 //If -n was specified, there must be a following
226 //parameter which supplies the integer. First
227 //check for existence of an additional parameter.
228 if (i >= (objc - 1))
229 {
230 rv = Tcl_NewStringObj("arbint cfbrapab: -n option specified without following integer.", -1);
231 Tcl_SetObjResult(interp, rv);
232
233 GMP_RATS_mpq_clear(&q_rn);
234 GMP_INTS_mpz_clear(&z_kmax);
235 GMP_INTS_mpz_clear(&z_hmax);
236
237 return(TCL_ERROR);
238 }
239
240 //We have at least one additional parameter. Try
241 //to parse out the next parameter as the integer
242 //we need for n.
243 i++;
244
245 input_arg = Tcl_GetString(objv[i]);
246 assert(input_arg != NULL);
247
248 GMP_INTS_mpz_parse_into_uint32(&n, &failure, input_arg);
249
250 //If the parse was unsuccessful, terminate.
251 if (failure)
252 {
253 rv = Tcl_NewStringObj("arbint cfbrapab: -n option followed by invalid integer.", -1);
254 Tcl_SetObjResult(interp, rv);
255
256 GMP_RATS_mpq_clear(&q_rn);
257 GMP_INTS_mpz_clear(&z_kmax);
258 GMP_INTS_mpz_clear(&z_hmax);
259
260 return(TCL_ERROR);
261 }
262
263 //Clip the integer into a 24-bit quantity.
264 n &= 0x00FFFFFF;
265 }
266 else
267 {
268 //Unrecognized option. Crash out.
269 rv = Tcl_NewStringObj("arbint cfbrapab: \"", -1);
270 Tcl_AppendToObj(rv, input_arg, -1);
271 Tcl_AppendToObj(rv, "\" is not a recognized option.", -1);
272 Tcl_SetObjResult(interp, rv);
273
274 GMP_RATS_mpq_clear(&q_rn);
275 GMP_INTS_mpz_clear(&z_kmax);
276 GMP_INTS_mpz_clear(&z_hmax);
277
278 return(TCL_ERROR);
279 }
280 }
281
282 //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
284 //way to do this.
285 if ((pred_option_specified + succ_option_specified + neversmaller_option_specified
286 + 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);
289 Tcl_SetObjResult(interp, rv);
290
291 GMP_RATS_mpq_clear(&q_rn);
292 GMP_INTS_mpz_clear(&z_kmax);
293 GMP_INTS_mpz_clear(&z_hmax);
294
295 return(TCL_ERROR);
296 }
297
298 //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
300 //create a hard error if something goes wrong. Any anomalies should trash
301 //a script.
302 if (!pred_option_specified && !succ_option_specified && !n_option_specified)
303 {
304 //This is the traditional best approximation case, with the possibility of
305 //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,
307 //and if there is a tie, which has the smaller magnitude. It is fairly
308 //messy.
309 GMP_RALG_fab_neighbor_collection_struct neighbor_data;
310 GMP_RATS_mpq_struct left_neigh, right_neigh, diff_left, diff_right, closer_neighbor;
311 int dist_cmp;
312 int mag_cmp;
313
314 //Allocate inner dynamic variables.
315 GMP_RATS_mpq_init(&left_neigh);
316 GMP_RATS_mpq_init(&right_neigh);
317 GMP_RATS_mpq_init(&diff_left);
318 GMP_RATS_mpq_init(&diff_right);
319 GMP_RATS_mpq_init(&closer_neighbor);
320
321 //Form up the neighbor data. We're only looking for up to one neighbor on each
322 //side.
323 GMP_RALG_consecutive_fab_terms(
324 &q_rn,
325 &z_kmax,
326 &z_hmax,
327 1,
328 1,
329 &neighbor_data
330 );
331
332 //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
334 //complete.
335 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);
338 Tcl_SetObjResult(interp, rv);
339
340 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
341 GMP_RATS_mpq_clear(&q_rn);
342 GMP_INTS_mpz_clear(&z_kmax);
343 GMP_INTS_mpz_clear(&z_hmax);
344
345 GMP_RATS_mpq_clear(&left_neigh);
346 GMP_RATS_mpq_clear(&right_neigh);
347 GMP_RATS_mpq_clear(&diff_left);
348 GMP_RATS_mpq_clear(&diff_right);
349 GMP_RATS_mpq_clear(&closer_neighbor);
350
351 return(TCL_ERROR);
352 }
353
354 if (neighbor_data.equality)
355 {
356 //The equality case takes precedence, always.
357 GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.norm_rn));
358 }
359 else
360 {
361 //The boolean test somewhat above guaranteed that we have both left
362 //and right neighbors. We can assume this.
363 GMP_RATS_mpq_copy(&left_neigh, &(neighbor_data.lefts[0].neighbor));
364 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));
367 GMP_RATS_mpq_sub(&diff_right, &right_neigh, &(neighbor_data.norm_rn));
368 GMP_INTS_mpz_abs(&(diff_left.num));
369 GMP_INTS_mpz_abs(&(diff_right.num));
370 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.
373 GMP_INTS_mpz_abs(&(left_neigh.num));
374 GMP_INTS_mpz_abs(&(right_neigh.num));
375 mag_cmp = GMP_RATS_mpq_cmp(&left_neigh, &right_neigh, NULL);
376
377 if (!neversmaller_option_specified
378 &&
379 (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));
382 }
383 else
384 {
385 GMP_RATS_mpq_copy(&closer_neighbor, &(neighbor_data.rights[0].neighbor));
386 }
387 }
388
389 //Stuff our variable of choice into a string ...
390 chars_reqd = INTFUNC_max(
391 GMP_INTS_mpz_size_in_base_10(&(closer_neighbor.num)),
392 GMP_INTS_mpz_size_in_base_10(&(closer_neighbor.den))
393 );
394 string_result = TclpAlloc(sizeof(char) * chars_reqd);
395 assert(string_result != NULL);
396
397 GMP_INTS_mpz_to_string(string_result, &(closer_neighbor.num));
398 rv = Tcl_NewStringObj(string_result, -1);
399 Tcl_AppendToObj(rv, "/", -1);
400 GMP_INTS_mpz_to_string(string_result, &(closer_neighbor.den));
401 Tcl_AppendToObj(rv, string_result, -1);
402
403 Tcl_SetObjResult(interp, rv);
404
405 //Deallocate variables, make normal return.
406 TclpFree(string_result);
407 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
408 GMP_RATS_mpq_clear(&q_rn);
409 GMP_INTS_mpz_clear(&z_kmax);
410 GMP_INTS_mpz_clear(&z_hmax);
411
412 GMP_RATS_mpq_clear(&left_neigh);
413 GMP_RATS_mpq_clear(&right_neigh);
414 GMP_RATS_mpq_clear(&diff_left);
415 GMP_RATS_mpq_clear(&diff_right);
416 GMP_RATS_mpq_clear(&closer_neighbor);
417
418 return(TCL_OK);
419 }
420 else if (n_option_specified)
421 {
422 char sbuf[50];
423 //Static buffer just to stage 32-bit integers.
424
425 //Multiple neighbors. Must iterate through.
426
427 GMP_RALG_fab_neighbor_collection_struct neighbor_data;
428
429 //Form up the neighbor data.
430 GMP_RALG_consecutive_fab_terms(
431 &q_rn,
432 &z_kmax,
433 &z_hmax,
434 n,
435 n,
436 &neighbor_data
437 );
438
439 //If there was an error forming up the neighbor data, create a hard error.
440 if (neighbor_data.error)
441 {
442 rv = Tcl_NewStringObj("arbint cfbrapab: unable to form neighbors.", -1);
443 Tcl_SetObjResult(interp, rv);
444
445 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
446 GMP_RATS_mpq_clear(&q_rn);
447 GMP_INTS_mpz_clear(&z_kmax);
448 GMP_INTS_mpz_clear(&z_hmax);
449
450 return(TCL_ERROR);
451 }
452
453 //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
455 //takes a mean integer to exceed 10K. However, the logic allows it to grow.
456 string_result_n_allocd = 10000;
457 string_result = TclpAlloc(sizeof(char) * string_result_n_allocd);
458 assert(string_result != NULL);
459
460 //Start off with a return value of the null string.
461 rv = Tcl_NewStringObj("", -1);
462
463 //Loop through, spitting out the left neighbors.
464 for (i = neighbor_data.n_left_out-1; i >= 0; i--)
465 {
466 //The protocol here is everyone spits out one space before
467 //they print anything. Must skip this on first loop iteration.
468 if (i != neighbor_data.n_left_out-1)
469 Tcl_AppendToObj(rv, " ", -1);
470
471 //The index will be the negative of the iteration variable minus one.
472 sprintf(sbuf, "%d", -i - 1);
473 Tcl_AppendToObj(rv, sbuf, -1);
474
475 //Force the buffer to have enough space for the components of the rational
476 //number.
477 chars_reqd = INTFUNC_max(
478 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))
480 );
481 if (chars_reqd > string_result_n_allocd)
482 {
483 string_result_n_allocd = chars_reqd;
484 string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd);
485 assert(string_result != NULL);
486 }
487
488 //Print the rational number out to the Tcl object.
489 Tcl_AppendToObj(rv, " ", -1);
490 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[i].neighbor.num));
491 Tcl_AppendToObj(rv, string_result, -1);
492 Tcl_AppendToObj(rv, "/", -1);
493 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[i].neighbor.den));
494 Tcl_AppendToObj(rv, string_result, -1);
495 }
496
497 //Spit out the equality case if appropriate.
498 if (neighbor_data.equality)
499 {
500 if (neighbor_data.n_left_out)
501 Tcl_AppendToObj(rv, " ", -1);
502
503 Tcl_AppendToObj(rv, "0", -1);
504
505 //Force the buffer to have enough space for the components of the rational
506 //number.
507 chars_reqd = INTFUNC_max(
508 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))
510 );
511 if (chars_reqd > string_result_n_allocd)
512 {
513 string_result_n_allocd = chars_reqd;
514 string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd);
515 assert(string_result != NULL);
516 }
517
518 //Print the rational number out to the Tcl object.
519 Tcl_AppendToObj(rv, " ", -1);
520 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.norm_rn.num));
521 Tcl_AppendToObj(rv, string_result, -1);
522 Tcl_AppendToObj(rv, "/", -1);
523 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.norm_rn.den));
524 Tcl_AppendToObj(rv, string_result, -1);
525 }
526
527 //Loop through, spitting out the right neighbors.
528 for (i = 0; i < neighbor_data.n_right_out; i++)
529 {
530 //The protocol here is everyone spits out one space before
531 //they print anything. Must skip this on first loop iteration.
532 if (neighbor_data.n_left_out || neighbor_data.equality || i)
533 Tcl_AppendToObj(rv, " ", -1);
534
535 //The index will be the iteration variable plus one.
536 sprintf(sbuf, "%d", i+1);
537 Tcl_AppendToObj(rv, sbuf, -1);
538
539 //Force the buffer to have enough space for the components of the rational
540 //number.
541 chars_reqd = INTFUNC_max(
542 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))
544 );
545 if (chars_reqd > string_result_n_allocd)
546 {
547 string_result_n_allocd = chars_reqd;
548 string_result = TclpRealloc(string_result, sizeof(char) * string_result_n_allocd);
549 assert(string_result != NULL);
550 }
551
552 //Print the rational number out to the Tcl object.
553 Tcl_AppendToObj(rv, " ", -1);
554 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[i].neighbor.num));
555 Tcl_AppendToObj(rv, string_result, -1);
556 Tcl_AppendToObj(rv, "/", -1);
557 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[i].neighbor.den));
558 Tcl_AppendToObj(rv, string_result, -1);
559 }
560
561 //Set up for a normal return.
562 Tcl_SetObjResult(interp, rv);
563
564 TclpFree(string_result);
565 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
566 GMP_RATS_mpq_clear(&q_rn);
567 GMP_INTS_mpz_clear(&z_kmax);
568 GMP_INTS_mpz_clear(&z_hmax);
569
570 return(TCL_OK);
571 }
572 else if (pred_option_specified)
573 {
574 //Simple predecessor case.
575
576 GMP_RALG_fab_neighbor_collection_struct neighbor_data;
577
578 //Form up the neighbor data.
579 GMP_RALG_consecutive_fab_terms(
580 &q_rn,
581 &z_kmax,
582 &z_hmax,
583 1,
584 0,
585 &neighbor_data
586 );
587
588 //If there was an error forming up the neighbor data or there are no left neighbors,
589 //create a hard error.
590 if (neighbor_data.error || !neighbor_data.n_left_out)
591 {
592 rv = Tcl_NewStringObj("arbint cfbrapab: unable to find predecessor.", -1);
593 Tcl_SetObjResult(interp, rv);
594
595 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
596 GMP_RATS_mpq_clear(&q_rn);
597 GMP_INTS_mpz_clear(&z_kmax);
598 GMP_INTS_mpz_clear(&z_hmax);
599
600 return(TCL_ERROR);
601 }
602
603 //The test above confirmed that we have at least one left neighbor calculated.
604 //We can dump it to a string and finish up.
605 chars_reqd = INTFUNC_max(
606 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))
608 );
609 string_result = TclpAlloc(sizeof(char) * chars_reqd);
610 assert(string_result != NULL);
611
612 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[0].neighbor.num));
613 rv = Tcl_NewStringObj(string_result, -1);
614 Tcl_AppendToObj(rv, "/", -1);
615 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.lefts[0].neighbor.den));
616 Tcl_AppendToObj(rv, string_result, -1);
617
618 Tcl_SetObjResult(interp, rv);
619
620 TclpFree(string_result);
621 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
622 GMP_RATS_mpq_clear(&q_rn);
623 GMP_INTS_mpz_clear(&z_kmax);
624 GMP_INTS_mpz_clear(&z_hmax);
625
626 return(TCL_OK);
627 }
628 else if (succ_option_specified)
629 {
630 //Simple successor.
631
632 GMP_RALG_fab_neighbor_collection_struct neighbor_data;
633
634 //Form up the neighbor data.
635 GMP_RALG_consecutive_fab_terms(
636 &q_rn,
637 &z_kmax,
638 &z_hmax,
639 0,
640 1,
641 &neighbor_data
642 );
643
644 //If there was an error forming up the neighbor data or there are no right neighbors,
645 //create a hard error.
646 if (neighbor_data.error || !neighbor_data.n_right_out)
647 {
648 rv = Tcl_NewStringObj("arbint cfbrapab: unable to find successor.", -1);
649 Tcl_SetObjResult(interp, rv);
650
651 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
652 GMP_RATS_mpq_clear(&q_rn);
653 GMP_INTS_mpz_clear(&z_kmax);
654 GMP_INTS_mpz_clear(&z_hmax);
655
656 return(TCL_ERROR);
657 }
658
659 //The test above confirmed that we have at least one right neighbor calculated.
660 //We can dump it to a string and finish up.
661 chars_reqd = INTFUNC_max(
662 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))
664 );
665 string_result = TclpAlloc(sizeof(char) * chars_reqd);
666 assert(string_result != NULL);
667
668 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[0].neighbor.num));
669 rv = Tcl_NewStringObj(string_result, -1);
670 Tcl_AppendToObj(rv, "/", -1);
671 GMP_INTS_mpz_to_string(string_result, &(neighbor_data.rights[0].neighbor.den));
672 Tcl_AppendToObj(rv, string_result, -1);
673
674 Tcl_SetObjResult(interp, rv);
675
676 TclpFree(string_result);
677 GMP_RALG_consecutive_fab_terms_result_free(&neighbor_data);
678 GMP_RATS_mpq_clear(&q_rn);
679 GMP_INTS_mpz_clear(&z_kmax);
680 GMP_INTS_mpz_clear(&z_hmax);
681
682 return(TCL_OK);
683 }
684
685 //Free up all dynamic memory.
686 GMP_RATS_mpq_clear(&q_rn);
687 GMP_INTS_mpz_clear(&z_kmax);
688 GMP_INTS_mpz_clear(&z_hmax);
689
690 //Return
691 return(TCL_OK);
692 }
693 }
694
695
696 //Handles the "cfratnum" subextension.
697 //08/07/01: Visually inspected, OK.
698 static
699 int ARBLENINTS_cfratnum_handler(ClientData dummy,
700 Tcl_Interp *interp,
701 int objc,
702 Tcl_Obj *objv[])
703 {
704 Tcl_Obj *rv;
705
706 //We must have exactly one additional argument
707 //to this function, which is the rational number
708 //whose continued fraction decomposition is to be
709 //calculated.
710 if (objc != 3)
711 {
712 Tcl_WrongNumArgs(interp,
713 2,
714 objv,
715 "urn");
716 return(TCL_ERROR);
717 }
718 else
719 {
720 char *input_arg;
721 int failure;
722 unsigned chars_reqd;
723 char *string_result;
724 int n_string_result;
725 int i;
726 GMP_RATS_mpq_struct rn;
727 GMP_RALG_cf_app_struct decomp;
728
729 //In this function, we are going to return a string
730 //result formed by starting with a string and then
731 //concatenating to it again and again. We start
732 //off believing that 10,000 characters of space is enough,
733 //but we may need to revise upward and reallocate.
734 //A 10,000 character block is chosen because it is quick
735 //to allocate and most times won't go beyond that.
736 n_string_result = 10000;
737 string_result = TclpAlloc(sizeof(char) * n_string_result);
738 assert(string_result != NULL);
739
740 //We will need a rational number to hold the return value
741 //from the parsing function. Allocate that now.
742 GMP_RATS_mpq_init(&rn);
743
744 //Grab a pointer to the string representation of
745 //the input argument. The storage does not belong to us.
746 input_arg = Tcl_GetString(objv[2]);
747 assert(input_arg != NULL);
748
749 //Try to parse our input string as a rational number.
750 //If we are not successful in this, must abort.
751 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
752 &failure,
753 &rn);
754
755 if (failure)
756 {
757 rv = Tcl_NewStringObj("arbint cfratnum: \"", -1);
758 Tcl_AppendToObj(rv, input_arg, -1);
759
760 Tcl_AppendToObj(rv, "\" is not a recognized non-negative rational number.", -1);
761 Tcl_SetObjResult(interp, rv);
762
763 TclpFree(string_result);
764 GMP_RATS_mpq_clear(&rn);
765
766 return(TCL_ERROR);
767 }
768
769 //OK, we have a rational number, but there is a possibility
770 //it is negative, which is a no-no. Normalize the signs
771 //for easier testing.
772 GMP_RATS_mpq_normalize_sign(&rn);
773 if (GMP_INTS_mpz_is_neg(&(rn.num)))
774 {
775 rv = Tcl_NewStringObj("arbint cfratnum: \"", -1);
776 Tcl_AppendToObj(rv, input_arg, -1);
777
778 Tcl_AppendToObj(rv, "\" is negative.", -1);
779 Tcl_SetObjResult(interp, rv);
780
781 TclpFree(string_result);
782 GMP_RATS_mpq_clear(&rn);
783
784 return(TCL_ERROR);
785 }
786
787 //OK, we have a rational number. Form the continued fraction
788 //decomposition of it. The function called is set up so that
789 //one must deallocate, even in an error condition.
790 GMP_RALG_cfdecomp_init(&decomp,
791 &failure,
792 &(rn.num),
793 &(rn.den));
794
795 //If we failed in the decomposition (don't know why that would
796 //happen) use the general error flag "NAN".
797 if (failure)
798 {
799 rv = Tcl_NewStringObj("NAN", -1);
800
801 Tcl_SetObjResult(interp, rv);
802
803 TclpFree(string_result);
804 GMP_RATS_mpq_clear(&rn);
805 GMP_RALG_cfdecomp_destroy(&decomp);
806
807 return(TCL_ERROR);
808 }
809
810 //OK, that really is the last error we could have.
811 //Iterate, adding the partial quotients and convergents
812 //to the string which we'll return. We need to watch out
813 //for running over our 10K buffer.
814 rv = Tcl_NewStringObj("", -1);
815 for (i=0; i<decomp.n; i++)
816 {
817 //Partial quotient.
818 chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.a[i]));
819 if (chars_reqd > (unsigned)n_string_result)
820 {
821 n_string_result = chars_reqd;
822 string_result = TclpRealloc(string_result,
823 sizeof(char) * n_string_result);
824 }
825 GMP_INTS_mpz_to_string(string_result, &(decomp.a[i]));
826 Tcl_AppendToObj(rv, string_result, -1);
827 Tcl_AppendToObj(rv, " ", -1);
828
829 //Numerator of convergent.
830 chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.p[i]));
831 if (chars_reqd > (unsigned)n_string_result)
832 {
833 n_string_result = chars_reqd;
834 string_result = TclpRealloc(string_result,
835 sizeof(char) * n_string_result);
836 }
837 GMP_INTS_mpz_to_string(string_result, &(decomp.p[i]));
838 Tcl_AppendToObj(rv, string_result, -1);
839 Tcl_AppendToObj(rv, " ", -1);
840
841 //Denominator of convergent.
842 chars_reqd = GMP_INTS_mpz_size_in_base_10(&(decomp.q[i]));
843 if (chars_reqd > (unsigned)n_string_result)
844 {
845 n_string_result = chars_reqd;
846 string_result = TclpRealloc(string_result,
847 sizeof(char) * n_string_result);
848 }
849 GMP_INTS_mpz_to_string(string_result, &(decomp.q[i]));
850 Tcl_AppendToObj(rv, string_result, -1);
851 if (i != (decomp.n - 1)) //No space after last number.
852 Tcl_AppendToObj(rv, " ", -1);
853 }
854
855 //Assign the result to be the return value.
856 Tcl_SetObjResult(interp, rv);
857
858 //Free up all dynamic memory.
859 TclpFree(string_result);
860 GMP_RATS_mpq_clear(&rn);
861 GMP_RALG_cfdecomp_destroy(&decomp);
862
863 //Return
864 return(TCL_OK);
865 }
866 }
867
868
869 //Handles the "commanate" subextension.
870 //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.
872 static
873 int ARBLENINTS_commanate_handler(ClientData dummy,
874 Tcl_Interp *interp,
875 int objc,
876 Tcl_Obj *objv[])
877 {
878 Tcl_Obj *rv;
879
880 //We must have one and exactly one additional argument
881 //to this function, which is the string we want to
882 //commanate.
883 if (objc != 3)
884 {
885 Tcl_WrongNumArgs(interp,
886 2,
887 objv,
888 "sint");
889 return(TCL_ERROR);
890 }
891 else
892 {
893 char *string_arg;
894
895 //Grab a pointer to the string representation of
896 //the input argument. The storage does not belong to us.
897 string_arg = Tcl_GetString(objv[2]);
898 assert(string_arg != NULL);
899
900 //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
902 //want to touch the string.
903 if (GMP_INTS_identify_nan_string(string_arg) >= 0)
904 {
905 rv = Tcl_NewStringObj(string_arg, -1);
906 Tcl_SetObjResult(interp, rv);
907 return(TCL_OK);
908 }
909 //Try to parse it as a signed integer with commas already.
910 //If it already has commas, there is no need to add any.
911 else if (BSTRFUNC_is_sint_w_commas(string_arg))
912 {
913 //This is already an acceptable commanated signed integer. Send it
914 //back as the return value.
915 rv = Tcl_NewStringObj(string_arg, -1);
916 Tcl_SetObjResult(interp, rv);
917 return(TCL_OK);
918 }
919 //Try to parse the argument as a signed integer without commas.
920 //If it is one of those, commanate it and return it.
921 else if (BSTRFUNC_is_sint_wo_commas(string_arg))
922 {
923 size_t len;
924 char *buffer;
925
926 len = strlen(string_arg);
927 buffer = TclpAlloc(((sizeof(char) * 4 * len) / 3) + 10);
928 strcpy(buffer, string_arg);
929 BSTRFUNC_commanate(buffer);
930 rv = Tcl_NewStringObj(buffer, -1);
931 TclpFree(buffer);
932 Tcl_SetObjResult(interp, rv);
933 return(TCL_OK);
934 }
935 else
936 {
937 //Error case. Must give error message.
938 rv = Tcl_NewStringObj("arbint commanate: \"", -1);
939 Tcl_AppendToObj(rv, string_arg, -1);
940 Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1);
941 Tcl_SetObjResult(interp, rv);
942 return(TCL_ERROR);
943 }
944 }
945 }
946
947
948 //Handles the "const" subextension.
949 //08/17/01: Visual inspection OK.
950 static
951 int ARBLENINTS_const_handler(ClientData dummy,
952 Tcl_Interp *interp,
953 int objc,
954 Tcl_Obj *objv[])
955 {
956 //Table of constants used.
957 static struct
958 {
959 char *tag;
960 //The symbolic tag used to identify the number.
961 char *desc;
962 //The full description of the number. It must consist
963 //of a string with lines no longer than about 70 chars,
964 //separated by newlines, and indented by 6 spaces.
965 char *minmant;
966 //The minimum mantissa or minimum representation.
967 //May not be empty or NULL.
968 char *mantrem;
969 //The remaining mantissa or remaining portion of
970 //number. May be empty, but may not be NULL.
971 char *exp;
972 //The exponent portion, if any, or NULL otherwise.
973 int deflen;
974 //The default number of digits for the constant
975 //if none is specified.
976 int digit_count_offset;
977 //The offset to go from string length of mantissa
978 //portions to number of digits. Cheap way to adjust
979 //for - sign and decimal point.
980 } tbl[] =
981 {
982 //e--the transcendental number e.
983 {
984 //tag
985 "e",
986 //desc
987 " Historically significant transcendental constant. Digits obtained\n"
988 " from http://fermi.udw.ac.za/physics/e.html on 08/17/01.",
989 //minmant
990 "2.7",
991 //mantrem
992 "182818284590452353602874713526624977572470936999595749669676277240766303535"
993 "475945713821785251664274274663919320030599218174135966290435729003342952605956"
994 "307381323286279434907632338298807531952510190115738341879307021540891499348841"
995 "675092447614606680822648001684774118537423454424371075390777449920695517027618"
996 "386062613313845830007520449338265602976067371132007093287091274437470472306969"
997 "772093101416928368190255151086574637721112523897844250569536967707854499699679"
998 "468644549059879316368892300987931277361782154249992295763514822082698951936680"
999 "331825288693984964651058209392398294887933203625094431173012381970684161403970"
1000 "198376793206832823764648042953118023287825098194558153017567173613320698112509"
1001 "961818815930416903515988885193458072738667385894228792284998920868058257492796"
1002 "104841984443634632449684875602336248270419786232090021609902353043699418491463"
1003 "140934317381436405462531520961836908887070167683964243781405927145635490613031"
1004 "07208510383750510115747704171898610687396965521267154688957035035",
1005 //exp
1006 NULL,
1007 //deflen
1008 30,
1009 //digit_count_offset
1010 1
1011 },
1012 //g_metric
1013 {
1014 //tag
1015 "g_si",
1016 //desc
1017 " Gravitational acceleration in SI units, meters per second**2.\n"
1018 " Obtained from NIST Special Publication 811 on 08/17/01.",
1019 //minmant
1020 "9.80665",
1021 //mantrem
1022 "",
1023 //exp
1024 NULL,
1025 //deflen
1026 30,
1027 //digit_count_offset
1028 1
1029 },
1030 //in2m
1031 {
1032 //tag
1033 "in2m",
1034 //desc
1035 " Multiplicative conversion factor from inches to meters.\n"
1036 " Obtained from NIST Special Publication 811 on 08/17/01.",
1037 //minmant
1038 "2.54",
1039 //mantrem
1040 "",
1041 //exp
1042 "e-2",
1043 //deflen
1044 30,
1045 //digit_count_offset
1046 1
1047 },
1048 //mi2km
1049 {
1050 //tag
1051 "mi2km",
1052 //desc
1053 " Multiplicative conversion factor from miles to kilometers.\n"
1054 " Obtained from NIST Special Publication 811 on 08/17/01.",
1055 //minmant
1056 "1.609344",
1057 //mantrem
1058 "",
1059 //exp
1060 NULL,
1061 //deflen
1062 30,
1063 //digit_count_offset
1064 1
1065 },
1066 //pi--the transcendental number PI.
1067 {
1068 //tag
1069 "pi",
1070 //desc
1071 " Transcendental constant supplying ratio of a circle's circumference\n"
1072 " to its diameter. Digits obtained from http://www.joyofpi.com/\n"
1073 " pi.htm on 08/17/01.",
1074 //minmant
1075 "3.14",
1076 //mantrem
1077 "15926535897932384626433832795028841971"
1078 "6939937510582097494459230781640628620899"
1079 "8628034825342117067982148086513282306647"
1080 "0938446095505822317253594081284811174502"
1081 "8410270193852110555964462294895493038196"
1082 "4428810975665933446128475648233786783165"
1083 "2712019091456485669234603486104543266482"
1084 "1339360726024914127372458700660631558817"
1085 "4881520920962829254091715364367892590360"
1086 "0113305305488204665213841469519415116094"
1087 "3305727036575959195309218611738193261179"
1088 "3105118548074462379962749567351885752724"
1089 "8912279381830119491298336733624406566430"
1090 "8602139494639522473719070217986094370277"
1091 "0539217176293176752384674818467669405132"
1092 "0005681271452635608277857713427577896091"
1093 "7363717872146844090122495343014654958537"
1094 "1050792279689258923542019956112129021960"
1095 "8640344181598136297747713099605187072113"
1096 "4999999837297804995105973173281609631859"
1097 "5024459455346908302642522308253344685035"
1098 "2619311881710100031378387528865875332083"
1099 "8142061717766914730359825349042875546873"
1100 "1159562863882353787593751957781857780532"
1101 "1712268066130019278766111959092164201989"
1102 "3809525720106548586327886593615338182796"
1103 "8230301952035301852968995773622599413891"
1104 "2497217752834791315155748572424541506959"
1105 "5082953311686172785588907509838175463746"
1106 "4939319255060400927701671139009848824012",
1107 //exp
1108 NULL,
1109 //deflen
1110 30,
1111 //digit_count_offset
1112 1
1113 },
1114 //sqrt5--the square root of 5.
1115 {
1116 //tag
1117 "sqrt5",
1118 //desc
1119 " The square root of 5. Digits obtained from\n"
1120 " http://home.earthlink.net/~maryski/sqrt51000000.txt on 08/17/01.",
1121 //minmant
1122 "2.236",
1123 //mantrem
1124 "0679774997896964091736687312762354406183596115257242708972454105209256378048"
1125 "99414414408378782274969508176150773783504253267724447073863586360121533452708866"
1126 "77817319187916581127664532263985658053576135041753378500342339241406444208643253"
1127 "90972525926272288762995174024406816117759089094984923713907297288984820886415426"
1128 "89894099131693577019748678884425089754132956183176921499977424801530434115035957"
1129 "66833251249881517813940800056242085524354223555610630634282023409333198293395974"
1130 "63522712013417496142026359047378855043896870611356600457571399565955669569175645"
1131 "78221952500060539231234005009286764875529722056766253666074485853505262330678494"
1132 "63342224231763727702663240768010444331582573350589309813622634319868647194698997"
1133 "01808189524264459620345221411922329125981963258111041704958070481204034559949435"
1134 "06855551855572512388641655010262436312571024449618789424682903404474716115455723"
1135 "20173767659046091852957560357798439805415538077906439363972302875606299948221385"
1136 "21773485924535151210463455550407072278724215347787529112121211843317893351910380",
1137 //exp
1138 NULL,
1139 //deflen
1140 30,
1141 //digit_count_offset
1142 1
1143 },
1144 };
1145
1146 Tcl_Obj *rv;
1147 //Value that will be returned to caller.
1148 int i;
1149 //Iteration variable.
1150 int tbl_idx;
1151 //Index into lookup table, of -1 if not found.
1152 int ndigits;
1153 //The number of digits to supply.
1154 int result_code;
1155 //Return value from Tcl library function.
1156
1157 //We must have either one or two additional arguments.
1158 if ((objc != 3) && (objc != 4))
1159 {
1160 Tcl_WrongNumArgs(interp,
1161 2,
1162 objv,
1163 "constant_tag ?ndigits?");
1164 return(TCL_ERROR);
1165 }
1166 else
1167 {
1168 char *string_arg;
1169
1170 //Grab a pointer to the string representation of
1171 //the input argument. The storage does not belong to us.
1172 string_arg = Tcl_GetString(objv[2]);
1173 assert(string_arg != NULL);
1174
1175 //Try to look up the string argument in the table.
1176 tbl_idx = -1;
1177 for (i=0; i<sizeof(tbl)/sizeof(tbl[0]); i++)
1178 {
1179 if (!strcmp(string_arg, tbl[i].tag))
1180 {
1181 tbl_idx = i;
1182 break;
1183 }
1184 }
1185
1186 //If the tag was not found in the table, print a hostile
1187 //message and abort.
1188 if (tbl_idx == -1)
1189 {
1190 char buf[100];
1191
1192 //Error case. Must give error message.
1193 //Must also list the constants available.
1194 rv = Tcl_NewStringObj("arbint const: \"", -1);
1195 Tcl_AppendToObj(rv, string_arg, -1);
1196 Tcl_AppendToObj(rv, "\" is not a recognized constant.\n", -1);
1197
1198 Tcl_AppendToObj(rv, "Available constants are:\n", -1);
1199
1200 for (i=0; i<sizeof(tbl)/sizeof(tbl[0]); i++)
1201 {
1202 Tcl_AppendToObj(rv, " ", -1);
1203 Tcl_AppendToObj(rv, tbl[i].tag, -1);
1204 sprintf(buf, " (%d digits available)\n",
1205 strlen(tbl[i].minmant) + strlen(tbl[i].mantrem) - tbl[i].digit_count_offset);
1206 Tcl_AppendToObj(rv, buf, -1);
1207 Tcl_AppendToObj(rv, tbl[i].desc, -1);
1208 if (i != (sizeof(tbl)/sizeof(tbl[0]) - 1))
1209 Tcl_AppendToObj(rv, "\n", -1);
1210 }
1211
1212 Tcl_SetObjResult(interp, rv);
1213 return(TCL_ERROR);
1214 }
1215
1216 //Make assertions about the string pointers.
1217 assert(tbl[tbl_idx].tag != NULL);
1218 assert(tbl[tbl_idx].desc != NULL);
1219 assert(tbl[tbl_idx].minmant != NULL);
1220 assert(tbl[tbl_idx].mantrem != NULL);
1221
1222 //Assume the default number of digits by default.
1223 ndigits = tbl[tbl_idx].deflen;
1224
1225 //If there is an additional parameter, try to interpret
1226 //that as the number of digits.
1227 if (objc == 4)
1228 {
1229 //SetIntFromAny(interp, objPtr)
1230 result_code = Tcl_GetIntFromObj(NULL, objv[3], &ndigits);
1231
1232 if (result_code != TCL_OK)
1233 {
1234 //Could not obtain an integer. Use hostile error
1235 //message and abort.
1236 string_arg = Tcl_GetString(objv[3]);
1237 assert(string_arg != NULL);
1238
1239 rv = Tcl_NewStringObj("arbint const: \"", -1);
1240 Tcl_AppendToObj(rv, string_arg, -1);
1241 Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1);
1242 Tcl_SetObjResult(interp, rv);
1243 return(TCL_ERROR);
1244 }
1245 }
1246
1247 //Ndigits may be corrupt. We have to be careful below to not
1248 //allow any funny stuff.
1249 rv = Tcl_NewStringObj(tbl[tbl_idx].minmant, -1);
1250 ndigits = ndigits - strlen(tbl[tbl_idx].minmant) + tbl[tbl_idx].digit_count_offset;
1251 if (ndigits > 0)
1252 {
1253 if (ndigits >= (int)strlen(tbl[tbl_idx].mantrem))
1254 {
1255 Tcl_AppendToObj(rv, tbl[tbl_idx].mantrem, -1);
1256 }
1257 else
1258 {
1259 Tcl_AppendToObj(rv, tbl[tbl_idx].mantrem, ndigits);
1260 }
1261 }
1262
1263 //Append the exponent portion.
1264 if (tbl[tbl_idx].exp)
1265 Tcl_AppendToObj(rv, tbl[tbl_idx].exp, -1);
1266
1267 //Default successful return.
1268 Tcl_SetObjResult(interp, rv);
1269 return(TCL_OK);
1270 }
1271 }
1272
1273
1274 //Handles the "decommanate" subextension.
1275 //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.
1277 static
1278 int ARBLENINTS_decommanate_handler(ClientData dummy,
1279 Tcl_Interp *interp,
1280 int objc,
1281 Tcl_Obj *objv[])
1282 {
1283 Tcl_Obj *rv;
1284
1285 //We must have one and exactly one additional argument
1286 //to this function, which is the string we want to
1287 //decommanate.
1288 if (objc != 3)
1289 {
1290 Tcl_WrongNumArgs(interp,
1291 2,
1292 objv,
1293 "sint");
1294 return(TCL_ERROR);
1295 }
1296 else
1297 {
1298 char *string_arg;
1299
1300 //Grab a pointer to the string representation of
1301 //the input argument. The storage does not belong to us.
1302 string_arg = Tcl_GetString(objv[2]);
1303 assert(string_arg != NULL);
1304
1305 //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
1307 //want to touch the string.
1308 if (GMP_INTS_identify_nan_string(string_arg) >= 0)
1309 {
1310 rv = Tcl_NewStringObj(string_arg, -1);
1311 Tcl_SetObjResult(interp, rv);
1312 return(TCL_OK);
1313 }
1314 //Try to parse it as a signed integer without commas.
1315 //If it has no commas, there is no need to decommanate it.
1316 else if (BSTRFUNC_is_sint_wo_commas(string_arg))
1317 {
1318 //This is already an acceptable commanated signed integer. Send it
1319 //back as the return value.
1320 rv = Tcl_NewStringObj(string_arg, -1);
1321 Tcl_SetObjResult(interp, rv);
1322 return(TCL_OK);
1323 }
1324 //Try to parse the argument as a signed integer with commas.
1325 //If it is one of those, decommanate it and return it.
1326 else if (BSTRFUNC_is_sint_w_commas(string_arg))
1327 {
1328 size_t len;
1329 char *buffer;
1330
1331 len = strlen(string_arg);
1332 buffer = TclpAlloc(sizeof(char) * len + 1);
1333 strcpy(buffer, string_arg);
1334 BSTRFUNC_decommanate(buffer);
1335 rv = Tcl_NewStringObj(buffer, -1);
1336 TclpFree(buffer);
1337 Tcl_SetObjResult(interp, rv);
1338 return(TCL_OK);
1339 }
1340 else
1341 {
1342 //Error case. Must give error message.
1343 rv = Tcl_NewStringObj("arbint decommanate: \"", -1);
1344 Tcl_AppendToObj(rv, string_arg, -1);
1345 Tcl_AppendToObj(rv, "\" is not a recognized integer.", -1);
1346 Tcl_SetObjResult(interp, rv);
1347 return(TCL_ERROR);
1348 }
1349 }
1350 }
1351
1352
1353 //Handles the "intadd" subextension.
1354 //08/06/01: Visual inspection OK.
1355 static
1356 int ARBLENINTS_intadd_handler(ClientData dummy,
1357 Tcl_Interp *interp,
1358 int objc,
1359 Tcl_Obj *objv[])
1360 {
1361 Tcl_Obj *rv;
1362
1363 //We must have two and exactly two additional arguments
1364 //to this function, which are the integers whose
1365 //sum is to be calculated.
1366 if (objc != 4)
1367 {
1368 Tcl_WrongNumArgs(interp,
1369 2,
1370 objv,
1371 "sint sint");
1372 return(TCL_ERROR);
1373 }
1374 else
1375 {
1376 GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result;
1377 char *add_arg1, *add_arg2;
1378 int failure1, failure2;
1379 unsigned chars_reqd;
1380 char *string_result;
1381 int i, j;
1382
1383 //Allocate space for the arbitrary-length integer result.
1384 GMP_INTS_mpz_init(&arb_arg1);
1385 GMP_INTS_mpz_init(&arb_arg2);
1386 GMP_INTS_mpz_init(&arb_result);
1387
1388 //Grab pointers to the string representation of
1389 //the input arguments. The storage does not belong to us.
1390 add_arg1 = Tcl_GetString(objv[2]);
1391 assert(add_arg1 != NULL);
1392 add_arg2 = Tcl_GetString(objv[3]);
1393 assert(add_arg2 != NULL);
1394
1395 //Try to interpret either of the strings as one of the NAN tags.
1396 //If it is one, return the appropriate result for
1397 //a binary operation.
1398 i = GMP_INTS_identify_nan_string(add_arg1);
1399 j = GMP_INTS_identify_nan_string(add_arg2);
1400
1401 if ((i >= 0) || (j >= 0))
1402 {
1403 const char *p;
1404
1405 //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
1407 //we do.
1408 if (i > j)
1409 ;
1410 else
1411 i = j;
1412
1413 //i now contains the max.
1414 switch (i)
1415 {
1416 case 0: p = GMP_INTS_supply_nan_string(2);
1417 break;
1418 case 1: p = GMP_INTS_supply_nan_string(3);
1419 break;
1420 case 2: p = GMP_INTS_supply_nan_string(2);
1421 break;
1422 case 3: p = GMP_INTS_supply_nan_string(3);
1423 break;
1424 default:
1425 assert(0);
1426 break;
1427 }
1428
1429 rv = Tcl_NewStringObj(p, -1);
1430 Tcl_SetObjResult(interp, rv);
1431
1432 GMP_INTS_mpz_clear(&arb_arg1);
1433 GMP_INTS_mpz_clear(&arb_arg2);
1434 GMP_INTS_mpz_clear(&arb_result);
1435
1436 return(TCL_OK);
1437 }
1438
1439 //Try to convert both strings into arbitrary integers.
1440 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, add_arg1);
1441 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
1444 //message. It is possible that both arguments failed the parse,
1445 //but only return one in the error message.
1446 if (failure1 || failure2)
1447 {
1448 rv = Tcl_NewStringObj("arbint intadd: \"", -1);
1449 if (failure1)
1450 Tcl_AppendToObj(rv, add_arg1, -1);
1451 else
1452 Tcl_AppendToObj(rv, add_arg2, -1);
1453
1454 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
1455 Tcl_SetObjResult(interp, rv);
1456
1457 GMP_INTS_mpz_clear(&arb_arg1);
1458 GMP_INTS_mpz_clear(&arb_arg2);
1459 GMP_INTS_mpz_clear(&arb_result);
1460
1461 return(TCL_ERROR);
1462 }
1463
1464 //Calculate the sum.
1465 GMP_INTS_mpz_add(&arb_result, &arb_arg1, &arb_arg2);
1466
1467 //Figure out the number of characters required for
1468 //the output string.
1469 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
1470
1471 //Allocate space for the conversion result.
1472 string_result = TclpAlloc(sizeof(char) * chars_reqd);
1473 assert(string_result != NULL);
1474
1475 //Make the conversion to a character string.
1476 GMP_INTS_mpz_to_string(string_result, &arb_result);
1477
1478 //Assign the string result to a Tcl object.
1479 rv = Tcl_NewStringObj(string_result, -1);
1480
1481 //Deallocate the string.
1482 TclpFree(string_result);
1483
1484 //Deallocate space for the arbitrary-length integers.
1485 GMP_INTS_mpz_clear(&arb_arg1);
1486 GMP_INTS_mpz_clear(&arb_arg2);
1487 GMP_INTS_mpz_clear(&arb_result);
1488
1489 //Assign the result to be the return value.
1490 Tcl_SetObjResult(interp, rv);
1491
1492 //Return
1493 return(TCL_OK);
1494 }
1495 }
1496
1497
1498 //08/01/01: Visual inspection and some unit testing, OK.
1499 //Handles the "intcmp" subextension.
1500 static
1501 int ARBLENINTS_intcmp_handler(ClientData dummy,
1502 Tcl_Interp *interp,
1503 int objc,
1504 Tcl_Obj *objv[])
1505 {
1506 Tcl_Obj *rv;
1507
1508 //We must have two and exactly two additional arguments
1509 //to this function, which are the integers to be compared.
1510 if (objc != 4)
1511 {
1512 Tcl_WrongNumArgs(interp,
1513 2,
1514 objv,
1515 "sint sint");
1516 return(TCL_ERROR);
1517 }
1518 else
1519 {
1520 GMP_INTS_mpz_struct arb_arg1, arb_arg2;
1521 char *cmp_arg1, *cmp_arg2;
1522 int failure1, failure2;
1523 int i, j, compare_result;
1524
1525 //Allocate space for the arbitrary-length integer result.
1526 GMP_INTS_mpz_init(&arb_arg1);
1527 GMP_INTS_mpz_init(&arb_arg2);
1528
1529 //Grab pointers to the string representation of
1530 //the input arguments. The storage does not belong to us.
1531 cmp_arg1 = Tcl_GetString(objv[2]);
1532 assert(cmp_arg1 != NULL);
1533 cmp_arg2 = Tcl_GetString(objv[3]);
1534 assert(cmp_arg2 != NULL);
1535
1536 //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
1538 //error.
1539 i = GMP_INTS_identify_nan_string(cmp_arg1);
1540 j = GMP_INTS_identify_nan_string(cmp_arg2);
1541
1542 if ((i >= 0) || (j >= 0))
1543 {
1544 rv = Tcl_NewStringObj("arbint intcmp: cannot compare NAN symbolic tags.", -1);
1545 Tcl_SetObjResult(interp, rv);
1546
1547 GMP_INTS_mpz_clear(&arb_arg1);
1548 GMP_INTS_mpz_clear(&arb_arg2);
1549
1550 return(TCL_ERROR);
1551 }
1552
1553 //Try to convert both strings into arbitrary integers.
1554 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, cmp_arg1);
1555 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
1558 //message. It is possible that both arguments failed the parse,
1559 //but only return one in the error message.
1560 if (failure1 || failure2)
1561 {
1562 rv = Tcl_NewStringObj("arbint intcmp: \"", -1);
1563 if (failure1)
1564 Tcl_AppendToObj(rv, cmp_arg1, -1);
1565 else
1566 Tcl_AppendToObj(rv, cmp_arg2, -1);
1567
1568 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
1569 Tcl_SetObjResult(interp, rv);
1570
1571 GMP_INTS_mpz_clear(&arb_arg1);
1572 GMP_INTS_mpz_clear(&arb_arg2);
1573
1574 return(TCL_ERROR);
1575 }
1576
1577 //Calculate the compare result.
1578 compare_result = GMP_INTS_mpz_cmp(&arb_arg1, &arb_arg2);
1579
1580 //Assign the return value based on the result.
1581 if (compare_result < 0)
1582 rv = Tcl_NewStringObj("-1", -1);
1583 else if (compare_result == 0)
1584 rv = Tcl_NewStringObj("0", -1);
1585 else
1586 rv = Tcl_NewStringObj("1", -1);
1587
1588 //Deallocate space for the arbitrary-length integers.
1589 GMP_INTS_mpz_clear(&arb_arg1);
1590 GMP_INTS_mpz_clear(&arb_arg2);
1591
1592 //Assign the result to be the return value.
1593 Tcl_SetObjResult(interp, rv);
1594
1595 //Return
1596 return(TCL_OK);
1597 }
1598 }
1599
1600
1601 //Handles the "intdiv" subextension.
1602 //07/31/01: Visually inspected, OK.
1603 static
1604 int ARBLENINTS_intdiv_handler(ClientData dummy,
1605 Tcl_Interp *interp,
1606 int objc,
1607 Tcl_Obj *objv[])
1608 {
1609 Tcl_Obj *rv;
1610
1611 //We must have two and exactly two additional arguments
1612 //to this function, which are the integers whose
1613 //integer quotient is to be calculated.
1614 if (objc != 4)
1615 {
1616 Tcl_WrongNumArgs(interp,
1617 2,
1618 objv,
1619 "sint sint");
1620 return(TCL_ERROR);
1621 }
1622 else
1623 {
1624 GMP_INTS_mpz_struct arb_dividend, arb_divisor, arb_quotient, arb_remainder;
1625 char *dividend_arg1, *divisor_arg2;
1626 int failure1, failure2;
1627 unsigned chars_reqd;
1628 char *string_result;
1629 int i, j;
1630
1631 //Allocate space for the arbitrary-length integer arguments and results.
1632 GMP_INTS_mpz_init(&arb_dividend);
1633 GMP_INTS_mpz_init(&arb_divisor);
1634 GMP_INTS_mpz_init(&arb_quotient);
1635 GMP_INTS_mpz_init(&arb_remainder);
1636
1637 //Grab pointers to the string representation of
1638 //the input arguments. The storage does not belong to us.
1639 dividend_arg1 = Tcl_GetString(objv[2]);
1640 assert(dividend_arg1 != NULL);
1641 divisor_arg2 = Tcl_GetString(objv[3]);
1642 assert(divisor_arg2 != NULL);
1643
1644 //Try to interpret either of the strings as one of the NAN tags.
1645 //If it is one, return the appropriate result for
1646 //a binary operation.
1647 i = GMP_INTS_identify_nan_string(dividend_arg1);
1648 j = GMP_INTS_identify_nan_string(divisor_arg2);
1649
1650 if ((i >= 0) || (j >= 0))
1651 {
1652 const char *p;
1653
1654 //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
1656 //we do.
1657 if (i > j)
1658 ;
1659 else
1660 i = j;
1661
1662 //i now contains the max.
1663 switch (i)
1664 {
1665 case 0: p = GMP_INTS_supply_nan_string(2);
1666 break;
1667 case 1: p = GMP_INTS_supply_nan_string(3);
1668 break;
1669 case 2: p = GMP_INTS_supply_nan_string(2);
1670 break;
1671 case 3: p = GMP_INTS_supply_nan_string(3);
1672 break;
1673 default:
1674 assert(0);
1675 break;
1676 }
1677
1678 rv = Tcl_NewStringObj(p, -1);
1679 Tcl_SetObjResult(interp, rv);
1680
1681 GMP_INTS_mpz_clear(&arb_dividend);
1682 GMP_INTS_mpz_clear(&arb_divisor);
1683 GMP_INTS_mpz_clear(&arb_quotient);
1684 GMP_INTS_mpz_clear(&arb_remainder);
1685
1686 return(TCL_OK);
1687 }
1688
1689 //Try to convert both strings into arbitrary integers.
1690 GMP_INTS_mpz_set_general_int(&arb_dividend, &failure1, dividend_arg1);
1691 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
1694 //message. It is possible that both arguments failed the parse,
1695 //but only return one in the error message.
1696 if (failure1 || failure2)
1697 {
1698 rv = Tcl_NewStringObj("arbint intdiv: \"", -1);
1699 if (failure1)
1700 Tcl_AppendToObj(rv, dividend_arg1, -1);
1701 else
1702 Tcl_AppendToObj(rv, divisor_arg2, -1);
1703
1704 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
1705 Tcl_SetObjResult(interp, rv);
1706
1707 GMP_INTS_mpz_clear(&arb_dividend);
1708 GMP_INTS_mpz_clear(&arb_divisor);
1709 GMP_INTS_mpz_clear(&arb_quotient);
1710 GMP_INTS_mpz_clear(&arb_remainder);
1711
1712 return(TCL_ERROR);
1713 }
1714
1715 //Calculate the quotient.
1716 GMP_INTS_mpz_tdiv_qr(&arb_quotient, &arb_remainder, &arb_dividend, &arb_divisor);
1717
1718 //Figure out the number of characters required for
1719 //the output string.
1720 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_quotient);
1721
1722 //Allocate space for the conversion result.
1723 string_result = TclpAlloc(sizeof(char) * chars_reqd);
1724 assert(string_result != NULL);
1725
1726 //Make the conversion to a character string.
1727 GMP_INTS_mpz_to_string(string_result, &arb_quotient);
1728
1729 //Assign the string result to a Tcl object.
1730 rv = Tcl_NewStringObj(string_result, -1);
1731
1732 //Deallocate the string.
1733 TclpFree(string_result);
1734
1735 //Deallocate space for the arbitrary-length integers.
1736 GMP_INTS_mpz_clear(&arb_dividend);
1737 GMP_INTS_mpz_clear(&arb_divisor);
1738 GMP_INTS_mpz_clear(&arb_quotient);
1739 GMP_INTS_mpz_clear(&arb_remainder);
1740
1741 //Assign the result to be the return value.
1742 Tcl_SetObjResult(interp, rv);
1743
1744 //Return
1745 return(TCL_OK);
1746 }
1747 }
1748
1749
1750 //08/01/01: Visually inspected.
1751 //Handles the "intexp" subextension.
1752 static
1753 int ARBLENINTS_intexp_handler(ClientData dummy,
1754 Tcl_Interp *interp,
1755 int objc,
1756 Tcl_Obj *objv[])
1757 {
1758 Tcl_Obj *rv;
1759
1760 //We must have two and exactly two additional arguments
1761 //to this function, which are the integers used to
1762 //calculate the exponential.
1763 if (objc != 4)
1764 {
1765 Tcl_WrongNumArgs(interp,
1766 2,
1767 objv,
1768 "sint uint32");
1769 return(TCL_ERROR);
1770 }
1771 else
1772 {
1773 GMP_INTS_mpz_struct arb_arg1, arb_result;
1774 unsigned arg2;
1775 char *str_arg1, *str_arg2;
1776 int failure1, failure2;
1777 unsigned chars_reqd;
1778 char *string_result;
1779 int i, j;
1780
1781 //Allocate space for the arbitrary-length integers.
1782 GMP_INTS_mpz_init(&arb_arg1);
1783 GMP_INTS_mpz_init(&arb_result);
1784
1785 //Grab pointers to the string representation of
1786 //the input arguments. The storage does not belong to us.
1787 str_arg1 = Tcl_GetString(objv[2]);
1788 assert(str_arg1 != NULL);
1789 str_arg2 = Tcl_GetString(objv[3]);
1790 assert(str_arg2 != NULL);
1791
1792 //Try to interpret either of the strings as one of the NAN tags.
1793 //If it is one, return the appropriate result for
1794 //a binary operation.
1795 i = GMP_INTS_identify_nan_string(str_arg1);
1796 j = GMP_INTS_identify_nan_string(str_arg2);
1797
1798 if ((i >= 0) || (j >= 0))
1799 {
1800 const char *p;
1801
1802 //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
1804 //we do.
1805 if (i > j)
1806 ;
1807 else
1808 i = j;
1809
1810 //i now contains the max.
1811 switch (i)
1812 {
1813 case 0: p = GMP_INTS_supply_nan_string(2);
1814 break;
1815 case 1: p = GMP_INTS_supply_nan_string(3);
1816 break;
1817 case 2: p = GMP_INTS_supply_nan_string(2);
1818 break;
1819 case 3: p = GMP_INTS_supply_nan_string(3);
1820 break;
1821 default:
1822 assert(0);
1823 break;
1824 }
1825
1826 rv = Tcl_NewStringObj(p, -1);
1827 Tcl_SetObjResult(interp, rv);
1828
1829 GMP_INTS_mpz_clear(&arb_arg1);
1830 GMP_INTS_mpz_clear(&arb_result);
1831
1832 return(TCL_OK);
1833 }
1834
1835 //Try to convert the first string into arbitrary integers.
1836 //The first string can be anything, including zero or a negative
1837 //arugument.
1838 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, str_arg1);
1839
1840 //If the conversion of the first string did not go alright,
1841 //print error message and abort.
1842 if (failure1)
1843 {
1844 rv = Tcl_NewStringObj("arbint intexp: \"", -1);
1845 Tcl_AppendToObj(rv, str_arg1, -1);
1846 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
1847 Tcl_SetObjResult(interp, rv);
1848
1849 GMP_INTS_mpz_clear(&arb_arg1);
1850 GMP_INTS_mpz_clear(&arb_result);
1851
1852 return(TCL_ERROR);
1853 }
1854
1855
1856 //Try to convert the second string into an unsigned 32-bit
1857 //integer.
1858 GMP_INTS_mpz_parse_into_uint32(&arg2, &failure2, str_arg2);
1859
1860 //If the conversion of the second string did not go alright,
1861 //print error message and abort.
1862 if (failure2)
1863 {
1864 rv = Tcl_NewStringObj("arbint intexp: \"", -1);
1865 Tcl_AppendToObj(rv, str_arg2, -1);
1866 Tcl_AppendToObj(rv, "\" is not a recognized unsigned 32-bit integer.", -1);
1867 Tcl_SetObjResult(interp, rv);
1868
1869 GMP_INTS_mpz_clear(&arb_arg1);
1870 GMP_INTS_mpz_clear(&arb_result);
1871
1872 return(TCL_ERROR);
1873 }
1874
1875 //Calculate the exponential.
1876 GMP_INTS_mpz_pow_ui(&arb_result, &arb_arg1, arg2);
1877
1878 //Figure out the number of characters required for
1879 //the output string.
1880 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
1881
1882 //Allocate space for the conversion result.
1883 string_result = TclpAlloc(sizeof(char) * chars_reqd);
1884 assert(string_result != NULL);
1885
1886 //Make the conversion to a character string.
1887 GMP_INTS_mpz_to_string(string_result, &arb_result);
1888
1889 //Assign the string result to a Tcl object.
1890 rv = Tcl_NewStringObj(string_result, -1);
1891
1892 //Deallocate the string.
1893 TclpFree(string_result);
1894
1895 //Deallocate space for the arbitrary-length integers.
1896 GMP_INTS_mpz_clear(&arb_arg1);
1897 GMP_INTS_mpz_clear(&arb_result);
1898
1899 //Assign the result to be the return value.
1900 Tcl_SetObjResult(interp, rv);
1901
1902 //Return
1903 return(TCL_OK);
1904 }
1905 }
1906
1907
1908 //Handles the "intfac" subextension.
1909 //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.
1911 static
1912 int ARBLENINTS_intfac_handler(ClientData dummy,
1913 Tcl_Interp *interp,
1914 int objc,
1915 Tcl_Obj *objv[])
1916 {
1917 Tcl_Obj *rv;
1918
1919 //We must have one and exactly one additional argument
1920 //to this function, which is the integer whose
1921 //factorial is to be evaluated.
1922 if (objc != 3)
1923 {
1924 Tcl_WrongNumArgs(interp,
1925 2,
1926 objv,
1927 "uint32");
1928 return(TCL_ERROR);
1929 }
1930 else
1931 {
1932 GMP_INTS_mpz_struct arb_result;
1933 char *fac_arg;
1934 int failure;
1935 unsigned fac_ui_arg;
1936 unsigned chars_reqd;
1937 char *string_result;
1938 int i;
1939
1940 //Allocate space for the arbitrary-length integer result.
1941 GMP_INTS_mpz_init(&arb_result);
1942
1943 //Grab a pointer to the string representation of
1944 //the input argument. The storage does not belong to us.
1945 fac_arg = Tcl_GetString(objv[2]);
1946 assert(fac_arg != NULL);
1947
1948 //Try to interpret the string as one of the NAN tags.
1949 //If it is one, return the appropriate result for
1950 //a unary operation.
1951 if ((i = GMP_INTS_identify_nan_string(fac_arg)) >= 0)
1952 {
1953 const char *p;
1954
1955 switch (i)
1956 {
1957 case 0: p = GMP_INTS_supply_nan_string(2);
1958 break;
1959 case 1: p = GMP_INTS_supply_nan_string(3);
1960 break;
1961 case 2: p = GMP_INTS_supply_nan_string(2);
1962 break;
1963 case 3: p = GMP_INTS_supply_nan_string(3);
1964 break;
1965 default:
1966 assert(0);
1967 break;
1968 }
1969
1970 rv = Tcl_NewStringObj(p, -1);
1971 Tcl_SetObjResult(interp, rv);
1972 GMP_INTS_mpz_clear(&arb_result);
1973 return(TCL_OK);
1974 }
1975
1976 //Try to convert the string to a UINT32 using all
1977 //known methods.
1978 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
1981 //message.
1982 if (failure)
1983 {
1984 rv = Tcl_NewStringObj("arbint intfac: \"", -1);
1985 Tcl_AppendToObj(rv, fac_arg, -1);
1986 Tcl_AppendToObj(rv, "\" is not a recognized 32-bit unsigned integer.", -1);
1987 Tcl_SetObjResult(interp, rv);
1988 GMP_INTS_mpz_clear(&arb_result);
1989 return(TCL_ERROR);
1990 }
1991
1992 //Calculate the factorial.
1993 GMP_INTS_mpz_fac_ui(&arb_result, fac_ui_arg);
1994
1995 //Figure out the number of characters required for
1996 //the output string.
1997 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
1998
1999 //Allocate space for the conversion result.
2000 string_result = TclpAlloc(sizeof(char) * chars_reqd);
2001 assert(string_result != NULL);
2002
2003 //Make the conversion to a character string.
2004 GMP_INTS_mpz_to_string(string_result, &arb_result);
2005
2006 //Assign the string result to a Tcl object.
2007 rv = Tcl_NewStringObj(string_result, -1);
2008
2009 //Deallocate the string.
2010 TclpFree(string_result);
2011
2012 //Deallocate space for the arbitrary-length integer.
2013 GMP_INTS_mpz_clear(&arb_result);
2014
2015 //Assign the result to be the return value.
2016 Tcl_SetObjResult(interp, rv);
2017
2018 //Return
2019 return(TCL_OK);
2020 }
2021 }
2022
2023
2024 //Handles the "intgcd" subextension.
2025 //08/06/01: Visual inspection OK.
2026 static
2027 int ARBLENINTS_intgcd_handler(ClientData dummy,
2028 Tcl_Interp *interp,
2029 int objc,
2030 Tcl_Obj *objv[])
2031 {
2032 Tcl_Obj *rv;
2033
2034 //We must have two and exactly two additional arguments
2035 //to this function, which are the integers whose
2036 //gcd is to be calculated.
2037 if (objc != 4)
2038 {
2039 Tcl_WrongNumArgs(interp,
2040 2,
2041 objv,
2042 "sint sint");
2043 return(TCL_ERROR);
2044 }
2045 else
2046 {
2047 GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result;
2048 char *gcd_arg1, *gcd_arg2;
2049 int failure1, failure2;
2050 unsigned chars_reqd;
2051 char *string_result;
2052 int i, j;
2053
2054 //Allocate space for the arbitrary-length integer result.
2055 GMP_INTS_mpz_init(&arb_arg1);
2056 GMP_INTS_mpz_init(&arb_arg2);
2057 GMP_INTS_mpz_init(&arb_result);
2058
2059 //Grab pointers to the string representation of
2060 //the input arguments. The storage does not belong to us.
2061 gcd_arg1 = Tcl_GetString(objv[2]);
2062 assert(gcd_arg1 != NULL);
2063 gcd_arg2 = Tcl_GetString(objv[3]);
2064 assert(gcd_arg2 != NULL);
2065
2066 //Try to interpret either of the strings as one of the NAN tags.
2067 //If it is one, return the appropriate result for
2068 //a binary operation.
2069 i = GMP_INTS_identify_nan_string(gcd_arg1);
2070 j = GMP_INTS_identify_nan_string(gcd_arg2);
2071
2072 if ((i >= 0) || (j >= 0))
2073 {
2074 const char *p;
2075
2076 //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
2078 //we do.
2079 if (i > j)
2080 ;
2081 else
2082 i = j;
2083
2084 //i now contains the max.
2085 switch (i)
2086 {
2087 case 0: p = GMP_INTS_supply_nan_string(2);
2088 break;
2089 case 1: p = GMP_INTS_supply_nan_string(3);
2090 break;
2091 case 2: p = GMP_INTS_supply_nan_string(2);
2092 break;
2093 case 3: p = GMP_INTS_supply_nan_string(3);
2094 break;
2095 default:
2096 assert(0);
2097 break;
2098 }
2099
2100 rv = Tcl_NewStringObj(p, -1);
2101 Tcl_SetObjResult(interp, rv);
2102
2103 GMP_INTS_mpz_clear(&arb_arg1);
2104 GMP_INTS_mpz_clear(&arb_arg2);
2105 GMP_INTS_mpz_clear(&arb_result);
2106
2107 return(TCL_OK);
2108 }
2109
2110 //Try to convert both strings into arbitrary integers.
2111 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, gcd_arg1);
2112 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
2115 //message. It is possible that both arguments failed the parse,
2116 //but only return one in the error message.
2117 if (failure1 || failure2)
2118 {
2119 rv = Tcl_NewStringObj("arbint intgcd: \"", -1);
2120 if (failure1)
2121 Tcl_AppendToObj(rv, gcd_arg1, -1);
2122 else
2123 Tcl_AppendToObj(rv, gcd_arg2, -1);
2124
2125 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
2126 Tcl_SetObjResult(interp, rv);
2127
2128 GMP_INTS_mpz_clear(&arb_arg1);
2129 GMP_INTS_mpz_clear(&arb_arg2);
2130 GMP_INTS_mpz_clear(&arb_result);
2131
2132 return(TCL_ERROR);
2133 }
2134
2135 //Calculate the gcd.
2136 GMP_INTS_mpz_gcd(&arb_result, &arb_arg1, &arb_arg2);
2137
2138 //Figure out the number of characters required for
2139 //the output string.
2140 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
2141
2142 //Allocate space for the conversion result.
2143 string_result = TclpAlloc(sizeof(char) * chars_reqd);
2144 assert(string_result != NULL);
2145
2146 //Make the conversion to a character string.
2147 GMP_INTS_mpz_to_string(string_result, &arb_result);
2148
2149 //Assign the string result to a Tcl object.
2150 rv = Tcl_NewStringObj(string_result, -1);
2151
2152 //Deallocate the string.
2153 TclpFree(string_result);
2154
2155 //Deallocate space for the arbitrary-length integers.
2156 GMP_INTS_mpz_clear(&arb_arg1);
2157 GMP_INTS_mpz_clear(&arb_arg2);
2158 GMP_INTS_mpz_clear(&arb_result);
2159
2160 //Assign the result to be the return value.
2161 Tcl_SetObjResult(interp, rv);
2162
2163 //Return
2164 return(TCL_OK);
2165 }
2166 }
2167
2168
2169 //Handles the "intlcm" subextension.
2170 //08/10/01: Visual inspection OK.
2171 static
2172 int ARBLENINTS_intlcm_handler(ClientData dummy,
2173 Tcl_Interp *interp,
2174 int objc,
2175 Tcl_Obj *objv[])
2176 {
2177 Tcl_Obj *rv;
2178
2179 //We must have two and exactly two additional arguments
2180 //to this function, which are the integers whose
2181 //lcm is to be calculated.
2182 if (objc != 4)
2183 {
2184 Tcl_WrongNumArgs(interp,
2185 2,
2186 objv,
2187 "sint sint");
2188 return(TCL_ERROR);
2189 }
2190 else
2191 {
2192 GMP_INTS_mpz_struct arb_arg1, arb_arg2, gcd, remainder, arb_result;
2193 char *lcm_arg1, *lcm_arg2;
2194 int failure1, failure2;
2195 unsigned chars_reqd;
2196 char *string_result;
2197 int i, j;
2198
2199 //Allocate space for the arbitrary-length integers.
2200 GMP_INTS_mpz_init(&arb_arg1);
2201 GMP_INTS_mpz_init(&arb_arg2);
2202 GMP_INTS_mpz_init(&gcd);
2203 GMP_INTS_mpz_init(&remainder);
2204 GMP_INTS_mpz_init(&arb_result);
2205
2206 //Grab pointers to the string representation of
2207 //the input arguments. The storage does not belong to us.
2208 lcm_arg1 = Tcl_GetString(objv[2]);
2209 assert(lcm_arg1 != NULL);
2210 lcm_arg2 = Tcl_GetString(objv[3]);
2211 assert(lcm_arg2 != NULL);
2212
2213 //Try to interpret either of the strings as one of the NAN tags.
2214 //If it is one, return the appropriate result for
2215 //a binary operation.
2216 i = GMP_INTS_identify_nan_string(lcm_arg1);
2217 j = GMP_INTS_identify_nan_string(lcm_arg2);
2218
2219 if ((i >= 0) || (j >= 0))
2220 {
2221 const char *p;
2222
2223 //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
2225 //we do.
2226 if (i > j)
2227 ;
2228 else
2229 i = j;
2230
2231 //i now contains the max.
2232 switch (i)
2233 {
2234 case 0: p = GMP_INTS_supply_nan_string(2);
2235 break;
2236 case 1: p = GMP_INTS_supply_nan_string(3);
2237 break;
2238 case 2: p = GMP_INTS_supply_nan_string(2);
2239 break;
2240 case 3: p = GMP_INTS_supply_nan_string(3);
2241 break;
2242 default:
2243 assert(0);
2244 break;
2245 }
2246
2247 rv = Tcl_NewStringObj(p, -1);
2248 Tcl_SetObjResult(interp, rv);
2249
2250 GMP_INTS_mpz_clear(&arb_arg1);
2251 GMP_INTS_mpz_clear(&arb_arg2);
2252 GMP_INTS_mpz_clear(&gcd);
2253 GMP_INTS_mpz_clear(&remainder);
2254 GMP_INTS_mpz_clear(&arb_result);
2255
2256 return(TCL_OK);
2257 }
2258
2259 //Try to convert both strings into arbitrary integers.
2260 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, lcm_arg1);
2261 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
2264 //message. It is possible that both arguments failed the parse,
2265 //but only return one in the error message.
2266 if (failure1 || failure2)
2267 {
2268 rv = Tcl_NewStringObj("arbint intlcm: \"", -1);
2269 if (failure1)
2270 Tcl_AppendToObj(rv, lcm_arg1, -1);
2271 else
2272 Tcl_AppendToObj(rv, lcm_arg2, -1);
2273
2274 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
2275 Tcl_SetObjResult(interp, rv);
2276
2277 GMP_INTS_mpz_clear(&arb_arg1);
2278 GMP_INTS_mpz_clear(&arb_arg2);
2279 GMP_INTS_mpz_clear(&gcd);
2280 GMP_INTS_mpz_clear(&remainder);
2281 GMP_INTS_mpz_clear(&arb_result);
2282
2283 return(TCL_ERROR);
2284 }
2285
2286 //Adjust errant arguments.
2287 if (GMP_INTS_mpz_is_neg(&arb_arg1))
2288 GMP_INTS_mpz_negate(&arb_arg1);
2289 else if (GMP_INTS_mpz_is_zero(&arb_arg1))
2290 GMP_INTS_mpz_set_ui(&arb_arg1, 1);
2291 if (GMP_INTS_mpz_is_neg(&arb_arg2))
2292 GMP_INTS_mpz_negate(&arb_arg2);
2293 else if (GMP_INTS_mpz_is_zero(&arb_arg2))
2294 GMP_INTS_mpz_set_ui(&arb_arg2, 1);
2295
2296 //Calculate the gcd.
2297 GMP_INTS_mpz_gcd(&gcd, &arb_arg1, &arb_arg2);
2298
2299 //Calculate the lcm.
2300 GMP_INTS_mpz_mul(&arb_arg1, &arb_arg1, &arb_arg2);
2301 GMP_INTS_mpz_tdiv_qr(&arb_result, &remainder,
2302 &arb_arg1, &gcd);
2303
2304 //Figure out the number of characters required for
2305 //the output string.
2306 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
2307
2308 //Allocate space for the conversion result.
2309 string_result = TclpAlloc(sizeof(char) * chars_reqd);
2310 assert(string_result != NULL);
2311
2312 //Make the conversion to a character string.
2313 GMP_INTS_mpz_to_string(string_result, &arb_result);
2314
2315 //Assign the string result to a Tcl object.
2316 rv = Tcl_NewStringObj(string_result, -1);
2317
2318 //Deallocate the string.
2319 TclpFree(string_result);
2320
2321 //Deallocate space for the arbitrary-length integers.
2322 GMP_INTS_mpz_clear(&arb_arg1);
2323 GMP_INTS_mpz_clear(&arb_arg2);
2324 GMP_INTS_mpz_clear(&gcd);
2325 GMP_INTS_mpz_clear(&remainder);
2326 GMP_INTS_mpz_clear(&arb_result);
2327
2328 //Assign the result to be the return value.
2329 Tcl_SetObjResult(interp, rv);
2330
2331 //Return
2332 return(TCL_OK);
2333 }
2334 }
2335
2336
2337 //Handles the "intmod" subextension.
2338 //08/06/01: Visual inspection OK.
2339 static
2340 int ARBLENINTS_intmod_handler(ClientData dummy,
2341 Tcl_Interp *interp,
2342 int objc,
2343 Tcl_Obj *objv[])
2344 {
2345 Tcl_Obj *rv;
2346
2347 //We must have two and exactly two additional arguments
2348 //to this function, which are the integers whose
2349 //integer quotient is to be calculated.
2350 if (objc != 4)
2351 {
2352 Tcl_WrongNumArgs(interp,
2353 2,
2354 objv,
2355 "sint sint");
2356 return(TCL_ERROR);
2357 }
2358 else
2359 {
2360 GMP_INTS_mpz_struct arb_dividend, arb_divisor, arb_quotient, arb_remainder;
2361 char *dividend_arg1, *divisor_arg2;
2362 int failure1, failure2;
2363 unsigned chars_reqd;
2364 char *string_result;
2365 int i, j;
2366
2367 //Allocate space for the arbitrary-length integer arguments and results.
2368 GMP_INTS_mpz_init(&arb_dividend);
2369 GMP_INTS_mpz_init(&arb_divisor);
2370 GMP_INTS_mpz_init(&arb_quotient);
2371 GMP_INTS_mpz_init(&arb_remainder);
2372
2373 //Grab pointers to the string representation of
2374 //the input arguments. The storage does not belong to us.
2375 dividend_arg1 = Tcl_GetString(objv[2]);
2376 assert(dividend_arg1 != NULL);
2377 divisor_arg2 = Tcl_GetString(objv[3]);
2378 assert(divisor_arg2 != NULL);
2379
2380 //Try to interpret either of the strings as one of the NAN tags.
2381 //If it is one, return the appropriate result for
2382 //a binary operation.
2383 i = GMP_INTS_identify_nan_string(dividend_arg1);
2384 j = GMP_INTS_identify_nan_string(divisor_arg2);
2385
2386 if ((i >= 0) || (j >= 0))
2387 {
2388 const char *p;
2389
2390 //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
2392 //we do.
2393 if (i > j)
2394 ;
2395 else
2396 i = j;
2397
2398 //i now contains the max.
2399 switch (i)
2400 {
2401 case 0: p = GMP_INTS_supply_nan_string(2);
2402 break;
2403 case 1: p = GMP_INTS_supply_nan_string(3);
2404 break;
2405 case 2: p = GMP_INTS_supply_nan_string(2);
2406 break;
2407 case 3: p = GMP_INTS_supply_nan_string(3);
2408 break;
2409 default:
2410 assert(0);
2411 break;
2412 }
2413
2414 rv = Tcl_NewStringObj(p, -1);
2415 Tcl_SetObjResult(interp, rv);
2416
2417 GMP_INTS_mpz_clear(&arb_dividend);
2418 GMP_INTS_mpz_clear(&arb_divisor);
2419 GMP_INTS_mpz_clear(&arb_quotient);
2420 GMP_INTS_mpz_clear(&arb_remainder);
2421
2422 return(TCL_OK);
2423 }
2424
2425 //Try to convert both strings into arbitrary integers.
2426 GMP_INTS_mpz_set_general_int(&arb_dividend, &failure1, dividend_arg1);
2427 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
2430 //message. It is possible that both arguments failed the parse,
2431 //but only return one in the error message.
2432 if (failure1 || failure2)
2433 {
2434 rv = Tcl_NewStringObj("arbint intmod: \"", -1);
2435 if (failure1)
2436 Tcl_AppendToObj(rv, dividend_arg1, -1);
2437 else
2438 Tcl_AppendToObj(rv, divisor_arg2, -1);
2439
2440 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
2441 Tcl_SetObjResult(interp, rv);
2442
2443 GMP_INTS_mpz_clear(&arb_dividend);
2444 GMP_INTS_mpz_clear(&arb_divisor);
2445 GMP_INTS_mpz_clear(&arb_quotient);
2446 GMP_INTS_mpz_clear(&arb_remainder);
2447
2448 return(TCL_ERROR);
2449 }
2450
2451 //Calculate the quotient and remainder.
2452 GMP_INTS_mpz_tdiv_qr(&arb_quotient, &arb_remainder, &arb_dividend, &arb_divisor);
2453
2454 //Figure out the number of characters required for
2455 //the output string.
2456 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_remainder);
2457
2458 //Allocate space for the conversion result.
2459 string_result = TclpAlloc(sizeof(char) * chars_reqd);
2460 assert(string_result != NULL);
2461
2462 //Make the conversion to a character string.
2463 GMP_INTS_mpz_to_string(string_result, &arb_remainder);
2464
2465 //Assign the string result to a Tcl object.
2466 rv = Tcl_NewStringObj(string_result, -1);
2467
2468 //Deallocate the string.
2469 TclpFree(string_result);
2470
2471 //Deallocate space for the arbitrary-length integers.
2472 GMP_INTS_mpz_clear(&arb_dividend);
2473 GMP_INTS_mpz_clear(&arb_divisor);
2474 GMP_INTS_mpz_clear(&arb_quotient);
2475 GMP_INTS_mpz_clear(&arb_remainder);
2476
2477 //Assign the result to be the return value.
2478 Tcl_SetObjResult(interp, rv);
2479
2480 //Return
2481 return(TCL_OK);
2482 }
2483 }
2484
2485
2486 //Handles the "intmul" subextension.
2487 //08/06/01: Visual inspection OK.
2488 static
2489 int ARBLENINTS_intmul_handler(ClientData dummy,
2490 Tcl_Interp *interp,
2491 int objc,
2492 Tcl_Obj *objv[])
2493 {
2494 Tcl_Obj *rv;
2495
2496 //We must have two and exactly two additional arguments
2497 //to this function, which are the integers whose
2498 //product is to be calculated.
2499 if (objc != 4)
2500 {
2501 Tcl_WrongNumArgs(interp,
2502 2,
2503 objv,
2504 "sint sint");
2505 return(TCL_ERROR);
2506 }
2507 else
2508 {
2509 GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result;
2510 char *mul_arg1, *mul_arg2;
2511 int failure1, failure2;
2512 unsigned chars_reqd;
2513 char *string_result;
2514 int i, j;
2515
2516 //Allocate space for the arbitrary-length integer result.
2517 GMP_INTS_mpz_init(&arb_arg1);
2518 GMP_INTS_mpz_init(&arb_arg2);
2519 GMP_INTS_mpz_init(&arb_result);
2520
2521 //Grab pointers to the string representation of
2522 //the input arguments. The storage does not belong to us.
2523 mul_arg1 = Tcl_GetString(objv[2]);
2524 assert(mul_arg1 != NULL);
2525 mul_arg2 = Tcl_GetString(objv[3]);
2526 assert(mul_arg2 != NULL);
2527
2528 //Try to interpret either of the strings as one of the NAN tags.
2529 //If it is one, return the appropriate result for
2530 //a binary operation.
2531 i = GMP_INTS_identify_nan_string(mul_arg1);
2532 j = GMP_INTS_identify_nan_string(mul_arg2);
2533
2534 if ((i >= 0) || (j >= 0))
2535 {
2536 const char *p;
2537
2538 //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
2540 //we do.
2541 if (i > j)
2542 ;
2543 else
2544 i = j;
2545
2546 //i now contains the max.
2547 switch (i)
2548 {
2549 case 0: p = GMP_INTS_supply_nan_string(2);
2550 break;
2551 case 1: p = GMP_INTS_supply_nan_string(3);
2552 break;
2553 case 2: p = GMP_INTS_supply_nan_string(2);
2554 break;
2555 case 3: p = GMP_INTS_supply_nan_string(3);
2556 break;
2557 default:
2558 assert(0);
2559 break;
2560 }
2561
2562 rv = Tcl_NewStringObj(p, -1);
2563 Tcl_SetObjResult(interp, rv);
2564
2565 GMP_INTS_mpz_clear(&arb_arg1);
2566 GMP_INTS_mpz_clear(&arb_arg2);
2567 GMP_INTS_mpz_clear(&arb_result);
2568
2569 return(TCL_OK);
2570 }
2571
2572 //Try to convert both strings into arbitrary integers.
2573 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, mul_arg1);
2574 GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, mul_arg2);
2575
2576 //If there was a parse failure, we have to return an error
2577 //message. It is possible that both arguments failed the parse,
2578 //but only return one in the error message.
2579 if (failure1 || failure2)
2580 {
2581 rv = Tcl_NewStringObj("arbint intmul: \"", -1);
2582 if (failure1)
2583 Tcl_AppendToObj(rv, mul_arg1, -1);
2584 else
2585 Tcl_AppendToObj(rv, mul_arg2, -1);
2586
2587 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
2588 Tcl_SetObjResult(interp, rv);
2589
2590 GMP_INTS_mpz_clear(&arb_arg1);
2591 GMP_INTS_mpz_clear(&arb_arg2);
2592 GMP_INTS_mpz_clear(&arb_result);
2593
2594 return(TCL_ERROR);
2595 }
2596
2597 //Calculate the product.
2598 GMP_INTS_mpz_mul(&arb_result, &arb_arg1, &arb_arg2);
2599
2600 //Figure out the number of characters required for
2601 //the output string.
2602 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
2603
2604 //Allocate space for the conversion result.
2605 string_result = TclpAlloc(sizeof(char) * chars_reqd);
2606 assert(string_result != NULL);
2607
2608 //Make the conversion to a character string.
2609 GMP_INTS_mpz_to_string(string_result, &arb_result);
2610
2611 //Assign the string result to a Tcl object.
2612 rv = Tcl_NewStringObj(string_result, -1);
2613
2614 //Deallocate the string.
2615 TclpFree(string_result);
2616
2617 //Deallocate space for the arbitrary-length integers.
2618 GMP_INTS_mpz_clear(&arb_arg1);
2619 GMP_INTS_mpz_clear(&arb_arg2);
2620 GMP_INTS_mpz_clear(&arb_result);
2621
2622 //Assign the result to be the return value.
2623 Tcl_SetObjResult(interp, rv);
2624
2625 //Return
2626 return(TCL_OK);
2627 }
2628 }
2629
2630
2631 //Handles the "intsub" subextension.
2632 //08/06/01: Visual inspection OK.
2633 static
2634 int ARBLENINTS_intsub_handler(ClientData dummy,
2635 Tcl_Interp *interp,
2636 int objc,
2637 Tcl_Obj *objv[])
2638 {
2639 Tcl_Obj *rv;
2640
2641 //We must have two and exactly two additional arguments
2642 //to this function, which are the integers whose
2643 //difference is to be calculated.
2644 if (objc != 4)
2645 {
2646 Tcl_WrongNumArgs(interp,
2647 2,
2648 objv,
2649 "sint sint");
2650 return(TCL_ERROR);
2651 }
2652 else
2653 {
2654 GMP_INTS_mpz_struct arb_arg1, arb_arg2, arb_result;
2655 char *sub_arg1, *sub_arg2;
2656 int failure1, failure2;
2657 unsigned chars_reqd;
2658 char *string_result;
2659 int i, j;
2660
2661 //Allocate space for the arbitrary-length integer result.
2662 GMP_INTS_mpz_init(&arb_arg1);
2663 GMP_INTS_mpz_init(&arb_arg2);
2664 GMP_INTS_mpz_init(&arb_result);
2665
2666 //Grab pointers to the string representation of
2667 //the input arguments. The storage does not belong to us.
2668 sub_arg1 = Tcl_GetString(objv[2]);
2669 assert(sub_arg1 != NULL);
2670 sub_arg2 = Tcl_GetString(objv[3]);
2671 assert(sub_arg2 != NULL);
2672
2673 //Try to interpret either of the strings as one of the NAN tags.
2674 //If it is one, return the appropriate result for
2675 //a binary operation.
2676 i = GMP_INTS_identify_nan_string(sub_arg1);
2677 j = GMP_INTS_identify_nan_string(sub_arg2);
2678
2679 if ((i >= 0) || (j >= 0))
2680 {
2681 const char *p;
2682
2683 //Find the max of i and j. This isn't a scientific way to tag the
2684 //result, but will be OK. Some information is lost no matter what
2685 //we do.
2686 if (i > j)
2687 ;
2688 else
2689 i = j;
2690
2691 //i now contains the max.
2692 switch (i)
2693 {
2694 case 0: p = GMP_INTS_supply_nan_string(2);
2695 break;
2696 case 1: p = GMP_INTS_supply_nan_string(3);
2697 break;
2698 case 2: p = GMP_INTS_supply_nan_string(2);
2699 break;
2700 case 3: p = GMP_INTS_supply_nan_string(3);
2701 break;
2702 default:
2703 assert(0);
2704 break;
2705 }
2706
2707 rv = Tcl_NewStringObj(p, -1);
2708 Tcl_SetObjResult(interp, rv);
2709
2710 GMP_INTS_mpz_clear(&arb_arg1);
2711 GMP_INTS_mpz_clear(&arb_arg2);
2712 GMP_INTS_mpz_clear(&arb_result);
2713
2714 return(TCL_OK);
2715 }
2716
2717 //Try to convert both strings into arbitrary integers.
2718 GMP_INTS_mpz_set_general_int(&arb_arg1, &failure1, sub_arg1);
2719 GMP_INTS_mpz_set_general_int(&arb_arg2, &failure2, sub_arg2);
2720
2721 //If there was a parse failure, we have to return an error
2722 //message. It is possible that both arguments failed the parse,
2723 //but only return one in the error message.
2724 if (failure1 || failure2)
2725 {
2726 rv = Tcl_NewStringObj("arbint intsub: \"", -1);
2727 if (failure1)
2728 Tcl_AppendToObj(rv, sub_arg1, -1);
2729 else
2730 Tcl_AppendToObj(rv, sub_arg2, -1);
2731
2732 Tcl_AppendToObj(rv, "\" is not a recognized signed integer.", -1);
2733 Tcl_SetObjResult(interp, rv);
2734
2735 GMP_INTS_mpz_clear(&arb_arg1);
2736 GMP_INTS_mpz_clear(&arb_arg2);
2737 GMP_INTS_mpz_clear(&arb_result);
2738
2739 return(TCL_ERROR);
2740 }
2741
2742 //Calculate the difference.
2743 GMP_INTS_mpz_sub(&arb_result, &arb_arg1, &arb_arg2);
2744
2745 //Figure out the number of characters required for
2746 //the output string.
2747 chars_reqd = GMP_INTS_mpz_size_in_base_10(&arb_result);
2748
2749 //Allocate space for the conversion result.
2750 string_result = TclpAlloc(sizeof(char) * chars_reqd);
2751 assert(string_result != NULL);
2752
2753 //Make the conversion to a character string.
2754 GMP_INTS_mpz_to_string(string_result, &arb_result);
2755
2756 //Assign the string result to a Tcl object.
2757 rv = Tcl_NewStringObj(string_result, -1);
2758
2759 //Deallocate the string.
2760 TclpFree(string_result);
2761
2762 //Deallocate space for the arbitrary-length integers.
2763 GMP_INTS_mpz_clear(&arb_arg1);
2764 GMP_INTS_mpz_clear(&arb_arg2);
2765 GMP_INTS_mpz_clear(&arb_result);
2766
2767 //Assign the result to be the return value.
2768 Tcl_SetObjResult(interp, rv);
2769
2770 //Return
2771 return(TCL_OK);
2772 }
2773 }
2774
2775
2776 //Handles the "iseflag" subextension.
2777 //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this
2778 //from memory an intuition as far as how to set return results and so forth.
2779 static
2780 int ARBLENINTS_iseflag_handler(ClientData dummy,
2781 Tcl_Interp *interp,
2782 int objc,
2783 Tcl_Obj *objv[])
2784 {
2785 Tcl_Obj *rv;
2786
2787 //We must have one and exactly one additional argument
2788 //to this function, which is the string we want to
2789 //classify.
2790 if (objc != 3)
2791 {
2792 Tcl_WrongNumArgs(interp,
2793 2,
2794 objv,
2795 "stringarg");
2796 return(TCL_ERROR);
2797 }
2798 else
2799 {
2800 char *string_arg;
2801
2802 //Grab a pointer to the string representation of
2803 //the input argument. The storage does not belong to us.
2804 string_arg = Tcl_GetString(objv[2]);
2805 assert(string_arg != NULL);
2806
2807 //Try to parse it out. We will definitely get one of
2808 //the return values.
2809 if (!strcmp(string_arg, GMP_INTS_EF_INTOVF_POS_STRING))
2810 {
2811 rv = Tcl_NewStringObj("1", -1);
2812 }
2813 else if (!strcmp(string_arg, GMP_INTS_EF_INTOVF_NEG_STRING))
2814 {
2815 rv = Tcl_NewStringObj("2", -1);
2816 }
2817 else if (!strcmp(string_arg, GMP_INTS_EF_INTOVF_TAINT_POS_STRING))
2818 {
2819 rv = Tcl_NewStringObj("3", -1);
2820 }
2821 else if (!strcmp(string_arg, GMP_INTS_EF_INTOVF_TAINT_NEG_STRING))
2822 {
2823 rv = Tcl_NewStringObj("4", -1);
2824 }
2825 else
2826 {
2827 rv = Tcl_NewStringObj("0", -1);
2828 }
2829
2830 //Assign the result to be the return value.
2831 Tcl_SetObjResult(interp, rv);
2832
2833 //Return
2834 return(TCL_OK);
2835 }
2836 }
2837
2838
2839 //08/08/01: Visual inspection OK.
2840 static
2841 int ARBLENINTS_rnadd_handler(ClientData dummy,
2842 Tcl_Interp *interp,
2843 int objc,
2844 Tcl_Obj *objv[])
2845 {
2846 Tcl_Obj *rv;
2847
2848 //We must have exactly two additional arguments
2849 //to this function, which are the rational numbers
2850 //to add.
2851 if (objc != 4)
2852 {
2853 Tcl_WrongNumArgs(interp,
2854 2,
2855 objv,
2856 "srn srn");
2857 return(TCL_ERROR);
2858 }
2859 else
2860 {
2861 char *input_arg;
2862 int failure;
2863 char *string_result;
2864 GMP_RATS_mpq_struct arg1, arg2, result;
2865
2866 //Allocate space for the rational numbers.
2867 GMP_RATS_mpq_init(&arg1);
2868 GMP_RATS_mpq_init(&arg2);
2869 GMP_RATS_mpq_init(&result);
2870
2871 //Grab a pointer to the string representation of
2872 //the first input argument. The storage does not belong to us.
2873 input_arg = Tcl_GetString(objv[2]);
2874 assert(input_arg != NULL);
2875
2876 //Try to parse our first input string as a rational number.
2877 //If we are not successful in this, must abort.
2878 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
2879 &failure,
2880 &arg1);
2881
2882 if (failure)
2883 {
2884 rv = Tcl_NewStringObj("arbint rnadd: \"", -1);
2885 Tcl_AppendToObj(rv, input_arg, -1);
2886
2887 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
2888 Tcl_SetObjResult(interp, rv);
2889
2890 GMP_RATS_mpq_clear(&arg1);
2891 GMP_RATS_mpq_clear(&arg2);
2892 GMP_RATS_mpq_clear(&result);
2893
2894 return(TCL_ERROR);
2895 }
2896
2897 //Grab a pointer to the string representation of
2898 //the second input argument. The storage does not belong to us.
2899 input_arg = Tcl_GetString(objv[3]);
2900 assert(input_arg != NULL);
2901
2902 //Try to parse our second input string as a rational number.
2903 //If we are not successful in this, must abort.
2904 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
2905 &failure,
2906 &arg2);
2907
2908 if (failure)
2909 {
2910 rv = Tcl_NewStringObj("arbint rnadd: \"", -1);
2911 Tcl_AppendToObj(rv, input_arg, -1);
2912
2913 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
2914 Tcl_SetObjResult(interp, rv);
2915
2916 GMP_RATS_mpq_clear(&arg1);
2917 GMP_RATS_mpq_clear(&arg2);
2918 GMP_RATS_mpq_clear(&result);
2919
2920 return(TCL_ERROR);
2921 }
2922
2923 //Perform the actual addition of the rational numbers. All
2924 //error cases are covered. If either of the inputs has a
2925 //denominator of zero, this will propagate to the result.
2926 GMP_RATS_mpq_add(&result, &arg1, &arg2);
2927
2928 //If the result has been NAN'd, return the string "NAN".
2929 if (GMP_RATS_mpq_is_nan(&result))
2930 {
2931 rv = Tcl_NewStringObj("NAN", -1);
2932
2933 Tcl_SetObjResult(interp, rv);
2934
2935 GMP_RATS_mpq_clear(&arg1);
2936 GMP_RATS_mpq_clear(&arg2);
2937 GMP_RATS_mpq_clear(&result);
2938
2939 return(TCL_OK);
2940 }
2941
2942 //Allocate space for the string result which we'll form for
2943 //both numerator and denominator. We need the maximum, because we'll only
2944 //do one number at a time.
2945 string_result = TclpAlloc(sizeof(char)
2946 *
2947 INTFUNC_max
2948 (
2949 GMP_INTS_mpz_size_in_base_10(&(result.num)),
2950 GMP_INTS_mpz_size_in_base_10(&(result.den))
2951 )
2952 );
2953 assert(string_result != NULL);
2954
2955 //Convert the numerator to a string and set that to be the
2956 //return value.
2957 GMP_INTS_mpz_to_string(string_result, &(result.num));
2958 rv = Tcl_NewStringObj(string_result, -1);
2959
2960 //Append the separating slash.
2961 Tcl_AppendToObj(rv, "/", -1);
2962
2963 //Convert the denominator to a string and append that to the
2964 //return value.
2965 GMP_INTS_mpz_to_string(string_result, &(result.den));
2966 Tcl_AppendToObj(rv, string_result, -1);
2967
2968 //Assign the result to be the return value.
2969 Tcl_SetObjResult(interp, rv);
2970
2971 //Free up all dynamic memory.
2972 TclpFree(string_result);
2973 GMP_RATS_mpq_clear(&arg1);
2974 GMP_RATS_mpq_clear(&arg2);
2975 GMP_RATS_mpq_clear(&result);
2976
2977 //Return
2978 return(TCL_OK);
2979 }
2980 }
2981
2982
2983 //08/16/01: Visual inspection OK.
2984 static
2985 int ARBLENINTS_rncmp_handler(ClientData dummy,
2986 Tcl_Interp *interp,
2987 int objc,
2988 Tcl_Obj *objv[])
2989 {
2990 Tcl_Obj *rv;
2991
2992 //We must have exactly two additional arguments
2993 //to this function, which are the rational numbers
2994 //to compare.
2995 if (objc != 4)
2996 {
2997 Tcl_WrongNumArgs(interp,
2998 2,
2999 objv,
3000 "srn srn");
3001 return(TCL_ERROR);
3002 }
3003 else
3004 {
3005 char *input_arg;
3006 int failure, compare_result;
3007 GMP_RATS_mpq_struct arg1, arg2;
3008
3009 //Allocate space for the rational numbers.
3010 GMP_RATS_mpq_init(&arg1);
3011 GMP_RATS_mpq_init(&arg2);
3012
3013 //Grab a pointer to the string representation of
3014 //the first input argument. The storage does not belong to us.
3015 input_arg = Tcl_GetString(objv[2]);
3016 assert(input_arg != NULL);
3017
3018 //Try to parse our first input string as a rational number.
3019 //If we are not successful in this, must abort.
3020 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3021 &failure,
3022 &arg1);
3023
3024 if (failure)
3025 {
3026 rv = Tcl_NewStringObj("arbint rncmp: \"", -1);
3027 Tcl_AppendToObj(rv, input_arg, -1);
3028
3029 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3030 Tcl_SetObjResult(interp, rv);
3031
3032 GMP_RATS_mpq_clear(&arg1);
3033 GMP_RATS_mpq_clear(&arg2);
3034
3035 return(TCL_ERROR);
3036 }
3037
3038 //Grab a pointer to the string representation of
3039 //the second input argument. The storage does not belong to us.
3040 input_arg = Tcl_GetString(objv[3]);
3041 assert(input_arg != NULL);
3042
3043 //Try to parse our second input string as a rational number.
3044 //If we are not successful in this, must abort.
3045 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3046 &failure,
3047 &arg2);
3048
3049 if (failure)
3050 {
3051 rv = Tcl_NewStringObj("arbint rncmp: \"", -1);
3052 Tcl_AppendToObj(rv, input_arg, -1);
3053
3054 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3055 Tcl_SetObjResult(interp, rv);
3056
3057 GMP_RATS_mpq_clear(&arg1);
3058 GMP_RATS_mpq_clear(&arg2);
3059
3060 return(TCL_ERROR);
3061 }
3062
3063 //Perform the actual comparison of the rational numbers. All
3064 //error cases are covered. If either of the inputs has a
3065 //denominator of zero, this will propagate to the result.
3066 compare_result = GMP_RATS_mpq_cmp(&arg1, &arg2, &failure);
3067
3068 //If the failure flag was thrown, we have to throw an error.
3069 //The reason is that if we can't successfully compare the two
3070 //rational numbers, then we have to kill the script--logical
3071 //correctness is not possible.
3072 if (failure)
3073 {
3074 rv = Tcl_NewStringObj("arbint rncmp: can't compare supplied rational numbers.", -1);
3075
3076 Tcl_SetObjResult(interp, rv);
3077
3078 GMP_RATS_mpq_clear(&arg1);
3079 GMP_RATS_mpq_clear(&arg2);
3080
3081 return(TCL_ERROR);
3082 }
3083
3084 //Convert the comparison result to a string.
3085 if (compare_result < 0)
3086 rv = Tcl_NewStringObj("-1", -1);
3087 else if (compare_result == 0)
3088 rv = Tcl_NewStringObj("0", -1);
3089 else
3090 rv = Tcl_NewStringObj("1", -1);
3091
3092 //Assign the result to be the return value.
3093 Tcl_SetObjResult(interp, rv);
3094
3095 //Free up all dynamic memory.
3096 GMP_RATS_mpq_clear(&arg1);
3097 GMP_RATS_mpq_clear(&arg2);
3098
3099 //Return
3100 return(TCL_OK);
3101 }
3102 }
3103
3104
3105 //08/09/01: Visual inspection OK.
3106 static
3107 int ARBLENINTS_rndiv_handler(ClientData dummy,
3108 Tcl_Interp *interp,
3109 int objc,
3110 Tcl_Obj *objv[])
3111 {
3112 Tcl_Obj *rv;
3113
3114 //We must have exactly two additional arguments
3115 //to this function, which are the rational numbers
3116 //to divide.
3117 if (objc != 4)
3118 {
3119 Tcl_WrongNumArgs(interp,
3120 2,
3121 objv,
3122 "srn srn");
3123 return(TCL_ERROR);
3124 }
3125 else
3126 {
3127 char *input_arg;
3128 int failure;
3129 char *string_result;
3130 GMP_RATS_mpq_struct arg1, arg2, result;
3131
3132 //Allocate space for the rational numbers.
3133 GMP_RATS_mpq_init(&arg1);
3134 GMP_RATS_mpq_init(&arg2);
3135 GMP_RATS_mpq_init(&result);
3136
3137 //Grab a pointer to the string representation of
3138 //the first input argument. The storage does not belong to us.
3139 input_arg = Tcl_GetString(objv[2]);
3140 assert(input_arg != NULL);
3141
3142 //Try to parse our first input string as a rational number.
3143 //If we are not successful in this, must abort.
3144 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3145 &failure,
3146 &arg1);
3147
3148 if (failure)
3149 {
3150 rv = Tcl_NewStringObj("arbint rndiv: \"", -1);
3151 Tcl_AppendToObj(rv, input_arg, -1);
3152
3153 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3154 Tcl_SetObjResult(interp, rv);
3155
3156 GMP_RATS_mpq_clear(&arg1);
3157 GMP_RATS_mpq_clear(&arg2);
3158 GMP_RATS_mpq_clear(&result);
3159
3160 return(TCL_ERROR);
3161 }
3162
3163 //Grab a pointer to the string representation of
3164 //the second input argument. The storage does not belong to us.
3165 input_arg = Tcl_GetString(objv[3]);
3166 assert(input_arg != NULL);
3167
3168 //Try to parse our second input string as a rational number.
3169 //If we are not successful in this, must abort.
3170 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3171 &failure,
3172 &arg2);
3173
3174 if (failure)
3175 {
3176 rv = Tcl_NewStringObj("arbint rndiv: \"", -1);
3177 Tcl_AppendToObj(rv, input_arg, -1);
3178
3179 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3180 Tcl_SetObjResult(interp, rv);
3181
3182 GMP_RATS_mpq_clear(&arg1);
3183 GMP_RATS_mpq_clear(&arg2);
3184 GMP_RATS_mpq_clear(&result);
3185
3186 return(TCL_ERROR);
3187 }
3188
3189 //Perform the actual division of the rational numbers. All
3190 //error cases are covered. If either of the inputs has a
3191 //denominator of zero, this will propagate to the result.
3192 GMP_RATS_mpq_div(&result, &arg1, &arg2);
3193
3194 //If the result has been NAN'd, return the string "NAN".
3195 if (GMP_RATS_mpq_is_nan(&result))
3196 {
3197 rv = Tcl_NewStringObj("NAN", -1);
3198
3199 Tcl_SetObjResult(interp, rv);
3200
3201 GMP_RATS_mpq_clear(&arg1);
3202 GMP_RATS_mpq_clear(&arg2);
3203 GMP_RATS_mpq_clear(&result);
3204
3205 return(TCL_OK);
3206 }
3207
3208 //Allocate space for the string result which we'll form for
3209 //both numerator and denominator. We need the maximum, because we'll only
3210 //do one number at a time.
3211 string_result = TclpAlloc(sizeof(char)
3212 *
3213 INTFUNC_max
3214 (
3215 GMP_INTS_mpz_size_in_base_10(&(result.num)),
3216 GMP_INTS_mpz_size_in_base_10(&(result.den))
3217 )
3218 );
3219 assert(string_result != NULL);
3220
3221 //Convert the numerator to a string and set that to be the
3222 //return value.
3223 GMP_INTS_mpz_to_string(string_result, &(result.num));
3224 rv = Tcl_NewStringObj(string_result, -1);
3225
3226 //Append the separating slash.
3227 Tcl_AppendToObj(rv, "/", -1);
3228
3229 //Convert the denominator to a string and append that to the
3230 //return value.
3231 GMP_INTS_mpz_to_string(string_result, &(result.den));
3232 Tcl_AppendToObj(rv, string_result, -1);
3233
3234 //Assign the result to be the return value.
3235 Tcl_SetObjResult(interp, rv);
3236
3237 //Free up all dynamic memory.
3238 TclpFree(string_result);
3239 GMP_RATS_mpq_clear(&arg1);
3240 GMP_RATS_mpq_clear(&arg2);
3241 GMP_RATS_mpq_clear(&result);
3242
3243 //Return
3244 return(TCL_OK);
3245 }
3246 }
3247
3248
3249 //08/09/01: Visual inspection OK.
3250 static
3251 int ARBLENINTS_rnmul_handler(ClientData dummy,
3252 Tcl_Interp *interp,
3253 int objc,
3254 Tcl_Obj *objv[])
3255 {
3256 Tcl_Obj *rv;
3257
3258 //We must have exactly two additional arguments
3259 //to this function, which are the rational numbers
3260 //to add.
3261 if (objc != 4)
3262 {
3263 Tcl_WrongNumArgs(interp,
3264 2,
3265 objv,
3266 "srn srn");
3267 return(TCL_ERROR);
3268 }
3269 else
3270 {
3271 char *input_arg;
3272 int failure;
3273 char *string_result;
3274 GMP_RATS_mpq_struct arg1, arg2, result;
3275
3276 //Allocate space for the rational numbers.
3277 GMP_RATS_mpq_init(&arg1);
3278 GMP_RATS_mpq_init(&arg2);
3279 GMP_RATS_mpq_init(&result);
3280
3281 //Grab a pointer to the string representation of
3282 //the first input argument. The storage does not belong to us.
3283 input_arg = Tcl_GetString(objv[2]);
3284 assert(input_arg != NULL);
3285
3286 //Try to parse our first input string as a rational number.
3287 //If we are not successful in this, must abort.
3288 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3289 &failure,
3290 &arg1);
3291
3292 if (failure)
3293 {
3294 rv = Tcl_NewStringObj("arbint rnmul: \"", -1);
3295 Tcl_AppendToObj(rv, input_arg, -1);
3296
3297 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3298 Tcl_SetObjResult(interp, rv);
3299
3300 GMP_RATS_mpq_clear(&arg1);
3301 GMP_RATS_mpq_clear(&arg2);
3302 GMP_RATS_mpq_clear(&result);
3303
3304 return(TCL_ERROR);
3305 }
3306
3307 //Grab a pointer to the string representation of
3308 //the second input argument. The storage does not belong to us.
3309 input_arg = Tcl_GetString(objv[3]);
3310 assert(input_arg != NULL);
3311
3312 //Try to parse our second input string as a rational number.
3313 //If we are not successful in this, must abort.
3314 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3315 &failure,
3316 &arg2);
3317
3318 if (failure)
3319 {
3320 rv = Tcl_NewStringObj("arbint rnmul: \"", -1);
3321 Tcl_AppendToObj(rv, input_arg, -1);
3322
3323 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3324 Tcl_SetObjResult(interp, rv);
3325
3326 GMP_RATS_mpq_clear(&arg1);
3327 GMP_RATS_mpq_clear(&arg2);
3328 GMP_RATS_mpq_clear(&result);
3329
3330 return(TCL_ERROR);
3331 }
3332
3333 //Perform the actual multiplication of the rational numbers. All
3334 //error cases are covered. If either of the inputs has a
3335 //denominator of zero, this will propagate to the result.
3336 GMP_RATS_mpq_mul(&result, &arg1, &arg2);
3337
3338 //If the result has been NAN'd, return the string "NAN".
3339 if (GMP_RATS_mpq_is_nan(&result))
3340 {
3341 rv = Tcl_NewStringObj("NAN", -1);
3342
3343 Tcl_SetObjResult(interp, rv);
3344
3345 GMP_RATS_mpq_clear(&arg1);
3346 GMP_RATS_mpq_clear(&arg2);
3347 GMP_RATS_mpq_clear(&result);
3348
3349 return(TCL_OK);
3350 }
3351
3352 //Allocate space for the string result which we'll form for
3353 //both numerator and denominator. We need the maximum, because we'll only
3354 //do one number at a time.
3355 string_result = TclpAlloc(sizeof(char)
3356 *
3357 INTFUNC_max
3358 (
3359 GMP_INTS_mpz_size_in_base_10(&(result.num)),
3360 GMP_INTS_mpz_size_in_base_10(&(result.den))
3361 )
3362 );
3363 assert(string_result != NULL);
3364
3365 //Convert the numerator to a string and set that to be the
3366 //return value.
3367 GMP_INTS_mpz_to_string(string_result, &(result.num));
3368 rv = Tcl_NewStringObj(string_result, -1);
3369
3370 //Append the separating slash.
3371 Tcl_AppendToObj(rv, "/", -1);
3372
3373 //Convert the denominator to a string and append that to the
3374 //return value.
3375 GMP_INTS_mpz_to_string(string_result, &(result.den));
3376 Tcl_AppendToObj(rv, string_result, -1);
3377
3378 //Assign the result to be the return value.
3379 Tcl_SetObjResult(interp, rv);
3380
3381 //Free up all dynamic memory.
3382 TclpFree(string_result);
3383 GMP_RATS_mpq_clear(&arg1);
3384 GMP_RATS_mpq_clear(&arg2);
3385 GMP_RATS_mpq_clear(&result);
3386
3387 //Return
3388 return(TCL_OK);
3389 }
3390 }
3391
3392
3393 //08/09/01: Visual inspection OK.
3394 static
3395 int ARBLENINTS_rnred_handler(ClientData dummy,
3396 Tcl_Interp *interp,
3397 int objc,
3398 Tcl_Obj *objv[])
3399 {
3400 Tcl_Obj *rv;
3401
3402 //We must have exactly one additional argument
3403 //to this function, which is the rational number
3404 //to provide the fully reduced form of.
3405 if (objc != 3)
3406 {
3407 Tcl_WrongNumArgs(interp,
3408 2,
3409 objv,
3410 "srn");
3411 return(TCL_ERROR);
3412 }
3413 else
3414 {
3415 char *input_arg;
3416 int failure;
3417 char *string_result;
3418 GMP_RATS_mpq_struct rn;
3419
3420 //We will need a rational number to hold the return value
3421 //from the parsing function. Allocate that now.
3422 GMP_RATS_mpq_init(&rn);
3423
3424 //Grab a pointer to the string representation of
3425 //the input argument. The storage does not belong to us.
3426 input_arg = Tcl_GetString(objv[2]);
3427 assert(input_arg != NULL);
3428
3429 //Try to parse our input string as a rational number.
3430 //If we are not successful in this, must abort.
3431 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3432 &failure,
3433 &rn);
3434
3435 if (failure)
3436 {
3437 rv = Tcl_NewStringObj("arbint rnred: \"", -1);
3438 Tcl_AppendToObj(rv, input_arg, -1);
3439
3440 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3441 Tcl_SetObjResult(interp, rv);
3442
3443 GMP_RATS_mpq_clear(&rn);
3444
3445 return(TCL_ERROR);
3446 }
3447
3448 //Normalize the rational number. This takes care of the
3449 //sign and also of the coprimality of numerator and
3450 //denominator.
3451 GMP_RATS_mpq_normalize(&rn);
3452
3453 //Allocate space for the string result which we'll form for
3454 //both numbers. We need the maximum, because we'll only
3455 //do one number at a time.
3456 string_result = TclpAlloc(sizeof(char)
3457 *
3458 INTFUNC_max
3459 (
3460 GMP_INTS_mpz_size_in_base_10(&(rn.num)),
3461 GMP_INTS_mpz_size_in_base_10(&(rn.den))
3462 )
3463 );
3464 assert(string_result != NULL);
3465
3466 //Convert the numerator to a string and set that to be the
3467 //return value.
3468 GMP_INTS_mpz_to_string(string_result, &(rn.num));
3469 rv = Tcl_NewStringObj(string_result, -1);
3470
3471 //Append the separating slash.
3472 Tcl_AppendToObj(rv, "/", -1);
3473
3474 //Convert the denominator to a string and append that to the
3475 //return value.
3476 GMP_INTS_mpz_to_string(string_result, &(rn.den));
3477 Tcl_AppendToObj(rv, string_result, -1);
3478
3479 //Assign the result to be the return value.
3480 Tcl_SetObjResult(interp, rv);
3481
3482 //Free up all dynamic memory.
3483 TclpFree(string_result);
3484 GMP_RATS_mpq_clear(&rn);
3485
3486 //Return
3487 return(TCL_OK);
3488 }
3489 }
3490
3491
3492 //08/08/01: Visual inspection OK.
3493 static
3494 int ARBLENINTS_rnsub_handler(ClientData dummy,
3495 Tcl_Interp *interp,
3496 int objc,
3497 Tcl_Obj *objv[])
3498 {
3499 Tcl_Obj *rv;
3500
3501 //We must have exactly two additional arguments
3502 //to this function, which are the rational numbers
3503 //to subtract.
3504 if (objc != 4)
3505 {
3506 Tcl_WrongNumArgs(interp,
3507 2,
3508 objv,
3509 "srn srn");
3510 return(TCL_ERROR);
3511 }
3512 else
3513 {
3514 char *input_arg;
3515 int failure;
3516 char *string_result;
3517 GMP_RATS_mpq_struct arg1, arg2, result;
3518
3519 //Allocate space for the rational numbers.
3520 GMP_RATS_mpq_init(&arg1);
3521 GMP_RATS_mpq_init(&arg2);
3522 GMP_RATS_mpq_init(&result);
3523
3524 //Grab a pointer to the string representation of
3525 //the first input argument. The storage does not belong to us.
3526 input_arg = Tcl_GetString(objv[2]);
3527 assert(input_arg != NULL);
3528
3529 //Try to parse our first input string as a rational number.
3530 //If we are not successful in this, must abort.
3531 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3532 &failure,
3533 &arg1);
3534
3535 if (failure)
3536 {
3537 rv = Tcl_NewStringObj("arbint rnsub: \"", -1);
3538 Tcl_AppendToObj(rv, input_arg, -1);
3539
3540 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3541 Tcl_SetObjResult(interp, rv);
3542
3543 GMP_RATS_mpq_clear(&arg1);
3544 GMP_RATS_mpq_clear(&arg2);
3545 GMP_RATS_mpq_clear(&result);
3546
3547 return(TCL_ERROR);
3548 }
3549
3550 //Grab a pointer to the string representation of
3551 //the second input argument. The storage does not belong to us.
3552 input_arg = Tcl_GetString(objv[3]);
3553 assert(input_arg != NULL);
3554
3555 //Try to parse our second input string as a rational number.
3556 //If we are not successful in this, must abort.
3557 GMP_RATS_mpq_set_all_format_rat_num(input_arg,
3558 &failure,
3559 &arg2);
3560
3561 if (failure)
3562 {
3563 rv = Tcl_NewStringObj("arbint rnsub: \"", -1);
3564 Tcl_AppendToObj(rv, input_arg, -1);
3565
3566 Tcl_AppendToObj(rv, "\" is not a recognized rational number.", -1);
3567 Tcl_SetObjResult(interp, rv);
3568
3569 GMP_RATS_mpq_clear(&arg1);
3570 GMP_RATS_mpq_clear(&arg2);
3571 GMP_RATS_mpq_clear(&result);
3572
3573 return(TCL_ERROR);
3574 }
3575
3576 //Perform the actual subtraction of the rational numbers. All
3577 //error cases are covered. If either of the inputs has a
3578 //denominator of zero, this will propagate to the result.
3579 GMP_RATS_mpq_sub(&result, &arg1, &arg2);
3580
3581 //If the result has been NAN'd, return the string "NAN".
3582 if (GMP_RATS_mpq_is_nan(&result))
3583 {
3584 rv = Tcl_NewStringObj("NAN", -1);
3585
3586 Tcl_SetObjResult(interp, rv);
3587
3588 GMP_RATS_mpq_clear(&arg1);
3589 GMP_RATS_mpq_clear(&arg2);
3590 GMP_RATS_mpq_clear(&result);
3591
3592 return(TCL_OK);
3593 }
3594
3595 //Allocate space for the string result which we'll form for
3596 //both numerator and denominator. We need the maximum, because we'll only
3597 //do one number at a time.
3598 string_result = TclpAlloc(sizeof(char)
3599 *
3600 INTFUNC_max
3601 (
3602 GMP_INTS_mpz_size_in_base_10(&(result.num)),
3603 GMP_INTS_mpz_size_in_base_10(&(result.den))
3604 )
3605 );
3606 assert(string_result != NULL);
3607
3608 //Convert the numerator to a string and set that to be the
3609 //return value.
3610 GMP_INTS_mpz_to_string(string_result, &(result.num));
3611 rv = Tcl_NewStringObj(string_result, -1);
3612
3613 //Append the separating slash.
3614 Tcl_AppendToObj(rv, "/", -1);
3615
3616 //Convert the denominator to a string and append that to the
3617 //return value.
3618 GMP_INTS_mpz_to_string(string_result, &(result.den));
3619 Tcl_AppendToObj(rv, string_result, -1);
3620
3621 //Assign the result to be the return value.
3622 Tcl_SetObjResult(interp, rv);
3623
3624 //Free up all dynamic memory.
3625 TclpFree(string_result);
3626 GMP_RATS_mpq_clear(&arg1);
3627 GMP_RATS_mpq_clear(&arg2);
3628 GMP_RATS_mpq_clear(&result);
3629
3630 //Return
3631 return(TCL_OK);
3632 }
3633 }
3634
3635
3636 //This is the search data table of possible subcommands
3637 //for the "arbint" extension. These must be kept
3638 //in alphabetical order, because a binary search is done
3639 //on this table in order to find an entry. If this table
3640 //falls out of alphabetical order, the binary search may
3641 //fail when in fact the entry exists.
3642 //
3643 //In a lot of cases below, this table is set up to accept
3644 //short forms. This is purely undocumented, and I won't put
3645 //it in any documentation. In a lot of cases, these table
3646 //entries cover common mistakes where people forget the "int".
3647 //
3648 static struct EXTNINIT_subextn_bsearch_record_struct
3649 ARBLENINTS_subextn_tbl[] =
3650 {
3651 { "brap", ARBLENINTS_cfbrapab_handler },
3652 { "cfbrapab", ARBLENINTS_cfbrapab_handler },
3653 { "cfratnum", ARBLENINTS_cfratnum_handler },
3654 { "cmp", ARBLENINTS_intcmp_handler },
3655 { "commanate", ARBLENINTS_commanate_handler },
3656 { "compare", ARBLENINTS_intcmp_handler },
3657 { "const", ARBLENINTS_const_handler },
3658 { "decommanate", ARBLENINTS_decommanate_handler },
3659 { "div", ARBLENINTS_intdiv_handler },
3660 { "divide", ARBLENINTS_intdiv_handler },
3661 { "exp", ARBLENINTS_intexp_handler },
3662 { "fac", ARBLENINTS_intfac_handler },
3663 { "factorial", ARBLENINTS_intfac_handler },
3664 { "gcd", ARBLENINTS_intgcd_handler },
3665 { "intadd", ARBLENINTS_intadd_handler },
3666 { "intcmp", ARBLENINTS_intcmp_handler },
3667 { "intdiv", ARBLENINTS_intdiv_handler },
3668 { "intexp", ARBLENINTS_intexp_handler },
3669 { "intfac", ARBLENINTS_intfac_handler },
3670 { "intgcd", ARBLENINTS_intgcd_handler },
3671 { "intlcm", ARBLENINTS_intlcm_handler },
3672 { "intmod", ARBLENINTS_intmod_handler },
3673 { "intmul", ARBLENINTS_intmul_handler },
3674 { "intsub", ARBLENINTS_intsub_handler },
3675 { "iseflag", ARBLENINTS_iseflag_handler },
3676 { "lcm", ARBLENINTS_intlcm_handler },
3677 { "mod", ARBLENINTS_intmod_handler },
3678 { "mul", ARBLENINTS_intmul_handler },
3679 { "multiply", ARBLENINTS_intmul_handler },
3680 { "rnadd", ARBLENINTS_rnadd_handler },
3681 { "rncmp", ARBLENINTS_rncmp_handler },
3682 { "rndiv", ARBLENINTS_rndiv_handler },
3683 { "rnmul", ARBLENINTS_rnmul_handler },
3684 { "rnred", ARBLENINTS_rnred_handler },
3685 { "rnsub", ARBLENINTS_rnsub_handler },
3686 { "times", ARBLENINTS_intmul_handler },
3687 };
3688
3689
3690 //Procedure called when the "arbint" command is encountered in a Tcl script.
3691 //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this
3692 //from memory an intuition as far as how to set return results and so forth.
3693 int ARBLENINTS_arbint_extn_command(ClientData dummy,
3694 Tcl_Interp *interp,
3695 int objc,
3696 Tcl_Obj *objv[])
3697 {
3698 char *subcommand;
3699 //Pointer to subcommand string.
3700 int tbl_entry;
3701 //Index into the subcommand lookup table, or -1
3702 //if no match.
3703 Tcl_Obj *rv;
3704 //The return result (a string) if there is an error.
3705 //In the normal execution case, one of the functions
3706 //above supplies the return object.
3707
3708 if (objc < 2)
3709 {
3710 //It isn't possible to have an object count of less than
3711 //2, because you must have at least the command name
3712 //plus a subcommand. The best way to handle this is
3713 //to indicate wrong number of arguments.
3714 Tcl_WrongNumArgs(interp,
3715 1,
3716 objv,
3717 "option ?args?");
3718 return(TCL_ERROR);
3719 }
3720 else
3721 {
3722 //A potentially appropriate number of arguments has been
3723 //specified. Try to look up the subcommand.
3724
3725 subcommand = Tcl_GetString(objv[1]);
3726 //Grab the string representation of the subcommand.
3727 //This is constant, belongs to Tcl, and cannot be
3728 //modified.
3729
3730 tbl_entry = EXTNINIT_subextension_bsearch(
3731 ARBLENINTS_subextn_tbl,
3732 sizeof(ARBLENINTS_subextn_tbl)/sizeof(ARBLENINTS_subextn_tbl[0]),
3733 subcommand);
3734 assert(tbl_entry < (int)(sizeof(ARBLENINTS_subextn_tbl)/sizeof(ARBLENINTS_subextn_tbl[0])));
3735
3736 //If the integer returned is zero or positive, should
3737 //run the subfunction. If negative, this is an error and
3738 //should generate meaningful message. A meaningful message
3739 //would definitely consist of all valid subcommands.
3740 if (tbl_entry < 0)
3741 {
3742 //This is an error path.
3743 rv = Tcl_NewStringObj("arbint: bad option \"", -1);
3744 subcommand = Tcl_GetString(objv[1]);
3745 Tcl_AppendToObj(rv, subcommand, -1);
3746 Tcl_AppendToObj(rv, "\": valid options are ", -1);
3747
3748 for (tbl_entry=0;
3749 tbl_entry < sizeof(ARBLENINTS_subextn_tbl)/sizeof(ARBLENINTS_subextn_tbl[0]);
3750 tbl_entry++)
3751 {
3752 if ((sizeof(ARBLENINTS_subextn_tbl)/sizeof(ARBLENINTS_subextn_tbl[0]) != 1)
3753 && (tbl_entry == sizeof(ARBLENINTS_subextn_tbl)/sizeof(ARBLENINTS_subextn_tbl[0]) - 1))
3754 Tcl_AppendToObj(rv, "and ", -1);
3755 Tcl_AppendToObj(rv, ARBLENINTS_subextn_tbl[tbl_entry].name, -1);
3756 if (tbl_entry == sizeof(ARBLENINTS_subextn_tbl)/sizeof(ARBLENINTS_subextn_tbl[0]) - 1)
3757 Tcl_AppendToObj(rv, ".", -1);
3758 else
3759 Tcl_AppendToObj(rv, ", ", -1);
3760 }
3761
3762 //Now, set the return value to be the object with our
3763 //meaningful string message.
3764 Tcl_SetObjResult(interp, rv);
3765
3766 return(TCL_ERROR);
3767 }
3768 else
3769 {
3770 //Call the function pointer. Called function will
3771 //set the string return value.
3772 return((*ARBLENINTS_subextn_tbl[tbl_entry].fptr)
3773 (dummy, interp, objc, objv));
3774 }
3775 }
3776 }
3777
3778
3779 //Performs initial registration to the hash table.
3780 //07/29/01: Visual inspection OK. Have not located my Tcl book, am doing this
3781 //from memory an intuition as far as how to set return results and so forth.
3782 void ARBLENINTS_arbint_extn_init(Tcl_Interp *interp)
3783 {
3784 //Register a command named "crc32".
3785 Tcl_CreateObjCommand(interp,
3786 "arbint",
3787 (Tcl_ObjCmdProc *)ARBLENINTS_arbint_extn_command,
3788 NULL,
3789 NULL);
3790 }
3791
3792
3793
3794 //Returns version control string for file.
3795 //
3796 const char *ARBLENINTS_cvcinfo(void)
3797 {
3798 return ("$Header$");
3799 }
3800
3801
3802 //Returns version control string for associated .H file.
3803 //
3804 const char *ARBLENINTS_hvcinfo(void)
3805 {
3806 return (ARBLENINTS_H_VERSION);
3807 }
3808
3809 //End of arblenints.c.

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25