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

2006-09-15 13:25 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

Browse Source 
* harbour/include/hbvm.h
  * harbour/source/vm/classes.c
  * harbour/source/vm/hvm.c
    + added hb_vmRequestReenter() and hb_vmRequestRestore()
    + added executing destructors when some exception is active
      I forgot about it in previous commit.

  + harbour/tests/destruct.prg
    + added example/test code for object destructors
This commit is contained in:
Przemyslaw Czerpak
2006-09-15 11:28:48 +00:00
parent a35053003b
commit f22f040335
5 changed files with 236 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
harbour/ChangeLog
View File

@@ -8,6 +8,17 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
compiled with -DHB_REAL_BLOCK_SCOPE. I set the second (real code
block scopes) as default. If you think we should be strict Class(y)
compatible here then please inform me and I'll change default setting.
+ tests/clsscope.prg
+ added demonstration/test code for class method scoping
2006-09-15 21:15 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/source/vm/arrays.c
* harbour/source/vm/classes.c
! fixed multiple use of supercasted object I broke in last commit
* removed some unused code and moved some scoping checking to
class creation code

2
harbour/include/hbvm.h
View File

@@ -106,6 +106,8 @@ extern HB_EXPORT void hb_vmRequestCancel( void );
extern HB_EXPORT void hb_vmRequestQuit( void );
extern HB_EXPORT void hb_vmRequestEndProc( void );
extern HB_EXPORT USHORT hb_vmRequestQuery( void );
extern HB_EXPORT BOOL hb_vmRequestReenter( USHORT * puiAction );
extern HB_EXPORT void hb_vmRequestRestore( USHORT uiAction );
/* Return values of hb_vmRequestQuery() */
#define HB_QUIT_REQUESTED 1 /* immediately quit the application */

97
harbour/source/vm/classes.c
View File

