diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 63c8654a12..4ea8b964c9 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,66 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +2007-09-26 02:30 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + * harbour/include/hbclass.ch + + added: + ON ERROR FUNCTION + OPERATOR FUNCTION + + * harbour/include/hbapicls.h + * harbour/source/vm/classes.c + * harbour/source/vm/hvm.c + + added support for overloading right side $ operator + + * harbour/contrib/xhb/xhbfunc.c + * rewritten xhb_ains() and xhb_adel() in C + + * harbour/contrib/xhb/xhb.ch + * changed AINS() conversion to be xHarbour compatible + + * harbour/contrib/xhb/Makefile + + added xhb.ch to PRG_HEADERS so it's installed automatically + during 'make install' + + * harbour/contrib/xhb/Makefile + + harbour/contrib/xhb/xhbmsgs.c + * harbour/contrib/xhb/xhbcomp.prg + + added support for $ operator used with hashes and arrays + on right side working _exactly_ like in xHarbour. + + added support for negative indexes in used in [] operator + for array and strings. + Please remember that standard harbour build (without + HB_COMPAT_XHB flag) generate warning for negative indexes, + if you wan to pacify them then instead of var[-1] use var[(-1)] + + added support for assign string characters with [] index. + Please remember that for standard harbour build (without + HB_COMPAT_XHB flag) you have to use -ks compile time switch + if you want to assign strings in such way because this feature + needs different PCODE, f.e. try to compile this code: + proc main() + local s:="ABC" + s[(-1)] := "*" + ? s + return + with and without -ks switch + + added support for accessing hash items using OO interface, f.e.: + proc main() + local h:={"ABC"=>123.45,"XYZ"=>567.89} + ? h["ABC"], h["XYZ"] + ? h:ABC, h:XYZ + h:ABC+=1000 + h:XYZ:=-2000 + ? h:ABC, h:XYZ + return + + All of the above extensions are written in C code so the speed + overhead is very small. Harbour evaluates PCODE faster then xHarbour + so in speed tests where above operators are executed in loop without + any other code the xHarbour results with native support are comparable + with Harbour ones where above operators are overloaded using scalar + classes so in normal code you should not find any difference with + one exception for assigning characters in very long strings. + 2007-09-25 19:15 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) * contrib/xhb/xhbcomp.prg + Added "string as array" implementation. I didn't test diff --git a/harbour/contrib/xhb/Makefile b/harbour/contrib/xhb/Makefile index 36bcc61b4b..3207b28d06 100644 --- a/harbour/contrib/xhb/Makefile +++ b/harbour/contrib/xhb/Makefile @@ -10,6 +10,7 @@ C_SOURCES=\ hboutdbg.c \ cstructc.c \ xhbfunc.c \ + xhbmsgs.c \ PRG_SOURCES=\ txml.prg \ @@ -19,6 +20,7 @@ PRG_SOURCES=\ xhbcomp.prg \ PRG_HEADERS=\ + xhb.ch \ hblog.ch \ hblogdef.ch \ cstruct.ch \ diff --git a/harbour/contrib/xhb/xhb.ch b/harbour/contrib/xhb/xhb.ch index 2d3c2e0f18..2118a08d56 100644 --- a/harbour/contrib/xhb/xhb.ch +++ b/harbour/contrib/xhb/xhb.ch @@ -56,7 +56,7 @@ REQUEST XHB_LIB - #xtranslate AIns(,,) => xhb_AIns(,,) + #xtranslate AIns(,,[]) => xhb_AIns(,,) #xtranslate ADel(,,) => xhb_ADel(,,) #endif diff --git a/harbour/contrib/xhb/xhbcomp.prg b/harbour/contrib/xhb/xhbcomp.prg index 1d4f28eb35..a4ad2f2f76 100644 --- a/harbour/contrib/xhb/xhbcomp.prg +++ b/harbour/contrib/xhb/xhbcomp.prg @@ -1,6 +1,6 @@ /* -* $Id$ -*/ + * $Id$ + */ /* * Harbour Project source code: @@ -56,162 +56,22 @@ ANNOUNCE XHB_LIB INIT PROCEDURE xhb_Init() - /* Add calls to do initial settings to Harbour to be more compatible with xhb. */ - ASSOCIATE CLASS xhb_Character WITH TYPE Character - - RETURN - -FUNCTION xhb_AIns( a, n, x ) - - AIns( a, n ) - IF PCount() > 2 - a[ n ] := x - ENDIF - - RETURN a - -FUNCTION xhb_ADel( a, n, l ) - - ADel( a, n ) - IF PCount() > 2 .AND. ISLOGICAL( l ) .AND. l - ASize( a, Len( a ) - 1 ) - ENDIF - - RETURN a - -/* -* Overloading of "$","[]" operators in scalar classes -* "$" is done for types: -* HBCharacter -* HBDate -* HBLogical -* HBNil -* HBNumeric -* // HBPointer -* // HBSymbol -* "[]" is only for HBCharacter type -* TODO: assign. in the form [n] := -* 2007 tfonrouge -*/ -/* - HBScalar -*/ -CLASS HBScalar - METHOD IsIn OPERATOR "$" -ENDCLASS - -/* - HBScalar:IsIn : "$" operator -*/ -METHOD IsIn( itm ) CLASS HBScalar - IF HB_IsArray( itm ) - RETURN AScan( itm, Self ) > 0 - ENDIF - IF HB_IsHash( itm ) - RETURN HB_HHasKey( itm, Self ) - ENDIF - /* - * we need to raise a error here ? when ? - */ -RETURN .F. /* */ - -/* - HBArray -*/ -CLASS HBArray FROM HBScalar - METHOD IsIn OPERATOR "$" // $ returns .F. -ENDCLASS - -/* - HBArray:IsIn : "$" operators -*/ -METHOD IsIn CLASS HBArray -RETURN .F. - -/* - HBCharacter -*/ -CLASS HBCharacter FROM HBScalar - METHOD Index OPERATOR "[]" -ENDCLASS - -/* - HBCharacter:Index -*/ -METHOD Index( n/*, char*/ ) CLASS HBCharacter - /* - IF PCount()>1 - Self := Stuff( Self, n, Len( char ), char ) - RETURN Self - ENDIF - */ -RETURN SubStr( Self, n , 1 ) - -/* - HBDate -*/ -CLASS HBDate FROM HBScalar -ENDCLASS - -/* - HBHash -*/ -CLASS HBHash FROM HBScalar - METHOD IsIn OPERATOR "$" // $ returns .F. -ENDCLASS - -/* - HBHash:IsIn : "$" operators -*/ -METHOD IsIn CLASS HBHash -RETURN .F. - -/* - HBLogical -*/ -CLASS HBLogical FROM HBScalar -ENDCLASS - -/* - HBNil -*/ -CLASS HBNil FROM HBScalar -ENDCLASS - -/* - HBNumeric -*/ -CLASS HBNumeric FROM HBScalar -ENDCLASS - -/* - HBPointer -*/ -/* -CLASS HBPointer FROM HBScalar -ENDCLASS -*/ - -/* - HBSymbol -*/ -/* -CLASS HBSymbol FROM HBScalar -ENDCLASS -*/ + ASSOCIATE CLASS xhb_Array WITH TYPE Array + ASSOCIATE CLASS xhb_Hash WITH TYPE Hash +RETURN CREATE CLASS Character INHERIT HBScalar FUNCTION xhb_Character - - METHOD AsString() - METHOD AsExpStr() - OPERATOR "[]" ARG nIndex INLINE SubStr( Self, iif( nIndex < 0, Len( Self ) + nIndex, nIndex ), 1 ) - + OPERATOR "[]" FUNCTION XHB_INDEX() ENDCLASS -METHOD AsString() CLASS Character - RETURN Self +CREATE CLASS Array INHERIT HBScalar FUNCTION xhb_Array + OPERATOR "[]" FUNCTION XHB_INDEX() + OPERATOR "$$" FUNCTION XHB_INCLUDE() +ENDCLASS -METHOD AsExpStr() CLASS Character - RETURN '"' + Self + '"' +CREATE CLASS Hash INHERIT HBScalar FUNCTION xhb_Hash + ON ERROR FUNCTION XHB_HASHERROR() + OPERATOR "$$" FUNCTION XHB_INCLUDE() +ENDCLASS diff --git a/harbour/contrib/xhb/xhbfunc.c b/harbour/contrib/xhb/xhbfunc.c index 4663c55460..f5a97182ee 100644 --- a/harbour/contrib/xhb/xhbfunc.c +++ b/harbour/contrib/xhb/xhbfunc.c @@ -211,3 +211,50 @@ HB_FUNC( INETDGRAMRECV ) { HB_FUNC_EXEC( HB_INETDGRAMRECV ); } HB_FUNC( INETCRLF ) { HB_FUNC_EXEC( HB_INETCRLF ); } HB_FUNC( ISINETSOCKET ) { HB_FUNC_EXEC( HB_ISINETSOCKET ); } HB_FUNC( INETDESTROY ) { } + +HB_FUNC( XHB_AINS ) +{ + PHB_ITEM pArray = hb_param( 1, HB_IT_ARRAY ); + + if( pArray ) + { + long lPos = hb_parnl( 2 ); + + if( lPos == 0 ) + lPos = 1; + + if( hb_pcount() >= 4 && ISLOG( 4 ) && hb_parl( 4 ) ) + { + ULONG ulLen = hb_arrayLen( pArray ) + 1; + if( lPos >= 1 && ( ULONG ) lPos <= ulLen ) + hb_arraySize( pArray, ulLen ); + } + + if( hb_arrayIns( pArray, lPos ) ) + { + if( hb_pcount() >= 3 && !ISNIL( 3 ) ) + hb_arraySet( pArray, lPos, hb_param( 3, HB_IT_ANY ) ); + } + hb_itemReturn( pArray ); /* AIns() returns the array itself */ + } +} + +HB_FUNC( XHB_ADEL ) +{ + PHB_ITEM pArray = hb_param( 1, HB_IT_ARRAY ); + + if( pArray ) + { + long lPos = hb_parnl( 2 ); + + if( lPos == 0 ) + lPos = 1; + + if( hb_arrayDel( pArray, lPos ) ) + { + if( hb_pcount() >= 3 && ISLOG( 3 ) && hb_parl( 3 ) ) + hb_arraySize( pArray, hb_arrayLen( pArray ) - 1 ); + } + hb_itemReturn( pArray ); /* ADel() returns the array itself */ + } +} diff --git a/harbour/contrib/xhb/xhbmsgs.c b/harbour/contrib/xhb/xhbmsgs.c new file mode 100644 index 0000000000..fc8ecad29d --- /dev/null +++ b/harbour/contrib/xhb/xhbmsgs.c @@ -0,0 +1,200 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * xHarbour compatible messages used in overloaded scalar classes + * + * Copyright 2007 Przemyslaw Czerpak + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "hbapiitm.h" +#include "hbapierr.h" +#include "hbapilng.h" +#include "hbstack.h" + +HB_FUNC( XHB_HASHERROR ) +{ + const char * szMessage = hb_itemGetSymbol( hb_stackBaseItem() )->szName; + int iPCount = hb_pcount(); + + if( iPCount == 1 ) + { + if( szMessage[ 0 ] == '_' ) + { /* ASSIGN */ + PHB_ITEM pIndex = hb_itemPutCConst( hb_stackAllocItem(), szMessage + 1 ); + PHB_ITEM pDest = hb_hashGetItemPtr( hb_stackSelfItem(), pIndex, HB_HASH_AUTOADD_ASSIGN ); + hb_stackPop(); + if( pDest ) + { + PHB_ITEM pValue = hb_param( 1, HB_IT_ANY ); + hb_itemCopyFromRef( pDest, pValue ); + hb_itemReturn( pValue ); + return; + } + } + } + else if( iPCount == 0 ) + { /* ACCESS */ + PHB_ITEM pIndex = hb_itemPutCConst( hb_stackAllocItem(), szMessage ); + PHB_ITEM pValue = hb_hashGetItemPtr( hb_stackSelfItem(), pIndex, HB_HASH_AUTOADD_ACCESS ); + hb_stackPop(); + if( pValue ) + { + hb_itemReturn( pValue ); + return; + } + } + + if( szMessage[0] == '_' ) + hb_errRT_BASE_SubstR( EG_NOVARMETHOD, 1005, NULL, szMessage + 1, HB_ERR_ARGS_SELFPARAMS ); + else + hb_errRT_BASE_SubstR( EG_NOMETHOD, 1004, NULL, szMessage, HB_ERR_ARGS_SELFPARAMS ); +} + +HB_FUNC( XHB_INCLUDE ) +{ + PHB_ITEM pSelf = hb_stackSelfItem(); + PHB_ITEM pKey = hb_param( 1, HB_IT_ANY ); + + if( HB_IS_ARRAY( pSelf ) ) + { + hb_retl( hb_arrayScan( pSelf, pKey, NULL, NULL, TRUE ) != 0 ); + } + else if( HB_IS_HASH( pSelf ) && ( HB_IS_HASHKEY( pKey ) || hb_hashLen( pKey ) == 1 ) ) + { + hb_retl( hb_hashScan( pSelf, pKey, NULL ) ); + } + else + { + PHB_ITEM pResult = hb_errRT_BASE_Subst( EG_ARG, 1109, NULL, "$", 2, pKey, pSelf ); + if( pResult ) + hb_itemReturnRelease( pResult ); + } +} + +#undef HB_IS_VALID_INDEX +#define HB_IS_VALID_INDEX( idx, max ) ( ( ( LONG ) (idx) < 0 ? (idx) += (max) + 1 : (idx) ) > 0 && ( ULONG ) (idx) <= (max) ) + +HB_FUNC( XHB_INDEX ) +{ + PHB_ITEM pSelf = hb_stackSelfItem(); + PHB_ITEM pIndex = hb_param( 1, HB_IT_ANY ); + + if( hb_pcount() == 2 ) + { /* ASSIGN */ + PHB_ITEM pValue = hb_param( 2, HB_IT_ANY ); + if( HB_IS_NUMERIC( pIndex ) ) + { + ULONG ulIndex = hb_itemGetNL( pIndex ); + if( HB_IS_ARRAY( pSelf ) ) + { + ULONG ulLen = hb_arrayLen( pSelf ); + if( HB_IS_VALID_INDEX( ulIndex, ulLen ) ) + { + hb_itemMoveRef( hb_arrayGetItemPtr( pSelf, ulIndex ), pValue ); + } + else + hb_errRT_BASE( EG_BOUND, 1133, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ), 1, pIndex ); + } + else if( HB_IS_STRING( pSelf ) ) + { + ULONG ulLen = hb_itemGetCLen( pSelf ); + if( HB_IS_VALID_INDEX( ulIndex, ulLen ) ) + { + char cValue = HB_IS_STRING( pValue ) ? hb_itemGetCPtr( pValue )[0] : + hb_itemGetNI( pValue ); + if( ulLen == 1 ) + hb_itemPutCL( pSelf, &cValue, 1 ); + else + { + hb_itemUnShareString( pSelf ); + hb_itemGetCPtr( pSelf )[ ulIndex - 1 ] = cValue; + } + } + else + hb_errRT_BASE( EG_BOUND, 1133, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ), 1, pIndex ); + } + else + hb_errRT_BASE( EG_ARG, 1069, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ), 1, pIndex ); + } + else + { + hb_errRT_BASE( EG_ARG, 1069, NULL, hb_langDGetErrorDesc( EG_ARRASSIGN ), 1, pIndex ); + } + hb_itemReturn( pSelf ); + } + else + { /* ACCESS */ + if( HB_IS_NUMERIC( pIndex ) ) + { + ULONG ulIndex = hb_itemGetNL( pIndex ); + if( HB_IS_ARRAY( pSelf ) ) + { + ULONG ulLen = hb_arrayLen( pSelf ); + if( HB_IS_VALID_INDEX( ulIndex, ulLen ) ) + hb_itemReturn( hb_arrayGetItemPtr( pSelf, ulIndex ) ); + else + hb_errRT_BASE( EG_BOUND, 1132, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ), 2, pSelf, pIndex ); + } + else if( HB_IS_STRING( pSelf ) ) + { + ULONG ulLen = hb_itemGetCLen( pSelf ); + if( HB_IS_VALID_INDEX( ulIndex, ulLen ) ) + hb_retclen( hb_itemGetCPtr( pSelf ) + ulIndex - 1, 1 ); + else + hb_errRT_BASE( EG_BOUND, 1132, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ), 2, pSelf, pIndex ); + } + else + hb_errRT_BASE( EG_ARG, 1068, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ), 2, pSelf, pIndex ); + } + else + { + PHB_ITEM pResult = hb_errRT_BASE_Subst( EG_ARG, 1068, NULL, hb_langDGetErrorDesc( EG_ARRACCESS ), 2, pSelf, pIndex ); + if( pResult ) + hb_itemReturnRelease( pResult ); + } + } +} diff --git a/harbour/include/hbapicls.h b/harbour/include/hbapicls.h index a597c81038..b35a6efde6 100644 --- a/harbour/include/hbapicls.h +++ b/harbour/include/hbapicls.h @@ -76,18 +76,19 @@ HB_EXTERN_BEGIN #define HB_OO_OP_GREATEREQUAL 14 #define HB_OO_OP_ASSIGN 15 #define HB_OO_OP_INSTRING 16 -#define HB_OO_OP_NOT 17 -#define HB_OO_OP_AND 18 -#define HB_OO_OP_OR 19 -#define HB_OO_OP_ARRAYINDEX 20 -#define HB_OO_OP_ENUMINDEX 21 -#define HB_OO_OP_ENUMBASE 22 -#define HB_OO_OP_ENUMVALUE 23 -#define HB_OO_OP_ENUMSTART 24 -#define HB_OO_OP_ENUMSKIP 25 -#define HB_OO_OP_ENUMSTOP 26 +#define HB_OO_OP_INCLUDE 17 +#define HB_OO_OP_NOT 18 +#define HB_OO_OP_AND 19 +#define HB_OO_OP_OR 20 +#define HB_OO_OP_ARRAYINDEX 21 +#define HB_OO_OP_ENUMINDEX 22 +#define HB_OO_OP_ENUMBASE 23 +#define HB_OO_OP_ENUMVALUE 24 +#define HB_OO_OP_ENUMSTART 25 +#define HB_OO_OP_ENUMSKIP 26 +#define HB_OO_OP_ENUMSTOP 27 -#define HB_OO_MAX_OPERATOR 26 +#define HB_OO_MAX_OPERATOR 27 extern void hb_clsInit( void ); /* initialize Classy/OO system at HVM startup */ extern void hb_clsDoInit( void ); /* initialize Classy/OO system .prg functions */ diff --git a/harbour/include/hbclass.ch b/harbour/include/hbclass.ch index 3c348c769a..6d56f961c8 100644 --- a/harbour/include/hbclass.ch +++ b/harbour/include/hbclass.ch @@ -318,6 +318,8 @@ DECLARE HBClass ; _HB_MEMBER __HB_CLS_ASFUNC();; __HB_CLS_DECLARE_METHOD __HB_CLS_PARAMS() _CLASS_NAME_ ;; s_oClass:SetOnError( @__HB_CLS_ASID( __HB_CLS_MTHNAME _CLASS_NAME_ )() ) +#xcommand ON ERROR FUNCTION => ; + s_oClass:SetOnError( @__HB_CLS_ASID( )() ) /* Friend function/class definitions */ #xcommand FRIEND CLASS [, ] => ; @@ -335,6 +337,9 @@ DECLARE HBClass ; __HB_CLS_DECLARE_METHOD __HB_CLS_PARAMS() _CLASS_NAME_ ;; s_oClass:AddMethod( <(op)>, @__HB_CLS_ASID( __HB_CLS_MTHNAME _CLASS_NAME_ )(), __HB_CLS_SCOPE( <.export.>, <.protect.>, <.hidde.> ) ) +#xcommand OPERATOR FUNCTION [ ] [] [