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

2004-04-17 12:30 UTC+0100 Ryszard Glab <rglab@imid.med.pl>

Browse Source 
* include/hbapi.h
   * source/rtl/empty.c
   * source/rtl/idle.c
   * source/vm/arrays.c
   * source/vm/estack.c
   * source/vm/extend.c
   * source/vm/itemapi.c
      * added missing code to use HB_IT_POINTER just like
      other value's type
      You can use:
      hb_retptr( void * pointer )
      hb_parptr( ) -> void *
      hb_storptr( void * pointer, ...... )
      to return/manage pointers from low level functions.
      For example:
      p = GET_SOME_POINTER()
      ? VALTYPE(p)   //prints: 'P'
      ? p   //prints: 0x12345678

   * tests/onidle.prg
      * fixed to use values of pointer type

   * tests/tstmacro.prg
      * added code to test TYPE() function
This commit is contained in:
Ryszard Glab
2004-04-17 10:58:20 +00:00
parent 5cb44ed54a
commit abe158c8d0
10 changed files with 252 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
harbour/ChangeLog
View File

@@ -8,6 +8,32 @@
2002-12-01 23:12 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2004-04-17 12:30 UTC+0100 Ryszard Glab <rglab@imid.med.pl>
* include/hbapi.h
* source/rtl/empty.c
* source/rtl/idle.c
* source/vm/arrays.c
* source/vm/estack.c
* source/vm/extend.c
* source/vm/itemapi.c
* added missing code to use HB_IT_POINTER just like
other value's type
You can use:
hb_retptr( void * pointer )
hb_parptr( ) -> void *
hb_storptr( void * pointer, ...... )
to return/manage pointers from low level functions.
For example:
p = GET_SOME_POINTER()
? VALTYPE(p) //prints: 'P'
? p //prints: 0x12345678
* tests/onidle.prg
* fixed to use values of pointer type
* tests/tstmacro.prg
* added code to test TYPE() function
2004-04-16 17:08 UTC-0800 Luis Krause Mantilla <lkrausem /*at*/ shaw /*dot*/ ca>
* harbour/contrib/rdd_ads/adsfunc.c
Renamed adsGetConnectionType() as AdsGetTableConType() and added

5
harbour/include/hbapi.h
View File

