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

19990907-01:00 GMT+1

Browse Source
This commit is contained in:
Viktor Szakats
1999-09-06 23:09:57 +00:00
parent ce001fb0a6
commit c3a842d991
9 changed files with 825 additions and 529 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
harbour/ChangeLog
View File

@@ -1,3 +1,37 @@
19990907-01:00 GMT+1 Victor Szel <info@szelvesz.hu>
* source/rtl/arrays.c
! hb_arrayScan() fixed, so that it can also search for a NIL value. Like
Clipper.
% Optimized the search loop for speed.
! Fixed searching of numeric values. Different numeric sub-types with the
same value are also considered equal (of course), so 10 == 10.0 now.
* Uses Item API calls where possible.
* source/rtl/classes.c
! hb___msgEval() added, so now send an :eval message to a block
will work fine, sending it to other types will result in a proper error
message.
! hb___msgClsH() will return 0, if the checked type is not an ARRAY/OBJECT.
Until now a GPF occured on this code: a := "A" ; a:classH
* Functions reordered.
* source/rtl/do.c
source/vm/hvm.c
* EVAL() moved to do.c.
! EVAL() internal message changed to the Clipper compatible one.
* DO() parameter count error message changed to EG_ARGCOUNT/3000.
* source/compiler/harbour.y
+ SETPOSBS() added to the reserved function list.
* tests/working/rtl_test.prg
+ Some PAD?() tests added with new types, byref. Some new MIN()/MAX() tests
added. ASCAN() tests added.
+ /SKIP: switch added, to make it possible to temporarly skip specific
tests. (RTL_TEST /SKIP:100,102)
+ EVAL(), :EVAL() tests added. Some are commented out, due to bugs.
* source/rtl/itemapi.c
include/itemapi.h
- Removed hb_itemSetNLen() since it was superseded by hb_itemPutN?Len()
functions, these are more compact, faster, and have default value of the
parameters.
19990906-11:25 GMT+1 Antonio Linares <alinares@fivetech.com>
* source/rtl/tbrowse.prg
* Fixes on Stabilize() method

1
harbour/include/itemapi.h
View File

@@ -59,7 +59,6 @@ extern double hb_itemGetND ( PHB_ITEM pItem );
extern int hb_itemGetNI ( PHB_ITEM pItem );
extern long hb_itemGetNL ( PHB_ITEM pItem );
extern void hb_itemGetNLen ( PHB_ITEM pItem, WORD * pwWidth, WORD * pwDecimal );
extern void hb_itemSetNLen ( PHB_ITEM pItem, WORD wWidth, WORD wDecimal );
extern PHB_ITEM hb_itemNew ( PHB_ITEM pNull );
extern PHB_ITEM hb_itemParam ( WORD wParam );
extern PHB_ITEM hb_itemPutC ( PHB_ITEM pItem, char * szText );

1
harbour/source/compiler/harbour.y
View File

@@ -389,6 +389,7 @@ static const char * _szReservedFun[] = {
"SECONDS" ,
"SELECT" ,
"SETPOS" ,
"SETPOSBS" ,
"SPACE" ,
"SQRT" ,
"STR" ,

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

@@ -393,11 +393,10 @@ BOOL hb_arrayFill( PHB_ITEM pArray, PHB_ITEM pValue, ULONG ulStart, ULONG ulCoun
ULONG hb_arrayScan( PHB_ITEM pArray, PHB_ITEM pValue, ULONG ulStart, ULONG ulCount )
{
if( IS_ARRAY( pArray ) && ! IS_NIL( pValue ) )
if( IS_ARRAY( pArray ) )
{
PBASEARRAY pBaseArray = pArray->item.asArray.value;
ULONG ulLen = pBaseArray->ulLen;
BOOL bFound = FALSE;
if( ulStart == 0 ) /* if parameter is missing */
ulStart = 1;
@@ -408,56 +407,76 @@ ULONG hb_arrayScan( PHB_ITEM pArray, PHB_ITEM pValue, ULONG ulStart, ULONG ulCou
if( ulStart + ulCount > ulLen ) /* check range */
ulCount = ulLen - ulStart + 1;
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
PHB_ITEM pItem = pBaseArray->pItems + ulStart;
/* Make separate search loops for different types to find, so that
the loop can be faster. */
if( pValue->type == IT_BLOCK )
if( IS_BLOCK( pValue ) )
{
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
hb_vmPushSymbol( &symEval );
hb_vmPush( pValue );
hb_vmPush( pItem );
hb_vmPush( pBaseArray->pItems + ulStart );
hb_vmDo( 1 );
if( IS_LOGICAL( &stack.Return ) &&
stack.Return.item.asLogical.value )
bFound = TRUE;
if( IS_LOGICAL( &stack.Return ) && stack.Return.item.asLogical.value )
return ulStart + 1; /* arrays start from 1 */
}
else
}
else if( IS_STRING( pValue ) )
{
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
if( pValue->type == pItem->type )
{
switch( pItem->type )
{
case IT_INTEGER :
bFound = ( pValue->item.asInteger.value == pItem->item.asInteger.value );
break;
PHB_ITEM pItem = pBaseArray->pItems + ulStart;
case IT_LONG :
bFound = ( pValue->item.asLong.value == pItem->item.asLong.value );
break;
case IT_DOUBLE :
bFound = ( pValue->item.asDouble.value == pItem->item.asDouble.value );
break;
case IT_DATE :
bFound = ( pValue->item.asDate.value == pItem->item.asDouble.value );
break;
case IT_LOGICAL :
bFound = ( pValue->item.asLogical.value == pItem->item.asLogical.value );
break;
case IT_STRING :
bFound = ( hb_itemStrCmp( pValue, pItem, FALSE ) == 0 );
break;
}
}
if( IS_STRING( pItem ) && hb_itemStrCmp( pValue, pItem, FALSE ) == 0 )
return ulStart + 1;
}
}
else if( IS_NUMERIC( pValue ) )
{
double dValue = hb_itemGetND( pValue );
if( bFound )
return ulStart + 1; /* arrays start from 1 */
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
PHB_ITEM pItem = pBaseArray->pItems + ulStart;
if( IS_NUMERIC( pItem ) && hb_itemGetND( pItem ) == dValue )
return ulStart + 1;
}
}
else if( IS_DATE( pValue ) )
{
/* NOTE: This is correct: Get the date as a long value. */
LONG lValue = hb_itemGetNL( pValue );
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
PHB_ITEM pItem = pBaseArray->pItems + ulStart;
if( IS_DATE( pItem ) && hb_itemGetNL( pItem ) == lValue )
return ulStart + 1;
}
}
else if( IS_LOGICAL( pValue ) )
{
BOOL bValue = hb_itemGetL( pValue ); /* NOTE: This is correct: Get the date as a long value. */
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
PHB_ITEM pItem = pBaseArray->pItems + ulStart;
if( IS_LOGICAL( pItem ) && hb_itemGetL( pItem ) == bValue )
return ulStart + 1;
}
}
else if( IS_NIL( pValue ) )
{
for( ulStart--; ulCount > 0; ulCount--, ulStart++ )
{
if( IS_NIL( pBaseArray->pItems + ulStart ) )
return ulStart + 1;
}
}
}

