diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 706f8775bf..b120f24526 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,33 @@ 2002-12-01 23:12 UTC+0100 Foo Bar */ +2002-07-07 22:40 UTC+0100 Martin Vogel + * source/rtl/math.c + * include/hbmath.h + + include/math.ch + * doc/en/math.txt + * math error handling redesigned + * tests/mathtest.prg + * small test program to demonstrate new math error handling capabilities + * source/vm/itemapi.c + * bug fix: app compiled with BCC crashed if hb_itemPutNDLen was called with a "NaN" double + * BCC checks for infinity added in hb_itemStr + * possible bug fixed: math handler has not been switched off before using log(0) in hb_itemStr + * contrib/libct/ctc.c + * contrib/libct/ctmath.c + * contrib/libct/ctmath.h + * contrib/libct/ctflist.txt + * contrib/libct/readme.txt + * contrib/libct/cterror.ch + * math error handling adopted to new design, function SETMATHERRMODE() removed + * contrib/libct/math.c + * contrib/libct/num1.c + * contrib/libct/trig.c + * contrib/libct/finan.c + * math error handling adopted to new design, compatibility with CTIII enhanced + * contrib/libct/test/Makefile + * typo fixed + 2002-07-07 11:05 UTC+0100 Antonio Linares * harbour/source/debug/debugger.prg * Changed constructor sequence diff --git a/harbour/contrib/libct/cterror.ch b/harbour/contrib/libct/cterror.ch index a3cd3ff4b5..492f2bc308 100644 --- a/harbour/contrib/libct/cterror.ch +++ b/harbour/contrib/libct/cterror.ch @@ -111,15 +111,6 @@ #define CT_ERROR_GETREAD_RANGEL 8900 /* get & read functions */ #define CT_ERROR_GETREAD_RANGEH 9099 -/* C math lib error sub codes */ -#define CT_ERROR_MATHLIB 100 /* unknown math lib error */ -#define CT_ERROR_MATHLIB_DOMAIN 101 /* a domain error has occured, such as sqrt( -1 ) */ -#define CT_ERROR_MATHLIB_SING 102 /* a singularity will result, such as pow( 0, -2 ) */ -#define CT_ERROR_MATHLIB_OVERFLOW 103 /* an overflow will result, such as pow( 10, 100 ) */ -#define CT_ERROR_MATHLIB_UNDERFLOW 104 /* an underflow will result, such as pow( 10, -100 ) */ -#define CT_ERROR_MATHLIB_TLOSS 105 /* total loss of significance will result, such as exp( 1000 ) */ -#define CT_ERROR_MATHLIB_PLOSS 106 /* partial loss of significance will result, such as sin( 10e70 ) */ - /* * function error sub codes * @@ -684,7 +675,6 @@ #define CT_ERROR_PV 8573 #define CT_ERROR_RATE 8583 #define CT_ERROR_RTOD 8593 -#define CT_ERROR_SETMATHERR 8602 #define CT_ERROR_SETPREC 8612 #define CT_ERROR_SIGN 8622 #define CT_ERROR_SIN 8633 diff --git a/harbour/contrib/libct/ctflist.txt b/harbour/contrib/libct/ctflist.txt index 050646be26..cde6f76a14 100644 --- a/harbour/contrib/libct/ctflist.txt +++ b/harbour/contrib/libct/ctflist.txt @@ -618,7 +618,6 @@ PI ;R; PV ;R; RATE ;R; RTOD ;R; -SETMATHERR ;R; !NEW! SETPREC ;R; SIGN ;R; SIN ;R; diff --git a/harbour/contrib/libct/ctmath.c b/harbour/contrib/libct/ctmath.c index 8577c6312d..402adea025 100644 --- a/harbour/contrib/libct/ctmath.c +++ b/harbour/contrib/libct/ctmath.c @@ -4,7 +4,7 @@ /* * Harbour Project source code: - * internal and switch functions for CT3 math functions + * initialization and switch functions for CT3 math functions * * Copyright 2001 IntTec GmbH, Neunlindenstr 32, 79106 Freiburg, Germany * Author: Martin Vogel @@ -55,357 +55,21 @@ #include "ct.h" -/* -------------- */ -/* initialization */ -/* -------------- */ -static HB_MATH_HANDLERHANDLE s_ctMathHandler = NULL; /* TODO: make this thread safe */ - -int ct_math_init (void) +/* ---------------- */ +/* initialization */ +/* ---------------- */ +int ct_math_init() { - HB_TRACE(HB_TR_DEBUG, ("ctmath_init()")); - - if (hb_mathIsHandler()) - { - s_ctMathHandler = hb_mathInstallHandler (ct_matherr); - /* CT3 math handler is inactive by default */ - hb_mathSetHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_INACTIVE); - return (1); - } - return (0); -} - -int ct_math_exit (void) -{ - HB_TRACE(HB_TR_DEBUG, ("ctmath_exit()")); - if (hb_mathIsHandler()) - { - hb_mathDeinstallHandler (s_ctMathHandler); - } + HB_TRACE(HB_TR_DEBUG, ("ct_math_init()")); return (1); } -static int s_ct_matherr_status = CT_MATHERR_STATUS_INACTIVE; /* TODO: make this thread safe */ -void ct_setmatherrstatus (int iStatus) +int ct_math_exit() { - HB_TRACE(HB_TR_DEBUG, ("ct_setmatherrstatus (%i)", iStatus)); - s_ct_matherr_status = iStatus; - return; + HB_TRACE(HB_TR_DEBUG, ("ct_math_exit()")); + return (1); } -int ct_getmatherrstatus (void) -{ - HB_TRACE(HB_TR_DEBUG, ("ct_getmatherrstatus()")); - return (s_ct_matherr_status); -} - -/* functions to "bracket" CT3 math code */ -void ct_matherrbegin (void) -{ - HB_TRACE(HB_TR_DEBUG, ("ct_matherrbegin()")); - if (hb_mathIsHandler() && (s_ct_matherr_status == CT_MATHERR_STATUS_ACTIVE)) - { - hb_mathSetHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_ACTIVE); - } - return; -} - -void ct_matherrend (void) -{ - HB_TRACE(HB_TR_DEBUG, ("ct_matherrend()")); - if (hb_mathIsHandler()) - { - hb_mathSetHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_INACTIVE); - } - return; -} - -/* ------------------------- */ -/* handling of mathlib error */ -/* ------------------------- */ -static int s_ct_matherr_mode = CT_MATHERR_MODE_DEFAULT; /* TODO: make this thread safe */ -void ct_setmatherrmode (int iMode) -{ - HB_TRACE(HB_TR_DEBUG, ("ct_setmatherrmode (%i)", iMode)); - s_ct_matherr_mode = iMode; - return; -} - -int ct_getmatherrmode (void) -{ - HB_TRACE(HB_TR_DEBUG, ("ct_getmatherrmode()")); - return (s_ct_matherr_mode); -} - - -/* $DOC$ - * $FUNCNAME$ - * SETMATHERR() - * $CATEGORY$ - * CT3 math functions - * $ONELINER$ - * Sets the math error correction status and mode - * $SYNTAX$ - * SETMATHERR ([] [,<[@]nMode>]) -> nOldStatus - * $ARGUMENTS$ - * [] new math error correction status - * [<[@]nMode>] new math error correction mode OR - * placeholder for current mode (if passed by reference) - * $RETURNS$ - * nOldStatus old (if nStatus is a valid value, see below) or - * current mode of math error correction - * $DESCRIPTION$ - * Most math functions within the CT3 library (and in Harbour itself) rely on the - * standard C math library which, on some platforms, calls a certain, - * user-definable error handling routine when one of the following - * mathematical errors occur (constants defined in cterror.ch): - * - * CT_ERROR_MATHLIB unknown math lib error - * CT_ERROR_MATHLIB_DOMAIN a domain error has occured, such as sqrt (-1) - * CT_ERROR_MATHLIB_SING a singularity will result, such as pow (0, -2) - * CT_ERROR_MATHLIB_OVERFLOW an overflow will result, such as pow (10, 100) - * CT_ERROR_MATHLIB_UNDERFLOW an underflow will result, such as pow (10, -100) - * CT_ERROR_MATHLIB_TLOSS total loss of significance will result, such as exp (1000) - * CT_ERROR_MATHLIB_PLOSS partial loss of significance will result, such as sin (10e70) - * - * The CT3 library redirects these errors within its math routines - * to its own math handler. - * The behaviour of this handler depends on the values of - * and : - * - * The values of and specify whether the CT3 - * math handler is active. It can be one of the following values - * (defined in ct.ch): - * - * CT_MATHERR_STATUS_NOTFOUND math handler is not installed - * CT_MATHERR_STATUS_INACTIVE math handler is installed but inactive - * CT_MATHERR_STATUS_ACTIVE math handler is installed and active - * - * Be aware that, if CT_MATHERR_STATUS_NOTFOUND is used as argument, - * SETMATHERR() will NOT deinstall the math handler. The math handler - * is installed by CTINIT(), remains inactive at first, and is deinstalled - * by CTEXIT(). - * - * The value of specifies the behaviour of the CT3 math handler - * if it is installed and active. It can be one of the following values: - * - * CT_MATHERR_MODE_NONE no correction at all, program will exit - * CT_MATHERR_MODE_DEFAULT default return value will be used, no error msgs ! - * CT_MATHERR_MODE_USER error will be thrown to user who is responsible for error correction - * CT_MATHERR_MODE_USERDEFAULT error will be thrown, but if user fails, default correction will be used - * - * The default behaviour is CT_MATHERR_MODE_DEFAULT. - * - * Be aware that, if is passed by reference, SETMATHERR() will - * store the current value in <@nMode> rather than setting a new one. - * - * $EXAMPLES$ - * $TESTS$ - * $STATUS$ - * Ready - * $COMPLIANCE$ - * SETMATHERR() is a new function in Harbour's CT3 library. - * $PLATFORMS$ - * All - * $FILES$ - * Source is ctmath.c, library is ct3. - * $SEEALSO$ - * CTINIT() CTEXIT() - * $END$ - */ - -HB_FUNC (SETMATHERR) -{ - - hb_retni (ct_getmatherrstatus()); - - /* set new status if first parameter is one of - {CT_MATHERR_STATUS_INACTIVE, CT_MATHERR_STATUS_ACTIVE}, but - ignore CT_MATHERR_STATUS_NOTFOUND !! */ - if (ISNUM (1)) - { - int iNewStatus = hb_parni (1); - if ((iNewStatus == CT_MATHERR_STATUS_INACTIVE) || - (iNewStatus == CT_MATHERR_STATUS_INACTIVE)) - { - ct_setmatherrstatus (iNewStatus); - } - else - { - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) - { - ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_SETMATHERR, - NULL, "SETMATHERR", 0, EF_CANDEFAULT, 2, - hb_paramError (1), hb_paramError (2)); - } - } - } - - /* set new mode, if ISNUM(2) but !ISBYREF(2) */ - if (ISNUM (2)) - { - if (ISBYREF (2)) - { - /* store current mode in second parameter */ - hb_storni (ct_getmatherrmode(), 2); - } - else - { - int iNewMode = hb_parni (2); - if ((iNewMode == CT_MATHERR_MODE_NONE) || - (iNewMode == CT_MATHERR_MODE_DEFAULT) || - (iNewMode == CT_MATHERR_MODE_USER) || - (iNewMode == CT_MATHERR_MODE_USERDEFAULT)) - { - ct_setmatherrmode (hb_parni(2)); - } - else - { - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) - { - ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_SETMATHERR, - NULL, "SETMATHERR", 0, EF_CANDEFAULT, 2, - hb_paramError (1), hb_paramError (2)); - } - } - } - } - else if (hb_pcount() > 1) /* more than 1 param, but second is not integer ! */ - { - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) - { - ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_SETMATHERR, - NULL, "SETMATHERR", 0, EF_CANDEFAULT, 2, - hb_paramError (1), hb_paramError (2)); - } - } - - return; - -} - - -/* -------------- */ -/* math handler */ -/* -------------- */ -int ct_matherr (HB_MATH_EXCEPTION * pexc) -{ - - int retval = 0; - int imatherr = ct_getmatherrmode(); - - HB_TRACE(HB_TR_DEBUG, ("ct_matherr (%p)", pexc)); - - if ((imatherr == CT_MATHERR_MODE_USER) || (imatherr == CT_MATHERR_MODE_USERDEFAULT)) - { - PHB_ITEM pMatherrResult, pArg1, pArg2; - ULONG ulSubCode; - - switch (pexc->type) - { - case HB_MATH_ERR_DOMAIN: - /* a domain error has occured, such as sqrt( -1 ) */ - ulSubCode = CT_ERROR_MATHLIB_DOMAIN; break; - case HB_MATH_ERR_SING: - /* a singularity will result, such as pow( 0, -2 ) */ - ulSubCode = CT_ERROR_MATHLIB_SING; break; - case HB_MATH_ERR_OVERFLOW: - /* an overflow will result, such as pow( 10, 100 ) */ - ulSubCode = CT_ERROR_MATHLIB_OVERFLOW; break; - case HB_MATH_ERR_UNDERFLOW: - /* an underflow will result, such as pow( 10, -100 ) */ - ulSubCode = CT_ERROR_MATHLIB_UNDERFLOW; break; - case HB_MATH_ERR_TLOSS: - /* total loss of significance will result, such as exp( 1000 ) */ - ulSubCode = CT_ERROR_MATHLIB_TLOSS; break; - case HB_MATH_ERR_PLOSS: - /* partial loss of significance will result, such as sin( 10e70 ) */ - ulSubCode = CT_ERROR_MATHLIB_PLOSS; break; - default: /* HB_MATH_ERR_UNKNOWN */ - /* unknown math lib error */ - ulSubCode = CT_ERROR_MATHLIB; break; - } - - pArg1 = hb_itemPutND (NULL, pexc->arg1); - pArg2 = hb_itemPutND (NULL, pexc->arg2); - pMatherrResult = ct_error_subst (ES_ERROR, EG_NUMERR, ulSubCode, - NULL, pexc->name, 0, EF_CANSUBSTITUTE, - 2, pArg1, pArg2); - - if ((pMatherrResult != NULL) && (HB_IS_NUMERIC (pMatherrResult))) - { - pexc->retval = hb_itemGetND (pMatherrResult); - retval = 1; - } - - hb_itemRelease (pMatherrResult); - hb_itemRelease (pArg1); - hb_itemRelease (pArg2); - } - - if ((retval == 0) && - ((imatherr == CT_MATHERR_MODE_DEFAULT) || (imatherr == CT_MATHERR_MODE_USERDEFAULT))) - { - /* find some appropiate return values */ - switch (pexc->type) - { - case HB_MATH_ERR_DOMAIN: - /* a domain error has occured, such as sqrt( -1 ) */ - pexc->retval = 0.0; - retval = 1; - break; - case HB_MATH_ERR_SING: - /* a singularity will result, such as pow( 0, -2 ) */ - if (pexc->arg1 < 0) /* it is just a guess that the resulting singularity - has the same sign as the first argument */ - pexc->retval = -DBL_MAX; - else - pexc->retval = DBL_MAX; - retval = 1; - break; - case HB_MATH_ERR_OVERFLOW: - /* an overflow will result, such as pow( 10, 100 ) */ - if (pexc->arg1 < 0) /* it is just a guess that the resulting singularity - has the same sign as the first argument */ - pexc->retval = -DBL_MAX; - else - pexc->retval = DBL_MAX; - retval = 1; - break; - case HB_MATH_ERR_UNDERFLOW: - /* an underflow will result, such as pow( 10, -100 ) */ - if (pexc->arg1 < 0) /* it is just a guess that the resulting singularity - has the same sign as the first argument */ - pexc->retval = -DBL_MIN; - else - pexc->retval = DBL_MIN; - retval = 1; - break; - case HB_MATH_ERR_TLOSS: - /* total loss of significance will result, such as exp( 1000 ) */ - pexc->retval = 1.0; - retval = 1; - break; - case HB_MATH_ERR_PLOSS: - /* partial loss of significance will result, such as sin( 10e70 ) */ - pexc->retval = 1.0; - retval = 1; - break; - default: /* HB_MATH_ERR_UNKNOWN */ - /* unknown math lib error */ - pexc->retval = 0.0; - retval = 1; - break; - } - } - - return (retval); - -} - - /* ---------------- */ /* math precision */ /* ---------------- */ diff --git a/harbour/contrib/libct/ctmath.h b/harbour/contrib/libct/ctmath.h index 52982d2511..8d13d99236 100644 --- a/harbour/contrib/libct/ctmath.h +++ b/harbour/contrib/libct/ctmath.h @@ -62,31 +62,6 @@ extern int ct_math_init (void); extern int ct_math_exit (void); -/* set & get math error correction status */ -extern void ct_setmatherrstatus (int iStatus); -extern int ct_getmatherrstatus (void); - -/* set & get math error correction mode */ -extern void ct_setmatherrmode (int iMode); -extern int ct_getmatherrmode (void); - -/* functions to bracket CT3 math code */ -void ct_matherrbegin (void); -void ct_matherrend (void); - -/* stati and modes for math error correction */ -#define CT_MATHERR_STATUS_NOTFOUND HB_MATH_HANDLER_STATUS_NOTFOUND /* math handler is not installed */ -#define CT_MATHERR_STATUS_INACTIVE HB_MATH_HANDLER_STATUS_INACTIVE /* math handler is installed but inactive */ -#define CT_MATHERR_STATUS_ACTIVE HB_MATH_HANDLER_STATUS_ACTIVE /* math handler is installed and active */ - -#define CT_MATHERR_MODE_NONE 0 /* no correction at all, program will exit */ -#define CT_MATHERR_MODE_DEFAULT 1 /* default return value will be used, no error msgs ! */ -#define CT_MATHERR_MODE_USER 2 /* error will be thrown to user who is responsible for error correction */ -#define CT_MATHERR_MODE_USERDEFAULT 3 /* error will be thrown, but if user fails, default correction will be used */ - -/* CT3 math error handler */ -extern int ct_matherr (HB_MATH_EXCEPTION * pexc); - /* set & get precision */ extern void ct_setprecision (int iPrecision); extern int ct_getprecision(); diff --git a/harbour/contrib/libct/finan.c b/harbour/contrib/libct/finan.c index a77baca5f5..73cfe3e53a 100644 --- a/harbour/contrib/libct/finan.c +++ b/harbour/contrib/libct/finan.c @@ -126,8 +126,6 @@ HB_FUNC( FV ) double dTime = hb_parnd(3); double dResult; - ct_matherrbegin(); - if (dRate == 0.0) { /* NOTE: CT3 crashes with dRate == 0.0 */ @@ -135,11 +133,30 @@ HB_FUNC( FV ) } else { + hb_mathResetError(); dResult = dPayment*(pow (1.0+dRate, dTime)-1.0)/dRate; + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retnd (dPayment*(hb_exc.retval-1.0)/dRate); + } + else + { + /* math exception is up to the Harbour function, so do this as CTIII compatible as possible: + replace the errorneous value of pow() with 0.0 */ + hb_retnd (dPayment*(-1.0)/dRate); + } + return; + } + } } - - ct_matherrend(); - + hb_retnd (dResult); } @@ -229,8 +246,6 @@ HB_FUNC( PV ) double dTime = hb_parnd(3); double dResult; - ct_matherrbegin(); - if (dRate == 0.0) { /* NOTE: CT3 crashes with dRate == 0.0 */ @@ -238,11 +253,30 @@ HB_FUNC( PV ) } else { + hb_mathResetError(); dResult = dPayment*(1.0-pow (1.0+dRate, -dTime))/dRate; + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retnd (dPayment*(1.0-hb_exc.retval)/dRate); + } + else + { + /* math exception is up to the Harbour function, so do this as CTIII compatible as possible: + replace the errorneous value of pow() with 0.0 */ + hb_retnd (dPayment/dRate); + } + return; + } + } } - ct_matherrend(); - hb_retnd (dResult); } else @@ -332,28 +366,32 @@ HB_FUNC( PAYMENT ) if (dRate == 0.0) { /* NOTE: CT3 crashes with dRate == 0.0 */ - if (dTime == 0.0) - { - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) - { - ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PAYMENT, - NULL, "PAYMENT", 0, EF_CANDEFAULT, 3, - hb_paramError (1), hb_paramError (2), - hb_paramError (3)); - }; - hb_retnd (0.0); - return; - } - ct_matherrbegin(); dResult = dCapital/dTime; - ct_matherrend(); } else { - ct_matherrbegin(); + hb_mathResetError(); dResult = dCapital*dRate/(1.0-pow (1.0+dRate, -dTime)); - ct_matherrend(); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retnd (dCapital*dRate/(1.0-hb_exc.retval)); + } + else + { + /* math exception is up to the Harbour function, so do this as CTIII compatible as possible: + replace the errorneous value of pow() with 0.0 */ + hb_retnd (dCapital*dRate); + } + return; + } + } } hb_retnd (dResult); @@ -458,28 +496,35 @@ HB_FUNC( PERIODS ) if (dRate == 0.0) { /* NOTE: CT3 crashes with dRate == 0.0 */ - if (dPayment == 0.0) - { - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) - { - ct_error ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_PERIODS, - NULL, "PERIODS", 0, EF_CANDEFAULT, 3, - hb_paramError (1), hb_paramError (2), - hb_paramError (3)); - }; - hb_retnd (0.0); - return; - } - ct_matherrbegin(); dResult = dCapital/dPayment; - ct_matherrend(); } else { - ct_matherrbegin(); - dResult = -log(1.0-(dCapital*dRate/dPayment))/log(1+dRate); - ct_matherrend(); + double dResult2; + hb_mathResetError(); + /* Note that this first expression will never give an error since dCapital*dRate/dPayment < 1.0, see above */ + dResult2 = -log(1.0-(dCapital*dRate/dPayment)); + dResult = dResult2/log(1+dRate); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retnd (dResult2/hb_exc.retval); + } + else + { + /* math exception is up to the Harbour function, so do this as CTIII compatible as possible: + replace the errorneous value of log() with -INF */ + hb_retnd (-0.0); + } + return; + } + } } hb_retnd( dResult ); @@ -577,7 +622,27 @@ HB_FUNC( RATE ) r = j * 0.000833333; /* j * ( 0.01 / 12.0) mensual's rate */ /* replace PAYMENT() function overhead */ + hb_mathResetError(); dExp = pow( (1.0 + r), dTime ); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + dExp = hb_exc.retval; + } + else + { + /* TODO: Check if this is a correct default correction value for pow() */ + dExp = 0.0; + } + } + } + dAux = dCapital * ( (dExp * r) / (dExp - 1.0) ); if( dAux > dPayment ) @@ -623,5 +688,3 @@ HB_FUNC( RATE ) - - diff --git a/harbour/contrib/libct/math.c b/harbour/contrib/libct/math.c index 3873d98f93..5d6896371d 100644 --- a/harbour/contrib/libct/math.c +++ b/harbour/contrib/libct/math.c @@ -104,11 +104,10 @@ HB_FUNC( FLOOR ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = floor (dInput); - ct_matherrend(); - hb_retnd( dResult ); + hb_retni( (int)dResult ); } else { @@ -177,11 +176,10 @@ HB_FUNC( CEILING ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = ceil (dInput); - ct_matherrend(); - - hb_retnd( dResult ); + + hb_retni( (int)dResult ); } else { @@ -330,32 +328,40 @@ HB_FUNC( LOG10 ) double dInput = hb_parnd(1); double dResult; - if (dInput <= 0.0) + hb_mathResetError(); + dResult = log10 (dInput); + + if (hb_mathIsMathErr()) { - PHB_ITEM pSubst = NULL; - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) { - pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_LOG10, - NULL, "LOG10", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1)); - } - if (pSubst != NULL) - { - hb_itemReturn (pSubst); - hb_itemRelease (pSubst); - } - else - { - hb_retnd (0.0); + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* math exception is up to the Harbour function, so do this as CTIII compatible as possible */ + switch (iLastError) + { + case HB_MATH_ERR_SING: /* argument to log10 was 0.0 */ + case HB_MATH_ERR_DOMAIN: /* argument to log10 was < 0.0 */ + { + hb_retndlen (-HUGE_VAL, -1, -1); /* return -infinity */ + }; break; + default: + { + hb_retnd (0.0); + } + } + } + return; } } - else - { - ct_matherrbegin(); - dResult = log10 (dInput); - ct_matherrend(); - hb_retnd( dResult ); - } + hb_retnd (dResult); } else { @@ -438,22 +444,7 @@ HB_FUNC( FACT ) } else { - PHB_ITEM pSubst = NULL; - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) - { - pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_FACT, - NULL, "FACT", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1)); - } - if (pSubst != NULL) - { - hb_itemReturn (pSubst); - hb_itemRelease (pSubst); - } - else - { - hb_retnd (-1.0); - } + hb_retnd (-1.0); } } else @@ -480,4 +471,3 @@ HB_FUNC( FACT ) return; } - diff --git a/harbour/contrib/libct/num1.c b/harbour/contrib/libct/num1.c index 9e7752d424..604df48f9f 100644 --- a/harbour/contrib/libct/num1.c +++ b/harbour/contrib/libct/num1.c @@ -109,9 +109,7 @@ HB_FUNC( CELSIUS ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); dResult = (5.0 / 9.0) * ( dInput - 32.0 ); - ct_matherrend(); hb_retnd( dResult ); } else @@ -183,9 +181,7 @@ HB_FUNC( FAHRENHEIT ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); dResult = (( 9.0 / 5.0) * dInput ) + 32.0 ; - ct_matherrend(); hb_retnd( dResult ); } else diff --git a/harbour/contrib/libct/readme.txt b/harbour/contrib/libct/readme.txt index 00e966de33..c16cf8c150 100644 --- a/harbour/contrib/libct/readme.txt +++ b/harbour/contrib/libct/readme.txt @@ -65,8 +65,6 @@ Martin Vogel * SETATLIKE() 2nd parameter can be passed by reference so that SETATLIKE can store the acutal wildcard character in it -+ SETMATHERR() math error handling - + SINH() hyperbolic sine * TABPACK() new 4th, 5th and 6th parameter to let one set the carriage-return-line-feed string, diff --git a/harbour/contrib/libct/tests/Makefile b/harbour/contrib/libct/tests/Makefile index 91f27c683b..270a8f6c56 100644 --- a/harbour/contrib/libct/tests/Makefile +++ b/harbour/contrib/libct/tests/Makefile @@ -83,7 +83,7 @@ PRG_SOURCES=\ tokenupp.prg \ trig.prg \ valpos.prg \ - wordone.org \ + wordone.prg \ wordonly.prg \ wordrepl.prg \ wordrem.prg \ diff --git a/harbour/contrib/libct/trig.c b/harbour/contrib/libct/trig.c index a58e9e20e2..ede5bf98ad 100644 --- a/harbour/contrib/libct/trig.c +++ b/harbour/contrib/libct/trig.c @@ -70,7 +70,6 @@ * */ - #include "ct.h" @@ -163,10 +162,27 @@ HB_FUNC( SIN ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = sin (dInput); - ct_matherrend(); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); + } + return; + } + } hb_retnd( dResult ); } else @@ -241,10 +257,27 @@ HB_FUNC( COS ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = cos (dInput); - ct_matherrend(); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); + } + return; + } + } hb_retnd( dResult ); } else @@ -319,32 +352,28 @@ HB_FUNC( TAN ) double dInput = hb_parnd(1); double dResult; - if (((dInput/CT_PI)-floor(dInput/CT_PI)) == 0.5) + hb_mathResetError(); + dResult = tan (dInput); + + if (hb_mathIsMathErr()) { - PHB_ITEM pSubst = NULL; - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) { - pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_TAN, - NULL, "TAN", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1)); - } - if (pSubst != NULL) - { - hb_itemReturn (pSubst); - hb_itemRelease (pSubst); - } - else - { - hb_retnd (DBL_MAX); + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); + } + return; } } - else - { - ct_matherrbegin(); - dResult = tan (dInput); - ct_matherrend(); - hb_retnd( dResult ); - } + hb_retnd( dResult ); } else { @@ -416,32 +445,27 @@ HB_FUNC( COT ) double dInput = hb_parnd(1); double dResult; - if (((dInput/CT_PI)-floor(dInput/CT_PI)) == 0.0) + hb_mathResetError(); + dResult = 1/tan (dInput); + if (hb_mathIsMathErr()) { - PHB_ITEM pSubst = NULL; - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) { - pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_COT, - NULL, "COT", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1)); - } - if (pSubst != NULL) - { - hb_itemReturn (pSubst); - hb_itemRelease (pSubst); - } - else - { - hb_retnd (DBL_MAX); + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); + } + return; } } - else - { - ct_matherrbegin(); - dResult = 1/tan (dInput); - ct_matherrend(); - hb_retnd( dResult ); - } + hb_retnd( dResult ); } else { @@ -516,32 +540,28 @@ HB_FUNC( ASIN ) double dInput = hb_parnd(1); double dResult; - if (fabs(dInput) > 1.0) + hb_mathResetError(); + dResult = asin (dInput); + if (hb_mathIsMathErr()) { - PHB_ITEM pSubst = NULL; - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) { - pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_ASIN, - NULL, "ASIN", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1)); - } - if (pSubst != NULL) - { - hb_itemReturn (pSubst); - hb_itemRelease (pSubst); - } - else - { - hb_retnd (0.0); + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); /* NOTE: CTIII crashes when argument is not between -1 and 1 , but we + better generate a NaN/overflow here */ + } + return; } } - else - { - ct_matherrbegin(); - dResult = asin (dInput); - ct_matherrend(); - hb_retnd( dResult ); - } + hb_retnd( dResult ); } else { @@ -617,32 +637,29 @@ HB_FUNC( ACOS ) double dInput = hb_parnd(1); double dResult; - if (fabs(dInput) > 1.0) + hb_mathResetError(); + dResult = acos (dInput); + if (hb_mathIsMathErr()) { - PHB_ITEM pSubst = NULL; - int iArgErrorMode = ct_getargerrormode(); - if (iArgErrorMode != CT_ARGERR_IGNORE) + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) { - pSubst = ct_error_subst ((USHORT)iArgErrorMode, EG_ARG, CT_ERROR_ACOS, - NULL, "ACOS", 0, EF_CANSUBSTITUTE, 1, hb_paramError (1)); - } - if (pSubst != NULL) - { - hb_itemReturn (pSubst); - hb_itemRelease (pSubst); - } - else - { - hb_retnd (0.0); + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); /* NOTE: CTIII crashes when argument is not between -1 and 1 , but we + better generate a NaN/overflow here */ + } + return; } } - else - { - ct_matherrbegin(); - dResult = acos (dInput); - ct_matherrend(); - hb_retnd( dResult ); - } + + hb_retnd( dResult ); } else { @@ -714,9 +731,36 @@ HB_FUNC( ATAN ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = atan (dInput); - ct_matherrend(); + + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* atan normally don't error, but it's save to return PI()/2 or -PI()/2, respectively, as these + are the boundary result values */ + if (dInput < 0.0) + { + hb_retnd (-CT_PI/2.0); + } + else + { + hb_retnd (CT_PI/2.0); + } + } + return; + } + } hb_retnd( dResult ); } else @@ -797,9 +841,47 @@ HB_FUNC( ATN2 ) double dX = hb_parnd(2); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = atan2( dY, dX ); /* NOTE: parameters are swapped */ - ct_matherrend(); + + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* DOMAIN error: both arguments to atan2 have been 0 */ + /* CTIII behaves very strange here: atn2 (0.0, 0.0) == -PI + atn2 (0.0, -0.0) == 0.0 + atn2 (-0.0, 0.0) == -PI + atn2 (-0.0, -0.0) == -2*PI */ + if (dX < 0.0) + { + if (dY < 0.0) + { + hb_retnd (-2.0*CT_PI); + } + else + { + hb_retnd (0.0); + } + } + else + { + hb_retnd (-CT_PI); + } + } + return; + } + } + hb_retnd( dResult ); } @@ -875,9 +957,35 @@ HB_FUNC( SINH ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = sinh (dInput); - ct_matherrend(); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* OVERFLOW error: we have no CTIII behaviour to follow, so return +INF or -INF, respectively */ + if (dInput < 0.0) + { + hb_retndlen (-HUGE_VAL, -1, -1); + } + else + { + hb_retndlen (HUGE_VAL, -1, -1); + } + } + return; + } + } + hb_retnd( dResult ); } else @@ -951,9 +1059,27 @@ HB_FUNC( COSH ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = cosh (dInput); - ct_matherrend(); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* OVERFLOW error: we have no CTIII behaviour to follow, so return +INF */ + hb_retndlen (HUGE_VAL, -1, -1); + } + return; + } + } hb_retnd( dResult ); } else @@ -983,7 +1109,7 @@ HB_FUNC( COSH ) /* $DOC$ * $FUNCNAME$ - * SINH() + * TANH() * $CATEGORY$ * CT3 math functions * $ONELINER$ @@ -1023,9 +1149,36 @@ HB_FUNC( TANH ) double dInput = hb_parnd(1); double dResult; - ct_matherrbegin(); + hb_mathResetError(); dResult = tanh (dInput); - ct_matherrend(); + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + HB_MATH_EXCEPTION hb_exc; + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* normally, tanh() doesn't give errors, but let's return -1 or +1, respectively, as these + are the boundary result values */ + if (dInput < 0.0) + { + hb_retnd (-1.0); + } + else + { + hb_retnd (1.0); + } + } + return; + } + } + hb_retnd( dResult ); } else diff --git a/harbour/doc/en/math.txt b/harbour/doc/en/math.txt index 05ab707b25..8e729520d9 100644 --- a/harbour/doc/en/math.txt +++ b/harbour/doc/en/math.txt @@ -343,7 +343,7 @@ /* $DOC$ * $FUNCNAME$ - * hb_getMathError() + * hb_mathGetLastError() * $CATEGORY$ * Math API * $ONELINER$ @@ -352,7 +352,52 @@ * C Prototype * * #include - * hb_getMathError (void) --> int iMathError + * hb_mathGetLastError (HB_MATH_EXCEPTION * phb_exc) --> int iMathErrorType + * $ARGUMENTS$ + * phb_exc pointer to HB_MATH_EXCEPTION structure, if not NULL, the structure will be filled + * with information about the last math error: + * typedef struct _HB_MATH_EXCEPTION { + * int type; /* math error type, is one of the constants HB_MATH_ERR_xxx defined in math.ch */ + * char *funcname; /* pointer to name of the math C RTL routine that caused the error */ + * char *error; /* pointer to error description */ + * double arg1; /* first and */ + * double arg2; /* second double argument to the math routine */ + * double retval; /* corrected return value for the math routine */ + * int retvalwidth; /* width and */ + * int retvaldec; /* decimals of the corrected return value, both default to -1 */ + * int handled; /* 1, if the math error is already corrected, 0 otherwise */ + * } HB_MATH_EXCEPTION; + * $RETURNS$ + * + * $DESCRIPTION$ + * + * $EXAMPLES$ + * + * $STATUS$ + * R + * $COMPLIANCE$ + * Compliance is not applicable to API calls. + * $FILES$ + * Library is rtl + * $PLATFORMS$ + * All + * $SEEALSO$ + * + * $END$ + */ + +/* $DOC$ + * $FUNCNAME$ + * hb_mathResetError() + * $CATEGORY$ + * Math API + * $ONELINER$ + * reset the internal math error information structure + * $SYNTAX$ + * C Prototype + * + * #include + * hb_mathResetError (void) --> void * $ARGUMENTS$ * * $RETURNS$ @@ -376,16 +421,16 @@ /* $DOC$ * $FUNCNAME$ - * hb_resetMathError() + * hb_mathIsMathErr() * $CATEGORY$ * Math API * $ONELINER$ - * reset the math error, i.e. set it to 0 + * check if harbour math error handling is available * $SYNTAX$ * C Prototype * * #include - * hb_resetMathError (void) --> void + * hb_mathIsMathErr (void) --> int iIsMathHandler * $ARGUMENTS$ * * $RETURNS$ @@ -409,20 +454,56 @@ /* $DOC$ * $FUNCNAME$ - * hb_isMathHandler() + * hb_mathSetHandler() * $CATEGORY$ * Math API * $ONELINER$ - * check if harbour math error handler is available + * set the harbour math handler * $SYNTAX$ * C Prototype * * #include - * hb_isMathHandler (void) --> int iIsMathHandler + * hb_mathSetHandler (HB_MATH_HANDLERPROC handlerproc) --> HB_MATH_HANDLERPROC previous_handerproc * $ARGUMENTS$ - * + * handlerproc custom math handler + * typedef int (* HB_MATH_HANDLERPROC)(HB_MATH_EXCEPTION * err) * $RETURNS$ + * previous_handlerproc previous math handler + * typedef int (* HB_MATH_HANDLERPROC)(HB_MATH_EXCEPTION * err) + * $DESCRIPTION$ + * + * $EXAMPLES$ * + * $STATUS$ + * R + * $COMPLIANCE$ + * Compliance is not applicable to API calls. + * $FILES$ + * Library is rtl + * $PLATFORMS$ + * All + * $SEEALSO$ + * + * $END$ + */ + +/* $DOC$ + * $FUNCNAME$ + * hb_mathGetHandler() + * $CATEGORY$ + * Math API + * $ONELINER$ + * get current Harbour math error handler + * $SYNTAX$ + * C Prototype + * + * #include + * hb_mathGetHandler (void) --> HB_MATH_HANDLERPROC handlerproc + * $ARGUMENTS$ + * handlerproc custom math handler + * typedef int (* HB_MATH_HANDLERPROC)(HB_MATH_EXCEPTION * err) + * $RETURNS$ + * * $DESCRIPTION$ * * $EXAMPLES$ @@ -442,20 +523,25 @@ /* $DOC$ * $FUNCNAME$ - * hb_installMathHandler() + * hb_mathSetErrMode() * $CATEGORY$ * Math API * $ONELINER$ - * add a custom math handler to the math error handler chain + * set math error handling mode * $SYNTAX$ * C Prototype * * #include - * hb_installMathHandler (HB_MATH_HANDLERPROC handlerproc) --> HB_MATH_HANDLERHANDLE handle + * hb_mathSetErrMode (int imode) --> int ioldmode * $ARGUMENTS$ - * handlerproc custom math handler + * imode math error handling mode, one of the following constants, defined in math.ch + * HB_MATH_ERRMODE_DEFAULT + * HB_MATH_ERRMODE_CDEFAULT + * HB_MATH_ERRMODE_USER + * HB_MATH_ERRMODE_USERDEFAULT + * HB_MATH_ERRMODE_USERCDEFAULT * $RETURNS$ - * handle handle to handlerproc in handle chain + * ioldmode old math error handling mode * $DESCRIPTION$ * * $EXAMPLES$ @@ -475,20 +561,20 @@ /* $DOC$ * $FUNCNAME$ - * hb_deinstallMathHandler() + * hb_mathGetErrMode() * $CATEGORY$ * Math API * $ONELINER$ - * remove custom math handler from the math error handler chain + * get math error handling mode * $SYNTAX$ * C Prototype * * #include - * hb_deinstallMathHandler (HB_MATH_HANDLERHANDLE handle) --> int iSuccess + * hb_mathGetErrMode (void) --> imode * $ARGUMENTS$ - * handle handle returned be hb_installMathHandler() + * * $RETURNS$ - * iSuccess success of operation + * imode math error handling mode * $DESCRIPTION$ * * $EXAMPLES$ @@ -508,37 +594,31 @@ /* $DOC$ * $FUNCNAME$ - * hb_setMathHandlerStatus() + * MATHERRMODE() * $CATEGORY$ - * Math API + * Math * $ONELINER$ - * set the status of a custom math handler in the math error handler chain + * Set/Get math error handling mode * $SYNTAX$ - * C Prototype - * - * #include - * hb_setMathHandlerStatus (HB_MATH_HANDLERHANDLE handle, int status) --> int iSuccess + * MATHERRMODE ([]) -> * $ARGUMENTS$ - * handle handle returned be hb_installMathHandler() - * status new status value, can be one of: - * HB_MATH_HANDLER_STATUS_INACTIVE - * --> handler is present but not active - * HB_MATH_HANDLER_STATUS_ACTIVE - * --> handler is present and active + * [] new math error handling mode, one of the following constants, defined in math.ch + * HB_MATH_ERRMODE_DEFAULT + * HB_MATH_ERRMODE_CDEFAULT + * HB_MATH_ERRMODE_USER + * HB_MATH_ERRMODE_USERDEFAULT + * HB_MATH_ERRMODE_USERCDEFAULT * $RETURNS$ - * iSuccess success of operation + * old math error handling mode * $DESCRIPTION$ - * * $EXAMPLES$ - * * $STATUS$ * R * $COMPLIANCE$ - * Compliance is not applicable to API calls. - * $FILES$ - * Library is rtl * $PLATFORMS$ * All + * $FILES$ + * Library is rtl * $SEEALSO$ * * $END$ @@ -546,35 +626,28 @@ /* $DOC$ * $FUNCNAME$ - * hb_getMathHandlerStatus() + * MATHERRORBLOCK() * $CATEGORY$ - * Math API + * Math * $ONELINER$ - * get the status of a custom math handler in the math error handler chain + * Set/Get math error handling codeblock * $SYNTAX$ - * C Prototype - * - * #include - * hb_getMathHandlerStatus (HB_MATH_HANDLERHANDLE handle) --> int iStatus + * MATHERRORBLOCK ([]) -> * $ARGUMENTS$ - * handle handle returned be hb_installMathHandler() * $RETURNS$ - * iStatus status of math handler * $DESCRIPTION$ - * * $EXAMPLES$ - * * $STATUS$ * R * $COMPLIANCE$ - * Compliance is not applicable to API calls. - * $FILES$ - * Library is rtl * $PLATFORMS$ * All + * $FILES$ + * Library is rtl * $SEEALSO$ * * $END$ */ + diff --git a/harbour/include/hbmath.h b/harbour/include/hbmath.h index 7cbc562aae..0491efdacd 100644 --- a/harbour/include/hbmath.h +++ b/harbour/include/hbmath.h @@ -86,43 +86,32 @@ extern "C" { typedef struct _HB_MATH_EXCEPTION { - int type; - char * name; - double arg1; - double arg2; - double retval; + int type; + char * funcname; + char * error; + double arg1; + double arg2; + double retval; + int retvalwidth; + int retvaldec; + int handled; } HB_MATH_EXCEPTION; -typedef int ( * HB_MATH_HANDLERPROC )( HB_MATH_EXCEPTION * err ); +typedef int (* HB_MATH_HANDLERPROC)(HB_MATH_EXCEPTION * err); -typedef struct HB_MATH_HANDLERCHAINELEMENT_ -{ - HB_MATH_HANDLERPROC handlerproc; - int status; - struct HB_MATH_HANDLERCHAINELEMENT_ * pnext; -} HB_MATH_HANDLERCHAINELEMENT, * PHB_MATH_HANDLERCHAINELEMENT; -typedef PHB_MATH_HANDLERCHAINELEMENT HB_MATH_HANDLERHANDLE; +extern void hb_mathResetError (void); +extern int hb_mathGetLastError (HB_MATH_EXCEPTION * phb_exc); +extern int hb_mathIsMathErr (void); -extern int hb_mathGetError( void ); -extern void hb_mathResetError( void ); -extern int hb_mathIsHandler( void ); -extern HB_MATH_HANDLERHANDLE hb_mathInstallHandler( HB_MATH_HANDLERPROC handlerproc ); -extern int hb_mathDeinstallHandler( HB_MATH_HANDLERHANDLE handle ); -extern int hb_mathSetHandlerStatus( HB_MATH_HANDLERHANDLE handle, int status ); -extern int hb_mathGetHandlerStatus( HB_MATH_HANDLERHANDLE handle ); +extern int hb_mathSetDefErrMode (int imode); +extern int hb_mathGetDefErrMode (void); +extern int hb_matherr (HB_MATH_EXCEPTION * pexc); -#define HB_MATH_HANDLER_STATUS_NOTFOUND ( ( int ) -1 ) -#define HB_MATH_HANDLER_STATUS_INACTIVE ( ( int ) 0 ) -#define HB_MATH_HANDLER_STATUS_ACTIVE ( ( int ) 1 ) - -#define HB_MATH_ERR_UNKNOWN ( ( int ) 0 ) -#define HB_MATH_ERR_DOMAIN ( ( int ) 1 ) -#define HB_MATH_ERR_SING ( ( int ) 2 ) -#define HB_MATH_ERR_OVERFLOW ( ( int ) 3 ) -#define HB_MATH_ERR_UNDERFLOW ( ( int ) 4 ) -#define HB_MATH_ERR_TLOSS ( ( int ) 5 ) -#define HB_MATH_ERR_PLOSS ( ( int ) 6 ) +extern HB_MATH_HANDLERPROC hb_mathSetHandler (HB_MATH_HANDLERPROC handlerproc); +extern HB_MATH_HANDLERPROC hb_mathGetHandler (void); +/* include defines from math.ch */ +#include #if defined(HB_EXTERN_C) } diff --git a/harbour/include/math.ch b/harbour/include/math.ch new file mode 100644 index 0000000000..3c22b11b07 --- /dev/null +++ b/harbour/include/math.ch @@ -0,0 +1,82 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Header file for MATHDEFERRMODE function + * + * Copyright 2002 IntTec GmbH, Neunlindenstr 32, 79106 Freiburg, Germany + * Author: Martin Vogel + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#ifndef _MATH_CH_ +#define _MATH_CH_ + +/* map the C math lib error definitions to harbour constants */ +#define HB_MATH_ERR_UNKNOWN -1 +#define HB_MATH_ERR_NONE 0 +#define HB_MATH_ERR_DOMAIN 1 +#define HB_MATH_ERR_SING 2 +#define HB_MATH_ERR_OVERFLOW 3 +#define HB_MATH_ERR_UNDERFLOW 4 +#define HB_MATH_ERR_TLOSS 5 +#define HB_MATH_ERR_PLOSS 6 + +/* working mode for hb_matherr, the basic Harbour math error handler */ +#define HB_MATH_ERRMODE_DEFAULT 0 /* no common error handling, save error data only; + Harbour function using math routines must handle error */ +#define HB_MATH_ERRMODE_CDEFAULT 1 /* handle error by using the C RTL correction values */ +#define HB_MATH_ERRMODE_USER 2 /* throw Harbour error, user MUST correct math error within Harbour error + handling */ +#define HB_MATH_ERRMODE_USERDEFAULT 3 /* dito, but if user does not correct math error, default + error handling, i.e. by individual function applies */ +#define HB_MATH_ERRMODE_USERCDEFAULT 4 /* as ERRMODE_USER, but if user does not correct math error, C RTL + correction values are used */ + +/* array element indices in aInfo parameter passed to math errorblock */ +#define HB_MATHERRORBLOCK_RETVAL 1 +#define HB_MATHERRORBLOCK_HANDLED 2 + +#endif /* _MATH_CH */ diff --git a/harbour/source/rtl/math.c b/harbour/source/rtl/math.c index a9be820a16..b0134d96b4 100644 --- a/harbour/source/rtl/math.c +++ b/harbour/source/rtl/math.c @@ -8,8 +8,8 @@ * * Copyright 1999 Matthew Hamilton * - * Functions for user defined math error handlers - * Copyright 2001 IntTec GmbH, Freiburg, Germany, + * Functions for user defined math error handlers, changes and fixes + * Copyright 2001/2002 IntTec GmbH, Freiburg, Germany, * Author: Martin Vogel * * www - http://www.harbour-project.org @@ -60,353 +60,616 @@ #include "hbapi.h" #include "hbapiitm.h" #include "hbapierr.h" +#include "hbvm.h" #include "hbmath.h" -#if defined(HB_MATH_HANDLER) - -static int s_internal_math_error = 0; /* TOFIX: This is not thread safe. */ - -int hb_mathGetError( void ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathGetError()")); - - return s_internal_math_error; -} - -void hb_mathResetError( void ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathResetError()")); - - s_internal_math_error = 0; -} - -/* math handler present ? */ -int hb_mathIsHandler( void ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathIsHandler()")); - - return 1; -} - -static PHB_MATH_HANDLERCHAINELEMENT s_pChain = NULL; /* TODO: make this thread safe */ - -/* install custom math handler */ -HB_MATH_HANDLERHANDLE hb_mathInstallHandler( HB_MATH_HANDLERPROC handlerproc ) -{ - PHB_MATH_HANDLERCHAINELEMENT pChain, pNewChainelement; - - HB_TRACE(HB_TR_DEBUG, ("hb_mathInstallHandler (%p)", handlerproc)); - pNewChainelement = (PHB_MATH_HANDLERCHAINELEMENT)hb_xgrab (sizeof (HB_MATH_HANDLERCHAINELEMENT)); - pNewChainelement->handlerproc = handlerproc; - pNewChainelement->status = HB_MATH_HANDLER_STATUS_ACTIVE; - /* initially activated */ - pNewChainelement->pnext = NULL; - - pChain = s_pChain; - if( pChain == NULL ) - { - s_pChain = pNewChainelement; - } - else - { - while( pChain->pnext != NULL ) - pChain = pChain->pnext; - pChain->pnext = pNewChainelement; - } - - return ( HB_MATH_HANDLERHANDLE ) pNewChainelement; -} - -/* deinstall custom math handler */ -int hb_mathDeinstallHandler( HB_MATH_HANDLERHANDLE handle ) -{ - PHB_MATH_HANDLERCHAINELEMENT pChain; - - HB_TRACE(HB_TR_DEBUG, ("hb_mathDeinstallHandler (%p)", handle)); - - if( handle != NULL ) - { - if( s_pChain == ( PHB_MATH_HANDLERCHAINELEMENT ) handle ) - { - s_pChain = ( ( PHB_MATH_HANDLERCHAINELEMENT ) handle )->pnext; - hb_xfree( ( void * ) handle); - return 0; - } - else - { - pChain = s_pChain; - - while( pChain != NULL ) - { - if( pChain->pnext == ( PHB_MATH_HANDLERCHAINELEMENT ) handle ) - { - pChain->pnext = ( ( PHB_MATH_HANDLERCHAINELEMENT ) handle )->pnext; - hb_xfree( ( void * ) handle ); - return 0; - } - - pChain = pChain->pnext; - } - } - } - - return -1; /* not found, not deinstalled, so return error code */ -} - -/* set custom math handler status */ -int hb_mathSetHandlerStatus( HB_MATH_HANDLERHANDLE handle, int status ) -{ - int oldstatus = HB_MATH_HANDLER_STATUS_NOTFOUND; - - HB_TRACE(HB_TR_DEBUG, ("hb_mathSetHandlerStatus (%p, %i)", handle, status)); - - if( handle != NULL ) - { - oldstatus = ( ( PHB_MATH_HANDLERCHAINELEMENT ) handle )->status; - ( ( PHB_MATH_HANDLERCHAINELEMENT ) handle )->status = status; - } - - return oldstatus; -} - -/* get custom math handler status */ -int hb_mathGetHandlerStatus( HB_MATH_HANDLERHANDLE handle ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathGetHandlerStatus (%p)", handle)); - - if( handle != NULL ) - return ( ( PHB_MATH_HANDLERCHAINELEMENT ) handle )->status; - else - return HB_MATH_HANDLER_STATUS_NOTFOUND; -} - - -/* define harbour specific error handler for math errors +/* + * ************************************************************ + * Harbour Math functions Part I: + * handling math errors, C math lib redirection + * ************************************************************ */ -int matherr( struct exception * err ) + +static HB_MATH_EXCEPTION s_hb_exc = {HB_MATH_ERR_NONE, "", "", 0.0, 0.0, 0.0, 1}; + +/* reset math error information */ +void hb_mathResetError (void) { - PHB_MATH_HANDLERCHAINELEMENT pChain = s_pChain; - int retval = -1; - double dretval = 0.0; - HB_MATH_EXCEPTION exc; - - HB_TRACE(HB_TR_DEBUG, ("matherr(%p)", err)); - - /* call custom math handlers */ - switch( err->type ) - { - case DOMAIN: - exc.type = HB_MATH_ERR_DOMAIN; - break; - case SING: - exc.type = HB_MATH_ERR_SING; - break; - case OVERFLOW: - exc.type = HB_MATH_ERR_OVERFLOW; - break; - case UNDERFLOW: - exc.type = HB_MATH_ERR_UNDERFLOW; - break; - case TLOSS: - exc.type = HB_MATH_ERR_TLOSS; - break; - case PLOSS: - exc.type = HB_MATH_ERR_PLOSS; - break; - default: - exc.type = HB_MATH_ERR_UNKNOWN; - break; - } - - exc.name = err->name; - exc.arg1 = err->arg1; - exc.arg2 = err->arg2; - exc.retval = err->retval; - - while( pChain != NULL ) - { - if( pChain->status == HB_MATH_HANDLER_STATUS_ACTIVE ) - { - int ret = ( *( pChain->handlerproc ) )( &exc ); - /* store the math return value from the handler that returns the largest integer */ - if( ret > retval ) - { - dretval = exc.retval; - retval = ret; - } - } - pChain = pChain->pnext; - } - - switch( err->type ) - { - case DOMAIN: - /* a domain error has occured, such as sqrt( -1 ) */ - s_internal_math_error = EG_ARG; - break; - case SING: - /* a singularity will result, such as pow( 0, -2 ) */ - s_internal_math_error = EG_ARG; - break; - case OVERFLOW: - /* an overflow will result, such as pow( 10, 100 ) */ - s_internal_math_error = EG_NUMOVERFLOW; - break; - case UNDERFLOW: - /* an underflow will result, such as pow( 10, -100 ) */ - s_internal_math_error = EG_NUMOVERFLOW; - break; - case TLOSS: - /* total loss of significance will result, such as exp( 1000 ) */ - s_internal_math_error = EG_NUMERR; - break; - case PLOSS: - /* partial loss of significance will result, such as sin( 10e70 ) */ - s_internal_math_error = EG_NUMERR; - break; - default: - s_internal_math_error = EG_NUMERR; - break; - } - - if( retval == -1 ) - { - /* default behaviour */ - err->retval = 0.0; - return 1; /* don't print any message and don't set errno */ - } - - err->retval = dretval; - - return retval; -} - -#else /* defined (HB_MATH_HANDLER) */ - -/* the functions don't do anything but they must exist */ - -int hb_mathGetError( void ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathGetError()")); - - return 0; -} - -void hb_mathResetError( void ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathResetError()")); - + HB_TRACE (HB_TR_DEBUG, ("hb_mathResetError()")); + s_hb_exc.type = HB_MATH_ERR_NONE; + s_hb_exc.funcname = ""; + s_hb_exc.error = ""; + s_hb_exc.arg1 = 0.0; + s_hb_exc.arg2 = 0.0; + s_hb_exc.retval = 0.0; + s_hb_exc.retvalwidth = -1; /* we don't know */ + s_hb_exc.retvaldec = -1; /* use standard SET DECIMALS */ + s_hb_exc.handled = 1; return; } -int hb_mathIsHandler( void ) +/* get last math error */ +int hb_mathGetLastError (HB_MATH_EXCEPTION * phb_exc) { - HB_TRACE(HB_TR_DEBUG, ("hb_mathIsHandler()")); - - return 0; -} - -HB_MATH_HANDLERHANDLE hb_mathInstallHandler( HB_MATH_HANDLERPROC handlerproc ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathInstallHandler (%p)", handlerproc)); - - return ( HB_MATH_HANDLERHANDLE ) NULL; -} - -int hb_mathDeinstallHandler( HB_MATH_HANDLERHANDLE handle ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathDeinstallHandler (%p)", handle)); - - return -1; -} - -int hb_mathSetHandlerStatus( HB_MATH_HANDLERHANDLE handle, int status ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathSetHandlerStatus (%p, %i)", handle, status)); - - return HB_MATH_HANDLER_STATUS_NOTFOUND; -} - -int hb_mathGetHandlerStatus( HB_MATH_HANDLERHANDLE handle ) -{ - HB_TRACE(HB_TR_DEBUG, ("hb_mathGetHandlerStatus (%p)", handle)); - - return HB_MATH_HANDLER_STATUS_NOTFOUND; -} - -#endif - - -HB_FUNC( EXP ) -{ - if( ISNUM( 1 ) ) + HB_TRACE (HB_TR_DEBUG, ("hb_mathGetLastError(%p)", phb_exc)); + if (phb_exc != NULL) { -#if defined(HB_MATH_HANDLER) - double dResult = exp( hb_parnd( 1 ) ); + phb_exc->type = s_hb_exc.type; + phb_exc->funcname = s_hb_exc.funcname; + phb_exc->error = s_hb_exc.error; + phb_exc->arg1 = s_hb_exc.arg1; + phb_exc->arg2 = s_hb_exc.arg2; + phb_exc->retval = s_hb_exc.retval; + phb_exc->retvalwidth = s_hb_exc.retvalwidth; + phb_exc->retvaldec = s_hb_exc.retvaldec; + phb_exc->handled = s_hb_exc.handled; + } - if( s_internal_math_error ) - { - hb_errRT_BASE_SubstR( s_internal_math_error, 1096, NULL, "EXP", 1, hb_paramError( 1 ) ); - s_internal_math_error = 0; - } - else - hb_retnd( dResult ); + return (s_hb_exc.type); +} + +/* is it reasonable to install math error handlers ? This depends on the C math lib we are using ! */ +int hb_mathIsMathErr (void) +{ + HB_TRACE (HB_TR_DEBUG, ("hb_mathIsMathErr()")); +#if defined(HB_MATH_HANDLER) + return (1); #else - hb_retnd( exp( hb_parnd( 1 ) ) ); + return (0); #endif +} + +/* route C math lib errors to Harbour error handling */ +int matherr (struct exception * err) +{ + int retval; + HB_MATH_HANDLERPROC mathHandler; + + HB_TRACE (HB_TR_DEBUG, ("matherr(%p)", err)); + + /* map math error types */ + switch (err->type) + { + case DOMAIN: + { + s_hb_exc.type = HB_MATH_ERR_DOMAIN; + s_hb_exc.error = "Argument not in domain of function"; + }; break; + case SING: + { + s_hb_exc.type = HB_MATH_ERR_SING; + s_hb_exc.error = "Calculation results in singularity"; + }; break; + case OVERFLOW: + { + s_hb_exc.type = HB_MATH_ERR_OVERFLOW; + s_hb_exc.error = "Calculation result too large to represent"; + }; break; + case UNDERFLOW: + { + s_hb_exc.type = HB_MATH_ERR_UNDERFLOW; + s_hb_exc.error = "Calculation result too small to represent"; + }; break; + case TLOSS: + { + s_hb_exc.type = HB_MATH_ERR_TLOSS; + s_hb_exc.error = "Total loss of significant digits"; + }; break; + case PLOSS: + { + s_hb_exc.type = HB_MATH_ERR_PLOSS; + s_hb_exc.error = "Partial loss of significant digits"; + }; break; + default: + { + s_hb_exc.type = HB_MATH_ERR_UNKNOWN; + s_hb_exc.error = "Unknown math error"; + }; break; + } + + s_hb_exc.funcname = err->name; + s_hb_exc.arg1 = err->arg1; + s_hb_exc.arg2 = err->arg2; + s_hb_exc.retval = err->retval; + s_hb_exc.handled = 0; + + mathHandler = hb_mathGetHandler(); + if (mathHandler != NULL) + { + retval = (*(mathHandler))(&s_hb_exc); + err->retval = s_hb_exc.retval; } else - hb_errRT_BASE_SubstR( EG_ARG, 1096, NULL, "EXP", 1, hb_paramError( 1 ) ); + { + /* there is no custom math handler */ + retval = 1; /* don't print any message, don't set errno and use return value provided by C RTL */ + } + return (retval); + } -HB_FUNC( LOG ) -{ - if( ISNUM( 1 ) ) - { -#if defined(HB_MATH_HANDLER) - double dResult = log( hb_parnd( 1 ) ); - if( s_internal_math_error ) +/* + * ************************************************************ + * Harbour Math functions Part II: + * handling math errors, Harbour default handling routine + * ************************************************************ + */ + +static int s_hb_matherr_mode = HB_MATH_ERRMODE_DEFAULT; /* TODO: make this thread safe */ + +/* set error handling mode of hb_matherr() */ +int hb_mathSetErrMode (int imode) +{ + int oldmode; + + HB_TRACE (HB_TR_DEBUG, ("hb_mathSetErrMode (%i)", imode)); + oldmode = s_hb_matherr_mode; + s_hb_matherr_mode = imode; + return (oldmode); +} + +/* get error handling mode of hb_matherr() */ +int hb_mathGetErrMode (void) +{ + HB_TRACE (HB_TR_DEBUG, ("hb_mathGetErrMode()")); + return (s_hb_matherr_mode); +} + +/* Harbour equivalent to mathSet/GetErrMode */ +HB_FUNC (MATHERRMODE) /* ([]) -> */ +{ + hb_retni (hb_mathGetErrMode()); + + /* set new mode */ + if (ISNUM (1)) + { + int iNewMode = hb_parni (1); + if ((iNewMode == HB_MATH_ERRMODE_DEFAULT) || + (iNewMode == HB_MATH_ERRMODE_CDEFAULT) || + (iNewMode == HB_MATH_ERRMODE_USER) || + (iNewMode == HB_MATH_ERRMODE_USERDEFAULT) || + (iNewMode == HB_MATH_ERRMODE_USERCDEFAULT)) + { + hb_mathSetErrMode (iNewMode); + } + } + + return; +} + +/* Harbour default math error handling routine */ +int hb_matherr (HB_MATH_EXCEPTION * pexc) +{ + + int mode = hb_mathGetErrMode(); + + HB_TRACE(HB_TR_DEBUG, ("hb_matherr(%p)",pexc)); + if ((pexc == NULL) || + ((pexc != NULL) && (pexc->handled != 0))) + { + /* error already handled by other handlers ! */ + return (1); + } + + if ((mode == HB_MATH_ERRMODE_USER) || (mode == HB_MATH_ERRMODE_USERDEFAULT) || + (mode == HB_MATH_ERRMODE_USERCDEFAULT)) + { + + PHB_ITEM pMatherrResult; + PHB_ITEM pArg1 = hb_itemPutND (NULL, pexc->arg1); + PHB_ITEM pArg2 = hb_itemPutND (NULL, pexc->arg2); + PHB_ITEM pArray; + PHB_ITEM pError; + + /* create an array with the two double arguments */ + /* NOTE: Unfortunately, we cannot decide whether one or two parameters have been used when the + math function has been called, so we always take two */ + pArray = hb_itemArrayNew (2); + hb_itemArrayPut (pArray, 1, pArg1); + hb_itemArrayPut (pArray, 2, pArg2); + + /* create an error object */ + /* NOTE: In case of HB_MATH_ERRMODE_USER[C]DEFAULT, I am setting both EF_CANSUBSTITUTE and EF_CANDEFAULT to .T. here. + This is forbidden according to the original Cl*pper docs, but I think this reflects the situation best here: + The error handler can either substitute the errorneous value (by returning a numeric value) or choose the + default error handling (by returning .F., as usual) [martin vogel]*/ + pError = hb_errRT_New_Subst (ES_ERROR, "MATH", EG_NUMERR, pexc->type, + pexc->error, pexc->funcname, 0, EF_CANSUBSTITUTE | + (mode == HB_MATH_ERRMODE_USER ? 0: EF_CANDEFAULT)); + + /* Assign the new array to the object data item. */ + hb_vmPushSymbol (hb_dynsymGet ("_ARGS")->pSymbol); + hb_vmPush (pError); + hb_vmPush (pArray); + hb_vmDo (1); + + /* Release the Array. */ + hb_itemRelease (pArray); + + /* launch error codeblock */ + pMatherrResult = hb_errLaunchSubst (pError); + hb_errRelease (pError); + + if ((pMatherrResult != NULL) && (HB_IS_NUMERIC (pMatherrResult))) + { + pexc->retval = hb_itemGetND (pMatherrResult); + hb_itemGetNLen (pMatherrResult, &(pexc->retvalwidth), &(pexc->retvaldec)); + pexc->handled = 1; + } + + hb_itemRelease (pMatherrResult); + hb_itemRelease (pArg1); + hb_itemRelease (pArg2); + } + + /* math exception not handled by Harbour error routine above ? */ + if (pexc->handled == 0) + { + int iret; + switch (mode) + { + case HB_MATH_ERRMODE_USER: { - hb_errRT_BASE_SubstR( s_internal_math_error, 1095, NULL, "LOG", 1, hb_paramError( 1 ) ); - s_internal_math_error = 0; + /* user failed to handle the math exception, so quit the app [yes, that's the meaning of this mode !!] */ + iret = 0; + hb_vmRequestQuit(); + }; break; + + case HB_MATH_ERRMODE_DEFAULT: + case HB_MATH_ERRMODE_USERDEFAULT: + { + /* return 1 to suppress C RTL error msgs, but leave error handling to the calling Harbour routine */ + iret = 1; + }; break; + + case HB_MATH_ERRMODE_CDEFAULT: + case HB_MATH_ERRMODE_USERCDEFAULT: + { + /* use the correction value supplied in pexc->retval */ + pexc->handled = 1; + iret = 1; + }; break; + } + return (iret); + + } + + return (1); /* error handling successful */ + +} + + +/* + * ************************************************************ + * Harbour Math functions Part III: + * (de)installing and (de)activating custom math error handlers + * ************************************************************ + */ + +/* static slot for current math error handler, this is hb_matherr by default */ +static HB_MATH_HANDLERPROC s_mathHandlerProc = hb_matherr; /* TODO: make this thread safe */ + +/* install a harbour-like math error handler (that will be called by the matherr() function), return old handler */ +HB_MATH_HANDLERPROC hb_mathSetHandler (HB_MATH_HANDLERPROC handlerproc) +{ + HB_MATH_HANDLERPROC oldHandlerProc; + + HB_TRACE (HB_TR_DEBUG, ("hb_mathSetHandler (%p)", handlerproc)); + + oldHandlerProc = s_mathHandlerProc; + s_mathHandlerProc = handlerproc; + + return ((HB_MATH_HANDLERPROC)oldHandlerProc); +} + +/* get current harbour-like math error handler */ +HB_MATH_HANDLERPROC hb_mathGetHandler (void) +{ + HB_TRACE (HB_TR_DEBUG, ("hb_mathGetHandler ()")); + + return ((HB_MATH_HANDLERPROC)s_mathHandlerProc); +} + + +/* + * ************************************************************ + * Harbour Math functions Part IV: + * example of hb_mathSet/GetHandler: add a new math handler that calls a given codeblock for every math error + * ************************************************************ + */ + +static PHB_ITEM spMathErrorBlock = NULL; +static HB_MATH_HANDLERPROC sPrevMathHandler = NULL; + +static int hb_matherrblock (HB_MATH_EXCEPTION * pexc) +{ + int retval; + + /* call codeblock for both case: handled and unhandled exceptions */ + + if (spMathErrorBlock != NULL) + { + PHB_ITEM pArray, pRet; + PHB_ITEM pType, pFuncname, pError, pArg1, pArg2, pRetval, pHandled; + + pType = hb_itemPutNI (NULL, pexc->type); + pFuncname = hb_itemPutC (NULL, pexc->funcname); + pError = hb_itemPutC (NULL, pexc->error); + pArg1 = hb_itemPutND (NULL, pexc->arg1); + pArg2 = hb_itemPutND (NULL, pexc->arg2); + pRetval = hb_itemPutNDLen (NULL, pexc->retval, pexc->retvalwidth, pexc->retvaldec); + pHandled = hb_itemPutL (NULL, pexc->handled); + + pArray = hb_itemArrayNew (2); + hb_itemArrayPut (pArray, 1, pRetval); + hb_itemArrayPut (pArray, 2, pHandled); + + /* launch error codeblock that can + a) change the members of the array = {dRetval, lHandled} to set the return value of the math C RTL routine and + the and it + b) can return an integer value to set the return value of matherr(). + NOTE that these values are only used if lHandled was .F. and is set to .T. within the codeblock */ + pRet = hb_itemDo (spMathErrorBlock, 6, pType, pFuncname, pError, pArg1, pArg2, pArray); + + hb_itemRelease (pType); + hb_itemRelease (pFuncname); + hb_itemRelease (pError); + hb_itemRelease (pArg1); + hb_itemRelease (pArg2); + hb_itemRelease (pRetval); + hb_itemRelease (pHandled); + + if (pexc->handled) + { + /* math exception has already been handled, so codeblock call above was only informative */ + retval = 1; + } + else + { + /* exception handled by codeblock ? */ + pHandled = hb_itemArrayGet (pArray, 2); + if (pHandled != NULL) + { + pexc->handled = hb_itemGetL (pHandled); + hb_itemRelease (pHandled); + } + + if (pexc->handled) + { + /* YES ! */ + /* extract retval for math routine and matherr() */ + pRetval = hb_itemArrayGet (pArray, 1); + if (pRetval != NULL) + { + pexc->retval = hb_itemGetND (pRetval); + hb_itemGetNLen (pRetval, &(pexc->retvalwidth), &(pexc->retvaldec)); + hb_itemRelease (pRetval); + } + if ((pRet != NULL) && HB_IS_NUMERIC (pRet)) + { + retval = hb_itemGetNI (pRet); /* block may also return 0 to force C math lib warnings */ + hb_itemRelease (pRet); + } + else + { + retval = 1; /* default return value to suppress C math lib warnings */ + } } else - hb_retnd( dResult ); -#else - double dNumber = hb_parnd( 1 ); - - if( dNumber <= 0.0 ) - /* Indicate overflow if called with an invalid argument */ - hb_retndlen( log( dNumber ), 99, -1 ); - else - hb_retnd( log( dNumber ) ); -#endif - } - else - hb_errRT_BASE_SubstR( EG_ARG, 1095, NULL, "LOG", 1, hb_paramError( 1 ) ); -} - -HB_FUNC( SQRT ) -{ - if( ISNUM( 1 ) ) - { -#if defined(HB_MATH_HANDLER) - double dResult = sqrt( hb_parnd( 1 ) ); - - if( s_internal_math_error ) { - hb_errRT_BASE_SubstR( s_internal_math_error, 1097, NULL, "SQRT", 1, hb_paramError( 1 ) ); - s_internal_math_error = 0; + /* NO ! */ + retval = 1; } - else - hb_retnd( dResult ); -#else - double dNumber = hb_parnd( 1 ); + } + hb_itemRelease (pArray); + } + else + { + retval = 1; /* default return value to suppress C math lib warnings */ + } + + if (sPrevMathHandler != NULL) + { + if (pexc->handled) + { + /* the error is handled, so simply inform the previous handler */ + (*sPrevMathHandler)(pexc); + } + else + { + /* else go on error handling within previous handler */ + retval = (*sPrevMathHandler)(pexc); + } + } + return (retval); +} - hb_retnd( dNumber > 0 ? sqrt( dNumber ) : 0 ); /* Clipper doesn't error! */ -#endif +/* set/get math error block */ +HB_FUNC (MATHERRORBLOCK) /* ([]) -> */ +{ + + /* immediately install hb_matherrblock and keep it permanently installed ! + This is not dangerous because hb_matherrorblock will always call the previous error handler */ + if (sPrevMathHandler == NULL) + { + sPrevMathHandler = hb_mathSetHandler (hb_matherrblock); + } + + /* return old math handler */ + if (spMathErrorBlock == NULL) + { + hb_ret(); + } + else + { + HB_ITEM oldMathError; + hb_itemInit (&oldMathError); + hb_itemCopy (&oldMathError, spMathErrorBlock); + hb_itemReturn (&oldMathError); + hb_itemClear (&oldMathError); + } + + if (hb_pcount() > 0) + { + /* set new error block */ + PHB_ITEM pNewErrorBlock = hb_param (1, HB_IT_BLOCK); + if (pNewErrorBlock != NULL) + { + if (spMathErrorBlock == NULL) + { + spMathErrorBlock = hb_itemNew (NULL); + } + hb_itemCopy (spMathErrorBlock, pNewErrorBlock); + } + else + { + /* a parameter other than a block has been passed -> delete error handler ! */ + if (spMathErrorBlock != NULL) + { + hb_itemRelease (spMathErrorBlock); + spMathErrorBlock = NULL; + } + } + } + + return; +} + + +/* + * ************************************************************ + * Harbour Math functions Part V: + * EXP(), LOG(), SQRT() + * ************************************************************ + */ + +HB_FUNC (EXP) +{ + if (ISNUM (1)) + { + HB_MATH_EXCEPTION hb_exc; + double dResult; + + hb_mathResetError(); + dResult = exp (hb_parnd (1)); + + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* math exception is up to the Harbour function, so do this as Clipper compatible as possible */ + if (iLastError == HB_MATH_ERR_OVERFLOW) + { + hb_retndlen (HUGE_VAL, -1, -1); + } + else + { + hb_retnd (0.0); + } + } + return; + } + } + hb_retnd (dResult); } else - hb_errRT_BASE_SubstR( EG_ARG, 1097, NULL, "SQRT", 1, hb_paramError( 1 ) ); + { + hb_errRT_BASE_SubstR (EG_ARG, 1096, NULL, "EXP", 1, hb_paramError (1)); + } } + + +HB_FUNC (LOG) +{ + + if (ISNUM (1)) + { + HB_MATH_EXCEPTION hb_exc; + double dResult; + + hb_mathResetError(); + dResult = log (hb_parnd (1)); + + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* math exception is up to the Harbour function, so do this as Clipper compatible as possible */ + switch (iLastError) + { + case HB_MATH_ERR_SING: /* argument to log was 0.0 */ + case HB_MATH_ERR_DOMAIN: /* argument to log was < 0.0 */ + { + hb_retndlen (-HUGE_VAL, -1, -1); /* return -infinity */ + }; break; + default: + { + hb_retnd (0.0); + } + } + } + return; + } + } + hb_retnd (dResult); + } + else + { + hb_errRT_BASE_SubstR (EG_ARG, 1095, NULL, "LOG", 1, hb_paramError (1)); + } +} + + +HB_FUNC (SQRT) +{ + if (ISNUM (1)) + { + HB_MATH_EXCEPTION hb_exc; + double dResult; + + hb_mathResetError(); + dResult = sqrt (hb_parnd (1)); + + if (hb_mathIsMathErr()) + { + /* the C-RTL provides a kind of matherr() mechanism */ + int iLastError = hb_mathGetLastError (&hb_exc); + if (iLastError != HB_MATH_ERR_NONE) + { + if (hb_exc.handled) + { + hb_retndlen (hb_exc.retval, hb_exc.retvalwidth, hb_exc.retvaldec); + } + else + { + /* math exception is up to the Harbour function, so do this as Clipper compatible as possible */ + hb_retnd (0.0); /* return 0.0 on all errors (all (?) of type DOMAIN) */ + } + return; + } + } + hb_retnd (dResult); + } + else + { + hb_errRT_BASE_SubstR (EG_ARG, 1097, NULL, "SQRT", 1, hb_paramError (1)); + } +} + diff --git a/harbour/source/vm/itemapi.c b/harbour/source/vm/itemapi.c index 77e8ea960a..3656a741b7 100644 --- a/harbour/source/vm/itemapi.c +++ b/harbour/source/vm/itemapi.c @@ -84,6 +84,9 @@ */ #include /* For log() */ +#if defined(__BORLANDC__) +#include /* for _finite() and _isnan() */ +#endif #include "hbapi.h" #include "hbstack.h" @@ -91,6 +94,7 @@ #include "hbapierr.h" #include "hbdate.h" #include "hbset.h" +#include "hbmath.h" /* DJGPP can sprintf a float that is almost 320 digits long */ #define HB_MAX_DOUBLE_LENGTH 320 @@ -661,7 +665,17 @@ PHB_ITEM hb_itemPutNDLen( PHB_ITEM pItem, double dNumber, int iWidth, int iDec ) pItem = hb_itemNew( NULL ); if( iWidth <= 0 || iWidth > 99 ) - iWidth = ( dNumber >= 10000000000.0 || dNumber <= -1000000000.0 ) ? 20 : 10; + { +#if defined (__BORLANDC__) + /* Borland C compiled app crashes if a "NaN" double is compared with another double [martin vogel] */ + if (_isnan (dNumber)) + { + iWidth = 20; + } + else +#endif + iWidth = ( dNumber >= 10000000000.0 || dNumber <= -1000000000.0 ) ? 20 : 10; + } if( iDec < 0 ) iDec = hb_set.HB_SET_DECIMALS; @@ -1124,22 +1138,36 @@ char * hb_itemStr( PHB_ITEM pNumber, PHB_ITEM pWidth, PHB_ITEM pDec ) { double dNumber = hb_itemGetND( pNumber ); - #if defined(__BORLANDC__) || defined(__WATCOMC__) + /* #if defined(__BORLANDC__) || defined(__WATCOMC__) */ + /* added infinity check for Borland C [martin vogel] */ + #if defined(__WATCOMC__) #else static double s_dInfinity = 0; static double s_bInfinityInit = FALSE; if( ! s_bInfinityInit ) { + /* set math handler to NULL for evaluating log(0), + to avoid error messages [martin vogel]*/ + HB_MATH_HANDLERPROC fOldMathHandler = hb_mathSetHandler (NULL); s_dInfinity = -log( ( double ) 0 ); + hb_mathSetHandler (fOldMathHandler); s_bInfinityInit = TRUE; } #endif + /* TODO: look if isinf()/_isinf or finite()/_finite() does exist for your compiler and add this to the check + below [martin vogel] */ if( pNumber->item.asDouble.length == 99 - #if defined(__BORLANDC__) || defined(__WATCOMC__) + /* #if defined(__BORLANDC__) || defined(__WATCOMC__) */ + #if defined(__WATCOMC__) + #elif defined(__BORLANDC__) /* No more checks for Borland C, which returns 0 for log( 0 ), and is therefore unable to test for infinity */ + /* log(0) returning 0 seems to be a side effect of using a custom math error handler that + always sets the return value to 0.0, switching this off, see above, yields -INF for log(0); + additionally one can use _finite() to check for infinity [martin vogel] */ + || dNumber == s_dInfinity || dNumber == -s_dInfinity || _finite(dNumber)==0 #else || dNumber == s_dInfinity || dNumber == -s_dInfinity #endif diff --git a/harbour/tests/mathtest.prg b/harbour/tests/mathtest.prg index 1a15118dbf..c5c0d24f4e 100644 --- a/harbour/tests/mathtest.prg +++ b/harbour/tests/mathtest.prg @@ -2,12 +2,95 @@ // $Id$ // -func main() - qout( sin( 33 ) ) - qout( cos( 43 ) ) - qout( tan( 54 ) ) - qout( log10( 112 ) ) - qout( asin( 33 ) ) - qout( acos( 43 ) ) - qout( atan( 54 ) ) +#include "math.ch" + +function main() + +local nOldMathErrMode +local bOldMathErr + + qout ("Testing math function: EXP(), LOG() and SQRT():") + qout ("") + qout (" I) Test with correct arguments:") + qout (" exp(0.0) == 1.00 ? ", exp (0.0)) + qout (" exp(1.0) == 2.71(8)... ? ", exp (1.0)) + qout (" exp(-1.0) == 0.36(7)... ? ", exp (-1.0)) + qout ("") + qout (" log(1.0) == 0.00 ? ", log (1.0)) + qout (" log(2.7) == 0.99(3)... ? ", log (2.7)) + qout (" log(0.36) == -1.02(1)... ? ", log (0.36)) + qout ("") + qout (" sqrt(1.0) == 1.00 ? ", sqrt (1.0)) + qout (" sqrt(4.0) == 2.00 ? ", sqrt (4.0)) + qout (" sqrt(2.0) == 1.41(4).. ? ", sqrt (2.0)) + qout ("") + qout (" II) Test with numeric but incorrect arguments:") + qout ("") + qout (" IIa) default error handling (by the functions themselves)") + qout (" exp (-1000) == 0.00 ?", exp (-1000)) + qout (" exp (1000) == ****... ?", exp (1000)) + qout ("") + qout (" log (0) == ****... ?", log (0)) + qout (" log (-10) == *****... ?", log (-10)) + qout ("") + qout (" sqrt (-4) == 0.00 ?", sqrt (-4)) + qout ("") + + nOldMathErrMode := MathErrMode (HB_MATH_ERRMODE_USERDEFAULT) + + qout (" IIb) error handling by error (MathErrMode() == HB_MATH_ERRMODE_USERDEFAULT)") + qout (" exp (-1000) == 0.00 ?", exp (-1000)) + qout (" exp (1000) == ****... ?", exp (1000)) + qout ("") + qout (" log (0) == ****... ?", log (0)) + qout (" log (-10) == *****... ?", log (-10)) + qout ("") + qout (" sqrt (-4) == 0.00 ?", sqrt (-4)) + qout ("") + + MathErrMode (nOldMathErrMode) + + bOldMathErr := MathErrorBlock ({|nType, cFuncname, cError, nArg1, nArg2, aInfo|; + localmatherr (nType, cFuncname, cError, nArg1, nArg2, aInfo)}) + + qout (" IIc) error handling by callback block (MathErrorBlock())") + qout (" exp (-1000) == ?", exp (-1000)) + qout (" exp (1000) == ?", exp (1000)) + qout ("") + qout (" log (0) == ?", log (0)) + qout (" log (-10) == ?", log (-10)) + qout ("") + qout (" sqrt (-4) == ?", sqrt (-4)) + + MathErrorBlock (bOldMathErr) + return nil + +function localmatherr (nType, cFuncname, cError, nArg1, nArg2, aInfo) + +local cStr := "!! Local handling of math error MATH/" + + cStr += alltrim(str(nType))+" in "+cFuncname+"(" + + if valtype(nArg1) == "N" + cStr += alltrim(str(nArg1)) + endif + if valtype(nArg2) == "N" + cStr += ","+alltrim(str(nArg2)) + endif + cStr += "):" + qout (cStr) + qout ("!! "+cError) + if aInfo[HB_MATHERRORBLOCK_HANDLED] + qout ("!! --> already handled with return value: "+; + alltrim(str(aInfo[HB_MATHERRORBLOCK_RETVAL]))) + return (1) + endif + + qout ("!! setting return value to --> 5.0") + + aInfo[HB_MATHERRORBLOCK_RETVAL] := 5.0 + aInfo[HB_MATHERRORBLOCK_HANDLED] := .T. + +return (1) +