fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2002-07-07 22:40 UTC+0100 Martin Vogel <vogel@inttec.de>

Browse Source
This commit is contained in:
Martin Vogel
2002-07-07 20:45:38 +00:00
parent 1dea91a364
commit 05cc84872f
17 changed files with 1377 additions and 1004 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
harbour/ChangeLog
View File

@@ -8,6 +8,33 @@
2002-12-01 23:12 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2002-07-07 22:40 UTC+0100 Martin Vogel <vogel@inttec.de>
* 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 <alinares@fivetech.com>
* harbour/source/debug/debugger.prg
* Changed constructor sequence

10
harbour/contrib/libct/cterror.ch
View File

@@ -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

1
harbour/contrib/libct/ctflist.txt
View File

@@ -618,7 +618,6 @@ PI ;R;
PV ;R;
RATE ;R;
RTOD ;R;
SETMATHERR ;R; !NEW!
SETPREC ;R;
SIGN ;R;
SIN ;R;

354
harbour/contrib/libct/ctmath.c
View File

@@ -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 <vogel@inttec.de>
@@ -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 ([<nStatus>] [,<[@]nMode>]) -> nOldStatus
* $ARGUMENTS$
* [<nStatus>] 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 <nStatus>
* and <nMode>:
*
* The values of <nStatus> and <nOldStatus> 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 <nMode> 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 <nMode> 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 */
/* ---------------- */

25
harbour/contrib/libct/ctmath.h
View File

@@ -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();

155
harbour/contrib/libct/finan.c
View File

@@ -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 )

82
harbour/contrib/libct/math.c
View File

@@ -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;
}

4
harbour/contrib/libct/num1.c
View File

@@ -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

2
harbour/contrib/libct/readme.txt
View File

@@ -65,8 +65,6 @@ Martin Vogel <vogel@inttec.de>
* 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,

2
harbour/contrib/libct/tests/Makefile
View File

@@ -83,7 +83,7 @@ PRG_SOURCES=\
tokenupp.prg \
trig.prg \
valpos.prg \
wordone.org \
wordone.prg \
wordonly.prg \
wordrepl.prg \
wordrem.prg \

361
harbour/contrib/libct/trig.c
View File

@@ -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

177
harbour/doc/en/math.txt
View File

@@ -343,7 +343,7 @@
/* $DOC$
* $FUNCNAME$
* hb_getMathError()
* hb_mathGetLastError()
* $CATEGORY$
* Math API
* $ONELINER$
@@ -352,7 +352,52 @@
* C Prototype
*
* #include <hbmath.h>
* 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 <hbmath.h>
* 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 <hbmath.h>
* 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 <hbmath.h>
* 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 <hbmath.h>
* 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 <hbmath.h>
* 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 <hbmath.h>
* 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 <hbmath.h>
* hb_setMathHandlerStatus (HB_MATH_HANDLERHANDLE handle, int status) --> int iSuccess
* MATHERRMODE ([<nNewMode>]) -> <nOldMode>
* $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
* [<nNumber>] 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
* <nOldMode> 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 <hbmath.h>
* hb_getMathHandlerStatus (HB_MATH_HANDLERHANDLE handle) --> int iStatus
* MATHERRORBLOCK ([<bNewBlock>]) -> <bOldBlock>
* $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$
*/

51
harbour/include/hbmath.h
View File

@@ -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 <math.ch>
#if defined(HB_EXTERN_C)
}

82
harbour/include/math.ch Normal file
View File

@@ -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 <vogel@inttec.de>
* 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 */

915
harbour/source/rtl/math.c
View File

@@ -8,8 +8,8 @@
*
* Copyright 1999 Matthew Hamilton <mhamilton@bunge.com.au>
*
* 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 <vogel@inttec.de>
*
* 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) /* ([<nNewMode>]) -> <nOldMode> */
{
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 <exception handled flag> 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) /* ([<nNewErrorBlock>]) -> <nOldErrorBlock> */
{
/* 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));
}
}

34
harbour/source/vm/itemapi.c
View File

@@ -84,6 +84,9 @@
*/
#include <math.h> /* For log() */
#if defined(__BORLANDC__)
#include <float.h> /* 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

99
harbour/tests/mathtest.prg
View File

@@ -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)