src/clipsrules/core/emathfun.c Source File

00001    /*******************************************************/
00002    /*      "C" Language Integrated Production System      */
00003    /*                                                     */
00004    /*             CLIPS Version 6.22  06/15/04            */
00005    /*                                                     */
00006    /*            EXTENDED MATH FUNCTIONS MODULE           */
00007    /*******************************************************/
00008 
00009 /*************************************************************/
00010 /* Purpose: Contains the code for numerous extended math     */
00011 /*   functions including cos, sin, tan, sec, csc, cot, acos, */
00012 /*   asin, atan, asec, acsc, acot, cosh, sinh, tanh, sech,   */
00013 /*   csch, coth, acosh, asinh, atanh, asech, acsch, acoth,   */
00014 /*   mod, exp, log, log10, sqrt, pi, deg-rad, rad-deg,       */
00015 /*   deg-grad, grad-deg, **, and round.                      */
00016 /*                                                           */
00017 /* Principal Programmer(s):                                  */
00018 /*      Brian L. Dantes                                      */
00019 /*                                                           */
00020 /* Contributing Programmer(s):                               */
00021 /*      Gary D. Riley                                        */
00022 /*                                                           */
00023 /* Revision History:                                         */
00024 /*                                                           */
00025 /*************************************************************/
00026 
00027 #include "setup.h"
00028 #include "argacces.h"
00029 #include "envrnmnt.h"
00030 #include "extnfunc.h"
00031 #include "router.h"
00032 
00033 #include "emathfun.h"
00034 
00035 #if EXTENDED_MATH_FUNCTIONS
00036 
00037 #include <math.h>
00038 
00039 /***************/
00040 /* DEFINITIONS */
00041 /***************/
00042 
00043 #ifndef PI
00044 #define PI   3.14159265358979323846
00045 #endif
00046 
00047 #ifndef PID2
00048 #define PID2 1.57079632679489661923 /* PI divided by 2 */
00049 #endif
00050 
00051 #define SMALLEST_ALLOWED_NUMBER 1e-15
00052 #define dtrunc(x) (((x) < 0.0) ? ceil(x) : floor(x))
00053 
00054 /***************************************/
00055 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
00056 /***************************************/
00057 
00058    static int                     SingleNumberCheck(void *,char *,double *);
00059    static int                     TestProximity(double,double);
00060    static void                    DomainErrorMessage(void *,char *);
00061    static void                    ArgumentOverflowErrorMessage(void *,char *);
00062    static void                    SingularityErrorMessage(void *,char *);
00063    static double                  genacosh(double);
00064    static double                  genasinh(double);
00065    static double                  genatanh(double);
00066    static double                  genasech(double);
00067    static double                  genacsch(double);
00068    static double                  genacoth(double);
00069 
00070 /************************************************/
00071 /* ExtendedMathFunctionDefinitions: Initializes */
00072 /*   the extended math functions.               */
00073 /************************************************/
00074 globle void ExtendedMathFunctionDefinitions(
00075   void *theEnv)
00076   {
00077 #if ! RUN_TIME
00078    EnvDefineFunction2(theEnv,"cos",      'd', PTIEF CosFunction,      "CosFunction", "11n");
00079    EnvDefineFunction2(theEnv,"sin",      'd', PTIEF SinFunction,      "SinFunction", "11n");
00080    EnvDefineFunction2(theEnv,"tan",      'd', PTIEF TanFunction,      "TanFunction", "11n");
00081    EnvDefineFunction2(theEnv,"sec",      'd', PTIEF SecFunction,      "SecFunction", "11n");
00082    EnvDefineFunction2(theEnv,"csc",      'd', PTIEF CscFunction,      "CscFunction", "11n");
00083    EnvDefineFunction2(theEnv,"cot",      'd', PTIEF CotFunction,      "CotFunction", "11n");
00084    EnvDefineFunction2(theEnv,"acos",     'd', PTIEF AcosFunction,     "AcosFunction", "11n");
00085    EnvDefineFunction2(theEnv,"asin",     'd', PTIEF AsinFunction,     "AsinFunction", "11n");
00086    EnvDefineFunction2(theEnv,"atan",     'd', PTIEF AtanFunction,     "AtanFunction", "11n");
00087    EnvDefineFunction2(theEnv,"asec",     'd', PTIEF AsecFunction,     "AsecFunction", "11n");
00088    EnvDefineFunction2(theEnv,"acsc",     'd', PTIEF AcscFunction,     "AcscFunction", "11n");
00089    EnvDefineFunction2(theEnv,"acot",     'd', PTIEF AcotFunction,     "AcotFunction", "11n");
00090    EnvDefineFunction2(theEnv,"cosh",     'd', PTIEF CoshFunction,     "CoshFunction", "11n");
00091    EnvDefineFunction2(theEnv,"sinh",     'd', PTIEF SinhFunction,     "SinhFunction", "11n");
00092    EnvDefineFunction2(theEnv,"tanh",     'd', PTIEF TanhFunction,     "TanhFunction", "11n");
00093    EnvDefineFunction2(theEnv,"sech",     'd', PTIEF SechFunction,     "SechFunction", "11n");
00094    EnvDefineFunction2(theEnv,"csch",     'd', PTIEF CschFunction,     "CschFunction", "11n");
00095    EnvDefineFunction2(theEnv,"coth",     'd', PTIEF CothFunction,     "CothFunction", "11n");
00096    EnvDefineFunction2(theEnv,"acosh",    'd', PTIEF AcoshFunction,    "AcoshFunction", "11n");
00097    EnvDefineFunction2(theEnv,"asinh",    'd', PTIEF AsinhFunction,    "AsinhFunction", "11n");
00098    EnvDefineFunction2(theEnv,"atanh",    'd', PTIEF AtanhFunction,    "AtanhFunction", "11n");
00099    EnvDefineFunction2(theEnv,"asech",    'd', PTIEF AsechFunction,    "AsechFunction", "11n");
00100    EnvDefineFunction2(theEnv,"acsch",    'd', PTIEF AcschFunction,    "AcschFunction", "11n");
00101    EnvDefineFunction2(theEnv,"acoth",    'd', PTIEF AcothFunction,    "AcothFunction", "11n");
00102 
00103    EnvDefineFunction2(theEnv,"mod",      'n', PTIEF ModFunction,      "ModFunction", "22n");
00104    EnvDefineFunction2(theEnv,"exp",      'd', PTIEF ExpFunction,      "ExpFunction", "11n");
00105    EnvDefineFunction2(theEnv,"log",      'd', PTIEF LogFunction,      "LogFunction", "11n");
00106    EnvDefineFunction2(theEnv,"log10",    'd', PTIEF Log10Function,    "Log10Function", "11n");
00107    EnvDefineFunction2(theEnv,"sqrt",     'd', PTIEF SqrtFunction,     "SqrtFunction", "11n");
00108    EnvDefineFunction2(theEnv,"pi",       'd', PTIEF PiFunction,       "PiFunction", "00");
00109    EnvDefineFunction2(theEnv,"deg-rad",  'd', PTIEF DegRadFunction,   "DegRadFunction", "11n");
00110    EnvDefineFunction2(theEnv,"rad-deg",  'd', PTIEF RadDegFunction,   "RadDegFunction", "11n");
00111    EnvDefineFunction2(theEnv,"deg-grad", 'd', PTIEF DegGradFunction,  "DegGradFunction", "11n");
00112    EnvDefineFunction2(theEnv,"grad-deg", 'd', PTIEF GradDegFunction,  "GradDegFunction", "11n");
00113    EnvDefineFunction2(theEnv,"**",       'd', PTIEF PowFunction,      "PowFunction", "22n");
00114    EnvDefineFunction2(theEnv,"round",    'g', PTIEF RoundFunction,    "RoundFunction", "11n");
00115 #else
00116 #if MAC_MCW || WIN_MCW || MAC_XCD
00117 #pragma unused(theEnv)
00118 #endif
00119 #endif
00120   }
00121 
00122 /************************************************************/
00123 /* SingleNumberCheck: Retrieves the numeric argument for    */
00124 /*   extended math functions which expect a single floating */
00125 /*   point argument.                                        */
00126 /************************************************************/
00127 static int SingleNumberCheck(
00128   void *theEnv,
00129   char *functionName,
00130   double *theNumber)
00131   {
00132    DATA_OBJECT theValue;
00133 
00134    if (EnvArgCountCheck(theEnv,functionName,EXACTLY,1) == -1) return(FALSE);
00135    if (EnvArgTypeCheck(theEnv,functionName,1,FLOAT,&theValue) == FALSE) return(FALSE);
00136 
00137    *theNumber = DOToDouble(theValue);
00138    return(TRUE);
00139   }
00140 
00141 /**************************************************************/
00142 /* TestProximity: Returns TRUE if the specified number falls  */
00143 /*   within the specified range, otherwise FALSE is returned. */
00144 /**************************************************************/
00145 static int TestProximity(
00146   double theNumber,
00147   double range)
00148   {
00149    if ((theNumber >= (- range)) && (theNumber <= range)) return TRUE;
00150    else return FALSE;
00151   }
00152 
00153 /********************************************************/
00154 /* DomainErrorMessage: Generic error message used when  */
00155 /*   a domain error is detected during a call to one of */
00156 /*   the extended math functions.                       */
00157 /********************************************************/
00158 static void DomainErrorMessage(
00159   void *theEnv,
00160   char *functionName)
00161   {
00162    PrintErrorID(theEnv,"EMATHFUN",1,FALSE);
00163    EnvPrintRouter(theEnv,WERROR,"Domain error for ");
00164    EnvPrintRouter(theEnv,WERROR,functionName);
00165    EnvPrintRouter(theEnv,WERROR," function.\n");
00166    SetHaltExecution(theEnv,TRUE);
00167    SetEvaluationError(theEnv,TRUE);
00168   }
00169 
00170 /************************************************************/
00171 /* ArgumentOverflowErrorMessage: Generic error message used */
00172 /*   when an argument overflow is detected during a call to */
00173 /*   one of the extended math functions.                    */
00174 /************************************************************/
00175 static void ArgumentOverflowErrorMessage(
00176   void *theEnv,
00177   char *functionName)
00178   {
00179    PrintErrorID(theEnv,"EMATHFUN",2,FALSE);
00180    EnvPrintRouter(theEnv,WERROR,"Argument overflow for ");
00181    EnvPrintRouter(theEnv,WERROR,functionName);
00182    EnvPrintRouter(theEnv,WERROR," function.\n");
00183    SetHaltExecution(theEnv,TRUE);
00184    SetEvaluationError(theEnv,TRUE);
00185   }
00186 
00187 /************************************************************/
00188 /* SingularityErrorMessage: Generic error message used when */
00189 /*   a singularity is detected during a call to one of the  */
00190 /*   extended math functions.                               */
00191 /************************************************************/
00192 static void SingularityErrorMessage(
00193   void *theEnv,
00194   char *functionName)
00195   {
00196    PrintErrorID(theEnv,"EMATHFUN",3,FALSE);
00197    EnvPrintRouter(theEnv,WERROR,"Singularity at asymptote in ");
00198    EnvPrintRouter(theEnv,WERROR,functionName);
00199    EnvPrintRouter(theEnv,WERROR," function.\n");
00200    SetHaltExecution(theEnv,TRUE);
00201    SetEvaluationError(theEnv,TRUE);
00202   }
00203 
00204 /*************************************/
00205 /* CosFunction: H/L access routine   */
00206 /*   for the cos function.           */
00207 /*************************************/
00208 globle double CosFunction(
00209   void *theEnv)
00210   {
00211    double num;
00212 
00213    if (SingleNumberCheck(theEnv,"cos",&num) == FALSE) return(0.0);
00214    return(cos(num));
00215   }
00216 
00217 /*************************************/
00218 /* SinFunction: H/L access routine   */
00219 /*   for the sin function.           */
00220 /*************************************/
00221 globle double SinFunction(
00222   void *theEnv)
00223   {
00224    double num;
00225 
00226    if (SingleNumberCheck(theEnv,"sin",&num) == FALSE) return(0.0);
00227    return(sin(num));
00228   }
00229 
00230 /*************************************/
00231 /* TanFunction: H/L access routine   */
00232 /*   for the tan function.           */
00233 /*************************************/
00234 globle double TanFunction(
00235   void *theEnv)
00236   {
00237    double num, tv;
00238 
00239    if (SingleNumberCheck(theEnv,"tan",&num) == FALSE) return (0.0);
00240    tv = cos(num);
00241    if ((tv < SMALLEST_ALLOWED_NUMBER) && (tv > -SMALLEST_ALLOWED_NUMBER))
00242      {
00243       SingularityErrorMessage(theEnv,"tan");
00244       return(0.0);
00245      }
00246 
00247    return(sin(num) / tv);
00248   }
00249 
00250 /*************************************/
00251 /* SecFunction: H/L access routine   */
00252 /*   for the sec function.           */
00253 /*************************************/
00254 globle double SecFunction(
00255   void *theEnv)
00256   {
00257    double num, tv;
00258 
00259    if (SingleNumberCheck(theEnv,"sec",&num) == FALSE) return(0.0);
00260 
00261    tv = cos(num);
00262    if ((tv < SMALLEST_ALLOWED_NUMBER) && (tv > -SMALLEST_ALLOWED_NUMBER))
00263      {
00264       SingularityErrorMessage(theEnv,"sec");
00265       return(0.0);
00266      }
00267 
00268    return(1.0 / tv);
00269   }
00270 
00271 /*************************************/
00272 /* CscFunction: H/L access routine   */
00273 /*   for the csc function.           */
00274 /*************************************/
00275 globle double CscFunction(
00276   void *theEnv)
00277   {
00278    double num, tv;
00279 
00280    if (SingleNumberCheck(theEnv,"csc",&num) == FALSE) return(0.0);
00281    tv = sin(num);
00282    if ((tv < SMALLEST_ALLOWED_NUMBER) && (tv > -SMALLEST_ALLOWED_NUMBER))
00283      {
00284       SingularityErrorMessage(theEnv,"csc");
00285       return(0.0);
00286      }
00287 
00288    return(1.0 / tv);
00289   }
00290 
00291 /*************************************/
00292 /* CotFunction: H/L access routine   */
00293 /*   for the cot function.           */
00294 /*************************************/
00295 globle double CotFunction(
00296   void *theEnv)
00297   {
00298     double num, tv;
00299 
00300     if (SingleNumberCheck(theEnv,"cot",&num) == FALSE) return(0.0);
00301 
00302     tv = sin(num);
00303     if ((tv < SMALLEST_ALLOWED_NUMBER) && (tv > -SMALLEST_ALLOWED_NUMBER))
00304       {
00305        SingularityErrorMessage(theEnv,"cot");
00306        return(0.0);
00307       }
00308 
00309     return(cos(num) / tv);
00310   }
00311 
00312 /**************************************/
00313 /* AcosFunction: H/L access routine   */
00314 /*   for the acos function.           */
00315 /**************************************/
00316 globle double AcosFunction(
00317   void *theEnv)
00318   {
00319    double num;
00320 
00321    if (SingleNumberCheck(theEnv,"acos",&num) == FALSE) return(0.0);
00322    if ((num > 1.0) || (num < -1.0))
00323      {
00324       DomainErrorMessage(theEnv,"acos");
00325       return(0.0);
00326      }
00327     return(acos(num));
00328   }
00329 
00330 /**************************************/
00331 /* AsinFunction: H/L access routine   */
00332 /*   for the asin function.           */
00333 /**************************************/
00334 globle double AsinFunction(
00335   void *theEnv)
00336   {
00337    double num;
00338 
00339    if (SingleNumberCheck(theEnv,"asin",&num) == FALSE) return(0.0);
00340    if ((num > 1.0) || (num < -1.0))
00341      {
00342       DomainErrorMessage(theEnv,"asin");
00343       return(0.0);
00344      }
00345    return(asin(num));
00346   }
00347 
00348 /**************************************/
00349 /* AtanFunction: H/L access routine   */
00350 /*   for the atan function.           */
00351 /**************************************/
00352 globle double AtanFunction(
00353   void *theEnv)
00354   {
00355    double num;
00356 
00357    if (SingleNumberCheck(theEnv,"atan",&num) == FALSE) return(0.0);
00358    return(atan(num));
00359   }
00360 
00361 /**************************************/
00362 /* AsecFunction: H/L access routine   */
00363 /*   for the asec function.           */
00364 /**************************************/
00365 globle double AsecFunction(
00366   void *theEnv)
00367   {
00368    double num;
00369 
00370    if (SingleNumberCheck(theEnv,"asec",&num) == FALSE) return(0.0);
00371    if ((num < 1.0) && (num > -1.0))
00372      {
00373       DomainErrorMessage(theEnv,"asec");
00374       return(0.0);
00375      }
00376     num = 1.0 / num;
00377     return(acos(num));
00378   }
00379 
00380 /**************************************/
00381 /* AcscFunction: H/L access routine   */
00382 /*   for the acsc function.           */
00383 /**************************************/
00384 globle double AcscFunction(
00385   void *theEnv)
00386   {
00387    double num;
00388 
00389    if (SingleNumberCheck(theEnv,"acsc",&num) == FALSE) return(0.0);
00390    if ((num < 1.0) && (num > -1.0))
00391      {
00392       DomainErrorMessage(theEnv,"acsc");
00393       return(0.0);
00394      }
00395     num = 1.0 / num;
00396     return(asin(num));
00397   }
00398 
00399 /**************************************/
00400 /* AcotFunction: H/L access routine   */
00401 /*   for the acot function.           */
00402 /**************************************/
00403 globle double AcotFunction(
00404   void *theEnv)
00405   {
00406    double num;
00407 
00408    if (SingleNumberCheck(theEnv,"acot",&num) == FALSE) return(0.0);
00409    if (TestProximity(num,1e-25) == TRUE)  return(PID2);
00410    num = 1.0 / num;
00411    return(atan(num));
00412   }
00413 
00414 /**************************************/
00415 /* CoshFunction: H/L access routine   */
00416 /*   for the cosh function.           */
00417 /**************************************/
00418 globle double CoshFunction(
00419   void *theEnv)
00420   {
00421    double num;
00422 
00423    if (SingleNumberCheck(theEnv,"cosh",&num) == FALSE) return(0.0);
00424    return(cosh(num));
00425   }
00426 
00427 /**************************************/
00428 /* SinhFunction: H/L access routine   */
00429 /*   for the sinh function.           */
00430 /**************************************/
00431 globle double SinhFunction(
00432   void *theEnv)
00433   {
00434    double num;
00435 
00436    if (SingleNumberCheck(theEnv,"sinh",&num) == FALSE) return(0.0);
00437    return(sinh(num));
00438   }
00439 
00440 /**************************************/
00441 /* TanhFunction: H/L access routine   */
00442 /*   for the tanh function.           */
00443 /**************************************/
00444 globle double TanhFunction(
00445   void *theEnv)
00446   {
00447    double num;
00448 
00449    if (SingleNumberCheck(theEnv,"tanh",&num) == FALSE) return(0.0);
00450    return(tanh(num));
00451   }
00452 
00453 /**************************************/
00454 /* SechFunction: H/L access routine   */
00455 /*   for the sech function.           */
00456 /**************************************/
00457 globle double SechFunction(
00458   void *theEnv)
00459   {
00460    double num;
00461 
00462    if (SingleNumberCheck(theEnv,"sech",&num) == FALSE) return(0.0);
00463    return(1.0 / cosh(num));
00464   }
00465 
00466 /**************************************/
00467 /* CschFunction: H/L access routine   */
00468 /*   for the csch function.           */
00469 /**************************************/
00470 globle double CschFunction(
00471   void *theEnv)
00472   {
00473    double num;
00474 
00475    if (SingleNumberCheck(theEnv,"csch",&num) == FALSE) return(0.0);
00476    if (num == 0.0)
00477      {
00478       SingularityErrorMessage(theEnv,"csch");
00479       return(0.0);
00480      }
00481    else if (TestProximity(num,1e-25) == TRUE)
00482      {
00483       ArgumentOverflowErrorMessage(theEnv,"csch");
00484       return(0.0);
00485      }
00486    return(1.0 / sinh(num));
00487   }
00488 
00489 /**************************************/
00490 /* CothFunction: H/L access routine   */
00491 /*   for the coth function.           */
00492 /**************************************/
00493 globle double CothFunction(
00494   void *theEnv)
00495   {
00496    double num;
00497 
00498    if (SingleNumberCheck(theEnv,"coth",&num) == FALSE) return(0.0);
00499    if (num == 0.0)
00500      {
00501       SingularityErrorMessage(theEnv,"coth");
00502       return(0.0);
00503      }
00504    else if (TestProximity(num,1e-25) == TRUE)
00505      {
00506       ArgumentOverflowErrorMessage(theEnv,"coth");
00507       return(0.0);
00508      }
00509    return(1.0 / tanh(num));
00510   }
00511 
00512 /***************************************/
00513 /* AcoshFunction: H/L access routine   */
00514 /*   for the acosh function.           */
00515 /***************************************/
00516 globle double AcoshFunction(
00517   void *theEnv)
00518   {
00519    double num;
00520 
00521    if (SingleNumberCheck(theEnv,"acosh",&num) == FALSE) return(0.0);
00522    if (num < 1.0)
00523      {
00524       DomainErrorMessage(theEnv,"acosh");
00525       return(0.0);
00526      }
00527    return(genacosh(num));
00528   }
00529 
00530 /***************************************/
00531 /* AsinhFunction: H/L access routine   */
00532 /*   for the asinh function.           */
00533 /***************************************/
00534 globle double AsinhFunction(
00535   void *theEnv)
00536   {
00537    double num;
00538 
00539    if (SingleNumberCheck(theEnv,"asinh",&num) == FALSE) return(0.0);
00540    return(genasinh(num));
00541   }
00542 
00543 /***************************************/
00544 /* AtanhFunction: H/L access routine   */
00545 /*   for the atanh function.           */
00546 /***************************************/
00547 globle double AtanhFunction(
00548   void *theEnv)
00549   {
00550    double num;
00551 
00552    if (SingleNumberCheck(theEnv,"atanh",&num) == FALSE) return(0.0);
00553    if ((num >= 1.0) || (num <= -1.0))
00554      {
00555       DomainErrorMessage(theEnv,"atanh");
00556       return(0.0);
00557      }
00558    return(genatanh(num));
00559   }
00560 
00561 /***************************************/
00562 /* AsechFunction: H/L access routine   */
00563 /*   for the asech function.           */
00564 /***************************************/
00565 globle double AsechFunction(
00566   void *theEnv)
00567   {
00568    double num;
00569 
00570    if (SingleNumberCheck(theEnv,"asech",&num) == FALSE) return(0.0);
00571    if ((num > 1.0) || (num <= 0.0))
00572      {
00573       DomainErrorMessage(theEnv,"asech");
00574       return(0.0);
00575      }
00576    return(genasech(num));
00577   }
00578 
00579 /***************************************/
00580 /* AcschFunction: H/L access routine   */
00581 /*   for the acsch function.           */
00582 /***************************************/
00583 globle double AcschFunction(
00584   void *theEnv)
00585   {
00586    double num;
00587 
00588    if (SingleNumberCheck(theEnv,"acsch",&num) == FALSE) return(0.0);
00589    if (num == 0.0)
00590      {
00591       DomainErrorMessage(theEnv,"acsch");
00592       return(0.0);
00593      }
00594    return(genacsch(num));
00595   }
00596 
00597 /***************************************/
00598 /* AcothFunction: H/L access routine   */
00599 /*   for the acoth function.           */
00600 /***************************************/
00601 globle double AcothFunction(
00602   void *theEnv)
00603   {
00604    double num;
00605 
00606    if (SingleNumberCheck(theEnv,"acoth",&num) == FALSE) return(0.0);
00607    if ((num <= 1.0) && (num >= -1.0))
00608      {
00609       DomainErrorMessage(theEnv,"acoth");
00610       return(0.0);
00611      }
00612    return(genacoth(num));
00613   }
00614 
00615 /*************************************/
00616 /* ExpFunction: H/L access routine   */
00617 /*   for the exp function.           */
00618 /*************************************/
00619 globle double ExpFunction(
00620   void *theEnv)
00621   {
00622    double num;
00623 
00624    if (SingleNumberCheck(theEnv,"exp",&num) == FALSE) return(0.0);
00625    return(exp(num));
00626   }
00627 
00628 /*************************************/
00629 /* LogFunction: H/L access routine   */
00630 /*   for the log function.           */
00631 /*************************************/
00632 globle double LogFunction(
00633   void *theEnv)
00634   {
00635    double num;
00636 
00637    if (SingleNumberCheck(theEnv,"log",&num) == FALSE) return(0.0);
00638    if (num < 0.0)
00639      {
00640       DomainErrorMessage(theEnv,"log");
00641       return(0.0);
00642      }
00643    else if (num == 0.0)
00644      {
00645       ArgumentOverflowErrorMessage(theEnv,"log");
00646       return(0.0);
00647      }
00648 
00649    return(log(num));
00650   }
00651 
00652 /***************************************/
00653 /* Log10Function: H/L access routine   */
00654 /*   for the log10 function.           */
00655 /***************************************/
00656 globle double Log10Function(
00657   void *theEnv)
00658   {
00659    double num;
00660 
00661    if (SingleNumberCheck(theEnv,"log10",&num) == FALSE) return(0.0);
00662    if (num < 0.0)
00663      {
00664       DomainErrorMessage(theEnv,"log10");
00665       return(0.0);
00666      }
00667    else if (num == 0.0)
00668      {
00669       ArgumentOverflowErrorMessage(theEnv,"log10");
00670       return(0.0);
00671      }
00672 
00673     return(log10(num));
00674    }
00675 
00676 /**************************************/
00677 /* SqrtFunction: H/L access routine   */
00678 /*   for the sqrt function.           */
00679 /**************************************/
00680 globle double SqrtFunction(
00681   void *theEnv)
00682   {
00683    double num;
00684 
00685    if (SingleNumberCheck(theEnv,"sqrt",&num) == FALSE) return(0.0);
00686    if (num < 0.00000)
00687      {
00688       DomainErrorMessage(theEnv,"sqrt");
00689       return(0.0);
00690      }
00691    return(sqrt(num));
00692   }
00693 
00694 /*************************************/
00695 /* PowFunction: H/L access routine   */
00696 /*   for the pow function.           */
00697 /*************************************/
00698 globle double PowFunction(
00699   void *theEnv)
00700   {
00701    DATA_OBJECT value1, value2;
00702 
00703    if (EnvArgCountCheck(theEnv,"**",EXACTLY,2) == -1) return(0.0);
00704 
00705    if (EnvArgTypeCheck(theEnv,"**",1,FLOAT,&value1) == FALSE) return(0.0);
00706    if (EnvArgTypeCheck(theEnv,"**",2,FLOAT,&value2) == FALSE) return(0.0);
00707 
00708     if (((DOToDouble(value1) == 0.0) &&
00709         (DOToDouble(value2) <= 0.0)) ||
00710        ((DOToDouble(value1) < 0.0) &&
00711         (dtrunc((double) DOToDouble(value2)) != DOToDouble(value2))))
00712      {
00713       DomainErrorMessage(theEnv,"**");
00714       SetHaltExecution(theEnv,TRUE);
00715       SetEvaluationError(theEnv,TRUE);
00716       return(0.0);
00717      }
00718 
00719    return (pow(DOToDouble(value1),DOToDouble(value2)));
00720   }
00721 
00722 /*************************************/
00723 /* ModFunction: H/L access routine   */
00724 /*   for the mod function.           */
00725 /*************************************/
00726 globle void ModFunction(
00727   void *theEnv,
00728   DATA_OBJECT_PTR result)
00729   {
00730    DATA_OBJECT item1, item2;
00731    double fnum1, fnum2;
00732    long long lnum1, lnum2;
00733 
00734    if (EnvArgCountCheck(theEnv,"mod",EXACTLY,2) == -1)
00735      {
00736       result->type = INTEGER;
00737       result->value = (void *) EnvAddLong(theEnv,0L);
00738       return;
00739      }
00740 
00741    if (EnvArgTypeCheck(theEnv,"mod",1,INTEGER_OR_FLOAT,&item1) == FALSE)
00742      {
00743       result->type = INTEGER;
00744       result->value = (void *) EnvAddLong(theEnv,0L);
00745       return;
00746      }
00747 
00748    if (EnvArgTypeCheck(theEnv,"mod",2,INTEGER_OR_FLOAT,&item2) == FALSE)
00749      {
00750       result->type = INTEGER;
00751       result->value = (void *) EnvAddLong(theEnv,0L);
00752       return;
00753      }
00754 
00755    if (((item2.type == INTEGER) ? (ValueToLong(item2.value) == 0L) : FALSE) ||
00756        ((item2.type == FLOAT) ? ValueToDouble(item2.value) == 0.0 : FALSE))
00757      {
00758       DivideByZeroErrorMessage(theEnv,"mod");
00759       SetEvaluationError(theEnv,TRUE);
00760       result->type = INTEGER;
00761       result->value = (void *) EnvAddLong(theEnv,0L);
00762       return;
00763      }
00764 
00765    if ((item1.type == FLOAT) || (item2.type == FLOAT))
00766      {
00767       fnum1 = CoerceToDouble(item1.type,item1.value);
00768       fnum2 = CoerceToDouble(item2.type,item2.value);
00769       result->type = FLOAT;
00770       result->value = (void *) EnvAddDouble(theEnv,fnum1 - (dtrunc(fnum1 / fnum2) * fnum2));
00771      }
00772    else
00773      {
00774       lnum1 = DOToLong(item1);
00775       lnum2 = DOToLong(item2);
00776       result->type = INTEGER;
00777       result->value = (void *) EnvAddLong(theEnv,lnum1 - (lnum1 / lnum2) * lnum2);
00778      }
00779   }
00780 
00781 /************************************/
00782 /* PiFunction: H/L access routine   */
00783 /*   for the pi function.           */
00784 /************************************/
00785 globle double PiFunction(
00786   void *theEnv)
00787   {
00788 
00789    if (EnvArgCountCheck(theEnv,"pi",EXACTLY,0) == -1) return(acos(-1.0));
00790    return(acos(-1.0));
00791   }
00792 
00793 /****************************************/
00794 /* DegRadFunction: H/L access routine   */
00795 /*   for the deg-rad function.          */
00796 /****************************************/
00797 globle double DegRadFunction(
00798   void *theEnv)
00799   {
00800    double num;
00801 
00802    if (SingleNumberCheck(theEnv,"deg-rad",&num) == FALSE) return(0.0);
00803    return(num * PI / 180.0);
00804   }
00805 
00806 /****************************************/
00807 /* RadDegFunction: H/L access routine   */
00808 /*   for the rad-deg function.          */
00809 /****************************************/
00810 globle double RadDegFunction(
00811   void *theEnv)
00812   {
00813    double num;
00814 
00815    if (SingleNumberCheck(theEnv,"rad-deg",&num) == FALSE) return(0.0);
00816    return(num * 180.0 / PI);
00817   }
00818 
00819 /*****************************************/
00820 /* DegGradFunction: H/L access routine   */
00821 /*   for the deg-grad function.          */
00822 /*****************************************/
00823 globle double DegGradFunction(
00824   void *theEnv)
00825   {
00826    double num;
00827 
00828    if (SingleNumberCheck(theEnv,"deg-grad",&num) == FALSE) return(0.0);
00829    return(num / 0.9);
00830   }
00831 
00832 /*****************************************/
00833 /* GradDegFunction: H/L access routine   */
00834 /*   for the grad-deg function.          */
00835 /*****************************************/
00836 globle double GradDegFunction(
00837   void *theEnv)
00838   {
00839    double num;
00840 
00841    if (SingleNumberCheck(theEnv,"grad-deg",&num) == FALSE) return(0.0);
00842    return(num * 0.9);
00843   }
00844 
00845 /***************************************/
00846 /* RoundFunction: H/L access routine   */
00847 /*   for the round function.           */
00848 /***************************************/
00849 globle long long RoundFunction(
00850   void *theEnv)
00851   {
00852    DATA_OBJECT result;
00853 
00854    if (EnvArgCountCheck(theEnv,"round",EXACTLY,1) == -1)
00855      { return(0LL); }
00856 
00857    if (EnvArgTypeCheck(theEnv,"round",1,INTEGER_OR_FLOAT,&result) == FALSE)
00858      { return(0LL); }
00859 
00860    if (result.type == INTEGER)
00861      { return(ValueToLong(result.value)); }
00862    else
00863      { return((long long) ceil(ValueToDouble(result.value) - 0.5)); }
00864   }
00865 
00866 /*******************************************/
00867 /* genacosh: Generic routine for computing */
00868 /*   the hyperbolic arccosine.             */
00869 /*******************************************/
00870 static double genacosh(
00871   double num)
00872   {
00873    return(log(num + sqrt(num * num - 1.0)));
00874   }
00875 
00876 /*******************************************/
00877 /* genasinh: Generic routine for computing */
00878 /*   the hyperbolic arcsine.               */
00879 /*******************************************/
00880 static double genasinh(
00881   double num)
00882   {
00883    return(log(num + sqrt(num * num + 1.0)));
00884   }
00885 
00886 /*******************************************/
00887 /* genatanh: Generic routine for computing */
00888 /*   the hyperbolic arctangent.            */
00889 /*******************************************/
00890 static double genatanh(
00891   double num)
00892   {
00893    return((0.5) * log((1.0 + num) / (1.0 - num)));
00894   }
00895 
00896 /*******************************************/
00897 /* genasech: Generic routine for computing */
00898 /*   the hyperbolic arcsecant.             */
00899 /*******************************************/
00900 static double genasech(
00901   double num)
00902   {
00903    return(log(1.0 / num + sqrt(1.0 / (num * num) - 1.0)));
00904   }
00905 
00906 /*******************************************/
00907 /* genacsch: Generic routine for computing */
00908 /*   the hyperbolic arccosecant.           */
00909 /*******************************************/
00910 static double genacsch(
00911   double num)
00912   {
00913    return(log(1.0 / num + sqrt(1.0 / (num * num) + 1.0)));
00914   }
00915 
00916 /*******************************************/
00917 /* genacoth: Generic routine for computing */
00918 /*   the hyperbolic arccotangent.          */
00919 /*******************************************/
00920 static double genacoth(
00921   double num)
00922   {
00923    return((0.5) * log((num + 1.0) / (num - 1.0)));
00924   }
00925 
00926 #endif
00927