850
harbour/source/rtl/classes.c
View File

@@ -74,7 +74,7 @@ typedef struct
static PCLASS s_pClasses = NULL;
static WORD s_wClasses = 0;
static PMETHOD s_pMethod = NULL;
static PMETHOD s_pMethod = NULL; /* TOFIX: The object engine is not thread safe because of this. */
static PHB_DYNS s_msgClassName = NULL;
static PHB_DYNS s_msgClassH = NULL;
static PHB_DYNS s_msgEval = NULL;
@@ -95,12 +95,209 @@ static HARBOUR hb___msgClsName( void );
static HARBOUR hb___msgClsSel( void );
static HARBOUR hb___msgSuper( void );
static HARBOUR hb___msgEvalInline( void );
static HARBOUR hb___msgEval( void );
static HARBOUR hb___msgVirtual( void );
static HARBOUR hb___msgGetClsData( void );
static HARBOUR hb___msgSetClsData( void );
static HARBOUR hb___msgGetData( void );
static HARBOUR hb___msgSetData( void );
/* ================================================ */
/*
* hb_clsDictRealloc( PCLASS )
*
* Realloc (widen) class
*/
static void hb_clsDictRealloc( PCLASS pClass )
{
/* TODO: Implement it for very large classes */
if( pClass )
hb_errInternal( 9999, "classes.c hb_clsDictRealloc() not implemented yet", NULL, NULL );
}
/*
* hb_clsRelease( <pClass> )
*
* Release a class from memory
*/
static void hb_clsRelease( PCLASS pClass )
{
WORD wAt;
WORD wLimit = pClass->wHashKey * BUCKET;
PMETHOD pMeth = pClass->pMethods;
for( wAt = 0; wAt < wLimit; wAt++, pMeth++ ) /* Release initializers */
if( pMeth->pInitValue && pMeth->wData > pClass->wDataFirst )
hb_itemRelease( pMeth->pInitValue );
hb_xfree( pClass->szName );
hb_xfree( pClass->pMethods );
hb_itemRelease( pClass->pClassDatas );
hb_itemRelease( pClass->pInlines );
}
/*
* hb_clsReleaseAll()
*
* Release all classes
*/
void hb_clsReleaseAll( void )
{
WORD w;
for( w = 0; w < s_wClasses; w++ )
hb_clsRelease( s_pClasses + w );
if( s_pClasses )
hb_xfree( s_pClasses );
}
/* ================================================ */
/*
* <szName> = hb_objGetClsName( pObject )
*
* Get the class name of an object
*
*/
char * hb_objGetClsName( PHB_ITEM pObject )
{
char * szClassName;
if( IS_ARRAY( pObject ) )
{
if( ! pObject->item.asArray.value->wClass )
szClassName = "ARRAY";
else
szClassName =
( s_pClasses + pObject->item.asArray.value->wClass - 1 )->szName;
}
else /* built in types */
{
switch( pObject->type )
{
case IT_NIL:
szClassName = "NIL";
break;
case IT_STRING:
szClassName = "CHARACTER";
break;
case IT_BLOCK:
szClassName = "BLOCK";
break;
case IT_SYMBOL:
szClassName = "SYMBOL";
break;
case IT_DATE:
szClassName = "DATE";
break;
case IT_INTEGER:
case IT_LONG:
case IT_DOUBLE:
szClassName = "NUMERIC";
break;
case IT_LOGICAL:
szClassName = "LOGICAL";
break;
default:
szClassName = "UNKNOWN";
break;
}
}
return szClassName;
}
/*
* <pFunc> = hb_objGetMethod( <pObject>, <pMessage> )
*
* Internal function to the function pointer of a message of an object
*/
PHB_FUNC hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pMessage )
{
WORD wClass;
PHB_DYNS pMsg = pMessage->pDynSym;
if( pObject->type == IT_ARRAY )
wClass = pObject->item.asArray.value->wClass;
else
wClass = 0;
if( wClass && wClass <= s_wClasses )
{
PCLASS pClass = &s_pClasses[ wClass - 1 ];
WORD wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET;
WORD wMask = pClass->wHashKey * BUCKET;
WORD wLimit = wAt ? ( wAt - 1 ) : ( wMask - 1 );
s_pMethod = NULL; /* Current method pointer */
while( wAt != wLimit )
{
if( pClass->pMethods[ wAt ].pMessage == pMsg )
{
s_pMethod = pClass->pMethods + wAt;
return s_pMethod->pFunction;
}
wAt++;
if( wAt == wMask )
wAt = 0;
}
}
if( s_msgClassName == NULL )
{
s_msgClassName = hb_dynsymGet( "CLASSNAME" ); /* Standard messages */
s_msgClassH = hb_dynsymGet( "CLASSH" ); /* Not present in classdef. */
s_msgClassSel = hb_dynsymGet( "CLASSSEL" );
s_msgEval = hb_dynsymGet( "EVAL" );
}
if( pMsg == s_msgClassName )
return hb___msgClsName;
else if( pMsg == s_msgClassH )
return hb___msgClsH;
else if( pMsg == s_msgClassSel )
return hb___msgClsSel;
else if( pMsg == s_msgEval )
return hb___msgEval;
return NULL;
}
/*
* <uPtr> = hb_objHasMsg( <pObject>, <szString> )
*
* Check whether <szString> is an existing message for object.
*
* <uPtr> should be read as a boolean
*/
ULONG hb_objHasMsg( PHB_ITEM pObject, char *szString )
{
PHB_SYMB pMessage = hb_dynsymGet( szString )->pSymbol;
return ( ULONG ) hb_objGetMethod( pObject, pMessage );
} /* Get funcptr of message */
/* ================================================ */
/*
* __clsAddMsg( <hClass>, <cMessage>, <pFunction>, <nType>, [xInit] )
*
@@ -329,17 +526,6 @@ HARBOUR HB___CLSDELMSG( void )
}
/*
* <hClass> := <obj>:ClassH()
*
* Returns class handle of <obj>
*/
static HARBOUR hb___msgClsH( void )
{
hb_retni( ( stack.pBase + 1 )->item.asArray.value->wClass );
}
/*
* <oNewObject> := __clsInst( <hClass> )
*
@@ -365,6 +551,7 @@ HARBOUR HB___CLSINST( void )
}
}
/*
* __clsModMsg( <oObj>, <cMessage>, <pFunc> )
*
@@ -417,24 +604,6 @@ HARBOUR HB___CLSMODMSG( void )
}
/*
* <cClassName> := <obj>:ClassName()
*
* Return class name of <obj>. Can also be used for all types.
*/
static HARBOUR hb___msgClsName( void )
{
PHB_ITEM pItemRef;
if( IS_BYREF( stack.pBase + 1 ) ) /* Variables by reference */
pItemRef = hb_itemUnRef( stack.pBase + 1 );
else
pItemRef = stack.pBase + 1;
hb_retc( hb_objGetClsName( pItemRef ) );
}
/*
* <cClassName> := ClassName( <hClass> )
*
@@ -463,256 +632,6 @@ HARBOUR HB___OBJGETCLSNAME( void )
}
/*
* <aMessages> := <obj>:ClassSel()
*
* Returns all the messages in <obj>
*/
static HARBOUR hb___msgClsSel( void )
{
WORD wClass = IS_ARRAY( stack.pBase + 1 ) ?
( stack.pBase + 1 )->item.asArray.value->wClass : 0;
/* Get class word */
PHB_ITEM pReturn = hb_itemNew( NULL );
if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) )
{ /* Variables by reference */
PHB_ITEM pItemRef = hb_itemUnRef( stack.pBase + 1 );
if( IS_ARRAY( pItemRef ) )
wClass = pItemRef->item.asArray.value->wClass;
}
if( wClass && wClass <= s_wClasses )
{
PCLASS pClass = &s_pClasses[ wClass - 1 ];
WORD wLimit = pClass->wHashKey * BUCKET; /* Number of Hash keys */
WORD wPos = 0;
WORD wAt;
hb_itemRelease( pReturn );
pReturn = hb_itemArrayNew( pClass->wMethods );
/* Create a transfer array */
for( wAt = 0; wAt < wLimit ; wAt++ )
{
PHB_DYNS pMessage = ( PHB_DYNS ) pClass->pMethods[ wAt ].pMessage;
if( pMessage ) /* Hash Entry used ? */
{
PHB_ITEM pItem = hb_itemPutC( NULL, pMessage->pSymbol->szName );
/* Add to array */
hb_itemArrayPut( pReturn, ++wPos, pItem );
hb_itemRelease( pItem );
}
}
}
hb_itemReturn( pReturn );
hb_itemRelease( pReturn );
}
/*
* hb_clsDictRealloc( PCLASS )
*
* Realloc (widen) class
*/
static void hb_clsDictRealloc( PCLASS pClass )
{
/* TODO: Implement it for very large classes */
if( pClass )
hb_errInternal( 9999, "classes.c hb_clsDictRealloc() not implemented yet", NULL, NULL );
}
/*
* __msgEvalInline()
*
* Internal function executed for inline methods
*/
static HARBOUR hb___msgEvalInline( void )
{
HB_ITEM block;
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
WORD w;
hb_arrayGet( s_pClasses[ wClass - 1 ].pInlines, s_pMethod->wData, &block );
hb_vmPushSymbol( &symEval );
hb_vmPush( &block );
hb_vmPush( stack.pBase + 1 ); /* Push self */
for( w = 1; w <= hb_pcount(); w++ )
hb_vmPush( hb_param( w, IT_ANY ) );
hb_vmDo( hb_pcount() + 1 ); /* Self is also an argument */
hb_itemClear( &block ); /* Release block */
}
/*
* <szName> = hb_objGetClsName( pObject )
*
* Get the class name of an object
*
*/
char * hb_objGetClsName( PHB_ITEM pObject )
{
char * szClassName;
if( IS_ARRAY( pObject ) )
{
if( ! pObject->item.asArray.value->wClass )
szClassName = "ARRAY";
else
szClassName =
( s_pClasses + pObject->item.asArray.value->wClass - 1 )->szName;
}
else /* built in types */
{
switch( pObject->type )
{
case IT_NIL:
szClassName = "NIL";
break;
case IT_STRING:
szClassName = "CHARACTER";
break;
case IT_BLOCK:
szClassName = "BLOCK";
break;
case IT_SYMBOL:
szClassName = "SYMBOL";
break;
case IT_DATE:
szClassName = "DATE";
break;
case IT_INTEGER:
case IT_LONG:
case IT_DOUBLE:
szClassName = "NUMERIC";
break;
case IT_LOGICAL:
szClassName = "LOGICAL";
break;
default:
szClassName = "UNKNOWN";
break;
}
}
return szClassName;
}
/*
* __msgGetClsData()
*
* Internal function to return a CLASSDATA
*/
static HARBOUR hb___msgGetClsData( void )
{
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
if( wClass && wClass <= s_wClasses )
hb_arrayGet( s_pClasses[ wClass - 1 ].pClassDatas, s_pMethod->wData, &stack.Return );
}
/*
* __msgGetData()
*
* Internal function to return a DATA
*/
static HARBOUR hb___msgGetData( void )
{
PHB_ITEM pObject = stack.pBase + 1;
WORD wIndex = s_pMethod->wData;
if( wIndex > ( WORD ) hb_arrayLen( pObject ) )
/* Resize needed */
hb_arraySize( pObject, wIndex ); /* Make large enough */
hb_arrayGet( pObject, wIndex, &stack.Return );
}
/*
* <pFunc> = hb_objGetMethod( <pObject>, <pMessage> )
*
* Internal function to the function pointer of a message of an object
*/
PHB_FUNC hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pMessage )
{
WORD wClass;
PHB_DYNS pMsg = pMessage->pDynSym;
if( pObject->type == IT_OBJECT )
wClass = pObject->item.asArray.value->wClass;
else
wClass = 0;
if( ! s_msgClassName )
{
s_msgClassName = hb_dynsymGet( "CLASSNAME" ); /* Standard messages */
s_msgClassH = hb_dynsymGet( "CLASSH" ); /* Not present in classdef. */
s_msgClassSel = hb_dynsymGet( "CLASSSEL" );
s_msgEval = hb_dynsymGet( "EVAL" );
}
if( wClass && wClass <= s_wClasses )
{
PCLASS pClass = &s_pClasses[ wClass - 1 ];
WORD wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET;
WORD wMask = pClass->wHashKey * BUCKET;
WORD wLimit = wAt ? ( wAt - 1 ) : ( wMask - 1 );
s_pMethod = NULL; /* Current method pointer */
while( wAt != wLimit )
{
if( pClass->pMethods[ wAt ].pMessage == pMsg )
{
s_pMethod = pClass->pMethods + wAt;
return s_pMethod->pFunction;
}
wAt++;
if( wAt == wMask )
wAt = 0;
}
}
if( pMsg == s_msgClassName )
return hb___msgClsName;
else if( pMsg == s_msgClassH )
return hb___msgClsH;
else if( pMsg == s_msgClassSel )
return hb___msgClsSel;
else if( pMsg == s_msgEval )
return hb___msgEvalInline;
return NULL;
}
/*
* <uPtr> = hb_objHasMsg( <pObject>, <szString> )
*
* Check whether <szString> is an existing message for object.
*
* <uPtr> should be read as a boolean
*/
ULONG hb_objHasMsg( PHB_ITEM pObject, char *szString )
{
PHB_SYMB pMessage = hb_dynsymGet( szString )->pSymbol;
return ( ULONG ) hb_objGetMethod( pObject, pMessage );
} /* Get funcptr of message */
/*
* <lRet> := __objHasMsg( <oObj>, <cSymbol> )
*
@@ -778,42 +697,264 @@ HARBOUR HB___OBJSENDMSG( void )
/*
* hb_clsRelease( <pClass> )
* <hClass> := __clsInstSuper( <cName> )
*
* Release a class from memory
* Instance super class and return class handle
*/
static void hb_clsRelease( PCLASS pClass )
HARBOUR HB___CLSINSTSUPER( void )
{
WORD wAt;
WORD wLimit = pClass->wHashKey * BUCKET;
PMETHOD pMeth = pClass->pMethods;
PHB_ITEM pString = hb_param( 1, IT_STRING );
BOOL bFound = FALSE;
for( wAt = 0; wAt < wLimit; wAt++, pMeth++ ) /* Release initializers */
if( pMeth->pInitValue && pMeth->wData > pClass->wDataFirst )
hb_itemRelease( pMeth->pInitValue );
if( pString )
{
PHB_DYNS pDynSym = hb_dynsymFind( pString->item.asString.value );
hb_xfree( pClass->szName );
hb_xfree( pClass->pMethods );
if( pDynSym ) /* Find function */
{
WORD w;
hb_itemRelease( pClass->pClassDatas );
hb_itemRelease( pClass->pInlines );
hb_vmPushSymbol( pDynSym->pSymbol ); /* Push function name */
hb_vmPushNil();
hb_vmFunction( 0 ); /* Execute super class */
if( !IS_OBJECT( &stack.Return ) )
{
hb_errRT_BASE( EG_ARG, 3002, "Super class does not return an object", "__CLSINSTSUPER" );
}
for( w = 0; !bFound && w < s_wClasses; w++ )
{ /* Locate the entry */
if( !hb_stricmp( pString->item.asString.value, s_pClasses[ w ].szName ) )
{
hb_retni( w + 1 ); /* Entry + 1 = hb___msgClsH */
bFound = TRUE;
}
}
}
else
hb_errRT_BASE( EG_ARG, 3003, "Cannot find super class", "__CLSINSTSUPER" );
}
if( !bFound )
hb_retni( 0 );
}
/*
* hb_clsReleaseAll()
* <nSeq> = __cls_CntClsData( <hClass> )
*
* Release all classes
* Return number of class datas
*/
void hb_clsReleaseAll( void )
HARBOUR HB___CLS_CNTCLSDATA( void )
{
WORD w;
WORD wClass = hb_parnl( 1 );
for( w = 0; w < s_wClasses; w++ )
hb_clsRelease( s_pClasses + w );
if( wClass )
{
PCLASS pClass = &s_pClasses[ wClass - 1 ];
hb_retni( hb_arrayLen( pClass->pClassDatas ) );
}
}
if( s_pClasses )
hb_xfree( s_pClasses );
/*
* <nSeq> = __cls_CntData( <hClass> )
*
* Return number of datas
*/
HARBOUR HB___CLS_CNTDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( s_pClasses[ wClass - 1 ].wDatas );
}
/*
* <nSeq> = __cls_DecData( <hClass> )
*
* Return number of datas and decrease
*/
HARBOUR HB___CLS_DECDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( s_pClasses[ wClass - 1 ].wDatas-- );
}
/*
* <nSeq> = __cls_IncData( <hClass> )
*
* Return number of datas and decrease
*/
HARBOUR HB___CLS_INCDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( ++s_pClasses[ wClass - 1 ].wDatas );
}
/* ================================================ */
/*
* <hClass> := <obj>:ClassH()
*
* Returns class handle of <obj>
*/
static HARBOUR hb___msgClsH( void )
{
if( IS_ARRAY( stack.pBase + 1 ) )
hb_retni( ( stack.pBase + 1 )->item.asArray.value->wClass );
else
hb_retni( 0 );
}
/*
* <cClassName> := <obj>:ClassName()
*
* Return class name of <obj>. Can also be used for all types.
*/
static HARBOUR hb___msgClsName( void )
{
PHB_ITEM pItemRef;
if( IS_BYREF( stack.pBase + 1 ) ) /* Variables by reference */
pItemRef = hb_itemUnRef( stack.pBase + 1 );
else
pItemRef = stack.pBase + 1;
hb_retc( hb_objGetClsName( pItemRef ) );
}
/*
* <aMessages> := <obj>:ClassSel()
*
* Returns all the messages in <obj>
*/
static HARBOUR hb___msgClsSel( void )
{
WORD wClass = IS_ARRAY( stack.pBase + 1 ) ?
( stack.pBase + 1 )->item.asArray.value->wClass : 0;
/* Get class word */
PHB_ITEM pReturn = hb_itemNew( NULL );
if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) )
{ /* Variables by reference */
PHB_ITEM pItemRef = hb_itemUnRef( stack.pBase + 1 );
if( IS_ARRAY( pItemRef ) )
wClass = pItemRef->item.asArray.value->wClass;
}
if( wClass && wClass <= s_wClasses )
{
PCLASS pClass = &s_pClasses[ wClass - 1 ];
WORD wLimit = pClass->wHashKey * BUCKET; /* Number of Hash keys */
WORD wPos = 0;
WORD wAt;
hb_itemRelease( pReturn );
pReturn = hb_itemArrayNew( pClass->wMethods );
/* Create a transfer array */
for( wAt = 0; wAt < wLimit ; wAt++ )
{
PHB_DYNS pMessage = ( PHB_DYNS ) pClass->pMethods[ wAt ].pMessage;
if( pMessage ) /* Hash Entry used ? */
{
PHB_ITEM pItem = hb_itemPutC( NULL, pMessage->pSymbol->szName );
/* Add to array */
hb_itemArrayPut( pReturn, ++wPos, pItem );
hb_itemRelease( pItem );
}
}
}
hb_itemReturn( pReturn );
hb_itemRelease( pReturn );
}
/*
* __msgEvalInline()
*
* Internal function executed for inline methods
*/
static HARBOUR hb___msgEvalInline( void )
{
HB_ITEM block;
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
WORD w;
hb_arrayGet( s_pClasses[ wClass - 1 ].pInlines, s_pMethod->wData, &block );
hb_vmPushSymbol( &symEval );
hb_vmPush( &block );
hb_vmPush( stack.pBase + 1 ); /* Push self */
for( w = 1; w <= hb_pcount(); w++ )
hb_vmPush( hb_param( w, IT_ANY ) );
hb_vmDo( hb_pcount() + 1 ); /* Self is also an argument */
hb_itemClear( &block ); /* Release block */
}
/*
* __msgEval()
*
* Internal function for the internal EVAL method.
*/
static HARBOUR hb___msgEval( void )
{
if( IS_BLOCK( stack.pBase + 1 ) )
{
USHORT uiParam;
hb_vmPushSymbol( &symEval );
hb_vmPush( stack.pBase + 1 ); /* Push block */
for( uiParam = 1; uiParam <= hb_pcount(); uiParam++ )
hb_vmPush( hb_param( uiParam, IT_ANY ) );
hb_vmDo( hb_pcount() ); /* Self is also an argument */
}
else
hb_errRT_BASE( EG_NOMETHOD, 1004, NULL, "EVAL" );
}
/*
* __msgGetClsData()
*
* Internal function to return a CLASSDATA
*/
static HARBOUR hb___msgGetClsData( void )
{
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
if( wClass && wClass <= s_wClasses )
hb_arrayGet( s_pClasses[ wClass - 1 ].pClassDatas, s_pMethod->wData, &stack.Return );
}
/*
* __msgGetData()
*
* Internal function to return a DATA
*/
static HARBOUR hb___msgGetData( void )
{
PHB_ITEM pObject = stack.pBase + 1;
WORD wIndex = s_pMethod->wData;
if( wIndex > ( WORD ) hb_arrayLen( pObject ) )
/* Resize needed */
hb_arraySize( pObject, wIndex ); /* Make large enough */
hb_arrayGet( pObject, wIndex, &stack.Return );
}
@@ -874,9 +1015,11 @@ static HARBOUR hb___msgSetData( void )
PHB_ITEM pReturn = stack.pBase + 2;
WORD wIndex = s_pMethod->wData;
/* Resize needed ? */
if( wIndex > ( WORD ) hb_arrayLen( pObject ) )
/* Resize needed */
hb_arraySize( pObject, wIndex ); /* Make large enough */
/* Make large enough */
hb_arraySize( pObject, wIndex );
hb_arraySet( pObject, wIndex, pReturn );
hb_itemCopy( &stack.Return, pReturn );
}
@@ -888,104 +1031,3 @@ static HARBOUR hb___msgVirtual( void )
hb_ret();
}
/*
* <hClass> := __clsInstSuper( <cName> )
*
* Instance super class and return class handle
*/
HARBOUR HB___CLSINSTSUPER( void )
{
PHB_ITEM pString = hb_param( 1, IT_STRING );
BOOL bFound = FALSE;
if( pString )
{
PHB_DYNS pDynSym = hb_dynsymFind( pString->item.asString.value );
if( pDynSym ) /* Find function */
{
WORD w;
hb_vmPushSymbol( pDynSym->pSymbol ); /* Push function name */
hb_vmPushNil();
hb_vmFunction( 0 ); /* Execute super class */
if( !IS_OBJECT( &stack.Return ) )
{
hb_errRT_BASE( EG_ARG, 3002, "Super class does not return an object", "__CLSINSTSUPER" );
}
for( w = 0; !bFound && w < s_wClasses; w++ )
{ /* Locate the entry */
if( !hb_stricmp( pString->item.asString.value, s_pClasses[ w ].szName ) )
{
hb_retni( w + 1 ); /* Entry + 1 = hb___msgClsH */
bFound = TRUE;
}
}
}
else
hb_errRT_BASE( EG_ARG, 3003, "Cannot find super class", "__CLSINSTSUPER" );
}
if( !bFound )
hb_retni( 0 );
}
/*
* <nSeq> = __cls_CntClsData( <hClass> )
*
* Return number of class datas
*/
HARBOUR HB___CLS_CNTCLSDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
{
PCLASS pClass = &s_pClasses[ wClass - 1 ];
hb_retni( hb_arrayLen( pClass->pClassDatas ) );
}
}
/*
* <nSeq> = __cls_CntData( <hClass> )
*
* Return number of datas
*/
HARBOUR HB___CLS_CNTDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( s_pClasses[ wClass - 1 ].wDatas );
}
/*
* <nSeq> = __cls_DecData( <hClass> )
*
* Return number of datas and decrease
*/
HARBOUR HB___CLS_DECDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( s_pClasses[ wClass - 1 ].wDatas-- );
}
/*
* <nSeq> = __cls_IncData( <hClass> )
*
* Return number of datas and decrease
*/
HARBOUR HB___CLS_INCDATA( void )
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( ++s_pClasses[ wClass - 1 ].wDatas );
}

