From f22f0403358b9fbf48b83f4d9fa85b6400adfd08 Mon Sep 17 00:00:00 2001 From: Przemyslaw Czerpak Date: Fri, 15 Sep 2006 11:28:48 +0000 Subject: [PATCH] 2006-09-15 13:25 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * 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 --- harbour/ChangeLog | 11 ++++ harbour/include/hbvm.h | 2 + harbour/source/vm/classes.c | 97 +++++++++++++++++++++-------- harbour/source/vm/hvm.c | 38 ++++++++++-- harbour/tests/destruct.prg | 119 ++++++++++++++++++++++++++++++++++++ 5 files changed, 236 insertions(+), 31 deletions(-) create mode 100644 harbour/tests/destruct.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index b4e8cfa6a3..1b7779ecf3 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,17 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ + 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 diff --git a/harbour/include/hbvm.h b/harbour/include/hbvm.h index 5b04ebc4f7..a3b5e95744 100644 --- a/harbour/include/hbvm.h +++ b/harbour/include/hbvm.h @@ -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 */ diff --git a/harbour/source/vm/classes.c b/harbour/source/vm/classes.c index c090e16adf..06950b1155 100644 --- a/harbour/source/vm/classes.c +++ b/harbour/source/vm/classes.c @@ -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 ); + } } } } diff --git a/harbour/source/vm/hvm.c b/harbour/source/vm/hvm.c index 0cbee22874..d26d992064 100644 --- a/harbour/source/vm/hvm.c +++ b/harbour/source/vm/hvm.c @@ -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 ) { diff --git a/harbour/tests/destruct.prg b/harbour/tests/destruct.prg new file mode 100644 index 0000000000..fa3d016d88 --- /dev/null +++ b/harbour/tests/destruct.prg @@ -0,0 +1,119 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * example/test code for object destructors + * + * Copyright 2006 Przemyslaw Czerpak + * 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