From 5e42eeb160bd8165f6f983800359117df9982daa Mon Sep 17 00:00:00 2001 From: Jean-Francois Lefebvre Date: Mon, 9 Jul 2001 22:40:33 +0000 Subject: [PATCH] 2001-07-10 00:15 UTC+1 JFL (mafact) --- harbour/ChangeLog | 14 + harbour/include/hbclass.ch | 6 +- harbour/source/vm/classes.c | 442 ++++++++++++++++---------------- harbour/utils/hbmake/hbmake.prg | 110 ++++---- 4 files changed, 296 insertions(+), 276 deletions(-) diff --git a/harbour/ChangeLog b/harbour/ChangeLog index ef8b1c0a16..0a716ec236 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,17 @@ +2001-07-10 00:15 UTC+1 JFL (mafact) + * harbour/source/vm/Classe.c + - Hb_ClsScope() Corrected and re-added + - hb_getRrealclsName() enhanced to keep a better trace of Class tree + - __ClsInst simplified + - List of modifs simplified + * harbour/include/Hbclass.ch + - List of modifs simplified + - Added a line of explanation for HB_CLS_ENFORCERO + * harbour/utils/hbmake/hbmake.prg + - added #ifndef __HARBOUR__ around Function HB_OSNEWLINE() + to allow compilation with Vc++ + + 2001-07-09 12:58 GMT+3 Alexander Kresin * contrib/rdd_ads/ads1.c * adsOrderInfo() fixed - before it returned info for current order only in diff --git a/harbour/include/hbclass.ch b/harbour/include/hbclass.ch index 39fa4142e5..2a0e22df4c 100644 --- a/harbour/include/hbclass.ch +++ b/harbour/include/hbclass.ch @@ -54,9 +54,11 @@ * The following parts are Copyright of the individual authors. * www - http://www.harbour-project.org * - * Copyright 2000 JF Lefebvre and RA Cuylen + * Copyright 2000 ( ->07/2000 ) JF. Lefebvre & RA. Cuylen * Support for Class(y), TopClass and Visual Object compatibility * Support for MI (multiple inheritance), + + * Copyright 2000-2001 ( 08/2000-> ) JF. Lefebvre * Scoping (Protect, Hidden and Readonly), * Delegating, DATA Shared * Support of 10 Chars limits @@ -96,6 +98,8 @@ /* #define HB_CLS_NOTOBJECT */ /* Should be included in some compatibility include files as needed */ /* #define HB_CLS_NOAUTOINIT */ /* Idem */ /* #define HB_CLS_ALLOWCLASS */ /* Work in progress, don't define it now */ +/* #define HB_CLS_ENFORCERO FLAG to disable Write access to RO VAR outside */ +/* of Constructors /!\ Could be related to some incompatibility */ DECLARE TClass ; New( cName AS String, OPTIONAL SuperParams ) AS CLASS TClass ; diff --git a/harbour/source/vm/classes.c b/harbour/source/vm/classes.c index 5f423e6fa8..9abf650122 100644 --- a/harbour/source/vm/classes.c +++ b/harbour/source/vm/classes.c @@ -1,5 +1,4 @@ -/* - * $Id$ +/* $Id$ */ /* @@ -78,92 +77,29 @@ * Copyright 1999 Janica Lubos * hb_clsDictRealloc() * - * Copyright 2000 JF. Lefebvre & RA. Cuylen - * hb_clsDictRealloc() New version - * - * Copyright 2000 JF. Lefebvre & RA. Cuylen - * Now support of shared and not shared class data + * Copyright 2000 ( ->07/2000 ) JF. Lefebvre & RA. Cuylen * Multiple inheritence fully implemented + * Forwarding, delegating + * Data initialisation & Autoinit for Bool and Numeric + * Scoping : Protected / exported + * + * hb_clsDictRealloc() New version + * Now support of shared and not shared class data * Multiple datas declaration fully supported - * Super msg correctly respond by a super object - * Scoping : working for protected, hidden and readonly - * This implie a message not found error in place of protection error hidden * - * 06/07/2000 - * Now, Each object instance will hold one object instance of all its parents - * The first one has the same pointer as SUPER and __SUPER msgs. - * See hb___msgSuper() - * Each inherited data will now has a pointer linked to it's original object's position - * - * hb___msgGetShrData() - * hb___msgSetShrData() - * hb___msgClsParent() - * __CLS_PARAM() (Now, all class inherit automaticly from TObject Class) - * __CLSPARENT() - * __SENDER() - * __CLSINST() (Call to hb_clsInst()) - * hb_cls_MsgToNum() (New Hashing method to allow a better use of buckets) - * hb_clsIsParent() - * hb_clsScope() - * hb_clsInst() (Mostly new one, called recursively) - * hb___msgSuper() (New one) - * hb___msgSetData() (Enhanced regarding herited datas) - * hb___msgGetData() (Enhanced regarding herited datas) - * - * ...and many minors (and not so minors ;-) modifications ( for TObject by ex.) - * - * 1.16 06/13/2000 JFL&RAC - * Initialisation is now working correctly - * as with autoinit for Logical (.F.) and Numerical (0) from tClass.prg - * - * 1.17 06/14/2000 JFL&RAC - * temporary workAround for Self bad referenced when calling super object - * hb___msgSuper() temporary modified - * hb___msgClass() implemented to allow a better compatibility with classy - * Now, calling Self:xClassDataVar is the same as Self:Class:xClassDataVar - * - * 1.18 06/??/2000 ? - * 1.19 06/??/2000 ? - * - * 1.20 06/23/2000 JFL&RAC - * Correction made relative to CLASSDATA SHARED ! - * Completly new method - * - * 1.21 06/23/2000 JFL&RAC - * Correction made relative to CLASSDATA SHARED ! - * Fixed init when redefining on subclass - * - * 1.26 07/??/2000 RGlab + * 2000 RGlab * Garbage collector fixe * - * 1.27 07/15/2000 JFL&RAC - * Fixe for the potential case where we coudl not find - * one free bucket when inheriting the super method - * Reduced the number of base message to 100 - * - * 1.28 07/18/2000 JFL&RAC - * Suppress. static var within hb_clsinst() - * Suppress. indirect call to item pointer by it's Long value - * improved hb_clsinst() hb_getdata() hb_setdata() - * solve lost item pointer (causing unreleased block) at hb_clsaddmsg() - * adding one function called by tObject.prg to implement :Error() message - * so improving class(y) compatibility (HB_FUNC( TOBJECT_ER )) - * - * 1.34 07/25/2000 JFL&RAC + * Copyright 2001 JF. Lefebvre + * Super msg corrected + * Scoping : working for protected, hidden and readonly + * To Many enhancement and correction to give a full list :-) + * Improved class(y) compatibility + * Improved TopClass compatibility * __CLS_PAR00() (Allow the creation of class wich not autoinherit of the default TObject) - * Suppression of the default :Class message ==> transfered to tObject - * - * 1.35 ? - * 1.36 Adding HB_CLS_ENFORCERO FLAG to disable Write access to RO VAR - * This is work in progress (JFL) Should be related to some compatibility flag - * 1.37 minor syntax correction - * 1.38 __ObjHasMsg() could return true when false - * - * 1.61 added hb_objGetpMethod and rewrite hb_clsScope() - * - * - * 1.67 temporary removed hb_objGetpMethod and hb_clsScope - * + * Adding HB_CLS_ENFORCERO FLAG to disable Write access to RO VAR + * outside of Constructors /!\ Could be related to some incompatibility + * Added hb_objGetRealClsName to keep a full class tree * * See doc/license.txt for licensing terms. * @@ -193,6 +129,7 @@ typedef struct BYTE bClsDataInitiated; /* There is one value assigned at init time */ ULONG ulCalls; /* profiler support */ ULONG ulTime; /* profiler support */ + PHB_ITEM pObject ; /* Related super object pointer or NIL */ } METHOD, * PMETHOD; typedef struct @@ -226,8 +163,8 @@ static PHB_DYNS s_msgClsParent = NULL; /* All functions contained in classes.c */ -static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * puiSize ); -/*static void hb_clsScope( PHB_ITEM pObject, PMETHOD pMethod );*/ +static PHB_ITEM hb_clsInst( USHORT uiClass ); +static void hb_clsScope( PHB_ITEM pObject, PMETHOD pMethod ); static ULONG hb_cls_MsgToNum( PHB_DYNS pMsg ); static BOOL hb_clsIsParent( PCLASS pClass, char * szParentName ); static void hb_clsDictRealloc( PCLASS pClass ); @@ -238,7 +175,7 @@ static void hb_clsRelease( PCLASS ); char * hb_objGetRealClsName( PHB_ITEM pObject, char * szName ); PHB_FUNC hb_objGetMethod( PHB_ITEM, PHB_SYMB ); PHB_FUNC hb_objGetMthd( PHB_ITEM pObject, PHB_SYMB pMessage, BOOL lAllowErrFunc ); - /*PMETHOD hb_objGetpMethod( PHB_ITEM, PHB_SYMB );*/ + PMETHOD hb_objGetpMethod( PHB_ITEM, PHB_SYMB ); ULONG hb_objHasMsg( PHB_ITEM pObject, char * szString ); void * hb_mthRequested( void ); @@ -416,6 +353,144 @@ void hb_clsIsClassRef( void ) } } +void hb_clsScope( PHB_ITEM pObject, PMETHOD pMethod ) +{ + PHB_ITEM * pBase = hb_stack.pBase; + PHB_ITEM pCaller; + LONG iLevel = 1; + BOOL bRetVal = FALSE ; + USHORT uiScope = pMethod->uiScope; + PHB_DYNS pMessage = pMethod->pMessage; + char szName[ HB_SYMBOL_NAME_LEN + HB_SYMBOL_NAME_LEN + 32 ]; + char * szCallerNameMsg; + char * szCallerNameObject; + char * szSelfNameMsg; + char * szSelfNameObject; + char * szSelfNameRealClass; + + szSelfNameObject = hb_objGetClsName( pObject ); + szSelfNameMsg = pMessage->pSymbol->szName ; + szSelfNameRealClass = hb_objGetRealClsName( pObject, pMessage->pSymbol->szName ); + + if ( (( uiScope & HB_OO_CLSTP_PROTECTED ) ) || + (( uiScope & HB_OO_CLSTP_HIDDEN ) ) || + (( uiScope & HB_OO_CLSTP_READONLY ) ) + ) + { + while( ( iLevel-- > 0 ) && pBase != hb_stack.pItems ) + pBase = hb_stack.pItems + ( *pBase )->item.asSymbol.stackbase; + + szCallerNameMsg = ( *pBase )->item.asSymbol.value->szName ; + + /* Is it an inline ? if so back one more ... */ + if ( ( strcmp( szCallerNameMsg, "__EVAL" ) == 0 ) && pBase != hb_stack.pItems) + { + pBase = hb_stack.pItems + ( *pBase )->item.asSymbol.stackbase; + } + + if( iLevel == -1 ) + { + + /* Now get the callers ... */ + pCaller = * (pBase+1 ) ; + szCallerNameMsg = ( *pBase )->item.asSymbol.value->szName ; + szCallerNameObject = hb_objGetRealClsName( pCaller, szCallerNameMsg ) ; + + strcpy( szName, szCallerNameObject ); + strcat( szName, ":" ); + strcat( szName, szCallerNameMsg ); + strcat( szName, ">" ); + strcat( szName, szSelfNameRealClass ); + strcat( szName, ">" ); + strcat( szName, szSelfNameObject ); + strcat( szName, ":" ); + strcat( szName, szSelfNameMsg ); + + if ( uiScope & HB_OO_CLSTP_PROTECTED ) + { + if( ( *( pBase+1 ) )->type == HB_IT_ARRAY ) /* is the sender an object */ + { + /* Trying to access a protected Msg from outside the object ... */ + if ( strcmp( szCallerNameObject, szSelfNameRealClass ) != 0 ) + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (protected 1)", szName, 0 ); + } + else + { + /* If called from a function ... protected violation ! */ + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (protected 0)", szName, 0 ); + } + } + + if ( uiScope & HB_OO_CLSTP_HIDDEN ) + { + if( ( *( pBase+1 ) )->type == HB_IT_ARRAY ) /* is the sender an object */ + { + /* Trying to access a protected Msg from outside the object ... */ + if ( strcmp( szCallerNameObject, szSelfNameRealClass ) != 0 ) + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (Hidden 1)", szName, 0 ); + else + { + /* Now as it is an hidden Msg, it can only be called from */ + /* a method of its original class */ + if (! (hb_objGetRealClsName( pCaller, szCallerNameMsg) == szSelfNameRealClass) ) + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (Hidden 2)", szName, 0 ); + } + } + else + { + /* If called from a function ... Hidden violation ! */ + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (Hidden 0)", szName, 0 ); + } + } + + if ( uiScope & HB_OO_CLSTP_READONLY ) + { + if( + ( pMethod->pFunction == hb___msgSetData ) || + ( pMethod->pFunction == hb___msgSetClsData ) || + ( pMethod->pFunction == hb___msgSetShrData ) + ) + bRetVal = TRUE; + + if (bRetVal) + { + if( ( *( pBase+1 ) )->type == HB_IT_ARRAY ) /* is the sender an object */ + { + /* Trying to assign a RO Msg from outside the object ... */ + if ( strcmp( szCallerNameObject, szSelfNameRealClass ) != 0 ) + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (ReadOnly)", szName, 0 ); + else + { +#ifdef HB_CLS_ENFORCERO /* Not enabled by default */ + /* can only be called from a Constructor */ + /* ok Now is it a CTOR ? */ + + PMETHOD pCallerMethod ; + + PHB_DYNS pCallerMsg = hb_dynsymGet( szCallerNameMsg ); + + pCallerMethod = hb_objGetpMethod( pCaller, pCallerMsg->pSymbol ); + + if ( pCallerMethod ) + { + if ( ! (pCallerMethod->uiScope & HB_OO_CLSTP_CTOR) ) + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (ReadOnly)", szName, 0 ); + } +#endif + } + } + else + { + /* If called from a function ... ReadOnly violation ! */ + hb_errRT_BASE( EG_NOMETHOD, 1004, "Scope violation (ReadOnly 0)", szName, 0 ); + } + } + } + } + } +} + + ULONG hb_cls_MsgToNum( PHB_DYNS pMsg ) { USHORT i; @@ -534,7 +609,10 @@ char * hb_objGetRealClsName( PHB_ITEM pObject, char * szName ) USHORT uiClass; /* default value to current class object */ - uiClass = pObject->item.asArray.value->uiClass; + if (pObject->item.asArray.value->uiPrevCls) + uiClass = pObject->item.asArray.value->uiPrevCls; + else + uiClass = pObject->item.asArray.value->uiClass; if( uiClass && uiClass <= s_uiClasses ) { @@ -642,7 +720,7 @@ PHB_FUNC hb_objGetMthd( PHB_ITEM pObject, PHB_SYMB pMessage, BOOL lAllowErrFunc { pMethod = pClass->pMethods + uiAt; pFunction = pMethod->pFunction; - /*hb_clsScope( pObject, pMethod );*/ + hb_clsScope( pObject, pMethod ); s_pMethod = pMethod ; pMethod->ulCalls++; /* Profiler */ return pFunction; @@ -696,6 +774,45 @@ PHB_FUNC hb_objGetMthd( PHB_ITEM pObject, PHB_SYMB pMessage, BOOL lAllowErrFunc return NULL; } +PMETHOD hb_objGetpMethod( PHB_ITEM pObject, PHB_SYMB pMessage ) +{ + USHORT uiClass; + PHB_DYNS pMsg = pMessage->pDynSym; + + HB_TRACE(HB_TR_DEBUG, ("hb_objGetpMethod(%p, %p)", pObject, pMessage)); + + if( pObject->type == HB_IT_ARRAY ) + uiClass = pObject->item.asArray.value->uiClass; + else + uiClass = 0; + + if( uiClass && uiClass <= s_uiClasses ) + { + PCLASS pClass = s_pClasses + ( uiClass - 1 ); + USHORT uiAt = ( USHORT ) ( ( ( hb_cls_MsgToNum( pMsg ) ) % pClass->uiHashKey ) * BUCKET ); + USHORT uiMask = ( USHORT ) ( pClass->uiHashKey * BUCKET ); + USHORT uiLimit = ( USHORT ) ( uiAt ? ( uiAt - 1 ) : ( uiMask - 1 ) ); + + while( uiAt != uiLimit ) + { + if( pClass->pMethods[ uiAt ].pMessage == pMsg ) + return (pClass->pMethods + uiAt) ; + + + + + + + uiAt++; + if( uiAt == uiMask ) + uiAt = 0; + } + } + + return NULL; +} + + /* * = hb_objHasMsg( , ) * @@ -1056,7 +1173,6 @@ HB_FUNC( __CLSNEW ) pNewCls->pFunError = pSprCls->pFunError; } - bResize = ( ( pNewCls->uiMethods + pSprCls->uiMethods ) > ( pNewCls->uiHashKey * BUCKET * 2 / 3 ) ) ; uiCurrent = 0 ; @@ -1065,7 +1181,6 @@ HB_FUNC( __CLSNEW ) if( bResize ) { - /* Not easy to debug ... I don't find any samples where this case appear */ hb_clsDictRealloc( pNewCls ); bResize=FALSE; } @@ -1100,9 +1215,7 @@ HB_FUNC( __CLSNEW ) || pNewCls->pMethods[ uiAt+uiBucket ].pFunction == hb___msgGetClsData ) - { pNewCls->pMethods[ uiAt+uiBucket ].uiData += nLenClsDatas; - } if( pNewCls->pMethods[ uiAt+uiBucket ].pFunction == hb___msgSetData @@ -1111,9 +1224,9 @@ HB_FUNC( __CLSNEW ) || pNewCls->pMethods[ uiAt+uiBucket ].pFunction == hb___msgSuper ) - { + { pNewCls->pMethods[ uiAt+uiBucket ].uiData += nLenDatas; - } + } if( pNewCls->pMethods[ uiAt+uiBucket ].pFunction == hb___msgEvalInline ) pNewCls->pMethods[ uiAt+uiBucket ].uiData += nLenInlines; @@ -1248,25 +1361,19 @@ HB_FUNC( __CLSINST ) { PHB_ITEM pSelf ; - PHB_ITEM * ppObjects=NULL; - USHORT uiSize=0; - - pSelf = hb_clsInst( ( USHORT ) hb_parni( 1 ), &ppObjects, &uiSize ); + pSelf = hb_clsInst( ( USHORT ) hb_parni( 1 )); if( pSelf ) hb_itemRelease( hb_itemReturn( pSelf ) ); - if( ppObjects ) - hb_xfree( ppObjects ); } - /* - * [] := hb_clsInst( , , ) + * [] := hb_clsInst( ) * * Create a (super)object from class definition */ -static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * puiSize ) +static PHB_ITEM hb_clsInst( USHORT uiClass ) { PHB_ITEM pSelf = NULL; @@ -1284,72 +1391,17 @@ static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * pui pSelf->item.asArray.value->uiClass = uiClass; pSelf->item.asArray.value->uiPrevCls = 0; - /* Phase I Instanciate all Herited object recursively */ - /* A:B ==> oB */ - /* Then B:C ==> oC ... */ - /* Do not try to work on A:C (inherited class super object from B) */ - pMeth = pClass->pMethods; - for( uiAt = 0; uiAt < uiLimit; uiAt++, pMeth++ ) - { - if( ( pMeth->uiScope & HB_OO_CLSTP_CLASS ) == HB_OO_CLSTP_CLASS - && - ( pMeth->uiScope & HB_OO_CLSTP_SUPER ) != HB_OO_CLSTP_SUPER - ) - { - - pSprObj = hb_clsInst( pMeth->uiSprClass, ppObjects, puiSize ); /*instance super object*/ - - hb_arraySet( pSelf, pMeth->uiData, pSprObj ); - hb_itemRelease( pSprObj ); - - ++(*puiSize); - if( *ppObjects == NULL ) - *ppObjects = ( PHB_ITEM * ) hb_xgrab( sizeof( PHB_ITEM ) ); - else - *ppObjects = ( PHB_ITEM * ) hb_xrealloc( *ppObjects, (*puiSize) * sizeof( PHB_ITEM ) ); - - pTmp = hb_arrayGetItemPtr( pSelf, pMeth->uiData ); - - (*ppObjects)[ (*puiSize) - 1 ] = pTmp; - - } - } - - /* Phase II Create link between A:C and A:B:C !! */ - /* They must point to the same object */ - pMeth = pClass->pMethods; - for( uiAt = 0; uiAt < uiLimit; uiAt++, pMeth++ ) - { - if( ( pMeth->uiScope & HB_OO_CLSTP_CLASS ) == HB_OO_CLSTP_CLASS - && - ( pMeth->uiScope & HB_OO_CLSTP_SUPER ) == HB_OO_CLSTP_SUPER - ) - { - USHORT uiCnt; - - for( uiCnt = 1; uiCnt <= (*puiSize); uiCnt++ ) - { - pTmp = (*ppObjects)[ uiCnt - 1 ]; - - if( pTmp->item.asArray.value->uiClass == pMeth->uiSprClass ) - { - hb_arraySet( pSelf, pMeth->uiData, pTmp ); - break; - } - } - - } - } - - /* Phase III Create link between instancied object and SuperDataMessages */ /* Initialise value if initialisation was requested */ pMeth = pClass->pMethods; for( uiAt = 0; uiAt < uiLimit; uiAt++, pMeth++ ) { /* Init Classdata (inherited and not) if needed */ - if( pMeth->pInitValue && pMeth->pFunction == hb___msgGetClsData && !( pMeth->bClsDataInitiated ) ) + if( pMeth->pInitValue ) { + + if( pMeth->pFunction == hb___msgGetClsData && !( pMeth->bClsDataInitiated ) ) + { HB_ITEM init; PHB_ITEM pInit; @@ -1372,50 +1424,9 @@ static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * pui } hb_itemClear( &init ); - } - - if( ( pMeth->uiScope & HB_OO_CLSTP_SUPER ) == HB_OO_CLSTP_SUPER ) - { - if( pMeth->pFunction == hb___msgGetData ) - { - USHORT uiCnt; - - for( uiCnt = 1; uiCnt <= (*puiSize); uiCnt++ ) - { - pTmp = (*ppObjects)[ uiCnt - 1 ]; - - if( pTmp->item.asArray.value->uiClass == pMeth->uiSprClass ) - { - USHORT ui, uiBucket; - PHB_DYNS pMsg; - PCLASS pSprCls; - PHB_ITEM pDataHrtd; - - pMsg = ( PHB_DYNS ) pMeth->pMessage; - - pSprCls = s_pClasses + ( pMeth->uiSprClass - 1 ); - - ui = ( USHORT ) ( ( ( hb_cls_MsgToNum( pMsg ) ) % pSprCls->uiHashKey ) * BUCKET ); - - for( uiBucket = 0; uiBucket < BUCKET; uiBucket++ ) - { - if( pMsg == pSprCls->pMethods[ ui+uiBucket ].pMessage /*strcmp( pMsg->pSymbol->szName, pSprCls->pMethods[ ui+uiBucket ].pMessage->pSymbol->szName ) == 0*/ ) - break; - } - - pDataHrtd = ( PHB_ITEM ) hb_arrayGetItemPtr( pTmp, pSprCls->pMethods[ ui+uiBucket ].uiData ); - - hb_arraySet( pSelf, pMeth->uiData, pDataHrtd ); - break; - - } - } - } - } - else if( pMeth->pInitValue ) - { - if( pMeth->pFunction == hb___msgGetData ) /* is a DATA but not herited */ - { + } + else if( pMeth->pFunction == hb___msgGetData ) /* is a DATA but not herited */ + { PHB_ITEM pInitValue ; if( HB_IS_ARRAY( pMeth->pInitValue ) ) @@ -1431,9 +1442,9 @@ static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * pui hb_arraySet( pSelf, pMeth->uiData, pInitValue ); hb_itemRelease( pInitValue ); - } - else if( pMeth->pFunction == hb___msgGetShrData && !( pMeth->bClsDataInitiated ) ) - { + } + else if( pMeth->pFunction == hb___msgGetShrData && !( pMeth->bClsDataInitiated ) ) + { /* Init Shared Classdata as needed, we only need to init the first */ /* not inherited classdata array where all shared will point to */ HB_ITEM init; @@ -1458,7 +1469,7 @@ static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * pui pMeth->bClsDataInitiated = 1; } hb_itemClear( &init ); - } + } } } } @@ -1466,7 +1477,6 @@ static PHB_ITEM hb_clsInst( USHORT uiClass, PHB_ITEM * * ppObjects, USHORT * pui return pSelf; } - /* * __clsModMsg( , , ) * @@ -2075,21 +2085,12 @@ static HARBOUR hb___msgEval( void ) static HARBOUR hb___msgSuper( void ) { PHB_ITEM pObject = hb_stackSelfItem(); -/* USHORT uiIndex = s_pMethod->uiData; */ pObject->item.asArray.value->uiPrevCls = pObject->item.asArray.value->uiClass; /* backup of actual handel */ - pObject->item.asArray.value->uiClass = s_pMethod->uiSprClass; /* superclass handel casting */ + pObject->item.asArray.value->uiClass = s_pMethod->uiSprClass; /* superclass handel casting */ hb_itemReturn( pObject ); -/* This one would return a real superObject but with the side effect to */ -/* also set a bad Self pointer for the supermessages */ -/* Please don't erase those lines until I do it myself (JF) */ -/* I have yet to think about a better solution where I could return a */ -/* real Object as keeping the good Self value within all the class tree */ -/* */ -/* hb_itemReturn( hb_arrayGetItemPtr( pObject, s_pMethod->uiData ) ); */ -/* */ } /* @@ -2261,7 +2262,6 @@ HB_FUNC( __CLS_PAR00 ) } hb_itemRelease( hb_itemReturn( array ) ); - } static ULONG MsgToNum( char * szName ) diff --git a/harbour/utils/hbmake/hbmake.prg b/harbour/utils/hbmake/hbmake.prg index 085b0b4a97..f7fb10de2e 100644 --- a/harbour/utils/hbmake/hbmake.prg +++ b/harbour/utils/hbmake/hbmake.prg @@ -50,8 +50,6 @@ * */ - - #include 'fileio.ch' #include "common.ch" #include "radios.ch" @@ -143,7 +141,7 @@ If Pcount() == 0 ? " or use one macro per -D switch" Return NIL Endif -If cFile == NIL +If cFile == NIL ? "File not Found" Return Nil Endif @@ -160,7 +158,7 @@ If Pcount() == 2 allparam:=strtran(allparam,"-B","") Endif -if at("-G",allparam)>0 +if at("-G",allparam)>0 lBcc := .F. lGcc := .T. lVcc := .F. @@ -175,7 +173,7 @@ if at("-G",allparam)>0 allparam:=strtran(allparam,"-V","") Endif -if at("-EL",allparam)>0 +if at("-EL",allparam)>0 allparam:=strtran(allparam,"-EL","") lLibrary:=.T. @@ -183,7 +181,7 @@ if at("-EL",allparam)>0 Return nil Endif -if at("-E",allparam)>0 +if at("-E",allparam)>0 allparam:=strtran(allparam,"-E","") @@ -191,7 +189,7 @@ if at("-E",allparam)>0 Return nil Endif -if at("-I",allparam)>0 +if at("-I",allparam)>0 lIgnoreErrors := .T. allparam:=strtran(allparam,"-I","") @@ -231,7 +229,7 @@ If Pcount() > 2 allparam:=strtran(allparam,"-B","") Endif -if at("-G",allparam)>0 +if at("-G",allparam)>0 lBcc := .F. lGcc := .T. lVcc := .F. @@ -239,7 +237,7 @@ if at("-G",allparam)>0 Endif - if at("-V",allparam)>0 + if at("-V",allparam)>0 lBcc := .F. lGcc := .F. @@ -264,14 +262,14 @@ if at("-E",allparam)>0 Return nil Endif - if at("-I",allparam)>0 + if at("-I",allparam)>0 lIgnoreErrors := .T. allparam:=strtran(allparam,"-I","") Endif - if at("-P",allparam)>0 + if at("-P",allparam)>0 lPrint := .t. allparam:=strtran(allparam,"-P","") @@ -322,7 +320,7 @@ Local cDep := "#DEPENDS" Local cOpt := "#OPTS" Local cCom := "#COMMANDS" Local cBuild := "#BUILD" -Local cTemp := "" +Local cTemp := "" Local cTemp1 := '' Local aTemp := {} Local lMacrosec := .f. @@ -581,8 +579,8 @@ Return cPath Function GetGccDir() Local cPath := '' -Local cEnv -Local aEnv +Local cEnv +Local aEnv Local nPos if at("linux",GetEnv("HB_ARCHITECTURE"))>0 cpath:="/usr/bin" @@ -840,7 +838,7 @@ For nCount := 1 To Len( aOrder ) Endif For nFiles := 1 To Len( aPrgs ) - + nPos := Ascan( aCs, { | x | Left( x, At( ".", x ) ) == Left( aPrgs[ nFiles ], At( ".", aPrgs[ nFiles ] ) ) } ) If nPos > 0 cComm := Strtran( cComm, "o$*", "o" + aCs[ nPos ] ) @@ -853,14 +851,14 @@ For nCount := 1 To Len( aOrder ) if !lIgnoreErrors .and. lEnd quit endif - + cComm := cold Endif Next Endif If aOrder[ nCount ] == "$(OBJFILES)" If lGcc - nPos := Ascan( aCommands, { | x, y | x[ 1 ] == ".c.o:" } ) + nPos := Ascan( aCommands, { | x, y | x[ 1 ] == ".c.o:" } ) Else nPos := Ascan( aCommands, { | x, y | x[ 1 ] == ".c.obj:" } ) Endif @@ -892,7 +890,7 @@ For nCount := 1 To Len( aOrder ) endif */ nPos := Ascan( aObjs, { | x | Left( x, At( ".", x ) ) == Left( acs[ nFiles ], At( ".", acs[ nFiles ] ) ) } ) - + If nPos > 0 cComm := Strtran( cComm, "o$*", "o" + aObjs[ nPos ] ) cComm := Strtran( cComm, "$**", acs[ nFiles ] ) @@ -1051,29 +1049,29 @@ Cls Setcolor( 'w/b+,w/b,w+/b,w/b+,w/b,w+/b' ) @ 0, 0, Maxrow(), Maxcol() Box( Chr( 201 ) + Chr( 205 ) + Chr( 187 ) + Chr( 186 ) + Chr( 188 ) + Chr( 205 ) + Chr( 200 ) + Chr( 186 ) + Space( 1 ) ) ATTENTION( "Enviroment options", 0 ) -@ 1, 1 Say "Select Os" +@ 1, 1 Say "Select Os" @ 1, 12 Get cos radio { "Win32", "OS/2", "Linux" } -@ 1, 23 Say "Select C Compiler" -@ 1, 40 Get cCompiler radio { "BCC", "MSVC", "GCC" } -@ 1, 48 Say "Graphic Library" -@ 1, 64 Get lFwh checkbox "Use FWH" when Cos=="Win32" -@ 2, 64 Get lcw checkbox "Use C4W" when Cos=="Win32" -@ 3, 64 Get lRddads checkbox "Use RddAds" when Cos=="Win32" +@ 1, 23 Say "Select C Compiler" +@ 1, 40 Get cCompiler radio { "BCC", "MSVC", "GCC" } +@ 1, 48 Say "Graphic Library" +@ 1, 64 Get lFwh checkbox "Use FWH" when Cos=="Win32" +@ 2, 64 Get lcw checkbox "Use C4W" when Cos=="Win32" +@ 3, 64 Get lRddads checkbox "Use RddAds" when Cos=="Win32" Read If lFwh - @ 4, 1 Say "FWH path" Get cfwhpath + @ 4, 1 Say "FWH path" Get cfwhpath Elseif lCw - @ 4, 1 Say "C4H path" Get ccwpath + @ 4, 1 Say "C4H path" Get ccwpath Endif ATTENTION( "Harbour Options", 5 ) -@ 6, 1 Get lautomemvar checkbox "Automatic memvar declaration" -@ 6, 43 Get lvarismemvar checkbox "Variables are assumed M->" -@ 7, 1 Get lDebug checkbox "Debug info" -@ 7, 43 Get lSupressline checkbox "Suppress line number information" -@ 8, 1 Get lGenppo checkbox "Generate pre-processed output" -@ 8, 43 Get lCompMod checkbox "compile module only" +@ 6, 1 Get lautomemvar checkbox "Automatic memvar declaration" +@ 6, 43 Get lvarismemvar checkbox "Variables are assumed M->" +@ 7, 1 Get lDebug checkbox "Debug info" +@ 7, 43 Get lSupressline checkbox "Suppress line number information" +@ 8, 1 Get lGenppo checkbox "Generate pre-processed output" +@ 8, 43 Get lCompMod checkbox "compile module only" Read lBcc := If( At( "BCC", cCompiler ) > 0, .t., .f. ) lVcc := If( At( "MSVC", cCompiler ) > 0, .t., .f. ) @@ -1208,7 +1206,7 @@ if lGcc hb_FNAMESPLIT(cTopfile,@cPath ,@cTest, @cExt , @cDrive) cExt:=substr(cExt,2) Fwrite( nLinkHandle, "PROJECT = " + if(isupper(cExt),cTest+"."+Strtran( cExt, "PRG", "EXE" ),cTest+"."+Strtran( cExt, "prg", "exe" )) +" $(PR) "+ CRLF ) - endif + endif else hb_FNAMESPLIT(cTopfile,@cPath ,@cTest, @cExt , @cDrive) cExt:=substr(cExt,2) @@ -1260,7 +1258,7 @@ if lRddads cDefBccLibs+=" rddads.lib ace32.lib" endif if lBcc .or. lVcc - If lFwh + If lFwh Fwrite( nLinkHandle, "LIBFILES = $(FWH)\lib\fiveh.lib $(FWH)\lib\fivehc.lib " + cDefBccLibs + CRLF ) elseif lCw Fwrite( nLinkHandle, "LIBFILES = $(C4W)\c4wclass.lib $(C4W)\wbrowset.lib $(C4W)\otabt.lib $(C4W)\clip4win.lib" + cDefBccLibs + CRLF ) @@ -1369,7 +1367,7 @@ elseif lGcc Fwrite( nLinkHandle, "!"+CRLF) endif - + Return nil @@ -1455,7 +1453,7 @@ For nCount := 1 To Len( aOrder ) if !lIgnoreErrors .and. lEnd quit endif - + cComm := cold Endif @@ -1509,7 +1507,7 @@ Next Return nil function fileisnewer(cFile,as) -local nCount := 0 +local nCount := 0 For nCount:=1 to len(aPrgs) adir := { cFile,, filedate( cFile ), filetime( cFile ), ; as[nCount], filedate( as[nCount] ), filetime( as[nCount] )} @@ -1580,22 +1578,22 @@ Cls Setcolor( 'w/b+,w/b,w+/b,w/b+,w/b,w+/b' ) @ 0, 0, Maxrow(), Maxcol() Box( Chr( 201 ) + Chr( 205 ) + Chr( 187 ) + Chr( 186 ) + Chr( 188 ) + Chr( 205 ) + Chr( 200 ) + Chr( 186 ) + Space( 1 ) ) ATTENTION( "Enviroment options", 0 ) -@ 1, 1 Say "Select Os" +@ 1, 1 Say "Select Os" @ 1, 12 Get cos radio { "Win32", "OS/2", "Linux" } -@ 1, 23 Say "Select C Compiler" -@ 1, 40 Get cCompiler radio { "BCC", "MSVC", "GCC" } +@ 1, 23 Say "Select C Compiler" +@ 1, 40 Get cCompiler radio { "BCC", "MSVC", "GCC" } Read - @ 4, 1 Say "Library name with our extention" Get cfwhpath + @ 4, 1 Say "Library name with our extention" Get cfwhpath ATTENTION( "Harbour Options", 5 ) -@ 6, 1 Get lautomemvar checkbox "Automatic memvar declaration" -@ 6, 43 Get lvarismemvar checkbox "Variables are assumed M->" -@ 7, 1 Get lDebug checkbox "Debug info" -@ 7, 43 Get lSupressline checkbox "Suppress line number information" -@ 8, 1 Get lGenppo checkbox "Generate pre-processed output" -@ 8, 43 Get lCompMod checkbox "compile module only" +@ 6, 1 Get lautomemvar checkbox "Automatic memvar declaration" +@ 6, 43 Get lvarismemvar checkbox "Variables are assumed M->" +@ 7, 1 Get lDebug checkbox "Debug info" +@ 7, 43 Get lSupressline checkbox "Suppress line number information" +@ 8, 1 Get lGenppo checkbox "Generate pre-processed output" +@ 8, 43 Get lCompMod checkbox "compile module only" Read lBcc := If( At( "BCC", cCompiler ) > 0, .t., .f. ) lVcc := If( At( "MSVC", cCompiler ) > 0, .t., .f. ) @@ -1784,7 +1782,7 @@ if lGcc Fwrite( nLinkHandle, "PROJECT = " + alltrim(lower(cfwhpath))+".a "+CRLF ) else Fwrite( nLinkHandle, "PROJECT = " + alltrim(lower(cfwhpath))+".a "+CRLF ) - endif + endif else Fwrite( nLinkHandle, "PROJECT = " + alltrim(lower(cfwhpath))+".lib "+CRLF ) @@ -1799,7 +1797,7 @@ else //Fwrite( nLinkHandle, "OBJFILES =" + if(isupper(cTopfile),Strtran( cTopfile, ".PRG", ".OBJ" ),Strtran( cTopfile, ".prg", ".obj" ))) For x := 1 To Len( aobjs ) - If x <> Len( aobjs ) + If x <> Len( aobjs ) Fwrite( nLinkHandle, alltrim(aobjs[ x ]) ) Else Fwrite( nLinkHandle," " + alltrim(aobjs[ x ]) +" $(OB) "+ CRLF ) @@ -1814,7 +1812,7 @@ else //Fwrite( nLinkHandle, "CFILES = " + if(isupper(cTopfile),Strtran( cTopfile, ".PRG", ".C" ),Strtran( cTopfile, ".prg", ".c" ))) For x := 1 To Len( acs ) - If x <> Len( acs ) + If x <> Len( acs ) Fwrite( nLinkHandle, " " + alltrim(aCs[ x ]) ) Else Fwrite( nLinkHandle, " " + alltrim(aCs[ x ]) +" $(CF) "+ CRLF ) @@ -1825,7 +1823,7 @@ endif Fwrite( nLinkHandle, "RESFILES = " + CRLF ) Fwrite( nLinkHandle, "RESDEPEN = $(RESFILES)" + CRLF ) if lBcc .or. lVcc - If lFwh + If lFwh Fwrite( nLinkHandle, "LIBFILES = " + CRLF ) elseif lCw Fwrite( nLinkHandle, "LIBFILES = " + CRLF ) @@ -1922,7 +1920,7 @@ elseif lGcc Fwrite( nLinkHandle, "!"+CRLF) endif - + Return nil @@ -1950,7 +1948,7 @@ If Len( amacro ) > 1 Next //if lgcc // fwrite(nLinkHandle,"CREATE " + cProject+CRLF) -//endif +//endif Endif Aadd( aBuildOrder, amacro[ 1 ] ) @@ -2083,8 +2081,12 @@ if NEGATIVE endif return val( SOMESTRING ) + +#ifndef __HARBOUR__ function HB_OSNEWLINE() RETURn CHR(13)+CHR(10) +#endif + function checkiffile(cFile) Local cNextLine:='' Local cCommand:=''