55
harbour/source/rtl/do.c
View File

@@ -84,9 +84,9 @@
*/
HARBOUR HB_DO( void )
{
int iPCount = hb_pcount();
USHORT uiPCount = hb_pcount();
if( iPCount >= 1 )
if( uiPCount >= 1 )
{
PHB_ITEM pItem = hb_param( 1, IT_ANY );
@@ -96,41 +96,66 @@ HARBOUR HB_DO( void )
if( pDynSym )
{
int i;
USHORT uiParam;
hb_vmPushSymbol( pDynSym->pSymbol );
hb_vmPushNil();
for( i = 2; i <= iPCount; i++ )
hb_vmPush( hb_param( i, IT_ANY ) );
hb_vmDo( iPCount - 1 );
for( uiParam = 2; uiParam <= uiPCount; uiParam++ )
hb_vmPush( hb_param( uiParam, IT_ANY ) );
hb_vmDo( uiPCount - 1 );
}
else
hb_errRT_BASE( EG_NOFUNC, 1001, NULL, pItem->item.asString.value );
}
else if( IS_BLOCK( pItem ) )
{
int i;
USHORT uiParam;
hb_vmPushSymbol( &symEval );
hb_vmPush( pItem );
for( i = 2; i <= iPCount; i++ )
hb_vmPush( hb_param( i, IT_ANY ) );
hb_vmDo( iPCount - 1 );
for( uiParam = 2; uiParam <= uiPCount; uiParam++ )
hb_vmPush( hb_param( uiParam, IT_ANY ) );
hb_vmDo( uiPCount - 1 );
}
else if( IS_SYMBOL( pItem ) )
{
int i;
USHORT uiParam;
hb_vmPushSymbol( pItem->item.asSymbol.value );
hb_vmPushNil();
for( i = 2; i <= iPCount; i++ )
hb_vmPush( hb_param( i, IT_ANY ) );
hb_vmDo( iPCount - 1 );
for( uiParam = 2; uiParam <= uiPCount; uiParam++ )
hb_vmPush( hb_param( uiParam, IT_ANY ) );
hb_vmDo( uiPCount - 1 );
}
else
hb_errRT_BASE( EG_ARG, 3012, NULL, "DO" );
}
else
hb_errRT_BASE( EG_ARG, 3012, NULL, "DO" );
hb_errRT_BASE( EG_ARGCOUNT, 3000, NULL, "DO" );
}
HARBOUR HB_EVAL( void )
{
USHORT uiPCount = hb_pcount();
if( uiPCount >= 1 )
{
PHB_ITEM pItem = hb_param( 1, IT_BLOCK );
if( pItem )
{
USHORT uiParam;
hb_vmPushSymbol( &symEval );
hb_vmPush( pItem );
for( uiParam = 2; uiParam <= uiPCount; uiParam++ )
hb_vmPush( hb_param( uiParam, IT_ANY ) );
hb_vmDo( uiPCount - 1 );
}
else
hb_errRT_BASE( EG_NOMETHOD, 1004, NULL, "EVAL" );
}
else
hb_errRT_BASE( EG_ARGCOUNT, 3000, NULL, "EVAL" ); /* NOTE: Clipper catches this at compile time! */
}