@@ -279,6 +279,9 @@ static HB_SYMB s___msgClassSel = { "CLASSSEL", {HB_FS_MESSAGE}, {hb___m
static HB_SYMB s___msgEval = { "EVAL", {HB_FS_MESSAGE}, {hb___msgEval}, NULL };
static HB_SYMB s___msgExec = { "EXEC", {HB_FS_MESSAGE}, {hb___msgNull}, NULL };
static HB_SYMB s___msgName = { "NAME", {HB_FS_MESSAGE}, {hb___msgNull}, NULL };
static HB_SYMB s___msgNew = { "NAME", {HB_FS_MESSAGE}, {NULL}, NULL };
/*
static HB_SYMB s___msgClsParent = { "ISDERIVEDFROM", {HB_FS_MESSAGE}, {hb___msgClsParent}, NULL };
static HB_SYMB s___msgClass = { "CLASS", {HB_FS_MESSAGE}, {hb___msgClass}, NULL };
@@ -611,6 +614,7 @@ void hb_clsInit( void )
s___msgEval.pDynSym = hb_dynsymGetCase( s___msgEval.szName );
s___msgExec.pDynSym = hb_dynsymGetCase( s___msgExec.szName );
s___msgName.pDynSym = hb_dynsymGetCase( s___msgName.szName );
s___msgNew.pDynSym = hb_dynsymGetCase( s___msgNew.szName );
/*
s___msgClsParent.pDynSym = hb_dynsymGetCase( s___msgClsParent.szName );
s___msgClass.pDynSym = hb_dynsymGetCase( s___msgClass.szName );
@@ -1386,11 +1390,15 @@ void hb_objDestructorCall( PHB_ITEM pObject )
if( pClass->pDestructor )
{
hb_stackPushReturn();
hb_vmPushSymbol( &s___msgDestructor );
hb_vmPush( pObject );
hb_vmSend( 0 );
hb_stackPopReturn();
USHORT uiAction;
if( hb_vmRequestReenter( &uiAction ) )
{
hb_vmPushSymbol( &s___msgDestructor );
hb_vmPush( pObject );
hb_vmSend( 0 );
hb_vmRequestRestore( uiAction );
}
}
}
}
@@ -2451,37 +2459,74 @@ HB_FUNC( __OBJCLONE )
HB_FUNC( __CLSINSTSUPER )
{
char * szString = hb_parc( 1 );
USHORT uiClassH = 0;
USHORT uiClassH = 0, uiClass;
if( szString && *szString )
{
PHB_DYNS pDynSym = hb_dynsymFindName( szString );
if( pDynSym ) /* Find function */
if( pDynSym )
{
/* TODO: optimize this function */
hb_vmPushSymbol( pDynSym->pSymbol ); /* Push function name */
hb_vmPushNil();
hb_vmFunction( 0 ); /* Execute super class */
if( hb_vmRequestQuery() == 0 )
for( uiClass = 0; uiClass < s_uiClasses; uiClass++ )
{
if( HB_IS_OBJECT( hb_stackReturnItem() ) )
if( s_pClasses[ uiClass ].pClassSym == pDynSym )
{
USHORT uiClass;
for( uiClass = 0; uiClass < s_uiClasses; uiClass++ )
{ /* Locate the entry */
if( s_pClasses[ uiClass ].pClassSym == pDynSym )
{
uiClassH = uiClass + 1; /* Entry + 1 = hb___msgClsH */
break;
}
}
uiClassH = uiClass + 1;
break;
}
else
}
if( uiClassH == 0 )
{
hb_vmPushSymbol( pDynSym->pSymbol ); /* Push function name */
hb_vmPushNil();
hb_vmFunction( 0 ); /* Execute super class */
if( hb_vmRequestQuery() == 0 )
{
hb_errRT_BASE( EG_ARG, 3002, "Super class does not return an object", "__CLSINSTSUPER", 0 );
PHB_ITEM pObject = hb_stackReturnItem();
if( HB_IS_OBJECT( pObject ) )
{
uiClass = pObject->item.asArray.value->uiClass;
if( s_pClasses[ uiClass - 1 ].pClassSym == pDynSym )
uiClassH = uiClass;
else
{
for( uiClass = 0; uiClass < s_uiClasses; uiClass++ )
{
if( s_pClasses[ uiClass ].pClassSym == pDynSym )
{
uiClassH = uiClass + 1;
break;
}
}
/* still not found, try to send NEW() message */
if( uiClassH == 0 )
{
hb_vmPushSymbol( &s___msgNew );
hb_vmPush( pObject );
hb_vmSend( 0 );
pObject = hb_stackReturnItem();
if( HB_IS_OBJECT( pObject ) )
{
uiClass = pObject->item.asArray.value->uiClass;
if( s_pClasses[ uiClass - 1 ].pClassSym == pDynSym )
uiClassH = uiClass;
}
}
}
/* This disables destructor execution for this object */
if( uiClassH && HB_IS_OBJECT( pObject ) )
pObject->item.asArray.value->uiClass = 0;
}
else
{
hb_errRT_BASE( EG_ARG, 3002, "Super class does not return an object", "__CLSINSTSUPER", 0 );
}
}
}
}

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

@@ -5943,11 +5943,6 @@ void hb_vmRequestBreak( PHB_ITEM pItem )
}
}
USHORT hb_vmRequestQuery( void )
{
return s_uiActionRequest;
}
void hb_vmRequestCancel( void )
{
HB_TRACE(HB_TR_DEBUG, ("hb_vmRequestCancel()"));
@@ -5979,6 +5974,39 @@ void hb_vmRequestCancel( void )
}
}
USHORT hb_vmRequestQuery( void )
{
return s_uiActionRequest;
}
BOOL hb_vmRequestReenter( USHORT * puiAction )
{
HB_TRACE(HB_TR_DEBUG, ("hb_vmRequestReenter(%p)", puiAction));
* puiAction = s_uiActionRequest;
s_uiActionRequest = 0;
hb_stackPushReturn();
return TRUE;
}
void hb_vmRequestRestore( USHORT uiAction )
{
HB_TRACE(HB_TR_DEBUG, ("hb_vmRequestRestore(%hu)", uiAction));
/* Do not overwrite QUIT request */
if( !( s_uiActionRequest & HB_QUIT_REQUESTED ) )
{
if( uiAction & HB_QUIT_REQUESTED )
s_uiActionRequest = HB_QUIT_REQUESTED;
else if( !( s_uiActionRequest & HB_BREAK_REQUESTED ) )
s_uiActionRequest = uiAction;
}
hb_stackPopReturn();
}
#undef hb_vmFlagEnabled
ULONG hb_vmFlagEnabled( ULONG flags )
{

119
harbour/tests/destruct.prg Normal file
View File

@@ -0,0 +1,119 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* example/test code for object destructors
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*
*/
#include "hbclass.ch"
memvar P
PROC MAIN()
LOCAL bError
PUBLIC P := NIL
bError := errorBlock( { | oErr | myErrorHandler( oErr ) } )
? "First simple tests when object is not destroyed by GC"
? "====================================================="
SIMPLETEST( 0 )
SIMPLETEST( 1 )
SIMPLETEST( 2 )
SIMPLETEST( 3 )
?
? "Now object will be destroyed by GC"
? "=================================="
GCFREETEST( 0 )
GCFREETEST( 1 )
GCFREETEST( 2 )
GCFREETEST( 3 )
errorBlock( bError )
?
? "*** END OF TEST ***"
return
STATIC PROCEDURE SIMPLETEST( type )
LOCAL o
?
? "=> o := myClass():new( " + ltrim( str( type ) ) + " )"
o := myClass():new( type )
? "=> o:className() ->", o:className()
? "=> o := NIL"
begin sequence
o := NIL
end
RETURN
STATIC PROCEDURE GCFREETEST( type )
LOCAL o, a
?
? "=> o := myClass():new( " + ltrim( str( type ) ) + " )"
o := myClass():new( type )
? "=> o:className() ->", o:className()
? "=> create corss reference: a := { o, nil }; a[2] := a; a := NIL"
a := { o, nil }; a[2] := a; a := NIL
? "=> o := NIL"
begin sequence
o := NIL
end
? "=> hb_gcAll()"
begin sequence
hb_gcAll()
end
RETURN
STATIC FUNCTION myErrorHandler( oErr )
? "Error ->", ltrim( str( oErr:gencode ) ), ;
oErr:description + ":", oErr:operation
BREAK oErr
RETURN NIL
CREATE CLASS myClass
VAR type
VAR var1
CLASS VAR var2
METHOD init
DESTRUCTOR dtor
END CLASS
METHOD INIT( type ) CLASS myClass
? "Hi, I'm INIT method of class:", self:classname()
::type := type
RETURN self
PROCEDURE DTOR CLASS myClass
? " Hi, I'm desturctor of class: ", self:classname()
IF ::type == 1
? " I'm storing reference to self in instance variable."
? " Bad practice but safe in Harbour because it will be destroyed."
::var1 := self
ELSEIF ::Type == 2
? " I'm storing reference to self in class variable."
? " It's programmer bug which should cause RT error."
::var2 := self
ELSEIF ::Type == 3
? " I'm storing reference to self in public variable."
? " It's programmer bug which should cause RT error."
P := self
ELSE
? " I do not store any references to self."
? " It's a safe destructor."
ENDIF
RETURN