From a586ef687202ca62abbf193e16e0a5df4a01ef28 Mon Sep 17 00:00:00 2001 From: Eddie Runia Date: Thu, 13 May 1999 21:40:13 +0000 Subject: [PATCH] Back --- harbour/source/rtl/classes.c | 125 ++++++++++++++++++++++- harbour/source/rtl/objfunc.prg | 145 +++++++++++++++++++++++++++ harbour/tests/working/dynobj.prg | 166 +++++++++++++++++++++++++++++++ 3 files changed, 434 insertions(+), 2 deletions(-) create mode 100644 harbour/tests/working/dynobj.prg diff --git a/harbour/source/rtl/classes.c b/harbour/source/rtl/classes.c index 89263545b2..f448b5f4cf 100644 --- a/harbour/source/rtl/classes.c +++ b/harbour/source/rtl/classes.c @@ -10,6 +10,7 @@ void PushNil( void ); void PushSymbol( PSYMBOL ); void Message( PSYMBOL ); void Do( WORD wParams ); +void ArrayDel( PITEM, WORD ); #define MET_METHOD 0 #define MET_DATA 1 @@ -136,12 +137,22 @@ char * _GetClassName( PITEM pObject ) static HARBOUR GetData( void ) { - ArrayGet( stack.pBase + 1, pMethod->wData, &stack.Return ); + PITEM pObject = stack.pBase + 1; + WORD wIndex = pMethod->wData; + + if( wIndex > ArrayLen ( pObject ) ) /* Resize needed */ + ArraySize( pObject, wIndex ); /* Make large enough */ + ArrayGet( pObject, wIndex, &stack.Return ); } static HARBOUR SetData( void ) { - ArraySet( stack.pBase + 1, pMethod->wData, stack.pBase + 2 ); + PITEM pObject = stack.pBase + 1; + WORD wIndex = pMethod->wData; + + if( wIndex > ArrayLen( pObject ) ) /* Resize needed */ + ArraySize( pObject, wIndex ); /* Make large enough */ + ArraySet( pObject, wIndex, stack.pBase + 2 ); } static HARBOUR GetClassData( void ) @@ -506,3 +517,113 @@ HARBOUR OSEND() /* = oSend( , , */ } +HARBOUR __WDATAINC() /* = __wDataInc( )*/ +{ + WORD wClass = _parnl( 1 ); + + if( wClass ) + _retni( ++pClasses[ wClass - 1 ].wDatas ); /* Return and increase */ +} /* number of DATAs */ + +HARBOUR __WDATADEC() /* = __wDataDec( )*/ +{ + WORD wClass = _parnl( 1 ); + + if( wClass ) + _retni( ++pClasses[ wClass - 1 ].wDatas ); /* Return and decrease */ +} /* number of DATAs */ + +HARBOUR CLASSMOD() /* Modify message (only for INLINE and METHOD) */ + /* := ClassMod( , , ) */ +{ + PITEM pString = _param( 2, IT_STRING ); + PSYMBOL pMessage = GetDynSym( pString->value.szText )->pSymbol; + PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; + PCLASS pClass; + + WORD wClass = _parni( 1 ); + WORD wAt; + WORD wLimit; + + HARBOURFUNC pFunc; + + if( wClass && wClass <= wClasses ) + { + pClass = &pClasses[ wClass - 1 ]; + wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; + wLimit = wAt + BUCKET; + + while( ( wAt < wLimit ) && + ( pClass->pMethods[ wAt ].pMessage && + ( pClass->pMethods[ wAt ].pMessage != pMsg ) ) ) + wAt++; + + if( wAt <= wLimit ) + { /* Requested method found */ + pFunc = pClass->pMethods[ wAt ].pFunction; + if( pFunc == EvalInline ) /* INLINE method changed */ + { + ArraySet( &pClass->aInlines, pClass->pMethods[ wAt ].wData, + _param( 3, IT_BLOCK ) ); + } + else if( ( pFunc == SetData ) || ( pFunc == GetData ) ) + { /* Not allowed for DATA */ + printf( "\nCannot modify a DATA item" ); + exit(1); + } /* TODO : Real error */ + else /* Modify METHOD */ + { + pClass->pMethods[ wAt ].pFunction = ( HARBOURFUNC ) _parnl( 3 ); + } + } + } +} + +HARBOUR CLASSDEL() /* Delete message (only for INLINE and METHOD) */ + /* := ClassDel( , ) */ +{ + PITEM pString = _param( 2, IT_STRING ); + PSYMBOL pMessage = GetDynSym( pString->value.szText )->pSymbol; + PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; + PCLASS pClass; + + WORD wClass = _parni( 1 ); + WORD wAt; + WORD wLimit; + + HARBOURFUNC pFunc; + + if( wClass && wClass <= wClasses ) + { + pClass = &pClasses[ wClass - 1 ]; + wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; + wLimit = wAt + BUCKET; + + while( ( wAt < wLimit ) && + ( pClass->pMethods[ wAt ].pMessage && + ( pClass->pMethods[ wAt ].pMessage != pMsg ) ) ) + wAt++; + + if( wAt <= wLimit ) + { /* Requested method found */ + pFunc = pClass->pMethods[ wAt ].pFunction; + if( pFunc == EvalInline ) /* INLINE method deleted */ + { + ArrayDel( &pClass->aInlines, pClass->pMethods[ wAt ].wData ); + /* Delete INLINE block */ + } /* Move messages */ + for( ; pClass->pMethods[ wAt ].pMessage && wAt < wLimit; wAt ++ ) + memcpy( &( pClass->pMethods[ wAt ] ), + &( pClass->pMethods[ wAt + 1 ] ), sizeof( METHOD ) ); + + pClass->pMethods[ wAt ].pFunction = NULL; + pClass->pMethods[ wAt ].pMessage = NULL; + pClass->pMethods[ wAt ].wData = NULL; + pClass->pMethods[ wAt ].wScope = NULL; + pClass->pMethods[ wAt ].wInitValue = NULL; + + pClass->wMethods--; /* Decrease number messages */ + } + } +} + diff --git a/harbour/source/rtl/objfunc.prg b/harbour/source/rtl/objfunc.prg index 29e522132d..b38a202943 100644 --- a/harbour/source/rtl/objfunc.prg +++ b/harbour/source/rtl/objfunc.prg @@ -1,3 +1,9 @@ +#define MET_METHOD 0 +#define MET_DATA 1 +#define MET_CLASSDATA 2 +#define MET_INLINE 3 +#define MET_VIRTUAL 4 + #define DATA_SYMBOL 1 #define DATA_VAL 2 @@ -114,3 +120,142 @@ function aOSet( oObject, aData ) next n return oObject + +// +// := oAddMethod( , , ) +// +// Add a method to an already existing class +// +function oAddMethod( oObj, cSymbol, nFuncPtr ) + + if IsMessage( oObj, cSymbol ) + QOut( "OADDMETHOD: ", cSymbol, " already exists in class." ) + elseif ValType( nFuncPtr ) != "N" + QOut( "OADDMETHOD: Argument type error " ) + elseif ValType( oObj ) != "O" + QOut( "OADDMETHOD: Argument type error " ) + else + ClassAdd( oObj:ClassH, cSymbol, nFuncPtr, MET_METHOD ) + endif +return oObj + + +// +// := oAddInline( , , ) +// +// Add an INLINE to an already existing class +// +function oAddInline( oObj, cSymbol, bInline ) + + if IsMessage( oObj, cSymbol ) + QOut( "OADDINLINE: ", cSymbol, " already exists in class." ) + elseif ValType( bInline ) != "B" + QOut( "OADDINLINE: Argument type error " ) + elseif ValType( oObj ) != "O" + QOut( "OADDINLINE: Argument type error " ) + else + ClassAdd( oObj:ClassH, cSymbol, bInline, MET_INLINE ) + endif +return oObj + + +// +// := oAddData( , ) +// +// Add a DATA to an already existing class +// +function oAddData( oObj, cSymbol ) + + local nSeq + + if IsMessage( oObj, cSymbol ) .or. IsMessage( oObj, "_" + cSymbol ) + QOut( "OADDDATA: ", cSymbol, " already exists in class." ) + elseif ValType( oObj ) != "O" + QOut( "OADDDATA: Argument type error " ) + else + nSeq := __wDataInc( oObj:ClassH ) // Allocate new Seq# + ClassAdd( oObj:ClassH, cSymbol, nSeq, MET_DATA ) + ClassAdd( oObj:ClassH, "_" + cSymbol, nSeq, MET_DATA ) + endif +return oObj + + +// +// := oModMethod( , , ) +// +// Modify a method to an already existing class +// +function oModMethod( oObj, cSymbol, nFuncPtr ) + + if !IsMethod( oObj, cSymbol ) + QOut( "OMODMETHOD: ", cSymbol, " doesnot exists in class." ) + elseif ValType( nFuncPtr ) != "N" + QOut( "OMODMETHOD: Argument type error " ) + elseif ValType( oObj ) != "O" + QOut( "OMODMETHOD: Argument type error " ) + else + ClassMod( oObj:ClassH, cSymbol, nFuncPtr ) + endif +return oObj + + +// +// := oModInline( , , ) +// +// Modify an INLINE to an already existing class +// +function oModInline( oObj, cSymbol, bInline ) + + if !IsMethod( oObj, cSymbol ) + QOut( "OMODINLINE: ", cSymbol, " doesnot exists in class." ) + elseif ValType( bInline ) != "B" + QOut( "OMODINLINE: Argument type error " ) + elseif ValType( oObj ) != "O" + QOut( "OMODINLINE: Argument type error " ) + else + ClassMod( oObj:ClassH, cSymbol, bInline ) + endif +return oObj + + +// +// := oDelMethod( , ) +// +// Delete a method from an already existing class +// +function oDelMethod( oObj, cSymbol ) + + if !IsMethod( oObj, cSymbol ) + QOut( "ODELMETHOD: ", cSymbol, " doesnot exists in class." ) + elseif ValType( oObj ) != "O" + QOut( "ODELMETHOD: Argument type error " ) + else + ClassDel( oObj:ClassH, cSymbol ) + endif +return oObj + +function oDelInline( oObj, cSymbol ) +return oDelMethod( oObj, cSymbol ) // Same story + + +// +// := oDelData( , ) +// +// Delete a DATA from an already existing class +// +function oDelData( oObj, cSymbol ) + + local nSeq + + if !IsData( oObj, cSymbol ) + QOut( "ODELDATA: ", cSymbol, " doesnot exists in class." ) + elseif ValType( oObj ) != "O" + QOut( "ODELDATA: Argument type error " ) + else + ClassDel( oObj:ClassH, cSymbol, ) + ClassDel( oObj:ClassH, "_" + cSymbol ) + nSeq := __wDataDec( oObj:ClassH ) // Decrease wData + endif +return oObj + + diff --git a/harbour/tests/working/dynobj.prg b/harbour/tests/working/dynobj.prg new file mode 100644 index 0000000000..a62a69d10b --- /dev/null +++ b/harbour/tests/working/dynobj.prg @@ -0,0 +1,166 @@ +// +// DynObj +// +// Implementation of dynamic objects in Harbour +// +// Date : 1999/05/12 +// +#define DATA_SYMBOL 1 +#define DATA_VAL 2 + +function Main() + + local oForm := TForm():New() + local nSeq + + QOut( "What methods are in the class :" ) + HBDebug( aoMethod( oForm ) ) + +/* Let's add an inline at run-time. Should already be possible */ + + QOut( "Let's add inline 'CalcArea' at run-time to an already instanced class" ) + + oAddInline( oForm, "CalcArea", ; + {|self| ( ::nRight - ::nLeft ) * ( ::nBottom - ::nTop ) } ) + + QOut( "What methods are in the class :" ) + HBDebug( aoMethod( oForm ) ) + + QOut( "What is the Form area ?" ) + QOut( oForm:CalcArea() ) + + QOut( "Let's add method 'Smile' at run-time to an already instanced class" ) + + oAddMethod( oForm, "Smile", @Smile() ) + + QOut( "What methods are in the class :" ) + HBDebug( aoMethod( oForm ) ) + + QOut( "Smile please " ) + oForm:Smile() + + QOut( "The next code can _not_ be used in the offical classes.c" ) + Pause() + + QOut( "Data items before" ) + HBDebug( oForm ) + + QOut( "Let's add an additional data item" ) + + oAddData( oForm, "cHelp" ) + + oForm:cHelp := "This is a real tricky test" + + QOut( "Data items after" ) + HBDebug( oForm ) + + Pause() + + QOut( "Let's attach a bigger smile" ) + + oModMethod( oForm, "Smile", @BigSmile() ) + + QOut( "Let's smile" ) + oForm:Smile() + + QOut( "And CalcArea() will now give a result in square inches" ) + + oModInline( oForm, "CalcArea", ; + {|self| ( ::nRight - ::nLeft ) * ( ::nBottom - ::nTop ) / (2.54*2.54) } ) + + QOut( "What is the Form area ?" ) + QOut( oForm:CalcArea() ) + + QOut( "What methods are in the class :" ) + HBDebug( aoMethod( oForm ) ) + + QOut( "Delete CalcArea" ) + oDelInline( oForm, "CalcArea" ) + + QOut( "What methods are in the class :" ) + HBDebug( aoMethod( oForm ) ) + + QOut( "Delete Smile" ) + oDelMethod( oForm, "Smile" ) + + QOut( "What methods are in the class :" ) + HBDebug( aoMethod( oForm ) ) + + Pause() + + QOut( "Data items before" ) + HBDebug( oForm ) + + QOut( "Let's delete cHelp" ) + + oDelData( oForm, "cHelp" ) + + QOut( "Data items after" ) + HBDebug( oForm ) + +/* oForm:cHelp := "Please crash" */ + +return nil + + +function TForm() + + static oClass + + if oClass == nil + oClass = TClass():New( "TFORM" ) // starts a new class definition + + oClass:AddData( "cText" ) // define this class objects datas + oClass:AddData( "nTop" ) + oClass:AddData( "nLeft" ) + oClass:AddData( "nBottom" ) + oClass:AddData( "nRight" ) + + oClass:AddMethod( "New", @New() ) // define this class objects methods + oClass:AddInline( "Show", {|self| ::cText } ) + + oClass:Create() // builds this class + endif + +return oClass:Instance() // builds an object of this class + + +static function New() + + local Self := QSelf() + + ::nTop := 10 + ::nLeft := 10 + ::nBottom := 20 + ::nRight := 40 + +return Self + + +static function Smile() + + local self := QSelf() + + if ::CalcArea() == 300 + QOut( ":-)" ) + else + QOut( ":-(" ) + endif +return self + + +static function BigSmile() + + local self := QSelf() + + QOut( ":-)))" ) +return self + + +function Pause() + + __Accept( "Pause :" ) +return nil + + +