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

19990816-02:45 GMT+1

Browse Source
This commit is contained in:
Viktor Szakats
1999-08-16 01:07:21 +00:00
parent db23cdabe2
commit 5d4c16f38f
21 changed files with 605 additions and 454 deletions
Download Patch File Download Diff File Expand all files Collapse all files

111
harbour/ChangeLog
View File

@@ -1,3 +1,112 @@
19990816-02:45 GMT+1 Victor Szel <info@szelvesz.hu>
* include/extend.h
source/rtl/classes.c
source/rtl/objfunc.prg
source/rtl/tclass.prg
source/vm/hvm.c
source/tools/stringp.prg
tests/working/dynobj.prg
tests/working/debugtst.prg
tests/working/inherit.prg
tests/working/strip.prg
tests/working/objects.prg
% Some variables and functions made static in classes.c
! Completed init symbol list.
* Names changed to standard ones (they should also work in 10 chars mode):
ClassCreate -> __clsNew
ClassInstance -> __clsInst
__InstSuper -> __clsInstSuper
ClassAdd -> __clsAddMsg
ClassDel -> __clsDelMsg
ClassMod -> __clsModMsg
WClsDatas -> __cls_CntClsData
__wDatas -> __cls_CntData
__wDataDec -> __cls_DecData
__wDataInc -> __cls_IncData
aOMethod -> __objGetMethodList
aOData -> __objGetMsgList
aOGet -> __objGetValueList
aOSet -> __objSetValueList
oClone -> __objClone
ClassName -> __objGetClsName
oSend -> __objSendMsg
isMessage -> __objHasMsg
IsData -> __objHasData
IsMethod -> __objHasMethod
oAddMethod -> __objAddMethod
oAddInline -> __objAddInLine
oAddData -> __objAddData
oModMethod -> __objModMethod
oModInline -> __objModInLine
oDelMethod -> __objDelMethod
oDelInline -> __objDelInLine
oDelData -> __objDelData
ClassH -> __msgClsH
ClassName -> __msgClsName
ClassSel -> __msgClsSel
SelectSuper -> __msgSuper
EvalInline -> __msgEvalInline
GetClassData -> __msgGetClsData
SetClassData -> __msgSetClsData
GetData -> __msgGetData
SetData -> __msgSetData
Virtual -> __msgVirtual
DictRealloc -> hb_clsDictRealloc
ReleaseClass -> hb_clsRelease
ReleaseClasses -> hb_clsReleaseAll
hb_GetClassName -> hb_objGetClsName
hb_GetMethod -> hb_objGetMethod
hb_isMessage -> hb_objHasMsg
* include/hboo.ch
source/rtl/classes.c
source/rtl/objfunc.prg
source/rtl/tclass.prg
source/tools/stringp.prg
tests/working/dynobj.prg
tests/working/objects.prg
tests/working/overload.prg
tests/working/objects.prg
+ MET_ and DATA_ declaration moved to one place (hboo.ch).
* source/rtl/errorapi.c
include/errorapi.h
% hb_error*() functions are returning void instead of WORD, except for
hb_errorRT_BASE_Ext1().
* include/error.ch
include/langapi.h
source/rtl/langapi.c
+ New error code EG_ARRDIMENSION added
* source/rtl/arrays.c
! ARRAY() now properly checks the passed parameters (Clipper compatible).
+ ARRAY() TODO: added (to support multiple dimensions)
! AADD() Fixed parameter handling, throws errors like Clipper.
! ASIZE() Fixed parameter handling.
! hb_arrayIns() removed one error to be Clipper compatible.
! hb_arrayDel() removed one error to be Clipper compatible.
+ AFILL(), ASCAN(), AEVAL(), ACOPY() TOFIX: added.
* source/rtl/transform.c
! _exit -> exit (_exit had no prototype, and that was the only place
where it was used)
! Some BYTE and int changed to BOOL at obviouse place.
! Some functions made static.
! Some unused variables removed (lFact*)
19990815-18:45 GMT+2 Ryszard Glab <rglab@imid.med.pl>
*source/rtl/hvm.c
@@ -35,7 +144,7 @@
* added functionality - some methods implemented, added support of
footing, head separator, footer separator, freeze.
Now it seems almost complete.
19990815-17:40 GMT+1 Victor Szel <info@szelvesz.hu>
* bldodbc.bat
hbodbc.b32

5
harbour/include/error.ch
View File

@@ -56,7 +56,8 @@
#define EG_ARGCOUNT 45 /* Harbour special */
#define EG_ARRACCESS 46 /* Harbour special */
#define EG_ARRASSIGN 47 /* Harbour special */
#define EG_NOTARRAY 48 /* Harbour special */
#define EG_CONDITION 49 /* Harbour special */
#define EG_ARRDIMENSION 48 /* Harbour special */
#define EG_NOTARRAY 49 /* Harbour special */
#define EG_CONDITION 50 /* Harbour special */
#endif /* _ERROR_CH */

8
harbour/include/errorapi.h
View File

@@ -99,11 +99,11 @@ extern void hb_errRelease ( PHB_ITEM pError );
extern void hb_errorInternal ( ULONG ulIntCode, char * szText, char * szModul, WORD wLine, char * szPar1, char * szPar2, char * szPar3 );
extern WORD hb_errorRT_BASE ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern void hb_errorRT_BASE ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern WORD hb_errorRT_BASE_Ext1 ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation, USHORT uiOsCode, USHORT uiFlags );
extern WORD hb_errorRT_TERMINAL ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern WORD hb_errorRT_DBCMD ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern WORD hb_errorRT_TOOLS ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern void hb_errorRT_TERMINAL ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern void hb_errorRT_DBCMD ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern void hb_errorRT_TOOLS ( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation );
extern char * hb_errorNatDescription ( ULONG ulGenCode ); /* Reads error description in national language */
extern char * hb_errorNatInternal ( ULONG ulIntCode ); /* Reads internal error description in national language */

9
harbour/include/extend.h
View File

@@ -290,9 +290,12 @@ extern char * hb_strUpper( char * szText, long lLen );
extern char * hb_strLower( char * szText, long lLen );
/* class management */
extern PHB_FUNC hb_GetMethod( PHB_ITEM pObject, PHB_SYMB pSymMsg ); /* returns the method pointer of a object class */
extern char * hb_GetClassName( PHB_ITEM pObject ); /* retrieves an object class name */
extern ULONG hb_isMessage( PHB_ITEM, char * );
extern void hb_clsReleaseAll( void ); /* releases all defined classes */
/* object management */
extern char * hb_objGetClsName( PHB_ITEM pObject ); /* retrieves an object class name */
extern PHB_FUNC hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pSymMsg ); /* returns the method pointer of a object class */
extern ULONG hb_objHasMsg( PHB_ITEM pObject, char *szString );
/* dynamic symbol table management */
extern PHB_DYNS hb_dynsymGet( char * szName ); /* finds and creates a dynamic symbol if not found */

20
harbour/include/hboo.ch Normal file
View File

@@ -0,0 +1,20 @@
/*
* $Id$
*/
/* NOTE: This file is also used by C code. */
#ifndef _HBOO_CH
#define _HBOO_CH
#define MET_METHOD 0
#define MET_DATA 1
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#define MET_SUPER 5
#define DATA_SYMBOL 1
#define DATA_VAL 2
#endif /* _HBOO_CH */

2
harbour/include/langapi.h
View File

@@ -41,7 +41,7 @@
#define HB_LANG_TEXT_NOCHAR 2
#define HB_LANG_TEXT_MAX_ 3
#define HB_LANG_ED_MAX_ 50
#define HB_LANG_ED_MAX_ 51
#define HB_LANG_EI_MAX_ 6
/* ; */

101
harbour/source/rtl/arrays.c
View File

