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

19990831-17:40 GMT+1

Browse Source
This commit is contained in:
Viktor Szakats
1999-08-31 15:56:33 +00:00
parent 33a3b2def3
commit 7472d95e81
23 changed files with 1096 additions and 814 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
harbour/ChangeLog
View File

@@ -1,3 +1,59 @@
19990831-17:40 GMT+1 Victor Szel <info@szelvesz.hu>
* source/rtl/arrays.c
include/extend.h
! Fixed handling of zero array index, it was allowed previously.
(hb_arrayGet*(), hb_arraySet())
+ Added hb_arrayError() which checks the pArray and ulIndex, if it's not
valid, it throws a runtime error.
* source/vm/hvm.c
! Fixed where operations followed the hb_err*() call.
(hb_vmArrayAt(), hb_vmArrayPut(), hb_vmDo(), ...)
! hb_vmPopLogical() was decrementing the stack but was only clearing it
when it was logical type. Leak fixed. (Is this correct ?)
* hb_vmAliasPop() -> hb_vmPopAlias()
hb_vmAliasPush() -> hb_vmPushAlias()
hb_vmAliasSwap() -> hb_vmSwapAlias()
Renamed to be consistent with the pcode name and with the others.
* tests/working/rtl_test.prg
tests/working/empty.prg (removed)
tests/working/strsub.prg (removed)
+ Added many new tests, comments, enhancement.
+ EMPTY.PRG, STRSUB.PRG incorporated.
! Some TRANSFORM() test results changed (@0)
* source/rtl/devoutp.prg
% One local variable eliminated.
* source/vm/hvm.c
+ Added value substitution for errors 1081, 1082, 1083, 1084, 1085, 1088
* source/rtl/transfrm.c
+ Put all stuff related to the @0 picture clause between
#ifndef HARBOUR_STRICT_CLIPPER_COMPATIBILITY guards, since this was
not in original Clipper, that's why the tests failed.
* source/rtl/set.c
! Fixed "ON"/"OFF" error where OFF was not recognized, this bug was
introduced yesterday.
% Some variables scopes optimalized, some internals changed to standard
interface calls.
* source/rtl/errorapi.c
source/vm/hvm.c
include/extend.h
+ Moved ERRORBLOCK() and errorBlock variable to errorapi.c, hb_errInit()
hb_errExit() added. All that is a *bit* slower, since only "official"
API calls are being used.
* source/runner/runlib.c
source/rtl/gtapi.c
source/vm/dynsym.c
source/vm/hvm.c
include/vm.api
include/fm.api
include/hbpp.h
include/gtapi.h
include/extend.h
include/hb_vmpub.h
include/hbdefs.h
* Formatting errors corrected.
+ static variables prefixed with "s_"
19990831-02:37 GMT+1 Bruno Cantero <bruno@issnet.net>
* include/rddapi.h
source/rdd/dbcmd.c

5
harbour/include/errorapi.h
View File

@@ -95,7 +95,10 @@ extern PHB_ITEM hb_errPutSubSystem ( PHB_ITEM pError, char * szSubSystem );
extern PHB_ITEM hb_errPutTries ( PHB_ITEM pError, USHORT uiTries );
extern void hb_errRelease ( PHB_ITEM pError );
/* Error launchers */
/* Harbour additions */
extern void hb_errInit ( void );
extern void hb_errExit ( void );
extern PHB_ITEM hb_errLaunchSubst ( PHB_ITEM pError );

41
harbour/include/extend.h
View File

