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

2006-09-11 20:10 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

Browse Source 
* harbour/include/hbapicls.ch
    * added HB_EXPORT to public functions and some internal covered by
      _HB_API_INTERNAL_ macro

  * harbour/include/hboo.ch
    + added HB_OO_CLSTP_NONVIRTUAL and HB_OO_CLSTP_OVERLOADED

  * harbour/source/rtl/tclass.prg
    ! do not add supercast class messages - now it's done automatically
      by __clsNew() function with proper instance area offset updating
    ! enumerate instance class datas in __clsAddMsg() from 1 - inherited
      instance variables are managed internally by classy code with
      proper instance area offset updating
    ! use __CLS_CNTCLSDATA() as start offset for class data. Do not
      try to calculate it yourself - some of super classes can be ignored
      when they are appear in the inheritance tree more then once so it's
      not possible to calculate class data or instance data start offset
      using simple sum of class or instance variables in super classes.

  * harbour/source/vm/classes.c
    ! fixed instance area casting
    ! fixed class variables casting
    ! fixed multi-inheritance when the same class can apear more then
      once in super classes tree.
    ! Do not add unnecessary instance variables for the same class when
      it's inherited more then once.
    ! Do not add unnecessary class variables for the same class when
      it's inherited more then once.
    ! Do not add unnecessary initialization class and instance variables
    + added support for non virtual messages
    + added support for static and casted scoping
    + super cast messages added automatically. They are used to dynamic
      recalculation of instance are offsets and to avoid multiple inheritance
      of the same class so please do not overload them or you will have as
      result something what we have before recent modifications in the
      instance and class data area. Just simply run tests/clsccast.prg
      and tests/clsicast.prg compiled with current CVS code and last
      release code or with xHarbour and compare the results.
      Also Class(y) does not pass these tests and I do not know if any
      other dynamic OOP model in xbase languages can properly address it.
      BTW maybe I should add RT error when .prg code will try to delete
      or overwrite class cast message. For me it seems to be reasonable
      and what's your opinion?
    * make hidden class members non virtual by default. It can be disabled
      by compiling classes.c with -DHB_VIRTUAL_HIDDEN but IMHO keeping
      HIDDEN members as virtual causes that they are not really HIDDEN
      because subclasses can simply overwrite them. It also means that
      it's not possible to create class with some private data and
      methods which will never interact with any subclass code created
      by other programmers where name conflict can appear. So one of
      the most important OOP features is missing in such case.
      See tests/clsnv.prg as an example for non virtual hidden members.

  + tests/clsicast.prg
    + added test code for proper instance area allocating and casting

  + tests/clsccast.prg
    + added test code for proper class data allocating and casting

  + tests/clsnv.prg
    + added test code for non virtual hidden class members

   Now we should be able to create and class model even replicate the
   static one like in C++ using current class engine which still fully
   supports dynamic bindings. It consumes less memory and due to much
   more efficient hashing it should be faster then it was though some
   other minor optimization can be add and I'll plan to make them in
   some spare time.
   The item type verification in assignment is still missing. I'll add
   it when I'll collect some statistic informantion I'd like to ask
   [x]Harbour users. I need these information to tune some internal
   structures where I can balance between speed and memory allocation
   to statistically optimal form.

   Marek asked me to add passing object datas by reference and I'll do
   that but I'd like to ask Ryszard to add support for:
      @<oVar>:<message>
   to compiler. I'll implement all other HVM modifications. If you can
   please also add support for:
      <oVar>:&<cMsgName>[(...)]
   For this we do not need any HVM modifications or new PCODEs.
   We are supporting xBase++ macro list compilation in:
      cList:="1,2,3"
      x := aVar[ &cList ]
      aVar:={ &cList }
      func( &cList )
   But we do not support:
      <oVar>:<message>( &cList )
   IMHO it looks ugly. If we have this syntax for function call then we
   should also support it in message sending.
   Ryszard can you make necessary compiler modifications?
   I'm also thinking about adding support for variable parameters
      func myfunc(...)
      [...]
      return xVar
   In few cases it will help to encode some function much more efficient
   then now.

   I'll add Class(y) compatible functions used in class(y) header files
   so it will be possible to use original class(y) .ch files in Harbour
   though it will not be the most efficient because we have @func() operator
   which gives better performance then using codeblocks. Anyhow classy
   create separate meta class for each class with CLASS members and
   <clasName>() function always return such meta class object so for full
   Class(y) compatibility we need to generate differ .prg code.
   But all such modifications now can be done on preprocessor and
   .prg level and they will not need .c code modification.
   We should make them to give user interface for our new OOP features.

   Now I'm waiting for reports about any problems with current classy
   code.
This commit is contained in:
Przemyslaw Czerpak
2006-09-11 18:14:41 +00:00
parent e10df29fdd
commit 7463296f9e
8 changed files with 1184 additions and 191 deletions
Download Patch File Download Diff File Expand all files Collapse all files

113
harbour/ChangeLog
View File

@@ -8,6 +8,119 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
* harbour/source/vm/itemapi.c
+ added support for FOR EACH overloading - it's work in progress
do not create any code which may use current solution - it may
change in the nearest future
2006-09-12 14:48 UTC+0300 Alexander Kresin <alex@belacy.belgorod.su>
* source/rtl/cdpapi.c
! Bug fixed
2006-09-12 12:37 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/source/vm/classes.c
! fixed typo in adding SHARED CLASS VAR ASSIGN messages
* some minor cleanup
2006-09-11 20:10 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/include/hbapicls.ch
* added HB_EXPORT to public functions and some internal covered by
_HB_API_INTERNAL_ macro
* harbour/include/hboo.ch
+ added HB_OO_CLSTP_NONVIRTUAL and HB_OO_CLSTP_OVERLOADED
* harbour/source/rtl/tclass.prg
! do not add supercast class messages - now it's done automatically
by __clsNew() function with proper instance area offset updating
! enumerate instance class datas in __clsAddMsg() from 1 - inherited
instance variables are managed internally by classy code with
proper instance area offset updating
! use __CLS_CNTCLSDATA() as start offset for class data. Do not
try to calculate it yourself - some of super classes can be ignored
when they are appear in the inheritance tree more then once so it's
not possible to calculate class data or instance data start offset
using simple sum of class or instance variables in super classes.
* harbour/source/vm/classes.c
! fixed instance area casting
! fixed class variables casting
! fixed multi-inheritance when the same class can apear more then
once in super classes tree.
! Do not add unnecessary instance variables for the same class when
it's inherited more then once.
! Do not add unnecessary class variables for the same class when
it's inherited more then once.
! Do not add unnecessary initialization class and instance variables
+ added support for non virtual messages
+ added support for static and casted scoping
+ super cast messages added automatically. They are used to dynamic
recalculation of instance are offsets and to avoid multiple inheritance
of the same class so please do not overload them or you will have as
result something what we have before recent modifications in the
instance and class data area. Just simply run tests/clsccast.prg
and tests/clsicast.prg compiled with current CVS code and last
release code or with xHarbour and compare the results.
Also Class(y) does not pass these tests and I do not know if any
other dynamic OOP model in xbase languages can properly address it.
BTW maybe I should add RT error when .prg code will try to delete
or overwrite class cast message. For me it seems to be reasonable
and what's your opinion?
* make hidden class members non virtual by default. It can be disabled
by compiling classes.c with -DHB_VIRTUAL_HIDDEN but IMHO keeping
HIDDEN members as virtual causes that they are not really HIDDEN
because subclasses can simply overwrite them. It also means that
it's not possible to create class with some private data and
methods which will never interact with any subclass code created
by other programmers where name conflict can appear. So one of
the most important OOP features is missing in such case.
See tests/clsnv.prg as an example for non virtual hidden members.
+ tests/clsicast.prg
+ added test code for proper instance area allocating and casting
+ tests/clsccast.prg
+ added test code for proper class data allocating and casting
+ tests/clsnv.prg
+ added test code for non virtual hidden class members
Now we should be able to create and class model even replicate the
static one like in C++ using current class engine which still fully
supports dynamic bindings. It consumes less memory and due to much
more efficient hashing it should be faster then it was though some
other minor optimization can be add and I'll plan to make them in
some spare time.
The item type verification in assignment is still missing. I'll add
it when I'll collect some statistic informantion I'd like to ask
[x]Harbour users. I need these information to tune some internal
structures where I can balance between speed and memory allocation
to statistically optimal form.
Marek asked me to add passing object datas by reference and I'll do
that but I'd like to ask Ryszard to add support for:
Ryszard can you make necessary compiler modifications?
to compiler. I'll implement all other HVM modifications. If you can
please also add support for:
<oVar>:&<cMsgName>[(...)]
For this we do not need any HVM modifications or new PCODEs.
We are supporting xBase++ macro list compilation in:
cList:="1,2,3"
x := aVar[ &cList ]
aVar:={ &cList }
func( &cList )
But we do not support:
<oVar>:<message>( &cList )
IMHO it looks ugly. If we have this syntax for function call then we
should also support it in message sending.
Ryszard can you make necessary compiler modifications?
I'm also thinking about adding support for variable parameters
func myfunc(...)
[...]
return xVar
In few cases it will help to encode some function much more efficient
then now.
I'll add Class(y) compatible functions used in class(y) header files
so it will be possible to use original class(y) .ch files in Harbour
though it will not be the most efficient because we have @func() operator

35
harbour/include/hbapicls.h
View File