25
harbour/source/rtl/itemapi.c
View File

@@ -32,7 +32,6 @@
hb_itemGetCPtr()
hb_itemGetCLen()
hb_itemGetNLen()
hb_itemSetNLen()
hb_itemPutNDLen()
hb_itemPutNILen()
hb_itemPutNLLen()
@@ -680,30 +679,6 @@ void hb_itemGetNLen( PHB_ITEM pItem, WORD * pwWidth, WORD * pwDecimal )
}
}
void hb_itemSetNLen( PHB_ITEM pItem, WORD wWidth, WORD wDecimal )
{
if( pItem
&& wWidth > 0 && wWidth <= 99
&& ( wDecimal == 0 || wDecimal < ( wWidth - 1 ) ) )
{
switch( pItem->type )
{
case IT_DOUBLE:
pItem->item.asDouble.length = wWidth;
pItem->item.asDouble.decimal = wDecimal;
break;
case IT_LONG:
pItem->item.asLong.length = wWidth;
break;
case IT_INTEGER:
pItem->item.asInteger.length = wWidth;
break;
}
}
}
ULONG hb_itemSize( PHB_ITEM pItem )
{
if( pItem )

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

@@ -1039,14 +1039,14 @@ HARBOUR hb_vmDoBlock( void )
/* set the current line number to a line where the codeblock was defined
*/
wLine =stack.pBase->item.asSymbol.lineno;
wLine = stack.pBase->item.asSymbol.lineno;
stack.pBase->item.asSymbol.lineno = pBlock->item.asBlock.lineno;
hb_codeblockEvaluate( pBlock );
/* restore stack pointers */
stack.pBase = stack.pItems + wStackBase;
stack.pBase->item.asSymbol.lineno =wLine;
stack.pBase->item.asSymbol.lineno = wLine;
HB_DEBUG( "End of DoBlock\n" );
}
@@ -2789,33 +2789,6 @@ void hb_vmForceLink( void )
/* ----------------------------- */
/* TODO: Put these to /source/rtl/?.c */
HARBOUR HB_EVAL( void )
{
WORD wPCount = hb_pcount();
if( wPCount >= 1 )
{
PHB_ITEM pBlock = hb_param( 1, IT_BLOCK );
if( pBlock )
{
WORD wParam;
hb_vmPushSymbol( &symEval );
hb_vmPush( pBlock );
for( wParam = 2; wParam <= wPCount; wParam++ )
hb_vmPush( hb_param( wParam, IT_ANY ) );
hb_vmDo( wPCount - 1 );
}
else
hb_errInternal( 9999, "Not a valid codeblock on EVAL", NULL, NULL );
}
else
hb_errRT_BASE( EG_ARGCOUNT, 3000, NULL, "EVAL" ); /* NOTE: Clipper catches this at compile time! */
}
HARBOUR HB_LEN( void )
{
if( hb_pcount() == 1 )

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

@@ -60,8 +60,9 @@ STATIC s_cNewLine
STATIC s_nCount
STATIC s_lShowAll
STATIC s_lShortcut
STATIC s_aSkipList
FUNCTION Main( cPar1 )
FUNCTION Main( cPar1, cPar2 )
/* NOTE: Some basic values we may need for some tests.
( passing by reference, avoid preprocessor bugs, etc. ) */
@@ -84,8 +85,31 @@ FUNCTION Main( cPar1 )
LOCAL loObject := ErrorNew()
LOCAL luNIL := NIL
LOCAL lbBlock := {|| NIL }
LOCAL lbBlockC := {|| "(string)" }
LOCAL laArray := { 9898 }
LOCAL laAllTypes := {;
lcString ,;
lcStringE ,;
lcStringZ ,;
lnIntZ ,;
lnDoubleZ ,;
lnIntP ,;
lnLongP ,;
lnDoubleP ,;
lnIntN ,;
lnLongN ,;
lnDoubleN ,;
lnDoubleI ,;
ldDateE ,;
llFalse ,;
llTrue ,;
loObject ,;
luNIL ,;
lbBlock ,;
lbBlockC ,;
laArray }
MEMVAR mxNotHere
MEMVAR mcString
MEMVAR mcStringE
@@ -105,6 +129,7 @@ FUNCTION Main( cPar1 )
MEMVAR moObject
MEMVAR muNIL
MEMVAR mbBlock
MEMVAR mbBlockC
MEMVAR maArray
/* NOTE: mxNotHere intentionally not declared */
@@ -126,6 +151,7 @@ FUNCTION Main( cPar1 )
PRIVATE moObject := ErrorNew()
PRIVATE muNIL := NIL
PRIVATE mbBlock := {|| NIL }
PRIVATE mbBlockC := {|| "(string)" }
PRIVATE maArray := { 9898 }
/* Initialize test */
@@ -134,10 +160,16 @@ FUNCTION Main( cPar1 )
to make sure all error messages comes in the original English
language. */
/* SET LANGID TO EN */
SET DATE ANSI
SET CENTURY ON
SET EXACT OFF
IF cPar1 == NIL
cPar1 := ""
ENDIF
IF cPar2 == NIL
cPar2 := ""
ENDIF
/* NOTE: CA-Cl*pper PP fails on these
TEST_LINE( "1" .AND. "2" , "E BASE 1066 Argument error conditional " )
@@ -145,7 +177,7 @@ FUNCTION Main( cPar1 )
TEST_LINE( "A" > 1 , "E BASE 1075 Argument error > F:S" )
*/
TEST_BEGIN( cPar1 )
TEST_BEGIN( cPar1 + " " + cPar2 )
/* VALTYPE() */
@@ -226,6 +258,107 @@ FUNCTION Main( cPar1 )
TEST_LINE( ValType( @mbBlock ) , "U" )
TEST_LINE( ValType( @maArray ) , "U" )
/* Special internal messages */
/* Harbour compiler not yet handles these */
#ifndef __HARBOUR__
TEST_LINE( NIL:className , "NIL" )
TEST_LINE( "":className , "CHARACTER" )
TEST_LINE( 0:className , "NUMERIC" )
TEST_LINE( ctod( "" ):className , "DATE" )
TEST_LINE( .F.:className , "LOGICAL" )
TEST_LINE( {|| nil }:className , "BLOCK" )
TEST_LINE( {}:className , "ARRAY" )
TEST_LINE( ErrorNew():className , "ERROR" )
TEST_LINE( NIL:classH , 0 )
TEST_LINE( "":classH , 0 )
TEST_LINE( 0:classH , 0 )
TEST_LINE( ctod( "" ):classH , 0 )
TEST_LINE( .F.:classH , 0 )
TEST_LINE( {|| nil }:classH , 0 )
TEST_LINE( {}:classH , 0 )
TEST_LINE( ErrorNew():classH > 0 , .T. )
#endif )
/* Harbour compiler not yet handles these */
#ifndef __HARBOUR__
TEST_LINE( luNIL:className , "NIL" )
#endif
TEST_LINE( lcString:className , "CHARACTER" )
TEST_LINE( lnIntP:className , "NUMERIC" )
TEST_LINE( ldDateE:className , "DATE" )
TEST_LINE( llFalse:className , "LOGICAL" )
TEST_LINE( lbBlock:className , "BLOCK" )
TEST_LINE( laArray:className , "ARRAY" )
TEST_LINE( loObject:className , "ERROR" )
/* Harbour compiler not yet handles these */
#ifndef __HARBOUR__
TEST_LINE( luNIL:classH , 0 )
#endif
TEST_LINE( lcString:classH , 0 )
TEST_LINE( lnIntP:classH , 0 )
TEST_LINE( ldDateE:classH , 0 )
TEST_LINE( llFalse:classH , 0 )
TEST_LINE( lbBlock:classH , 0 )
TEST_LINE( laArray:classH , 0 )
TEST_LINE( loObject:classH > 0 , .T. )
/* ASCAN() */
TEST_LINE( aScan() , 0 )
TEST_LINE( aScan( NIL ) , 0 )
TEST_LINE( aScan( "A" ) , 0 )
TEST_LINE( aScan( "A", "A" ) , 0 )
TEST_LINE( aScan( "A", {|| .F. } ) , 0 )
TEST_LINE( aScan( {1,2,3}, {|x| NIL } ) , 0 )
TEST_LINE( aScan( laAllTypes, lcString ) , 1 )
TEST_LINE( aScan( @laAllTypes, lcString ) , 0 )
TEST_LINE( aScan( laAllTypes, @lcString ) , 0 )
TEST_LINE( aScan( laAllTypes, lcStringE ) , 1 )
TEST_LINE( aScan( laAllTypes, lcStringZ ) , 3 )
TEST_LINE( aScan( laAllTypes, lnIntZ ) , 4 )
TEST_LINE( aScan( laAllTypes, lnDoubleZ ) , 4 )
TEST_LINE( aScan( laAllTypes, lnIntP ) , 6 )
TEST_LINE( aScan( laAllTypes, lnLongP ) , 7 )
TEST_LINE( aScan( laAllTypes, lnDoubleP ) , 8 )
TEST_LINE( aScan( laAllTypes, lnIntN ) , 9 )
TEST_LINE( aScan( laAllTypes, lnLongN ) , 10 )
TEST_LINE( aScan( laAllTypes, lnDoubleN ) , 11 )
TEST_LINE( aScan( laAllTypes, lnDoubleI ) , 12 )
TEST_LINE( aScan( laAllTypes, ldDateE ) , 13 )
TEST_LINE( aScan( laAllTypes, llFalse ) , 14 )
TEST_LINE( aScan( laAllTypes, llTrue ) , 15 )
TEST_LINE( aScan( laAllTypes, loObject ) , 0 )
TEST_LINE( aScan( laAllTypes, luNIL ) , 17 )
TEST_LINE( aScan( laAllTypes, lbBlock ) , 0 )
TEST_LINE( aScan( laAllTypes, lbBlockC ) , 0 )
TEST_LINE( aScan( laAllTypes, laArray ) , 0 )
SET EXACT ON
TEST_LINE( aScan( laAllTypes, lcString ) , 1 )
TEST_LINE( aScan( laAllTypes, lcStringE ) , 2 )
TEST_LINE( aScan( laAllTypes, lcStringZ ) , 3 )
SET EXACT OFF
/* EVAL(), :EVAL */
TEST_LINE( Eval( NIL ) , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( Eval( 1 ) , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( Eval( @lbBlock ) , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( Eval( {|p1| p1 },"A","B") , "A" )
TEST_LINE( Eval( {|p1,p2| p1+p2 },"A","B") , "AB" )
TEST_LINE( Eval( {|p1,p2,p3| p1 },"A","B") , "A" )
/* Harbour compiler not yet handles these */
#ifndef __HARBOUR__
TEST_LINE( luNIL:Eval , "E BASE 1004 No exported method EVAL F:S" )
#endif
TEST_LINE( lcString:Eval , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( lnIntP:Eval , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( ldDateE:Eval , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( llFalse:Eval , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( lbBlock:Eval , NIL )
TEST_LINE( laArray:Eval , "E BASE 1004 No exported method EVAL F:S" )
TEST_LINE( loObject:Eval , "E BASE 1004 No exported method EVAL F:S" )
/* STOD() */
/* For these tests in CA-Cl*pper 5.2e the following native STOD() has
@@ -692,11 +825,39 @@ FUNCTION Main( cPar1 )
/* PADR() */
TEST_LINE( Pad(NIL, 5) , "" )
TEST_LINE( Pad(.T., 5) , "" )
TEST_LINE( Pad(10, 5) , "10 " )
TEST_LINE( Pad(10.2, 5) , "10.2 " )
TEST_LINE( Pad(100000, 8) , "100000 " )
TEST_LINE( Pad(100000, 8, "-") , "100000--" )
TEST_LINE( Pad(-100000, 8, "-") , "-100000-" )
TEST_LINE( Pad(SToD("19800101"), 12) , "1980.01.01 " )
TEST_LINE( Pad(Year(SToD("19800101")), 5) , "1980 " )
TEST_LINE( Pad(Day(SToD("19800101")), 5) , "1 " )
TEST_LINE( Pad(@lcString, 10) , "" )
TEST_LINE( Pad(lcString, @lnIntP) , "" )
TEST_LINE( Pad("abcdef", -5) , "" )
TEST_LINE( Pad("abcdef", 0) , "" )
TEST_LINE( Pad("abcdef", 5) , "abcde" )
TEST_LINE( Pad("abcdef", 10) , "abcdef " )
TEST_LINE( Pad("abcdef", 10, "1") , "abcdef1111" )
TEST_LINE( Pad("abcdef", 10, "12") , "abcdef1111" )
/* PADR() */
TEST_LINE( PadR(NIL, 5) , "" )
TEST_LINE( PadR(.T., 5) , "" )
TEST_LINE( PadR(10, 5) , "10 " )
TEST_LINE( PadR(10.2, 5) , "10.2 " )
TEST_LINE( PadR(100000, 8) , "100000 " )
TEST_LINE( PadR(100000, 8, "-") , "100000--" )
TEST_LINE( PadR(-100000, 8, "-") , "-100000-" )
TEST_LINE( PadR(SToD("19800101"), 12) , "1980.01.01 " )
TEST_LINE( PadR(Year(SToD("19800101")), 5) , "1980 " )
TEST_LINE( PadR(Day(SToD("19800101")), 5) , "1 " )
TEST_LINE( PadR(@lcString, 10) , "" )
TEST_LINE( PadR(lcString, @lnIntP) , "" )
TEST_LINE( PadR("abcdef", -5) , "" )
TEST_LINE( PadR("abcdef", 0) , "" )
TEST_LINE( PadR("abcdef", 5) , "abcde" )
@@ -709,8 +870,15 @@ FUNCTION Main( cPar1 )
TEST_LINE( PadL(NIL, 5) , "" )
TEST_LINE( PadL(.T., 5) , "" )
TEST_LINE( PadL(10, 5) , " 10" )
TEST_LINE( PadL(10.2, 5) , " 10.2" )
TEST_LINE( PadL(100000, 8) , " 100000" )
TEST_LINE( PadL(100000, 8, "-") , "--100000" )
TEST_LINE( PadL(-100000, 8, "-") , "--100000" )
TEST_LINE( PadL(SToD("19800101"), 12) , " 1980.01.01" )
TEST_LINE( PadL(Year(SToD("19800101")), 5) , " 1980" )
TEST_LINE( PadL(Day(SToD("19800101")), 5) , " 1" )
TEST_LINE( PadL(@lcString, 10) , "" )
TEST_LINE( PadL(lcString, @lnIntP) , "" )
TEST_LINE( PadL("abcdef", -5) , "" )
TEST_LINE( PadL("abcdef", 0) , "" )
TEST_LINE( PadL("abcdef", 5) , "abcde" ) /* QUESTION: CA-Cl*pper "bug", should return: "bcdef" ? */
@@ -723,8 +891,15 @@ FUNCTION Main( cPar1 )
TEST_LINE( PadC(NIL, 5) , "" )
TEST_LINE( PadC(.T., 5) , "" )
TEST_LINE( PadC(10, 5) , " 10 " )
TEST_LINE( PadC(10.2, 5) , "10.2 " )
TEST_LINE( PadC(100000, 8) , " 100000 " )
TEST_LINE( PadC(100000, 8, "-") , "-100000-" )
TEST_LINE( PadC(-100000, 8, "-") , "-100000-" )
TEST_LINE( PadC(SToD("19800101"), 12) , " 1980.01.01 " )
TEST_LINE( PadC(Year(SToD("19800101")), 5) , "1980 " )
TEST_LINE( PadC(Day(SToD("19800101")), 5) , " 1 " )
TEST_LINE( PadC(@lcString, 10) , "" )
TEST_LINE( PadC(lcString, @lnIntP) , "" )
TEST_LINE( PadC("abcdef", -5) , "" )
TEST_LINE( PadC("abcdef", 0) , "" )
TEST_LINE( PadC("abcdef", 2) , "ab" ) /* QUESTION: CA-Cl*pper "bug", should return: "cd" ? */
@@ -855,6 +1030,25 @@ FUNCTION Main( cPar1 )
TEST_LINE( Str(-100000, 6, -1) , "******" )
TEST_LINE( Str(-100000, 8, -1) , " -100000" )
/* MIN()/MAX() */
TEST_LINE( Max(NIL, NIL) , "E BASE 1093 Argument error MAX F:S" )
TEST_LINE( Max(10, NIL) , "E BASE 1093 Argument error MAX F:S" )
TEST_LINE( Max(SToD("19800101"), 10) , "E BASE 1093 Argument error MAX F:S" )
TEST_LINE( Max(SToD("19800101"), SToD("19800101")) , SToD("19800101") )
TEST_LINE( Max(SToD("19800102"), SToD("19800101")) , SToD("19800102") )
TEST_LINE( Max(SToD("19800101"), SToD("19800102")) , SToD("19800102") )
TEST_LINE( Max(lnIntP, lnLongP) , 100000 )
TEST_LINE( Max(@lnIntP, @lnLongP) , "E BASE 1093 Argument error MAX F:S" )
TEST_LINE( Min(NIL, NIL) , "E BASE 1092 Argument error MIN F:S" )
TEST_LINE( Min(10, NIL) , "E BASE 1092 Argument error MIN F:S" )
TEST_LINE( Min(SToD("19800101"), 10) , "E BASE 1092 Argument error MIN F:S" )
TEST_LINE( Min(SToD("19800101"), SToD("19800101")) , SToD("19800101") )
TEST_LINE( Min(SToD("19800102"), SToD("19800101")) , SToD("19800101") )
TEST_LINE( Min(SToD("19800101"), SToD("19800102")) , SToD("19800101") )
TEST_LINE( Min(lnIntP, lnLongP) , 10 )
TEST_LINE( Min(@lnIntP, @lnLongP) , "E BASE 1092 Argument error MIN F:S" )
/* Decimals handling */
TEST_LINE( Str(Max(10, 12) ) , " 12" )
@@ -983,9 +1177,6 @@ FUNCTION Main( cPar1 )
TEST_LINE( Transform( .F. , "@R Y" ) , "N" )
TEST_LINE( Transform( .T. , "@R X!" ) , "X!T" )
SET DATE ANSI
SET CENTURY ON
TEST_LINE( Transform( SToD("19901214") , "99/99/9999" ) , "1990.12.14" )
TEST_LINE( Transform( SToD("19901202") , "99.99.9999" ) , "1990.12.02" )
TEST_LINE( Transform( SToD("") , "99/99/9999" ) , " . . " )
@@ -1020,6 +1211,8 @@ FUNCTION Main( cPar1 )
TEST_LINE( Transform( 1234 , "@D 9999" ) , "**.**.* " )
TEST_LINE( Transform( 1234 , "@BD 9999" ) , "**.**.* " )
SET CENTURY ON
TEST_LINE( Transform( 15 , "9999" ) , " 15" )
TEST_LINE( Transform( 1.5 , "99.99" ) , " 1.50" )
TEST_LINE( Transform( 1.5 , "9999" ) , " 2" )
@@ -1135,6 +1328,7 @@ STATIC FUNCTION TEST_BEGIN( cParam )
ENDIF
s_lShowAll := "/ALL" $ Upper( cParam )
s_aSkipList := ListToNArray( CMDLGetValue( Upper( cParam ), "/SKIP:", "" ) )
/* Detect presence of shortcutting optimalization */
@@ -1181,10 +1375,22 @@ STATIC FUNCTION TEST_CALL( cBlock, bBlock, xResultExpected )
LOCAL oError
LOCAL bOldError
LOCAL lFailed
LOCAL lSkipped
s_nCount++
IF ValType( cBlock ) == "C"
IF !( ValType( cBlock ) == "C" )
cBlock := "!! Preprocessor error !!"
ENDIF
lSkipped := aScan( s_aSkipList, s_nCount ) > 0
IF lSkipped
lFailed := .F.
xResult := "!! Skipped !!"
ELSE
bOldError := ErrorBlock( {|oError| Break( oError ) } )
@@ -1206,23 +1412,18 @@ STATIC FUNCTION TEST_CALL( cBlock, bBlock, xResultExpected )
lFailed := !( xResult == xResultExpected )
ENDIF
ELSE
lFailed := .T.
cBlock := "!! Preprocessor error. Test skipped !!"
xResult := NIL
ENDIF
IF s_lShowAll .OR. lFailed
IF s_lShowAll .OR. lFailed .OR. lSkipped
fWrite( s_nFhnd, PadR( iif( lFailed, "!", " " ), TEST_RESULT_COL1_WIDTH ) + " " +;
fWrite( s_nFhnd, PadR( iif( lFailed, "!", iif( lSkipped, "S", " " ) ), TEST_RESULT_COL1_WIDTH ) + " " +;
Str( s_nCount, TEST_RESULT_COL2_WIDTH ) + ". " +;
PadR( cBlock, TEST_RESULT_COL3_WIDTH ) + " -> " +;
PadR( XToStr( xResult ), TEST_RESULT_COL4_WIDTH ) + " | " +;
PadR( XToStr( xResultExpected ), TEST_RESULT_COL5_WIDTH ) )
fWrite( s_nFhnd, s_cNewLine )
ENDIF
IF lFailed
@@ -1320,6 +1521,33 @@ STATIC FUNCTION ErrorMessage( oError )
RETURN cMessage
STATIC FUNCTION ListToNArray( cString )
LOCAL aArray := {}
LOCAL nPos
IF !Empty( cString )
DO WHILE ( nPos := At( ",", cString ) ) > 0
aAdd( aArray, Val( AllTrim( Left( cString, nPos - 1 ) ) ) )
cString := SubStr( cString, nPos + 1 )
ENDDO
aAdd( aArray, Val( AllTrim( cString ) ) )
ENDIF
RETURN aArray
STATIC FUNCTION CMDLGetValue( cCommandLine, cName, cRetVal )
LOCAL tmp, tmp1
IF ( tmp := At( cName, cCommandLine ) ) > 0
IF ( tmp1 := At( " ", tmp := SubStr( cCommandLine, tmp + Len( cName ) ) ) ) > 0
tmp := Left( tmp, tmp1 - 1 )
ENDIF
cRetVal := tmp
ENDIF
RETURN cRetVal
#ifndef __HARBOUR__
#ifndef __XPP__