@@ -38,24 +38,24 @@
#endif
/* items types */
#define IT_NIL ((WORD) 0x0000)
#define IT_INTEGER ((WORD) 0x0002)
#define IT_LONG ((WORD) 0x0008)
#define IT_DOUBLE ((WORD) 0x0010)
#define IT_DATE ((WORD) 0x0020)
#define IT_LOGICAL ((WORD) 0x0080)
#define IT_SYMBOL ((WORD) 0x0100)
#define IT_ALIAS ((WORD) 0x0200)
#define IT_STRING ((WORD) 0x0400)
#define IT_MEMOFLAG ((WORD) 0x0800)
#define IT_NIL ( ( WORD ) 0x0000 )
#define IT_INTEGER ( ( WORD ) 0x0002 )
#define IT_LONG ( ( WORD ) 0x0008 )
#define IT_DOUBLE ( ( WORD ) 0x0010 )
#define IT_DATE ( ( WORD ) 0x0020 )
#define IT_LOGICAL ( ( WORD ) 0x0080 )
#define IT_SYMBOL ( ( WORD ) 0x0100 )
#define IT_ALIAS ( ( WORD ) 0x0200 )
#define IT_STRING ( ( WORD ) 0x0400 )
#define IT_MEMOFLAG ( ( WORD ) 0x0800 )
#define IT_MEMO ( IT_MEMOFLAG & IT_STRING )
#define IT_BLOCK ((WORD) 0x1000)
#define IT_BYREF ((WORD) 0x2000)
#define IT_MEMVAR ((WORD) 0x4000)
#define IT_ARRAY ((WORD) 0x8000)
#define IT_BLOCK ( ( WORD ) 0x1000 )
#define IT_BYREF ( ( WORD ) 0x2000 )
#define IT_MEMVAR ( ( WORD ) 0x4000 )
#define IT_ARRAY ( ( WORD ) 0x8000 )
#define IT_OBJECT IT_ARRAY
#define IT_NUMERIC ( IT_INTEGER | IT_LONG | IT_DOUBLE )
#define IT_ANY ((WORD) 0xFFFF)
#define IT_ANY ( ( WORD ) 0xFFFF )
/* forward declarations */
struct _HB_CODEBLOCK;
@@ -128,7 +128,7 @@ struct hb_struRefer
struct hb_struString
{
ULONG length;
char *value;
char * value;
};
struct hb_struSymbol
@@ -186,7 +186,7 @@ typedef struct
/* internal structure for codeblocks */
typedef struct _HB_CODEBLOCK
{
BYTE* pCode; /* codeblock pcode */
BYTE * pCode; /* codeblock pcode */
PHB_ITEM pLocals; /* table with referenced local variables */
WORD wLocals; /* number of referenced local variables */
PHB_SYMB pSymbols; /* codeblocks symbols */
@@ -202,7 +202,6 @@ typedef struct _HB_VALUE
extern STACK stack;
extern HB_SYMB symEval;
extern HB_ITEM errorBlock;
extern HB_ITEM aStatics;
/* Extend API */
@@ -246,6 +245,7 @@ extern void * hb_xrealloc( void * pMem, ULONG lSize ); /* reallocates memory *
extern ULONG hb_xsize( void * pMem ); /* returns the size of an allocated memory block */
/* array management */
extern BOOL hb_arrayError( PHB_ITEM pArray, ULONG ulIndex, BOOL bAssign ); /* Checks if the passed parameters are valid, launches runtim error if needed */
extern void hb_arrayNew( PHB_ITEM pItem, ULONG ulLen ); /* creates a new array */
extern void hb_arrayGet( PHB_ITEM pArray, ULONG ulIndex, PHB_ITEM pItem ); /* retrieves an item */
extern ULONG hb_arrayLen( PHB_ITEM pArray ); /* retrives the array len */
@@ -268,13 +268,13 @@ extern void hb_arrayAdd( PHB_ITEM pArray, PHB_ITEM pItemValue );
#define HB_STRGREATER_LEFT 1
#define HB_STRGREATER_RIGHT 2
extern int hb_stricmp( const char *s1, const char *s2 );
extern int hb_stricmp( const char * s1, const char * s2 );
extern int hb_strgreater( char * sz1, char * sz2 );
extern void hb_strupr( char * szText );
extern BOOL hb_strMatchRegExp( char * szString, char * szMask );
extern BOOL hb_strEmpty( char * szText, ULONG ulLen );
extern char * hb_strDescend( char * szText, ULONG ulLen );
extern ULONG hb_strAt(char *szSub, ULONG ulSubLen, char *szText, ULONG ulLen);
extern ULONG hb_strAt( char * szSub, ULONG ulSubLen, char * szText, ULONG ulLen );
extern char * hb_strUpper( char * szText, ULONG ulLen );
extern char * hb_strLower( char * szText, ULONG ulLen );
extern char * hb_strDescend( char * szText, ULONG ulLen );
@@ -329,3 +329,4 @@ extern char * hb_consoleGetNewLine( void );
extern char * hb_setColor( char * );
#endif /* HB_EXTEND_H_ */

10
harbour/include/fm.api
View File

@@ -13,13 +13,13 @@
/* Functions */
#define _xalloc hb_xalloc
#define _xgrab hb_xgrab
#define _xfree hb_xfree
#define _xalloc hb_xalloc
#define _xgrab hb_xgrab
#define _xfree hb_xfree
/* Nant*cket Clipper Summer 87 compatible */
#define _exmgrab hb_xgrab
#define _exmback(p, s) hb_xfree( p )
#define _exmgrab hb_xgrab
#define _exmback( p, s ) hb_xfree( p )
#endif /* HB_FM_API_ */

4
harbour/include/gtapi.h
View File

@@ -102,7 +102,7 @@ extern void hb_gt_DrawShadow( char cTop, char cLeft, char cBottom, char cRight
extern void hb_gt_DispBegin( void );
extern void hb_gt_DispEnd( void );
extern BOOL hb_gt_SetMode( USHORT uiRows, USHORT uiCols );
extern BOOL hb_gt_GetBlink(void);
extern void hb_gt_SetBlink(BOOL bBlink);
extern BOOL hb_gt_GetBlink( void );
extern void hb_gt_SetBlink( BOOL bBlink );
#endif /* HB_GTAPI_H_ */

14
harbour/include/hb_vmpub.h
View File

@@ -63,14 +63,14 @@ typedef struct _HB_DYNS
#define HB_DYNS_FUNC( hbfunc ) BOOL hbfunc( PHB_DYNS pDynSymbol )
typedef HB_DYNS_FUNC( PHB_DYNS_FUNC );
/* Harbour Functions scope (SYMBOLSCOPE) */
#define FS_PUBLIC ((SYMBOLSCOPE)0x00)
#define FS_STATIC ((SYMBOLSCOPE)0x02)
#define FS_INIT ((SYMBOLSCOPE)0x08)
#define FS_EXIT ((SYMBOLSCOPE)0x10)
/* Harbour Functions scope ( SYMBOLSCOPE ) */
#define FS_PUBLIC ( ( SYMBOLSCOPE ) 0x00 )
#define FS_STATIC ( ( SYMBOLSCOPE ) 0x02 )
#define FS_INIT ( ( SYMBOLSCOPE ) 0x08 )
#define FS_EXIT ( ( SYMBOLSCOPE ) 0x10 )
#define FS_INITEXIT ( FS_INIT | FS_EXIT )
#define FS_MESSAGE ((SYMBOLSCOPE)0x20)
#define FS_MEMVAR ((SYMBOLSCOPE)0x80)
#define FS_MESSAGE ( ( SYMBOLSCOPE ) 0x20 )
#define FS_MEMVAR ( ( SYMBOLSCOPE ) 0x80 )
extern void hb_vmExecute( BYTE * pCode, PHB_SYMB pSymbols ); /* invokes the virtual machine */

4
harbour/include/hbdefs.h
View File

@@ -79,10 +79,10 @@ typedef unsigned long DWORD;
#endif /* __IBMCPP__ */
#ifndef MAX
#define MAX( a, b ) (( ( a ) > ( b ) ) ? ( a ) : ( b ) )
#define MAX( a, b ) ( ( ( a ) > ( b ) ) ? ( a ) : ( b ) )
#endif
#ifndef MIN
#define MIN( a, b ) (( ( a ) < ( b ) ) ? ( a ) : ( b ) )
#define MIN( a, b ) ( ( ( a ) < ( b ) ) ? ( a ) : ( b ) )
#endif
#ifdef __GNUC__

50
harbour/include/hbpp.h
View File

@@ -11,51 +11,51 @@
#include "hbdefs.h"
typedef struct _PATHNAMES { /* the list of pathnames to search with #include */
char *szPath;
char * szPath;
struct _PATHNAMES *pNext;
} PATHNAMES;
struct _DEFINES;
typedef struct _DEFINES
{
char *name;
char *pars;
char * name;
char * pars;
int npars;
char *value;
struct _DEFINES *last;
char * value;
struct _DEFINES * last;
} DEFINES;
struct _COMMANDS;
typedef struct _COMMANDS
{
int com_or_xcom;
char *name;
char *mpatt;
char *value;
struct _COMMANDS *last;
char * name;
char * mpatt;
char * value;
struct _COMMANDS * last;
} COMMANDS;
#define STR_SIZE 8192
#define BUFF_SIZE 2048
#define SKIPTABSPACES( sptr ) while ( *sptr == ' ' || *sptr == '\t' ) ( sptr )++
#define SKIPTABSPACES( sptr ) while( *sptr == ' ' || *sptr == '\t' ) ( sptr )++
#define IS_OPT_SEP( c ) ( strchr( OS_OPT_DELIMITER_LIST, ( c ) ) != NULL )
/* HBPP.C exported functions */
extern int ParseDirective( char* );
extern int ParseExpression( char*, char* );
extern int pp_RdStr(FILE*,char *,int,int,char*,int*,int*);
extern int pp_WrStr(FILE*,char *);
extern int strolen ( char* );
extern int strocpy (char*, char* );
extern char* strodup ( char * );
extern DEFINES *AddDefine( char * szDefine, char * szValue ); /* add a new Lex define from the command line */
extern int ParseDirective( char * );
extern int ParseExpression( char *, char * );
extern int pp_RdStr( FILE *, char *, int, int, char *, int *, int * );
extern int pp_WrStr( FILE *, char * );
extern int strolen( char * );
extern int strocpy( char *, char * );
extern char * strodup( char * );
extern DEFINES * AddDefine( char * szDefine, char * szValue ); /* add a new Lex define from the command line */
/* HBPP.C exported variables */
extern int lInclude;
extern int *aCondCompile, nCondCompile;
extern int * aCondCompile, nCondCompile;
extern int nline;
extern char * _szPErrors[];
@@ -72,8 +72,8 @@ typedef struct
char * szExtension;
} HB_FNAME, * PHB_FNAME, * HB_FNAME_PTR;
extern PHB_FNAME hb_fsFNameSplit ( char * szFilename ); /* Split given filename into path, name and extension */
extern char * hb_fsFNameMerge ( char * szFileName, PHB_FNAME pFileName ); /* This function joins path, name and extension into a string with a filename */
extern PHB_FNAME hb_fsFNameSplit( char * szFilename ); /* Split given filename into path, name and extension */
extern char * hb_fsFNameMerge( char * szFileName, PHB_FNAME pFileName ); /* This function joins path, name and extension into a string with a filename */
extern void * hb_xgrab( ULONG lSize ); /* allocates memory, exists on failure */
extern void * hb_xrealloc( void * pMem, ULONG lSize ); /* reallocates memory */
@@ -81,10 +81,10 @@ extern void hb_xfree( void * pMem ); /* frees memory */
/* Needed support variables, but not contained in HBPP.C */
extern PATHNAMES *_pIncludePath;
extern PATHNAMES * _pIncludePath;
extern PHB_FNAME _pFileName;
extern DEFINES *topDefine;
extern COMMANDS *topCommand;
extern COMMANDS *topTranslate;
extern DEFINES * topDefine;
extern COMMANDS * topCommand;
extern COMMANDS * topTranslate;
#endif /* HB_PP_H_ */

8
harbour/include/vm.api
View File

@@ -25,7 +25,7 @@ typedef void * HANDLE;
#define _xvunwire( h ) /* dummy */
/* State */
#define _xvlockcount( h ) (0)
#define _xvlockcount( h ) ( 0 )
#define _xvsize( h ) hb_xsize( h )
/* -------------------------------------------------------- */
@@ -34,12 +34,12 @@ typedef void * HANDLE;
/* -------------------------------------------------------- */
/* Heap */
#define _xvheapnew( size ) (0)
#define _xvheapnew( size ) ( 0 )
#define _xvheapdestroy( h ) /* dummy */
#define _xvheapresize( h, size ) /* dummy */
#define _xvheapalloc( h, size ) (0)
#define _xvheapalloc( h, size ) ( 0 )
#define _xvheapfree( h, offset ) /* dummy */
#define _xvheaplock( h, offset ) (0)
#define _xvheaplock( h, offset ) ( 0 )
#define _xvheapunlock( h, offset ) /* dummy */
#endif /* HB_VM_API_ */

45
harbour/source/rtl/arrays.c
View File

@@ -33,11 +33,40 @@
* Internal
*/
BOOL hb_arrayError( PHB_ITEM pArray, ULONG ulIndex, BOOL bAssign )
{
BOOL bRetVal;
if( IS_ARRAY( pArray ) )
{
if( ulIndex > 0 && ulIndex <= pArray->item.asArray.value->ulLen )
bRetVal = FALSE;
else
{
bRetVal = TRUE;
if( bAssign )
hb_errRT_BASE( EG_BOUND, 1133, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ) );
else
hb_errRT_BASE( EG_BOUND, 1132, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ) );
}
}
else
{
bRetVal = TRUE;
if( bAssign )
hb_errRT_BASE( EG_ARG, 1069, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ) );
else
hb_errRT_BASE( EG_ARG, 1068, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ) );
}
return bRetVal;
}
char * hb_arrayGetDate( PHB_ITEM pArray, ULONG ulIndex, char * szDate )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
{
PHB_ITEM pItem = pArray->item.asArray.value->pItems + ulIndex - 1;
@@ -64,7 +93,7 @@ BOOL hb_arrayGetBool( PHB_ITEM pArray, ULONG ulIndex )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
{
PHB_ITEM pItem = pArray->item.asArray.value->pItems + ulIndex - 1;
@@ -93,7 +122,7 @@ double hb_arrayGetDouble( PHB_ITEM pArray, ULONG ulIndex )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
{
PHB_ITEM pItem = pArray->item.asArray.value->pItems + ulIndex - 1;
@@ -162,7 +191,7 @@ void hb_arrayGet( PHB_ITEM pArray, ULONG ulIndex, PHB_ITEM pItem )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
hb_itemCopy( pItem, pArray->item.asArray.value->pItems + ( ulIndex - 1 ) );
else
hb_errRT_BASE( EG_BOUND, 1132, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ) );
@@ -175,7 +204,7 @@ char * hb_arrayGetString( PHB_ITEM pArray, ULONG ulIndex )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
{
PHB_ITEM pItem = pArray->item.asArray.value->pItems + ulIndex - 1;
@@ -195,7 +224,7 @@ ULONG hb_arrayGetStringLen( PHB_ITEM pArray, ULONG ulIndex )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
{
PHB_ITEM pItem = pArray->item.asArray.value->pItems + ulIndex - 1;
@@ -215,7 +244,7 @@ int hb_arrayGetType( PHB_ITEM pArray, ULONG ulIndex )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
{
PHB_ITEM pItem = pArray->item.asArray.value->pItems + ulIndex - 1;
return pItem->type;
@@ -252,7 +281,7 @@ void hb_arraySet( PHB_ITEM pArray, ULONG ulIndex, PHB_ITEM pItem )
{
if( IS_ARRAY( pArray ) )
{
if( ulIndex <= hb_arrayLen( pArray ) )
if( ulIndex > 0 && ulIndex <= hb_arrayLen( pArray ) )
hb_itemCopy( pArray->item.asArray.value->pItems + ( ulIndex - 1 ), pItem );
else
hb_errRT_BASE( EG_BOUND, 1133, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ) );

3
harbour/source/rtl/devoutp.prg
View File

@@ -76,6 +76,5 @@
*/
FUNCTION DEVOUTPICT( xValue, cPicture, cColor )
LOCAL cText := TRANSFORM( xValue, cPicture )
DEVOUT( cText, cColor )
DEVOUT( TRANSFORM( xValue, cPicture ), cColor )
RETURN NIL

57
harbour/source/rtl/errorapi.c
View File

@@ -30,9 +30,11 @@
hb_errGetFlags()
hb_errPutFlags()
hb_errRT_New()
hb_errRT_New_Subst()
HB___ERRRT_BASE()
hb_errRT_BASE()
hb_errRT_BASE_Ext1()
hb_errRT_BASE_Subst()
hb_errInternal()
See doc/hdr_tpl.txt, Version 1.2 or later, for licensing terms.
*/
@@ -47,9 +49,10 @@
go into an infinite loop, this is an emulated version of the Clipper
"Unrecoverable error 650: Processor stack fault" internal error, but
better shows what is really the problem */
#define ERROR_LAUNCH_MAX 8
#define HB_ERROR_LAUNCH_MAX 8
static int s_iLaunchCount = 0;
static int s_iLaunchCount = 0;
static HB_ITEM s_errorBlock;
extern HARBOUR HB_ERRORNEW( void );
@@ -60,6 +63,31 @@ void hb_errForceLink()
HB_ERRORNEW();
}
HARBOUR HB_ERRORBLOCK( void )
{
HB_ITEM oldError;
PHB_ITEM pNewErrorBlock = hb_param( 1, IT_BLOCK );
hb_itemClear( &oldError );
hb_itemCopy( &oldError, &s_errorBlock );
if( pNewErrorBlock )
hb_itemCopy( &s_errorBlock, pNewErrorBlock );
hb_itemReturn( &oldError );
hb_itemClear( &oldError );
}
void hb_errInit( void )
{
hb_itemClear( &s_errorBlock );
}
void hb_errExit( void )
{
hb_itemClear( &s_errorBlock );
}
PHB_ITEM hb_errNew( void )
{
PHB_ITEM pReturn = hb_itemNew( NULL );
@@ -86,12 +114,12 @@ WORD hb_errLaunch( PHB_ITEM pError )
/* Check if we have a valid error handler */
if( ! IS_BLOCK( &errorBlock ) )
if( ! IS_BLOCK( &s_errorBlock ) )
hb_errInternal( 9999, "No ERRORBLOCK() for error", NULL, NULL );
/* Check if the error launcher was called too many times recursively */
if( s_iLaunchCount == ERROR_LAUNCH_MAX )
if( s_iLaunchCount == HB_ERROR_LAUNCH_MAX )
hb_errInternal( 9999, "Too many recursive error handler calls", NULL, NULL );
s_iLaunchCount++;
@@ -101,7 +129,7 @@ WORD hb_errLaunch( PHB_ITEM pError )
pBlock = hb_itemNew( NULL );
pObject = hb_itemNew( NULL );
hb_itemCopy( pBlock, &errorBlock );
hb_itemCopy( pBlock, &s_errorBlock );
hb_itemCopy( pObject, pError );
hb_evalNew( &eval, pBlock );
@@ -178,12 +206,12 @@ PHB_ITEM hb_errLaunchSubst( PHB_ITEM pError )
/* Check if we have a valid error handler */
if( ! IS_BLOCK( &errorBlock ) )
if( ! IS_BLOCK( &s_errorBlock ) )
hb_errInternal( 9999, "No ERRORBLOCK() for error", NULL, NULL );
/* Check if the error launcher was called too many times recursively */
if( s_iLaunchCount == ERROR_LAUNCH_MAX )
if( s_iLaunchCount == HB_ERROR_LAUNCH_MAX )
hb_errInternal( 9999, "Too many recursive ERRORBLOCK() calls", NULL, NULL );
s_iLaunchCount++;
@@ -193,7 +221,7 @@ PHB_ITEM hb_errLaunchSubst( PHB_ITEM pError )
pBlock = hb_itemNew( NULL );
pObject = hb_itemNew( NULL );
hb_itemCopy( pBlock, &errorBlock );
hb_itemCopy( pBlock, &s_errorBlock );
hb_itemCopy( pObject, pError );
hb_evalNew( &eval, pBlock );
@@ -252,7 +280,6 @@ PHB_ITEM hb_errPutDescription( PHB_ITEM pError, char * szDescription )
hb_vmPush( pError );
hb_vmPushString( szDescription, strlen( szDescription ) );
hb_vmDo( 1 );
return pError;
}
@@ -456,8 +483,7 @@ PHB_ITEM hb_errPutFlags( PHB_ITEM pError, USHORT uiFlags )
/* Wrappers for hb_errLaunch() */
static WORD hb_errRT_New
(
static WORD hb_errRT_New(
USHORT uiSeverity,
char * szSubSystem,
ULONG ulGenCode,
@@ -465,8 +491,7 @@ static WORD hb_errRT_New
char * szDescription,
char * szOperation,
USHORT uiOsCode,
USHORT uiFlags
)
USHORT uiFlags )
{
PHB_ITEM pError = hb_errNew();
WORD wRetVal;
@@ -487,8 +512,7 @@ static WORD hb_errRT_New
return wRetVal;
}
static PHB_ITEM hb_errRT_New_Subst
(
static PHB_ITEM hb_errRT_New_Subst(
USHORT uiSeverity,
char * szSubSystem,
ULONG ulGenCode,
@@ -496,8 +520,7 @@ static PHB_ITEM hb_errRT_New_Subst
char * szDescription,
char * szOperation,
USHORT uiOsCode,
USHORT uiFlags
)
USHORT uiFlags )
{
PHB_ITEM pError = hb_errNew();
PHB_ITEM pRetVal;

16
harbour/source/rtl/errorsys.prg
View File

@@ -41,6 +41,14 @@ return
//----------------------------------------------------------------------------//
procedure ErrorSys
ErrorBlock( { | oError | DefError( oError ) } )
return
//----------------------------------------------------------------------------//
static function DefError( oError )
LOCAL cMessage
@@ -111,14 +119,6 @@ static function DefError( oError )
RETURN .F.
//----------------------------------------------------------------------------//
procedure ErrorSys
ErrorBlock( { | oError | DefError( oError ) } )
return
// [vszel]
STATIC FUNCTION ErrorMessage(oError)

48
harbour/source/rtl/gtapi.c
View File

@@ -132,14 +132,16 @@ int hb_gtBox( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight, char
if( uiTop > uiMRow || uiBottom > uiMRow ||
uiLeft > uiMCol || uiRight > uiMCol )
{
return 1;
return 1;
}
/* For full compatibility, pad box string with last char if too short */
cPadChar = ' ';
for( tmp = 0; *pbyFrame && tmp < 9; tmp++ ) cPadChar = pszBox[ tmp ] = *pbyFrame++;
while( tmp < 8 ) pszBox[ tmp++ ] = cPadChar;
for( tmp = 0; *pbyFrame && tmp < 9; tmp++ )
cPadChar = pszBox[ tmp ] = *pbyFrame++;
while( tmp < 8 )
pszBox[ tmp++ ] = cPadChar;
pszBox[ tmp ] = '\0';
/* Ensure that box is drawn from top left to bottom right. */
@@ -178,27 +180,27 @@ int hb_gtBox( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight, char
{
hb_gtRepChar( uiRow, uiCol, pszBox[ 1 ], uiRight - uiLeft + ( height > 1 ? -1 : 1 ) );
if( height > 1 )
hb_gtRepChar( uiBottom, uiCol, pszBox[ 5 ], uiRight - uiLeft + ( height > 1 ? -1 : 1 ) );
hb_gtRepChar( uiBottom, uiCol, pszBox[ 5 ], uiRight - uiLeft + ( height > 1 ? -1 : 1 ) );
}
if( pszBox[ 8 ] && height > 2 && width > 2 )
{
for( uiRow = uiTop + 1; uiRow < uiBottom; uiRow++ )
{
uiCol = uiLeft;
hb_gtWriteAt( uiRow, uiCol++, pszBox + 7, sizeof( BYTE ) );
hb_gtRepChar( uiRow, uiCol , pszBox[ 8 ], uiRight - uiLeft - 1 );
hb_gtWriteAt( uiRow, uiRight, pszBox + 3, sizeof( BYTE ) );
}
for( uiRow = uiTop + 1; uiRow < uiBottom; uiRow++ )
{
uiCol = uiLeft;
hb_gtWriteAt( uiRow, uiCol++, pszBox + 7, sizeof( BYTE ) );
hb_gtRepChar( uiRow, uiCol , pszBox[ 8 ], uiRight - uiLeft - 1 );
hb_gtWriteAt( uiRow, uiRight, pszBox + 3, sizeof( BYTE ) );
}
}
else
{
for( uiRow = ( width > 1 ? uiTop + 1 : uiTop ); uiRow < ( width > 1 ? uiBottom : uiBottom + 1 ); uiRow++ )
{
hb_gtWriteAt( uiRow, uiLeft, pszBox + 7, sizeof( BYTE ) );
if( width > 1 )
hb_gtWriteAt( uiRow, uiRight, pszBox + 3, sizeof( BYTE ) );
}
for( uiRow = ( width > 1 ? uiTop + 1 : uiTop ); uiRow < ( width > 1 ? uiBottom : uiBottom + 1 ); uiRow++ )
{
hb_gtWriteAt( uiRow, uiLeft, pszBox + 7, sizeof( BYTE ) );
if( width > 1 )
hb_gtWriteAt( uiRow, uiRight, pszBox + 3, sizeof( BYTE ) );
}
}
/* speed issue for now */
@@ -222,9 +224,9 @@ int hb_gtBoxS( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight )
int hb_gtColorSelect(USHORT uiColorIndex)
{
if( uiColorIndex > s_ColorCount )
return 1;
return 1;
else
s_uiColorIndex = uiColorIndex;
s_uiColorIndex = uiColorIndex;
return 0;
}
@@ -533,7 +535,7 @@ int hb_gtGetCursor( USHORT * uipCursorShape )
if( i <= SC_SPECIAL2 )
{
* uipCursorShape = i;
*uipCursorShape = i;
}
else
{
@@ -594,15 +596,15 @@ int hb_gtRectSize( USHORT uiTop, USHORT uiLeft, USHORT uiBottom, USHORT uiRight,
USHORT uiMCol = s_uiMaxCol;
if( uiBottom > uiMRow )
uiBottom = uiMRow;
uiBottom = uiMRow;
if( uiRight > uiMCol )
uiRight = uiMCol;
uiRight = uiMCol;
if( uiTop > uiMRow || uiBottom > uiMRow ||
uiLeft > uiMCol || uiRight > uiMCol ||
uiTop > uiBottom || uiLeft > uiRight )
{
return 1;
return 1;
}
*uipBuffSize = ( uiBottom - uiTop + 1 ) * ( uiRight - uiLeft + 1 ) * 2;

69
harbour/source/rtl/set.c
View File

@@ -187,22 +187,19 @@ static BOOL set_logical( PHB_ITEM pItem )
{
BOOL logical = FALSE;
if( IS_LOGICAL( pItem ) ) logical = pItem->item.asLogical.value;
if( IS_LOGICAL( pItem ) )
logical = pItem->item.asLogical.value;
else if( IS_STRING( pItem ) )
{
if( pItem->item.asString.length >= 2 )
{
if( toupper( pItem->item.asString.value[ 0 ] ) == 'O'
&& toupper( pItem->item.asString.value[ 1 ] ) == 'N' )
logical = TRUE;
}
else if( pItem->item.asString.length >= 3 )
{
if( toupper( pItem->item.asString.value[ 0 ] ) == 'O'
&& toupper( pItem->item.asString.value[ 1 ] ) == 'F'
&& toupper( pItem->item.asString.value[ 2 ] ) == 'F' )
logical = FALSE;
}
if( pItem->item.asString.length >= 2
&& toupper( pItem->item.asString.value[ 0 ] ) == 'O'
&& toupper( pItem->item.asString.value[ 1 ] ) == 'N' )
logical = TRUE;
else if( pItem->item.asString.length >= 3
&& toupper( pItem->item.asString.value[ 0 ] ) == 'O'
&& toupper( pItem->item.asString.value[ 1 ] ) == 'F'
&& toupper( pItem->item.asString.value[ 2 ] ) == 'F' )
logical = FALSE;
}
return logical;
@@ -337,40 +334,39 @@ static int open_handle( char * file_name, BOOL bMode, char * def_ext, HB_set_enu
*/
HARBOUR HB___SETCENTURY( void )
{
int count, digit, size, y_size, y_start, y_stop;
int old_century_setting = hb_set_century;
PHB_ITEM pItem = hb_param( 1, IT_ANY );
char * szDateFormat, * szNewFormat;
/* Start by returning the current setting */
hb_retl( hb_set_century );
/*
* Then change the setting if the parameter is a logical value, or is
* Change the setting if the parameter is a logical value, or is
* either "ON" or "OFF" (regardless of case)
*/
if( pItem && IS_LOGICAL( pItem ) ) hb_set_century = pItem->item.asLogical.value;
else if( pItem && IS_STRING( pItem ) )
if( ISLOG( 1 ) )
hb_set_century = hb_parl( 1 );
else if( ISCHAR( 1 ) )
{
if( pItem->item.asString.length >= 2 )
{
if( toupper( pItem->item.asString.value[ 0 ] ) == 'O'
&& toupper( pItem->item.asString.value[ 1 ] ) == 'N' )
hb_set_century = TRUE;
}
else if( pItem->item.asString.length >= 3 )
{
if( toupper ( pItem->item.asString.value[ 0 ] ) == 'O'
&& toupper ( pItem->item.asString.value[ 1 ] ) == 'F'
&& toupper ( pItem->item.asString.value[ 2 ] ) == 'F' )
hb_set_century = FALSE;
}
char * szString = hb_parc( 1 );
ULONG ulLen = hb_parclen( 1 );
if( ulLen >= 2
&& toupper( szString[ 0 ] ) == 'O'
&& toupper( szString[ 1 ] ) == 'N' )
hb_set_century = TRUE;
else if( ulLen >= 3
&& toupper( szString[ 0 ] ) == 'O'
&& toupper( szString[ 1 ] ) == 'F'
&& toupper( szString[ 2 ] ) == 'F' )
hb_set_century = FALSE;
}
/*
* Finally, if the setting changed, adjust the current date format to use
* the correct number of year digits.
*/
if( old_century_setting != hb_set_century )
{
int count, digit, size, y_size, y_start, y_stop;
char * szDateFormat, * szNewFormat;
/* Convert to upper case and determine where year is */
y_start = y_stop = -1;
szDateFormat = hb_set.HB_SET_DATEFORMAT;
@@ -412,6 +408,9 @@ HARBOUR HB___SETCENTURY( void )
hb_set.HB_SET_DATEFORMAT = szNewFormat;
}
}
/* Return the previous setting */
hb_retl( old_century_setting );
}
/* $DOC$

15
harbour/source/rtl/transfrm.c
View File

@@ -56,7 +56,9 @@
#define PF_LEFT 0x0001 /* @B */
#define PF_CREDIT 0x0002 /* @C */
#define PF_DEBIT 0x0004 /* @X */
#ifndef HARBOUR_STRICT_CLIPPER_COMPATIBILITY
#define PF_ZERO 0x0008 /* @0 */
#endif
#define PF_PARNEG 0x0010 /* @( */
#define PF_REMAIN 0x0020 /* @R */
#define PF_UPPER 0x0040 /* @! */
@@ -114,9 +116,11 @@ static WORD PictFunc( char **szPict, ULONG *pulPicLen )
case '(':
wPicFlags |= PF_PARNEG;
break;
#ifndef HARBOUR_STRICT_CLIPPER_COMPATIBILITY
case '0':
wPicFlags |= PF_ZERO;
break;
#endif
case 'B':
wPicFlags |= PF_LEFT;
break;
@@ -228,18 +232,23 @@ static char * NumPicture( char *szPic, ULONG ulPic, WORD wPicFlags, double dValu
szStr = pItem->item.asString.value;
iCount = 0;
if( wPicFlags & PF_ZERO ) /* Pad with Zero's */
#ifndef HARBOUR_STRICT_CLIPPER_COMPATIBILITY
/* Pad with Zero's */
if( wPicFlags & PF_ZERO )
{
for( i = 0; szStr[ i ] == ' ' && i < iWidth; i++ )
szStr[ i ] = '0';
}
#endif
/* Suppress empty value */
if( bEmpty && pItem->item.asString.length )
/* Suppress empty value */
{
szStr[ pItem->item.asString.length - 1 ] = ' ';
}
if( wPicFlags & PF_LEFT ) /* Left align */
/* Left align */
if( wPicFlags & PF_LEFT )
{
for( i = 0; szStr[ i ] == ' ' && i <= iWidth; i++ );
/* Find first non-space */

58
harbour/source/runner/runlib.c
View File

@@ -46,7 +46,7 @@ static BYTE prgFunction[] = { 0x68, 0x00, 0x00, 0x00, 0x00,
add esp, 8
ret near */
/* This is the assembler output from : hb_vmExecute(pcode,symbols). */
/* This is the assembler output from : hb_vmExecute( pcode, symbols ). */
/* #elseif INTEL16 */
/* #elseif MOTOROLA */
@@ -114,9 +114,9 @@ HARBOUR HB___HRBRUN( void )
/* Open as binary */
while ((file = hb_hrbFileOpen( szFileName )) == NULL)
while ( ( file = hb_hrbFileOpen( szFileName ) ) == NULL )
{
if ( hb_errRT_BASE_Ext1( EG_OPEN, 9999, NULL, szFileName, 0, EF_CANDEFAULT | EF_CANRETRY ) == E_DEFAULT )
if( hb_errRT_BASE_Ext1( EG_OPEN, 9999, NULL, szFileName, 0, EF_CANDEFAULT | EF_CANRETRY ) == E_DEFAULT )
{
break;
}
@@ -140,17 +140,17 @@ HARBOUR HB___HRBRUN( void )
ulSymbols = hb_hrbFileReadLong( file, szFileName );
pSymRead = ( PHB_SYMB )hb_xgrab( ulSymbols * sizeof( HB_SYMB ) );
for( ul=0; ul < ulSymbols; ul++) /* Read symbols in .HRB */
for( ul = 0; ul < ulSymbols; ul++ ) /* Read symbols in .HRB */
{
pSymRead[ ul ].szName = hb_hrbFileReadId( file, szFileName );
pSymRead[ ul ].cScope = hb_hrbFileReadByte( file, szFileName );
pSymRead[ ul ].pFunPtr = ( PHB_FUNC ) (ULONG) hb_hrbFileReadByte( file, szFileName );
pSymRead[ ul ].pFunPtr = ( PHB_FUNC ) ( ULONG ) hb_hrbFileReadByte( file, szFileName );
pSymRead[ ul ].pDynSym = NULL;
}
ulFuncs = hb_hrbFileReadLong( file, szFileName ); /* Read number of functions */
pDynFunc = ( PHB_DYNF ) hb_xgrab( ulFuncs * sizeof( HB_DYNF ) );
for( ul=0; ul < ulFuncs; ul++) /* Read symbols in .HRB */
for( ul = 0; ul < ulFuncs; ul++ ) /* Read symbols in .HRB */
{
pDynFunc[ ul ].szName = hb_hrbFileReadId( file, szFileName );
@@ -168,7 +168,7 @@ HARBOUR HB___HRBRUN( void )
s_ulSymEntry = 0;
for( ul = 0; ul < ulSymbols; ul++ ) /* Linker */
{
if( ( (ULONG) pSymRead[ ul ].pFunPtr ) == SYM_FUNC )
if( ( ( ULONG ) pSymRead[ ul ].pFunPtr ) == SYM_FUNC )
{
ulPos = hb_hrbFindSymbol( pSymRead[ ul ].szName, pDynFunc, ulFuncs );
if( ulPos != SYM_NOT_FOUND )
@@ -185,7 +185,7 @@ HARBOUR HB___HRBRUN( void )
else
pSymRead[ ul ].pFunPtr = ( PHB_FUNC ) SYM_EXTERN;
}
if( ( (ULONG) pSymRead[ ul ].pFunPtr ) == SYM_EXTERN )
if( ( ( ULONG ) pSymRead[ ul ].pFunPtr ) == SYM_EXTERN )
{ /* External function */
pDynSym = hb_dynsymFind( pSymRead[ ul ].szName );
if( !pDynSym )
@@ -218,7 +218,7 @@ HARBOUR HB___HRBRUN( void )
{
hb_vmPushSymbol( pSymRead + ul );
hb_vmPushNil();
for( i = 0; i < (hb_pcount() - 1); i++ )
for( i = 0; i < ( hb_pcount() - 1 ); i++ )
hb_vmPush( hb_param( i + 2, IT_ANY ) );
/* Push other cmdline params*/
hb_vmDo( hb_pcount() - 1 ); /* Run init function */
@@ -227,7 +227,7 @@ HARBOUR HB___HRBRUN( void )
hb_vmPushSymbol( pSymRead );
hb_vmPushNil();
for( i = 0; i < (hb_pcount() - 1); i++ )
for( i = 0; i < ( hb_pcount() - 1 ); i++ )
hb_vmPush( hb_param( i + 2, IT_ANY ) ); /* Push other cmdline params*/
hb_vmDo( hb_pcount() - 1 ); /* Run the thing !!! */
@@ -318,7 +318,7 @@ static char * hb_hrbFileReadId( FILE *file, char * szFileName )
bCont = FALSE;
} while( bCont );
szRet = (char *) hb_xgrab( szIdx - szTemp + 1 );
szRet = ( char * ) hb_xgrab( szIdx - szTemp + 1 );
strcpy( szRet, szTemp );
hb_xfree( szTemp );
@@ -330,7 +330,7 @@ static BYTE hb_hrbFileReadByte( FILE *file, char * szFileName )
{
BYTE bRet;
hb_hrbFileRead( file, szFileName, &bRet, 1, 1);
hb_hrbFileRead( file, szFileName, &bRet, 1, 1 );
return bRet;
}
@@ -338,20 +338,20 @@ static BYTE hb_hrbFileReadByte( FILE *file, char * szFileName )
static long hb_hrbFileReadLong( FILE *file, char * szFileName )
{
char cLong[4]; /* Temporary long */
char cLong[ 4 ]; /* Temporary long */
hb_hrbFileRead( file, szFileName, cLong, 4, 1 );
if( cLong[3] ) /* Convert to long if ok */
if( cLong[ 3 ] ) /* Convert to long if ok */
{
hb_errRT_BASE_Ext1( EG_READ, 9999, NULL, szFileName, 0, EF_NONE );
return 0;
}
else
return ( (BYTE) cLong[0] ) +
( (BYTE) cLong[1] ) * 0x100 +
( (BYTE) cLong[2] ) * 0x10000 +
( (BYTE) cLong[3] ) * 0x1000000 ;
return ( ( BYTE ) cLong[ 0 ] ) +
( ( BYTE ) cLong[ 1 ] ) * 0x100 +
( ( BYTE ) cLong[ 2 ] ) * 0x10000 +
( ( BYTE ) cLong[ 3 ] ) * 0x1000000 ;
}
@@ -359,7 +359,7 @@ static long hb_hrbFileReadLong( FILE *file, char * szFileName )
Controlled read from file. If errornous -> Break */
static void hb_hrbFileRead( FILE *file, char * szFileName, char *cBuffer, int iSize, int iCount )
{
if( iCount != (int) fread( cBuffer, iSize, iCount, file ) )
if( iCount != ( int ) fread( cBuffer, iSize, iCount, file ) )
{ /* Read error */
hb_errRT_BASE_Ext1( EG_READ, 9999, NULL, szFileName, 0, EF_NONE );
}
@@ -399,15 +399,15 @@ static void hb_hrbFileClose( FILE *file )
*/
static PASM_CALL hb_hrbAsmCreateFun( PHB_SYMB pSymbols, BYTE * pCode )
{
PASM_CALL asmRet = (PASM_CALL) hb_xgrab( sizeof( ASM_CALL ) );
PASM_CALL asmRet = ( PASM_CALL ) hb_xgrab( sizeof( ASM_CALL ) );
asmRet->pAsmData = (BYTE * ) hb_xgrab( sizeof( prgFunction ) );
asmRet->pAsmData = ( BYTE * ) hb_xgrab( sizeof( prgFunction ) );
memcpy( asmRet->pAsmData, prgFunction, sizeof( prgFunction ) );
/* Copy new assembler code in */
/* #if INTEL32 */
hb_hrbAsmPatch( asmRet->pAsmData, 1, pSymbols ); /* Insert pointer to testsym */
hb_hrbAsmPatch( asmRet->pAsmData, 6, pCode); /* Insert pointer to testcode */
hb_hrbAsmPatch( asmRet->pAsmData, 1, pSymbols ); /* Insert pointer to testsym */
hb_hrbAsmPatch( asmRet->pAsmData, 6, pCode ); /* Insert pointer to testcode */
hb_hrbAsmPatchRelative( asmRet->pAsmData, 11, &hb_vmExecute, 15 );
/* Insert pointer to hb_vmExecute() */
@@ -423,10 +423,10 @@ static void hb_hrbAsmPatch( BYTE * pCode, ULONG ulOffset, void *Address )
{
/* #if 32 bits and low byte first */
pCode[ ulOffset ] = ( (ULONG) Address ) & 0xFF;
pCode[ ulOffset + 1 ] = ( (ULONG) Address >> 8 ) & 0xFF;
pCode[ ulOffset + 2 ] = ( (ULONG) Address >> 16 ) & 0xFF;
pCode[ ulOffset + 3 ] = ( (ULONG) Address >> 24 ) & 0xFF;
pCode[ ulOffset ] = ( ( ULONG ) Address ) & 0xFF;
pCode[ ulOffset + 1 ] = ( ( ULONG ) Address >> 8 ) & 0xFF;
pCode[ ulOffset + 2 ] = ( ( ULONG ) Address >> 16 ) & 0xFF;
pCode[ ulOffset + 3 ] = ( ( ULONG ) Address >> 24 ) & 0xFF;
/* #elseif 16 bits and low byte first */
/* #elseif 32 bits and high byte first */
@@ -440,9 +440,9 @@ static void hb_hrbAsmPatchRelative( BYTE * pCode, ULONG ulOffset,
void * Address, ULONG ulNext )
{
/* #if 32 bits and low byte first */
ULONG ulBase = (ULONG) pCode + ulNext;
ULONG ulBase = ( ULONG ) pCode + ulNext;
/* Relative to next instruction */
ULONG ulRelative = (ULONG) Address - ulBase;
ULONG ulRelative = ( ULONG ) Address - ulBase;
pCode[ ulOffset ] = ( ulRelative ) & 0xFF;
pCode[ ulOffset + 1 ] = ( ulRelative >> 8 ) & 0xFF;

76
harbour/source/vm/dynsym.c
View File

@@ -28,16 +28,16 @@
#include "extend.h"
#define SYM_ALLOCATED ((SYMBOLSCOPE)-1)
#define SYM_ALLOCATED ( ( SYMBOLSCOPE ) -1 )
typedef struct
{
PHB_DYNS pDynSym; /* Pointer to dynamic symbol */
} DYNHB_ITEM, * PDYNHB_ITEM, * DYNHB_ITEM_PTR;
static PDYNHB_ITEM pDynItems = NULL; /* Pointer to dynamic items */
static WORD wDynSymbols = 0; /* Number of symbols present */
static WORD wClosestDynSym = 0;
static PDYNHB_ITEM s_pDynItems = NULL; /* Pointer to dynamic items */
static WORD s_wDynSymbols = 0; /* Number of symbols present */
static WORD s_wClosestDynSym = 0;
/* Closest symbol for match. hb_dynsymFind() will search for the name. */
/* If it cannot find the name, it positions itself to the */
/* closest symbol. */
@@ -46,8 +46,8 @@ void hb_dynsymLog( void )
{
WORD w;
for( w = 0; w < wDynSymbols; w++ ) /* For all dynamic symbols */
printf( "%i %s\n", w + 1, pDynItems[ w ].pDynSym->pSymbol->szName );
for( w = 0; w < s_wDynSymbols; w++ ) /* For all dynamic symbols */
printf( "%i %s\n", w + 1, s_pDynItems[ w ].pDynSym->pSymbol->szName );
}
PHB_SYMB hb_symbolNew( char * szName ) /* Create a new symbol */
@@ -78,26 +78,26 @@ PHB_DYNS hb_dynsymNew( PHB_SYMB pSymbol ) /* creates a new dynamic symbol */
return pDynSym; /* Return pointer to DynSym */
}
if( wDynSymbols == 0 ) /* Do we have any symbols ? */
pDynSym = pDynItems[ 0 ].pDynSym; /* Point to first symbol */
if( s_wDynSymbols == 0 ) /* Do we have any symbols ? */
pDynSym = s_pDynItems[ 0 ].pDynSym; /* Point to first symbol */
/* *<1>* Remember we already got this one */
else
{ /* We want more symbols ! */
pDynItems = ( PDYNHB_ITEM ) hb_xrealloc( pDynItems, ( wDynSymbols + 1 ) * sizeof( DYNHB_ITEM ) );
s_pDynItems = ( PDYNHB_ITEM ) hb_xrealloc( s_pDynItems, ( s_wDynSymbols + 1 ) * sizeof( DYNHB_ITEM ) );
if( wClosestDynSym <= wDynSymbols ) /* Closest < current !! */
if( s_wClosestDynSym <= s_wDynSymbols ) /* Closest < current !! */
{ /* Here it goes :-) */
WORD w;
for( w = 0; w < ( wDynSymbols - wClosestDynSym ); w++ )
memcpy( &pDynItems[ wDynSymbols - w ],
&pDynItems[ wDynSymbols - w - 1 ], sizeof( DYNHB_ITEM ) );
for( w = 0; w < ( s_wDynSymbols - s_wClosestDynSym ); w++ )
memcpy( &s_pDynItems[ s_wDynSymbols - w ],
&s_pDynItems[ s_wDynSymbols - w - 1 ], sizeof( DYNHB_ITEM ) );
} /* Insert element in array */
pDynSym = ( PHB_DYNS ) hb_xgrab( sizeof( HB_DYNS ) );
pDynItems[ wClosestDynSym ].pDynSym = pDynSym; /* Enter DynSym */
s_pDynItems[ s_wClosestDynSym ].pDynSym = pDynSym; /* Enter DynSym */
}
wDynSymbols++; /* Got one more symbol */
s_wDynSymbols++; /* Got one more symbol */
pDynSym->pSymbol = pSymbol;
pDynSym->hMemvar = 0;
pDynSym->hArea = 0;
@@ -134,21 +134,21 @@ PHB_DYNS hb_dynsymGet( char * szName ) /* finds and creates a symbol if not fou
PHB_DYNS hb_dynsymFind( char * szName )
{
if( ! pDynItems )
if( s_pDynItems == NULL )
{
pDynItems = ( PDYNHB_ITEM ) hb_xgrab( sizeof( DYNHB_ITEM ) ); /* Grab array */
pDynItems->pDynSym = ( PHB_DYNS ) hb_xgrab( sizeof( HB_DYNS ) );
s_pDynItems = ( PDYNHB_ITEM ) hb_xgrab( sizeof( DYNHB_ITEM ) ); /* Grab array */
s_pDynItems->pDynSym = ( PHB_DYNS ) hb_xgrab( sizeof( HB_DYNS ) );
/* Always grab a first symbol. Never an empty bucket. *<1>* */
pDynItems->pDynSym->hMemvar = 0;
pDynItems->pDynSym->pSymbol = NULL;
pDynItems->pDynSym->pFunPtr = NULL;
s_pDynItems->pDynSym->hMemvar = 0;
s_pDynItems->pDynSym->pSymbol = NULL;
s_pDynItems->pDynSym->pFunPtr = NULL;
return NULL;
}
else
{ /* Classic Tree Insert Sort Mechanism
*
* Insert Sort means the new item is entered alphabetically into
* the array. In this case pDynItems !
* the array. In this case s_pDynItems !
*
* 1) We start in the middle of the array.
* 2a) If the symbols are equal -> we have found the symbol !!
@@ -164,26 +164,26 @@ PHB_DYNS hb_dynsymFind( char * szName )
*/
WORD wFirst = 0;
WORD wLast = wDynSymbols;
WORD wLast = s_wDynSymbols;
WORD wMiddle = wLast / 2;
wClosestDynSym = wMiddle; /* Start in the middle */
s_wClosestDynSym = wMiddle; /* Start in the middle */
while( wFirst < wLast )
{
switch( hb_strgreater( pDynItems[ wMiddle ].pDynSym->pSymbol->szName, szName ) )
switch( hb_strgreater( s_pDynItems[ wMiddle ].pDynSym->pSymbol->szName, szName ) )
{
case HB_STRGREATER_EQUAL: /* they are equals */
return pDynItems[ wMiddle ].pDynSym;
return s_pDynItems[ wMiddle ].pDynSym;
case HB_STRGREATER_LEFT: /* pMiddle is greater */
wLast = wMiddle;
wClosestDynSym = wMiddle;
s_wClosestDynSym = wMiddle;
break;
case HB_STRGREATER_RIGHT: /* szName is greater */
wFirst = wMiddle + 1;
wClosestDynSym = wFirst;
s_wClosestDynSym = wFirst;
break;
}
wMiddle = wFirst + ( ( wLast - wFirst ) / 2 );
@@ -197,8 +197,8 @@ void hb_dynsymEval( PHB_DYNS_FUNC pFunction )
BOOL bCont = TRUE;
WORD i;
for( i = 0; i < wDynSymbols && bCont; i++ )
bCont = (pFunction)( pDynItems[ i ].pDynSym );
for( i = 0; i < s_wDynSymbols && bCont; i++ )
bCont = ( pFunction )( s_pDynItems[ i ].pDynSym );
}
@@ -206,29 +206,29 @@ void hb_dynsymRelease( void )
{
WORD w;
for( w = 0; w < wDynSymbols; w++ )
for( w = 0; w < s_wDynSymbols; w++ )
{
/* it is a allocated symbol ? */
if( ( pDynItems + w )->pDynSym->pSymbol->cScope == (SYMBOLSCOPE)SYM_ALLOCATED )
if( ( s_pDynItems + w )->pDynSym->pSymbol->cScope == SYM_ALLOCATED )
{
hb_xfree( ( pDynItems + w )->pDynSym->pSymbol->szName );
hb_xfree( ( pDynItems + w )->pDynSym->pSymbol );
hb_xfree( ( s_pDynItems + w )->pDynSym->pSymbol->szName );
hb_xfree( ( s_pDynItems + w )->pDynSym->pSymbol );
}
hb_xfree( ( pDynItems + w )->pDynSym );
hb_xfree( ( s_pDynItems + w )->pDynSym );
}
hb_xfree( pDynItems );
hb_xfree( s_pDynItems );
}
HARBOUR HB___DYNSCOUNT( void ) /* How much symbols do we have: dsCount = __dynsymCount() */
{
hb_retnl( wDynSymbols );
hb_retnl( s_wDynSymbols );
}
HARBOUR HB___DYNSGETNAME( void ) /* Get name of symbol: cSymbol = __dynsymGetName( dsIndex ) */
{
hb_retc( pDynItems[ hb_parnl( 1 ) - 1 ].pDynSym->pSymbol->szName );
hb_retc( s_pDynItems[ hb_parnl( 1 ) - 1 ].pDynSym->pSymbol->szName );
}
HARBOUR HB___DYNSGETINDEX( void ) /* Gimme index number of symbol: dsIndex = __dynsymGetIndex( cSymbol ) */

599
harbour/source/vm/hvm.c
View File

File diff suppressed because it is too large Load Diff

146
harbour/tests/working/Makefile
View File

@@ -20,133 +20,25 @@ ifeq ($(PM),)
endif
ifeq ($(PM),) # PM not defined = build all files
PRG_SOURCES=\
ac_test.prg \
adirtest.prg \
ainstest.prg \
and_or.prg \
array16.prg \
arrayidx.prg \
arrays.prg \
arreval.prg \
arrindex.prg \
atest.prg \
begin.prg \
box.prg \
byref.prg \
calling.prg \
cdow.prg \
clasinit.prg \
clasname.prg \
classch.prg \
classes.prg \
clsdata.prg \
cmphello.prg \
codebl.prg \
codebloc.prg \
comments.prg \
copyfile.prg \
curdirt.prg \
cursrtst.prg \
dates.prg \
dates2.prg \
dates3.prg \
dates4.prg \
debugtst.prg \
descend.prg \
dirtest.prg \
docase.prg \
dosshell.prg \
dynobj.prg \
dynsym.prg \
empty.prg \
exittest.prg \
fib.prg \
fileio.prg \
filexist.prg \
fornext.prg \
fornext2.prg \
fortest.prg \
funcarr.prg \
guess.prg \
hardcr.prg \
hello.prg \
ifelse.prg \
ifinline.prg \
inherit.prg \
inifiles.prg \
initexit.prg \
inkeytst.prg \
inline.prg \
instr.prg \
iotest.prg \
iotest2.prg \
longstr.prg \
longstr2.prg \
mankala.prg \
mathtest.prg \
memvar.prg \
menutest.prg \
mtran.prg \
multiarg.prg \
nums.prg \
objarr.prg \
objasign.prg \
objects.prg \
operat.prg \
os.prg \
output.prg \
overload.prg \
passref.prg \
procline.prg \
procname.prg \
readfile.prg \
readhrb.prg \
recursiv.prg \
returns.prg \
round.prg \
rtfclass.prg \
rtl_test.prg \
say.prg \
scroll.prg \
seconds.prg \
set_num.prg \
set_test.prg \
sound.prg \
statfun.prg \
statics.prg \
strcmp.prg \
strdelim.prg \
strings.prg \
strings2.prg \
strings3.prg \
strip.prg \
strsub.prg \
syserror.prg \
t1.prg \
test.prg \
test_all.prg \
testbrw.prg \
testcgi.prg \
testcopy.prg \
testerro.prg \
testfor.prg \
testgt.prg \
testhbf.prg \
testhtml.prg \
testinc.prg \
testmem.prg \
teststr.prg \
testtok.prg \
testpre.prg \
testread.prg \
testrdd.prg \
testvars.prg \
testwarn.prg \
tstcolor.prg \
transdef.prg \
val.prg \
version.prg \
while.prg \
huh.prg \
huh2.prg \
rtl_test.prg \
fileio.prg \
and_or.prg \
copyfile.prg \
kej.prg \
kejj.prg \
inkeytst.prg \
para.prg \
rtl_test.prg \
i.prg \
j.prg \
k.prg \
ac_test.prg \
fileio.prg \
rtl_test.prg \
testrdd.prg \
testdbf.prg \
PRG_HEADERS=\
cgi.ch \

68
harbour/tests/working/empty.prg
View File

@@ -1,68 +0,0 @@
//
// $Id$
//
//
// Testing Empty() function
//
// Date : 16/05/1999
// Time : 21:00
//
// Writte by Eddie Runia <eddie@runia.com>
// www - http://www.harbour-project.org
//
// Placed in the public domain
//
#include "set.ch"
function Main()
__SETCENTURY ("ON") // SET CENTURY ON
SET (_SET_DATEFORMAT, "DD/MM/YYYY") // SET DATE BRITISH
QOut( "British date format with century on" )
QOut( "C 'Hallo' ", empty( "Hallo" ) )
QOut( "C '' ", empty( "" ) )
QOut( "C ' ' ", empty( " " ) )
QOut( "C ' \0' ", empty( " "+chr(0) ) )
QOut( "C ' \n\t' ", empty( " "+chr(13)+chr(9) ) )
QOut( "C ' A' ", empty( " A" ) )
QOut( "C ' x ' ", empty( " x " ) )
QOut( "C ' x\0' ", empty( " x"+chr(0) ) )
QOut( "C ' \nx\t' ", empty( " "+chr(13)+"x"+chr(9) ) )
QOut( "N 0 ", empty( 0 ) )
QOut( "N -0 ", empty( -0 ) )
QOut( "N 0.0 ", empty( 0.0 ) )
QOut( "N 70000-70000 ", empty( 70000-70000 ) )
QOut( "N 1.5*1.5-2.25 ", empty( 1.5*1.5-2.25 ) )
QOut( "N 10 ", empty( 10 ) )
QOut( "N 10.0 ", empty( 10.0 ) )
QOut( "N 70000+70000 ", empty( 70000+70000 ) )
QOut( "N 1.5*1.5*2.25 ", empty( 1.5*1.5*2.25 ) )
Pause()
QOut( "D 10/10/1824 ", ctod("10/10/1824"), empty( ctod("10/10/1824") ) )
QOut( "D 31/02/1825 ", ctod("31/02/1825"), empty( ctod("31/02/1825") ) )
QOut( "D 99/99/9999 ", ctod("99/99/9999"), empty( ctod("99/99/9999") ) )
QOut( "D / / ", ctod(" / / "), empty( ctod(" / / ") ) )
QOut( "D ", ctod(""), empty( ctod("") ) )
QOut( "L .T. ", empty( .T. ) )
QOut( "L .F. ", empty( .F. ) )
QOut( "U NIL ", empty( NIL ) )
QOut( "A {1} ", empty( {1} ) )
QOut( "A {} ", empty( {} ) )
QOut( "A {0} ", empty( {0} ) )
QOut( "B {|x|x+x} ", empty( {|x|x+x} ) )
QOut()
return nil
function Pause()
QOut()
__Accept( "Pause:" )
return nil

476
harbour/tests/working/rtl_test.prg
View File

@@ -35,48 +35,321 @@
*/
/* TRANSFORM() tests written by Eddie Runia <eddie@runia.com> */
/* EMPTY() tests written by Eddie Runia <eddie@runia.com> */
/* NOTE: Always compile with /n switch */
/* NOTE: It's worth to make tests with and without the /z switch */
/* NOTE: Guard all Harbour extensions with __HARBOUR__ #ifdefs */
/* TODO: Add checks for string parameters with embedded NUL character */
/* TODO: Add test cases for other string functions */
/* TODO: Incorporate tests from test/working/string*.prg */
/* TODO: String overflow on + and - tests */
/* TODO: Tests with MEMO type ? */
/* TODO: Tests with Log(0) type of invalid values */
#include "error.ch"
#translate TEST_LINE( <x>, <result> ) => TEST_CALL(<(x)>, {|| <x> }, <result>)
#translate TEST_LINE( <x>, <result> ) => TEST_CALL( <(x)>, {|| <x> }, <result> )
STATIC snPass
STATIC snFail
STATIC scFileName
STATIC snFhnd
STATIC scNewLine
STATIC snCount
STATIC slShowAll
STATIC s_nPass
STATIC s_nFail
STATIC s_cFileName
STATIC s_nFhnd
STATIC s_cNewLine
STATIC s_nCount
STATIC s_lShowAll
STATIC s_lShortcut
FUNCTION Main( cPar1 )
/* NOTE: Some basic values we may need for some tests.
( passing by reference, avoid preprocessor bugs, etc. ) */
LOCAL lcString := "HELLO"
LOCAL lcStringE := ""
LOCAL lcStringZ := "A" + Chr(0) + "B"
LOCAL lnIntZ := 0
LOCAL lnDoubleZ := 0.0
LOCAL lnIntP := 10
LOCAL lnLongP := 100000
LOCAL lnDoubleP := 10.567
LOCAL lnIntN := -10
LOCAL lnLongN := -100000
LOCAL lnDoubleN := -10.567
LOCAL lnDoubleI := Log( 0 )
LOCAL ldDateE := SToD("")
LOCAL llFalse := .F.
LOCAL llTrue := .T.
LOCAL loObject := ErrorNew()
LOCAL luNIL := NIL
LOCAL lbBlock := {|| NIL }
LOCAL laArray := { 9898 }
MEMVAR mxNotHere
MEMVAR mcString
MEMVAR mcStringE
MEMVAR mcStringZ
MEMVAR mnIntZ
MEMVAR mnDoubleZ
MEMVAR mnIntP
MEMVAR mnLongP
MEMVAR mnDoubleP
MEMVAR mnDoubleI
MEMVAR mnIntN
MEMVAR mnLongN
MEMVAR mnDoubleN
MEMVAR mdDateE
MEMVAR mlFalse
MEMVAR mlTrue
MEMVAR moObject
MEMVAR muNIL
MEMVAR mbBlock
MEMVAR maArray
/* NOTE: mxNotHere intentionally not declared */
PRIVATE mcString := "HELLO"
PRIVATE mcStringE := ""
PRIVATE mcStringZ := "A" + Chr(0) + "B"
PRIVATE mnIntZ := 0
PRIVATE mnDoubleZ := 0.0
PRIVATE mnIntP := 10
PRIVATE mnLongP := 100000
PRIVATE mnDoubleP := 10.567
PRIVATE mnDoubleI := Log( 0 )
PRIVATE mnIntN := -10
PRIVATE mnLongN := -100000
PRIVATE mnDoubleN := -10.567
PRIVATE mdDateE := SToD("")
PRIVATE mlFalse := .F.
PRIVATE mlTrue := .T.
PRIVATE moObject := ErrorNew()
PRIVATE muNIL := NIL
PRIVATE mbBlock := {|| NIL }
PRIVATE maArray := { 9898 }
/* Initialize test */
/* TODO: Need to add this, when multi language support will be available
to make sure all error messages comes in the original English
language. */
/* SET LANGID TO EN */
IF cPar1 == NIL
cPar1 := ""
ENDIF
/* Initialize test */
// SET LANGID TO EN
TEST_BEGIN( cPar1 )
/* NOTE: CA-Cl*pper PP fails on these
TEST_LINE( "1" .AND. "2" , "E BASE 1066 Argument error conditional " )
TEST_LINE( "1" .AND. .F. , .F. )
TEST_LINE( "A" > 1 , "E BASE 1075 Argument error > F:S" )
*/
/* (operators) */
TEST_LINE( 1 + NIL , "E BASE 1081 Argument error + F:S" )
TEST_LINE( 1 - NIL , "E BASE 1082 Argument error - F:S" )
TEST_LINE( "A" - "B" , "AB" )
TEST_LINE( "A " - "B" , "AB " )
TEST_LINE( "A " - "B " , "AB " )
TEST_LINE( "A " - " B" , "A B " )
TEST_LINE( " " - "B " , "B " )
TEST_LINE( 1 / NIL , "E BASE 1084 Argument error / F:S" )
TEST_LINE( 1 * NIL , "E BASE 1083 Argument error * F:S" )
// PP fails to preprocess this line, so it's temporarly commented out
TEST_LINE( 1 ** NIL , "E BASE 1088 Argument error ^ F:S" )
/* NOTE: Harbour PP fails to process this line, so it's temporarly commented out */
#ifndef __HARBOUR__
TEST_LINE( 1 ^ NIL , "E BASE 1088 Argument error ^ F:S" )
#endif
TEST_LINE( 1 % NIL , "E BASE 1085 Argument error % F:S" )
TEST_LINE( -(0) , 0 )
TEST_LINE( -(10) , -10 )
TEST_LINE( -(10.505) , -10.505 )
TEST_LINE( -(100000) , -100000 )
TEST_LINE( -(-10) , 10 )
TEST_LINE( -("1") , "E BASE 1080 Argument error - F:S" )
/* NOTE: Harbour PP fails to process this line, so it's temporarly commented out */
#ifndef __HARBOUR__
TEST_LINE( "AA" $ 1 , "E BASE 1109 Argument error $ F:S" )
#endif
TEST_LINE( lcString $ 1 , "E BASE 1109 Argument error $ F:S" )
TEST_LINE( 1 $ "AA" , "E BASE 1109 Argument error $ F:S" )
IF TEST_OPT_Z()
/* With the shortcut optimalization *ON* */
TEST_LINE( 1 .AND. 2 , "E BASE 1066 Argument error conditional " )
TEST_LINE( NIL .AND. NIL , "E BASE 1066 Argument error conditional " )
TEST_LINE( lcString .AND. lcString , "E BASE 1066 Argument error conditional " )
TEST_LINE( .T. .AND. 1 , 1 )
TEST_LINE( .T. .AND. 1.567 , 1.567 )
TEST_LINE( .T. .AND. lcString , "HELLO" )
TEST_LINE( .T. .AND. SToD("") , SToD(" ") )
TEST_LINE( .T. .AND. NIL , NIL )
TEST_LINE( .T. .AND. {} , "{.[0].}" )
TEST_LINE( .T. .AND. {|| NIL } , "{||...}" )
TEST_LINE( .F. .AND. 1 , .F. )
TEST_LINE( .F. .AND. 1.567 , .F. )
TEST_LINE( .F. .AND. lcString , .F. )
TEST_LINE( .F. .AND. SToD("") , .F. )
TEST_LINE( .F. .AND. NIL , .F. )
TEST_LINE( .F. .AND. {} , .F. )
TEST_LINE( .F. .AND. {|| NIL } , .F. )
TEST_LINE( 1 .AND. .F. , .F. )
TEST_LINE( 1.567 .AND. .F. , .F. )
TEST_LINE( lcString .AND. .F. , .F. )
/* With the shortcut optimalization *OFF* (/z switch) */
TEST_LINE( 1 .OR. 2 , "E BASE 1066 Argument error conditional " )
TEST_LINE( .F. .OR. 2 , 2 )
TEST_LINE( .F. .OR. 1.678 , 1.678 )
TEST_LINE( .F. .OR. lcString , "HELLO" )
TEST_LINE( .T. .OR. 2 , .T. )
TEST_LINE( .T. .OR. 1.678 , .T. )
TEST_LINE( .T. .OR. lcString , .T. )
TEST_LINE( 1 .OR. .F. , 1 )
TEST_LINE( 1.0 .OR. .F. , 1.0 )
TEST_LINE( lcString .OR. .F. , "HELLO" )
ELSE
TEST_LINE( 1 .AND. 2 , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( NIL .AND. NIL , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( lcString .AND. lcString , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. 1 , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. 1.567 , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. lcString , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. SToD("") , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. NIL , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. {} , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .T. .AND. {|| NIL } , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. 1 , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. 1.567 , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. lcString , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. SToD("") , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. NIL , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. {} , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( .F. .AND. {|| NIL } , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( 1 .AND. .F. , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( 1.567 .AND. .F. , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( lcString .AND. .F. , "E BASE 1078 Argument error .AND. F:S" )
TEST_LINE( 1 .OR. 2 , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( .F. .OR. 2 , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( .F. .OR. 1.678 , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( .F. .OR. lcString , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( .T. .OR. 2 , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( .T. .OR. 1.678 , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( .T. .OR. lcString , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( 1 .OR. .F. , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( 1.0 .OR. .F. , "E BASE 1079 Argument error .OR. F:S" )
TEST_LINE( lcString .OR. .F. , "E BASE 1079 Argument error .OR. F:S" )
ENDIF
TEST_LINE( .NOT. .T. , .F. )
TEST_LINE( .NOT. .F. , .T. )
TEST_LINE( .NOT. 1 , "E BASE 1077 Argument error .NOT. F:S" )
TEST_LINE( iif( "A", ":T:", ":F:" ) , "E BASE 1066 Argument error conditional " )
TEST_LINE( iif( .T., ":T:", ":F:" ) , ":T:" )
TEST_LINE( iif( .F., ":T:", ":F:" ) , ":F:" )
TEST_LINE( lcString++ , "E BASE 1086 Argument error ++ F:S" )
TEST_LINE( lcString-- , "E BASE 1087 Argument error -- F:S" )
TEST_LINE( mxNotHere , "E BASE 1003 Variable does not exist MXNOTHERE F:R" )
TEST_LINE( laArray[ 0 ] , "E BASE 1132 Bound error array access " )
TEST_LINE( laArray[ 0 ] := 1 , "E BASE 1133 Bound error array assign " )
TEST_LINE( laArray[ 1000 ] , "E BASE 1132 Bound error array access " )
TEST_LINE( laArray[ 1000 ] := 1 , "E BASE 1133 Bound error array assign " )
TEST_LINE( laArray[ -1 ] , "E BASE 1132 Bound error array access " )
TEST_LINE( laArray[ -1 ] := 1 , "E BASE 1133 Bound error array assign " )
TEST_LINE( laArray[ "1" ] , "E BASE 1068 Argument error array access F:S" )
TEST_LINE( laArray[ "1" ] := 1 , "E BASE 1069 Argument error array assign " )
TEST_LINE( lcString > 1 , "E BASE 1075 Argument error > F:S" )
TEST_LINE( lcString >= 1 , "E BASE 1076 Argument error >= F:S" )
TEST_LINE( lcString <> 1 , "E BASE 1072 Argument error <> F:S" )
TEST_LINE( lcString == 1 , "E BASE 1070 Argument error == F:S" )
TEST_LINE( {|| NIL } == {|| NIL } , "E BASE 1070 Argument error == F:S" )
TEST_LINE( lcString = 1 , "E BASE 1071 Argument error = F:S" )
TEST_LINE( lcString < 1 , "E BASE 1073 Argument error < F:S" )
TEST_LINE( lcString <= 1 , "E BASE 1074 Argument error <= F:S" )
/* NOTE: Harbour RDD will GPF if commented out. */
#ifndef __HARBOUR__
/* NOTE: TEST_CALL() should be used here, since CA-Cl*pper can't preprocess
the TEST_LINE() variation properly. */
/* TEST_LINE( ("NOTHERE")->NOFIELD , "E BASE 1002 Alias does not exist NOTHERE F:R" ) */
TEST_CALL( '("NOTHERE")->NOFIELD', {|| ("NOTHERE")->NOFIELD }, "E BASE 1002 Alias does not exist NOTHERE F:R" )
TEST_LINE( NOTHERE->NOFIELD , "E BASE 1002 Alias does not exist NOTHERE F:R" )
TEST_LINE( 200->NOFIELD , "E BASE 1003 Variable does not exist NOFIELD F:R" )
#endif
TEST_LINE( loObject:hello , "E BASE 1004 No exported method HELLO F:S" )
TEST_LINE( loObject:hello := 1 , "E BASE 1005 No exported variable HELLO F:S" )
/* LEN() */
TEST_LINE( Len( NIL ) , "E BASE 1111 Argument error LEN F:S" )
TEST_LINE( Len( 123 ) , "E BASE 1111 Argument error LEN F:S" )
TEST_LINE( Len( "" ) , 0 )
TEST_LINE( Len( "123" ) , 3 )
TEST_LINE( Len( laArray ) , 1 )
#ifdef __HARBOUR__
TEST_LINE( Len( Space( 3000000000 ) ) , 3000000000 )
#else
TEST_LINE( Len( Space( 40000 ) ) , 40000 )
#endif
/* EMPTY() */
TEST_LINE( Empty( @lcString ) , .T. ) /* Bug in CA-Cl*pper ? */
TEST_LINE( Empty( @lcStringE ) , .T. )
TEST_LINE( Empty( @lnIntP ) , .T. ) /* Bug in CA-Cl*pper ? */
TEST_LINE( Empty( @lnIntZ ) , .T. )
TEST_LINE( Empty( "Hallo" ) , .F. )
TEST_LINE( Empty( "" ) , .T. )
TEST_LINE( Empty( " " ) , .T. )
TEST_LINE( Empty( " "+Chr(0) ) , .F. )
TEST_LINE( Empty( " "+Chr(13)+Chr(9) ) , .T. )
TEST_LINE( Empty( " A" ) , .F. )
TEST_LINE( Empty( " x " ) , .F. )
TEST_LINE( Empty( " x"+Chr(0) ) , .F. )
TEST_LINE( Empty( " "+Chr(13)+"x"+Chr(9) ) , .F. )
TEST_LINE( Empty( 0 ) , .T. )
TEST_LINE( Empty( -0 ) , .T. )
TEST_LINE( Empty( 0.0 ) , .T. )
TEST_LINE( Empty( 70000-70000 ) , .T. )
TEST_LINE( Empty( 1.5*1.5-2.25 ) , .T. )
TEST_LINE( Empty( 10 ) , .F. )
TEST_LINE( Empty( 10.0 ) , .F. )
TEST_LINE( Empty( 70000+70000 ) , .F. )
TEST_LINE( Empty( 1.5*1.5*2.25 ) , .F. )
TEST_LINE( Empty( SToD("18241010") ) , .F. )
TEST_LINE( Empty( SToD("18250231") ) , .T. )
TEST_LINE( Empty( SToD("99999999") ) , .T. )
TEST_LINE( Empty( SToD(" ") ) , .T. )
TEST_LINE( Empty( SToD("") ) , .T. )
TEST_LINE( Empty( .T. ) , .F. )
TEST_LINE( Empty( .F. ) , .T. )
TEST_LINE( Empty( NIL ) , .T. )
TEST_LINE( Empty( {1} ) , .F. )
TEST_LINE( Empty( {} ) , .T. )
TEST_LINE( Empty( {0} ) , .F. )
TEST_LINE( Empty( {|x|x+x} ) , .F. )
/* ABS() */
TEST_LINE( Abs("A") , "E BASE 1089 Argument error ABS F:S" )
@@ -170,6 +443,14 @@ FUNCTION Main( cPar1 )
TEST_LINE( RAt("ABCDEFG", "ABCDEF") , 0 )
TEST_LINE( RAt("FI", "ABCDEF") , 0 )
/* REPLICATE() */
#ifdef __HARBOUR__
TEST_LINE( Replicate("XXX", 2000000000) , "E BASE 1234 String overflow REPLICATE F:S" )
#else
TEST_LINE( Replicate("XXX", 30000) , "E BASE 1234 String overflow REPLICATE F:S" )
#endif
/* SUBSTR() */
TEST_LINE( SubStr("abcdef", 0, -1) , "" )
@@ -255,6 +536,8 @@ FUNCTION Main( cPar1 )
TEST_LINE( PadC("abcdef", 10, "1") , "11abcdef11" )
TEST_LINE( PadC("abcdef", 10, "12") , "11abcdef11" )
/* STUFF() */
TEST_LINE( Stuff("ABCDEF", 0, 0, NIL) , "" )
TEST_LINE( Stuff("ABCDEF", 0, 0, "xyz") , "xyzABCDEF" )
TEST_LINE( Stuff("ABCDEF", 1, 0, "xyz") , "xyzABCDEF" )
@@ -525,8 +808,10 @@ FUNCTION Main( cPar1 )
TEST_LINE( Transform( 150 , "99,99" ) , " 1,50" )
TEST_LINE( Transform( 41 , "@Z 9999" ) , " 41" )
TEST_LINE( Transform( 0 , "@Z 9999" ) , " " )
TEST_LINE( Transform( 41 , "@0 9999" ) , " 41" )
TEST_LINE( Transform( 0 , "@0 9999" ) , " 0" )
#ifdef __HARBOUR__
TEST_LINE( Transform( 41 , "@0 9999" ) , "0041" ) /* Extension in Harbour, in CA-Cl*pper it should return: " 41" */
TEST_LINE( Transform( 0 , "@0 9999" ) , "0000" ) /* Extension in Harbour, in CA-Cl*pper it should return: " 0" */
#endif
TEST_LINE( Transform( 41 , "@B 9999" ) , "41 " )
TEST_LINE( Transform( 41 , "@B 99.9" ) , "41.0" )
TEST_LINE( Transform( 7 , "@B 99.9" ) , "7.0 " )
@@ -570,7 +855,7 @@ FUNCTION Main( cPar1 )
#define TEST_RESULT_COL1_WIDTH 4
#define TEST_RESULT_COL2_WIDTH 30
#define TEST_RESULT_COL3_WIDTH 40
#define TEST_RESULT_COL3_WIDTH 55
#define TEST_RESULT_COL4_WIDTH 40
STATIC FUNCTION TEST_BEGIN( cParam )
@@ -578,42 +863,51 @@ STATIC FUNCTION TEST_BEGIN( cParam )
IF "OS/2" $ cOs .OR. ;
"DOS" $ cOs
scNewLine := Chr( 13 ) + Chr( 10 )
s_cNewLine := Chr( 13 ) + Chr( 10 )
ELSE
scNewLine := Chr( 10 )
s_cNewLine := Chr( 10 )
ENDIF
slShowAll := "/ALL" $ Upper( cParam )
s_lShowAll := "/ALL" $ Upper( cParam )
/*
#ifdef __HARBOUR__
scFileName := "rtl_test.hb"
#else
scFileName := "rtl_test.cl"
#endif
*/
/* Detect presence of shortcutting optimalization */
snFhnd := 1 /* FHND_STDOUT */
scFileName := "(stdout)"
s_lShortcut := .T.
IF .T. .OR. Eval( {|| s_lShortcut := .F. } )
/* Do nothing */
ENDIF
snCount := 0
snPass := 0
snFail := 0
/* Decide about output filename */
fWrite( snFhnd, " Version: " + Version() + scNewLine +;
" OS: " + OS() + scNewLine +;
"Date, Time: " + DToS( Date() ) + " " + Time() + scNewLine +;
" Output: " + scFileName + scNewLine +;
" Switches: " + cParam + scNewLine +;
"===========================================================================" + scNewLine +;
scNewLine )
DO CASE
CASE "HARBOUR" $ Upper( Version() ) ; s_cFileName := "rtl_test.hb"
CASE "CLIPPER (R)" $ Upper( Version() ) .AND. ;
"5.3" $ Version() ; s_cFileName := "rtl_test.c53"
CASE "CLIPPER (R)" $ Upper( Version() ) ; s_cFileName := "rtl_test.c5x"
ENDCASE
fWrite( snFhnd, PadL( "No", TEST_RESULT_COL1_WIDTH ) + ". " +;
PadR( "TestCall()", TEST_RESULT_COL2_WIDTH ) + " -> " +;
PadR( "Result", TEST_RESULT_COL3_WIDTH ) + " | " +;
PadR( "Expected", TEST_RESULT_COL4_WIDTH ) +;
" [! *FAIL* !]" + scNewLine )
fWrite( snFhnd, "---------------------------------------------------------------------------" + scNewLine )
s_nFhnd := 1 /* FHND_STDOUT */
s_cFileName := "(stdout)"
s_nCount := 0
s_nPass := 0
s_nFail := 0
fWrite( s_nFhnd, " Version: " + Version() + s_cNewLine +;
" OS: " + OS() + s_cNewLine +;
" Date, Time: " + DToS( Date() ) + " " + Time() + s_cNewLine +;
" Output: " + s_cFileName + s_cNewLine +;
"Shortcut opt.: " + iif( s_lShortcut, "ON", "OFF" ) + s_cNewLine +;
" Switches: " + cParam + s_cNewLine +;
"===========================================================================" + s_cNewLine +;
s_cNewLine )
fWrite( s_nFhnd, PadL( "No", TEST_RESULT_COL1_WIDTH ) + ". " +;
PadR( "TestCall()", TEST_RESULT_COL2_WIDTH ) + " -> " +;
PadR( "Result", TEST_RESULT_COL3_WIDTH ) + " | " +;
PadR( "Expected", TEST_RESULT_COL4_WIDTH ) +;
" [! *FAIL* !]" + s_cNewLine )
fWrite( s_nFhnd, "---------------------------------------------------------------------------" + s_cNewLine )
RETURN NIL
@@ -623,61 +917,83 @@ STATIC FUNCTION TEST_CALL( cBlock, bBlock, xResultExpected )
LOCAL bOldError
LOCAL lFailed
bOldError := ErrorBlock( {|oError| Break( oError ) } )
s_nCount++
BEGIN SEQUENCE
xResult := Eval( bBlock )
RECOVER USING oError
xResult := ErrorMessage( oError )
END SEQUENCE
IF ValType( cBlock ) == "C"
ErrorBlock( bOldError )
bOldError := ErrorBlock( {|oError| Break( oError ) } )
snCount++
BEGIN SEQUENCE
xResult := Eval( bBlock )
RECOVER USING oError
xResult := ErrorMessage( oError )
END SEQUENCE
lFailed := !( ValType( xResult ) == ValType( xResultExpected ) ) .OR. ;
!( xResult == xResultExpected )
ErrorBlock( bOldError )
IF slShowAll .OR. lFailed
fWrite( snFhnd, Str( snCount, TEST_RESULT_COL1_WIDTH ) + ". " +;
PadR( StrTran( cBlock, Chr(0), "." ), TEST_RESULT_COL2_WIDTH ) + " -> " +;
PadR( StrTran( XToStr( xResult ), Chr(0), "." ), TEST_RESULT_COL3_WIDTH ) + " | " +;
PadR( StrTran( XToStr( xResultExpected ), Chr(0), "." ), TEST_RESULT_COL4_WIDTH ) )
IF lFailed
fWrite( snFhnd, " ! *FAIL* !" )
IF !( ValType( xResult ) == ValType( xResultExpected ) )
IF ValType( xResultExpected) == "C" .AND. ValType( xResult ) $ "ABM"
lFailed := !( XToStr( xResult ) == xResultExpected )
ELSE
lFailed := .T.
ENDIF
ELSE
lFailed := !( xResult == xResultExpected )
ENDIF
fWrite( snFhnd, scNewLine )
ELSE
lFailed := .T.
cBlock := "!! Preprocessor error. Test skipped !!"
xResult := NIL
ENDIF
IF s_lShowAll .OR. lFailed
fWrite( s_nFhnd, Str( s_nCount, TEST_RESULT_COL1_WIDTH ) + ". " +;
PadR( StrTran( cBlock, Chr(0), "." ), TEST_RESULT_COL2_WIDTH ) + " -> " +;
PadR( StrTran( XToStr( xResult ), Chr(0), "." ), TEST_RESULT_COL3_WIDTH ) + " | " +;
PadR( StrTran( XToStr( xResultExpected ), Chr(0), "." ), TEST_RESULT_COL4_WIDTH ) )
IF lFailed
fWrite( s_nFhnd, " ! *FAIL* !" )
ENDIF
fWrite( s_nFhnd, s_cNewLine )
ENDIF
IF lFailed
snFail++
s_nFail++
ELSE
snPass++
s_nPass++
ENDIF
RETURN NIL
STATIC FUNCTION TEST_OPT_Z()
RETURN s_lShortCut
STATIC FUNCTION TEST_END()
fWrite( snFhnd, scNewLine +;
"===========================================================================" + scNewLine +;
"Test calls passed: " + Str( snPass ) + scNewLine +;
"Test calls failed: " + Str( snFail ) + scNewLine +;
scNewLine )
fWrite( s_nFhnd, s_cNewLine +;
"===========================================================================" + s_cNewLine +;
"Test calls passed: " + Str( s_nPass ) + s_cNewLine +;
"Test calls failed: " + Str( s_nFail ) + s_cNewLine +;
" ----------" + s_cNewLine +;
" Total: " + Str( s_nPass + s_nFail ) + s_cNewLine +;
s_cNewLine )
IF snFail != 0
IF s_nFail != 0
IF "CLIPPER (R)" $ Upper( Version() )
fWrite( snFhnd, "WARNING ! Failures detected using CA-Clipper." + scNewLine +;
"Please fix those expected results which are not bugs in CA-Clipper itself." + scNewLine )
fWrite( s_nFhnd, "WARNING ! Failures detected using CA-Clipper." + s_cNewLine +;
"Please fix those expected results which are not bugs in CA-Clipper itself." + s_cNewLine )
ELSE
fWrite( snFhnd, "WARNING ! Failures detected" + scNewLine )
fWrite( s_nFhnd, "WARNING ! Failures detected" + s_cNewLine )
ENDIF
ENDIF
ErrorLevel( iif( snFail != 0, 1, 0 ) )
ErrorLevel( iif( s_nFail != 0, 1, 0 ) )
RETURN NIL
@@ -687,13 +1003,13 @@ STATIC FUNCTION XToStr( xValue )
DO CASE
CASE cType == "C" ; RETURN '"' + xValue + '"'
CASE cType == "N" ; RETURN LTrim( Str( xValue ) )
CASE cType == "D" ; RETURN DToC( xValue )
CASE cType == "D" ; RETURN 'SToD("' + DToS( xValue ) + '")'
CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." )
CASE cType == "O" ; RETURN xValue:className + " Object"
CASE cType == "U" ; RETURN "NIL"
CASE cType == "B" ; RETURN "{||...}"
CASE cType == "A" ; RETURN "{...}"
CASE cType == "M" ; RETURN xValue
CASE cType == "B" ; RETURN '{||...}'
CASE cType == "A" ; RETURN '{.[' + LTrim( Str( Len( xValue ) ) ) + '].}'
CASE cType == "M" ; RETURN 'M:"' + xValue + '"'
ENDCASE
RETURN ""

42
harbour/tests/working/strsub.prg
View File

@@ -1,42 +0,0 @@
/*
* $Id$
*/
// Testing strings concat
// Expected result:
//
// [STRINGSCONCAT ]
// [STRINGSCONCAT ]
// [STRINGSCONCAT ]
// >AB<
// >AB <
// >AB <
// >A B <
// >B <
function main()
LOCAL a := "STRINGS "
LOCAL b := "CONCAT"
LOCAL c
LOCAL i
for i := 1 to 3
a += " "
c := a
c -= b
QOut( "[" + c + "]" )
next
QOut( ">" + "A" - "B" + "<" ) // "AB"
QOut( ">" + "A " - "B" + "<" ) // "AB "
QOut( ">" + "A " - "B " + "<" ) // "AB "
QOut( ">" + "A " - " B" + "<" ) // "A B "
QOut( ">" + " " - "B " + "<" ) // "B "
QOut()
__Accept( "Press <Enter> to raise an error!" )
QOut( a - i )
return nil