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

20000522-06:15 GMT-8 Ron Pinkas <Ron@Profit-Master.com>

Browse Source 
* source/compiler/harbour.l
     + Added "as structure", "as stru", "as array of structure", "as array of stru"

   * source/compiler/hbpcode.c
     * Improved some logic in hb_StrongType()

   * source/vm/hvm.c
     ! Corrected startup symbol when having to use Main() as per Ryszard.

   * source/pp/pptable.c
     + Added the equivalent of:
        #COMMANDS STRUCTURE <StruName> <Var1> AS <Type1> [, <VarN> AS <TypeN> ] => ;
                  STATIC __<StruName> := {|| IF( __<StruName> == NIL, , ) , HB_Structure( <"StruName">, { <"Var1"> [, <"VarN">] } )} ;;
                  DECLARE <StruName> <Var1> AS <Type1> [ <VarN> AS <TypeN> ] ;;
                  #TRANSLATE AS NEW <ClassName> => AS CLASS <StruName> := ( Eval( __<StruName> ), HB_Structure( <StruName> ) )

	#TRANSLATE AS NEW <ClassName> => AS CLASS <ClassName> := <ClassName>():New()

   * source/rtl/tclass.prg
     + Added Function HB_Structure() ( Fully Declared! ) This function is used internally, but may be freely called from Clipper level.
       It Aceepts Parameter 1 Structure Name, and optional parameter 2, as array of structure variable names.
       If called with 2nd parameter, returns NIL (just creates the new Structure), if called with just parameter 1, it returns
       new instance of defined structure.

   + tests\teststru.prg
     + Added demo for new structure syntax
This commit is contained in:
Ron Pinkas
2000-05-22 13:53:14 +00:00
parent 82c9bb8579
commit eb2d8afdb4
8 changed files with 139 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
harbour/ChangeLog
View File

@@ -1,3 +1,32 @@
20000522-06:15 GMT-8 Ron Pinkas <Ron@Profit-Master.com>
* source/compiler/harbour.l
+ Added "as structure", "as stru", "as array of structure", "as array of stru"
* source/compiler/hbpcode.c
* Improved some logic in hb_StrongType()
* source/vm/hvm.c
! Corrected startup symbol when having to use Main() as per Ryszard.
* source/pp/pptable.c
+ Added the equivalent of:
#COMMANDS STRUCTURE <StruName> <Var1> AS <Type1> [, <VarN> AS <TypeN> ] => ;
STATIC __<StruName> := {|| IF( __<StruName> == NIL, , ) , HB_Structure( <"StruName">, { <"Var1"> [, <"VarN">] } )} ;;
DECLARE <StruName> <Var1> AS <Type1> [ <VarN> AS <TypeN> ] ;;
#TRANSLATE AS NEW <ClassName> => AS CLASS <StruName> := ( Eval( __<StruName> ), HB_Structure( <StruName> ) )
#TRANSLATE AS NEW <ClassName> => AS CLASS <ClassName> := <ClassName>():New()
* source/rtl/tclass.prg
+ Added Function HB_Structure() ( Fully Declared! ) This function is used internally, but may be freely called from Clipper level.
It Aceepts Parameter 1 Structure Name, and optional parameter 2, as array of structure variable names.
If called with 2nd parameter, returns NIL (just creates the new Structure), if called with just parameter 1, it returns
new instance of defined structure.
+ tests\teststru.prg
+ Added demo for new structure syntax
20000522-01:51 DST Paul Tucker <ptucker@sympatico.ca>
* include/hbcomp.h
* adjust declaration of COMCLASS and COMDECLARE

4
harbour/source/compiler/harbour.l
View File

@@ -1439,6 +1439,8 @@ Separator {SpaceTab}
"as character" { return AS_CHARACTER; }
"as string" { return AS_CHARACTER; }
"as class" { return AS_CLASS; }
"as stru" { return AS_CLASS; }
"as structure" { return AS_CLASS; }
"as date" { return AS_DATE; }
"as logical" { return AS_LOGICAL; }
"as bool" { return AS_LOGICAL; }
@@ -1458,6 +1460,8 @@ Separator {SpaceTab}
"as array of character" { return AS_CHARACTER_ARRAY; }
"as array of string" { return AS_CHARACTER_ARRAY; }
"as array of class" { return AS_CLASS_ARRAY; }
"as array of stru" { return AS_CLASS_ARRAY; }
"as array of structure" { return AS_CLASS_ARRAY; }
"as array of date" { return AS_DATE_ARRAY; }
"as array of logical" { return AS_LOGICAL_ARRAY; }
"as array of bool" { return AS_LOGICAL_ARRAY; }

27
harbour/source/compiler/hbpcode.c
View File