@@ -57,6 +57,8 @@
HB_EXTERN_BEGIN
#ifdef _HB_API_INTERNAL_
#define HB_OO_OP_PLUS 0
#define HB_OO_OP_MINUS 1
#define HB_OO_OP_MULT 2
@@ -86,37 +88,36 @@ HB_EXTERN_BEGIN
#define HB_OO_MAX_OPERATOR 25
/* class management */
extern void hb_clsInit( void ); /* initialize Classy/OO system at HVM startup */
extern void hb_clsReleaseAll( void ); /* releases all defined classes */
extern void hb_clsIsClassRef( void ); /* classes.c - mark all class internals as used */
extern char * hb_clsName( USHORT uiClass );
/* has this function to be public? */
extern BOOL hb_clsIsParent( USHORT uiClass, char * szParentName ); /* is a class handle inherited from szParentName Class ? */
/* object management */
#ifdef _HB_API_INTERNAL_
extern PHB_SYMB hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pSymMsg, PHB_STACK_STATE pStack ); /* returns the method pointer of an object class */
#endif
extern BOOL hb_objHasOperator( PHB_ITEM pObject, USHORT uiOperator );
extern BOOL hb_objOperatorCall( USHORT uiOperator, HB_ITEM_PTR pResult, PHB_ITEM pObject, PHB_ITEM pMsgArg1, PHB_ITEM pMsgArg2 );
extern USHORT hb_objGetClass( PHB_ITEM pItem ); /* get object class handle */
extern char * hb_objGetClsName( PHB_ITEM pObject ); /* retrieves an object class name */
extern char * hb_objGetRealClsName( PHB_ITEM pObject, char * szString ); /* retrieves an object class name for a specific message */
extern BOOL hb_objHasMsg( PHB_ITEM pObject, char * szString ); /* returns TRUE/FALSE whether szString is an existing message for object */
extern BOOL hb_objHasMessage( PHB_ITEM pObject, PHB_DYNS pMessage );
extern void hb_objSendMsg( PHB_ITEM pObj, char *sMsg, ULONG ulArg, ... );
extern void hb_objSendMessage( PHB_ITEM pObj, PHB_DYNS pMessage, ULONG ulArg, ... );
#ifndef HB_NO_PROFILER
/* profiler for object management */
extern BOOL hb_bProfiler; /* profiler activity status */
extern void hb_mthAddTime( ULONG ); /* profiler from classes.c */
#endif
#endif
/* class management */
HB_EXPORT extern char * hb_clsName( USHORT uiClass );
HB_EXPORT extern BOOL hb_clsIsParent( USHORT uiClass, char * szParentName ); /* is a class handle inherited from szParentName Class ? */
/* object management */
HB_EXPORT extern USHORT hb_objGetClass( PHB_ITEM pItem ); /* get object class handle */
HB_EXPORT extern char * hb_objGetClsName( PHB_ITEM pObject ); /* retrieves an object class name */
HB_EXPORT extern char * hb_objGetRealClsName( PHB_ITEM pObject, char * szString ); /* retrieves an object class name for a specific message */
HB_EXPORT extern BOOL hb_objHasMsg( PHB_ITEM pObject, char * szString ); /* returns TRUE/FALSE whether szString is an existing message for object */
HB_EXPORT extern BOOL hb_objHasMessage( PHB_ITEM pObject, PHB_DYNS pMessage );
HB_EXPORT extern void hb_objSendMsg( PHB_ITEM pObj, char *sMsg, ULONG ulArg, ... );
HB_EXPORT extern void hb_objSendMessage( PHB_ITEM pObj, PHB_DYNS pMessage, ULONG ulArg, ... );
HB_EXTERN_END
#endif /* HB_APICLS_H_ */

26
harbour/include/hboo.ch
View File

@@ -72,17 +72,21 @@
#define HB_MSGLISTPURE 2
/* Method or Data attribute (nScope)*/
#define HB_OO_CLSTP_EXPORTED 1 /* No comment, default */
#define HB_OO_CLSTP_PROTECTED 2 /* Only usable from one of the object's method (even sublclassed object) */
#define HB_OO_CLSTP_HIDDEN 4 /* Only usable from one of the object's method (and not from sublclassed one) */
#define HB_OO_CLSTP_CTOR 8 /* Constructor (Not yet used) */
#define HB_OO_CLSTP_READONLY 16 /* No comment */
#define HB_OO_CLSTP_SHARED 32 /* Allow a classvar (or classmethod) to be shared by all the subclasses.
Not the default behaviour as each subclass will have its own copy by default. */
#define HB_OO_CLSTP_CLASS 64 /* The related message is a superobject call, uidata is the superclass handle
pInitValue contain one superclass object instance (absolutely needed for Inline msg and class data) */
#define HB_OO_CLSTP_SUPER 128 /* The related message is inherited from a superclass */
#define HB_OO_CLSTP_PERSIST 256 /* Message is persistent (PROPERTY) */
#define HB_OO_CLSTP_EXPORTED 1 /* No comment, default */
#define HB_OO_CLSTP_PROTECTED 2 /* Only usable from one of the object's method (even sublclassed object) */
#define HB_OO_CLSTP_HIDDEN 4 /* Only usable from one of the object's method (and not from sublclassed one) */
#define HB_OO_CLSTP_CTOR 8 /* Constructor (Not yet used) */
#define HB_OO_CLSTP_READONLY 16 /* No comment */
#define HB_OO_CLSTP_SHARED 32 /* Allow a classvar (or classmethod) to be shared by all the subclasses.
Not the default behaviour as each subclass will have its own copy by default. */
#define HB_OO_CLSTP_CLASS 64 /* The related message is a superobject call, uidata is the superclass handle
pInitValue contain one superclass object instance (absolutely needed for Inline msg and class data) */
#define HB_OO_CLSTP_SUPER 128 /* The related message is inherited from a superclass */
#define HB_OO_CLSTP_PERSIST 256 /* Message is persistent (PROPERTY) */
#define HB_OO_CLSTP_NONVIRTUAL 512 /* Non Virtual message - should not be covered
by subclass(es) messages when executed
from a given class message */
#define HB_OO_CLSTP_OVERLOADED 1024 /* message overload NONVIRTUAL one */
/* Message types */
#define HB_OO_MSG_METHOD 0

20
harbour/source/rtl/tclass.prg
View File

