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

2001-07-20 13:10 GMT+2 Martin Vopgel <vogel@inttec.de>

Browse Source
This commit is contained in:
Martin Vogel
2001-07-20 11:14:33 +00:00
parent 0f765fb8fb
commit ad9e413e24
6 changed files with 122 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
harbour/ChangeLog
View File

@@ -1,3 +1,18 @@
2001-07-20 13:10 GMT+2 Martin Vopgel <vogel@inttec.de>
* source/rtl/math.c
* include/hbmath.h
! Added typedefs for non-matherr-math libraries
! Fixed bug concerning custom math handler return values
* contrib/libct/ctmath.c
* contrib/libct/ctmath.h
! Changes analog to the changes in rtl/math.c
! minor bug fixes and cleanups
* contrib/libct/makefile.bc
! typo fixed
2001-07-20 13:35 GMT+3 Alexander Kresin <alex@belacy.belgorod.su>
* source/rtl/memofile.c
! A bug fixed, which appeared while reading an empty file

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

@@ -58,43 +58,65 @@
/* -------------- */
/* initialization */
/* -------------- */
static HB_MATH_HANDLERHANDLE s_ctMathHandler; /* TODO: make this thread safe */
static HB_MATH_HANDLERHANDLE s_ctMathHandler = NULL; /* TODO: make this thread safe */
int ct_math_init (void)
{
HB_TRACE(HB_TR_DEBUG, ("ctmath_init()"));
s_ctMathHandler = hb_installMathHandler (ct_matherr);
/* CT3 math handler is inactive by default */
hb_setMathHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_INACTIVE);
return;
if (hb_isMathHandler())
{
s_ctMathHandler = hb_installMathHandler (ct_matherr);
/* CT3 math handler is inactive by default */
hb_setMathHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_INACTIVE);
return (1);
}
return (0);
}
int ct_math_exit (void)
{
HB_TRACE(HB_TR_DEBUG, ("ctmath_exit()"));
hb_deinstallMathHandler (s_ctMathHandler);
return;
if (hb_isMathHandler())
{
hb_deinstallMathHandler (s_ctMathHandler);
}
return (1);
}
static int s_ct_matherr_status = CT_MATHERR_STATUS_INACTIVE; /* TODO: make this thread safe */
void ct_setmatherrstatus (int iStatus)
{
HB_TRACE(HB_TR_DEBUG, ("ct_setmatherrstatus (%i)", iStatus));
if (s_ctMathHandler != NULL)
{
hb_setMathHandlerStatus (s_ctMathHandler, iStatus);
}
s_ct_matherr_status = iStatus;
return;
}
int ct_getmatherrstatus (void)
{
HB_TRACE(HB_TR_DEBUG, ("ct_getmatherrstatus()"));
if (s_ctMathHandler != NULL)
return (s_ct_matherr_status);
}
/* functions to "bracket" CT3 math code */
void ct_matherrbegin (void)
{
HB_TRACE(HB_TR_DEBUG, ("ct_matherrbegin()"));
if (hb_isMathHandler() && (s_ct_matherr_status == CT_MATHERR_STATUS_ACTIVE))
{
return (hb_getMathHandlerStatus (s_ctMathHandler));
hb_setMathHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_ACTIVE);
}
return (0);
return;
}
void ct_matherrend (void)
{
HB_TRACE(HB_TR_DEBUG, ("ct_matherrend()"));
if (hb_isMathHandler())
{
hb_setMathHandlerStatus (s_ctMathHandler, CT_MATHERR_STATUS_INACTIVE);
}
return;
}
/* ------------------------- */
@@ -107,6 +129,7 @@ void ct_setmatherrmode (int iMode)
s_ct_matherr_mode = iMode;
return;
}
int ct_getmatherrmode (void)
{
HB_TRACE(HB_TR_DEBUG, ("ct_getmatherrmode()"));
@@ -144,7 +167,8 @@ int ct_getmatherrmode (void)
* 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 to its own math handler.
* 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>:
*
@@ -266,20 +290,20 @@ HB_FUNC (SETMATHERR)
/* -------------- */
/* math handler */
/* -------------- */
int ct_matherr (struct exception * err)
int ct_matherr (HB_MATH_EXCEPTION * pexc)
{
int retval = 0;
int imatherr = ct_getmatherrmode();
HB_TRACE(HB_TR_DEBUG, ("ct_matherr (%p)", err));
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 (err->type)
switch (pexc->type)
{
case DOMAIN:
/* a domain error has occured, such as sqrt( -1 ) */
@@ -304,15 +328,15 @@ int ct_matherr (struct exception * err)
ulSubCode = CT_ERROR_MATHLIB; break;
}
pArg1 = hb_itemPutND (NULL, err->arg1);
pArg2 = hb_itemPutND (NULL, err->arg2);
pArg1 = hb_itemPutND (NULL, pexc->arg1);
pArg2 = hb_itemPutND (NULL, pexc->arg2);
pMatherrResult = ct_error_subst (ES_ERROR, EG_NUMERR, ulSubCode,
NULL, err->name, 0, EF_CANSUBSTITUTE,
NULL, pexc->name, 0, EF_CANSUBSTITUTE,
2, pArg1, pArg2);
if ((pMatherrResult != NULL) && (HB_IS_NUMERIC (pMatherrResult)))
{
err->retval = hb_itemGetND (pMatherrResult);
pexc->retval = hb_itemGetND (pMatherrResult);
retval = 1;
}
@@ -325,53 +349,53 @@ int ct_matherr (struct exception * err)
((imatherr == CT_MATHERR_MODE_DEFAULT) || (imatherr == CT_MATHERR_MODE_USERDEFAULT)))
{
/* find some appropiate return values */
switch (err->type)
switch (pexc->type)
{
case DOMAIN:
/* a domain error has occured, such as sqrt( -1 ) */
err->retval = 0.0;
pexc->retval = 0.0;
retval = 1;
break;
case SING:
/* a singularity will result, such as pow( 0, -2 ) */
if (err->arg1 < 0) /* it is just a guess that the resulting singularity
has the same sign as the first argument */
err->retval = -DBL_MAX;
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
err->retval = DBL_MAX;
pexc->retval = DBL_MAX;
retval = 1;
break;
case OVERFLOW:
/* an overflow will result, such as pow( 10, 100 ) */
if (err->arg1 < 0) /* it is just a guess that the resulting singularity
has the same sign as the first argument */
err->retval = -DBL_MAX;
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
err->retval = DBL_MAX;
pexc->retval = DBL_MAX;
retval = 1;
break;
case UNDERFLOW:
/* an underflow will result, such as pow( 10, -100 ) */
if (err->arg1 < 0) /* it is just a guess that the resulting singularity
has the same sign as the first argument */
err->retval = -DBL_MIN;
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
err->retval = DBL_MIN;
pexc->retval = DBL_MIN;
retval = 1;
break;
case TLOSS:
/* total loss of significance will result, such as exp( 1000 ) */
err->retval = 1.0;
pexc->retval = 1.0;
retval = 1;
break;
case PLOSS:
/* partial loss of significance will result, such as sin( 10e70 ) */
err->retval = 1.0;
pexc->retval = 1.0;
retval = 1;
break;
default:
/* unknown math lib error */
err->retval = 0.0;
pexc->retval = 0.0;
retval = 1;
break;
}

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

@@ -70,6 +70,10 @@ extern int ct_getmatherrstatus (void);
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 */
@@ -81,7 +85,7 @@ extern int ct_getmatherrmode (void);
#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 (struct exception * err);
extern int ct_matherr (HB_MATH_EXCEPTION * pexc);
/* set & get precision */
extern void ct_setprecision (int iPrecision);

4
harbour/contrib/libct/makefile.bc
View File

@@ -106,8 +106,8 @@ TOOLS_LIB_OBJS = \
$(OBJ_DIR)\charrepl.obj \
$(OBJ_DIR)\charsort.obj \
$(OBJ_DIR)\charswap.obj \
$(OBJ_DIR)\ct.c \
$(OBJ_DIR)\ctmath.c \
$(OBJ_DIR)\ct.obj \
$(OBJ_DIR)\ctmath.obj \
$(OBJ_DIR)\ctset.obj \
$(OBJ_DIR)\ctstr.obj \
$(OBJ_DIR)\ctchksum.obj \

12
harbour/include/hbmath.h
View File

@@ -87,7 +87,17 @@ extern int hb_getMathError (void);
extern void hb_resetMathError (void);
extern int hb_isMathHandler (void);
typedef int (* HB_MATH_HANDLERPROC)(struct exception *err);
typedef struct _HB_MATH_EXCEPTION
{
int type;
char *name;
double arg1;
double arg2;
double retval;
} HB_MATH_EXCEPTION;
typedef int (* HB_MATH_HANDLERPROC)(HB_MATH_EXCEPTION *err);
typedef struct HB_MATH_HANDLERCHAINELEMENT_
{
HB_MATH_HANDLERPROC handlerproc;

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

@@ -8,10 +8,10 @@
*
* Copyright 1999 Matthew Hamilton <mhamilton@bunge.com.au>
*
* Functions for user defined math error handlers
* Functions for user defined math error handlers
* Copyright 2001 IntTec GmbH, 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
@@ -92,7 +92,7 @@ static PHB_MATH_HANDLERCHAINELEMENT s_pChain = NULL; /* TODO: make this thread s
/* install custom math handler */
HB_MATH_HANDLERHANDLE hb_installMathHandler (HB_MATH_HANDLERPROC handlerproc)
{
PHB_MATH_HANDLERCHAINELEMENT pChain, pNewChainelement;
HB_TRACE(HB_TR_DEBUG, ("hb_installMathHandler (%p)", handlerproc));
@@ -121,7 +121,7 @@ HB_MATH_HANDLERHANDLE hb_installMathHandler (HB_MATH_HANDLERPROC handlerproc)
/* deinstall custom math handler */
int hb_deinstallMathHandler (HB_MATH_HANDLERHANDLE handle)
{
PHB_MATH_HANDLERCHAINELEMENT pChain;
HB_TRACE(HB_TR_DEBUG, ("hb_deinstallMathHandler (%p)", handle));
@@ -136,7 +136,7 @@ int hb_deinstallMathHandler (HB_MATH_HANDLERHANDLE handle)
else
{
pChain = s_pChain;
while (pChain != NULL)
{
if (pChain->pnext == (PHB_MATH_HANDLERCHAINELEMENT)handle)
@@ -159,7 +159,7 @@ int hb_deinstallMathHandler (HB_MATH_HANDLERHANDLE handle)
int hb_setMathHandlerStatus (HB_MATH_HANDLERHANDLE handle, int status)
{
int oldstatus = HB_MATH_HANDLER_STATUS_NOTFOUND;
HB_TRACE(HB_TR_DEBUG, ("hb_setMathHandlerStatus (%p, %i)", handle, status));
if (handle != NULL)
{
@@ -191,18 +191,30 @@ int matherr( struct exception * err )
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 */
exc.type = err->type;
exc.name = err->name;
exc.arg1 = err->arg1;
exc.arg2 = err->arg2;
exc.retval = err->retval;
while (pChain != NULL)
{
int ret;
if (pChain->status == HB_MATH_HANDLER_STATUS_ACTIVE)
{
ret = (*(pChain->handlerproc))(err);
/* store the maximum return value */
retval = (retval <= ret ? ret : retval);
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;
}
@@ -242,9 +254,10 @@ int matherr( struct exception * err )
{
/* default behaviour */
err->retval = 0.0;
return 1; /* don't print any message and don't set errno */
return (1); /* don't print any message and don't set errno */
}
err->retval = dretval;
return (retval);
}