@@ -444,7 +444,10 @@ void hb_compStrongType( int iSize )
/*printf( "\nMethod: %s of Class: %s Parameters: %i\n", pSym->szName, pFunc->pStackClasses[ pFunc->iStackClasses - 1 ]->szName, pFunc->pStackFunctions[ pFunc->iStackFunctions - 1 ]->iParamCount );*/
if ( pFunc->pStackFunctions[ pFunc->iStackFunctions - 1 ] == NULL )
hb_compGenWarning( hb_comp_szWarnings, 'W', HB_COMP_WARN_MESSAGE_NOT_FOUND, pSym->szName, pFunc->pStackClasses[ pFunc->iStackClasses - 1 ]->szName );
if ( pSym->szName[0] == '_' )
hb_compGenWarning( hb_comp_szWarnings, 'W', HB_COMP_WARN_MESSAGE_NOT_FOUND, &( pSym->szName[1] ), pFunc->pStackClasses[ pFunc->iStackClasses - 1 ]->szName );
else
hb_compGenWarning( hb_comp_szWarnings, 'W', HB_COMP_WARN_MESSAGE_NOT_FOUND, pSym->szName, pFunc->pStackClasses[ pFunc->iStackClasses - 1 ]->szName );
}
else
{
@@ -1250,9 +1253,14 @@ void hb_compStrongType( int iSize )
pVar = hb_compVariableFind( pTmp->pStatics, wVar - pTmp->iStaticsBase );
/* Will be pushed shortly. */
pFunc->iStackIndex++;
if ( pVar )
{
/*printf( "\nStatic: %s Function: %s Found in: %s\n", pVar->szName, pFunc->szName, pTmp->szName );*/
/*
printf( "\nStatic: %s Type: %c Function: %s Found in: %s\n", pVar->szName, pVar->cType, pFunc->szName, pTmp->szName );
*/
/* Only if "private" static, since global static may be intialized elsewhere. */
/* May have been initialized in previous execution of the function.
@@ -1264,23 +1272,22 @@ void hb_compStrongType( int iSize )
/* Mark as used */
pVar->iUsed |= VU_USED;
if ( pVar->cType == 'S' && pFunc->iStackClasses < 8 )
if ( toupper( pVar->cType ) == 'S' && pFunc->iStackClasses < 8 )
{
/* Object of declared class */
pFunc->pStackClasses[ pFunc->iStackClasses++ ] = pVar->pClass;
pFunc->pStack[ pFunc->iStackIndex++ ] = 'S';
}
if ( pFunc->pCode[ ulPos ] == HB_P_PUSHSTATICREF )
pFunc->pStack[ pFunc->iStackIndex++ ] = pVar->cType + VT_OFFSET_BYREF;
pFunc->pStack[ pFunc->iStackIndex - 1 ] = pVar->cType + VT_OFFSET_BYREF;
else
pFunc->pStack[ pFunc->iStackIndex++ ] = pVar->cType;
pFunc->pStack[ pFunc->iStackIndex - 1 ] = pVar->cType;
}
else
if ( pFunc->pCode[ ulPos ] == HB_P_PUSHSTATICREF )
pFunc->pStack[ pFunc->iStackIndex++ ] = '@';
pFunc->pStack[ pFunc->iStackIndex - 1 ] = '@';
else
pFunc->pStack[ pFunc->iStackIndex++ ] = ' ';
pFunc->pStack[ pFunc->iStackIndex - 1 ] = ' ';
break;
@@ -1439,6 +1446,10 @@ void hb_compStrongType( int iSize )
{
BYTE cVarType = pFunc->pStack[ pFunc->iStackIndex - 1 ];
/*
printf( "\n Base Type: %c\n", cVarType );
*/
if ( cVarType >= ( 'A' + VT_OFFSET_VARIANT ) )
cVarType -= VT_OFFSET_VARIANT;

7
harbour/source/pp/pptable.c
View File

@@ -389,6 +389,9 @@ static COMMANDS sC___236 = {0,"SET","INDEX TO [ \1A40 [, \1B40]] [\1C20 ADDITIVE
static COMMANDS sC___237 = {0,"SET","ORDER TO \1A00 [IN \1B40]","ordSetFocus( \1A00 [, \1B30] )",&sC___236 };
static COMMANDS sC___238 = {0,"SET","ORDER TO TAG \1A40 [IN \1B40]","ordSetFocus( \1A30 [, \1B30] )",&sC___237 };
static COMMANDS sC___239 = {0,"SET","ORDER TO","ordSetFocus(0)",&sC___238 };
static COMMANDS sC___240 = {0,"STRUCTURE","\1A00 \1B00 AS \1C00 [, \1D00 AS \1E00 ]","STATIC __\1A00 := {|| IF(__\1A00 == NIL, , ) ,hb_structure( \1A20, { \1B20 [, \1D20] } )} ; DECLARE \1A00 \1B00 AS \1C00 [ \1D00 AS \1E00] ; #translate AS NEW \1A00 => AS CLASS \1A00 := ( Eval(__\1A00), hb_Structure( \1A20 ) )",&sC___239 };
COMMANDS * hb_pp_topCommand = &sC___239;
COMMANDS * hb_pp_topTranslate = NULL;
static COMMANDS sT___1 = {0,"AS","NEW \1A00","AS CLASS \1A00 := \1A00():New()",NULL };
COMMANDS * hb_pp_topCommand = &sC___240;
COMMANDS * hb_pp_topTranslate = &sT___1;

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

@@ -41,6 +41,10 @@
* Support for inheritance
* Support for default DATA values
*
* Copyright 2000 Ron Pinkas <Ron@Profit-Master.com>
*
* HB_Structure()
*
* See doc/license.txt for licensing terms.
*
*/
@@ -286,3 +290,66 @@ STATIC FUNCTION SetType( cType )
RETURN NIL
//----------------------------------------------------------------------------//
Function HB_Structure( cStructureName AS Char, aMembers AS Array OF Char )
STRUCTURE HB_Structure cName AS Char, hId As Num
DECLARE __ClsNew( ClassName AS Char, N As Num ) AS Num
DECLARE __ClsAddMsg( H AS Num, Data AS Char, Type As Num, ID As Num ) AS Num
DECLARE __ClsInst( H AS Num ) AS Structure HB_Structure
LOCAL hStructure AS Num, nCounter AS Num, nMembers AS Num
STATIC asStructures AS Array OF Structure HB_Structure := {}
STATIC sStructure AS Stru HB_Structure
LOCAL hSelf As Num
cStructureName := Upper( cStructureName )
hStructure := aScan( asStructures, { |aStructure| aStructure:cName == cStructureName } )
IF aMembers == NIL
IF hStructure == 0
//hb_Structure( cStructureName, {} )
RETURN NIL //hb_Structure( cStructureName )
ELSE
RETURN __ClsInst( asStructures[ hStructure ]:hId )
ENDIF
ELSE
IF hStructure > 0
// Duplicate declaration
RETURN NIL
ENDIF
ENDIF
nMembers := Len( aMembers )
hStructure := __ClsNew( cStructureName, nMembers )
FOR nCounter := 1 TO nMembers
__clsAddMsg( hStructure, aMembers[nCounter], nCounter, 1 )
__clsAddMsg( hStructure, '_' + aMembers[nCounter], nCounter, 1 )
NEXT
IF sStructure == NIL
hSelf := __ClsNew( "HB_Structure", 2 )
__clsAddMsg( hSelf, "cName", 1, 1 )
__clsAddMsg( hSelf, "_cName", 1, 1 )
__clsAddMsg( hSelf, "hID", 2, 1 )
__clsAddMsg( hSelf, "_hID", 2, 1 )
sStructure := __ClsInst( hSelf )
ENDIF
sStructure:cName := cStructureName
sStructure:hId := hStructure
aAdd( asStructures, sStructure )
RETURN NIL //__clsInst( hStructure )
//----------------------------------------------------------------------------//

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

@@ -4070,7 +4070,7 @@ void hb_vmProcessSymbols( PHB_SYMB pModuleSymbols, USHORT uiModuleSymbols ) /* m
if( ( ! s_pSymStart ) && ( hSymScope & HB_FS_FIRST ) )
s_pSymStart = pModuleSymbols + ui; /* first public defined symbol to start execution */
if( ( hSymScope == HB_FS_PUBLIC ) || ( hSymScope & ( HB_FS_MESSAGE | HB_FS_MEMVAR ) ) )
if( ( hSymScope == HB_FS_PUBLIC ) || ( hSymScope & ( HB_FS_MESSAGE | HB_FS_MEMVAR | HB_FS_FIRST ) ) )
hb_dynsymNew( pModuleSymbols + ui );
}
}

14
harbour/tests/teststru.prg Normal file
View File

@@ -0,0 +1,14 @@
STRUCTURE MyStruct Var1 As Char, Var2 As Num
PROCEDURE MAIN()
LOCAL sTest AS New MyStruct
sTest:Var1 := 8 // Warning Here as Expected.
sTest:NoSuchVar := "Error" // Warning here as expected.
sTest:Var1 := 'Working' // No problem here.
? sTest:Var1 // Np Problem here.
RETURN

1
harbour/tests/testwarn.prg
View File

@@ -6,7 +6,6 @@
#ifdef __HARBOUR__
#pragma -es0
#else
#TRANSLATE AS ARRAY [OF <type>] =>
#TRANSLATE AS CHAR =>