@@ -181,8 +181,7 @@ STATIC PROCEDURE Create()
LOCAL n
LOCAL nLen := Len( ::acSuper )
LOCAL nLenDatas := Len( ::aDatas ) //Datas local to the class !!
LOCAL nDataBegin := 0
LOCAL nClassBegin := 0
LOCAL nClassBegin
LOCAL hClass
LOCAL ahSuper := Array( nLen )
@@ -194,18 +193,10 @@ STATIC PROCEDURE Create()
FOR n := 1 TO nLen
ahSuper[ n ] := __clsInstSuper( Upper( ::acSuper[ n ] ) ) // Super handle available
NEXT
hClass := __clsNew( ::cName, nLenDatas, ahSuper )
__clsAddMsg( hClass, "SUPER" , nDataBegin, HB_OO_MSG_SUPER, ahSuper[ 1 ], HB_OO_CLSTP_EXPORTED )
__clsAddMsg( hClass, "__SUPER", nDataBegin, HB_OO_MSG_SUPER, ahSuper[ 1 ], HB_OO_CLSTP_EXPORTED )
FOR n := 1 TO nLen
__clsAddMsg( hClass, Upper( ::acSuper[ n ] ), nDataBegin, HB_OO_MSG_SUPER, ahSuper[ n ], HB_OO_CLSTP_EXPORTED + HB_OO_CLSTP_CLASS )
nDataBegin += __cls_CntData( ahSuper[ n ] ) // Get offset for new DATAs
nClassBegin += __cls_CntClsData( ahSuper[ n ] ) // Get offset for new ClassData
NEXT
__clsAddMsg( hClass, "SUPER" , 0, HB_OO_MSG_SUPER, ahSuper[ 1 ], HB_OO_CLSTP_EXPORTED )
__clsAddMsg( hClass, "__SUPER", 0, HB_OO_MSG_SUPER, ahSuper[ 1 ], HB_OO_CLSTP_EXPORTED )
ENDIF
__clsAddMsg( hClass, ::cName , 0, HB_OO_MSG_SUPER , hClass, HB_OO_CLSTP_EXPORTED )
__clsAddMsg( hClass, "REALCLASS" , 0, HB_OO_MSG_REALCLASS, 0 , HB_OO_CLSTP_EXPORTED )
::hClass := hClass
@@ -221,10 +212,10 @@ STATIC PROCEDURE Create()
//Local message...
FOR n := 1 TO nLenDatas
__clsAddMsg( hClass, ::aDatas[ n ][ HB_OO_DATA_SYMBOL ] , n + nDataBegin, ;
__clsAddMsg( hClass, ::aDatas[ n ][ HB_OO_DATA_SYMBOL ] , n, ;
HB_OO_MSG_ACCESS, ::aDatas[ n ][ HB_OO_DATA_VALUE ], ::aDatas[ n ][ HB_OO_DATA_SCOPE ],;
::aDatas[ n ][ HB_OO_DATA_PERSISTENT ] )
__clsAddMsg( hClass, "_" + ::aDatas[ n ][ HB_OO_DATA_SYMBOL ] , n + nDataBegin, ;
__clsAddMsg( hClass, "_" + ::aDatas[ n ][ HB_OO_DATA_SYMBOL ] , n, ;
HB_OO_MSG_ASSIGN, , ::aDatas[ n ][ HB_OO_DATA_SCOPE ] )
NEXT
@@ -235,6 +226,7 @@ STATIC PROCEDURE Create()
NEXT
nLen := Len( ::aClsDatas )
nClassBegin := __CLS_CNTCLSDATA( hClass )
FOR n := 1 TO nLen
__clsAddMsg( hClass, ::aClsDatas[ n ][ HB_OO_CLSD_SYMBOL ] , n + nClassBegin,;
HB_OO_MSG_CLSACCESS, ::aClsDatas[ n ][ HB_OO_CLSD_VALUE ], ::aClsDatas[ n ][ HB_OO_CLSD_SCOPE ] )

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

@@ -156,7 +156,9 @@ typedef struct
{
PHB_ITEM pInitValue; /* Init Value for data */
USHORT uiType; /* HB_OO_MSG_DATA, HB_OO_MSG_CLASSDATA or HB_OO_MSG_INITIALIZED */
USHORT uiData; /* Item position in instance area or in class data */
USHORT uiData; /* Item position in instance area or class data */
USHORT uiOffset; /* Supper cast instance are offset */
USHORT uiSprClass; /* The real class where method were defined */
} INITDATA, * PINITDATA;
typedef struct
@@ -166,7 +168,7 @@ typedef struct
USHORT uiSprClass; /* Originalclass'handel (super or current class'handel if not herited). */ /*Added by RAC&JF*/
USHORT uiScope; /* Scoping value */
USHORT uiData; /* Item position for instance data or shared data (Harbour like, begin from 1) or supercast offset (from 0) */
USHORT uiInit; /* position in pInitData (from 1) or 0 */
USHORT uiOffset; /* position in pInitData for class datas (from 1) or offset to instance area in inherited instance data (from 0) */
#ifndef HB_NO_PROFILER
ULONG ulCalls; /* profiler support */
ULONG ulTime; /* profiler support */
@@ -187,7 +189,7 @@ typedef struct
USHORT uiMethods; /* Total Method initialised Counter */
USHORT uiInitDatas; /* Total Method initialised Counter */
USHORT uiDatas; /* Total Data Counter */
USHORT uiDataFirst; /* First uiData from this class */
USHORT uiDataFirst; /* First instance item from this class */
USHORT uiHashKey;
} CLASS, * PCLASS;
@@ -430,25 +432,23 @@ static void hb_clsCopyClass( PCLASS pClsDst, PCLASS pClsSrc )
/* CLASS DATA Not Shared ( new array, new value ) */
pClsDst->pClassDatas = hb_arrayClone( pClsSrc->pClassDatas );
pClsDst->pInlines = hb_arrayClone( pClsSrc->pInlines );
pClsDst->uiDatas = pClsSrc->uiDatas;
pClsDst->ulOpFlags = pClsSrc->ulOpFlags;
if( pClsSrc->uiInitDatas )
{
USHORT uiData, uiType;
ULONG ulSize = ( ULONG ) pClsSrc->uiInitDatas * sizeof( INITDATA );
USHORT uiData;
pClsDst->uiInitDatas = pClsSrc->uiInitDatas;
pClsDst->pInitData = ( PINITDATA ) hb_xgrab( pClsSrc->uiInitDatas *
sizeof( INITDATA ) );
for( uiData = 0; uiData < pClsSrc->uiInitDatas; ++uiData )
pClsDst->pInitData = ( PINITDATA ) hb_xgrab( ulSize );
memcpy( pClsDst->pInitData, pClsSrc->pInitData, ulSize );
for( uiData = 0; uiData < pClsDst->uiInitDatas; ++uiData )
{
uiType = pClsSrc->pInitData[ uiData ].uiType;
if( uiType == HB_OO_MSG_INITIALIZED )
uiType = HB_OO_MSG_CLASSDATA;
if( pClsDst->pInitData[ uiData ].uiType == HB_OO_MSG_INITIALIZED )
pClsDst->pInitData[ uiData ].uiType = HB_OO_MSG_CLASSDATA;
pClsDst->pInitData[ uiData ].pInitValue =
hb_itemNew( pClsSrc->pInitData[ uiData ].pInitValue );
pClsDst->pInitData[ uiData ].uiType = uiType;
pClsDst->pInitData[ uiData ].uiData =
pClsSrc->pInitData[ uiData ].uiData;
hb_itemNew( pClsDst->pInitData[ uiData ].pInitValue );
}
}
@@ -533,26 +533,50 @@ static void hb_clsFreeMsg( PCLASS pClass, PHB_DYNS pMsg )
}
static USHORT hb_clsAddInitValue( PCLASS pClass, PHB_ITEM pItem,
USHORT uiType, USHORT uiData )
USHORT uiType, USHORT uiData,
USHORT uiOffset, USHORT uiSprClass )
{
PINITDATA pInitData;
HB_TRACE(HB_TR_DEBUG, ("hb_clsAddInitValue(%p,%p,%hu,%hu)", pClass, pItem, uiType, uiData));
HB_TRACE(HB_TR_DEBUG, ("hb_clsAddInitValue(%p,%p,%hu,%hu,%hu,%hu)", pClass, pItem, uiType, uiData, uiOffset, uiSprClass));
if( ! pItem || HB_IS_NIL( pItem ) )
return 0;
if( ! pClass->uiInitDatas )
{
pClass->pInitData = ( PINITDATA ) hb_xgrab( sizeof( INITDATA ) );
pInitData = pClass->pInitData + pClass->uiInitDatas++;
}
else
pClass->pInitData = ( PINITDATA ) hb_xrealloc( pClass->pInitData,
( pClass->uiInitDatas + 1 ) * sizeof( INITDATA ) );
{
USHORT ui = pClass->uiInitDatas;
pInitData = pClass->pInitData;
do
{
if( pInitData->uiType == uiType &&
pInitData->uiData + pInitData->uiOffset == uiData + uiOffset )
{
hb_itemRelease( pInitData->pInitValue );
break;
}
++pInitData;
}
while( --ui );
pInitData = pClass->pInitData + pClass->uiInitDatas++;
if( ui == 0 )
{
pClass->pInitData = ( PINITDATA ) hb_xrealloc( pClass->pInitData,
( ULONG ) ( pClass->uiInitDatas + 1 ) * sizeof( INITDATA ) );
pInitData = pClass->pInitData + pClass->uiInitDatas++;
}
}
pInitData->pInitValue = hb_itemClone( pItem );
pInitData->uiType = uiType;
pInitData->uiData = uiData;
pInitData->uiOffset = uiOffset;
pInitData->uiSprClass = uiSprClass;
return pClass->uiInitDatas;
}
@@ -862,7 +886,7 @@ static void hb_clsScope( PHB_ITEM pObject, PMETHOD pMethod )
}
#endif
char * hb_clsName( USHORT uiClass )
HB_EXPORT char * hb_clsName( USHORT uiClass )
{
if( uiClass && uiClass <= s_uiClasses )
return ( s_pClasses + ( uiClass - 1 ) )->szName;
@@ -884,7 +908,7 @@ static USHORT hb_clsParentInstanceOffset( PCLASS pClass, PHB_DYNS pParentSym )
return ( pMethod && pMethod->pFuncSym == &s___msgSuper ) ? pMethod->uiData : 0;
}
BOOL hb_clsIsParent( USHORT uiClass, char * szParentName )
HB_EXPORT BOOL hb_clsIsParent( USHORT uiClass, char * szParentName )
{
if( uiClass && uiClass <= s_uiClasses )
{
@@ -904,7 +928,7 @@ BOOL hb_clsIsParent( USHORT uiClass, char * szParentName )
return FALSE;
}
USHORT hb_objGetClass( PHB_ITEM pItem )
HB_EXPORT USHORT hb_objGetClass( PHB_ITEM pItem )
{
if( pItem && HB_IS_ARRAY( pItem ) )
return pItem->item.asArray.value->uiClass;
@@ -920,7 +944,7 @@ USHORT hb_objGetClass( PHB_ITEM pItem )
* Get the class name of an object
*
*/
char * hb_objGetClsName( PHB_ITEM pObject )
HB_EXPORT char * hb_objGetClsName( PHB_ITEM pObject )
{
char * szClassName;
@@ -990,7 +1014,7 @@ char * hb_objGetClsName( PHB_ITEM pObject )
* of inheritance.
*
*/
char * hb_objGetRealClsName( PHB_ITEM pObject, char * szName )
HB_EXPORT char * hb_objGetRealClsName( PHB_ITEM pObject, char * szName )
{
HB_TRACE(HB_TR_DEBUG, ("hb_objGetrealClsName(%p)", pObject));
@@ -1082,27 +1106,40 @@ static USHORT hb_clsSenderObjectClasss( void )
return 0;
}
static PHB_SYMB hb_clsValidScope( PHB_ITEM pObject, PMETHOD pMethod )
static PHB_SYMB hb_clsValidScope( PHB_ITEM pObject, PMETHOD pMethod,
PHB_STACK_STATE pStack )
{
USHORT uiScope = pMethod->uiScope;
if( uiScope & ( HB_OO_CLSTP_HIDDEN | HB_OO_CLSTP_PROTECTED ) )
if( pMethod->uiScope & ( HB_OO_CLSTP_HIDDEN | HB_OO_CLSTP_PROTECTED |
HB_OO_CLSTP_OVERLOADED ) )
{
USHORT uiSenderClass = hb_clsSenderMethodClasss();
if( uiSenderClass )
{
if( uiScope & HB_OO_CLSTP_HIDDEN )
if( pMethod->uiScope & HB_OO_CLSTP_OVERLOADED &&
uiSenderClass != pMethod->uiSprClass )
{
PCLASS pClass = s_pClasses + ( uiSenderClass - 1 );
PMETHOD pHiddenMthd = hb_clsFindMsg( pClass, pMethod->pMessage );
if( pHiddenMthd )
{
pMethod = pHiddenMthd;
pStack->uiClass = uiSenderClass;
pStack->uiMethod = pMethod - pClass->pMethods;
}
}
if( pMethod->uiScope & HB_OO_CLSTP_HIDDEN )
{
/* Class(y) does not allow to write to HIDDEN+READONLY
instance variables, [druzus] */
if( ( uiScope & HB_OO_CLSTP_READONLY ) == 0 )
if( ( pMethod->uiScope & HB_OO_CLSTP_READONLY ) == 0 )
{
if( uiSenderClass == pMethod->uiSprClass )
return pMethod->pFuncSym;
}
}
else
else if( pMethod->uiScope & HB_OO_CLSTP_PROTECTED )
{
#ifdef HB_STATIC_PROTECT_SCOPE
if( uiSenderClass == pMethod->uiSprClass ||
@@ -1119,6 +1156,8 @@ static PHB_SYMB hb_clsValidScope( PHB_ITEM pObject, PMETHOD pMethod )
#endif
return pMethod->pFuncSym;
}
else
return pMethod->pFuncSym;
}
return &s___msgScopeErr;
@@ -1128,11 +1167,12 @@ static PHB_SYMB hb_clsValidScope( PHB_ITEM pObject, PMETHOD pMethod )
}
/*
* <pFuncSym> = hb_objGetMethod( <pObject>, <pMessage>, <fpPopSuper> )
* <pFuncSym> = hb_objGetMethod( <pObject>, <pMessage>, <pStackState> )
*
* Internal function to the function pointer of a message of an object
*/
PHB_SYMB hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pMessage, PHB_STACK_STATE pStack )
PHB_SYMB hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pMessage,
PHB_STACK_STATE pStack )
{
PCLASS pClass = NULL;
PHB_DYNS pMsg;
@@ -1171,7 +1211,7 @@ PHB_SYMB hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pMessage, PHB_STACK_STATE p
if( pStack )
{
pStack->uiMethod = pMethod - pClass->pMethods;
return hb_clsValidScope( pObject, pMethod );
return hb_clsValidScope( pObject, pMethod, pStack );
}
return pMethod->pFuncSym;
}
@@ -1356,7 +1396,7 @@ BOOL hb_objOperatorCall( USHORT uiOperator, HB_ITEM_PTR pResult, PHB_ITEM pObjec
/*
* return TRUE if object has a given message
*/
BOOL hb_objHasMessage( PHB_ITEM pObject, PHB_DYNS pMessage )
HB_EXPORT BOOL hb_objHasMessage( PHB_ITEM pObject, PHB_DYNS pMessage )
{
return hb_objGetMethod( pObject, pMessage->pSymbol, NULL ) != NULL;
}
@@ -1368,7 +1408,7 @@ BOOL hb_objHasMessage( PHB_ITEM pObject, PHB_DYNS pMessage )
*
* <uPtr> should be read as a boolean
*/
BOOL hb_objHasMsg( PHB_ITEM pObject, char *szString )
HB_EXPORT BOOL hb_objHasMsg( PHB_ITEM pObject, char *szString )
{
PHB_DYNS pDynSym;
@@ -1385,7 +1425,7 @@ BOOL hb_objHasMsg( PHB_ITEM pObject, char *szString )
}
}
void hb_objSendMessage( PHB_ITEM pObject, PHB_DYNS pMsgSym, ULONG ulArg, ... )
HB_EXPORT void hb_objSendMessage( PHB_ITEM pObject, PHB_DYNS pMsgSym, ULONG ulArg, ... )
{
if( pObject && pMsgSym )
{
@@ -1412,7 +1452,7 @@ void hb_objSendMessage( PHB_ITEM pObject, PHB_DYNS pMsgSym, ULONG ulArg, ... )
}
}
void hb_objSendMsg( PHB_ITEM pObject, char *sMsg, ULONG ulArg, ... )
HB_EXPORT void hb_objSendMsg( PHB_ITEM pObject, char *sMsg, ULONG ulArg, ... )
{
hb_vmPushSymbol( hb_dynsymGet( sMsg )->pSymbol );
hb_vmPush( pObject );
@@ -1572,12 +1612,13 @@ static USHORT hb_clsUpdateScope( USHORT uiScope, BOOL fAssign )
* HB_OO_CLSTP_CLASS 64 : message is the name of a superclass
* HB_OO_CLSTP_SUPER 128 : message is herited
* HB_OO_CLSTP_PERSIST 256 : message is persistent (PROPERTY)
* HB_OO_CLSTP_NONVIRTUAL 512 : Class method constructor
* HB_OO_CLSTP_OVERLOADED 1024 : Class method constructor
*
* HB_OO_CLSTP_CLASSCTOR 512 : Class method constructor
* HB_OO_CLSTP_CLASSMETH 1024 : Class method
* HB_OO_CLSTP_CLASSCTOR 2048 : Class method constructor
* HB_OO_CLSTP_CLASSMETH 4096 : Class method
*/
HB_FUNC( __CLSADDMSG )
{
USHORT uiClass = ( USHORT ) hb_parni( 1 );
@@ -1591,7 +1632,7 @@ HB_FUNC( __CLSADDMSG )
USHORT uiOperator, uiSprClass = 0, uiIndex = 0;
PHB_SYMB pOpSym, pFuncSym = NULL;
PHB_ITEM pBlock = NULL;
BOOL fOK, fAssign;
BOOL fOK;
ULONG ulOpFlags = 0;
char * szMessage = hb_parc( 2 );
USHORT nType = ( USHORT ) hb_parni( 4 );
@@ -1664,8 +1705,6 @@ HB_FUNC( __CLSADDMSG )
}
}
fAssign = pMessage->pSymbol->szName[ 0 ] == '_';
/* basic parameter validation */
switch( nType )
{
@@ -1687,31 +1726,29 @@ HB_FUNC( __CLSADDMSG )
uiIndex <= pClass->uiDatas;
break;
case HB_OO_MSG_REALCLASS:
uiIndex = ( USHORT ) hb_parni( 3 );
fOK = TRUE;
break;
case HB_OO_MSG_DATA:
nType = fAssign ? HB_OO_MSG_ASSIGN : HB_OO_MSG_ACCESS;
nType = pMessage->pSymbol->szName[ 0 ] == '_' ?
HB_OO_MSG_ASSIGN : HB_OO_MSG_ACCESS;
case HB_OO_MSG_ASSIGN:
case HB_OO_MSG_ACCESS:
uiIndex = ( USHORT ) hb_parni( 3 );
/* This validation can break buggy .prg code which wrongly
* sets data offsets but IMHO it will help to clean the code.
* [druzus]
*/
case HB_OO_MSG_ASSIGN:
case HB_OO_MSG_ACCESS:
uiIndex = ( USHORT ) hb_parni( 3 );
fOK = uiIndex && uiIndex <= pClass->uiDatas;
fOK = uiIndex && uiIndex <= pClass->uiDatas - pClass->uiDataFirst;
break;
case HB_OO_MSG_CLASSDATA:
nType = fAssign ? HB_OO_MSG_CLSASSIGN : HB_OO_MSG_CLSACCESS;
nType = pMessage->pSymbol->szName[ 0 ] == '_' ?
HB_OO_MSG_CLSASSIGN : HB_OO_MSG_CLSACCESS;
case HB_OO_MSG_CLSASSIGN:
case HB_OO_MSG_CLSACCESS:
uiIndex = ( USHORT ) hb_parni( 3 );
fOK = uiIndex != 0;
break;
case HB_OO_MSG_REALCLASS:
case HB_OO_MSG_VIRTUAL:
fOK = TRUE;
break;
@@ -1730,12 +1767,26 @@ HB_FUNC( __CLSADDMSG )
if( ! pNewMeth )
return;
#ifndef HB_VIRTUAL_HIDDEN
if( uiScope & HB_OO_CLSTP_HIDDEN )
uiScope |= HB_OO_CLSTP_NONVIRTUAL;
#endif
if( ! pNewMeth->pMessage )
pClass->uiMethods++; /* One more message */
else if( ! hb_clsClearMsg( pClass, pNewMeth ) )
return;
else
{
BOOL fOverLoad = ( pNewMeth->uiScope & HB_OO_CLSTP_OVERLOADED ) ||
( ( pNewMeth->uiScope & HB_OO_CLSTP_NONVIRTUAL ) &&
pNewMeth->uiSprClass != uiClass );
if( ! hb_clsClearMsg( pClass, pNewMeth ) )
return;
memset( pNewMeth, 0, sizeof( METHOD ) );
if( fOverLoad )
uiScope |= HB_OO_CLSTP_OVERLOADED;
}
pNewMeth->pMessage = pMessage;
pNewMeth->uiSprClass = uiClass ; /* now used !! */
@@ -1749,36 +1800,38 @@ HB_FUNC( __CLSADDMSG )
case HB_OO_MSG_ASSIGN:
pNewMeth->uiData = uiIndex;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, fAssign );
pNewMeth->pFuncSym = &s___msgSetData;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, TRUE );
pNewMeth->uiData = uiIndex;
pNewMeth->uiOffset = pClass->uiDataFirst;
break;
case HB_OO_MSG_ACCESS:
pNewMeth->pFuncSym = &s___msgGetData;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, FALSE );
pNewMeth->uiData = uiIndex;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, fAssign );
pNewMeth->pFuncSym = &s___msgGetData;
pNewMeth->uiInit = hb_clsAddInitValue( pClass,
hb_param( 5, HB_IT_ANY ), HB_OO_MSG_DATA, pNewMeth->uiData );
pNewMeth->uiOffset = pClass->uiDataFirst;
hb_clsAddInitValue( pClass, hb_param( 5, HB_IT_ANY ), HB_OO_MSG_DATA,
pNewMeth->uiData, pNewMeth->uiOffset, uiClass );
break;
case HB_OO_MSG_CLSASSIGN:
pNewMeth->uiData = uiIndex;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, fAssign );
if( hb_arrayLen( pClass->pClassDatas ) < ( ULONG ) pNewMeth->uiData )
hb_arraySize( pClass->pClassDatas, pNewMeth->uiData );
if( pNewMeth->uiScope & HB_OO_CLSTP_SHARED )
pNewMeth->pFuncSym = &s___msgSetShrData;
else
pNewMeth->pFuncSym = &s___msgSetClsData;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, TRUE );
pNewMeth->uiData = uiIndex;
if( hb_arrayLen( pClass->pClassDatas ) < ( ULONG ) pNewMeth->uiData )
hb_arraySize( pClass->pClassDatas, pNewMeth->uiData );
break;
case HB_OO_MSG_CLSACCESS:
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, FALSE );
pNewMeth->uiData = uiIndex;
pNewMeth->uiScope = hb_clsUpdateScope( uiScope, fAssign );
if( hb_arrayLen( pClass->pClassDatas ) < ( ULONG ) pNewMeth->uiData )
hb_arraySize( pClass->pClassDatas, pNewMeth->uiData );
if( pNewMeth->uiScope & HB_OO_CLSTP_SHARED )
@@ -1800,41 +1853,40 @@ HB_FUNC( __CLSADDMSG )
}
else
{
pNewMeth->uiInit = hb_clsAddInitValue( pClass,
pNewMeth->uiOffset = hb_clsAddInitValue( pClass,
hb_param( 5, HB_IT_ANY ), HB_OO_MSG_CLASSDATA,
pNewMeth->uiData );
pNewMeth->uiData, 0, uiClass );
pNewMeth->pFuncSym = &s___msgGetClsData;
}
break;
case HB_OO_MSG_INLINE:
pNewMeth->uiData = ( USHORT ) ( hb_arrayLen( pClass->pInlines ) + 1 );
pNewMeth->pFuncSym = &s___msgEvalInline;
pNewMeth->uiScope = uiScope;
pNewMeth->uiData = ( USHORT ) ( hb_arrayLen( pClass->pInlines ) + 1 );
hb_arraySize( pClass->pInlines, pNewMeth->uiData );
hb_arraySet( pClass->pInlines, pNewMeth->uiData, pBlock );
hb_clsSetInlineClass( pClass, pNewMeth->uiData, uiClass );
pNewMeth->pFuncSym = &s___msgEvalInline;
break;
case HB_OO_MSG_VIRTUAL:
pNewMeth->uiScope = uiScope;
pNewMeth->pFuncSym = &s___msgVirtual;
pNewMeth->uiScope = uiScope;
break;
case HB_OO_MSG_SUPER:
pNewMeth->uiData = uiIndex; /* offset to instance area */
pNewMeth->uiSprClass = uiSprClass; /* store the super handel */
pNewMeth->uiData = uiIndex; /* offset to instance area */
pNewMeth->uiScope = uiScope;
pNewMeth->pFuncSym = &s___msgSuper;
break;
case HB_OO_MSG_REALCLASS:
pNewMeth->uiData = uiIndex; /* offset to instance area */
pNewMeth->uiScope = uiScope;
pNewMeth->pFuncSym = &s___msgRealClass;
pNewMeth->uiScope = uiScope;
break;
case HB_OO_MSG_ONERROR:
@@ -1861,14 +1913,14 @@ HB_FUNC( __CLSADDMSG )
* <cClassName> Name of the class
* <nDatas> Number of DATAs in the class
* <ahSuper> Optional handle(s) of superclass(es)
* <aoSuper> Optional superclass(es) Object instance -
* seems it's not implemented
*/
HB_FUNC( __CLSNEW )
{
PCLASS pNewCls;
PMETHOD pMethod;
PHB_ITEM pahSuper;
USHORT ui, uiSuper, uiSuperCls;
USHORT * puiClassData = NULL, uiClassDataSize = 0;
pahSuper = hb_param( 3, HB_IT_ARRAY );
uiSuper = ( USHORT ) ( pahSuper ? hb_arrayLen( pahSuper ) : 0 );
@@ -1895,70 +1947,93 @@ HB_FUNC( __CLSNEW )
{
hb_clsCopyClass( pNewCls, pSprCls );
}
else
else if( !hb_clsHasParent( pNewCls, pSprCls->pClassSym ) )
{
PHB_DYNS pMsg;
PHB_ITEM pClsAnyTmp;
ULONG ul, ulLimit, ulLen;
ULONG ul, ulLimit;
USHORT nLenClsDatas;
ulLimit = hb_clsMthNum( pSprCls );
/* Ok add now the previous len to the offset */
nLenClsDatas = ( USHORT ) hb_itemSize( pNewCls->pClassDatas );
/* ClassDatas */
ulLen = hb_itemSize( pSprCls->pClassDatas );
if( ulLen )
/* create class data translation tables */
nLenClsDatas = ( USHORT ) hb_itemSize( pSprCls->pClassDatas );
if( nLenClsDatas )
{
pClsAnyTmp = hb_arrayClone( pSprCls->pClassDatas );
hb_arraySize( pNewCls->pClassDatas, nLenClsDatas + ulLen );
for( ul = 1; ul <= ulLen; ul++ )
if( nLenClsDatas > uiClassDataSize )
{
hb_itemCopy( hb_arrayGetItemPtr( pNewCls->pClassDatas,
nLenClsDatas + ul ),
hb_arrayGetItemPtr( pClsAnyTmp, ul ) );
if( puiClassData )
puiClassData = ( USHORT * ) hb_xrealloc( puiClassData,
sizeof( USHORT ) * nLenClsDatas );
else
puiClassData = ( USHORT * ) hb_xgrab( sizeof( USHORT ) *
nLenClsDatas );
uiClassDataSize = nLenClsDatas;
}
hb_itemRelease( pClsAnyTmp );
memset( puiClassData, 0, sizeof( USHORT ) * nLenClsDatas );
}
/* Copy init datas */
/* Copy super classs handles */
ulLimit = hb_clsMthNum( pSprCls );
for( ul = 0; ul < ulLimit; ++ul )
{
if( pSprCls->pMethods[ ul ].pMessage &&
pSprCls->pMethods[ ul ].pFuncSym == &s___msgSuper )
{
PCLASS pCls = s_pClasses +
( pSprCls->pMethods[ ul ].uiSprClass - 1 );
pMethod = hb_clsAllocMsg( pNewCls,
pSprCls->pMethods[ ul ].pMessage );
if( ! pMethod )
return;
if( pMethod->pMessage == NULL )
{
pNewCls->uiMethods++;
memcpy( pMethod, pSprCls->pMethods + ul, sizeof( METHOD ) );
pMethod->uiData = pNewCls->uiDatas;
pNewCls->uiDatas += pCls->uiDatas - pCls->uiDataFirst;
}
}
}
/* add class casting if not exist */
pMethod = hb_clsAllocMsg( pNewCls, pSprCls->pClassSym );
if( ! pMethod )
return;
if( pMethod->pMessage == NULL )
{
pNewCls->uiMethods++;
pMethod->pMessage = pSprCls->pClassSym;
pMethod->uiSprClass = uiSuperCls;
pMethod->uiScope = HB_OO_CLSTP_EXPORTED;
pMethod->pFuncSym = &s___msgSuper;
pMethod->uiData = pNewCls->uiDatas;
pNewCls->uiDatas += pSprCls->uiDatas - pSprCls->uiDataFirst;
}
/* Copy instance area init data */
if( pSprCls->uiInitDatas )
{
USHORT uiData, uiStart = pNewCls->uiInitDatas, uiType;
pNewCls->uiInitDatas += pSprCls->uiInitDatas;
if( ! uiStart )
pNewCls->pInitData = ( PINITDATA )
hb_xgrab( pNewCls->uiInitDatas * sizeof( INITDATA ) );
else
pNewCls->pInitData = ( PINITDATA ) hb_xrealloc( pNewCls->pInitData,
pNewCls->uiInitDatas * sizeof( INITDATA ) );
for( uiData = 0; uiData < pSprCls->uiInitDatas; ++uiData )
USHORT ui;
for( ui = 0; ui < pSprCls->uiInitDatas; ++ui )
{
uiType = pSprCls->pInitData[ uiData ].uiType;
if( uiType == HB_OO_MSG_INITIALIZED )
uiType = HB_OO_MSG_CLASSDATA;
pNewCls->pInitData[ uiData + uiStart ].pInitValue =
hb_itemNew( pSprCls->pInitData[ uiData ].pInitValue );
pNewCls->pInitData[ uiData + uiStart ].uiType = uiType;
pNewCls->pInitData[ uiData + uiStart ].uiData =
pSprCls->pInitData[ uiData ].uiData +
( uiType == HB_OO_MSG_CLASSDATA ? nLenClsDatas :
( uiType == HB_OO_MSG_DATA ? pNewCls->uiDatas : 0 ) );
if( pSprCls->pInitData[ ui ].uiType == HB_OO_MSG_DATA )
{
USHORT uiCls = pSprCls->pInitData[ ui ].uiSprClass;
hb_clsAddInitValue( pNewCls,
pSprCls->pInitData[ ui ].pInitValue, HB_OO_MSG_DATA,
pSprCls->pInitData[ ui ].uiData,
hb_clsParentInstanceOffset( pNewCls,
( s_pClasses + ( uiCls - 1 ) )->pClassSym ),
uiCls );
}
}
}
/* Now working on pMethods */
for( ul = 0; ul < ulLimit; ul++ )
/* Now working on other methods */
ulLimit = hb_clsMthNum( pSprCls );
for( ul = 0; ul < ulLimit; ++ul )
{
pMsg = ( PHB_DYNS ) pSprCls->pMethods[ ul ].pMessage;
if( pMsg )
if( pSprCls->pMethods[ ul ].pMessage )
{
PMETHOD pMethod = hb_clsAllocMsg( pNewCls, pMsg );
pMethod = hb_clsAllocMsg( pNewCls, pSprCls->pMethods[ ul ].pMessage );
if( ! pMethod )
return;
@@ -1978,28 +2053,47 @@ HB_FUNC( __CLSNEW )
else if( pMethod->pFuncSym == &s___msgSetClsData ||
pMethod->pFuncSym == &s___msgGetClsData )
{
pMethod->uiData += nLenClsDatas;
if( pMethod->uiData > nLenClsDatas )
hb_errInternal( HB_EI_CLSINVMETHOD, NULL, "__clsNew", NULL );
if( puiClassData[ pMethod->uiData - 1 ] == 0 )
{
puiClassData[ pMethod->uiData - 1 ] = ( USHORT )
hb_arrayLen( pNewCls->pClassDatas ) + 1;
hb_arraySize( pNewCls->pClassDatas,
puiClassData[ pMethod->uiData - 1 ] );
}
if( pMethod->uiOffset )
{
pMethod->uiOffset = hb_clsAddInitValue( pNewCls,
pSprCls->pInitData[ pMethod->uiOffset - 1 ].pInitValue,
HB_OO_MSG_CLASSDATA, puiClassData[ pMethod->uiData - 1 ],
0, uiSuperCls );
}
pMethod->uiData = puiClassData[ pMethod->uiData - 1 ];
}
else if( pMethod->pFuncSym == &s___msgSetData ||
pMethod->pFuncSym == &s___msgGetData ||
pMethod->pFuncSym == &s___msgSuper ||
pMethod->pFuncSym == &s___msgRealClass )
pMethod->pFuncSym == &s___msgGetData )
{
pMethod->uiData += pNewCls->uiDatas;
USHORT uiIndex = pMethod->uiData + pMethod->uiOffset;
if( uiIndex > pSprCls->uiDatas )
hb_errInternal( HB_EI_CLSINVMETHOD, NULL, "__clsNew", NULL );
pMethod->uiOffset = hb_clsParentInstanceOffset( pNewCls,
( s_pClasses + ( pMethod->uiSprClass - 1 ) )->pClassSym );
}
pMethod->uiScope |= HB_OO_CLSTP_SUPER;
}
else if( pSprCls->pMethods[ ul ].uiScope &
( HB_OO_CLSTP_OVERLOADED | HB_OO_CLSTP_NONVIRTUAL ) )
pMethod->uiScope |= HB_OO_CLSTP_OVERLOADED;
}
}
pNewCls->ulOpFlags |= pSprCls->ulOpFlags;
}
pNewCls->uiDatas += pSprCls->uiDatas;
pNewCls->ulOpFlags |= pSprCls->ulOpFlags;
}
}
pNewCls->uiDataFirst = pNewCls->uiDatas;
pNewCls->uiDatas += ( USHORT ) hb_parni( 2 );
if( puiClassData )
hb_xfree( puiClassData );
if( !pNewCls->pMethods )
{
@@ -2008,9 +2102,43 @@ HB_FUNC( __CLSNEW )
pNewCls->pInlines = hb_itemArrayNew( 0 );
}
/* add self class casting */
pMethod = hb_clsAllocMsg( pNewCls, pNewCls->pClassSym );
if( ! pMethod )
return;
if( pMethod->pMessage == NULL )
{
pNewCls->uiMethods++;
pMethod->pMessage = pNewCls->pClassSym;
pMethod->uiSprClass = s_uiClasses;
pMethod->uiScope = HB_OO_CLSTP_EXPORTED;
pMethod->pFuncSym = &s___msgSuper;
pMethod->uiData = pNewCls->uiDatas;
}
pNewCls->uiDataFirst = pNewCls->uiDatas;
pNewCls->uiDatas += ( USHORT ) hb_parni( 2 );
hb_retni( s_uiClasses );
}
HB_FUNC( __CLSSOFFSET )
{
USHORT uiClass = ( USHORT ) hb_parni( 1 );
char * szSuper = hb_parc( 2 );
if( uiClass && uiClass <= s_uiClasses && szSuper )
{
PHB_DYNS pDynSym = hb_dynsymFindName( szSuper );
if( pDynSym )
{
hb_retni( hb_clsParentInstanceOffset( s_pClasses + ( uiClass - 1 ),
pDynSym ) );
}
}
}
/*
* __clsDelMsg( <oObj>, <cMessage> )
@@ -2062,10 +2190,12 @@ static PHB_ITEM hb_clsInst( USHORT uiClass )
do
{
if( pInitData->uiType == HB_OO_MSG_DATA )
pDestItm = hb_arrayGetItemPtr( pSelf, pInitData->uiData );
pDestItm = hb_arrayGetItemPtr( pSelf,
pInitData->uiData + pInitData->uiOffset );
else if( pInitData->uiType == HB_OO_MSG_CLASSDATA )
{
pDestItm = hb_arrayGetItemPtr( pClass->pClassDatas, pInitData->uiData );
pDestItm = hb_arrayGetItemPtr( pClass->pClassDatas,
pInitData->uiData );
/* do not initialize it again */
pInitData->uiType = HB_OO_MSG_INITIALIZED;
}
@@ -2324,14 +2454,14 @@ HB_FUNC( __CLS_CNTDATA )
/*
* <nSeq> = __cls_DecData( <hClass> )
*
* Return number of datas and decrease
* Decrease number of datas and return new value
*/
HB_FUNC( __CLS_DECDATA )
{
USHORT uiClass = ( USHORT ) hb_parni( 1 );
if( uiClass && uiClass <= s_uiClasses && s_pClasses[ uiClass - 1 ].uiDatas )
hb_retni( s_pClasses[ uiClass - 1 ].uiDatas-- );
hb_retni( --s_pClasses[ uiClass - 1 ].uiDatas );
else
hb_retni( 0 );
}
@@ -2339,15 +2469,13 @@ HB_FUNC( __CLS_DECDATA )
/*
* <nSeq> = __cls_IncData( <hClass> )
*
* Return number of datas and increase
* Increase number of datas and return new value
*/
HB_FUNC( __CLS_INCDATA )
{
USHORT uiClass = ( USHORT ) hb_parni( 1 );
if( uiClass && uiClass <= s_uiClasses )
/* TOFIX: fix the description or change preincrementation to postinc */
hb_retni( ++s_pClasses[ uiClass - 1 ].uiDatas );
else
hb_retni( 0 );
@@ -2760,7 +2888,8 @@ static HARBOUR hb___msgRealClass( void )
USHORT uiClass = hb_clsSenderMethodClasss();
if( uiClass &&
hb_clsSenderObjectClasss() == pObject->item.asArray.value->uiClass )
hb_clsSenderObjectClasss() == pObject->item.asArray.value->uiClass &&
uiClass != pObject->item.asArray.value->uiClass )
{
PHB_ITEM pCopy = hb_itemArrayNew(1);
@@ -2874,8 +3003,17 @@ static HARBOUR hb___msgGetData( void )
if( uiClass != pObject->item.asArray.value->uiClass )
{
ulIndex += hb_clsParentInstanceOffset( s_pClasses + ( uiObjClass - 1 ),
pClass->pClassSym );
PCLASS pCls1 = s_pClasses + ( uiObjClass - 1 );
PCLASS pCls2 = s_pClasses + ( pMethod->uiSprClass - 1 );
PHB_DYNS pSym = pCls2->pClassSym;
ulIndex += hb_clsParentInstanceOffset( pCls1, pSym );
// ulIndex += hb_clsParentInstanceOffset( s_pClasses + ( uiObjClass - 1 ),
// ( s_pClasses + ( pMethod->uiSprClass - 1 ) )->pClassSym );
}
else
{
ulIndex += pMethod->uiOffset;
}
/* will arise only if the class has been modified after first instance */
@@ -2904,7 +3042,11 @@ static HARBOUR hb___msgSetData( void )
if( uiClass != pObject->item.asArray.value->uiClass )
{
ulIndex += hb_clsParentInstanceOffset( s_pClasses + ( uiObjClass - 1 ),
pClass->pClassSym );
( s_pClasses + ( pMethod->uiSprClass - 1 ) )->pClassSym );
}
else
{
ulIndex += pMethod->uiOffset;
}
/* will arise only if the class has been modified after first instance */

