diff --git a/harbour/ChangeLog b/harbour/ChangeLog index dacb82ee2c..d58517e050 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,37 @@ +19990907-01:00 GMT+1 Victor Szel + * 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 * source/rtl/tbrowse.prg * Fixes on Stabilize() method diff --git a/harbour/include/itemapi.h b/harbour/include/itemapi.h index d65f8ff77b..258d3c8185 100644 --- a/harbour/include/itemapi.h +++ b/harbour/include/itemapi.h @@ -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 ); diff --git a/harbour/source/compiler/harbour.y b/harbour/source/compiler/harbour.y index 85f7e0bbfd..919d7646a4 100644 --- a/harbour/source/compiler/harbour.y +++ b/harbour/source/compiler/harbour.y @@ -389,6 +389,7 @@ static const char * _szReservedFun[] = { "SECONDS" , "SELECT" , "SETPOS" , + "SETPOSBS" , "SPACE" , "SQRT" , "STR" , diff --git a/harbour/source/rtl/arrays.c b/harbour/source/rtl/arrays.c index cebded0ed7..c17e245fc8 100644 --- a/harbour/source/rtl/arrays.c +++ b/harbour/source/rtl/arrays.c @@ -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; + } } } diff --git a/harbour/source/rtl/classes.c b/harbour/source/rtl/classes.c index c1e08eb4ce..d18ce7c277 100644 --- a/harbour/source/rtl/classes.c +++ b/harbour/source/rtl/classes.c @@ -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( ) + * + * 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 ); +} + +/* ================================================ */ + + +/* + * = 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; +} + + +/* + * = hb_objGetMethod( , ) + * + * 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; +} + + +/* + * = hb_objHasMsg( , ) + * + * Check whether is an existing message for object. + * + * 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( , , , , [xInit] ) * @@ -329,17 +526,6 @@ HARBOUR HB___CLSDELMSG( void ) } -/* - * := :ClassH() - * - * Returns class handle of - */ -static HARBOUR hb___msgClsH( void ) -{ - hb_retni( ( stack.pBase + 1 )->item.asArray.value->wClass ); -} - - /* * := __clsInst( ) * @@ -365,6 +551,7 @@ HARBOUR HB___CLSINST( void ) } } + /* * __clsModMsg( , , ) * @@ -417,24 +604,6 @@ HARBOUR HB___CLSMODMSG( void ) } -/* - * := :ClassName() - * - * Return class name of . 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 ) ); -} - - /* * := ClassName( ) * @@ -463,256 +632,6 @@ HARBOUR HB___OBJGETCLSNAME( void ) } -/* - * := :ClassSel() - * - * Returns all the messages in - */ -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 */ -} - - -/* - * = 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 ); -} - - -/* - * = hb_objGetMethod( , ) - * - * 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; -} - - -/* - * = hb_objHasMsg( , ) - * - * Check whether is an existing message for object. - * - * 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 */ - - /* * := __objHasMsg( , ) * @@ -778,42 +697,264 @@ HARBOUR HB___OBJSENDMSG( void ) /* - * hb_clsRelease( ) + * := __clsInstSuper( ) * - * 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() + * = __cls_CntClsData( ) * - * 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 ); + +/* + * = __cls_CntData( ) + * + * Return number of datas + */ +HARBOUR HB___CLS_CNTDATA( void ) +{ + WORD wClass = hb_parnl( 1 ); + + if( wClass ) + hb_retni( s_pClasses[ wClass - 1 ].wDatas ); +} + + +/* + * = __cls_DecData( ) + * + * 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-- ); +} + + +/* + * = __cls_IncData( ) + * + * 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 ); +} + + +/* ================================================ */ + +/* + * := :ClassH() + * + * Returns class handle of + */ +static HARBOUR hb___msgClsH( void ) +{ + if( IS_ARRAY( stack.pBase + 1 ) ) + hb_retni( ( stack.pBase + 1 )->item.asArray.value->wClass ); + else + hb_retni( 0 ); +} + + +/* + * := :ClassName() + * + * Return class name of . 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 ) ); +} + + +/* + * := :ClassSel() + * + * Returns all the messages in + */ +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(); } - -/* - * := __clsInstSuper( ) - * - * 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 ); -} - - -/* - * = __cls_CntClsData( ) - * - * 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 ) ); - } -} - -/* - * = __cls_CntData( ) - * - * Return number of datas - */ -HARBOUR HB___CLS_CNTDATA( void ) -{ - WORD wClass = hb_parnl( 1 ); - - if( wClass ) - hb_retni( s_pClasses[ wClass - 1 ].wDatas ); -} - -/* - * = __cls_DecData( ) - * - * 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-- ); -} - - -/* - * = __cls_IncData( ) - * - * 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 ); -} - diff --git a/harbour/source/rtl/do.c b/harbour/source/rtl/do.c index 486e129bc5..86255bc851 100644 --- a/harbour/source/rtl/do.c +++ b/harbour/source/rtl/do.c @@ -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! */ } diff --git a/harbour/source/rtl/itemapi.c b/harbour/source/rtl/itemapi.c index 1b6a3d5bb2..7941684c65 100644 --- a/harbour/source/rtl/itemapi.c +++ b/harbour/source/rtl/itemapi.c @@ -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 ) diff --git a/harbour/source/vm/hvm.c b/harbour/source/vm/hvm.c index c7acbedc07..ae27a520fc 100644 --- a/harbour/source/vm/hvm.c +++ b/harbour/source/vm/hvm.c @@ -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 ) diff --git a/harbour/tests/working/rtl_test.prg b/harbour/tests/working/rtl_test.prg index b8e0a4ad56..f7e983cec5 100644 --- a/harbour/tests/working/rtl_test.prg +++ b/harbour/tests/working/rtl_test.prg @@ -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__