home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXfmath.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  18.7 KB  |  694 lines
  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 "tclExtdInt.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. 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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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.  
  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. }
  694.