340
harbour/tests/clsccast.prg Normal file
View File

@@ -0,0 +1,340 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* demonstration/test code for class variables casting and allocating
* in multiinherited classes
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*
*/
#define EOL chr(10)
#xtranslate QQOUT([<x,...>]) => [OUTSTD(<x>)]
#xtranslate QOUT([<x,...>]) => OUTSTD(EOL)[;OUTSTD(<x>)]
#ifdef __HARBOUR__
#include "hbclass.ch"
#translate MESSAGE <message> INLINE <*expr*> ;
=> ;
METHOD <message> INLINE <expr>
#else
#include "class(y).ch"
#xtranslate __SENDER( => SENDER(
#endif
proc main()
local o:=myclass4():new(), i, cbErr
? DATE(), TIME(), VERSION(), OS()
?
? "myclass1 class vars:", str( __CLS_CNTCLSDATA(o:myclass1:classH), 3), " => should be: 3"
? "myclass2 class vars:", str( __CLS_CNTCLSDATA(o:myclass2:classH), 3), " => should be: 6"
? "myclass3 class vars:", str( __CLS_CNTCLSDATA(o:myclass3:classH), 3), " => should be: 9"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "myclass4 class vars:", str( __CLS_CNTCLSDATA(o:myclass4:classH), 3), " => should be: 12"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? "myclass4 class vars:", str( __CLS_CNTCLSDATA(o:classH), 3), " => should be: 12"
?
/* direct assignment, possible because the variables have differ names */
? "instance variables ["+ltrim(str(len(o)))+"]:"; ?
for i:=1 to len(o); ?? "",o[i]; next
? " => shoule be [0]:"
?
? "initialization..."
o:x1:=" X1 "; o:y1:=" Y1 "; o:z1:=" Z1 "
o:x2:=" X2 "; o:y2:=" Y2 "; o:z2:=" Z2 "
o:x3:=" X3 "; o:y3:=" Y3 "; o:z3:=" Z3 "
o:x4:=" X4 "; o:y4:=" Y4 "; o:z4:=" Z4 "
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: (x1) (y1) (z1)"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: (x1) (y1) (z1)"
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: (x2) (y2) (z2)"
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: (x1) (y1) (z1)"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: (x2) (y2) (z2)"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: (x3) (y3) (z3)"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: X1 Y1 Z1"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: X2 Y2 Z2"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: X3 Y3 Z3"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: X4 Y4 Z4"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: X1 Y1 Z1"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: X2 Y2 Z2"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "instance variables ["+ltrim(str(len(o)))+"]:"; ?
for i:=1 to len(o); ?? "",o[i]; next
? " => shoule be [0]:"
?
? "Setting MYCLASS1 class variables..."
o:myclass1:x1:="[X1]"
o:myclass1:y1:="[Y1]"
o:myclass1:z1:="[Z1]"
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: [X1] [Y1] [Z1]"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: (x1) (y1) (z1)"
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: (x2) (y2) (z2)"
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: (x1) (y1) (z1)"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: (x2) (y2) (z2)"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: (x3) (y3) (z3)"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: X1 Y1 Z1"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: X2 Y2 Z2"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: X3 Y3 Z3"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: X4 Y4 Z4"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: X1 Y1 Z1"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: X2 Y2 Z2"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "Setting MYCLASS2 class variables..."
o:myclass2:x1:="{X1}"
o:myclass2:y1:="{Y1}"
o:myclass2:z1:="{Z1}"
o:myclass2:x2:="{X2}"
o:myclass2:y2:="{Y2}"
o:myclass2:z2:="{Z2}"
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: [X1] [Y1] [Z1]"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: {X1} {Y1} {Z1}"
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: {X2} {Y2} {Z2}"
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: (x1) (y1) (z1)"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: (x2) (y2) (z2)"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: (x3) (y3) (z3)"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: X1 Y1 Z1"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: X2 Y2 Z2"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: X3 Y3 Z3"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: X4 Y4 Z4"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: X1 Y1 Z1"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: X2 Y2 Z2"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "Setting MYCLASS3 class variables..."
o:myclass3:x1:="<X1>"
o:myclass3:y1:="<Y1>"
o:myclass3:z1:="<Z1>"
o:myclass3:x2:="<X2>"
o:myclass3:y2:="<Y2>"
o:myclass3:z2:="<Z2>"
o:myclass3:x3:="<X3>"
o:myclass3:y3:="<Y3>"
o:myclass3:z3:="<Z3>"
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: [X1] [Y1] [Z1]"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: {X1} {Y1} {Z1}"
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: {X2} {Y2} {Z2}"
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: <X1> <Y1> <Z1>"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: <X2> <Y2> <Z2>"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: <X3> <Y3> <Z3>"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: X1 Y1 Z1"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: X2 Y2 Z2"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: X3 Y3 Z3"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: X4 Y4 Z4"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: X1 Y1 Z1"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: X2 Y2 Z2"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "Setting MYCLASS4 class variables..."
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
o:myclass4:x1:="|X1|"
o:myclass4:y1:="|Y1|"
o:myclass4:z1:="|Z1|"
o:myclass4:x2:="|X2|"
o:myclass4:y2:="|Y2|"
o:myclass4:z2:="|Z2|"
o:myclass4:x3:="|X3|"
o:myclass4:y3:="|Y3|"
o:myclass4:z3:="|Z3|"
o:myclass4:x4:="|X4|"
o:myclass4:y4:="|Y4|"
o:myclass4:z4:="|Z4|"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: [X1] [Y1] [Z1]"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: {X1} {Y1} {Z1}"
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: {X2} {Y2} {Z2}"
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: <X1> <Y1> <Z1>"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: <X2> <Y2> <Z2>"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: <X3> <Y3> <Z3>"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: |X1| |Y1| |Z1|"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: |X2| |Y2| |Z2|"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: |X3| |Y3| |Z3|"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: |X4| |Y4| |Z4|"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: |X1| |Y1| |Z1|"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: |X2| |Y2| |Z2|"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: |X3| |Y3| |Z3|"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: |X4| |Y4| |Z4|"
?
? "Setting MYCLASS3:MYCLASS1 class variables..."
o:myclass3:myclass1:x1:="^X1^"
o:myclass3:myclass1:y1:="^Y1^"
o:myclass3:myclass1:z1:="^Z1^"
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: ^X1^ ^Y1^ ^Z1^"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: {X1} {Y1} {Z1}"
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: {X2} {Y2} {Z2}"
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: <X1> <Y1> <Z1>"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: <X2> <Y2> <Z2>"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: <X3> <Y3> <Z3>"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: |X1| |Y1| |Z1|"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: |X2| |Y2| |Z2|"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: |X3| |Y3| |Z3|"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: |X4| |Y4| |Z4|"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: |X1| |Y1| |Z1|"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: |X2| |Y2| |Z2|"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: |X3| |Y3| |Z3|"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: |X4| |Y4| |Z4|"
?
? "Setting MYCLASS3:MYCLASS2 class variables..."
o:myclass3:myclass2:x1:="=X1="
o:myclass3:myclass2:y1:="=Y1="
o:myclass3:myclass2:z1:="=Z1="
o:myclass3:myclass2:x2:="=X2="
o:myclass3:myclass2:y2:="=Y2="
o:myclass3:myclass2:z2:="=Z2="
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: ^X1^ ^Y1^ ^Z1^"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: =X1= =Y1= =Z1="
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: =X2= =Y2= =Z2="
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: <X1> <Y1> <Z1>"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: <X2> <Y2> <Z2>"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: <X3> <Y3> <Z3>"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: |X1| |Y1| |Z1|"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: |X2| |Y2| |Z2|"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: |X3| |Y3| |Z3|"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: |X4| |Y4| |Z4|"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: |X1| |Y1| |Z1|"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: |X2| |Y2| |Z2|"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: |X3| |Y3| |Z3|"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: |X4| |Y4| |Z4|"
?
? "Setting SUPER class variables..."
o:super:x1:="*X1*"
o:super:y1:="*Y1*"
o:super:z1:="*Z1*"
o:super:x2:="*X2*"
o:super:y2:="*Y2*"
o:super:z2:="*Z2*"
o:super:x3:="*X3*"
o:super:y3:="*Y3*"
o:super:z3:="*Z3*"
? "[1] MYCLASS1 VARS:", o:myclass1:x1, o:myclass1:y1, o:myclass1:z1, " => should be: ^X1^ ^Y1^ ^Z1^"
? "[2] MYCLASS1 VARS:", o:myclass2:x1, o:myclass2:y1, o:myclass2:z1, " => should be: =X1= =Y1= =Z1="
? "[2] MYCLASS2 VARS:", o:myclass2:x2, o:myclass2:y2, o:myclass2:z2, " => should be: =X2= =Y2= =Z2="
? "[3] MYCLASS1 VARS:", o:myclass3:x1, o:myclass3:y1, o:myclass3:z1, " => should be: *X1* *Y1* *Z1*"
? "[3] MYCLASS2 VARS:", o:myclass3:x2, o:myclass3:y2, o:myclass3:z2, " => should be: *X2* *Y2* *Z2*"
? "[3] MYCLASS3 VARS:", o:myclass3:x3, o:myclass3:y3, o:myclass3:z3, " => should be: *X3* *Y3* *Z3*"
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "[4] MYCLASS1 VARS:", o:myclass4:x1, o:myclass4:y1, o:myclass4:z1, " => should be: |X1| |Y1| |Z1|"
? "[4] MYCLASS2 VARS:", o:myclass4:x2, o:myclass4:y2, o:myclass4:z2, " => should be: |X2| |Y2| |Z2|"
? "[4] MYCLASS3 VARS:", o:myclass4:x3, o:myclass4:y3, o:myclass4:z3, " => should be: |X3| |Y3| |Z3|"
? "[4] MYCLASS4 VARS:", o:myclass4:x4, o:myclass4:y4, o:myclass4:z4, " => should be: |X4| |Y4| |Z4|"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? " MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: |X1| |Y1| |Z1|"
? " MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: |X2| |Y2| |Z2|"
? " MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: |X3| |Y3| |Z3|"
? " MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: |X4| |Y4| |Z4|"
?
? "instance variables ["+ltrim(str(len(o)))+"]:"; ?
for i:=1 to len(o); ?? "",o[i]; next
? " => shoule be [0]:"
?
return
create class myclass1
export:
class var x1 init "(x1)"
class var y1 init "(y1)"
class var z1 init "(z1)"
endclass
create class myclass2 from myclass1
export:
class var x2 init "(x2)"
class var y2 init "(y2)"
class var z2 init "(z2)"
endclass
create class myclass3 from myclass1, myclass2
export:
class var x3 init "(x3)"
class var y3 init "(y3)"
class var z3 init "(z3)"
endclass
create class myclass4 from myclass3, myclass2
export:
class var x4 init "(x4)"
class var y4 init "(y4)"
class var z4 init "(z4)"
endclass