@@ -293,6 +293,7 @@ extern int HB_EXPORT hb_parl( int iParam, ... ); /* retrieve a logical para
extern double HB_EXPORT hb_parnd( int iParam, ... ); /* retrieve a numeric parameter as a double */
extern int HB_EXPORT hb_parni( int iParam, ... ); /* retrieve a numeric parameter as a integer */
extern long HB_EXPORT hb_parnl( int iParam, ... ); /* retrieve a numeric parameter as a long */
extern void HB_EXPORT * hb_parptr( int iParam, ... ); /* retrieve a parameter as a pointer */
extern PHB_ITEM HB_EXPORT hb_param( int iParam, int iMask ); /* retrieve a generic parameter */
extern PHB_ITEM HB_EXPORT hb_paramError( int iParam ); /* Returns either the generic parameter or a NIL item if param not provided */
extern BOOL HB_EXPORT hb_extIsArray( int iParam );
@@ -328,6 +329,7 @@ extern BOOL HB_EXPORT hb_extIsArray( int iParam );
#define hb_retndlen( dNumber, iWidth, iDec ) hb_itemPutNDLen( &hb_stack.Return, dNumber, iWidth, iDec )
#define hb_retnilen( iNumber, iWidth ) hb_itemPutNILen( &hb_stack.Return, iNumber, iWidth )
#define hb_retnllen( lNumber, iWidth ) hb_itemPutNLLen( &hb_stack.Return, lNumber, iWidth )
#define hb_retptr( pointer ) hb_itemPutPtr( &hb_stack.Return, pointer )
#else
@@ -351,6 +353,7 @@ extern void HB_EXPORT hb_retndlen( double dNumber, int iWidth, int iDec ); /*
extern void HB_EXPORT hb_retnilen( int iNumber, int iWidth ); /* returns a integer number, with specific width */
extern void HB_EXPORT hb_retnllen( long lNumber, int iWidth ); /* returns a long number, with specific width */
extern void HB_EXPORT hb_reta( ULONG ulLen ); /* returns an array with a specific length */
extern void HB_EXPORT hb_retptr( void * ptr ); /* returns a pointer */
#endif
@@ -361,6 +364,7 @@ extern int HB_EXPORT hb_storl( int iLogical, int iParam, ... ); /* stores a l
extern int HB_EXPORT hb_storni( int iValue, int iParam, ... ); /* stores an integer on a variable by reference */
extern int HB_EXPORT hb_stornl( long lValue, int iParam, ... ); /* stores a long on a variable by reference */
extern int HB_EXPORT hb_stornd( double dValue, int iParam, ... ); /* stores a double on a variable by reference */
extern int HB_EXPORT hb_storptr( void * pointer, int iParam, ... ); /* stores a pointer on a variable by reference */
extern void HB_EXPORT hb_xinit( void ); /* Initialize fixed memory subsystem */
extern void HB_EXPORT hb_xexit( void ); /* Deinitialize fixed memory subsystem */
@@ -399,6 +403,7 @@ extern ULONG hb_arrayCopyC( PHB_ITEM pArray, ULONG ulIndex, char * szBuffer,
extern char * hb_arrayGetC( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the string contained on an array element */
extern char * hb_arrayGetCPtr( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the string pointer on an array element */
extern ULONG hb_arrayGetCLen( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the string length contained on an array element */
extern void * hb_arrayGetPtr( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the pointer contained on an array element */
extern BOOL hb_arrayGetL( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the logical value contained on an array element */
extern int hb_arrayGetNI( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the int value contained on an array element */
extern long hb_arrayGetNL( PHB_ITEM pArray, ULONG ulIndex ); /* retrieves the long numeric value contained on an array element */

4
harbour/source/rtl/empty.c
View File

@@ -92,6 +92,10 @@ HB_FUNC( EMPTY )
hb_retl( FALSE );
break;
case HB_IT_POINTER:
hb_retl( hb_itemGetPtr( pItem ) == NULL );
break;
default:
hb_retl( TRUE );
break;

10
harbour/source/rtl/idle.c
View File

@@ -229,10 +229,10 @@ HB_FUNC( HB_IDLEADD )
/* return a pointer as a handle to this idle task
*/
hb_retnl( ( ULONG ) pBlock->item.asBlock.value ); /* TODO: access to pointers from harbour code */
hb_retptr( ( void * ) pBlock->item.asBlock.value ); /* TODO: access to pointers from harbour code */
}
else
hb_retnl( -1 ); /* error - a codeblock is required */
hb_retptr( NULL ); /* error - a codeblock is required */
}
/* Delete a task with given handle and return a codeblock with this task */
@@ -240,17 +240,17 @@ HB_FUNC( HB_IDLEDEL )
{
BOOL bFound = FALSE;
if( s_pIdleTasks && ( hb_parinfo( 1 ) & HB_IT_NUMERIC ) )
if( s_pIdleTasks && ( hb_parinfo( 1 ) & HB_IT_POINTER ) )
{
SHORT iTask;
ULONG ulID = hb_parnl( 1 ); /* TODO: access to pointers from harbour code */
void * pID = hb_parptr( 1 );
HB_ITEM_PTR pItem;
iTask = 0;
while( iTask < s_uiIdleMaxTask && !bFound )
{
pItem = s_pIdleTasks[ iTask ];
if( ulID == ( ULONG ) pItem->item.asBlock.value )
if( pID == ( void * ) pItem->item.asBlock.value )
{
hb_itemClear( hb_itemReturn( pItem ) ); /* return a codeblock */
hb_itemRelease( pItem );

11
harbour/source/vm/arrays.c
View File

@@ -400,6 +400,17 @@ ULONG hb_arrayGetCLen( PHB_ITEM pArray, ULONG ulIndex )
return 0;
}
void * hb_arrayGetPtr( PHB_ITEM pArray, ULONG ulIndex )
{
HB_TRACE(HB_TR_DEBUG, ("hb_arrayGetPtr(%p, %lu)", pArray, ulIndex));
if( HB_IS_ARRAY( pArray ) && ulIndex > 0 && ulIndex <= pArray->item.asArray.value->ulLen )
return hb_itemGetPtr( pArray->item.asArray.value->pItems + ulIndex - 1 );
else
return NULL;
}
USHORT hb_arrayGetType( PHB_ITEM pArray, ULONG ulIndex )
{
HB_TRACE(HB_TR_DEBUG, ("hb_arrayGetType(%p, %lu)", pArray, ulIndex));

6
harbour/source/vm/estack.c
View File

@@ -324,6 +324,10 @@ void hb_stackDispLocal( void )
printf( HB_I_("SYMBOL = %s "), ( *pBase )->item.asSymbol.value->szName );
break;
case HB_IT_POINTER:
printf( HB_I_("POINTER = %p "), ( *pBase )->item.asPointer.value );
break;
default:
printf( HB_I_("UNKNOWN = TYPE %i "), hb_itemType( *pBase ) );
break;
@@ -441,7 +445,7 @@ ULONG _System OS2TermHandler(PEXCEPTIONREPORTRECORD p1,
during debugging */
if (p1->ExceptionNum != XCPT_UNWIND && p1->ExceptionNum < XCPT_BREAKPOINT) {
fprintf(stderr, HB_I_("\nException %lx at address %lx \n"), p1->ExceptionNum, (ULONG)p1->ExceptionAddress);
fprintf(stderr, HB_I_("\nException %lx at address %p \n"), p1->ExceptionNum, p1->ExceptionAddress);
do
{

73
harbour/source/vm/extend.c
View File

@@ -426,6 +426,35 @@ long HB_EXPORT hb_parnl( int iParam, ... )
return 0;
}
void HB_EXPORT * hb_parptr( int iParam, ... )
{
HB_TRACE(HB_TR_DEBUG, ("hb_parptr(%d, ...)", iParam));
if( ( iParam >= 0 && iParam <= hb_pcount() ) || ( iParam == -1 ) )
{
PHB_ITEM pItem = ( iParam == -1 ) ? &hb_stack.Return : hb_stackItemFromBase( iParam );
if( HB_IS_BYREF( pItem ) )
pItem = hb_itemUnRef( pItem );
if( HB_IS_POINTER( pItem ) )
return pItem->item.asPointer.value;
else if( HB_IS_ARRAY( pItem ) )
{
va_list va;
ULONG ulArrayIndex;
va_start( va, iParam );
ulArrayIndex = va_arg( va, ULONG );
va_end( va );
return hb_arrayGetPtr( pItem, ulArrayIndex );
}
}
return NULL;
}
ULONG HB_EXPORT hb_parinfa( int iParamNum, ULONG uiArrayIndex )
{
PHB_ITEM pArray;
@@ -626,6 +655,15 @@ void HB_EXPORT hb_retnllen( long lNumber, int iWidth )
hb_itemPutNLLen( &hb_stack.Return, lNumber, iWidth );
}
#undef hb_retptr
void HB_EXPORT hb_retptr( void * pointer )
{
HB_TRACE(HB_TR_DEBUG, ("hb_retptr(%p)", pointer));
hb_itemPutPtr( &hb_stack.Return, pointer );
}
int HB_EXPORT hb_storc( char * szText, int iParam, ... )
{
HB_TRACE(HB_TR_DEBUG, ("hb_storc(%s, %d, ...)", szText, iParam));
@@ -865,3 +903,38 @@ int HB_EXPORT hb_stornd( double dNumber, int iParam, ... )
return 0;
}
int HB_EXPORT hb_storptr( void * pointer, int iParam, ... )
{
HB_TRACE(HB_TR_DEBUG, ("hb_storptr(%p, %d, ...)", pointer, iParam));
if( ( iParam >= 0 && iParam <= hb_pcount() ) || ( iParam == -1 ) )
{
PHB_ITEM pItem = ( iParam == -1 ) ? &hb_stack.Return : hb_stackItemFromBase( iParam );
BOOL bByRef = HB_IS_BYREF( pItem );
if( bByRef )
pItem = hb_itemUnRef( pItem );
if( HB_IS_ARRAY( pItem ) )
{
va_list va;
PHB_ITEM pItemNew = hb_itemPutPtr( NULL, pointer );
va_start( va, iParam );
hb_arraySet( pItem, va_arg( va, ULONG ), pItemNew );
va_end( va );
hb_itemRelease( pItemNew );
return 1;
}
else if( bByRef || iParam == -1 )
{
hb_itemPutPtr( pItem, pointer );
return 1;
}
return 0;
}
return 0;
}

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

@@ -847,6 +847,9 @@ char * HB_EXPORT hb_itemTypeStr( PHB_ITEM pItem )
case HB_IT_MEMO:
return "M";
case HB_IT_POINTER:
return "P";
}
return "U";
@@ -1405,6 +1408,36 @@ char * HB_EXPORT hb_itemString( PHB_ITEM pItem, ULONG * ulLen, BOOL * bFreeReq )
* bFreeReq = FALSE;
break;
case HB_IT_POINTER:
{
int size = 11; /* 8 bytes for address + 0x + \0 */
int n;
BOOL bFail = TRUE;
buffer = ( char * ) hb_xgrab( size );
do
{
n = snprintf( buffer, size, "%p", hb_itemGetPtr( pItem ) );
if( (n > -1) && (n < size) )
{
bFail = FALSE;
}
else
{
if( n > -1 )
size = n + 1;
else
size *= 2;
buffer = hb_xrealloc( buffer, size );
}
}
while( bFail );
* ulLen = strlen( buffer );
* bFreeReq = TRUE;
}
break;
default:
buffer = "";
* ulLen = 0;

26
harbour/tests/onidle.prg
View File

@@ -26,15 +26,29 @@ LOCAL nPrev:=SECONDS()
nH3 = HB_IDLEADD( {|| DEVPOS(0,41), IIF(n=4,n:=1,n++),DEVOUT(aSign[n]) } )
nH4 = HB_IDLEADD( {|| DEVPOS(0,61), DEVOUT( 1000*(SECONDS()-nPrev) ), nPrev:=SECONDS() } )
? VALTYPE(nH1), nH1, VALTYPE(nH2), nH2, VALTYPE(nH3), nH3, VALTYPE(nH4), nH4
INKEY( 30 )
HB_IDLEDEL( nH3 )
HB_IDLEDEL( nH2 )
HB_IDLEDEL( nH1 )
HB_IDLEDEL( nH4 )
IF( !EMPTY(nH3) )
@ 14,2 SAY "Delete task 3: " + HB_VALTOSTR(nH3)
HB_IDLEDEL( nH3 )
ENDIF
IF( !EMPTY(nH2) )
@ 15,2 SAY "Delete task 2: " + HB_VALTOSTR(nH2)
HB_IDLEDEL( nH2 )
ENDIF
IF( !EMPTY(nH1) )
@ 16,2 SAY "Delete task 1: " + HB_VALTOSTR(nH1)
HB_IDLEDEL( nH1 )
ENDIF
IF( !EMPTY(nH4) )
@ 17,2 SAY "Delete task 4: " + HB_VALTOSTR(nH4)
HB_IDLEDEL( nH4 )
ENDIF
@ 13,2 SAY "Memory after idle states" + STR( MEMORY(HB_MEM_USED) )
@ 18,2 SAY "Memory after idle states" + STR( MEMORY(HB_MEM_USED) )
HB_GCALL()
@ 14,2 SAY "Memory after collecting" + STR( MEMORY(HB_MEM_USED) )
@ 19,2 SAY "Memory after collecting" + STR( MEMORY(HB_MEM_USED) )
RETURN 1

70
harbour/tests/tstmacro.prg
View File

@@ -47,6 +47,8 @@ Function Main( )
? M->NewPublicVar
TEST_TYPE()
RETURN NIL
FUNCTION TValue
@@ -94,3 +96,71 @@ Function SubFun()
? '"cVar_1" = [' + M->cVar_1 + '] in SubFun() PRIVATE'
RETURN NIL
STATIC PROCEDURE TEST_TYPE()
LOCAL v1, v2, v1a, v2a
LOCAL bErr:=ERRORBLOCK({|e|BREAK(e)}), oE
?
? "=========== TYPE() function ================="
v1 := "UDF()"
? "Test for TYPE('UDF()') - should be 'UI': ", TYPE(v1)
v2 := "UDF_STATIC()"
? "Test for TYPE('UDF_STATIC()') - should be 'U': ", TYPE(v2)
? "Test for &"+"'UDF()' - should print 'udf': ", &v1
? "Test for &"+"'UDF_STATIC()' - should print 'ERROR: undefined function': "
BEGIN SEQUENCE
?? &v2
RECOVER USING oE
? "ERROR: "+oE:Description
END SEQUENCE
ERRORBLOCK(bErr)
v1 := "UDF"
? "Test for TYPE('UDF') - should be 'U': ", TYPE(v1)
v2 := "UDF_STATIC"
? "Test for TYPE('UDF_STATIC') - should be 'U': ", TYPE(v2)
v1a := "UDF:=1"
? "Test for TYPE('UDF:=1') - should be 'N': ", TYPE(v1a)
v2a := "UDF_STATIC:=1"
? "Test for TYPE('UDF_STATIC:=1') - should be 'N': ", TYPE(v2a)
? "=== after the assignment ==="
v1 := "UDF"
? "Test for TYPE('UDF') - should be 'N': ", TYPE(v1)
v2 := "UDF_STATIC"
? "Test for TYPE('UDF_STATIC') - should be 'N': ", TYPE(v2)
v1 := "UDF()"
? "Test for TYPE('UDF()') - should be 'UI': ", TYPE(v1)
v2 := "UDF_STATIC()"
? "Test for TYPE('UDF_STATIC()') - should be 'U': ", TYPE(v2)
? "=== declared public variable ==="
PUBLIC UDF2, UDF2_STATIC
v1 := "UDF2()"
? "Test for TYPE('UDF2()') - should be 'UI': ", TYPE(v1)
v2 := "UDF2_STATIC()"
? "Test for TYPE('UDF2_STATIC()') - should be 'U': ", TYPE(v2)
v1 := "UDF2"
? "Test for TYPE('UDF') - should be 'L': ", TYPE(v1)
v2 := "UDF2_STATIC"
? "Test for TYPE('UDF_STATIC') - should be 'L': ", TYPE(v2)
?
RETURN
STATIC FUNCTION UDF_STATIC()
RETURN "udf_static"
FUNCTION UDF()
RETURN "udf"
STATIC FUNCTION UDF2_STATIC()
RETURN "udf2_static"
FUNCTION UDF2()
RETURN "udf2"