@@ -395,10 +395,6 @@ void hb_arrayDel( PHB_ITEM pArray, ULONG ulIndex )
hb_itemClear( pBaseArray->pItems + ( ulLen - 1 ) );
}
else
{
hb_errorRT_BASE(EG_BOUND, 1132, NULL, hb_langDGetErrorDesc(EG_ARRACCESS));
}
}
else
{
@@ -423,10 +419,6 @@ void hb_arrayIns( PHB_ITEM pArray, ULONG ulIndex )
hb_itemClear( pBaseArray->pItems + ulLen );
}
else
{
hb_errorRT_BASE(EG_BOUND, 1132, NULL, hb_langDGetErrorDesc(EG_ARRACCESS));
}
}
else
{
@@ -649,33 +641,76 @@ PHB_ITEM hb_arrayClone( PHB_ITEM pSrcArray )
/*
* HARBOUR
*/
/* TODO: Support multiple dimensions */
HARBOUR HB_ARRAY( void )
{
hb_arrayNew( &stack.Return, hb_parnl( 1 ) );
int iParCount = hb_pcount();
if ( iParCount > 0 )
{
int tmp;
BOOL lError = FALSE;
for ( tmp = 1; tmp <= iParCount; tmp++ )
{
if ( !ISNUM( tmp ) )
{
lError = TRUE;
break;
}
if ( hb_parnl( tmp ) < 0 )
{
hb_errorRT_BASE( EG_BOUND, 1131, NULL, hb_langDGetErrorDesc( EG_ARRDIMENSION ) );
}
}
if ( lError )
hb_ret();
else
hb_arrayNew( &stack.Return, hb_parnl( 1 ) );
}
else
hb_ret();
}
HARBOUR HB_AADD( void )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
PHB_ITEM pValue = hb_param( 2, IT_ANY );
if ( hb_pcount() == 2 )
{
if ( ISARRAY( 1 ) )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
PHB_ITEM pValue = hb_param( 2, IT_ANY );
if ( pArray )
hb_arrayAdd( pArray, pValue );
hb_arrayAdd( pArray, pValue );
hb_itemCopy( &stack.Return, pValue );
hb_itemCopy( &stack.Return, pValue );
}
else
hb_errorRT_BASE( EG_ARG, 1123, NULL, "AADD" );
}
else
/* QUESTION: Clipper catches this at compile time! */
hb_errorRT_BASE( EG_ARGCOUNT, 3000, NULL, "AADD" );
}
HARBOUR HB_ASIZE( void )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
if ( pArray )
{
hb_arraySize( pArray, hb_parnl( 2 ) );
hb_itemCopy( &stack.Return, pArray ); /* ASize() returns the array itself */
}
if ( pArray && ISNUM( 2 ) )
{
LONG lSize = hb_parnl( 2 );
hb_arraySize( pArray, MAX( lSize, 0 ) );
hb_itemCopy( &stack.Return, pArray ); /* ASize() returns the array itself */
}
else
hb_ret(); /* QUESTION: Should we raise an error here ? */
hb_ret();
}
HARBOUR HB_ATAIL( void )
@@ -685,7 +720,7 @@ HARBOUR HB_ATAIL( void )
if ( pArray )
hb_arrayLast( pArray, &stack.Return );
else
hb_ret(); /* QUESTION: Should we raise an error here ? */
hb_ret();
}
HARBOUR HB_AINS( void )
@@ -693,10 +728,12 @@ HARBOUR HB_AINS( void )
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
if ( pArray )
{
{
if ( ISNUM( 2 ) )
hb_arrayIns( pArray, hb_parnl( 2 ) );
hb_itemCopy( &stack.Return, pArray ); /* AIns() returns the array itself */
}
hb_itemCopy( &stack.Return, pArray ); /* AIns() returns the array itself */
}
else
hb_ret();
}
@@ -706,14 +743,18 @@ HARBOUR HB_ADEL( void )
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
if ( pArray )
{
{
if ( ISNUM( 2 ) )
hb_arrayDel( pArray, hb_parnl( 2 ) );
hb_itemCopy( &stack.Return, pArray ); /* ADel() returns the array itself */
}
hb_itemCopy( &stack.Return, pArray ); /* ADel() returns the array itself */
}
else
hb_ret();
}
/* TOFIX: nCount parameter == zero is incompatible. */
HARBOUR HB_AFILL( void )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
@@ -727,6 +768,8 @@ HARBOUR HB_AFILL( void )
hb_ret();
}
/* TOFIX: nCount parameter == zero is incompatible. */
HARBOUR HB_ASCAN( void )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
@@ -737,6 +780,8 @@ HARBOUR HB_ASCAN( void )
hb_retnl( 0 );
}
/* TOFIX: nCount parameter == zero is incompatible. */
HARBOUR HB_AEVAL( void )
{
PHB_ITEM pArray = hb_param( 1, IT_ARRAY );
@@ -751,6 +796,8 @@ HARBOUR HB_AEVAL( void )
hb_ret();
}
/* TOFIX: nCount parameter == zero is incompatible. */
HARBOUR HB_ACOPY( void )
{
PHB_ITEM pSrcArray = hb_param( 1, IT_ARRAY );

381
harbour/source/rtl/classes.c
View File

@@ -28,18 +28,17 @@
*
* Partial Copyright (C) 1999 Eddie Runia ( eddie@runia.com )
* partial copyright regarding the following functions :
* CLASSDEL
* CLASSMOD
* :CLASSSEL()
* ISMESSAGE
* OCLONE
* OSEND
* SELECTSUPER
* __INSTSUPER
* __WCLSDATAS
* __WDATAS
* __WDATADEC
* __WDATAINC
* __clsDelMsg()
* __clsModMsg()
* __clsInstSuper()
* __cls_CntClsData()
* __cls_CntData()
* __cls_DecData()
* __cls_IncData()
* __objClone()
* __objHasMsg()
* __objSendMsg()
*/
#include "extend.h"
@@ -47,13 +46,7 @@
#include "itemapi.h"
#include "ctoharb.h"
#include "init.h"
#define MET_METHOD 0
#define MET_DATA 1
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#define MET_SUPER 5
#include "hboo.ch"
typedef struct
{
@@ -80,97 +73,105 @@ typedef struct
#define BUCKET 4
#define HASH_KEY (BASE_METHODS / BUCKET)
PCLASS pClasses = 0;
WORD wClasses = 0;
PMETHOD pMethod = 0;
PHB_DYNS msgClassName = 0;
PHB_DYNS msgClassH = 0;
PHB_DYNS msgEval = 0;
PHB_DYNS msgClassSel = 0;
static PCLASS pClasses = 0;
static WORD wClasses = 0;
static PMETHOD pMethod = 0;
static PHB_DYNS msgClassName = 0;
static PHB_DYNS msgClassH = 0;
static PHB_DYNS msgEval = 0;
static PHB_DYNS msgClassSel = 0;
/* All functions contained in classes.c */
HARBOUR HB_CLASSADD( void );
HARBOUR HB_CLASSCREATE( void );
HARBOUR HB_CLASSDEL( void );
static HARBOUR ClassH( void );
HARBOUR HB_CLASSINSTANCE( void );
HARBOUR HB_CLASSMOD( void );
static HARBOUR ClassName( void );
HARBOUR HB_CLASSNAME( void );
static HARBOUR ClassSel( void );
static void DictRealloc( PCLASS );
static HARBOUR EvalInline( void );
char * hb_GetClassName( PHB_ITEM pObject );
static HARBOUR GetClassData( void );
static HARBOUR GetData( void );
PHB_FUNC hb_GetMethod( PHB_ITEM, PHB_SYMB );
ULONG hb_isMessage( PHB_ITEM, char *);
HARBOUR HB_ISMESSAGE( void );
HARBOUR HB_OCLONE( void );
HARBOUR HB_OSEND( void );
void ReleaseClass( PCLASS );
void ReleaseClasses( void );
static HARBOUR SelectSuper( void );
static HARBOUR SetClassData( void );
static HARBOUR SetData( void );
static HARBOUR Virtual( void );
HARBOUR HB___INSTSUPER( void );
HARBOUR HB___WCLSDATAS(void);
HARBOUR HB___WDATAS( void );
HARBOUR HB___WDATADEC( void );
HARBOUR HB___WDATAINC( void );
static HARBOUR __msgClsH( void );
static HARBOUR __msgClsName( void );
static HARBOUR __msgClsSel( void );
static HARBOUR __msgSuper( void );
static HARBOUR __msgEvalInline( void );
static HARBOUR __msgVirtual( void );
static HARBOUR __msgGetClsData( void );
static HARBOUR __msgSetClsData( void );
static HARBOUR __msgGetData( void );
static HARBOUR __msgSetData( void );
static void hb_clsDictRealloc( PCLASS pClass );
static void hb_clsRelease( PCLASS );
void hb_clsReleaseAll( void );
char * hb_objGetClsName( PHB_ITEM pObject );
PHB_FUNC hb_objGetMethod( PHB_ITEM, PHB_SYMB );
ULONG hb_objHasMsg( PHB_ITEM pObject, char *szString );
HARBOUR HB___CLSNEW( void );
HARBOUR HB___CLSINST( void );
HARBOUR HB___CLSINSTSUPER( void );
HARBOUR HB___CLSADDMSG( void );
HARBOUR HB___CLSDELMSG( void );
HARBOUR HB___CLSMODMSG( void );
HARBOUR HB___CLS_CNTCLSDATA(void);
HARBOUR HB___CLS_CNTDATA( void );
HARBOUR HB___CLS_DECDATA( void );
HARBOUR HB___CLS_INCDATA( void );
HARBOUR HB___OBJGETCLSNAME( void );
HARBOUR HB___OBJCLONE( void );
HARBOUR HB___OBJHASMSG( void );
HARBOUR HB___OBJSENDMSG( void );
/* All function contained in matching objfunc.prg */
HARBOUR HB_AODATA( void );
HARBOUR HB_AOGET( void );
HARBOUR HB_AOMETHOD( void );
HARBOUR HB_AOSET( void );
HARBOUR HB_ISDATA( void );
HARBOUR HB_ISMETHOD( void );
HARBOUR HB_OADDDATA( void );
HARBOUR HB_OADDINLINE( void );
HARBOUR HB_OADDMETHOD( void );
HARBOUR HB_ODELDATA( void );
HARBOUR HB_ODELINLINE( void );
HARBOUR HB_ODELMETHOD( void );
HARBOUR HB_OMODINLINE( void );
HARBOUR HB_OMODMETHOD( void );
extern HARBOUR HB___OBJGETMSGLIST( void );
extern HARBOUR HB___OBJGETMETHODLIST( void );
extern HARBOUR HB___OBJGETVALUELIST( void );
extern HARBOUR HB___OBJSETVALUELIST( void );
extern HARBOUR HB___OBJHASDATA( void );
extern HARBOUR HB___OBJHASMETHOD( void );
extern HARBOUR HB___OBJADDDATA( void );
extern HARBOUR HB___OBJADDINLINE( void );
extern HARBOUR HB___OBJADDMETHOD( void );
extern HARBOUR HB___OBJDELDATA( void );
extern HARBOUR HB___OBJDELINLINE( void );
extern HARBOUR HB___OBJDELMETHOD( void );
extern HARBOUR HB___OBJMODINLINE( void );
extern HARBOUR HB___OBJMODMETHOD( void );
/* Exported symbols of both classes.c and objfunc.prg */
HB_INIT_SYMBOLS_BEGIN( Classes__InitSymbols )
{ "AODATA" , FS_PUBLIC, HB_AODATA , 0 },
{ "AOGET" , FS_PUBLIC, HB_AOGET , 0 },
{ "AOMETHOD" , FS_PUBLIC, HB_AOMETHOD , 0 },
{ "AOSET" , FS_PUBLIC, HB_AOSET , 0 },
{ "CLASSADD" , FS_PUBLIC, HB_CLASSADD , 0 },
{ "CLASSCREATE" , FS_PUBLIC, HB_CLASSCREATE , 0 },
{ "CLASSDEL" , FS_PUBLIC, HB_CLASSDEL , 0 },
{ "CLASSINSTANCE" , FS_PUBLIC, HB_CLASSINSTANCE , 0 },
{ "CLASSMOD" , FS_PUBLIC, HB_CLASSMOD , 0 },
{ "CLASSNAME" , FS_PUBLIC, HB_CLASSNAME , 0 },
{ "ISDATA" , FS_PUBLIC, HB_ISDATA , 0 },
{ "ISMESSAGE" , FS_PUBLIC, HB_ISMESSAGE , 0 },
{ "ISMETHOD" , FS_PUBLIC, HB_ISMETHOD , 0 },
{ "OADDDATA" , FS_PUBLIC, HB_OADDDATA , 0 },
{ "OADDINLINE" , FS_PUBLIC, HB_OADDINLINE , 0 },
{ "OADDMETHOD" , FS_PUBLIC, HB_OADDMETHOD , 0 },
{ "OCLONE" , FS_PUBLIC, HB_OCLONE , 0 },
{ "ODELDATA" , FS_PUBLIC, HB_ODELDATA , 0 },
{ "ODELINLINE" , FS_PUBLIC, HB_ODELINLINE , 0 },
{ "ODELMETHOD" , FS_PUBLIC, HB_ODELMETHOD , 0 },
{ "OMODINLINE" , FS_PUBLIC, HB_OMODINLINE , 0 },
{ "OMODMETHOD" , FS_PUBLIC, HB_OMODMETHOD , 0 },
{ "OSEND" , FS_PUBLIC, HB_OSEND , 0 }
{ "__CLSNEW" , FS_PUBLIC, HB___CLSNEW , 0 },
{ "__CLSINST" , FS_PUBLIC, HB___CLSINST , 0 },
{ "__CLSINSTSUPER" , FS_PUBLIC, HB___CLSINSTSUPER , 0 },
{ "__CLSADDMSG" , FS_PUBLIC, HB___CLSADDMSG , 0 },
{ "__CLSDELMSG" , FS_PUBLIC, HB___CLSDELMSG , 0 },
{ "__CLSMODMSG" , FS_PUBLIC, HB___CLSMODMSG , 0 },
{ "__CLS_CNTCLSDATA" , FS_PUBLIC, HB___CLS_CNTCLSDATA , 0 },
{ "__CLS_CNTDATA" , FS_PUBLIC, HB___CLS_CNTDATA , 0 },
{ "__CLS_DECDATA" , FS_PUBLIC, HB___CLS_DECDATA , 0 },
{ "__CLS_INCDATA" , FS_PUBLIC, HB___CLS_INCDATA , 0 },
{ "__OBJGETCLSNAME" , FS_PUBLIC, HB___OBJGETCLSNAME , 0 },
{ "__OBJCLONE" , FS_PUBLIC, HB___OBJCLONE , 0 },
{ "__OBJHASMSG" , FS_PUBLIC, HB___OBJHASMSG , 0 },
{ "__OBJSENDMSG" , FS_PUBLIC, HB___OBJSENDMSG , 0 },
{ "__OBJGETMSGLIST" , FS_PUBLIC, HB___OBJGETMSGLIST , 0 },
{ "__OBJGETMETHODLIST" , FS_PUBLIC, HB___OBJGETMETHODLIST , 0 },
{ "__OBJGETVALUELIST" , FS_PUBLIC, HB___OBJGETVALUELIST , 0 },
{ "__OBJSETVALUELIST" , FS_PUBLIC, HB___OBJSETVALUELIST , 0 },
{ "__OBJHASDATA" , FS_PUBLIC, HB___OBJHASDATA , 0 },
{ "__OBJHASMETHOD" , FS_PUBLIC, HB___OBJHASMETHOD , 0 },
{ "__OBJADDDATA" , FS_PUBLIC, HB___OBJADDDATA , 0 },
{ "__OBJADDINLINE" , FS_PUBLIC, HB___OBJADDINLINE , 0 },
{ "__OBJADDMETHOD" , FS_PUBLIC, HB___OBJADDMETHOD , 0 },
{ "__OBJDELDATA" , FS_PUBLIC, HB___OBJDELDATA , 0 },
{ "__OBJDELINLINE" , FS_PUBLIC, HB___OBJDELINLINE , 0 },
{ "__OBJDELMETHOD" , FS_PUBLIC, HB___OBJDELMETHOD , 0 },
{ "__OBJMODINLINE" , FS_PUBLIC, HB___OBJMODINLINE , 0 },
{ "__OBJMODMETHOD" , FS_PUBLIC, HB___OBJMODMETHOD , 0 }
HB_INIT_SYMBOLS_END( Classes__InitSymbols )
#if ! defined(__GNUC__)
#pragma startup Classes__InitSymbols
#endif
/*
* ClassAdd( <hClass>, <cMessage>, <pFunction>, <nType>, [xInit] )
* __clsAddMsg( <hClass>, <cMessage>, <pFunction>, <nType>, [xInit] )
*
* Add a message to the class.
*
@@ -184,7 +185,7 @@ HB_INIT_SYMBOLS_END( Classes__InitSymbols )
* <nType> see MET_*
* <xInit> Optional initializer for DATA
*/
HARBOUR HB_CLASSADD(void)
HARBOUR HB___CLSADDMSG(void)
{
WORD wClass = hb_parnl( 1 );
WORD wType = hb_parni( 4 );
@@ -203,7 +204,7 @@ HARBOUR HB_CLASSADD(void)
wMask = pClass->wHashKey * BUCKET;
if( pClass->wMethods > ( pClass->wHashKey * BUCKET * 2/3 ) )
DictRealloc( pClass );
hb_clsDictRealloc( pClass );
/* Find either the existing message or an open spot for a new message */
@@ -227,10 +228,10 @@ HARBOUR HB_CLASSADD(void)
case MET_DATA:
pNewMeth->wData = hb_parnl( 3 );
if( pMessage->pSymbol->szName[ 0 ] == '_' )
pNewMeth->pFunction = SetData;
pNewMeth->pFunction = __msgSetData;
else
{
pNewMeth->pFunction = GetData;
pNewMeth->pFunction = __msgGetData;
if( pInit && !IS_NIL( pInit )) /* Initializer found */
{
pNewMeth->pInitValue = hb_itemNew( NULL );
@@ -245,9 +246,9 @@ HARBOUR HB_CLASSADD(void)
hb_arraySize( pClass->pClassDatas, hb_parnl( 3 ) );
if( pMessage->pSymbol->szName[ 0 ] == '_' )
pNewMeth->pFunction = SetClassData;
pNewMeth->pFunction = __msgSetClsData;
else
pNewMeth->pFunction = GetClassData;
pNewMeth->pFunction = __msgGetClsData;
break;
case MET_INLINE:
@@ -255,20 +256,20 @@ HARBOUR HB_CLASSADD(void)
hb_arraySize( pClass->pInlines, pNewMeth->wData );
hb_arraySet( pClass->pInlines, pNewMeth->wData,
hb_param( 3, IT_BLOCK ) );
pNewMeth->pFunction = EvalInline;
pNewMeth->pFunction = __msgEvalInline;
break;
case MET_VIRTUAL:
pNewMeth->pFunction = Virtual;
pNewMeth->pFunction = __msgVirtual;
break;
case MET_SUPER:
pNewMeth->wData = hb_parnl( 3 );
pNewMeth->pFunction = SelectSuper;
pNewMeth->pFunction = __msgSuper;
break;
default:
printf( "Invalid method type from ClassAdd\n" );
printf( "Invalid method type from __clsAddMsg\n" );
exit( 1 );
break;
}
@@ -277,7 +278,7 @@ HARBOUR HB_CLASSADD(void)
/*
* <hClass> := ClassCreate( <cClassName>, <nDatas>, [hSuper] )
* <hClass> := __clsNew( <cClassName>, <nDatas>, [hSuper] )
*
* Create a new class
*
@@ -285,7 +286,7 @@ HARBOUR HB_CLASSADD(void)
* <nDatas> Number of DATAs in the class
* <hSuper> Optional handle of superclass
*/
HARBOUR HB_CLASSCREATE(void)
HARBOUR HB___CLSNEW(void)
{
WORD wSuper = hb_parni( 3 ); /* Super class present */
WORD wSize;
@@ -337,14 +338,14 @@ HARBOUR HB_CLASSCREATE(void)
/*
* ClassDel( <oObj>, <cMessage> )
* __clsDelMsg( <oObj>, <cMessage> )
*
* Delete message (only for INLINE and METHOD)
*
* <oObj> Object
* <cMessage> Message
*/
HARBOUR HB_CLASSDEL(void)
HARBOUR HB___CLSDELMSG(void)
{
PHB_ITEM pString = hb_param( 2, IT_STRING );
PHB_SYMB pMessage = hb_dynsymGet( pString->item.asString.value )->pSymbol;
@@ -377,7 +378,7 @@ HARBOUR HB_CLASSDEL(void)
if( wAt != wLimit )
{ /* Requested method found */
pFunc = pClass->pMethods[ wAt ].pFunction;
if( pFunc == EvalInline ) /* INLINE method deleted */
if( pFunc == __msgEvalInline ) /* INLINE method deleted */
{
hb_arrayDel( pClass->pInlines, pClass->pMethods[ wAt ].wData );
/* Delete INLINE block */
@@ -406,18 +407,18 @@ HARBOUR HB_CLASSDEL(void)
*
* Returns class handle of <obj>
*/
static HARBOUR ClassH( void )
static HARBOUR __msgClsH( void )
{
hb_retni( ( stack.pBase + 1 )->item.asArray.value->wClass );
}
/*
* <oNewObject> := ClassInstance( <hClass> )
* <oNewObject> := __clsInst( <hClass> )
*
* Create a new object from class definition <hClass>
*/
HARBOUR HB_CLASSINSTANCE(void)
HARBOUR HB___CLSINST(void)
{
WORD wClass = hb_parni( 1 );
WORD wAt, wLimit;
@@ -441,11 +442,11 @@ HARBOUR HB_CLASSINSTANCE(void)
}
/*
* ClassMod( <oObj>, <cMessage>, <pFunc> )
* __clsModMsg( <oObj>, <cMessage>, <pFunc> )
*
* Modify message (only for INLINE and METHOD)
*/
HARBOUR HB_CLASSMOD(void)
HARBOUR HB___CLSMODMSG(void)
{
PHB_ITEM pString = hb_param( 2, IT_STRING );
PHB_SYMB pMessage = hb_dynsymGet( pString->item.asString.value )->pSymbol;
@@ -478,13 +479,13 @@ HARBOUR HB_CLASSMOD(void)
if( wAt != wLimit )
{ /* Requested method found */
pFunc = pClass->pMethods[ wAt ].pFunction;
if( pFunc == EvalInline ) /* INLINE method changed */
if( pFunc == __msgEvalInline ) /* INLINE method changed */
hb_arraySet( pClass->pInlines, pClass->pMethods[ wAt ].wData,
hb_param( 3, IT_BLOCK ) );
else if( ( pFunc == SetData ) || ( pFunc == GetData ) )
else if( ( pFunc == __msgSetData ) || ( pFunc == __msgGetData ) )
{ /* Not allowed for DATA */
/*hb_errPutDescription(pError, "CLASSMOD: Cannot modify a DATA item");*/
hb_errorRT_BASE(EG_ARG, 3004, NULL, "CLASSMOD");
/*hb_errPutDescription(pError, "__clsModMsg: Cannot modify a DATA item");*/
hb_errorRT_BASE(EG_ARG, 3004, NULL, "__CLSMODMSG");
}
else /* Modify METHOD */
pClass->pMethods[ wAt ].pFunction = ( PHB_FUNC ) hb_parnl( 3 );
@@ -498,7 +499,7 @@ HARBOUR HB_CLASSMOD(void)
*
* Return class name of <obj>. Can also be used for all types.
*/
static HARBOUR ClassName( void )
static HARBOUR __msgClsName( void )
{
PHB_ITEM pItemRef;
@@ -507,7 +508,7 @@ static HARBOUR ClassName( void )
else
pItemRef = stack.pBase + 1;
hb_retc( hb_GetClassName( pItemRef ) );
hb_retc( hb_objGetClsName( pItemRef ) );
}
@@ -516,7 +517,7 @@ static HARBOUR ClassName( void )
*
* Returns class name of <hClass>
*/
HARBOUR HB_CLASSNAME(void)
HARBOUR HB___OBJGETCLSNAME(void)
{
PHB_ITEM pObject = hb_param( 0, IT_OBJECT );
WORD wClass;
@@ -542,7 +543,7 @@ HARBOUR HB_CLASSNAME(void)
*
* Returns all the messages in <obj>
*/
static HARBOUR ClassSel(void)
static HARBOUR __msgClsSel(void)
{
WORD wClass = IS_ARRAY( stack.pBase + 1 ) ?
( stack.pBase + 1 )->item.asArray.value->wClass : 0;
@@ -588,27 +589,27 @@ static HARBOUR ClassSel(void)
/*
* DictRealloc( PCLASS )
* hb_clsDictRealloc( PCLASS )
*
* Realloc (widen) class
*/
static void DictRealloc( PCLASS pClass )
static void hb_clsDictRealloc( PCLASS pClass )
{
/* TODO: Implement it for very large classes */
if( pClass )
{
printf( "classes.c DictRealloc not implemented yet\n" );
printf( "classes.c hb_clsDictRealloc() not implemented yet\n" );
exit( 1 );
}
}
/*
* EvalInline()
* __msgEvalInline()
*
* Internal function executed for inline methods
*/
static HARBOUR EvalInline( void )
static HARBOUR __msgEvalInline( void )
{
HB_ITEM block;
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
@@ -628,12 +629,12 @@ static HARBOUR EvalInline( void )
/*
* <szName> = hb_GetClassName( pObject )
* <szName> = hb_objGetClsName( pObject )
*
* Get the class name of an object
*
*/
char * hb_GetClassName( PHB_ITEM pObject )
char * hb_objGetClsName( PHB_ITEM pObject )
{
char * szClassName;
@@ -688,11 +689,11 @@ char * hb_GetClassName( PHB_ITEM pObject )
}
/*
* GetClassData()
* __msgGetClsData()
*
* Internal function to return a CLASSDATA
*/
static HARBOUR GetClassData( void )
static HARBOUR __msgGetClsData( void )
{
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
WORD wIndex = pMethod->wData;
@@ -704,11 +705,11 @@ static HARBOUR GetClassData( void )
/*
* GetData()
* __msgGetData()
*
* Internal function to return a DATA
*/
static HARBOUR GetData( void )
static HARBOUR __msgGetData( void )
{
PHB_ITEM pObject = stack.pBase + 1;
WORD wIndex = pMethod->wData;
@@ -721,11 +722,11 @@ static HARBOUR GetData( void )
/*
* <pFunc> = hb_GetMethod( <pObject>, <pMessage> )
* <pFunc> = hb_objGetMethod( <pObject>, <pMessage> )
*
* Internal function to the function pointer of a message of an object
*/
PHB_FUNC hb_GetMethod( PHB_ITEM pObject, PHB_SYMB pMessage )
PHB_FUNC hb_objGetMethod( PHB_ITEM pObject, PHB_SYMB pMessage )
{
WORD wAt, wLimit, wMask;
WORD wClass;
@@ -767,60 +768,60 @@ PHB_FUNC hb_GetMethod( PHB_ITEM pObject, PHB_SYMB pMessage )
}
}
if( pMsg == msgClassName )
return ClassName;
return __msgClsName;
else if( pMsg == msgClassH )
return ClassH;
return __msgClsH;
else if( pMsg == msgClassSel )
return ClassSel;
return __msgClsSel;
else if( pMsg == msgEval )
return EvalInline;
return __msgEvalInline;
return 0;
}
/*
* <uPtr> = hb_isMessage( <pObject>, <szString> )
* <uPtr> = hb_objHasMsg( <pObject>, <szString> )
*
* Check whether <szString> is an existing message for object.
*
* <uPtr> should be read as a boolean
*/
ULONG hb_isMessage( PHB_ITEM pObject, char *szString )
ULONG hb_objHasMsg( PHB_ITEM pObject, char *szString )
{
PHB_SYMB pMessage = hb_dynsymGet( szString )->pSymbol;
return( (ULONG) hb_GetMethod( pObject, pMessage ) );
return( (ULONG) hb_objGetMethod( pObject, pMessage ) );
} /* Get funcptr of message */
/*
* <lRet> := IsMessage( <oObj>, <cSymbol> )
* <lRet> := __objHasMsg( <oObj>, <cSymbol> )
*
* Is <cSymbol> a valid message for the <oObj>
*/
HARBOUR HB_ISMESSAGE(void)
HARBOUR HB___OBJHASMSG(void)
{
PHB_ITEM pObject = hb_param( 1, IT_OBJECT );
PHB_ITEM pString = hb_param( 2, IT_STRING );
if( pObject && pString )
hb_retl( hb_isMessage( pObject, pString->item.asString.value ) != 0 );
hb_retl( hb_objHasMsg( pObject, pString->item.asString.value ) != 0 );
else
{
hb_errorRT_BASE(EG_ARG, 3000, NULL, "ISMESSAGE");
hb_errorRT_BASE(EG_ARG, 3000, NULL, "__OBJHASMSG");
}
}
/*
* <oNew> := oClone( <oOld> )
* <oNew> := __objClone( <oOld> )
*
* Clone an object. Note the similarity with aClone ;-)
*/
HARBOUR HB_OCLONE( void )
HARBOUR HB___OBJCLONE( void )
{
PHB_ITEM pSrcObject = hb_param( 1, IT_OBJECT );
@@ -833,17 +834,17 @@ HARBOUR HB_OCLONE( void )
}
else
{
hb_errorRT_BASE(EG_ARG, 3001, NULL, "OCLONE");
hb_errorRT_BASE(EG_ARG, 3001, NULL, "__OBJCLONE");
}
}
/*
* <xRet> = oSend( <oObj>, <cSymbol>, <xArg,..>
* <xRet> = __objSendMsg( <oObj>, <cSymbol>, <xArg,..>
*
* Send a message to an object
*/
HARBOUR HB_OSEND(void)
HARBOUR HB___OBJSENDMSG(void)
{
PHB_ITEM pObject = hb_param( 1, IT_OBJECT );
PHB_ITEM pMessage = hb_param( 2, IT_STRING );
@@ -860,17 +861,17 @@ HARBOUR HB_OSEND(void)
}
else
{
hb_errorRT_BASE(EG_ARG, 3000, NULL, "OSEND");
hb_errorRT_BASE(EG_ARG, 3000, NULL, "__OBJSENDMSG");
}
}
/*
* ReleaseClass( <pClass> )
* hb_clsRelease( <pClass> )
*
* Release a class from memory
*/
void ReleaseClass( PCLASS pClass )
static void hb_clsRelease( PCLASS pClass )
{
WORD wAt;
WORD wLimit;
@@ -891,16 +892,16 @@ void ReleaseClass( PCLASS pClass )
/*
* ReleaseClasses()
* hb_clsReleaseAll()
*
* Release all classes
*/
void ReleaseClasses( void )
void hb_clsReleaseAll( void )
{
WORD w;
for( w = 0; w < wClasses; w++ )
ReleaseClass( pClasses + w );
hb_clsRelease( pClasses + w );
if( pClasses )
hb_xfree( pClasses );
@@ -908,11 +909,11 @@ void ReleaseClasses( void )
/*
* SelectSuper()
* __msgSuper()
*
* Internal function to cast to a super method
*/
static HARBOUR SelectSuper( void )
static HARBOUR __msgSuper( void )
{
PHB_ITEM pObject = stack.pBase + 1;
PHB_ITEM pSuper = (PHB_ITEM) hb_xgrab( sizeof( HB_ITEM ) );
@@ -935,11 +936,11 @@ static HARBOUR SelectSuper( void )
/*
* SetClassData()
* __msgSetClsData()
*
* Internal function to set a CLASSDATA
*/
static HARBOUR SetClassData( void )
static HARBOUR __msgSetClsData( void )
{
WORD wClass = ( stack.pBase + 1 )->item.asArray.value->wClass;
PHB_ITEM pReturn = stack.pBase + 2;
@@ -954,11 +955,11 @@ static HARBOUR SetClassData( void )
/*
* SetData()
* __msgSetData()
*
* Internal function to set a DATA
*/
static HARBOUR SetData( void )
static HARBOUR __msgSetData( void )
{
PHB_ITEM pObject = stack.pBase + 1;
PHB_ITEM pReturn = stack.pBase + 2;
@@ -973,18 +974,18 @@ static HARBOUR SetData( void )
/* No comment :-) */
static HARBOUR Virtual( void )
static HARBOUR __msgVirtual( void )
{
hb_ret();
}
/*
* <hClass> := hb__InstSuper( <cName> )
* <hClass> := __clsInstSuper( <cName> )
*
* Instance super class and return class handle
*/
HARBOUR HB___INSTSUPER( void )
HARBOUR HB___CLSINSTSUPER( void )
{
PHB_ITEM pString = hb_param( 1, IT_STRING );
PHB_DYNS pDynSym;
@@ -1003,14 +1004,14 @@ HARBOUR HB___INSTSUPER( void )
if( !IS_OBJECT( &stack.Return ) )
{
/* hb_errPutDescription(pError, "INSTSUPER : Super class does not return an object"); */
hb_errorRT_BASE(EG_ARG, 3002, NULL, "__INSTSUPER");
hb_errorRT_BASE(EG_ARG, 3002, NULL, "__CLSINSTSUPER");
}
for( w = 0; !bFound && w < wClasses; w++ )
{ /* Locate the entry */
if( !hb_stricmp( pString->item.asString.value, pClasses[ w ].szName ) )
{
hb_retni( w + 1 ); /* Entry + 1 = ClassH */
hb_retni( w + 1 ); /* Entry + 1 = __msgClsH */
bFound = TRUE;
}
}
@@ -1018,7 +1019,7 @@ HARBOUR HB___INSTSUPER( void )
else
{
/* hb_errPutDescription(pError, "INSTSUPER : Cannot find super class"); */
hb_errorRT_BASE(EG_ARG, 3003, NULL, "__INSTSUPER");
hb_errorRT_BASE(EG_ARG, 3003, NULL, "__CLSINSTSUPER");
}
}
if( !bFound )
@@ -1027,28 +1028,42 @@ HARBOUR HB___INSTSUPER( void )
/*
* <nSeq> = hb__wClsDatas( <hClass> )
* <nSeq> = __cls_CntClsData( <hClass> )
*
* Return number of class datas
*/
HARBOUR HB___WCLSDATAS(void)
HARBOUR HB___CLS_CNTCLSDATA(void)
{
WORD wClass = hb_parnl( 1 );
PCLASS pClass;
if( wClass )
{
pClass = &pClasses[ wClass - 1 ];
PCLASS pClass = &pClasses[ wClass - 1 ];
hb_retni( hb_arrayLen( pClass->pClassDatas ) );
}
}
/*
* <nSeq> = hb__wDataDec( <hClass> )
* <nSeq> = __cls_CntData( <hClass> )
*
* Return number of datas
*/
HARBOUR HB___CLS_CNTDATA(void)
{
WORD wClass = hb_parnl( 1 );
if( wClass )
{
hb_retni( pClasses[ wClass - 1 ].wDatas );
}
}
/*
* <nSeq> = __cls_DecData( <hClass> )
*
* Return number of datas and decrease
*/
HARBOUR HB___WDATADEC(void)
HARBOUR HB___CLS_DECDATA(void)
{
WORD wClass = hb_parnl( 1 );
@@ -1058,11 +1073,11 @@ HARBOUR HB___WDATADEC(void)
/*
* <nSeq> = hb__wDataInc( <hClass> )
* <nSeq> = __cls_IncData( <hClass> )
*
* Return number of datas and decrease
*/
HARBOUR HB___WDATAINC(void)
HARBOUR HB___CLS_INCDATA(void)
{
WORD wClass = hb_parnl( 1 );
@@ -1070,17 +1085,3 @@ HARBOUR HB___WDATAINC(void)
hb_retni( ++pClasses[ wClass - 1 ].wDatas );
}
/*
* <nSeq> = hb__wDatas( <hClass> )
*
* Return number of datas
*/
HARBOUR HB___WDATAS(void)
{
WORD wClass = hb_parnl( 1 );
if( wClass )
hb_retni( pClasses[ wClass - 1 ].wDatas );
}

16
harbour/source/rtl/errorapi.c
View File

@@ -384,9 +384,9 @@ static WORD hb_errorRT_New
return wRetVal;
}
WORD hb_errorRT_BASE( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
void hb_errorRT_BASE( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
{
return hb_errorRT_New( ES_ERROR, HB_ERR_SS_BASE, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
hb_errorRT_New( ES_ERROR, HB_ERR_SS_BASE, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
}
WORD hb_errorRT_BASE_Ext1( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation, USHORT uiOsCode, USHORT uiFlags )
@@ -394,19 +394,19 @@ WORD hb_errorRT_BASE_Ext1( ULONG ulGenCode, ULONG ulSubCode, char * szDescriptio
return hb_errorRT_New( ES_ERROR, HB_ERR_SS_BASE, ulGenCode, ulSubCode, szDescription, szOperation, uiOsCode, uiFlags );
}
WORD hb_errorRT_TERMINAL( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
void hb_errorRT_TERMINAL( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
{
return hb_errorRT_New( ES_ERROR, HB_ERR_SS_TERMINAL, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
hb_errorRT_New( ES_ERROR, HB_ERR_SS_TERMINAL, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
}
WORD hb_errorRT_DBCMD( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
void hb_errorRT_DBCMD( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
{
return hb_errorRT_New( ES_ERROR, HB_ERR_SS_DBCMD, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
hb_errorRT_New( ES_ERROR, HB_ERR_SS_DBCMD, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
}
WORD hb_errorRT_TOOLS( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
void hb_errorRT_TOOLS( ULONG ulGenCode, ULONG ulSubCode, char * szDescription, char * szOperation )
{
return hb_errorRT_New( ES_ERROR, HB_ERR_SS_BASE, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
hb_errorRT_New( ES_ERROR, HB_ERR_SS_BASE, ulGenCode, ulSubCode, szDescription, szOperation, 0, EF_NONE );
}
/* NOTES: Use as minimal calls from here, as possible. */

1
harbour/source/rtl/langapi.c
View File

@@ -131,6 +131,7 @@ static HB_LANG langEN =
"Incorrect number of arguments",
"array access",
"array assign",
"array dimension",
"not an array",
"conditional"
},

157
harbour/source/rtl/objfunc.prg
View File

@@ -33,46 +33,39 @@
* their web site at http://www.gnu.org/).
*
* Partial Copyright Antonio Linares (alinares@fivetech.com)
* partial copyright regarding function : aoData
* partial copyright regarding function : __objGetMsgList
*/
#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
#include "hboo.ch"
//
// <lRet> := IsData( <oObject>, <cSymbol> )
// <lRet> := __objHasData( <oObject>, <cSymbol> )
//
// Is the symbol present in the object as DATA ?
//
function IsData( oObject, cSymbol )
function __objHasData( oObject, cSymbol )
return IsMessage( oObject, cSymbol ) .and. IsMessage( oObject, "_" + cSymbol )
return __objHasMsg( oObject, cSymbol ) .and. __objHasMsg( oObject, "_" + cSymbol )
//
// <lRet> := IsMethod( <oObject>, <cSymbol> )
// <lRet> := __objHasMethod( <oObject>, <cSymbol> )
//
// Is the symbol present in the object as METHOD ?
//
function IsMethod( oObject, cSymbol )
function __objHasMethod( oObject, cSymbol )
return IsMessage( oObject, cSymbol ) .and. !IsMessage( oObject, "_" + cSymbol )
return __objHasMsg( oObject, cSymbol ) .and. !__objHasMsg( oObject, "_" + cSymbol )
//
// <aData> aOData( <oObject>, [lDataMethod] )
// <aData> __objGetMsgList( <oObject>, [lDataMethod] )
//
// Return an array containing the names of all the data items of oObject.
//
// lDataMethod = .T. (default) Return all DATAs
// .F. Return all METHODs
//
function aOData( oObject, lDataMethod )
function __objGetMsgList( oObject, lDataMethod )
local aInfo := aSort( oObject:ClassSel() )
local aData := {}
@@ -104,19 +97,19 @@ return aData
//
// aData aOMethod( oObject )
// aData __objGetMethodList( oObject )
//
// Return an array containing the names of all the method of oObject.
//
function aOMethod( oObject )
function __objGetMethodList( oObject )
return aOData( oObject, .F. )
return __objGetMsgList( oObject, .F. )
//
// <aData> aOGet( <oObject>, [<aExcept>] )
// <aData> __objGetValueList( <oObject>, [<aExcept>] )
//
// Basically the same as aOData except that it returns a 2D array
// Basically the same as __objGetMsgList except that it returns a 2D array
// containing :
//
// [x][1] Symbol name
@@ -124,9 +117,9 @@ return aOData( oObject, .F. )
//
// aExcept is an optional list of DATA you do not want to collect
//
function aOGet( oObject, aExcept )
function __objGetValueList( oObject, aExcept )
local aDataSymbol := aoData( oObject )
local aDataSymbol := __objGetMsgList( oObject )
local nLen := Len( aDataSymbol )
local aData := {}
local cSymbol
@@ -139,160 +132,160 @@ function aOGet( oObject, aExcept )
for n := 1 to nLen
cSymbol := aDataSymbol[ n ]
if Empty( aScan( aExcept, cSymbol ) )
aAdd( aData, { cSymbol, oSend( oObject, cSymbol ) } )
aAdd( aData, { cSymbol, __objSendMsg( oObject, cSymbol ) } )
endif
next n
return aData
//
// aOSet( <oObject>, <aData> )
// __objSetValueList( <oObject>, <aData> )
//
// The reverse of aOGet. It puts an 2D array of DATA into an object.
// The reverse of __objGetValueList.
// It puts an 2D array of DATA into an object.
//
function aOSet( oObject, aData )
function __objSetValueList( oObject, aData )
aEval( aData, ;
{|aItem| oSend( oObject, "_"+aItem[DATA_SYMBOL], aItem[DATA_VAL] ) } )
{|aItem| __objSendMsg( oObject, "_"+aItem[DATA_SYMBOL], aItem[DATA_VAL] ) } )
return oObject
//
// <oObj> := oAddMethod( <oObj>, <cSymbol>, <nFuncPtr> )
// <oObj> := __objAddMethod( <oObj>, <cSymbol>, <nFuncPtr> )
//
// Add a method to an already existing class
//
function oAddMethod( oObj, cSymbol, nFuncPtr )
function __objAddMethod( oObj, cSymbol, nFuncPtr )
if IsMessage( oObj, cSymbol )
QOut( "OADDMETHOD: ", cSymbol, " already exists in class." )
if __objHasMsg( oObj, cSymbol )
QOut( "__objAddMethod: ", cSymbol, " already exists in class." )
elseif ValType( nFuncPtr ) != "N"
QOut( "OADDMETHOD: Argument type error <nFuncPtr>" )
QOut( "__objAddMethod: Argument type error <nFuncPtr>" )
elseif ValType( oObj ) != "O"
QOut( "OADDMETHOD: Argument type error <oObj>" )
QOut( "__objAddMethod: Argument type error <oObj>" )
else
ClassAdd( oObj:ClassH, cSymbol, nFuncPtr, MET_METHOD )
__clsAddMsg( oObj:ClassH, cSymbol, nFuncPtr, MET_METHOD )
endif
return oObj
//
// <oObj> := oAddInline( <oObj>, <cSymbol>, <bInline> )
// <oObj> := __objAddInline( <oObj>, <cSymbol>, <bInline> )
//
// Add an INLINE to an already existing class
//
function oAddInline( oObj, cSymbol, bInline )
function __objAddInline( oObj, cSymbol, bInline )
if IsMessage( oObj, cSymbol )
QOut( "OADDINLINE: ", cSymbol, " already exists in class." )
if __objHasMsg( oObj, cSymbol )
QOut( "__objAddInline: ", cSymbol, " already exists in class." )
elseif ValType( bInline ) != "B"
QOut( "OADDINLINE: Argument type error <bInline>" )
QOut( "__objAddInline: Argument type error <bInline>" )
elseif ValType( oObj ) != "O"
QOut( "OADDINLINE: Argument type error <oObj>" )
QOut( "__objAddInline: Argument type error <oObj>" )
else
ClassAdd( oObj:ClassH, cSymbol, bInline, MET_INLINE )
__clsAddMsg( oObj:ClassH, cSymbol, bInline, MET_INLINE )
endif
return oObj
//
// <oObj> := oAddData( <oObj>, <cSymbol> )
// <oObj> := __objAddData( <oObj>, <cSymbol> )
//
// Add a DATA to an already existing class
//
function oAddData( oObj, cSymbol )
function __objAddData( oObj, cSymbol )
local nSeq
if IsMessage( oObj, cSymbol ) .or. IsMessage( oObj, "_" + cSymbol )
QOut( "OADDDATA: ", cSymbol, " already exists in class." )
if __objHasMsg( oObj, cSymbol ) .or. __objHasMsg( oObj, "_" + cSymbol )
QOut( "__objAddData: ", cSymbol, " already exists in class." )
elseif ValType( oObj ) != "O"
QOut( "OADDDATA: Argument type error <oObj>" )
QOut( "__objAddData: Argument type error <oObj>" )
else
nSeq := __wDataInc( oObj:ClassH ) // Allocate new Seq#
ClassAdd( oObj:ClassH, cSymbol, nSeq, MET_DATA )
ClassAdd( oObj:ClassH, "_" + cSymbol, nSeq, MET_DATA )
nSeq := __cls_IncData( oObj:ClassH ) // Allocate new Seq#
__clsAddMsg( oObj:ClassH, cSymbol, nSeq, MET_DATA )
__clsAddMsg( oObj:ClassH, "_" + cSymbol, nSeq, MET_DATA )
endif
return oObj
//
// <oObj> := oModMethod( <oObj>, <cSymbol>, <nFuncPtr> )
// <oObj> := __objModMethod( <oObj>, <cSymbol>, <nFuncPtr> )
//
// Modify a method to an already existing class
//
function oModMethod( oObj, cSymbol, nFuncPtr )
function __objModMethod( oObj, cSymbol, nFuncPtr )
if !IsMethod( oObj, cSymbol )
QOut( "OMODMETHOD: ", cSymbol, " does not exist in class." )
if !__objHasMethod( oObj, cSymbol )
QOut( "__objModMethod: ", cSymbol, " does not exist in class." )
elseif ValType( nFuncPtr ) != "N"
QOut( "OMODMETHOD: Argument type error <nFuncPtr>" )
QOut( "__objModMethod: Argument type error <nFuncPtr>" )
elseif ValType( oObj ) != "O"
QOut( "OMODMETHOD: Argument type error <oObj>" )
QOut( "__objModMethod: Argument type error <oObj>" )
else
ClassMod( oObj:ClassH, cSymbol, nFuncPtr )
__clsModMsg( oObj:ClassH, cSymbol, nFuncPtr )
endif
return oObj
//
// <oObj> := oModInline( <oObj>, <cSymbol>, <bInline> )
// <oObj> := __objModInline( <oObj>, <cSymbol>, <bInline> )
//
// Modify an INLINE to an already existing class
//
function oModInline( oObj, cSymbol, bInline )
function __objModInline( oObj, cSymbol, bInline )
if !IsMethod( oObj, cSymbol )
QOut( "OMODINLINE: ", cSymbol, " does not exist in class." )
if !__objHasMethod( oObj, cSymbol )
QOut( "__objModInline: ", cSymbol, " does not exist in class." )
elseif ValType( bInline ) != "B"
QOut( "OMODINLINE: Argument type error <bInline>" )
QOut( "__objModInline: Argument type error <bInline>" )
elseif ValType( oObj ) != "O"
QOut( "OMODINLINE: Argument type error <oObj>" )
QOut( "__objModInline: Argument type error <oObj>" )
else
ClassMod( oObj:ClassH, cSymbol, bInline )
__clsModMsg( oObj:ClassH, cSymbol, bInline )
endif
return oObj
//
// <oObj> := oDelMethod( <oObj>, <cSymbol> )
// <oObj> := __objDelMethod( <oObj>, <cSymbol> )
//
// Delete a method from an already existing class
//
function oDelMethod( oObj, cSymbol )
function __objDelMethod( oObj, cSymbol )
if !IsMethod( oObj, cSymbol )
QOut( "ODELMETHOD: ", cSymbol, " does not exist in class." )
if !__objHasMethod( oObj, cSymbol )
QOut( "__objDelMethod: ", cSymbol, " does not exist in class." )
elseif ValType( oObj ) != "O"
QOut( "ODELMETHOD: Argument type error <oObj>" )
QOut( "__objDelMethod: Argument type error <oObj>" )
else
ClassDel( oObj:ClassH, cSymbol )
__clsDelMsg( oObj:ClassH, cSymbol )
endif
return oObj
function oDelInline( oObj, cSymbol )
return oDelMethod( oObj, cSymbol ) // Same story
function __objDelInline( oObj, cSymbol )
return __objDelMethod( oObj, cSymbol ) // Same story
//
// <oObj> := oDelData( <oObj>, <cSymbol> )
// <oObj> := __objDelData( <oObj>, <cSymbol> )
//
// Delete a DATA from an already existing class
//
function oDelData( oObj, cSymbol )
function __objDelData( oObj, cSymbol )
local nSeq
if !IsData( oObj, cSymbol )
QOut( "ODELDATA: ", cSymbol, " does not exist in class." )
if !__objHasData( oObj, cSymbol )
QOut( "__objDelData: ", cSymbol, " does not exist in class." )
elseif ValType( oObj ) != "O"
QOut( "ODELDATA: Argument type error <oObj>" )
QOut( "__objDelData: Argument type error <oObj>" )
else
ClassDel( oObj:ClassH, cSymbol, )
ClassDel( oObj:ClassH, "_" + cSymbol )
nSeq := __wDataDec( oObj:ClassH ) // Decrease wData
__clsDelMsg( oObj:ClassH, cSymbol, )
__clsDelMsg( oObj:ClassH, "_" + cSymbol )
nSeq := __cls_DecData( oObj:ClassH ) // Decrease wData
endif
return oObj

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

@@ -31,15 +31,7 @@
* Support for default DATA values
*/
#define MET_METHOD 0
#define MET_DATA 1
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#define MET_SUPER 5
#define DAT_SYMBOL 1
#define DAT_INITVAL 2
#include "hboo.ch"
//----------------------------------------------------------------------------//
@@ -48,36 +40,36 @@ function TClass()
static hClass := 0
if hClass == 0
hClass = ClassCreate( "TCLASS", 8 )
hClass = __clsNew( "TCLASS", 8 )
ClassAdd( hClass, "New", @New(), MET_METHOD )
ClassAdd( hClass, "Create", @Create(), MET_METHOD )
ClassAdd( hClass, "AddData", @AddData(), MET_METHOD )
ClassAdd( hClass, "AddClassData", @AddClassData(), MET_METHOD )
ClassAdd( hClass, "AddInline", @AddInline(), MET_METHOD )
ClassAdd( hClass, "AddMethod", @AddMethod(), MET_METHOD )
ClassAdd( hClass, "AddVirtual", @AddVirtual(), MET_METHOD )
ClassAdd( hClass, "Instance", @Instance(), MET_METHOD )
__clsAddMsg( hClass, "New", @New(), MET_METHOD )
__clsAddMsg( hClass, "Create", @Create(), MET_METHOD )
__clsAddMsg( hClass, "AddData", @AddData(), MET_METHOD )
__clsAddMsg( hClass, "AddClassData", @AddClassData(), MET_METHOD )
__clsAddMsg( hClass, "AddInline", @AddInline(), MET_METHOD )
__clsAddMsg( hClass, "AddMethod", @AddMethod(), MET_METHOD )
__clsAddMsg( hClass, "AddVirtual", @AddVirtual(), MET_METHOD )
__clsAddMsg( hClass, "Instance", @Instance(), MET_METHOD )
ClassAdd( hClass, "hClass", 1, MET_DATA )
ClassAdd( hClass, "_hClass", 1, MET_DATA )
ClassAdd( hClass, "cName", 2, MET_DATA )
ClassAdd( hClass, "_cName", 2, MET_DATA )
ClassAdd( hClass, "aDatas", 3, MET_DATA )
ClassAdd( hClass, "_aDatas", 3, MET_DATA )
ClassAdd( hClass, "aMethods", 4, MET_DATA )
ClassAdd( hClass, "_aMethods", 4, MET_DATA )
ClassAdd( hClass, "aClsDatas", 5, MET_DATA )
ClassAdd( hClass, "_aClsDatas", 5, MET_DATA )
ClassAdd( hClass, "aInlines", 6, MET_DATA )
ClassAdd( hClass, "_aInlines", 6, MET_DATA )
ClassAdd( hClass, "aVirtuals", 7, MET_DATA )
ClassAdd( hClass, "_aVirtuals", 7, MET_DATA )
ClassAdd( hClass, "cSuper", 8, MET_DATA )
ClassAdd( hClass, "_cSuper", 8, MET_DATA )
__clsAddMsg( hClass, "hClass", 1, MET_DATA )
__clsAddMsg( hClass, "_hClass", 1, MET_DATA )
__clsAddMsg( hClass, "cName", 2, MET_DATA )
__clsAddMsg( hClass, "_cName", 2, MET_DATA )
__clsAddMsg( hClass, "aDatas", 3, MET_DATA )
__clsAddMsg( hClass, "_aDatas", 3, MET_DATA )
__clsAddMsg( hClass, "aMethods", 4, MET_DATA )
__clsAddMsg( hClass, "_aMethods", 4, MET_DATA )
__clsAddMsg( hClass, "aClsDatas", 5, MET_DATA )
__clsAddMsg( hClass, "_aClsDatas", 5, MET_DATA )
__clsAddMsg( hClass, "aInlines", 6, MET_DATA )
__clsAddMsg( hClass, "_aInlines", 6, MET_DATA )
__clsAddMsg( hClass, "aVirtuals", 7, MET_DATA )
__clsAddMsg( hClass, "_aVirtuals", 7, MET_DATA )
__clsAddMsg( hClass, "cSuper", 8, MET_DATA )
__clsAddMsg( hClass, "_cSuper", 8, MET_DATA )
endif
return ClassInstance( hClass )
return __clsInst( hClass )
//----------------------------------------------------------------------------//
@@ -112,48 +104,48 @@ static function Create()
local ahSuper := {}
if ::cSuper == NIL
hClass := ClassCreate( ::cName, nLenDatas )
hClass := __clsNew( ::cName, nLenDatas )
else // Single inheritance
hSuper := __InstSuper( Upper( ::cSuper ) )
hClass := ClassCreate( ::cName, nLenDatas, hSuper )
hSuper := __clsInstSuper( Upper( ::cSuper ) )
hClass := __clsNew( ::cName, nLenDatas, hSuper )
// Add class casts
ClassAdd( hClass, Upper( ::cSuper ), hSuper, MET_SUPER )
ClassAdd( hClass, "__SUPER", hSuper, MET_SUPER )
__clsAddMsg( hClass, Upper( ::cSuper ), hSuper, MET_SUPER )
__clsAddMsg( hClass, "__SUPER", hSuper, MET_SUPER )
nDataBegin := __WDatas( hSuper ) // Get offset for new DATAs
nClassBegin := __WClsDatas( hSuper ) // Get offset for new ClassData
nDataBegin := __cls_CntData( hSuper ) // Get offset for new DATAs
nClassBegin := __cls_CntClsData( hSuper ) // Get offset for new ClassData
endif
::hClass = hClass
for n = 1 to nLenDatas
ClassAdd( hClass, ::aDatas[ n ][ DAT_SYMBOL ], n + nDataBegin, MET_DATA, ;
::aDatas[ n ][ DAT_INITVAL ] )
ClassAdd( hClass, "_" + ::aDatas[ n ][ DAT_SYMBOL ], n + nDataBegin, MET_DATA )
__clsAddMsg( hClass, ::aDatas[ n ][ DATA_SYMBOL ], n + nDataBegin, MET_DATA, ;
::aDatas[ n ][ DATA_VAL ] )
__clsAddMsg( hClass, "_" + ::aDatas[ n ][ DATA_SYMBOL ], n + nDataBegin, MET_DATA )
next
nLen = Len( ::aMethods )
for n = 1 to nLen
ClassAdd( hClass, ::aMethods[ n ][ 1 ], ::aMethods[ n ][ 2 ], MET_METHOD )
__clsAddMsg( hClass, ::aMethods[ n ][ 1 ], ::aMethods[ n ][ 2 ], MET_METHOD )
next
nLen = Len( ::aClsDatas )
for n = 1 to nLen
ClassAdd( hClass, ::aClsDatas[ n ], n + nClassBegin, MET_CLASSDATA )
ClassAdd( hClass, "_" + ::aClsDatas[ n ], n + nClassBegin, MET_CLASSDATA )
__clsAddMsg( hClass, ::aClsDatas[ n ], n + nClassBegin, MET_CLASSDATA )
__clsAddMsg( hClass, "_" + ::aClsDatas[ n ], n + nClassBegin, MET_CLASSDATA )
next
nLen = Len( ::aInlines )
for n = 1 to nLen
ClassAdd( hClass, ::aInlines[ n ][ 1 ], ::aInlines[ n ][ 2 ],;
__clsAddMsg( hClass, ::aInlines[ n ][ 1 ], ::aInlines[ n ][ 2 ],;
MET_INLINE )
next
// ClassAdd( hClass, Upper( ::cName ), {|self|self}, MET_INLINE ) // Useful?
// __clsAddMsg( hClass, Upper( ::cName ), {|self|self}, MET_INLINE ) // Useful?
nLen = Len( ::aVirtuals )
for n = 1 to nLen
ClassAdd( hClass, ::aVirtuals[ n ], n, MET_VIRTUAL )
__clsAddMsg( hClass, ::aVirtuals[ n ], n, MET_VIRTUAL )
next
return nil
@@ -164,7 +156,7 @@ static function Instance()
local Self := QSelf()
return ClassInstance( ::hClass )
return __clsInst( ::hClass )
//----------------------------------------------------------------------------//

26
harbour/source/rtl/transfrm.c
View File

@@ -87,13 +87,7 @@ HB_INIT_SYMBOLS_END( Transfrm__InitSymbols )
#define DF_YMD 2
#define DF_EOT 3 /* End of table for Century */
/* Multiplication factors for different formats. */
long lFactDay [] = { 10000, 100, 1, 1000000, 10000, 1 };
long lFactMonth[] = { 100, 10000, 100, 10000, 1000000, 100 };
long lFactYear [] = { 1, 1, 10000, 1, 1, 10000 };
char *szBritish[] = { "DD/MM/YY", "DD/MM/YYYY" }; /* For @E */
static char *szBritish[] = { "DD/MM/YY", "DD/MM/YYYY" }; /* For @E */
/*
PictFunc -> Analyze function flags and return binary flags bits
@@ -101,9 +95,9 @@ char *szBritish[] = { "DD/MM/YY", "DD/MM/YYYY" }; /* For @E */
szPict : Pointer to the picture
lPicLen : Pointer to the length. Changed during execution.
*/
int PictFunc( char **szPict, long *lPicLen )
static int PictFunc( char **szPict, long *lPicLen )
{
int bDone = FALSE;
BOOL bDone = FALSE;
int iPicFlags = 0;
char *szPic = *szPict;
@@ -165,8 +159,8 @@ int PictFunc( char **szPict, long *lPicLen )
iOrigWidth : Original width
iOrigDec : Original decimals
*/
char *NumPicture( char *szPic, long lPic, int iPicFlags, double dValue,
long *lRetSize, int iOrigWidth, int iOrigDec )
static char *NumPicture( char *szPic, long lPic, int iPicFlags, double dValue,
long *lRetSize, int iOrigWidth, int iOrigDec )
{
int iWidth; /* Width of string */
int iDecimals; /* Number of decimals */
@@ -179,8 +173,8 @@ char *NumPicture( char *szPic, long lPic, int iPicFlags, double dValue,
PHB_ITEM pItem;
BYTE bFound = FALSE;
BYTE bEmpty; /* Suppress empty string */
BOOL bFound = FALSE;
BOOL bEmpty; /* Suppress empty string */
double dPush;
@@ -352,7 +346,7 @@ char *NumPicture( char *szPic, long lPic, int iPicFlags, double dValue,
else
{
printf( "\nNUMPICTURE: STR does not return string" );
_exit(1);
exit(1);
}
return(szRet);
}
@@ -365,7 +359,7 @@ char *NumPicture( char *szPic, long lPic, int iPicFlags, double dValue,
szResult : Buffer of at least size 11 to hold formatted date
lRetSize : The size of the returned string is passed here !
*/
char *DatePicture( char * szDate, int iPicFlags, char * szResult, long *lRetSize )
static char *DatePicture( char * szDate, int iPicFlags, char * szResult, long *lRetSize )
{
char * szDateFormat;
@@ -400,7 +394,7 @@ HARBOUR HB_TRANSFORM( void )
int iPicFlags = 0; /* Function flags */
int n;
BYTE bDone = FALSE;
BOOL bDone = FALSE;
if( lPic )
{

5
harbour/source/tools/stringp.prg
View File

@@ -31,8 +31,7 @@
* their web site at http://www.gnu.org/).
*/
#define DATA_SYMBOL 1
#define DATA_VAL 2
#include "hboo.ch"
/* $Doc$
* $FuncName$ <xRet> Default( <xArg>, <xDefault> )
@@ -123,7 +122,7 @@ function ToChar( xTxt, cSeparator, lDebug )
case cValTxt=="O" // Object
if lDebug
cOut := xTxt:ClassName() + "(#" + ToChar( xTxt:ClassH() ) + "):{"
aData := aoGet( xTxt )
aData := __objGetValueList( xTxt )
nLen := Len( aData )
for n := 1 to nLen // For each item : Recurse !
cOut += aData[n][DATA_SYMBOL] + ":" + ;

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

@@ -46,7 +46,6 @@
extern void hb_consoleInitialize( void );
extern void hb_consoleRelease( void );
extern void ReleaseClasses( void ); /* releases all defined classes */
extern void InitSymbolTable( void ); /* initialization of runtime support symbols */
typedef struct _SYMBOLS
@@ -181,7 +180,7 @@ int main( int argc, char * argv[] )
hb_itemClear( &stack.Return );
hb_arrayRelease( &aStatics );
hb_itemClear( &errorBlock );
ReleaseClasses();
hb_clsReleaseAll();
hb_vmReleaseLocalSymbols(); /* releases the local modules linked list */
hb_dynsymRelease(); /* releases the dynamic symbol table */
hb_consoleRelease(); /* releases Console */
@@ -849,12 +848,12 @@ void hb_vmDo( WORD wParams )
if( pSym == &( symEval ) && IS_BLOCK( pSelf ) )
pFunc = pSym->pFunPtr; /* __EVAL method = function */
else
pFunc = hb_GetMethod( pSelf, pSym );
pFunc = hb_objGetMethod( pSelf, pSym );
if( ! pFunc )
{
printf( "error: message %s not implemented for class %s in line %i\n",
pSym->szName, hb_GetClassName( pSelf ), wLineNo );
pSym->szName, hb_objGetClsName( pSelf ), wLineNo );
exit( 1 );
}
pFunc();
@@ -988,7 +987,7 @@ void hb_vmEqual( BOOL bExact )
else if( IS_NUMERIC( pItem1 ) && IS_NUMERIC( pItem2 ) )
hb_vmPushLogical( hb_vmPopDouble(&wDec) == hb_vmPopDouble(&wDec) );
else if( IS_OBJECT( pItem1 ) && hb_isMessage( pItem1, "==" ) )
else if( IS_OBJECT( pItem1 ) && hb_objHasMsg( pItem1, "==" ) )
hb_vmOperatorCall( pItem1, pItem2, "==" );
else if( pItem1->type != pItem2->type )
@@ -1116,7 +1115,7 @@ void hb_vmGreater( void )
}
else if( IS_OBJECT( stack.pPos - 2 ) &&
hb_isMessage( stack.pPos - 2, ">" ) )
hb_objHasMsg( stack.pPos - 2, ">" ) )
hb_vmOperatorCall( stack.pPos - 2, stack.pPos - 1, ">" );
else if( ( stack.pPos - 2 )->type != ( stack.pPos - 1 )->type )
@@ -1161,7 +1160,7 @@ void hb_vmGreaterEqual( void )
}
else if( IS_OBJECT( stack.pPos - 2 ) &&
hb_isMessage( stack.pPos - 2, ">=" ) )
hb_objHasMsg( stack.pPos - 2, ">=" ) )
hb_vmOperatorCall( stack.pPos - 2, stack.pPos - 1, ">=" );
else if( ( stack.pPos - 2 )->type != ( stack.pPos - 1 )->type )
@@ -1248,7 +1247,7 @@ void hb_vmLess( void )
}
else if( IS_OBJECT( stack.pPos - 2 ) &&
hb_isMessage( stack.pPos - 2, "<" ) )
hb_objHasMsg( stack.pPos - 2, "<" ) )
hb_vmOperatorCall( stack.pPos - 2, stack.pPos - 1, "<" );
else if( ( stack.pPos - 2 )->type != ( stack.pPos - 1 )->type )
@@ -1293,7 +1292,7 @@ void hb_vmLessEqual( void )
}
else if( IS_OBJECT( stack.pPos - 2 ) &&
hb_isMessage( stack.pPos - 2, "<=" ) )
hb_objHasMsg( stack.pPos - 2, "<=" ) )
hb_vmOperatorCall( stack.pPos - 2, stack.pPos - 1, "<=" );
else if( ( stack.pPos - 2 )->type != ( stack.pPos - 1 )->type )
@@ -1374,7 +1373,7 @@ void hb_vmNotEqual( void )
else if( IS_LOGICAL( pItem1 ) && IS_LOGICAL( pItem2 ) )
hb_vmPushLogical( hb_vmPopLogical() != hb_vmPopLogical() );
else if( IS_OBJECT( pItem1 ) && hb_isMessage( pItem1, "!=" ) )
else if( IS_OBJECT( pItem1 ) && hb_objHasMsg( pItem1, "!=" ) )
hb_vmOperatorCall( pItem1, pItem2, "!=" );
else if( pItem1->type != pItem2->type )
@@ -1438,7 +1437,7 @@ void hb_vmMinus( void )
hb_stackPop();
return;
}
else if( IS_OBJECT( stack.pPos - 2 ) && hb_isMessage( stack.pPos - 2, "-" ) )
else if( IS_OBJECT( stack.pPos - 2 ) && hb_objHasMsg( stack.pPos - 2, "-" ) )
hb_vmOperatorCall( stack.pPos - 2, stack.pPos - 1, "-" );
else
hb_errorRT_BASE(EG_ARG, 1082, NULL, "-");
@@ -1546,7 +1545,7 @@ void hb_vmPlus( void )
hb_vmPushDate( lDate1 + dNumber2 );
}
else if( IS_OBJECT( pItem1 ) && hb_isMessage( pItem2, "+" ) )
else if( IS_OBJECT( pItem1 ) && hb_objHasMsg( pItem2, "+" ) )
hb_vmOperatorCall( pItem1, pItem2, "+" );
else

30
harbour/tests/working/debugtst.prg
View File

@@ -31,15 +31,15 @@ function Main()
QOut( "What is in oForm ? " )
Debug( oForm:Transfer() )
QOut( "Does transfer exists ? ", IsMessage( oForm, "Transfer" ) )
QOut( "Is transfer DATA ? ", IsData ( oForm, "Transfer" ) )
QOut( "Is transfer METHOD ? ", IsMethod ( oForm, "Transfer" ) )
QOut( "Does nLeft exists ? ", IsMessage( oForm, "nLeft" ) )
QOut( "Is nLeft DATA ? ", IsData ( oForm, "nLeft" ) )
QOut( "Is nLeft METHOD ? ", IsMethod ( oForm, "nLeft" ) )
QOut( "Does unknown exists ? ", IsMessage( oForm, "Unknown" ) )
QOut( "Is unknown DATA ? ", IsData ( oForm, "Unknown" ) )
QOut( "Is unknown METHOD ? ", IsMethod ( oForm, "Unknown" ) )
QOut( "Does transfer exists ? ", __objHasMsg ( oForm, "Transfer" ) )
QOut( "Is transfer DATA ? ", __objHasData ( oForm, "Transfer" ) )
QOut( "Is transfer METHOD ? ", __objHasMethod( oForm, "Transfer" ) )
QOut( "Does nLeft exists ? ", __objHasMsg ( oForm, "nLeft" ) )
QOut( "Is nLeft DATA ? ", __objHasData ( oForm, "nLeft" ) )
QOut( "Is nLeft METHOD ? ", __objHasMethod( oForm, "nLeft" ) )
QOut( "Does unknown exists ? ", __objHasMsg ( oForm, "Unknown" ) )
QOut( "Is unknown DATA ? ", __objHasData ( oForm, "Unknown" ) )
QOut( "Is unknown METHOD ? ", __objHasMethod( oForm, "Unknown" ) )
QOut( "Set nLeft to 50 and nRight to 100" )
oForm:Transfer( {"nLeft", 50}, {"nRight", 100} )
@@ -186,7 +186,7 @@ return nil
// one class to another
//
// If <xArg> is not present, the current object will be returned as an array
// for description see aoSet / aoGet.
// for description see __objSetValueList / __objGetValueList.
//
// The method aExcept() is called to determine the DATA which should not
// be returned. Eg. hWnd ( do not copy this DATA from external source )
@@ -195,11 +195,11 @@ return nil
//
// oTarget:Transfer( oSource )
//
// If we do not want 'cName' duplicated we have to use aoGet :
// If we do not want 'cName' duplicated we have to use __objGetValueList :
//
// aNewExcept := aClone( oSource:aExcept() )
// aAdd( aNewExcept, "cName" ) /* Add cName to exception list */
// oTarget:Transfer( aoGet( oSource, aNewExcept ) )
// oTarget:Transfer( __objGetValueList( oSource, aNewExcept ) )
// /* Get DATA from oSource with new exceptions */
// /* Transfer DATA to oTarget */
//
@@ -233,7 +233,7 @@ static function Transfer( x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 /* etc */ )
local n
if nLen == 0
xRet := aOGet( self, ::aExcept() )
xRet := __objGetValueList( self, ::aExcept() )
else
for n := 1 to nLen
@@ -241,9 +241,9 @@ static function Transfer( x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 /* etc */ )
if ValType( xData ) == "A"
if ValType( xData[1] ) == "A" // 2D array passed
xRet := aOSet( self, xData )
xRet := __objSetValueList( self, xData )
else // 1D array passed
xRet := aOSet( self, {xData} )
xRet := __objSetValueList( self, {xData} )
endif
elseif ValType( xData ) == "O" // Object passed

32
harbour/tests/working/dynobj.prg
View File

@@ -14,8 +14,8 @@
//
// Placed in the public domain
//
#define DATA_SYMBOL 1
#define DATA_VAL 2
#include "hboo.ch"
function Main()
@@ -23,27 +23,27 @@ function Main()
local nSeq
QOut( "What methods are in the class :" )
Debug( aoMethod( oForm ) )
Debug( __objGetMethodList( 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", ;
__objAddInline( oForm, "CalcArea", ;
{|self| ( ::nRight - ::nLeft ) * ( ::nBottom - ::nTop ) } )
QOut( "What methods are in the class :" )
Debug( aoMethod( oForm ) )
Debug( __objGetMethodList( 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() )
__objAddMethod( oForm, "Smile", @Smile() )
QOut( "What methods are in the class :" )
Debug( aoMethod( oForm ) )
Debug( __objGetMethodList( oForm ) )
QOut( "Smile please " )
oForm:Smile()
@@ -55,7 +55,7 @@ function Main()
QOut( "Let's add an additional data item" )
oAddData( oForm, "cHelp" )
__objAddData( oForm, "cHelp" )
oForm:cHelp := "This is a real tricky test"
@@ -66,33 +66,33 @@ function Main()
QOut( "Let's attach a bigger smile" )
oModMethod( oForm, "Smile", @BigSmile() )
__objModMethod( oForm, "Smile", @BigSmile() )
QOut( "Let's smile" )
oForm:Smile()
QOut( "And CalcArea() will now give a result in square inches" )
oModInline( oForm, "CalcArea", ;
__objModInline( 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 :" )
Debug( aoMethod( oForm ) )
Debug( __objGetMethodList( oForm ) )
QOut( "Delete CalcArea" )
oDelInline( oForm, "CalcArea" )
__objDelInline( oForm, "CalcArea" )
QOut( "What methods are in the class :" )
Debug( aoMethod( oForm ) )
Debug( __objGetMethodList( oForm ) )
QOut( "Delete Smile" )
oDelMethod( oForm, "Smile" )
__objDelMethod( oForm, "Smile" )
QOut( "What methods are in the class :" )
Debug( aoMethod( oForm ) )
Debug( __objGetMethodList( oForm ) )
Pause()
@@ -101,7 +101,7 @@ function Main()
QOut( "Let's delete cHelp" )
oDelData( oForm, "cHelp" )
__objDelData( oForm, "cHelp" )
QOut( "Data items after" )
Debug( oForm )

6
harbour/tests/working/inherit.prg
View File

@@ -31,11 +31,11 @@ function Main()
oTo := TTextFile():New( "hello.out", "W" )
QOut( "What's in oFrom" )
Debug( { oFrom, aoMethod( oFrom ) } )
Debug( { oFrom, __objGetMethodList( oFrom ) } )
QOut()
QOut( "What's in oFrom:TEmpty" )
Debug( { oFrom:TEmpty, aoMethod( oFrom:TEmpty ) } )
Debug( { oFrom:TEmpty, __objGetMethodList( oFrom:TEmpty ) } )
QOut()
QOut( "Let's call Run() from TEmpty : " )
@@ -91,7 +91,7 @@ function TOnTop()
if oOnTop == NIL
oOnTop := TClass():New( "TOnTop", "TTextFile" )
oOnTop:AddInline( "Say", {|self, cArg| QOut( oSend(self, cArg) ) } )
oOnTop:AddInline( "Say", {|self, cArg| QOut( __objSendMsg(self, cArg) ) } )
oOnTop:Create()
endif
return oOnTop:Instance()

20
harbour/tests/working/objects.prg
View File

@@ -5,11 +5,7 @@
// Testing Harbour classes and objects management
// be aware Harbour provides a much simpler way using Class TClass (source\rtl\class.prg)
#define MET_METHOD 0 // these defines should be declared with these specific values
#define MET_DATA 1 // as Harbour Classes building modules uses them
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#include "hboo.ch"
function Main()
@@ -35,17 +31,17 @@ function TAny() /* builds a class */
static hClass
if hClass == nil
hClass = ClassCreate( "TANY", 3 ) // cClassName, nDatas
ClassAdd( hClass, "cName", 1, MET_DATA ) // retrieve data
ClassAdd( hClass, "_cName", 1, MET_DATA ) // assign data. Note the '_'
ClassAdd( hClass, "New", @New(), MET_METHOD )
ClassAdd( hClass, "Test", @Test(), MET_METHOD )
ClassAdd( hClass, "DoNothing", 0, MET_VIRTUAL )
hClass = __clsNew( "TANY", 3 ) // cClassName, nDatas
__clsAddMsg( hClass, "cName", 1, MET_DATA ) // retrieve data
__clsAddMsg( hClass, "_cName", 1, MET_DATA ) // assign data. Note the '_'
__clsAddMsg( hClass, "New", @New(), MET_METHOD )
__clsAddMsg( hClass, "Test", @Test(), MET_METHOD )
__clsAddMsg( hClass, "DoNothing", 0, MET_VIRTUAL )
endif
/* warning: we are not defining datas names and methods yet */
return ClassInstance( hClass ) // creates an object of this class
return __clsInst( hClass ) // creates an object of this class
static function New()

6
harbour/tests/working/overload.prg
View File

@@ -2,11 +2,7 @@
// $Id$
//
#define MET_METHOD 0
#define MET_DATA 1
#define MET_CLASSDATA 2
#define MET_INLINE 3
#define MET_VIRTUAL 4
#include "hboo.ch"
//
// DynObj

4
harbour/tests/working/strip.prg
View File

@@ -36,10 +36,10 @@ function Main( cFrom, cTo )
cTo := Default( cTo, "strip.out" )
oFrom := TTextFile()
// Debug( aoMethod( oFrom ) )
// Debug( __objGetMethodList( oFrom ) )
oFrom:New( cFrom, "R" )
oTo := TTextFile()
// Debug( aoMethod( oTo ) )
// Debug( __objGetMethodList( oTo ) )
oTo:New( cTo , "W" )
do while !oFrom:EoF()