175
harbour/tests/clsicast.prg Normal file
View File

@@ -0,0 +1,175 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* demonstration/test code for instance variables casting and allocating
* in multiinherited classes
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*
*/
#define EOL chr(10)
#xtranslate QQOUT([<x,...>]) => [OUTSTD(<x>)]
#xtranslate QOUT([<x,...>]) => OUTSTD(EOL)[;OUTSTD(<x>)]
#ifdef __HARBOUR__
#include "hbclass.ch"
#translate MESSAGE <message> INLINE <*expr*> ;
=> ;
METHOD <message> INLINE <expr>
#else
#include "class(y).ch"
#xtranslate __SENDER( => SENDER(
#endif
proc main()
local o:=myclass4():new(), i, cbErr
? DATE(), TIME(), VERSION(), OS()
?
/* direct assignment, possible because the variables have differ names */
? "instance variables ["+ltrim(str(len(o)))+"]:"; ?
for i:=1 to len(o); ?? "",o[i]; next
? " => shoule be [12]:"
? " (x1) (y1) (z1) (x2) (y2) (z2) (x3) (y3) (z3) (x4) (y4) (z4)"
?
? "initialization..."
o:x1:=" X1 "; o:y1:=" Y1 "; o:z1:=" Z1 "
o:x2:=" X2 "; o:y2:=" Y2 "; o:z2:=" Z2 "
o:x3:=" X3 "; o:y3:=" Y3 "; o:z3:=" Z3 "
o:x4:=" X4 "; o:y4:=" Y4 "; o:z4:=" Z4 "
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: X1 Y1 Z1"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: X2 Y2 Z2"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "instance variables ["+ltrim(str(len(o)))+"]:"; ?
for i:=1 to len(o); ?? "",o[i]; next
? " => shoule be [12]:"
? " X1 Y1 Z1 X2 Y2 Z2 X3 Y3 Z3 X4 Y4 Z4"
?
? "Setting MYCLASS1 instance variables..."
o:myclass1:x1:="[X1]"
o:myclass1:y1:="[Y1]"
o:myclass1:z1:="[Z1]"
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: [X1] [Y1] [Z1]"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: X2 Y2 Z2"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "Setting MYCLASS2 instance variables..."
o:myclass2:x2:="[X2]"
o:myclass2:y2:="[Y2]"
o:myclass2:z2:="[Z2]"
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: [X1] [Y1] [Z1]"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: [X2] [Y2] [Z2]"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: X3 Y3 Z3"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
? "Setting MYCLASS3 instance variables..."
o:myclass3:x3:="[X3]"
o:myclass3:y3:="[Y3]"
o:myclass3:z3:="[Z3]"
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: [X1] [Y1] [Z1]"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: [X2] [Y2] [Z2]"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: [X3] [Y3] [Z3]"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: X4 Y4 Z4"
?
cbErr:=errorBlock({|oErr|break(oErr)})
begin sequence
? "Setting MYCLASS4 instance variables..."
o:myclass4:x4:="[X4]"
o:myclass4:y4:="[Y4]"
o:myclass4:z4:="[Z4]"
recover
? "ERROR: no selfclass casting"
end
errorBlock(cbErr)
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: [X1] [Y1] [Z1]"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: [X2] [Y2] [Z2]"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: [X3] [Y3] [Z3]"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: [X4] [Y4] [Z4]"
?
? "Setting MYCLASS3:MYCLASS1 instance variables..."
o:myclass3:myclass1:x1:="<X1>"
o:myclass3:myclass1:y1:="<Y1>"
o:myclass3:myclass1:z1:="<Z1>"
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: <X1> <Y1> <Z1>"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: [X2] [Y2] [Z2]"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: [X3] [Y3] [Z3]"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: [X4] [Y4] [Z4]"
?
? "Setting MYCLASS3:MYCLASS2 instance variables..."
o:myclass3:myclass2:x2:="<X2>"
o:myclass3:myclass2:y2:="<Y2>"
o:myclass3:myclass2:z2:="<Z2>"
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: <X1> <Y1> <Z1>"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: <X2> <Y2> <Z2>"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: [X3] [Y3] [Z3]"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: [X4] [Y4] [Z4]"
?
? "Setting SUPER instance variables..."
o:super:x1:="{X1}"
o:super:y1:="{Y1}"
o:super:z1:="{Z1}"
o:super:x2:="{X2}"
o:super:y2:="{Y2}"
o:super:z2:="{Z2}"
o:super:x3:="{X3}"
o:super:y3:="{Y3}"
o:super:z3:="{Z3}"
? "MYCLASS1 VARS:", o:x1, o:y1, o:z1, " => should be: {X1} {Y1} {Z1}"
? "MYCLASS2 VARS:", o:x2, o:y2, o:z2, " => should be: {X2} {Y2} {Z2}"
? "MYCLASS3 VARS:", o:x3, o:y3, o:z3, " => should be: {X3} {Y3} {Z3}"
? "MYCLASS4 VARS:", o:x4, o:y4, o:z4, " => should be: [X4] [Y4] [Z4]"
?
? "instance variables ["+ltrim(str(len(o)))+"]:"; ?
for i:=1 to len(o); ?? "",o[i]; next
? " => shoule be [12]:"
? " {X1} {Y1} {Z1} {X2} {Y2} {Z2} {X3} {Y3} {Z3} [X4] [Y4] [Z4]"
?
return
create class myclass1
export:
var x1 init "(x1)"
var y1 init "(y1)"
var z1 init "(z1)"
endclass
create class myclass2 from myclass1
export:
var x2 init "(x2)"
var y2 init "(y2)"
var z2 init "(z2)"
endclass
create class myclass3 from myclass1, myclass2
export:
var x3 init "(x3)"
var y3 init "(y3)"
var z3 init "(z3)"
endclass
create class myclass4 from myclass3, myclass2
export:
var x4 init "(x4)"
var y4 init "(y4)"
var z4 init "(z4)"
endclass

