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
 123     Tcl_AppendResult (interp, "floating point error",
 124                       (char *) NULL);
 125     G_gotTclFPMathErr = FALSE;  /* Clear the flag. */
 126     return TCL_ERROR;
 127 }
 128 #endif /* NO_MATH_ERR */
 129 \f
 130 /*
 131  *-----------------------------------------------------------------------------
 132  *
 133  * Tcl_MathError --
 134  *    Tcl math error handler, should be called by an application `matherr'
 135  *    routine to determine if an error was caused by Tcl code or by other
 136  *    code in the application.  If the error occured in Tcl code, flags will
 137  *    be set so that a standard Tcl interpreter error can be returned.
 138  *
 139  * Paramenter:
 140  *   o functionName (I) - The name of the function that got the error.  From
 141  *     the exception structure supplied to matherr.
 142  *   o errorType (I) - The type of error that occured.  From the exception
 143  *     structure supplied to matherr.
 144  * Results:
 145  *      Returns TRUE if the error was in Tcl code, in which case the
 146  *   matherr routine calling this function should return non-zero so no
 147  *   error message will be generated.  FALSE if the error was not in Tcl
 148  *   code, in which case the matherr routine can handle the error in any
 149  *   manner it choses.
 150  *
 151  *-----------------------------------------------------------------------------
 152  */
 153 int
 154 Tcl_MathError (functionName, errorType)
 155     char *functionName;
 156     int   errorType;
 157 {
 158
 159   if (G_inTclFPMath) {
 160       G_gotTclFPMathErr = TRUE;
 161       G_errorType = errorType;
 162       return TRUE;
 163   } else
 164       return FALSE;
 165
 166 }
 167 \f
 168 /*
 169  *-----------------------------------------------------------------------------
 170  *
 171  * Tcl_UnaryFloatFunction --
 172  *     Helper routine that implements Tcl unary floating point
 173  *     functions by validating parameters, converting the
 174  *     argument, applying the function (the address of which
 175  *     is passed as an argument), and converting the result to
 176  *     a string and storing it in the result buffer
 177  *
 178  * Results:
 179  *      Returns TCL_OK if number is present, conversion succeeded,
 180  *        the function was performed, etc.
 181  *      Return TCL_ERROR for any error; an appropriate error message
 182  *        is placed in the result string in this case.
 183  *
 184  *-----------------------------------------------------------------------------
 185  */
 186 static int
 187 Tcl_UnaryFloatFunction(interp, argc, argv, function)
 188     Tcl_Interp *interp;
 189     int         argc;
 190     char      **argv;
 191     double    (*function)();
 192 {
 193     double dbVal, dbResult;
 194
 195     if (argc != 2) {
 196         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " expr",
 197                           (char *) NULL);
 198         return TCL_ERROR;
 199     }
 200
 201     if (Tcl_ExprDouble (interp, argv [1], &dbVal) != TCL_OK)
 202         return TCL_ERROR;
 203
 204     G_inTclFPMath = TRUE;
 205     dbResult = (*function)(dbVal);
 206     G_inTclFPMath = FALSE;
 207
 208 #ifdef TCL_IEEE_FP_MATH
 209     if ((dbResult != dbResult) ||
 210         (dbResult < -MAXDOUBLE) ||
 211         (dbResult >  MAXDOUBLE))
 212         return ReturnIEEEMathError (interp, dbResult);
 213 #else
 214     if (G_gotTclFPMathErr)
 215         return ReturnFPMathError (interp);
 216 #endif
 217
 218     Tcl_ReturnDouble (interp, dbResult);
 219     return TCL_OK;
 220 }
 221 \f
 222 /*
 223  *-----------------------------------------------------------------------------
 224  *
 225  * Tcl_AcosCmd --
 226  *    Implements the TCL arccosine command:
 227  *        acos num
 228  *
 229  * Results:
 230  *      Returns TCL_OK if number is present and conversion succeeds.
 231  *
 232  *-----------------------------------------------------------------------------
 233  */
 234 int
 235 Tcl_AcosCmd(clientData, interp, argc, argv)
 236     ClientData  clientData;
 237     Tcl_Interp *interp;
 238     int         argc;
 239     char      **argv;
 240 {
 241     return Tcl_UnaryFloatFunction(interp, argc, argv, acos);
 242 }
 243 \f
 244 /*
 245  *-----------------------------------------------------------------------------
 246  *
 247  * Tcl_AsinCmd --
 248  *    Implements the TCL arcsin command:
 249  *        asin num
 250  *
 251  * Results:
 252  *      Returns TCL_OK if number is present and conversion succeeds.
 253  *
 254  *-----------------------------------------------------------------------------
 255  */
 256 int
 257 Tcl_AsinCmd(clientData, interp, argc, argv)
 258     ClientData  clientData;
 259     Tcl_Interp *interp;
 260     int         argc;
 261     char      **argv;
 262 {
 263     return Tcl_UnaryFloatFunction(interp, argc, argv, asin);
 264 }
 265 \f
 266 /*
 267  *-----------------------------------------------------------------------------
 268  *
 269  * Tcl_AtanCmd --
 270  *    Implements the TCL arctangent command:
 271  *        atan num
 272  *
 273  * Results:
 274  *      Returns TCL_OK if number is present and conversion succeeds.
 275  *
 276  *-----------------------------------------------------------------------------
 277  */
 278 int
 279 Tcl_AtanCmd(clientData, interp, argc, argv)
 280     ClientData  clientData;
 281     Tcl_Interp *interp;
 282     int         argc;
 283     char      **argv;
 284 {
 285     return Tcl_UnaryFloatFunction(interp, argc, argv, atan);
 286 }
 287 \f
 288 /*
 289  *-----------------------------------------------------------------------------
 290  *
 291  * Tcl_CosCmd --
 292  *    Implements the TCL cosine command:
 293  *        cos num
 294  *
 295  * Results:
 296  *      Returns TCL_OK if number is present and conversion succeeds.
 297  *
 298  *-----------------------------------------------------------------------------
 299  */
 300 int
 301 Tcl_CosCmd(clientData, interp, argc, argv)
 302     ClientData  clientData;
 303     Tcl_Interp *interp;
 304     int         argc;
 305     char      **argv;
 306 {
 307     return Tcl_UnaryFloatFunction(interp, argc, argv, cos);
 308 }
 309 \f
 310 /*
 311  *-----------------------------------------------------------------------------
 312  *
 313  * Tcl_SinCmd --
 314  *    Implements the TCL sin command:
 315  *        sin num
 316  *
 317  * Results:
 318  *      Returns TCL_OK if number is present and conversion succeeds.
 319  *
 320  *-----------------------------------------------------------------------------
 321  */
 322 int
 323 Tcl_SinCmd(clientData, interp, argc, argv)
 324     ClientData  clientData;
 325     Tcl_Interp *interp;
 326     int         argc;
 327     char      **argv;
 328 {
 329     return Tcl_UnaryFloatFunction(interp, argc, argv, sin);
 330 }
 331 \f
 332 /*
 333  *-----------------------------------------------------------------------------
 334  *
 335  * Tcl_TanCmd --
 336  *    Implements the TCL tangent command:
 337  *        tan num
 338  *
 339  * Results:
 340  *      Returns TCL_OK if number is present and conversion succeeds.
 341  *
 342  *-----------------------------------------------------------------------------
 343  */
 344 int
 345 Tcl_TanCmd(clientData, interp, argc, argv)
 346     ClientData  clientData;
 347     Tcl_Interp *interp;
 348     int         argc;
 349     char      **argv;
 350 {
 351     return Tcl_UnaryFloatFunction(interp, argc, argv, tan);
 352 }
 353 \f
 354 /*
 355  *-----------------------------------------------------------------------------
 356  *
 357  * Tcl_CoshCmd --
 358  *    Implements the TCL hyperbolic cosine command:
 359  *        cosh num
 360  *
 361  * Results:
 362  *      Returns TCL_OK if number is present and conversion succeeds.
 363  *
 364  *-----------------------------------------------------------------------------
 365  */
 366 int
 367 Tcl_CoshCmd(clientData, interp, argc, argv)
 368     ClientData  clientData;
 369     Tcl_Interp *interp;
 370     int         argc;
 371     char      **argv;
 372 {
 373     return Tcl_UnaryFloatFunction(interp, argc, argv, cosh);
 374 }
 375 \f
 376 /*
 377  *-----------------------------------------------------------------------------
 378  *
 379  * Tcl_SinhCmd --
 380  *    Implements the TCL hyperbolic sin command:
 381  *        sinh num
 382  *
 383  * Results:
 384  *      Returns TCL_OK if number is present and conversion succeeds.
 385  *
 386  *-----------------------------------------------------------------------------
 387  */
 388 int
 389 Tcl_SinhCmd(clientData, interp, argc, argv)
 390     ClientData  clientData;
 391     Tcl_Interp *interp;
 392     int         argc;
 393     char      **argv;
 394 {
 395     return Tcl_UnaryFloatFunction(interp, argc, argv, sinh);
 396 }
 397 \f
 398 /*
 399  *-----------------------------------------------------------------------------
 400  *
 401  * Tcl_TanhCmd --
 402  *    Implements the TCL hyperbolic tangent command:
 403  *        tanh num
 404  *
 405  * Results:
 406  *      Returns TCL_OK if number is present and conversion succeeds.
 407  *
 408  *-----------------------------------------------------------------------------
 409  */
 410 int
 411 Tcl_TanhCmd(clientData, interp, argc, argv)
 412     ClientData  clientData;
 413     Tcl_Interp *interp;
 414     int         argc;
 415     char      **argv;
 416 {
 417     return Tcl_UnaryFloatFunction(interp, argc, argv, tanh);
 418 }
 419 \f
 420 /*
 421  *-----------------------------------------------------------------------------
 422  *
 423  * Tcl_ExpCmd --
 424  *    Implements the TCL exponent command:
 425  *        exp num
 426  *
 427  * Results:
 428  *      Returns TCL_OK if number is present and conversion succeeds.
 429  *
 430  *-----------------------------------------------------------------------------
 431  */
 432 int
 433 Tcl_ExpCmd(clientData, interp, argc, argv)
 434     ClientData  clientData;
 435     Tcl_Interp *interp;
 436     int         argc;
 437     char      **argv;
 438 {
 439     return Tcl_UnaryFloatFunction(interp, argc, argv, exp);
 440 }
 441 \f
 442 /*
 443  *-----------------------------------------------------------------------------
 444  *
 445  * Tcl_LogCmd --
 446  *    Implements the TCL logarithm command:
 447  *        log num
 448  *
 449  * Results:
 450  *      Returns TCL_OK if number is present and conversion succeeds.
 451  *
 452  *-----------------------------------------------------------------------------
 453  */
 454 int
 455 Tcl_LogCmd(clientData, interp, argc, argv)
 456     ClientData  clientData;
 457     Tcl_Interp *interp;
 458     int         argc;
 459     char      **argv;
 460 {
 461     return Tcl_UnaryFloatFunction(interp, argc, argv, log);
 462 }
 463 \f
 464 /*
 465  *-----------------------------------------------------------------------------
 466  *
 467  * Tcl_Log10Cmd --
 468  *    Implements the TCL base-10 logarithm command:
 469  *        log10 num
 470  *
 471  * Results:
 472  *      Returns TCL_OK if number is present and conversion succeeds.
 473  *
 474  *-----------------------------------------------------------------------------
 475  */
 476 int
 477 Tcl_Log10Cmd(clientData, interp, argc, argv)
 478     ClientData  clientData;
 479     Tcl_Interp *interp;
 480     int         argc;
 481     char      **argv;
 482 {
 483     return Tcl_UnaryFloatFunction(interp, argc, argv, log10);
 484 }
 485 \f
 486 /*
 487  *-----------------------------------------------------------------------------
 488  *
 489  * Tcl_SqrtCmd --
 490  *    Implements the TCL square root command:
 491  *        sqrt num
 492  *
 493  * Results:
 494  *      Returns TCL_OK if number is present and conversion succeeds.
 495  *
 496  *-----------------------------------------------------------------------------
 497  */
 498 int
 499 Tcl_SqrtCmd(clientData, interp, argc, argv)
 500     ClientData  clientData;
 501     Tcl_Interp *interp;
 502     int         argc;
 503     char      **argv;
 504 {
 505     return Tcl_UnaryFloatFunction(interp, argc, argv, sqrt);
 506 }
 507 \f
 508 /*
 509  *-----------------------------------------------------------------------------
 510  *
 511  * Tcl_FabsCmd --
 512  *    Implements the TCL floating point absolute value command:
 513  *        fabs num
 514  *
 515  * Results:
 516  *      Returns TCL_OK if number is present and conversion succeeds.
 517  *
 518  *-----------------------------------------------------------------------------
 519  */
 520 int
 521 Tcl_FabsCmd(clientData, interp, argc, argv)
 522     ClientData  clientData;
 523     Tcl_Interp *interp;
 524     int         argc;
 525     char      **argv;
 526 {
 527     return Tcl_UnaryFloatFunction(interp, argc, argv, fabs);
 528 }
 529 \f
 530 /*
 531  *-----------------------------------------------------------------------------
 532  *
 533  * Tcl_FloorCmd --
 534  *    Implements the TCL floor command:
 535  *        floor num
 536  *
 537  * Results:
 538  *      Returns TCL_OK if number is present and conversion succeeds.
 539  *
 540  *-----------------------------------------------------------------------------
 541  */
 542 int
 543 Tcl_FloorCmd(clientData, interp, argc, argv)
 544     ClientData  clientData;
 545     Tcl_Interp *interp;
 546     int         argc;
 547     char      **argv;
 548 {
 549     return Tcl_UnaryFloatFunction(interp, argc, argv, floor);
 550 }
 551 \f
 552 /*
 553  *-----------------------------------------------------------------------------
 554  *
 555  * Tcl_CeilCmd --
 556  *    Implements the TCL ceil command:
 557  *        ceil num
 558  *
 559  * Results:
 560  *      Returns TCL_OK if number is present and conversion succeeds.
 561  *
 562  *-----------------------------------------------------------------------------
 563  */
 564 int
 565 Tcl_CeilCmd(clientData, interp, argc, argv)
 566     ClientData  clientData;
 567     Tcl_Interp *interp;
 568     int         argc;
 569     char      **argv;
 570 {
 571     return Tcl_UnaryFloatFunction(interp, argc, argv, ceil);
 572 }
 573 \f
 574 /*
 575  *-----------------------------------------------------------------------------
 576  *
 577  * Tcl_FmodCmd --
 578  *    Implements the TCL floating modulo command:
 579  *        fmod num1 num2
 580  *
 581  * Results:
 582  *      Returns TCL_OK if number is present and conversion succeeds.
 583  *
 584  *-----------------------------------------------------------------------------
 585  */
 586 int
 587 Tcl_FmodCmd(clientData, interp, argc, argv)
 588     ClientData  clientData;
 589     Tcl_Interp *interp;
 590     int         argc;
 591     char      **argv;
 592 {
 593     double dbVal, dbDivisor, dbResult;
 594
 595     if (argc != 3) {
 596         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " expr divisor",
 597                           (char *) NULL);
 598         return TCL_ERROR;
 599     }
 600
 601     if (Tcl_ExprDouble (interp, argv [1], &dbVal) != TCL_OK)
 602         return TCL_ERROR;
 603
 604     if (Tcl_ExprDouble (interp, argv [2], &dbDivisor) != TCL_OK)
 605         return TCL_ERROR;
 606
 607     G_inTclFPMath = TRUE;
 608     dbResult = fmod (dbVal, dbDivisor);
 609     G_inTclFPMath = FALSE;
 610
 611 #ifdef TCL_IEEE_FP_MATH
 612     if ((dbResult != dbResult) ||
 613         (dbResult < -MAXDOUBLE) ||
 614         (dbResult >  MAXDOUBLE))
 615         return ReturnIEEEMathError (interp, dbResult);
 616 #else
 617     if (G_gotTclFPMathErr)
 618         return ReturnFPMathError (interp);
 619 #endif
 620
 621     Tcl_ReturnDouble (interp, dbResult);
 622     return TCL_OK;
 623 }
 624 \f
 625 /*
 626  *-----------------------------------------------------------------------------
 627  *
 628  * Tcl_PowCmd --
 629  *    Implements the TCL power (exponentiation) command:
 630  *        pow num1 num2
 631  *
 632  * Results:
 633  *      Returns TCL_OK if number is present and conversion succeeds.
 634  *
 635  *-----------------------------------------------------------------------------
 636  */
 637 int
 638 Tcl_PowCmd(clientData, interp, argc, argv)
 639     ClientData  clientData;
 640     Tcl_Interp *interp;
 641     int         argc;
 642     char      **argv;
 643 {
 644     double dbVal, dbExp, dbResult;
 645
 646     if (argc != 3) {
 647         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " expr exp",
 648                           (char *) NULL);
 649         return TCL_ERROR;
 650     }
 651
 652     if (Tcl_ExprDouble (interp, argv [1], &dbVal) != TCL_OK)
 653         return TCL_ERROR;
 654
 655     if (Tcl_ExprDouble (interp, argv [2], &dbExp) != TCL_OK)
 656         return TCL_ERROR;
 657
 658     G_inTclFPMath = TRUE;
 659     dbResult = pow (dbVal,dbExp);
 660     G_inTclFPMath = FALSE;
 661
 662 #ifdef TCL_IEEE_FP_MATH
 663     if ((dbResult != dbResult) ||
 664         (dbResult < -MAXDOUBLE) ||
 665         (dbResult >  MAXDOUBLE))
 666         return ReturnIEEEMathError (interp, dbResult);
 667 #else
 668     if (G_gotTclFPMathErr)
 669         return ReturnFPMathError (interp);
 670 #endif
 671
 672     Tcl_ReturnDouble (interp, dbResult);
 673     return TCL_OK;
 674 }