git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxfmat.c

   1 /*
   2  * tclXfmath.c --
   3  *
   4  *      Contains the TCL trig and floating point math functions.
   5  *-----------------------------------------------------------------------------
   6  * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
   7  *
   8  * Permission to use, copy, modify, and distribute this software and its
   9  * documentation for any purpose and without fee is hereby granted, provided
  10  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11  * Mark Diekhans make no representations about the suitability of this
  12  * software for any purpose.  It is provided "as is" without express or
  13  * implied warranty.
  14  *-----------------------------------------------------------------------------
  15  * $Id: tclXfmath.c,v 2.5 1992/11/09 07:58:13 markd Exp $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.h"
  20 #include <math.h>
  21
  22 /*
  23  * Flag used to indicate if a floating point math routine is currently being
  24  * executed.  Used to determine if a matherr belongs to Tcl.
  25  */
  26 static int G_inTclFPMath = FALSE;
  27
  28 /*
  29  * Flag indicating if a floating point math error occured during the execution
  30  * of a library routine called by a Tcl command.  Will not be set by the trap
  31  * handler if the error did not occur while the `G_inTclFPMath' flag was
  32  * set.  If the error did occur the error type and the name of the function
  33  * that got the error are save here.
  34  */
  35 static int   G_gotTclFPMathErr = FALSE;
  36 static int   G_errorType;
  37
  38 /*
  39  * Prototypes of internal functions.
  40  */
  41 #ifdef TCL_IEEE_FP_MATH
  42 static int
  43 ReturnIEEEMathError _ANSI_ARGS_((Tcl_Interp *interp,
  44                                  double      dbResult));
  45 #else
  46 static int
  47 ReturnFPMathError _ANSI_ARGS_((Tcl_Interp *interp));
  48 #endif
  49
  50 static int
  51 Tcl_UnaryFloatFunction _ANSI_ARGS_((Tcl_Interp *interp,
  52                                     int         argc,
  53                                     char      **argv,
  54                                     double (*function)()));
  55
  56
  57 #ifdef TCL_IEEE_FP_MATH
  58 \f
  59 /*
  60  *-----------------------------------------------------------------------------
  61  *
  62  * ReturnIEEEMathError --
  63  *    Handle return of floating point errors on machines that use IEEE 745-1985
  64  * error reporting instead of Unix matherr.  Some machines support both and
  65  * on these, either option may be used.
  66  *    Various tests are used to determine if a number is one of the special
  67  * values.  Not-a-number is tested by comparing the number against itself
  68  * (x != x if x is NaN).  Infinity is tested for by comparing against MAXDOUBLE.
  69  *
  70  * Parameters:
  71  *   o interp (I) - Error is returned in result.
  72  *   o dbResult (I) - Result of a function call that returned a special value.
  73  * Returns:
  74  *   Always returns the value TCL_ERROR, so if can be called as the
  75  * argument to `return'.
  76  *-----------------------------------------------------------------------------
  77  */
  78 static int
  79 ReturnIEEEMathError (interp, dbResult)
  80     Tcl_Interp *interp;
  81     double      dbResult;
  82 {
  83     char *errorMsg;
  84
  85     if (dbResult != dbResult)
  86         errorMsg = "domain";
  87     else if (dbResult > MAXDOUBLE)
  88         errorMsg = "overflow";
  89     else if (dbResult < -MAXDOUBLE)
  90         errorMsg = "underflow";
  91
  92     Tcl_AppendResult (interp, "floating point ", errorMsg, " error",
  93                       (char *) NULL);
  94     return TCL_ERROR;
  95 }
  96 #else
  97 \f
  98 /*
  99  *-----------------------------------------------------------------------------
 100  *
 101  * ReturnFPMathError --
 102  *    Routine to set an interpreter result to contain a floating point
 103  * math error message.  Will clear the `G_gotTclFPMathErr' flag.
 104  * This routine always returns the value TCL_ERROR, so if can be called
 105  * as the argument to `return'.
 106  *
 107  * Parameters:
 108  *   o interp (I) - Error is returned in result.
 109  * Globals:
 110  *   o G_gotTclFPMathErr (O) - Flag indicating an error occured, will be
 111  *     cleared.
 112  *   o G_errorType (I) - Type of error that occured.
 113  * Returns:
 114  *   Always returns the value TCL_ERROR, so if can be called as the
 115  * argument to `return'.
 116  *-----------------------------------------------------------------------------
 117  */
 118 static int
 119 ReturnFPMathError (interp)
 120     Tcl_Interp *interp;
 121 {
 122     char *errorMsg;
 123
 124     switch (G_errorType) {
 125        case DOMAIN:
 126            errorMsg = "domain";
 127            break;
 128        case SING:
 129            errorMsg = "singularity";
 130            break;
 131        case OVERFLOW:
 132            errorMsg = "overflow";
 133            break;
 134        case UNDERFLOW:
 135            errorMsg = "underflow";
 136            break;
 137        case TLOSS:
 138        case PLOSS:
 139            errorMsg = "loss of significance";
 140            break;
 141     }
 142     Tcl_AppendResult (interp, "floating point ", errorMsg, " error",
 143                       (char *) NULL);
 144     G_gotTclFPMathErr = FALSE;  /* Clear the flag. */
 145     return TCL_ERROR;
 146 }
 147 #endif /* NO_MATH_ERR */
 148 \f
 149 /*
 150  *-----------------------------------------------------------------------------
 151  *
 152  * Tcl_MathError --
 153  *    Tcl math error handler, should be called by an application `matherr'
 154  *    routine to determine if an error was caused by Tcl code or by other
 155  *    code in the application.  If the error occured in Tcl code, flags will
 156  *    be set so that a standard Tcl interpreter error can be returned.
 157  *
 158  * Paramenter:
 159  *   o functionName (I) - The name of the function that got the error.  From
 160  *     the exception structure supplied to matherr.
 161  *   o errorType (I) - The type of error that occured.  From the exception
 162  *     structure supplied to matherr.
 163  * Results:
 164  *      Returns TRUE if the error was in Tcl code, in which case the
 165  *   matherr routine calling this function should return non-zero so no
 166  *   error message will be generated.  FALSE if the error was not in Tcl
 167  *   code, in which case the matherr routine can handle the error in any
 168  *   manner it choses.
 169  *
 170  *-----------------------------------------------------------------------------
 171  */
 172 int
 173 Tcl_MathError (functionName, errorType)
 174     char *functionName;
 175     int   errorType;
 176 {
 177
 178   if (G_inTclFPMath) {
 179       G_gotTclFPMathErr = TRUE;
 180       G_errorType = errorType;
 181       return TRUE;
 182   } else
 183       return FALSE;
 184
 185 }
 186 \f
 187 /*
 188  *-----------------------------------------------------------------------------
 189  *
 190  * Tcl_UnaryFloatFunction --
 191  *     Helper routine that implements Tcl unary floating point
 192  *     functions by validating parameters, converting the
 193  *     argument, applying the function (the address of which
 194  *     is passed as an argument), and converting the result to
 195  *     a string and storing it in the result buffer
 196  *
 197  * Results:
 198  *      Returns TCL_OK if number is present, conversion succeeded,
 199  *        the function was performed, etc.
 200  *      Return TCL_ERROR for any error; an appropriate error message
 201  *        is placed in the result string in this case.
 202  *
 203  *-----------------------------------------------------------------------------
 204  */
 205 static int
 206 Tcl_UnaryFloatFunction(interp, argc, argv, function)
 207     Tcl_Interp *interp;
 208     int         argc;
 209     char      **argv;
 210     double    (*function)();
 211 {
 212     double dbVal, dbResult;
 213
 214     if (argc != 2) {
 215         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " expr",
 216                           (char *) NULL);
 217         return TCL_ERROR;
 218     }
 219
 220     if (Tcl_ExprDouble (interp, argv [1], &dbVal) != TCL_OK)
 221         return TCL_ERROR;
 222
 223     G_inTclFPMath = TRUE;
 224     dbResult = (*function)(dbVal);
 225     G_inTclFPMath = FALSE;
 226
 227 #ifdef TCL_IEEE_FP_MATH
 228     if ((dbResult != dbResult) ||
 229         (dbResult < -MAXDOUBLE) ||
 230         (dbResult >  MAXDOUBLE))
 231         return ReturnIEEEMathError (interp, dbResult);
 232 #else
 233     if (G_gotTclFPMathErr)
 234         return ReturnFPMathError (interp);
 235 #endif
 236
 237     Tcl_ReturnDouble (interp, dbResult);
 238     return TCL_OK;
 239 }
 240 \f
 241 /*
 242  *-----------------------------------------------------------------------------
 243  *
 244  * Tcl_AcosCmd --
 245  *    Implements the TCL arccosine command:
 246  *        acos num
 247  *
 248  * Results:
 249  *      Returns TCL_OK if number is present and conversion succeeds.
 250  *
 251  *-----------------------------------------------------------------------------
 252  */
 253 int
 254 Tcl_AcosCmd(clientData, interp, argc, argv)
 255     ClientData  clientData;
 256     Tcl_Interp *interp;
 257     int         argc;
 258     char      **argv;
 259 {
 260     return Tcl_UnaryFloatFunction(interp, argc, argv, acos);
 261 }
 262 \f
 263 /*
 264  *-----------------------------------------------------------------------------
 265  *
 266  * Tcl_AsinCmd --
 267  *    Implements the TCL arcsin command:
 268  *        asin num
 269  *
 270  * Results:
 271  *      Returns TCL_OK if number is present and conversion succeeds.
 272  *
 273  *-----------------------------------------------------------------------------
 274  */
 275 int
 276 Tcl_AsinCmd(clientData, interp, argc, argv)
 277     ClientData  clientData;
 278     Tcl_Interp *interp;
 279     int         argc;
 280     char      **argv;
 281 {
 282     return Tcl_UnaryFloatFunction(interp, argc, argv, asin);
 283 }
 284 \f
 285 /*
 286  *-----------------------------------------------------------------------------
 287  *
 288  * Tcl_AtanCmd --
 289  *    Implements the TCL arctangent command:
 290  *        atan num
 291  *
 292  * Results:
 293  *      Returns TCL_OK if number is present and conversion succeeds.
 294  *
 295  *-----------------------------------------------------------------------------
 296  */
 297 int
 298 Tcl_AtanCmd(clientData, interp, argc, argv)
 299     ClientData  clientData;
 300     Tcl_Interp *interp;
 301     int         argc;
 302     char      **argv;
 303 {
 304     return Tcl_UnaryFloatFunction(interp, argc, argv, atan);
 305 }
 306 \f
 307 /*
 308  *-----------------------------------------------------------------------------
 309  *
 310  * Tcl_CosCmd --
 311  *    Implements the TCL cosine command:
 312  *        cos num
 313  *
 314  * Results:
 315  *      Returns TCL_OK if number is present and conversion succeeds.
 316  *
 317  *-----------------------------------------------------------------------------
 318  */
 319 int
 320 Tcl_CosCmd(clientData, interp, argc, argv)
 321     ClientData  clientData;
 322     Tcl_Interp *interp;
 323     int         argc;
 324     char      **argv;
 325 {
 326     return Tcl_UnaryFloatFunction(interp, argc, argv, cos);
 327 }
 328 \f
 329 /*
 330  *-----------------------------------------------------------------------------
 331  *
 332  * Tcl_SinCmd --
 333  *    Implements the TCL sin command:
 334  *        sin num
 335  *
 336  * Results:
 337  *      Returns TCL_OK if number is present and conversion succeeds.
 338  *
 339  *-----------------------------------------------------------------------------
 340  */
 341 int
 342 Tcl_SinCmd(clientData, interp, argc, argv)
 343     ClientData  clientData;
 344     Tcl_Interp *interp;
 345     int         argc;
 346     char      **argv;
 347 {
 348     return Tcl_UnaryFloatFunction(interp, argc, argv, sin);
 349 }
 350 \f
 351 /*
 352  *-----------------------------------------------------------------------------
 353  *
 354  * Tcl_TanCmd --
 355  *    Implements the TCL tangent command:
 356  *        tan num
 357  *
 358  * Results:
 359  *      Returns TCL_OK if number is present and conversion succeeds.
 360  *
 361  *-----------------------------------------------------------------------------
 362  */
 363 int
 364 Tcl_TanCmd(clientData, interp, argc, argv)
 365     ClientData  clientData;
 366     Tcl_Interp *interp;
 367     int         argc;
 368     char      **argv;
 369 {
 370     return Tcl_UnaryFloatFunction(interp, argc, argv, tan);
 371 }
 372 \f
 373 /*
 374  *-----------------------------------------------------------------------------
 375  *
 376  * Tcl_CoshCmd --
 377  *    Implements the TCL hyperbolic cosine command:
 378  *        cosh num
 379  *
 380  * Results:
 381  *      Returns TCL_OK if number is present and conversion succeeds.
 382  *
 383  *-----------------------------------------------------------------------------
 384  */
 385 int
 386 Tcl_CoshCmd(clientData, interp, argc, argv)
 387     ClientData  clientData;
 388     Tcl_Interp *interp;
 389     int         argc;
 390     char      **argv;
 391 {
 392     return Tcl_UnaryFloatFunction(interp, argc, argv, cosh);
 393 }
 394 \f
 395 /*
 396  *-----------------------------------------------------------------------------
 397  *
 398  * Tcl_SinhCmd --
 399  *    Implements the TCL hyperbolic sin command:
 400  *        sinh num
 401  *
 402  * Results:
 403  *      Returns TCL_OK if number is present and conversion succeeds.
 404  *
 405  *-----------------------------------------------------------------------------
 406  */
 407 int
 408 Tcl_SinhCmd(clientData, interp, argc, argv)
 409     ClientData  clientData;
 410     Tcl_Interp *interp;
 411     int         argc;
 412     char      **argv;
 413 {
 414     return Tcl_UnaryFloatFunction(interp, argc, argv, sinh);
 415 }
 416 \f
 417 /*
 418  *-----------------------------------------------------------------------------
 419  *
 420  * Tcl_TanhCmd --
 421  *    Implements the TCL hyperbolic tangent command:
 422  *        tanh num
 423  *
 424  * Results:
 425  *      Returns TCL_OK if number is present and conversion succeeds.
 426  *
 427  *-----------------------------------------------------------------------------
 428  */
 429 int
 430 Tcl_TanhCmd(clientData, interp, argc, argv)
 431     ClientData  clientData;
 432     Tcl_Interp *interp;
 433     int         argc;
 434     char      **argv;
 435 {
 436     return Tcl_UnaryFloatFunction(interp, argc, argv, tanh);
 437 }
 438 \f
 439 /*
 440  *-----------------------------------------------------------------------------
 441  *
 442  * Tcl_ExpCmd --
 443  *    Implements the TCL exponent command:
 444  *        exp num
 445  *
 446  * Results:
 447  *      Returns TCL_OK if number is present and conversion succeeds.
 448  *
 449  *-----------------------------------------------------------------------------
 450  */
 451 int
 452 Tcl_ExpCmd(clientData, interp, argc, argv)
 453     ClientData  clientData;
 454     Tcl_Interp *interp;
 455     int         argc;
 456     char      **argv;
 457 {
 458     return Tcl_UnaryFloatFunction(interp, argc, argv, exp);
 459 }
 460 \f
 461 /*
 462  *-----------------------------------------------------------------------------
 463  *
 464  * Tcl_LogCmd --
 465  *    Implements the TCL logarithm command:
 466  *        log num
 467  *
 468  * Results:
 469  *      Returns TCL_OK if number is present and conversion succeeds.
 470  *
 471  *-----------------------------------------------------------------------------
 472  */
 473 int
 474 Tcl_LogCmd(clientData, interp, argc, argv)
 475     ClientData  clientData;
 476     Tcl_Interp *interp;
 477     int         argc;
 478     char      **argv;
 479 {
 480     return Tcl_UnaryFloatFunction(interp, argc, argv, log);
 481 }
 482 \f
 483 /*
 484  *-----------------------------------------------------------------------------
 485  *
 486  * Tcl_Log10Cmd --
 487  *    Implements the TCL base-10 logarithm command:
 488  *        log10 num
 489  *
 490  * Results:
 491  *      Returns TCL_OK if number is present and conversion succeeds.
 492  *
 493  *-----------------------------------------------------------------------------
 494  */
 495 int
 496 Tcl_Log10Cmd(clientData, interp, argc, argv)
 497     ClientData  clientData;
 498     Tcl_Interp *interp;
 499     int         argc;
 500     char      **argv;
 501 {
 502     return Tcl_UnaryFloatFunction(interp, argc, argv, log10);
 503 }
 504 \f
 505 /*
 506  *-----------------------------------------------------------------------------
 507  *
 508  * Tcl_SqrtCmd --
 509  *    Implements the TCL square root command:
 510  *        sqrt num
 511  *
 512  * Results:
 513  *      Returns TCL_OK if number is present and conversion succeeds.
 514  *
 515  *-----------------------------------------------------------------------------
 516  */
 517 int
 518 Tcl_SqrtCmd(clientData, interp, argc, argv)
 519     ClientData  clientData;
 520     Tcl_Interp *interp;
 521     int         argc;
 522     char      **argv;
 523 {
 524     return Tcl_UnaryFloatFunction(interp, argc, argv, sqrt);
 525 }
 526 \f
 527 /*
 528  *-----------------------------------------------------------------------------
 529  *
 530  * Tcl_FabsCmd --
 531  *    Implements the TCL floating point absolute value command:
 532  *        fabs num
 533  *
 534  * Results:
 535  *      Returns TCL_OK if number is present and conversion succeeds.
 536  *
 537  *-----------------------------------------------------------------------------
 538  */
 539 int
 540 Tcl_FabsCmd(clientData, interp, argc, argv)
 541     ClientData  clientData;
 542     Tcl_Interp *interp;
 543     int         argc;
 544     char      **argv;
 545 {
 546     return Tcl_UnaryFloatFunction(interp, argc, argv, fabs);
 547 }
 548 \f
 549 /*
 550  *-----------------------------------------------------------------------------
 551  *
 552  * Tcl_FloorCmd --
 553  *    Implements the TCL floor command:
 554  *        floor num
 555  *
 556  * Results:
 557  *      Returns TCL_OK if number is present and conversion succeeds.
 558  *
 559  *-----------------------------------------------------------------------------
 560  */
 561 int
 562 Tcl_FloorCmd(clientData, interp, argc, argv)
 563     ClientData  clientData;
 564     Tcl_Interp *interp;
 565     int         argc;
 566     char      **argv;
 567 {
 568     return Tcl_UnaryFloatFunction(interp, argc, argv, floor);
 569 }
 570 \f
 571 /*
 572  *-----------------------------------------------------------------------------
 573  *
 574  * Tcl_CeilCmd --
 575  *    Implements the TCL ceil command:
 576  *        ceil num
 577  *
 578  * Results:
 579  *      Returns TCL_OK if number is present and conversion succeeds.
 580  *
 581  *-----------------------------------------------------------------------------
 582  */
 583 int
 584 Tcl_CeilCmd(clientData, interp, argc, argv)
 585     ClientData  clientData;
 586     Tcl_Interp *interp;
 587     int         argc;
 588     char      **argv;
 589 {
 590     return Tcl_UnaryFloatFunction(interp, argc, argv, ceil);
 591 }
 592 \f
 593 /*
 594  *-----------------------------------------------------------------------------
 595  *
 596  * Tcl_FmodCmd --
 597  *    Implements the TCL floating modulo command:
 598  *        fmod num1 num2
 599  *
 600  * Results:
 601  *      Returns TCL_OK if number is present and conversion succeeds.
 602  *
 603  *-----------------------------------------------------------------------------
 604  */
 605 int
 606 Tcl_FmodCmd(clientData, interp, argc, argv)
 607     ClientData  clientData;
 608     Tcl_Interp *interp;
 609     int         argc;
 610     char      **argv;
 611 {
 612     double dbVal, dbDivisor, dbResult;
 613
 614     if (argc != 3) {
 615         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " expr divisor",
 616                           (char *) NULL);
 617         return TCL_ERROR;
 618     }
 619
 620     if (Tcl_ExprDouble (interp, argv [1], &dbVal) != TCL_OK)
 621         return TCL_ERROR;
 622
 623     if (Tcl_ExprDouble (interp, argv [2], &dbDivisor) != TCL_OK)
 624         return TCL_ERROR;
 625
 626     G_inTclFPMath = TRUE;
 627     dbResult = fmod (dbVal, dbDivisor);
 628     G_inTclFPMath = FALSE;
 629
 630 #ifdef TCL_IEEE_FP_MATH
 631     if ((dbResult != dbResult) ||
 632         (dbResult < -MAXDOUBLE) ||
 633         (dbResult >  MAXDOUBLE))
 634         return ReturnIEEEMathError (interp, dbResult);
 635 #else
 636     if (G_gotTclFPMathErr)
 637         return ReturnFPMathError (interp);
 638 #endif
 639
 640     Tcl_ReturnDouble (interp, dbResult);
 641     return TCL_OK;
 642 }
 643 \f
 644 /*
 645  *-----------------------------------------------------------------------------
 646  *
 647  * Tcl_PowCmd --
 648  *    Implements the TCL power (exponentiation) command:
 649  *        pow num1 num2
 650  *
 651  * Results:
 652  *      Returns TCL_OK if number is present and conversion succeeds.
 653  *
 654  *-----------------------------------------------------------------------------
 655  */
 656 int
 657 Tcl_PowCmd(clientData, interp, argc, argv)
 658     ClientData  clientData;
 659     Tcl_Interp *interp;
 660     int         argc;
 661     char      **argv;
 662 {
 663     double dbVal, dbExp, dbResult;
 664
 665     if (argc != 3) {
 666         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " expr exp",
 667                           (char *) NULL);
 668         return TCL_ERROR;
 669     }
 670
 671     if (Tcl_ExprDouble (interp, argv [1], &dbVal) != TCL_OK)
 672         return TCL_ERROR;
 673
 674     if (Tcl_ExprDouble (interp, argv [2], &dbExp) != TCL_OK)
 675         return TCL_ERROR;
 676
 677     G_inTclFPMath = TRUE;
 678     dbResult = pow (dbVal,dbExp);
 679     G_inTclFPMath = FALSE;
 680
 681 #ifdef TCL_IEEE_FP_MATH
 682     if ((dbResult != dbResult) ||
 683         (dbResult < -MAXDOUBLE) ||
 684         (dbResult >  MAXDOUBLE))
 685         return ReturnIEEEMathError (interp, dbResult);
 686 #else
 687     if (G_gotTclFPMathErr)
 688         return ReturnFPMathError (interp);
 689 #endif
 690
 691     Tcl_ReturnDouble (interp, dbResult);
 692     return TCL_OK;
 693 }