226
harbour/tests/clsnv.prg Normal file
View File

@@ -0,0 +1,226 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* demonstration/test code for non virtual hidden messages
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*
*/
#define EOL chr(10)
#xtranslate QQOUT([<x,...>]) => [OUTSTD(<x>)]
#xtranslate QOUT([<x,...>]) => OUTSTD(EOL)[;OUTSTD(<x>)]
#ifdef __HARBOUR__
#include "hbclass.ch"
#translate MESSAGE <message> INLINE <*expr*> ;
=> ;
METHOD <message> INLINE <expr>
#else
#include "class(y).ch"
#xtranslate __SENDER( => SENDER(
#endif
proc main()
local o:=myclass3():new(), i, cbErr
? DATE(), TIME(), VERSION(), OS()
?
o:m1()
o:m2()
o:m3()
return
create class myclass1
hidden:
var a init "(a1)"
class var b init "(b1)"
method x
protected:
var c init "(c1)"
class var d init "(d1)"
method y
exported:
var e init "(e1)"
class var f init "(f1)"
method z
method m1
endclass
method m1
? "Method: MYCLASS1:M1()"
? " a =>", ::a, ", should be: (a1)"
? " b =>", ::b, ", should be: (b1)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
? " execute ::x(), should be: MYCLASS1:X()"
::x()
? " execute ::y(), should be: MYCLASS3:Y()"
::y()
? " execute ::z(), should be: MYCLASS3:Z()"
::z()
return self
method x
? " Method: MYCLASS1:X()"
? " a =>", ::a, ", should be: (a1)"
? " b =>", ::b, ", should be: (b1)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
method y
? " Method: MYCLASS1:Y()"
? " a =>", ::a, ", should be: (a1)"
? " b =>", ::b, ", should be: (b1)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
method z
? " Method: MYCLASS1:Z()"
? " a =>", ::a, ", should be: (a1)"
? " b =>", ::b, ", should be: (b1)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
create class myclass2
hidden:
var a init "(a2)"
class var b init "(b2)"
method x
protected:
var c init "(c2)"
class var d init "(d2)"
method y
exported:
var e init "(e2)"
class var f init "(f2)"
method z
method m2
endclass
method m2
? "Method: MYCLASS2:M2()"
? " a =>", ::a, ", should be: (a2)"
? " b =>", ::b, ", should be: (b2)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
? " execute ::x(), should be: MYCLASS2:X()"
::x()
? " execute ::y(), should be: MYCLASS3:Y()"
::y()
? " execute ::z(), should be: MYCLASS3:Z()"
::z()
return self
method x
? " Method: MYCLASS2:X()"
? " a =>", ::a, ", should be: (a2)"
? " b =>", ::b, ", should be: (b2)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
method y
? " Method: MYCLASS2:Y()"
? " a =>", ::a, ", should be: (a2)"
? " b =>", ::b, ", should be: (b2)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
method z
? " Method: MYCLASS2:Z()"
? " a =>", ::a, ", should be: (a2)"
? " b =>", ::b, ", should be: (b2)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
create class myclass3 from myclass1, myclass2
hidden:
var a init "(a3)"
class var b init "(b3)"
method x
protected:
var c init "(c3)"
class var d init "(d3)"
method y
exported:
var e init "(e3)"
class var f init "(f3)"
method z
method m3
endclass
method m3
? "Method: MYCLASS3:M3()"
? " a =>", ::a, ", should be: (a3)"
? " b =>", ::b, ", should be: (b3)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
? " execute ::x(), should be: MYCLASS3:X()"
::x()
? " execute ::y(), should be: MYCLASS3:Y()"
::y()
? " execute ::z(), should be: MYCLASS3:Z()"
::z()
return self
method x
? " Method: MYCLASS3:X()"
? " a =>", ::a, ", should be: (a3)"
? " b =>", ::b, ", should be: (b3)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
method y
? " Method: MYCLASS3:Y()"
? " a =>", ::a, ", should be: (a3)"
? " b =>", ::b, ", should be: (b3)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self
method z
? " Method: MYCLASS3:Z()"
? " a =>", ::a, ", should be: (a3)"
? " b =>", ::b, ", should be: (b3)"
? " c =>", ::c, ", should be: (c3)"
? " d =>", ::d, ", should be: (d3)"
? " e =>", ::e, ", should be: (e3)"
? " f =>", ::f, ", should be: (f3)"
return self