From 9d457f6e483488780b845cb675e49e7ca72d6578 Mon Sep 17 00:00:00 2001 From: Antonio Linares Date: Tue, 4 May 1999 22:24:43 +0000 Subject: [PATCH] Initial revision --- harbour/source/compiler/harbour.l | 368 ++++ harbour/source/compiler/harbour.y | 2948 +++++++++++++++++++++++++++++ harbour/source/rtl/arrays.c | 473 +++++ harbour/source/rtl/classes.c | 411 ++++ harbour/source/rtl/codebloc.c | 176 ++ harbour/source/rtl/console.c | 112 ++ harbour/source/rtl/dates.c | 360 ++++ harbour/source/rtl/environ.c | 32 + harbour/source/rtl/error.prg | 33 + harbour/source/rtl/errorapi.c | 39 + harbour/source/rtl/errorsys.prg | 39 + harbour/source/rtl/extend.c | 619 ++++++ harbour/source/rtl/files.c | 337 ++++ harbour/source/rtl/itemapi.c | 360 ++++ harbour/source/rtl/math.c | 278 +++ harbour/source/rtl/mathx.c | 135 ++ harbour/source/rtl/set.c | 295 +++ harbour/source/rtl/strcmp.c | 41 + harbour/source/rtl/strings.c | 1067 +++++++++++ harbour/source/rtl/tclass.prg | 157 ++ harbour/source/rtl/transfrm.c | 670 +++++++ harbour/source/vm/dynsym.c | 230 +++ harbour/source/vm/hvm.c | 1992 +++++++++++++++++++ 23 files changed, 11172 insertions(+) create mode 100644 harbour/source/compiler/harbour.l create mode 100644 harbour/source/compiler/harbour.y create mode 100644 harbour/source/rtl/arrays.c create mode 100644 harbour/source/rtl/classes.c create mode 100644 harbour/source/rtl/codebloc.c create mode 100644 harbour/source/rtl/console.c create mode 100644 harbour/source/rtl/dates.c create mode 100644 harbour/source/rtl/environ.c create mode 100644 harbour/source/rtl/error.prg create mode 100644 harbour/source/rtl/errorapi.c create mode 100644 harbour/source/rtl/errorsys.prg create mode 100644 harbour/source/rtl/extend.c create mode 100644 harbour/source/rtl/files.c create mode 100644 harbour/source/rtl/itemapi.c create mode 100644 harbour/source/rtl/math.c create mode 100644 harbour/source/rtl/mathx.c create mode 100644 harbour/source/rtl/set.c create mode 100644 harbour/source/rtl/strcmp.c create mode 100644 harbour/source/rtl/strings.c create mode 100644 harbour/source/rtl/tclass.prg create mode 100644 harbour/source/rtl/transfrm.c create mode 100644 harbour/source/vm/dynsym.c create mode 100644 harbour/source/vm/hvm.c diff --git a/harbour/source/compiler/harbour.l b/harbour/source/compiler/harbour.l new file mode 100644 index 0000000000..165a30e5d6 --- /dev/null +++ b/harbour/source/compiler/harbour.l @@ -0,0 +1,368 @@ +%{ + +/* + Harbour lex rules. + Build 21: Spring 99 + Usage: flex -i -oyylex.c harbour.l + You may find flex.exe at www.harbour-project.org +*/ + +#include +#include +#include +#include +#include "y_tab.h" + +void yyerror( char * ); +void yyunput( int, char * ); +#undef yywrap /* to implement our own yywrap() funtion to handle EOFs */ +int yywrap( void ); +#undef YY_INPUT /* to implement our own YY_INPUT function to manage PRGs without \n at the end */ +extern FILE * yyin; /* currently yacc parsed file */ +int yy_lex_input( char *, int ); +#define YY_INPUT( buf, result, max_size ) result = yy_lex_input( buf, max_size ); +void GenError( int, char*, char * ); /* generic parsing error management function */ + +#define ERR_NUMERIC_FORMAT 6 +#define ERR_STRING_TERMINATOR 7 + +typedef struct +{ + char * szDefine; + char * szValue; + void * pKeys; + void * pNext; +} _DEFINE, * PDEFINE; + +PDEFINE LastDef( PDEFINE pDef ); /* searches for the latest #define */ +void Define( char * szDefine ); /* add a new #define symbol */ +void DefineKey( char * szKey ); /* add a new key to a #define expression */ +void AddDefine( char * szDefine, char * szValue ); /* add a new define from the command line */ +PDEFINE FindDef( char * szText ); /* finds a #define */ + +extern int _iQuiet; +extern int _iRestrictSymbolLength; + +PDEFINE pDefs = 0; /* support for #defines */ +int iLine = 1; +long lNumber = 0; + +%} + +SpaceTab [ \t]+ +InvalidNumber [0-9]+\. +Number ([0-9]+)|([0-9]*\.[0-9]+) +HexNumber 0x[0-9A-F]+ +Identifier (([a-zA-Z])|([_a-zA-Z][_a-zA-Z0-9]+)) +String (\"(([^\"]*)|([\!]*))\")|(\'(([^\']*)|([\!]*))\') +PseudoFunc {Identifier}"("+.*")"+ + +%x COMMENT3 DEFINE DEFINE_PARAMS DEFINE_EXPR +%x IFDEF IFNDEF STRING1 STRING2 + +%% + +("//".*)|("&&".*) ; + +^{SpaceTab}*(\*|"NOTE").* ; +\n{SpaceTab}*(\*|"NOTE").* ++iLine; if( ! _iQuiet ) printf( "\rline: %i", iLine ); + +' BEGIN STRING1; +\" BEGIN STRING2; + +[^'^\n]* GenError( ERR_STRING_TERMINATOR, yytext, NULL ); BEGIN 0; +[^\"^\n]* GenError( ERR_STRING_TERMINATOR, yytext, NULL ); BEGIN 0; + +[^']*' { BEGIN 0; yylval.string = strdup( yytext + 1 ); + yylval.string[ yyleng - 2 ] = 0; return LITERAL; } +[^\"]*\" { BEGIN 0; yylval.string = strdup( yytext + 1 ); + yylval.string[ yyleng - 2 ] = 0; return LITERAL; } + +"/*" BEGIN COMMENT3; +"*/" BEGIN 0; +[^"*/"\n]* ; +[\/\"]+ ; +\n ++iLine; if( ! _iQuiet ) printf( "\rline: %i", iLine ); + +"#"{SpaceTab}*"define" BEGIN DEFINE; +{Identifier}/{SpaceTab}+ Define( yytext ); +{Identifier}/{SpaceTab}*\n Define( yytext ); BEGIN 0; +{SpaceTab} ; +{Identifier} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0; +{PseudoFunc} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0; +{String} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0; +-?{Number} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0; +{HexNumber} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0; +"/*".*"*/" ; +{Number}{SpaceTab}*[\(] yyerror( "Syntax error in #define" ); +{String}{SpaceTab}*[\(] yyerror( "Syntax error in #define" ); +{Identifier}{SpaceTab}*[\(] Define( yytext ); BEGIN DEFINE_PARAMS; +{SpaceTab} ; +{Identifier} DefineKey( yytext ); +[\,] ; +[\)] BEGIN DEFINE_EXPR; +.*/\n LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0; + +"#"{SpaceTab}*"ifdef" BEGIN IFDEF; +{Identifier} if( FindDef( yytext ) ) BEGIN 0; +"#"{SpaceTab}*"else"\n ++iLine; BEGIN 0; +"#"{SpaceTab}*"endif"\n ++iLine; BEGIN 0; +\n ++iLine; +[\(\),\"\/\.]* ; +"#"{SpaceTab}*"ifdef" ; +"#"{SpaceTab}*"else" BEGIN 0; +"#"{SpaceTab}*"else" BEGIN IFDEF; +"#"{SpaceTab}*"endif" BEGIN 0; + +"#"{SpaceTab}*"ifndef" BEGIN IFNDEF; +{Identifier} if( ! FindDef( yytext ) ) BEGIN 0; +"#endif"\n ++iLine; BEGIN 0; +\n ++iLine; + +"#"{SpaceTab}*"line".* ; + +{SpaceTab} ; + +\n.* yyless( 1 ); ++iLine; if( ! _iQuiet ) printf( "\rline: %i", iLine ); return '\n'; +;\n ++iLine; if( ! _iQuiet ) printf( "\rline: %i", iLine ); + +"begin" return BEGINSEQ; +"break" return BREAK; +"case" return CASE; +"do" return DO; +"do"{SpaceTab}+"case" return DOCASE; +("do"{SpaceTab}+"while")|"while" return WHILE; +"else" return ELSE; +"elseif" return ELSEIF; +"end"/[^(] return END; +"endif" return ENDIF; +"endcase" return ENDCASE; +"enddo" return ENDDO; +"exit"/[\n\;] return EXITLOOP; +"exit" return EXIT; +"extern"|"external" return EXTERN; +"field"/[^(] return FIELD; +"for" return FOR; +"func"|"funct"|"functi"|"functio"|"function"/[^(] return FUNCTION; +("if"|"iif"){SpaceTab}*/[(] return IF; +"if" return IF; +"in" return IN; +"include" return INCLUDE; +"init" return INIT; +"local" return LOCAL; +"loop" return LOOP; +"memvar" return MEMVAR; +"next" return NEXT; +"nil" return NIL; +"otherwise" return OTHERWISE; +"parameters" return PARAMETERS; +"private" return PRIVATE; +"proc"|"procedure" return PROCEDURE; +"public" return PUBLIC; +"qself"{SpaceTab}*[(]{SpaceTab}*[)] return SELF; +"recover" return RECOVER; +"retu"|"retur"|"return" return RETURN; +"sequence" return SEQUENCE; +"static" return STATIC; +"step"/[^(] return STEP; +"to" return TO; +"using" return USING; +"with" return WITH; +"#" return NE1; +"<>"|"!=" return NE2; +":=" return INASSIGN; +"==" return EQ; +"++" return INC; +"--" return DEC; +"->" return ALIAS; +"<=" return LE; +">=" return GE; +"+=" return PLUSEQ; +"-=" return MINUSEQ; +"*=" return MULTEQ; +"/=" return DIVEQ; +"^=" return EXPEQ; +"%=" return MODEQ; +"**"|"^" return POWER; +"."[t|y]"." return TRUE; +"."[f|n]"." return FALSE; +".and." return AND; +".or." return OR; +"!"|".not." return NOT; +"::" unput( ':' ); unput( 'f' ); unput( 'l' ); unput( 'e' ); unput( 'S' ); +[,\;+\-\*\/\{\}\|\#\&\:\<\>\=\[\]\$\%\(\)\@] return yytext[ 0 ]; + +{InvalidNumber} GenError( ERR_NUMERIC_FORMAT, NULL, NULL ); + +{Number} { yylval.dNumber = atof( yytext ); + if( strchr( yytext, '.' ) ) + return DOUBLE; + else + { + if( ( double )SHRT_MIN <= yylval.dNumber && + yylval.dNumber <= ( double )SHRT_MAX ) + { + yylval.iNumber = ( int ) yylval.dNumber; + return INTEGER; + } + else if( ( double )LONG_MIN <= yylval.dNumber && + yylval.dNumber <= ( double )LONG_MAX ) + { + yylval.lNumber = ( long ) yylval.dNumber; + return INTLONG; + } + else + return DOUBLE; + } + } + +{HexNumber} { sscanf( yytext, "%lxI", &lNumber ); + + if( ( double )SHRT_MIN <= lNumber && + lNumber <= ( double )SHRT_MAX ) + { + yylval.iNumber = lNumber; + return INTEGER; + } + else if( ( double )LONG_MIN <= lNumber && + lNumber <= ( double )LONG_MAX ) + { + yylval.lNumber = lNumber; + return INTLONG; + } + else + { + yylval.dNumber = lNumber; + return DOUBLE; + } + } + +{String} yylval.string = strdup( yytext + 1 ); yylval.string[ yyleng - 2 ] = 0; return LITERAL; + +{Identifier} { + PDEFINE pDef = FindDef( yytext ); + char * szText; int c; + + if( pDef ) + { + c = strlen( pDef->szValue ) - 1; + szText = pDef->szValue; + while( c >= 0 ) + unput( szText[ c-- ] ); + } + else + { + if( _iRestrictSymbolLength && strlen( yytext ) > 10 ) + { + yytext[ 10 ] = 0; + yyleng = 10; + } + yylval.string = strupr( strdup( yytext ) ); + return IDENTIFIER; + } + } + +%% + +PDEFINE LastDef( PDEFINE pDef ) +{ + while( pDef->pNext ) + pDef = pDef->pNext; + + return pDef; +} + +void Define( char * szDefine ) +{ + PDEFINE pDef = ( PDEFINE ) malloc( sizeof( _DEFINE ) ); + + if( ! pDefs ) + pDefs = pDef; + else + LastDef( pDefs )->pNext = pDef; + + pDef->szDefine = strdup( szDefine ); + pDef->szValue = 0; + pDef->pKeys = 0; + pDef->pNext = 0; +} + +void DefineKey( char * szKey ) +{ + PDEFINE pDef = ( PDEFINE ) malloc( sizeof( _DEFINE ) ); + PDEFINE pLast = LastDef( pDefs ); + + if( pLast->pKeys ) + LastDef( pLast->pKeys )->pNext = pDef; + else + pLast->pKeys = pDef; + + pDef->szDefine = strdup( szKey ); + pDef->szValue = 0; + pDef->pKeys = 0; + pDef->pNext = 0; +} + +PDEFINE FindDef( char * szText ) +{ + PDEFINE pDef = pDefs; + + while( pDef ) + { + if( ! strcmp( pDef->szDefine, szText ) ) + return pDef; + else + { + if( pDef->pNext ) + pDef = pDef->pNext; + else + return 0; + } + } + return 0; +} + +void AddDefine( char * szId, char * szValue ) /* adds a new define from command line */ +{ + PDEFINE pDefine = FindDef( szId ); /* just incase there are several repited defines */ + + if( pDefine ) + { + if( pDefine->szValue ) + { + free( pDefine->szValue ); + pDefine->szValue = 0; + } + if( szValue ) + pDefine->szValue = strdup( szValue ); + } + else + { + Define( szId ); + if( szValue ) + LastDef( pDefs )->szValue = strdup( szValue ); + } +} + +int yy_lex_input( char *buffer, int iBufferSize ) +{ + int i; + static int _ineedLF = 1; /* we want LF as the last character */ + + if( ((i = fread(buffer, 1, iBufferSize, yyin)) == 0) && ferror(yyin) ) + YY_FATAL_ERROR( "input in flex scanner failed" ); + + if( i == iBufferSize ) + _ineedLF =( buffer[i-1] != '\n' ); /* check if last character is LF */ + /* in case it is the last block */ + else if( i < iBufferSize && _ineedLF ) + { + if( i == 0 ) + buffer[ i++ ] ='\n'; + else if( buffer[ i-1 ] != '\n' ) + buffer[ i++ ] ='\n'; + _ineedLF =0; /* OK - no more LF */ + } + return i; +} + diff --git a/harbour/source/compiler/harbour.y b/harbour/source/compiler/harbour.y new file mode 100644 index 0000000000..028d2cbf90 --- /dev/null +++ b/harbour/source/compiler/harbour.y @@ -0,0 +1,2948 @@ +%{ + +/* + Harbour compiler (yacc rules and actions) + Build 21 proposal: spring 1999 + Usage: bison -d -v harbour.y You may find Bison at www.harbour.project.org +*/ + +#define BUILD 21 /* current harbour.y build */ + +#include +#include +#include +#include +#include /* required for allocating and freeing memory */ +#include "pcode.h" /* pcode values */ +#include "types.h" /* our defined types */ + +#ifdef __BORLANDC__ + #define HAVE_STRUPR +#endif + +#ifndef HAVE_STRUPR + #include + char *strupr( char *p ); +#endif + +/* TODO: #define this for various platforms */ +#define PATH_DELIMITER "/\\" +#define IS_PATH_SEP( c ) (strchr(PATH_DELIMITER, (c))!=NULL) + +extern FILE * yyin; /* currently yacc parsed file */ +extern int iLine; /* currently parsed file line number */ +FILE * yyc; /* file handle for C output */ + +typedef struct /* #include support */ +{ + FILE * handle; /* handle of the opened file */ + void * pBuffer; /* buffer used by yacc */ + char * szFileName; /* name of the file */ + void * pPrev; /* pointer to the previous opened file */ + void * pNext; /* pointer to the next opened file */ + int iLine; /* currently processed line number */ +} _FILE, * PFILE; /* structure to hold an opened PRG or CH */ + +typedef struct +{ + PFILE pLast; /* pointer to the last opened file */ + int iFiles; /* number of files currently opened */ +} FILES; /* structure to control several opened PRGs and CHs */ + +int Include( char * szFileName ); /* end #include support */ + +typedef struct _VAR /* locals, static, public variables support */ +{ + char *szName; /* variable name */ + char *szAlias; /* variable alias namespace */ + struct _VAR * pNext; /* pointer to next defined variable */ +} VAR, * PVAR; + +typedef struct __FUNC /* functions definition support */ +{ + char * szName; /* name of a defined Clipper function */ + char cScope; /* scope of a defined Clipper function */ + BYTE bFlags; /* some flags we may need */ + WORD wParamCount; /* number of declared parameters */ + PVAR pLocals; /* pointer to local variables list */ + PVAR pStatics; /* pointer to static variables list */ + PVAR pFields; /* pointer to fields variables list */ + BYTE * pCode; /* pointer to a memory block where pcode is stored */ + LONG lPCodeSize; /* total memory size for pcode */ + LONG lPCodePos; /* actual pcode offset */ + WORD wStaticsBase; /* base for this function statics */ + struct __FUNC * pOwner; /* pointer to the function/procedure that owns the codeblock */ + struct __FUNC * pNext; /* pointer to the next defined function */ +} _FUNC, * PFUNCTION; /* structure to hold a Clipper defined function */ + +/* + * flags for bFlags member +*/ +#define FUN_STATEMENTS 1 /* Function have at least one executable statement */ + +typedef struct +{ + PFUNCTION pFirst; /* pointer to the first defined funtion */ + PFUNCTION pLast; /* pointer to the last defined function */ + int iCount; /* number of defined functions */ +} FUNCTIONS; /* structure to control all Clipper defined functions */ + +/* pcode chunks bytes size */ +#define PCODE_CHUNK 100 + +typedef struct _COMSYMBOL /* compiler symbol support structure */ +{ + char * szName; /* the name of the symbol */ + char cScope; /* the scope of the symbol */ + struct _COMSYMBOL * pNext; /* pointer to the next defined symbol */ +} COMSYMBOL, * PCOMSYMBOL; + +typedef struct /* symbol table support structures */ +{ + PCOMSYMBOL pFirst; /* pointer to the first defined symbol */ + PCOMSYMBOL pLast; /* pointer to the last defined symbol */ + int iCount; /* number of defined symbols */ +} SYMBOLS; + +typedef struct __ELSEIF +{ + WORD wOffset; + struct __ELSEIF * pNext; +} _ELSEIF, * PELSEIF; /* support structure for else if pcode fixups */ + +typedef struct __RETURN +{ + WORD wOffset; + struct __RETURN * pNext; +} _RETURN, * PRETURN; /* support structure for multiple returns from a function */ + +typedef struct /* support for filenames */ +{ + char _buffer[ _POSIX_PATH_MAX+3 ]; + char *path; + char *name; + char *extension; +} FILENAME; + +typedef struct __EXTERN +{ + char * szName; + struct __EXTERN * pNext; +} _EXTERN, * PEXTERN; /* support structure for extern symbols */ +/* as they have to be placed on the symbol table later than the first public symbol */ + +FILENAME *SplitFilename( char * ); /* splits filename into a path, a name and an extension */ +char *MakeFilename( char *, FILENAME *); /* joins a path, a name an an extension int filename */ + +/* lex & yacc related prototypes */ +void yyerror( char * ); /* parsing error management function */ +int yylex( void ); /* main lex token function, called by yyparse() */ +int yyparse( void ); /* main yacc parsing function */ +int yywrap( void ); /* manages the EOF of current processed file */ +void AddDefine( char * szDefine, char * szValue ); /* add a new Lex define from the command line */ + +void * yy_create_buffer( FILE *, int ); /* yacc functions to manage multiple files */ +void yy_switch_to_buffer( void * ); /* yacc functions to manage multiple files */ +void yy_delete_buffer( void * ); /* yacc functions to manage multiple files */ +void __yy_memcpy( char * from, char * to, int count ); /* Bison prototype */ + +/* production related functions */ +PFUNCTION AddFunCall( char * szFuntionName ); +void AddExtern( char * szExternName ); /* defines a new extern name */ +void AddVar( char * szVarName ); /* add a new param, local, static variable to a function definition or a public or private */ +PCOMSYMBOL AddSymbol( char * szSymbolName ); +void CheckDuplVars( PVAR pVars, char * szVarName, int iVarScope ); /*checks for duplicate variables definitions */ +void CheckStatics( void ); /* creates the _STATICS function if there are any static defined */ +void Dec( void ); /* generates the pcode to decrement the latest value on the virtual machine stack */ +void DimArray( WORD wDimensions ); /* instructs the virtual machine to build an array with wDimensions */ +void Do( BYTE bParams ); /* generates the pcode to execute a Clipper function discarding its result */ +void Duplicate( void ); /* duplicates the virtual machine latest stack latest value and places it on the stack */ +void DupPCode( WORD wStart ); /* duplicates the current generated pcode from an offset */ +void FixElseIfs( void * pIfElseIfs ); /* implements the ElseIfs pcode fixups */ +void FixReturns( void ); /* fixes all last defined function returns jumps offsets */ +void Function( BYTE bParams ); /* generates the pcode to execute a Clipper function pushing its result */ +void FunDef( char * szFunName, char cScope ); /* starts a new Clipper language function definition */ +void GenArray( WORD wElements ); /* instructs the virtual machine to build an array and load elemnst from the stack */ +void * GenElseIf( void * pFirstElseIf, WORD wOffset ); /* generates a support structure for elseifs pcode fixups */ +void GenError( int, char*, char * ); /* generic parsing error management function */ +void GenExterns( void ); /* generates the symbols for the EXTERN names */ +void GenReturn( WORD wOffset ); /* generates a return offset to later on fill it with the proper exiting pcode address */ +PFUNCTION GetFuncall( char * szFunName ); /* locates a previously defined called function */ +PFUNCTION GetFunction( char * szFunName ); /* locates a previously defined function */ +PVAR GetVar( PVAR pVars, WORD wOrder ); /* returns a variable if defined or zero */ +WORD GetVarPos( PVAR pVars, char * szVarName ); /* returns the order + 1 of a variable if defined or zero */ +int GetLocalVarPos( char * szVarName ); /* returns the order + 1 of a local variable */ +PCOMSYMBOL GetSymbol( char * szSymbolName ); /* returns a symbol pointer from the symbol table */ +PCOMSYMBOL GetSymbolOrd( WORD wSymbol ); /* returns a symbol based on its index on the symbol table */ +WORD GetSymbolPos( char * szSymbolName ); /* returns the index + 1 of a symbol on the symbol table */ +void Inc( void ); /* generates the pcode to increment the latest value on the virtual machine stack */ +WORD Jump( int iOffset ); /* generates the pcode to jump to a specific offset */ +WORD JumpFalse( int iOffset ); /* generates the pcode to jump if false */ +void JumpHere( int iOffset ); /* returns the pcode pos where to set a jump offset */ +void JumpThere( int iOffset, WORD wTo ); /* sets a jump offset */ +WORD JumpTrue( int iOffset ); /* generates the pcode to jump if true */ +void Line( void ); /* generates the pcode with the currently compiled source code line */ +void LineBody( void ); /* generates the pcode with the currently compiled source code line */ +void Message( char * szMsgName ); /* sends a message to an object */ +void PopDefId( char * szVarName ); /* generates the pcode to pop a default value from the virtual machine stack onto a variable */ +void PopId( char * szVarName ); /* generates the pcode to pop a value from the virtual machine stack onto a variable */ +void PushDouble( double fNumber ); /* Pushes a number on the virtual machine stack */ +void PushId( char * szVarName ); /* generates the pcode to push a variable value to the virtual machine stack */ +void PushIdByRef( char * szVarName ); /* generates the pcode to push a variable by reference to the virtual machine stack */ +void PushInteger( int iNumber ); /* Pushes a integer number on the virtual machine stack */ +void PushLogical( int iTrueFalse ); /* pushes a logical value on the virtual machine stack */ +void PushLong( long lNumber ); /* Pushes a long number on the virtual machine stack */ +void PushNil( void ); /* Pushes nil on the virtual machine stack */ +void PushString( char * szText ); /* Pushes a string on the virtual machine stack */ +void PushSymbol( char * szSymbolName, int iIsFunction ); /* Pushes a symbol on to the Virtual machine stack */ +void GenPCode1( BYTE ); /* generates 1 byte of pcode */ +void GenPCode3( BYTE, BYTE, BYTE ); /* generates 3 bytes of pcode */ +void GenPCodeN( BYTE * pBuffer, WORD wSize ); /* copy bytes to a pcode buffer */ +char * SetData( char * szMsg ); /* generates an underscore-symbol name for a data assignment */ +void SetFrame( void ); /* generates the proper _FRAME values */ + +/* support for FIELD declaration */ +void SetAlias( char *, int ); +int FieldsCount( void ); + +/* Codeblocks */ +void CodeBlockStart( void ); /* starts a codeblock creation */ +void CodeBlockEnd( void ); /* end of codeblock creation */ + +void * OurMalloc( LONG lSize ); /* our malloc with error control */ +void * OurRealloc( void * p, LONG lSize ); /* our malloc with error control */ +#define OurFree( p ) free( (p) ); /* just for symetry -we can expand it later */ + +/* output related functions */ +void GenCCode( char *, char * ); /* generates the C language output */ +void GenJava( char *, char * ); /* generates the Java language output */ +void GenPascal( char *, char * ); /* generates the Pascal language output */ +void GenRC( char *, char * ); /* generates the RC language output */ + +void PrintUsage( char * ); + +#define YYDEBUG 1 /* Parser debug information support */ + +typedef enum +{ + LANG_C, /* C language (by default) */ + LANG_JAVA, /* Java */ + LANG_PASCAL, /* Pascal */ + LANG_RESOURCES /* Resources */ +} LANGUAGES; /* supported Harbour output languages */ + +extern int iLine; /* currently compiled source code line */ + +int iVarScope = 0; /* holds the scope for next variables to be defined */ +#define VS_LOCAL 0 /* different values for iVarScope */ +#define VS_STATIC 1 +#define VS_PARAMETER 2 +#define VS_FIELD 3 +#define VS_MEMVAR 4 + +#define ERR_OUTSIDE 1 +#define ERR_FUNC_DUPL 2 +#define ERR_VAR_DUPL 3 +#define ERR_FOLLOWS_EXEC 4 +#define ERR_OUTER_VAR 5 +#define ERR_NUMERIC_FORMAT 6 +#define ERR_STRING_TERMINATOR 7 + +/* Table with parse errors */ +char * _szErrors[] = { "Statement not allowed outside of procedure or function", + "Redefinition of procedure or function: \'%s\'", + "Duplicate variable declaration: \'%s\'", + "%s declaration follows executable statement", + "Outer codeblock variable is out of reach: \'%s\'", + "Invalid numeric format '.'", + "Unterminated string: \'%s\'" + }; + +FILES files; +FUNCTIONS functions, funcalls; +SYMBOLS symbols; +int _iStartProc = 1; /* holds if we need to create the starting procedure */ +int _iLineNumbers = 1; /* holds if we need pcodes with line numbers */ +int _iQuiet = 0; /* quiet mode */ +int _iSyntaxCheckOnly = 0; /* syntax check only */ +int _iLanguage = LANG_C; /* default Harbour generated output language */ +int _iRestrictSymbolLength = 0; /* generate 10 chars max symbols length */ +int _iShortCuts = 1; /* .and. & .or. expressions shortcuts */ +WORD wStatics = 0; /* number of defined statics variables on the PRG */ +PRETURN pReturns = 0; /* list of multiple returns from a function */ +PEXTERN pExterns = 0; + +%} + +%union /* special structure used by lex and yacc to share info */ +{ + char * string; /* to hold a string returned by lex */ + int iNumber; /* to hold a number returned by lex */ + long lNumber; /* to hold a long number returned by lex */ + double dNumber; /* to hold a double number returned by lex */ + void * pVoid; /* to hold any memory structure we may need */ +}; + +%token FUNCTION PROCEDURE IDENTIFIER RETURN NIL DOUBLE INASSIGN INTEGER INTLONG +%token LOCAL STATIC IF ELSE ELSEIF END ENDIF LITERAL TRUE FALSE +%token INCLUDE EXTERN INIT EXIT AND OR NOT PUBLIC EQ NE1 NE2 +%token INC DEC ALIAS DOCASE CASE OTHERWISE ENDCASE ENDDO MEMVAR +%token WHILE EXIT LOOP END FOR NEXT TO STEP LE GE FIELD IN PARAMETERS +%token PLUSEQ MINUSEQ MULTEQ DIVEQ POWER EXPEQ MODEQ EXITLOOP +%token PRIVATE BEGINSEQ BREAK RECOVER USING SEQUENCE DO WITH SELF + +/*the lowest precedence*/ +/*postincrement and postdecrement*/ +%left POST +/*assigment - from right to left*/ +%right INASSIGN +%left PLUSEQ MINUSEQ +%left MULTEQ DIVEQ MODEQ +%left EXPEQ +/*logical operators*/ +%left OR +%left AND +%left NOT +/*relational operators*/ +%left '<' '>' EQ NE1 NE2 LE GE '$' +/*mathematical operators*/ +%left '+' '-' +%left '*' '/' '%' +%left POWER +%left UNARY +/*preincrement and predecrement*/ +%left PRE +/*special operators*/ +%left ALIAS '&' '@' ')' +%right '\n' ';' ',' '=' +/*the highest precedence*/ + +%type IDENTIFIER LITERAL FunStart MethStart IdSend +%type DOUBLE ObjectData +%type ArgList ElemList ExpList FunCall FunScope IncDec Logical Params ParamList +%type INTEGER BlockExpList Argument IfBegin VarId VarList MethParams ObjFunCall +%type MethCall BlockList FieldList +%type INTLONG WhileBegin BlockBegin +%type IfElseIf Cases + +%% + +Main : { Line(); } Source { CheckStatics(); if( ! _iQuiet ) printf( "\nsyntax ok\n" ); } + ; + +Source : Crlf + | Extern + | Include + | VarDefs + | FieldsDef + | MEMVAR IdentList + | Function + | Statement + | Source Crlf + | Source Extern + | Source Include + | Source Function + | Source { LineBody(); } Statement + | Source VarDefs + | Source FieldsDef + | Source MEMVAR IdentList + ; + +Include : NE1 INCLUDE LITERAL { Include( $3 ); } Crlf + ; + +Extern : EXTERN ExtList Crlf + ; + +ExtList : IDENTIFIER { AddExtern( $1 ); } + | ExtList ',' IDENTIFIER { AddExtern( $3 ); } + ; + +Function : FunScope FUNCTION IDENTIFIER { FunDef( $3, $1 ); } Params Crlf { SetFrame(); } + | FunScope PROCEDURE IDENTIFIER { FunDef( $3, $1 ); } Params Crlf { SetFrame(); } + ; + +FunScope : { $$ = FS_PUBLIC; } + | STATIC { $$ = FS_STATIC; } + | INIT { $$ = FS_INIT; } + | EXIT { $$ = FS_EXIT; } + ; + +Params : { $$ = 0; } + | '(' ')' { $$ = 0; } + | '(' { iVarScope = VS_PARAMETER; } ParamList ')' { $$ = $3; } + ; + +ParamList : IDENTIFIER { AddVar( $1 ); $$ = 1; } + | ParamList ',' IDENTIFIER { AddVar( $3 ); $$++; } + ; + +Statements : Statement + | Statements { Line(); } Statement + ; + +Statement : ExecFlow Crlf {} + | FunCall Crlf { Do( $1 ); } + | AliasFunc Crlf {} + | IfInline Crlf { GenPCode1( _POP ); } + | ObjectMethod Crlf { GenPCode1( _POP ); } + | VarUnary Crlf { GenPCode1( _POP ); } + | VarAssign Crlf { GenPCode1( _POP ); } + + | IDENTIFIER '=' Expression Crlf { PopId( $1 ); } + | VarId ArrayIndex '=' Expression Crlf { GenPCode1( _ARRAYPUT ); GenPCode1( _POP ); } + | FunCall ArrayIndex '=' Expression Crlf { Do( $1 ); GenPCode1( _ARRAYPUT ); } + | IdSend IDENTIFIER '=' { Message( SetData( $2 ) ); } Expression Crlf { Function( 1 ); } + | ObjectData ArrayIndex '=' Expression Crlf {} + | ObjectMethod ArrayIndex '=' Expression Crlf {} + + | RETURN Crlf { GenReturn( Jump( 0 ) ); } + | RETURN Expression Crlf { GenPCode1( _RETVALUE ); GenReturn( Jump ( 0 ) ); } + | PUBLIC VarList Crlf + | PRIVATE VarList Crlf + | PARAMETERS IdentList Crlf + | EXITLOOP Crlf + | LOOP Crlf + | DoProc Crlf + ; + +FunCall : FunStart ')' { $$ = 0; } + | FunStart ArgList ')' { $$ = $2; } + ; + +FunStart : IDENTIFIER '(' { PushSymbol( $1, 1 ); PushNil(); $$ = $1; } + ; + +MethCall : MethStart ')' { $$ = 0; } + | MethStart ArgList ')' { $$ = $2; } + ; + +MethStart : IDENTIFIER '(' { Message( $1 ); $$ = $1; } + ; + +ArgList : ',' { PushNil(); PushNil(); $$ = 2; } + | Argument { $$ = 1; } + | ArgList ',' { PushNil(); $$++; } + | ArgList ',' Argument { $$++; } + ; + +Argument : Expression {} + | '@' IDENTIFIER { PushIdByRef( $2 ); } + | '@' IDENTIFIER '(' ')' { PushSymbol( $2, 1 ); GenPCode1( _FUNCPTR ); } + ; + +MethParams : /* empty */ { $$ = 0; } + | ArgList { $$ = $1; } + ; + +ObjectData : IdSend IDENTIFIER { Message( $2 ); Function( 0 ); } + | VarId ArrayIndex ':' IDENTIFIER { Message( $4 ); Function( 0 ); } + | ObjFunCall IDENTIFIER { Message( $2 ); Function( 0 ); } + | FunCall ArrayIndex ':' IDENTIFIER { Function( $1 ); Message( $4 ); Function( 0 ); } + | ObjectMethod ':' IDENTIFIER { Message( $3 ); Function( 0 ); } + | ObjectData ':' IDENTIFIER { Message( $3 ); Function( 0 ); } + | ObjectData ArrayIndex ':' IDENTIFIER { Message( $4 ); Function( 0 ); } + ; + +ObjectMethod : IdSend IDENTIFIER { Message( $2 ); } '(' MethParams ')' { Function( $5 ); } + | VarId ArrayIndex ':' MethCall { Function( $4 ); } + | ObjFunCall MethCall { Function( $2 ); } + | FunCall ArrayIndex ':' MethCall { Function( $4 ); } + | ObjectData ':' MethCall { Function( $3 ); } + | ObjectData ArrayIndex ':' MethCall { Function( $4 ); } + | ObjectMethod ':' MethCall { Function( $3 ); } + ; + +IdSend : IDENTIFIER ':' { PushId( $1 ); $$ = $1; } + ; + +ObjFunCall : FunCall ':' { Function( $1 ); $$ = $1; } + ; + +Expression : NIL { PushNil(); } + | DOUBLE { PushDouble( $1 ); } + | INTEGER { PushInteger( $1 ); } + | INTLONG { PushLong( $1 ); } + | LITERAL { PushString( $1 ); } + | Variable + | VarUnary + | Logical { PushLogical( $1 ); } + | Operators {} + | FunCall { Function( $1 ); } + | IfInline {} + | Array {} + | CodeBlock {} + | ObjectMethod {} + | Macro {} + | AliasExp {} + | '(' Expression ')' {} + | '(' ExpList ')' {} + | SELF { GenPCode1( _PUSHSELF ); } + ; + +IfInline : IF '(' Expression ',' { $$ = JumpFalse( 0 ); } + IfInlExp ',' { $$ = Jump( 0 ); JumpHere( $5 ); } + IfInlExp ')' { JumpHere( $8 ); } + ; + +IfInlExp : /* nothing => nil */ { PushNil(); } + | Expression + ; + +Macro : '&' Variable + | '&' '(' Expression ')' + ; + +AliasExp : IDENTIFIER ALIAS IDENTIFIER {} + | '(' Expression ')' ALIAS IDENTIFIER {} + | AliasFunc {} + ; + +AliasFunc : IDENTIFIER ALIAS '(' ExpList ')' {} + | '(' Expression ')' ALIAS '(' ExpList ')' {} + ; + +VarUnary : IDENTIFIER IncDec %prec POST { PushId( $1 ); Duplicate(); $2 ? Inc(): Dec(); PopId( $1 ); } + | IncDec IDENTIFIER %prec PRE { PushId( $2 ); $1 ? Inc(): Dec(); Duplicate(); PopId( $2 ); } + | VarId ArrayIndex IncDec %prec POST { DupPCode( $1 ); GenPCode1( _ARRAYAT ); $3 ? Inc(): Dec(); GenPCode1( _ARRAYPUT ); $3 ? Dec(): Inc(); } + | IncDec VarId ArrayIndex %prec PRE { DupPCode( $2 ); GenPCode1( _ARRAYAT ); $1 ? Inc(): Dec(); GenPCode1( _ARRAYPUT ); } + | FunCall ArrayIndex IncDec %prec POST {} + | IncDec FunCall ArrayIndex %prec PRE {} + | ObjectData IncDec %prec POST {} + | IncDec ObjectData %prec PRE {} + | ObjectData ArrayIndex IncDec %prec POST {} + | IncDec ObjectData ArrayIndex %prec PRE {} + | ObjectMethod ArrayIndex IncDec %prec POST {} + | IncDec ObjectMethod ArrayIndex %prec PRE {} + ; + +IncDec : INC { $$ = 1; } + | DEC { $$ = 0; } + ; + +Variable : VarId {} + | VarId ArrayIndex { GenPCode1( _ARRAYAT ); } + | FunCall ArrayIndex { GenPCode1( _ARRAYAT ); } + | ObjectData {} + | ObjectData ArrayIndex { GenPCode1( _ARRAYAT ); } + | ObjectMethod ArrayIndex { GenPCode1( _ARRAYAT ); } + ; + +VarId : IDENTIFIER { $$ = functions.pLast->lPCodePos; PushId( $1 ); } + ; + +ArrayIndex : '[' IndexList ']' + | ArrayIndex { GenPCode1( _ARRAYAT ); } '[' IndexList ']' + ; + +IndexList : Expression + | IndexList { GenPCode1( _ARRAYAT ); } ',' Expression + ; + +VarAssign : IDENTIFIER INASSIGN Expression { PopId( $1 ); PushId( $1 ); } + | IDENTIFIER PLUSEQ { PushId( $1 ); } Expression { GenPCode1( _PLUS ); PopId( $1 ); PushId( $1 ); } + | IDENTIFIER MINUSEQ { PushId( $1 ); } Expression { GenPCode1( _MINUS ); PopId( $1 ); PushId( $1 ); } + | IDENTIFIER MULTEQ { PushId( $1 ); } Expression { GenPCode1( _MULT ); PopId( $1 ); PushId( $1 ); } + | IDENTIFIER DIVEQ { PushId( $1 ); } Expression { GenPCode1( _DIVIDE ); PopId( $1 ); PushId( $1 ); } + | IDENTIFIER EXPEQ { PushId( $1 ); } Expression { GenPCode1( _POWER ); PopId( $1 ); PushId( $1 ); } + | IDENTIFIER MODEQ { PushId( $1 ); } Expression { GenPCode1( _MODULUS ); PopId( $1 ); PushId( $1 ); } + | VarId ArrayIndex INASSIGN Expression { GenPCode1( _ARRAYPUT ); } + | VarId ArrayIndex PLUSEQ Expression { GenPCode1( _PLUS ); GenPCode1( _ARRAYPUT ); } + | VarId ArrayIndex MINUSEQ Expression {} + | VarId ArrayIndex MULTEQ Expression {} + | VarId ArrayIndex DIVEQ Expression {} + | VarId ArrayIndex EXPEQ Expression {} + | VarId ArrayIndex MODEQ Expression {} + | FunCall ArrayIndex INASSIGN Expression {} + | FunCall ArrayIndex PLUSEQ Expression {} + | FunCall ArrayIndex MINUSEQ Expression {} + | FunCall ArrayIndex MULTEQ Expression {} + | FunCall ArrayIndex DIVEQ Expression {} + | FunCall ArrayIndex EXPEQ Expression {} + | FunCall ArrayIndex MODEQ Expression {} + | ObjectData INASSIGN Expression {} + | ObjectData PLUSEQ Expression {} + | ObjectData MINUSEQ Expression {} + | ObjectData MULTEQ Expression {} + | ObjectData DIVEQ Expression {} + | ObjectData EXPEQ Expression {} + | ObjectData MODEQ Expression {} + | ObjectData ArrayIndex INASSIGN Expression {} + | ObjectData ArrayIndex PLUSEQ Expression {} + | ObjectData ArrayIndex MINUSEQ Expression {} + | ObjectData ArrayIndex MULTEQ Expression {} + | ObjectData ArrayIndex DIVEQ Expression {} + | ObjectData ArrayIndex EXPEQ Expression {} + | ObjectData ArrayIndex MODEQ Expression {} + | ObjectMethod ArrayIndex INASSIGN Expression {} + | ObjectMethod ArrayIndex PLUSEQ Expression {} + | ObjectMethod ArrayIndex MINUSEQ Expression {} + | ObjectMethod ArrayIndex MULTEQ Expression {} + | ObjectMethod ArrayIndex DIVEQ Expression {} + | ObjectMethod ArrayIndex EXPEQ Expression {} + | ObjectMethod ArrayIndex MODEQ Expression {} + | AliasExp INASSIGN Expression {} + ; + +Operators : Expression '=' Expression { GenPCode1( _EQUAL ); } /* compare */ + | Expression '+' Expression { GenPCode1( _PLUS ); } + | Expression '-' Expression { GenPCode1( _MINUS ); } + | Expression '*' Expression { GenPCode1( _MULT ); } + | Expression '/' Expression { GenPCode1( _DIVIDE ); } + | Expression '<' Expression { GenPCode1( _LESS ); } + | Expression '>' Expression { GenPCode1( _GREATER ); } + | Expression '$' Expression { GenPCode1( _INSTRING ); } + | Expression '%' Expression { GenPCode1( _MODULUS ); } + | Expression LE Expression { GenPCode1( _LESSEQUAL ); } + | Expression GE Expression { GenPCode1( _GREATEREQUAL ); } + | Expression AND { if( _iShortCuts ){ Duplicate(); $$ = JumpFalse( 0 ); } } + Expression { GenPCode1( _AND ); if( _iShortCuts ) JumpHere( $3 ); } + | Expression OR { if( _iShortCuts ){ Duplicate(); $$ = JumpTrue( 0 ); } } + Expression { GenPCode1( _OR ); if( _iShortCuts ) JumpHere( $3 ); } + | Expression EQ Expression { GenPCode1( _EQUAL ); } + | Expression NE1 Expression { GenPCode1( _NOTEQUAL ); } + | Expression NE2 Expression { GenPCode1( _NOTEQUAL ); } + | Expression POWER Expression { GenPCode1( _POWER ); } + | NOT Expression { GenPCode1( _NOT ); } + | '-' Expression %prec UNARY { GenPCode1( _NEGATE ); } + | '+' Expression %prec UNARY + | VarAssign + ; + +Logical : TRUE { $$ = 1; } + | FALSE { $$ = 0; } + ; + +Array : '{' ElemList '}' { GenArray( $2 ); } + ; + +ElemList : /*empty array*/ { $$ = 0; } + | Expression { $$ = 1; } + | ElemList ',' { if( $$ == 0 ) { + PushNil(); + PushNil(); + $$ = 2; + } else { + PushNil(); + $$++; + } } + | ElemList ',' Expression { if( $$ == 0 ) + { + PushNil(); + $$ = 2; + } + else + $$++; } + ; + +CodeBlock : BlockBegin '|' BlockExpList '}' { CodeBlockEnd(); } + | BlockBegin BlockList '|' BlockExpList '}' { CodeBlockEnd(); } + ; + +BlockBegin : '{' '|' { CodeBlockStart(); } + ; + +BlockExpList : Expression { $$ = 1; } + | ',' { PushNil(); GenPCode1( _POP ); PushNil(); $$ = 2; } + | BlockExpList ',' { GenPCode1( _POP ); PushNil(); $$++; } + | BlockExpList ',' { GenPCode1( _POP ); } Expression { $$++; } + ; + +BlockList : IDENTIFIER { AddVar( $1 ); $$ = 1; } + | BlockList ',' IDENTIFIER { AddVar( $3 ); $$++; } + ; + +ExpList : Expression %prec POST { $$ = 1; } + | ExpList { GenPCode1( _POP ); } ',' Expression %prec POST { $$++; } + ; + +VarDefs : LOCAL { iVarScope = VS_LOCAL; Line(); } VarList Crlf { SetFrame(); } + | STATIC { iVarScope = VS_STATIC; Line(); } VarList Crlf { wStatics += $3; } + ; + +VarList : VarDef { $$ = 1; } + | VarList ',' VarDef { $$++; } + ; + +VarDef : IDENTIFIER { AddVar( $1 ); } + | IDENTIFIER INASSIGN Expression { AddVar( $1 ); PopDefId( $1 ); } + | IDENTIFIER '[' ExpList ']' { AddVar( $1 ); DimArray( $3 ); } + ; + +FieldsDef : FIELD { iVarScope =VS_FIELD; } FieldList Crlf { LineBody(); } + ; + +FieldList : IDENTIFIER { $$=FieldsCount(); AddVar( $1 ); } + | FieldList ',' IDENTIFIER { AddVar( $3 ); } + | FieldList IN IDENTIFIER { SetAlias( $3, $1 ); } + ; + +IdentList : IDENTIFIER {} + | IdentList ',' IDENTIFIER {} + ; + +ExecFlow : IfEndif + | DoCase + | DoWhile + | ForNext + | BeginSeq + ; + +IfEndif : IfBegin EndIf { JumpHere( $1 ); } + | IfBegin IfElse EndIf { JumpHere( $1 ); } + | IfBegin IfElseIf EndIf { JumpHere( $1 ); FixElseIfs( $2 ); } + | IfBegin IfElseIf IfElse EndIf { JumpHere( $1 ); FixElseIfs( $2 ); } + ; + +IfBegin : IF Expression Crlf { $$ = JumpFalse( 0 ); } IfStats + { $$ = Jump( 0 ); JumpHere( $4 ); } + ; + +IfElse : ELSE Crlf IfStats + ; + +IfElseIf : ELSEIF Expression Crlf { $$ = JumpFalse( 0 ); } + IfStats { $$ = GenElseIf( 0, Jump( 0 ) ); JumpHere( $4 ); } + + | IfElseIf ELSEIF Expression Crlf { $$ = JumpFalse( 0 ); } + IfStats { $$ = GenElseIf( $1, Jump( 0 ) ); JumpHere( $5 ); } + ; + +EndIf : ENDIF + | END + ; + +IfStats : /* no statements */ + | Statements + ; + +DoCase : DoCaseBegin + Cases + EndCase { FixElseIfs( $2 ); } + + | DoCaseBegin + Otherwise + EndCase + + | DoCaseBegin + Cases + Otherwise + EndCase { FixElseIfs( $2 ); } + ; + +EndCase : ENDCASE + | END + ; + +DoCaseBegin : DOCASE Crlf + ; + +Cases : CASE Expression Crlf { $$ = JumpFalse( 0 ); Line(); } CaseStmts { $$ = GenElseIf( 0, Jump( 0 ) ); JumpHere( $4 ); Line(); } + | Cases CASE Expression Crlf { $$ = JumpFalse( 0 ); Line(); } CaseStmts { $$ = GenElseIf( $1, Jump( 0 ) ); JumpHere( $5 ); Line(); } + ; + +Otherwise : OTHERWISE Crlf CaseStmts + ; + +CaseStmts : /* no statements */ + | Statements + ; + +DoWhile : WhileBegin Expression Crlf { $$ = JumpFalse( 0 ); } + { Jump( $1 - functions.pLast->lPCodePos ); } + EndWhile { JumpHere( $4 ); } + + | WhileBegin Expression Crlf { $$ = JumpFalse( 0 ); Line(); } + WhileStatements { Jump( $1 - functions.pLast->lPCodePos ); } + EndWhile { JumpHere( $4 ); } + ; + +WhileBegin : WHILE { $$ = functions.pLast->lPCodePos; } + ; + +WhileStatements : Statement + | WhileStatements Statement { Line(); } + ; + +EndWhile : END + | ENDDO + ; + +ForNext : FOR IDENTIFIER ForAssign Expression { PopId( $2 ); $$ = functions.pLast->lPCodePos; } + TO Expression { PushId( $2 ); } + StepExpr Crlf { GenPCode1( _FORTEST ); $$ = JumpTrue( 0 ); PushId( $2 ) } + ForStatements { GenPCode1( _PLUS ); PopId( $2 ); Jump( $5 - functions.pLast->lPCodePos ); JumpHere( $11 ); } + ; + +ForAssign : '=' + | INASSIGN + ; + +StepExpr : /* default step expression */ { PushInteger( 1 ); } + | STEP Expression + ; + +ForStatements : ForStat NEXT + | ForStat NEXT IDENTIFIER + | NEXT + | NEXT IDENTIFIER + ; + +ForStat : Statements { Line(); } + ; + +BeginSeq : BEGINSEQ SEQUENCE Crlf + BreakSeq + RecoverSeq + EndSeq + + | BEGINSEQ SEQUENCE Crlf Statements + BreakSeq + RecoverSeq + EndSeq + ; + +BreakSeq : /* no break */ + | BREAK Crlf + | BREAK Crlf Statements + | BREAK Expression Crlf + | BREAK Expression Crlf Statements + ; + +RecoverSeq : /* no recover */ + | RECOVER Crlf + | RECOVER Crlf Statements + | RECOVER USING IDENTIFIER Crlf + | RECOVER USING IDENTIFIER Crlf Statements + ; + +EndSeq : END + | END SEQUENCE + ; + +DoProc : DO IDENTIFIER { PushSymbol( $2, 1 ); PushNil(); Do( 0 ); } + | DO IDENTIFIER { PushSymbol( $2, 1 ); PushNil(); } WITH ArgList { Do( $5 ); } + ; + +Crlf : '\n' + | ';' + | '\n' Crlf + | ';' Crlf + ; + +%% + +void yyerror( char * s ) +{ + printf( "\n%s at line %i\n", s, --iLine ); + exit( 1 ); +} + +void * GenElseIf( void * pFirst, WORD wOffset ) +{ + PELSEIF pElseIf = ( PELSEIF ) OurMalloc( sizeof( _ELSEIF ) ), pLast; + + pElseIf->wOffset = wOffset; + pElseIf->pNext = 0; + + if( ! pFirst ) + pFirst = pElseIf; + else + { + pLast = ( PELSEIF ) pFirst; + while( pLast->pNext ) + pLast = pLast->pNext; + pLast->pNext = pElseIf; + } + return pFirst; +} + +void GenError( int iError, char * szError1, char * szError2 ) +{ + char * szLine = ( char * ) OurMalloc( 160 ); /*2 lines of text */ + printf( "\r%s(%i) ", files.pLast->szFileName, iLine ); + printf( "Error C%i ", iError ); + sprintf( szLine, _szErrors[ iError - 1 ], szError1, szError2 ); + printf( "%s\n\n", szLine ); + exit( 1 ); +} + +int main( int argc, char * argv[] ) +{ + int iStatus = 0, iArg = 1; + char szFileName[ _POSIX_PATH_MAX ]; /* filename to parse */ + char *szPath =""; + FILENAME *pFileName =NULL; + + printf( "Harbour compiler\nbuild %i Spring 1999\n", BUILD ); + + if( argc > 1 ) + { + /* Command line options */ + while( iArg < argc ) + { + if( argv[ iArg ][ 0 ] == '/' || argv[ iArg ][ 0 ] == '-' ) + { + switch( argv[ iArg ][ 1 ] ) + { + case '1': + if( argv[ iArg ][ 2 ] == '0' ) + _iRestrictSymbolLength = 1; + break; + + case 'd': + case 'D': /* defines a Lex #define from the command line */ + { + unsigned int i = 0; + char * szDefText = strdup( argv[ iArg ] + 2 ); + while( i < strlen( szDefText ) && szDefText[ i ] != '=' ) + i++; + if( szDefText[ i ] != '=' ) + AddDefine( szDefText, 0 ); + else + { + szDefText[ i ] = 0; + AddDefine( szDefText, szDefText + i + 1 ); + } + free( szDefText ); + } + break; + + case 'g': + case 'G': + switch( argv[ iArg ][ 2 ] ) + { + case 'c': + case 'C': + _iLanguage = LANG_C; + break; + + case 'j': + case 'J': + _iLanguage = LANG_JAVA; + break; + + case 'p': + case 'P': + _iLanguage = LANG_PASCAL; + break; + + case 'r': + case 'R': + _iLanguage = LANG_RESOURCES; + break; + + default: + printf( "\nUnsupported output language option\n" ); + exit( 1 ); + } + break; + + case 'l': + case 'L': + _iLineNumbers = 0; + break; + + case 'n': + case 'N': + _iStartProc = 0; + break; + + case 'o': + case 'O': + szPath = argv[ iArg ]+2; + break; + + case 'q': + case 'Q': + _iQuiet = 1; + break; + + case 's': + case 'S': + _iSyntaxCheckOnly = 1; + break; + + case 'y': + case 'Y': + yydebug = TRUE; + break; + + case 'z': + case 'Z': + _iShortCuts = 0; + break; + + default: + printf( "Invalid command line option: %s\n", + &argv[ iArg ][ 1 ] ); + break; + } + } + else + pFileName =SplitFilename( argv[ iArg ] ); + iArg++; + } + + if( pFileName ) + { + if( !pFileName->extension ) + pFileName->extension =".prg"; + MakeFilename( szFileName, pFileName ); + } + else + { + PrintUsage( argv[ 0 ] ); + return iStatus; + } + + files.iFiles = 0; /* initialize support variables */ + files.pLast = 0; + functions.iCount = 0; + functions.pFirst = 0; + functions.pLast = 0; + funcalls.iCount = 0; + funcalls.pFirst = 0; + funcalls.pLast = 0; + symbols.iCount = 0; + symbols.pFirst = 0; + symbols.pLast = 0; + + if( Include( szFileName ) ) + { + FunDef( strupr( strdup( pFileName->name ) ), FS_PUBLIC ); + yyparse(); + FixReturns(); /* fix all previous function returns offsets */ + fclose( yyin ); + + if( ! _iSyntaxCheckOnly ) + { + /* we create a the output file */ + pFileName->path = szPath; + switch( _iLanguage ) + { + case LANG_C: + pFileName->extension =".c"; + MakeFilename( szFileName, pFileName ); + GenCCode( szFileName, pFileName->name ); + break; + + case LANG_JAVA: + pFileName->extension =".java"; + MakeFilename( szFileName, pFileName ); + GenJava( szFileName, pFileName->name ); + break; + + case LANG_PASCAL: + pFileName->extension =".pas"; + MakeFilename( szFileName, pFileName ); + GenPascal( szFileName, pFileName->name ); + break; + + case LANG_RESOURCES: + pFileName->extension =".rc"; + MakeFilename( szFileName, pFileName ); + GenRC( szFileName, pFileName->name ); + break; + } + } + } + else + { + printf( "Can't open input file: %s\n", szFileName ); + iStatus = 1; + } + OurFree( pFileName ); + } + else + PrintUsage( argv[ 0 ] ); + + return iStatus; +} + +/* + * Prints available options +*/ +void PrintUsage( char * szSelf ) +{ + printf( "Syntax: %s [options]\n" + "\nOptions: \n" + "\t/d[=]\t#define \n" + "\t/g\t\tgenerated output language\n" + "\t\t\t /gc (C default) --> \n" + "\t\t\t /gj (Java) --> \n" + "\t\t\t /gp (Pascal) --> \n" + "\t\t\t /gr (Resources) --> \n" + "\t/l\t\tsuppress line number information\n" + "\t/n\t\tno implicit starting procedure\n" + "\t/o\tobject file drive and/or path\n" + "\t/q\t\tquiet\n" + "\t/s\t\tsyntax check only\n" + "\t/y\t\ttrace lex & yacc activity\n" + "\t/z\t\tsupress .and. & .or. shortcutting\n" + "\t/10\t\trestrict symbol length to 10 characters\n" + , szSelf ); +} + +/* + * Split given filename into path, name and extension +*/ +FILENAME *SplitFilename( char *szFilename ) +{ + FILENAME *pName =(FILENAME *)OurMalloc( sizeof(FILENAME) ); + int iLen = strlen(szFilename); + int iSlashPos, iDotPos; + int iPos; + + pName->path =pName->name =pName->extension =NULL; + + iSlashPos =iLen-1; + iPos =0; + while( iSlashPos >= 0 && !IS_PATH_SEP(szFilename[ iSlashPos ]) ) + --iSlashPos; + if( iSlashPos == 0 ) + { + /* root path -> \filename */ + pName->_buffer[ 0 ] =PATH_DELIMITER[ 0 ]; + pName->_buffer[ 1 ] ='\x0'; + pName->path =pName->_buffer; + iPos =2; /* first free position after the slash */ + } + else if( iSlashPos > 0 ) + { + /* path with separator -> path\filename */ + memcpy( pName->_buffer, szFilename, iSlashPos ); + pName->_buffer[ iSlashPos ] ='\x0'; + pName->path =pName->_buffer; + iPos =iSlashPos +1; /* first free position after the slash */ + } + + iDotPos =iLen-1; + while( iDotPos > iSlashPos && szFilename[ iDotPos ] != '.' ) + --iDotPos; + if( (iDotPos-iSlashPos) > 1 ) + { + /* the dot was found + * and there is at least one character between a slash and a dot + */ + if( iDotPos == iLen-1 ) + { + /* the dot is the last character -use it as extension name */ + pName->extension =pName->_buffer+iPos; + pName->_buffer[ iPos++ ] ='.'; + pName->_buffer[ iPos++ ] ='\x0'; + } + else + { + pName->extension =pName->_buffer+iPos; + /* copy rest of the string with terminating ZERO character */ + memcpy( pName->extension, szFilename+iDotPos+1, iLen-iDotPos ); + iPos +=iLen-iDotPos; + } + } + else + /* there is no dot in the filename or it is '.filename' */ + iDotPos =iLen; + + pName->name =pName->_buffer+iPos; + memcpy( pName->name, szFilename+iSlashPos+1, iDotPos-iSlashPos-1 ); + pName->name[ iDotPos-iSlashPos-1 ] ='\x0'; + + return pName; +} + +/* + * This function joins path, name and extension into a string with a filename +*/ +char *MakeFilename( char *szFileName, FILENAME *pFileName ) +{ + if( pFileName->path && pFileName->path[ 0 ] ) + { + /* we have not empty path specified */ + int iLen =strlen(pFileName->path); + strcpy( szFileName, pFileName->path ); + /* if the path is a root directory then we don't need to add path separator */ + if( !(IS_PATH_SEP(pFileName->path[ 0 ]) && pFileName->path[ 0 ] == '\x0') ) + { + /* add the path separator only in cases: + * when a name doesn't start with it + * when the path doesn't end with it + */ + if( !( IS_PATH_SEP(pFileName->name[ 0 ]) || IS_PATH_SEP(pFileName->path[ iLen-1 ]) ) ) + { + szFileName[ iLen++ ] =PATH_DELIMITER[ 0 ]; + szFileName[ iLen ] ='\x0'; + } + } + strcpy( szFileName+iLen, pFileName->name ); + } + else + strcpy( szFileName, pFileName->name ); + + if( pFileName->extension ) + { + int iLen =strlen(szFileName); + + if( !(pFileName->extension[ 0 ] == '.' || pFileName->name[ iLen-1 ] == '.') ) + { + /* add extension separator only when extansion doesn't contain it */ + szFileName[ iLen++ ] ='.'; + szFileName[ iLen ] ='\x0'; + } + strcpy( szFileName+iLen, pFileName->extension ); + } + + return szFileName; +} + +PFUNCTION AddFunCall( char * szFunctionName ) +{ + PFUNCTION pFunc = ( PFUNCTION ) OurMalloc( sizeof( _FUNC ) ); + + pFunc->szName = szFunctionName; + pFunc->cScope = 0; + pFunc->pNext = 0; + + if( ! funcalls.iCount ) + { + funcalls.pFirst = pFunc; + funcalls.pLast = pFunc; + } + else + { + ( ( PFUNCTION ) funcalls.pLast )->pNext = pFunc; + funcalls.pLast = pFunc; + } + funcalls.iCount++; + + return pFunc; +} + +void AddExtern( char * szExternName ) /* defines a new extern name */ +{ + PEXTERN pExtern = ( PEXTERN ) OurMalloc( sizeof( _EXTERN ) ), pLast; + + pExtern->szName = szExternName; + pExtern->pNext = 0; + + if( pExterns == 0 ) + pExterns = pExtern; + else + { + pLast = pExterns; + while( pLast->pNext ) + pLast = pLast->pNext; + pLast->pNext = pExtern; + } +} + +void AddVar( char * szVarName ) +{ + PVAR pVar, pLastVar; + PFUNCTION pFunc =functions.pLast; + + if( ! _iStartProc && functions.iCount <= 1 && iVarScope == VS_LOCAL ) + { + /* Variable declaration is outside of function/procedure body. + In this case only STATIC and PARAMETERS variables are allowed. */ + --iLine; + GenError( ERR_OUTSIDE, NULL, NULL ); + } + + /* check if we are declaring local/static variable after some + * executable statements + * Note: FIELD and MEMVAR are executable statements + */ + if( (functions.pLast->bFlags & FUN_STATEMENTS) && !(iVarScope == VS_FIELD || iVarScope == VS_MEMVAR) ) + { + --iLine; + GenError( ERR_FOLLOWS_EXEC, (iVarScope==VS_LOCAL?"LOCAL":"STATIC"), NULL ); + } + + /* Check if a declaration of duplicated variable name is requested */ + if( pFunc->szName ) + { + /* variable defined in a function/procedure */ + CheckDuplVars( pFunc->pStatics, szVarName, iVarScope ); + CheckDuplVars( pFunc->pFields, szVarName, iVarScope ); + } + else + /* variable defined in a codeblock */ + iVarScope =VS_PARAMETER; + CheckDuplVars( pFunc->pLocals, szVarName, iVarScope ); + + pVar = ( PVAR ) OurMalloc( sizeof( VAR ) ); + pVar->szName = szVarName; + pVar->pNext = 0; + + switch( iVarScope ) + { + case VS_LOCAL: + case VS_PARAMETER: + if( ! pFunc->pLocals ) + pFunc->pLocals = pVar; + else + { + pLastVar = pFunc->pLocals; + while( pLastVar->pNext ) + pLastVar = pLastVar->pNext; + pLastVar->pNext = pVar; + } + if( iVarScope == VS_PARAMETER ) + ++functions.pLast->wParamCount; + break; + + case VS_STATIC: + if( functions.pLast ) + { + if( ! pFunc->pStatics ) + pFunc->pStatics = pVar; + else + { + pLastVar = pFunc->pStatics; + while( pLastVar->pNext ) + pLastVar = pLastVar->pNext; + pLastVar->pNext = pVar; + } + } + break; + + case VS_FIELD: + if( ! pFunc->pFields ) + pFunc->pFields = pVar; + else + { + pLastVar = pFunc->pFields; + while( pLastVar->pNext ) + pLastVar = pLastVar->pNext; + pLastVar->pNext = pVar; + } + break; + } +} + +PCOMSYMBOL AddSymbol( char * szSymbolName ) +{ + PCOMSYMBOL pSym = ( PCOMSYMBOL ) OurMalloc( sizeof( COMSYMBOL ) ); + + pSym->szName = szSymbolName; + pSym->cScope = 0; + pSym->pNext = 0; + + if( ! symbols.iCount ) + { + symbols.pFirst = pSym; + symbols.pLast = pSym; + } + else + { + ( ( PCOMSYMBOL ) symbols.pLast )->pNext = pSym; + symbols.pLast = pSym; + } + symbols.iCount++; + + return pSym; +} + +int Include( char * szFileName ) +{ + PFILE pFile; + + if( ! ( yyin = fopen( szFileName, "r" ) ) ) + return 0; + + if( ! _iQuiet ) + printf( "\nparsing file %s\n", szFileName ); + + pFile = ( PFILE ) OurMalloc( sizeof( _FILE ) ); + pFile->handle = yyin; + pFile->szFileName = szFileName; + + if( ! files.iFiles ) + files.pLast = pFile; + else + { + files.pLast->iLine = iLine; + iLine = 1; + pFile->pPrev = files.pLast; + files.pLast = pFile; + } + yy_switch_to_buffer( pFile->pBuffer = yy_create_buffer( yyin, 8192 * 2 ) ); + files.iFiles++; + return 1; +} + +int yywrap( void ) /* handles the EOF of the currently processed file */ +{ + void * pLast; + + if( files.iFiles == 1 ) + return 1; /* we have reached the main EOF */ + else + { + pLast = files.pLast; + fclose( files.pLast->handle ); + files.pLast = ( PFILE ) ( ( PFILE ) files.pLast )->pPrev; + iLine = files.pLast->iLine; + printf( "\nparsing file %s\n", files.pLast->szFileName ); + yy_delete_buffer( ( ( PFILE ) pLast )->pBuffer ); + free( pLast ); + files.iFiles--; + yyin = files.pLast->handle; + yy_switch_to_buffer( files.pLast->pBuffer ); + return 0; /* we close the currently include file and continue */ + } +} + +void Duplicate( void ) +{ + GenPCode1( _DUPLICATE ); +} + +void DupPCode( WORD wStart ) /* duplicates the current generated pcode from an offset */ +{ + WORD w, wEnd = functions.pLast->lPCodePos - wStart; + + for( w = 0; w < wEnd; w++ ) + GenPCode1( functions.pLast->pCode[ wStart + w ] ); +} + +void FunDef( char * szFunName, char cScope ) /* stores a Clipper defined function */ +{ + PCOMSYMBOL pSym; + PFUNCTION pFunc; + WORD wSymbol; + + if( ( pFunc = GetFunction( szFunName ) ) ) + { + /* The name of a function/procedure is already defined */ + if( pFunc != functions.pFirst || _iStartProc ) + /* it is not a starting procedure that was automatically created */ + GenError( ERR_FUNC_DUPL, szFunName, NULL ); + } + + FixReturns(); /* fix all previous function returns offsets */ + + if( !( pSym = GetSymbol( szFunName ) ) ) + /* there is not a symbol on the symbol table for this function name */ + pSym = AddSymbol( szFunName ); + + GenExterns(); /* generates EXTERN symbols names */ + + if( cScope == FS_PUBLIC ) + pSym->cScope = FS_PUBLIC; + else + pSym->cScope |= cScope; /* we may have a non public function and a object message */ + + pFunc = ( PFUNCTION ) OurMalloc( sizeof( _FUNC ) ); + pFunc->szName = szFunName; + pFunc->cScope = cScope; + pFunc->pLocals = 0; + pFunc->pStatics = 0; + pFunc->pFields = 0; + pFunc->pCode = 0; + pFunc->lPCodeSize = 0; + pFunc->lPCodePos = 0; + pFunc->pNext = 0; + pFunc->wParamCount = 0; + pFunc->wStaticsBase = wStatics; + pFunc->pOwner = NULL; + pFunc->bFlags = 0; + + if( functions.iCount == 0 ) + { + functions.pFirst = pFunc; + functions.pLast = pFunc; + } + else + { + functions.pLast->pNext = pFunc; + functions.pLast = pFunc; + } + functions.iCount++; + + if( ! strcmp( szFunName, "_INITSTATICS" ) ) /* is it the _INITSTATICS function ? */ + { + PushInteger( wStatics ); + wSymbol = GetSymbolPos( "_INITSTATICS" ) - ( _iStartProc ? 1: 2 ); + GenPCode3( _STATICS, LOBYTE( wSymbol ), HIBYTE( wSymbol ) ); + } + else + GenPCode3( _FRAME, 0, 0 ); /* frame for locals and parameters */ + + GenPCode3( _SFRAME, 0, 0 ); /* frame for statics variables */ +} + +void GenJava( char *szFileName, char *szName ) +{ + printf( "\ngenerating Java language output...\n" ); + printf( "%s -> not implemented yet!\n", szFileName, szName ); +} + +void GenPascal( char *szFileName, char *szName ) +{ + printf( "\ngenerating Pascal language output...\n" ); + printf( "%s -> not implemented yet!\n", szFileName, szName ); +} + +void GenRC( char *szFileName, char *szName ) +{ + printf( "\ngenerating resources output...\n" ); + printf( "%s -> not implemented yet!\n", szFileName, szName ); +} + +void GenCCode( char *szFileName, char *szName ) /* generates the C language output */ +{ + PFUNCTION pFunc = functions.pFirst, pFTemp; + PCOMSYMBOL pSym = symbols.pFirst; + WORD w, wLen, wSym, wVar; + WORD iNestedCodeblock = 0; + LONG lPCodePos; + char chr; + FILE * yyc; /* file handle for C output */ + + szName =szName; /* just to keep compiler silent */ + + if( ! ( yyc = fopen( szFileName, "wb" ) ) ) + { + printf( "Error opening file %s\n", szFileName ); + return; + } + + if( ! _iQuiet ) + printf( "\ngenerating C language output...\n" ); + + fprintf( yyc, "#include \"pcode.h\"\n\n" ); + + if( ! _iStartProc && ! pFunc->pStatics ) + pFunc = pFunc->pNext; /* No implicit starting procedure */ + + /* write functions prototypes for PRG defined functions */ + while( pFunc ) + { + if ( pFunc->cScope & FS_STATIC || pFunc->cScope & FS_INIT || + pFunc->cScope & FS_EXIT ) + fprintf( yyc, "static " ); + + fprintf( yyc, "HARBOUR %s( void );\n", pFunc->szName ); + pFunc = pFunc->pNext; + } + /* write functions prototypes for called functions outside this PRG */ + pFunc = funcalls.pFirst; + while( pFunc ) + { + if( ! ( pFTemp = GetFunction( pFunc->szName ) ) || pFTemp == functions.pFirst ) + fprintf( yyc, "HARBOUR %s( void );\n", pFunc->szName ); + pFunc = pFunc->pNext; + } + + /* writes the symbol table */ + fprintf( yyc, "\nstatic SYMBOL symbols[] = { " ); + + if( ! _iStartProc ) + pSym = pSym->pNext; /* starting procedure is always the first symbol */ + + while( pSym ) + { + fprintf( yyc, "{ \"%s\", ", pSym->szName ); + + if( pSym->cScope & FS_STATIC ) + fprintf( yyc, "FS_STATIC" ); + + else if( pSym->cScope & FS_INIT ) + fprintf( yyc, "FS_INIT" ); + + else if( pSym->cScope & FS_EXIT ) + fprintf( yyc, "FS_EXIT" ); + + else + fprintf( yyc, "FS_PUBLIC" ); + + if( ( pSym->cScope != FS_MESSAGE ) && ( pSym->cScope & FS_MESSAGE ) ) /* only for non public symbols */ + fprintf( yyc, " | FS_MESSAGE" ); + + /* specify the function address if it is a defined function or a + external called function */ + if( ( pFTemp = GetFunction( pSym->szName ) ) ) /* is it a defined function ? */ + fprintf( yyc, ", %s, 0 }", pFTemp->szName ); + else + { + if( ( pFTemp = GetFuncall( pSym->szName ) ) ) + fprintf( yyc, ", %s, 0 }", pFTemp->szName ); + else + fprintf( yyc, ", 0, 0 }" ); + } + + if( pSym != symbols.pLast ) + fprintf( yyc, ",\n " ); + + pSym = pSym->pNext; + } + fprintf( yyc, " };\n\n" ); + + fprintf( yyc, "#include \n\n" ); + + pFunc = functions.pFirst; + if( ! _iStartProc ) + pFunc = pFunc->pNext; /* No implicit starting procedure */ + + while( pFunc ) + { + if( pFunc->cScope != FS_PUBLIC ) + fprintf( yyc, "static " ); + + fprintf( yyc, "HARBOUR %s( void )\n{\n static BYTE pcode[] = { \n", pFunc->szName ); + + lPCodePos = 0; + while( lPCodePos < pFunc->lPCodePos ) + { + switch( pFunc->pCode[ lPCodePos ] ) + { + case _AND: + fprintf( yyc, " _AND,\n" ); + lPCodePos++; + break; + + case _ARRAYAT: + fprintf( yyc, " _ARRAYAT,\n" ); + lPCodePos++; + break; + + case _ARRAYPUT: + fprintf( yyc, " _ARRAYPUT,\n" ); + lPCodePos++; + break; + + case _DEC: + fprintf( yyc, " _DEC,\n" ); + lPCodePos++; + break; + + case _DIMARRAY: + w = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _DIMARRAY, %i, %i,\t/* %i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], w ); + lPCodePos += 3; + break; + + case _DIVIDE: + fprintf( yyc, " _DIVIDE,\n" ); + lPCodePos++; + break; + + case _DO: + fprintf( yyc, " _DO, %i, %i,\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ] ); + lPCodePos += 3; + break; + + case _DUPLICATE: + fprintf( yyc, " _DUPLICATE,\n" ); + lPCodePos++; + break; + + case _EQUAL: + fprintf( yyc, " _EQUAL,\n" ); + lPCodePos++; + break; + + case _ENDBLOCK: + --iNestedCodeblock; + fprintf( yyc, " _ENDBLOCK,\n" ); + lPCodePos++; + break; + + case _FALSE: + fprintf( yyc, " _FALSE,\n" ); + lPCodePos++; + break; + + case _FORTEST: /* ER For tests. Step > 0 LESS */ + /* Step < 0 GREATER */ + fprintf( yyc, " _FORTEST,\n" ); + lPCodePos++; + break; + + case _FRAME: + if( pFunc->pCode[ lPCodePos + 1 ] || pFunc->pCode[ lPCodePos + 2 ] ) + fprintf( yyc, " _FRAME, %i, %i,\t\t/* locals, params */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ] ); + lPCodePos += 3; + break; + + case _FUNCPTR: + fprintf( yyc, " _FUNCPTR,\n" ); + lPCodePos++; + break; + + case _FUNCTION: + fprintf( yyc, " _FUNCTION, %i, %i,\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ] ); + lPCodePos += 3; + break; + + case _GENARRAY: + w = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _GENARRAY, %i, %i,\t/* %i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], w ); + lPCodePos += 3; + break; + + case _GREATER: + fprintf( yyc, " _GREATER,\n" ); + lPCodePos++; + break; + + case _GREATEREQUAL: + fprintf( yyc, " _GREATEREQUAL,\n" ); + lPCodePos++; + break; + + case _INC: + fprintf( yyc, " _INC,\n" ); + lPCodePos++; + break; + + case _INSTRING: + fprintf( yyc, " _INSTRING,\n" ); + lPCodePos++; + break; + + case _JUMP: + w = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _JUMP, %i, %i,\t/* %i (abs: %05li) */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], w, lPCodePos + ( w ? w: 3 ) ); + lPCodePos += 3; + break; + + case _JUMPFALSE: + w = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _JUMPFALSE, %i, %i,\t/* %i (abs: %05li) */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], w, lPCodePos + ( w ? w: 3 ) ); + lPCodePos += 3; + break; + + case _JUMPTRUE: + w = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _JUMPTRUE, %i, %i,\t/* %i (abs: %05li) */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], w, lPCodePos + ( w ? w: 3 ) ); + lPCodePos += 3; + break; + + case _LESS: + fprintf( yyc, " _LESS,\n" ); + lPCodePos++; + break; + + case _LESSEQUAL: + fprintf( yyc, " _LESSEQUAL,\n" ); + lPCodePos++; + break; + + case _LINE: + fprintf( yyc, "/* %05li */", lPCodePos ); + w = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _LINE, %i, %i,\t\t/* %i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], w ); + lPCodePos += 3; + break; + + case _MESSAGE: + wSym = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _MESSAGE, %i, %i, /* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetSymbolOrd( wSym + ! _iStartProc )->szName ); + lPCodePos += 3; + break; + + case _MINUS: + fprintf( yyc, " _MINUS,\n" ); + lPCodePos++; + break; + + case _MODULUS: + fprintf( yyc, " _MODULUS,\n" ); + lPCodePos++; + break; + + case _MULT: + fprintf( yyc, " _MULT,\n" ); + lPCodePos++; + break; + + case _NEGATE: + fprintf( yyc, " _NEGATE,\n" ); + lPCodePos++; + break; + + case _NOT: + fprintf( yyc, " _NOT,\n" ); + lPCodePos++; + break; + + case _NOTEQUAL: + fprintf( yyc, " _NOTEQUAL,\n" ); + lPCodePos++; + break; + + case _OR: + fprintf( yyc, " _OR,\n" ); + lPCodePos++; + break; + + case _PLUS: + fprintf( yyc, " _PLUS,\n" ); + lPCodePos++; + break; + + case _POP: + fprintf( yyc, " _POP,\n" ); + lPCodePos++; + break; + + case _POPDEFSTAT: + { + SHORT wVar = pFunc->pCode[ lPCodePos + 1 ] + + ( pFunc->pCode[ lPCodePos + 2 ] * 256 ); + fprintf( yyc, " _POPDEFSTAT, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pStatics, wVar )->szName ); + lPCodePos += 3; + } + break; + + case _POPLOCAL: + { + SHORT wVar = * ( ( SHORT *) &(pFunc->pCode )[ lPCodePos + 1 ] ); + /* Variable with negative order are local variables + * referenced in a codeblock -handle it with care + */ + if( iNestedCodeblock ) + { + /* we are accesing variables within a codeblock */ + /* the names of codeblock variable are lost */ + if( wVar < 0 ) + fprintf( yyc, " _POPLOCAL, %i, %i,\t/* localvar%i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + -wVar ); + else + fprintf( yyc, " _POPLOCAL, %i, %i,\t/* codeblockvar%i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + wVar ); + } + else + fprintf( yyc, " _POPLOCAL, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pLocals, wVar )->szName ); + lPCodePos += 3; + } + break; + + case _POPMEMVAR: + wVar = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _POPMEMVAR, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetSymbolOrd( wVar + ! _iStartProc )->szName ); + lPCodePos += 3; + break; + + case _POPSTATIC: + wVar = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _POPSTATIC, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pStatics, wVar )->szName ); + lPCodePos += 3; + break; + + case _POWER: + fprintf( yyc, " _POWER,\n" ); + lPCodePos++; + break; + + case _PUSHBLOCK: + ++iNestedCodeblock; + fprintf( yyc, " _PUSHBLOCK, %i, %i,\t/* %i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256 ); + w = * ( ( WORD *) &( pFunc->pCode [ lPCodePos + 3 ] ) ); + fprintf( yyc, " %i, %i, \t/* number of local parameters (%i) */\n", + pFunc->pCode[ lPCodePos + 3 ], + pFunc->pCode[ lPCodePos + 4 ], w ); + wVar = * ( ( WORD *) &( pFunc->pCode [ lPCodePos + 5 ] ) ); + fprintf( yyc, " %i, %i, \t/* number of local variables (%i) */\n", + pFunc->pCode[ lPCodePos + 5 ], + pFunc->pCode[ lPCodePos + 6 ], wVar ); + lPCodePos += 7; /* codeblock size + number of parameters + number of local variables */ + /* create the table of referenced local variables */ + while( wVar-- ) + { + w = * ( ( WORD *) &( pFunc->pCode [ lPCodePos ] ) ); + fprintf( yyc, " %i, %i, \t/* %s */\n", + pFunc->pCode[ lPCodePos ], + pFunc->pCode[ lPCodePos + 1 ], + GetVar( pFunc->pLocals, w )->szName ); + lPCodePos +=2; + } + break; + + case _PUSHDOUBLE: + { + int i; + ++lPCodePos; + fprintf( yyc, " _PUSHDOUBLE, " ); + for( i = 0; i < sizeof( double ); ++i ) + fprintf( yyc, "%i, ", ( ( BYTE * ) pFunc->pCode )[ lPCodePos + i ] ); + fprintf( yyc, "/* %f */\n", + *( ( double * ) &( pFunc->pCode[ lPCodePos ] ) ) ); + lPCodePos += sizeof( double ); + } + break; + + case _PUSHINT: + fprintf( yyc, " _PUSHINT, %i, %i, /* %i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256 ); + lPCodePos += 3; + break; + + case _PUSHLOCAL: + { + SHORT wVar = * ( ( SHORT *) &(pFunc->pCode )[ lPCodePos + 1 ] ); + /* Variable with negative order are local variables + * referenced in a codeblock -handle it with care + */ + if( iNestedCodeblock ) + { + /* we are accesing variables within a codeblock */ + /* the names of codeblock variable are lost */ + if( wVar < 0 ) + fprintf( yyc, " _PUSHLOCAL, %i, %i,\t/* localvar%i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + -wVar ); + else + fprintf( yyc, " _PUSHLOCAL, %i, %i,\t/* codeblockvar%i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + wVar ); + } + else + fprintf( yyc, " _PUSHLOCAL, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pLocals, wVar )->szName ); + lPCodePos += 3; + } + break; + + case _PUSHLOCALREF: + { + SHORT wVar = * ( ( SHORT *) &(pFunc->pCode )[ lPCodePos + 1 ] ); + /* Variable with negative order are local variables + * referenced in a codeblock -handle it with care + */ + if( iNestedCodeblock ) + { + /* we are accesing variables within a codeblock */ + /* the names of codeblock variable are lost */ + if( wVar < 0 ) + fprintf( yyc, " _PUSHLOCALREF, %i, %i,\t/* localvar%i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + -wVar ); + else + fprintf( yyc, " _PUSHLOCALREF, %i, %i,\t/* codeblockvar%i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + wVar ); + } + else + fprintf( yyc, " _PUSHLOCALREF, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pLocals, wVar )->szName ); + lPCodePos += 3; + } + break; + + case _PUSHLONG: + fprintf( yyc, " _PUSHLONG, %i, %i, %i, %i, /* %li */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + pFunc->pCode[ lPCodePos + 3 ], + pFunc->pCode[ lPCodePos + 4 ], + *( ( long * ) &( pFunc->pCode[ lPCodePos + 1 ] ) ) ); + lPCodePos +=( 1 + sizeof(long) ); + break; + + case _PUSHMEMVAR: + wVar = pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _PUSHMEMVAR, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetSymbolOrd( wVar + ! _iStartProc )->szName ); + lPCodePos += 3; + break; + + case _PUSHMEMVARREF: + wVar = pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _PUSHMEMVARREF, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetSymbolOrd( wVar + ! _iStartProc )->szName ); + lPCodePos += 3; + break; + + case _PUSHNIL: + fprintf( yyc, " _PUSHNIL,\n" ); + lPCodePos++; + break; + + case _PUSHSELF: + fprintf( yyc, " _PUSHSELF,\n" ); + lPCodePos++; + break; + + case _PUSHSTATIC: + wVar = pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _PUSHSTATIC, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pStatics, wVar )->szName ); + lPCodePos += 3; + break; + + case _PUSHSTATICREF: + wVar = pFunc->pCode[ lPCodePos + 1 ] + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _PUSHSTATICREF, %i, %i,\t/* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetVar( pFunc->pStatics, wVar )->szName ); + lPCodePos += 3; + break; + + case _PUSHSTR: + wLen = pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _PUSHSTR, %i, %i, /* %i */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], wLen ); + lPCodePos +=3; + while( wLen-- ) + { + chr = pFunc->pCode[ lPCodePos++ ]; + if( chr == '\'' || chr == '\\') + fprintf( yyc, " \'\\%c\',", chr ); + else + fprintf( yyc, " \'%c\',", chr ); + } + fprintf( yyc, "\n" ); + break; + + case _PUSHSYM: + wSym = pFunc->pCode[ lPCodePos + 1 ] + + pFunc->pCode[ lPCodePos + 2 ] * 256; + fprintf( yyc, " _PUSHSYM, %i, %i, /* %s */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ], + GetSymbolOrd( wSym + ! _iStartProc )->szName ); + lPCodePos += 3; + break; + + case _RETVALUE: + fprintf( yyc, " _RETVALUE,\n" ); + lPCodePos++; + break; + + case _SFRAME: /* we only generate it if there are statics in the PRG */ + if( wStatics ) + { + w = GetSymbolPos( "_INITSTATICS" ) - ( _iStartProc ? 1: 2 ); + fprintf( yyc, " _SFRAME, %i, %i,\t\t/* symbol _INITSTATICS */\n", + LOBYTE( w ), HIBYTE( w ) ); + } + lPCodePos += 3; + break; + + case _STATICS: + fprintf( yyc, " _STATICS, %i, %i,\t\t/* symbol _INITSTATICS */\n", + pFunc->pCode[ lPCodePos + 1 ], + pFunc->pCode[ lPCodePos + 2 ] ); + lPCodePos += 3; + break; + + case _TRUE: + fprintf( yyc, " _TRUE,\n" ); + lPCodePos++; + break; + + case _ZERO: + fprintf( yyc, " _ZERO,\n" ); + lPCodePos++; + break; + + default: + printf( "Incorrect pcode value!\n" ); + lPCodePos = pFunc->lPCodePos; + break; + } + } + + fprintf( yyc, "/* %05li */", lPCodePos ); + fprintf( yyc, " _ENDPROC };\n\n" ); + fprintf( yyc, " VirtualMachine( pcode, symbols );\n}\n\n" ); + pFunc = pFunc->pNext; + } + fclose( yyc ); + + if( ! _iQuiet ) + printf( "%s -> done!\n", szFileName ); +} + +void GenExterns( void ) /* generates the symbols for the EXTERN names */ +{ + PEXTERN pLast = pExterns, pDelete; + + if( pExterns ) + { + while( pLast ) + { + PushSymbol( pLast->szName, 1 ); + pLast = pLast->pNext; + } + pLast = pExterns; + pDelete = pExterns; + while( pLast ) + { + pLast = pLast->pNext; + OurFree( pDelete ); + pDelete = pLast; + } + pExterns = 0; + } +} + +void GenReturn( WORD wOffset ) /* generates a return offset to later on fill it with the proper exiting pcode address */ +{ + PRETURN pReturn = ( PRETURN ) OurMalloc( sizeof( _RETURN ) ), pLast; + + pReturn->wOffset = wOffset; + pReturn->pNext = 0; + + if( ! pReturns ) + pReturns = pReturn; + else + { + pLast = pReturns; + while( pLast->pNext ) + pLast = pLast->pNext; + pLast->pNext = pReturn; + } +} + +PFUNCTION GetFuncall( char * szFunctionName ) /* returns a previously called defined function */ +{ + PFUNCTION pFunc = funcalls.pFirst; + + while( pFunc ) + { + if( ! strcmp( pFunc->szName, szFunctionName ) ) + return pFunc; + else + { + if( pFunc->pNext ) + pFunc = pFunc->pNext; + else + return 0; + } + } + return 0; +} + +PFUNCTION GetFunction( char * szFunctionName ) /* returns a previously defined function */ +{ + PFUNCTION pFunc = functions.pFirst; + + while( pFunc ) + { + if( ! strcmp( pFunc->szName, szFunctionName ) ) + return pFunc; + else + { + if( pFunc->pNext ) + pFunc = pFunc->pNext; + else + return 0; + } + } + return 0; +} + +PVAR GetVar( PVAR pVars, WORD wOrder ) /* returns variable if defined or zero */ +{ + WORD w = 1; + + while( pVars->pNext && w++ < wOrder ) + pVars = pVars->pNext; + + return pVars; +} + +WORD GetVarPos( PVAR pVars, char * szVarName ) /* returns the order + 1 of a variable if defined or zero */ +{ + WORD wVar = 1; + + while( pVars ) + { + if( ! strcmp( pVars->szName, szVarName ) ) + return wVar; + else + { + if( pVars->pNext ) + { + pVars = pVars->pNext; + wVar++; + } + else + return 0; + } + } + return 0; +} + +int GetLocalVarPos( char * szVarName ) /* returns the order + 1 of a variable if defined or zero */ +{ + int iVar; + PFUNCTION pFunc =functions.pLast; + + if( pFunc->szName ) + /* we are in a function/procedure -we don't need any tricks */ + return GetVarPos( pFunc->pLocals, szVarName ); + else + { + /* we are in a codeblock */ + if( (iVar = GetVarPos( pFunc->pLocals, szVarName ) ) ) + /* this a current codeblock parameter */ + return iVar; + else + { + /* we have to check the list of nested codeblock up to a function + * where the codeblock is defined + */ + pFunc =pFunc->pOwner; + while( pFunc ) + { + iVar =GetVarPos( pFunc->pLocals, szVarName ); + if( iVar ) + { + if( pFunc->pOwner ) + /* this variable is defined in a parent codeblock + * It is not possible to access a parameter of a codeblock in which + * the current codeblock is defined + */ + GenError( ERR_OUTER_VAR, szVarName, NULL ); + else + { + /* We want to access a local variable defined in a function that + * owns this codeblock. We cannot access this variable in a normal + * way because at runtime the stack base will point to local + * variables of EVAL function. + * The codeblock cannot have static variables then we can use this + * structure to store temporarily all referenced local variables + */ + pFunc =functions.pLast; + + iVar =GetVarPos( pFunc->pStatics, szVarName ); + if( !iVar ) + { + /* this variable was not referenced yet - add it to the list */ + PVAR pVar; + + pVar =(PVAR) OurMalloc( sizeof(PVAR) ); + pVar->szName =szVarName; + pVar->pNext =NULL; + iVar =1; /* first variable */ + if( ! pFunc->pStatics ) + pFunc->pStatics = pVar; + else + { + PVAR pLastVar = pFunc->pStatics; + + ++iVar; /* this will be at least second variable */ + while( pLastVar->pNext ) + { + pLastVar = pLastVar->pNext; + ++iVar; + } + pLastVar->pNext = pVar; + } + } + /* Use negative order to signal that we are accessing a local + * variable from a codeblock + */ + return (-iVar); + } + } + pFunc =pFunc->pOwner; + } + } + } + return 0; +} + +PCOMSYMBOL GetSymbol( char * szSymbolName ) /* returns a symbol pointer from the symbol table */ +{ + PCOMSYMBOL pSym = symbols.pFirst; + + while( pSym ) + { + if( ! strcmp( pSym->szName, szSymbolName ) && pSym != symbols.pFirst ) + return pSym; + else + { + if( pSym->pNext ) + pSym = pSym->pNext; + else + return 0; + } + } + return 0; +} + +PCOMSYMBOL GetSymbolOrd( WORD wSymbol ) /* returns a symbol based on its index on the symbol table */ +{ + PCOMSYMBOL pSym = symbols.pFirst; + WORD w = 0; + + while( w++ < wSymbol && pSym->pNext ) + pSym = pSym->pNext; + + return pSym; +} + +WORD GetSymbolPos( char * szSymbolName ) /* return 0 if not found or order + 1 */ +{ + PCOMSYMBOL pSym = symbols.pFirst; + WORD wSymbol = 1; + + while( pSym ) + { + if( ! strcmp( pSym->szName, szSymbolName ) && pSym != symbols.pFirst ) + return wSymbol; + else + { + if( pSym->pNext ) + { + pSym = pSym->pNext; + wSymbol++; + } + else + return 0; + } + } + return 0; +} + +void Inc( void ) +{ + GenPCode1( _INC ); +} + +WORD Jump( int iOffset ) +{ + GenPCode3( _JUMP, LOBYTE( iOffset ), HIBYTE( iOffset ) ); + + return functions.pLast->lPCodePos - 2; +} + +WORD JumpFalse( int iOffset ) +{ + GenPCode3( _JUMPFALSE, LOBYTE( iOffset ), HIBYTE( iOffset ) ); + + return functions.pLast->lPCodePos - 2; +} + +void JumpThere( int iOffset, WORD wTo ) +{ + BYTE * pCode = functions.pLast->pCode; + + pCode[ ( WORD ) iOffset ] = LOBYTE( wTo - iOffset + 1 ); + pCode[ ( WORD ) iOffset + 1 ] = HIBYTE( wTo - iOffset + 1 ); +} + +void JumpHere( int iOffset ) +{ + JumpThere( iOffset, functions.pLast->lPCodePos ); +} + +WORD JumpTrue( int iOffset ) +{ + GenPCode3( _JUMPTRUE, LOBYTE( iOffset ), HIBYTE( iOffset ) ); + + return functions.pLast->lPCodePos - 2; +} + +void Line( void ) /* generates the pcode with the currently compiled source code line */ +{ + if( _iLineNumbers ) + GenPCode3( _LINE, LOBYTE( iLine ), HIBYTE( iLine ) ); +} + +void LineBody( void ) /* generates the pcode with the currently compiled source code line */ +{ + /* This line can be placed inside a procedure or function only */ + if( ! _iStartProc && functions.iCount <= 1 ) + { + GenError( ERR_OUTSIDE, NULL, NULL ); + } + functions.pLast->bFlags |= FUN_STATEMENTS; + if( _iLineNumbers ) + GenPCode3( _LINE, LOBYTE( iLine ), HIBYTE( iLine ) ); +} + +void Message( char * szMsgName ) /* sends a message to an object */ +{ + WORD wSym = GetSymbolPos( szMsgName ); + + if( ! wSym ) /* the symbol was not found on the symbol table */ + { + AddSymbol( szMsgName ); + wSym = symbols.iCount; + } + GetSymbolOrd( wSym - 1 )->cScope = FS_MESSAGE; + wSym -= _iStartProc ? 1: 2; + GenPCode3( _MESSAGE, LOBYTE( wSym ), HIBYTE( wSym ) ); +} + +void PopDefId( char * szVarName ) /* generates the pcode to pop a default value from the virtual machine stack onto a variable */ +{ + WORD wVar; + + if( functions.pLast && ( wVar = GetVarPos( functions.pLast->pLocals, szVarName ) ) ) + GenPCode3( _POPLOCAL, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else if( functions.pLast && ( wVar = GetVarPos( functions.pLast->pStatics, szVarName ) ) ) + { + wVar += functions.pLast->wStaticsBase; /* number of already defined statics for this PRG */ + GenPCode3( _POPDEFSTAT, LOBYTE( wVar ), HIBYTE( wVar ) ); + } + else if( ( wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2 ) ) + GenPCode3( _POPMEMVAR, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else + { + AddSymbol( szVarName ); + wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2; + GenPCode3( _POPMEMVAR, LOBYTE( wVar ), HIBYTE( wVar ) ); + } +} + +void PopId( char * szVarName ) /* generates the pcode to pop a value from the virtual machine stack onto a variable */ +{ + WORD wVar; + + if( ( wVar = GetLocalVarPos( szVarName ) ) ) + GenPCode3( _POPLOCAL, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else if( ( wVar = GetVarPos( functions.pLast->pStatics, szVarName ) ) ) + { + wVar += functions.pLast->wStaticsBase; /* number of already defined statics for this PRG */ + GenPCode3( _POPSTATIC, LOBYTE( wVar ), HIBYTE( wVar ) ); + } + else if( ( wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2 ) ) + GenPCode3( _POPMEMVAR, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else + { + AddSymbol( szVarName ); + wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2; + GenPCode3( _POPMEMVAR, LOBYTE( wVar ), HIBYTE( wVar ) ); + } +} + +void PushId( char * szVarName ) /* generates the pcode to push a variable value to the virtual machine stack */ +{ + WORD wVar; + + if( ( wVar = GetLocalVarPos( szVarName ) ) ) + GenPCode3( _PUSHLOCAL, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else if( ( wVar = GetVarPos( functions.pLast->pStatics, szVarName ) ) ) + { + wVar += functions.pLast->wStaticsBase; /* number of already defined statics for this PRG */ + GenPCode3( _PUSHSTATIC, LOBYTE( wVar ), HIBYTE( wVar ) ); + } + else if( ( wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2 ) ) + GenPCode3( _PUSHMEMVAR, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else + { + AddSymbol( szVarName ); + wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2; + GenPCode3( _PUSHMEMVAR, LOBYTE( wVar ), HIBYTE( wVar ) ); + } +} + +void PushIdByRef( char * szVarName ) /* generates the pcode to push a variable by reference to the virtual machine stack */ +{ + WORD wVar; + + if( ( wVar = GetLocalVarPos( szVarName ) ) ) + GenPCode3( _PUSHLOCALREF, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else if( ( wVar = GetVarPos( functions.pLast->pStatics, szVarName ) ) ) + GenPCode3( _PUSHSTATICREF, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else if( ( wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2) ) + GenPCode3( _PUSHMEMVARREF, LOBYTE( wVar ), HIBYTE( wVar ) ); + + else + { + AddSymbol( szVarName ); + wVar = GetSymbolPos( szVarName ) - _iStartProc ? 1: 2; + GenPCode3( _PUSHMEMVARREF, LOBYTE( wVar ), HIBYTE( wVar ) ); + } +} + +void PushLogical( int iTrueFalse ) /* pushes a logical value on the virtual machine stack */ +{ + if( iTrueFalse ) + GenPCode1( _TRUE ); + else + GenPCode1( _FALSE ); +} + +void PushNil( void ) +{ + GenPCode1( _PUSHNIL ); +} + +/* generates the pcode to push a double number on the virtual machine stack */ +void PushDouble( double dNumber ) +{ + if( dNumber ) + { + GenPCode1( _PUSHDOUBLE ); + GenPCodeN( ( BYTE * ) &dNumber, sizeof( double ) ); + } + else + GenPCode1( _ZERO ); +} + +/* generates the pcode to push a integer number on the virtual machine stack */ +void PushInteger( int iNumber ) +{ + if( iNumber ) + GenPCode3( _PUSHINT, LOBYTE( ( WORD ) iNumber ), HIBYTE( ( WORD ) iNumber ) ); + else + GenPCode1( _ZERO ); +} + +/* generates the pcode to push a long number on the virtual machine stack */ +void PushLong( long lNumber ) +{ + if( lNumber ) + { + GenPCode1( _PUSHLONG ); + GenPCode1( ( ( char * ) &lNumber )[ 0 ] ); + GenPCode1( ( ( char * ) &lNumber )[ 1 ] ); + GenPCode1( ( ( char * ) &lNumber )[ 2 ] ); + GenPCode1( ( ( char * ) &lNumber )[ 3 ] ); + } + else + GenPCode1( _ZERO ); +} + +/* generates the pcode to push a string on the virtual machine stack */ +void PushString( char * szText ) +{ + WORD wStrLen = strlen( szText ); + + GenPCode3( _PUSHSTR, LOBYTE(wStrLen), HIBYTE(wStrLen) ); + GenPCodeN( szText, wStrLen ); +} + +/* generates the pcode to push a symbol on the virtual machine stack */ +void PushSymbol( char * szSymbolName, int iIsFunction ) +{ + WORD wSym = GetSymbolPos( szSymbolName ); /* returns 1, 2, ... */ + + if( wSym == 1 ) /* default module name procedure */ + wSym = 0; + + if( ! wSym ) /* the symbol was not found on the symbol table */ + { + AddSymbol( szSymbolName ); + wSym = symbols.iCount; + if( iIsFunction ) + AddFunCall( szSymbolName ); + } + else + { + if( iIsFunction && ! GetFuncall( szSymbolName ) ) + AddFunCall( szSymbolName ); + } + wSym -= _iStartProc ? 1: 2; + + if( ! iIsFunction ) + GetSymbolOrd( wSym )->cScope = FS_MESSAGE; + + GenPCode3( _PUSHSYM, LOBYTE( wSym ), HIBYTE( wSym ) ); +} + +void CheckDuplVars( PVAR pVar, char * szVarName, int iVarScope ) +{ + while( pVar ) + { + if( ! strcmp( pVar->szName, szVarName ) ) + { + if( iVarScope != VS_PARAMETER ) + --iLine; + GenError( ERR_VAR_DUPL, szVarName, NULL ); + } + else + pVar =pVar->pNext; + } +} + +void CheckStatics( void ) /* creates the _STATICS function if there are any static defined */ +{ + /* there are defined statics variables but no globals ones */ + if( wStatics && ! GetFunction( "_INITSTATICS" ) ) + FunDef( "_INITSTATICS", FS_INIT ); +} + +void Dec( void ) +{ + GenPCode1( _DEC ); +} + +void DimArray( WORD wDimensions ) +{ + GenPCode3( _DIMARRAY, LOBYTE( wDimensions ), HIBYTE( wDimensions ) ); +} + +void Do( BYTE bParams ) +{ + GenPCode3( _DO, bParams, 0 ); +} + +void FixElseIfs( void * pFixElseIfs ) +{ + PELSEIF pFix = ( PELSEIF ) pFixElseIfs; + + while( pFix ) + { + JumpHere( pFix->wOffset ); + pFix = pFix->pNext; + } +} + +void FixReturns( void ) /* fixes all last defined function returns jumps offsets */ +{ + PRETURN pLast = pReturns, pDelete; + + if( pReturns ) + { + while( pLast ) + { + JumpHere( pLast->wOffset ); + pLast = pLast->pNext; + } + pLast = pReturns; + pDelete = pReturns; + while( pLast ) + { + pLast = pLast->pNext; + OurFree( pDelete ); + pDelete = pLast; + } + pReturns = 0; + } +} + +void Function( BYTE bParams ) +{ + GenPCode3( _FUNCTION, bParams, 0 ); +} + +void GenArray( WORD wElements ) +{ + GenPCode3( _GENARRAY, LOBYTE( wElements ), HIBYTE( wElements ) ); +} + +void GenPCode1( BYTE byte ) +{ + PFUNCTION pFunc = functions.pLast; /* get the currently defined Clipper function */ + + if( ! pFunc->pCode ) /* has been created the memory block to hold the pcode ? */ + { + pFunc->pCode = (BYTE *) OurMalloc( PCODE_CHUNK ); + pFunc->lPCodeSize = PCODE_CHUNK; + pFunc->lPCodePos = 0; + } + else + if( ( pFunc->lPCodeSize - pFunc->lPCodePos ) < 1 ) + pFunc->pCode = (BYTE *)OurRealloc( pFunc->pCode, pFunc->lPCodeSize += PCODE_CHUNK ); + + pFunc->pCode[ pFunc->lPCodePos++ ] = byte; +} + +void GenPCode3( BYTE byte1, BYTE byte2, BYTE byte3 ) +{ + PFUNCTION pFunc = functions.pLast; /* get the currently defined Clipper function */ + + if( ! pFunc->pCode ) /* has been created the memory block to hold the pcode ? */ + { + pFunc->pCode = (BYTE *) OurMalloc( PCODE_CHUNK ); + pFunc->lPCodeSize = PCODE_CHUNK; + pFunc->lPCodePos = 0; + } + else + if( ( pFunc->lPCodeSize - pFunc->lPCodePos ) < 3 ) + pFunc->pCode = (BYTE *) OurRealloc( pFunc->pCode, pFunc->lPCodeSize += PCODE_CHUNK ); + + pFunc->pCode[ pFunc->lPCodePos++ ] = byte1; + pFunc->pCode[ pFunc->lPCodePos++ ] = byte2; + pFunc->pCode[ pFunc->lPCodePos++ ] = byte3; +} + +void GenPCodeN( BYTE * pBuffer, WORD wSize ) +{ + PFUNCTION pFunc = functions.pLast; /* get the currently defined Clipper function */ + + if( ! pFunc->pCode ) /* has been created the memory block to hold the pcode ? */ + { + pFunc->lPCodeSize = ((wSize / PCODE_CHUNK) +1) * PCODE_CHUNK; + pFunc->pCode = (BYTE *) OurMalloc( pFunc->lPCodeSize ); + pFunc->lPCodePos = 0; + } + else if( pFunc->lPCodePos + wSize > pFunc->lPCodeSize ) + { + /* not enough free space in pcode buffer - increase it */ + pFunc->lPCodeSize +=( ((wSize / PCODE_CHUNK) +1) * PCODE_CHUNK ); + pFunc->pCode = (BYTE *) OurRealloc( pFunc->pCode, pFunc->lPCodeSize ); + } + + memcpy( pFunc->pCode+pFunc->lPCodePos, pBuffer, wSize ); + pFunc->lPCodePos +=wSize; +} + +char * SetData( char * szMsg ) /* generates an underscore-symbol name for a data assignment */ +{ + char * szResult = ( char * ) OurMalloc( strlen( szMsg ) + 2 ); + + strcpy( szResult, "_" ); + strcat( szResult, szMsg ); + + return szResult; +} + +void SetFrame( void ) /* generates the proper _FRAME values */ +{ + BYTE * pCode = functions.pLast->pCode; + PVAR pLocal = functions.pLast->pLocals; + BYTE bLocals = 0; + + while( pLocal ) + { + pLocal = pLocal->pNext; + bLocals++; + } + + pCode[ 1 ] = bLocals - functions.pLast->wParamCount; + pCode[ 2 ] = functions.pLast->wParamCount; +} + +/* + * Start a new fake-function that will hold pcodes for a codeblock +*/ +void CodeBlockStart() +{ + PFUNCTION pFunc; + + pFunc = ( PFUNCTION ) OurMalloc( sizeof( _FUNC ) ); + + pFunc->szName = NULL; + pFunc->cScope = FS_STATIC; + pFunc->pLocals = 0; + pFunc->pStatics = 0; + pFunc->pFields = 0; + pFunc->lPCodePos = 0; + pFunc->lPCodeSize = 0; + pFunc->pCode = 0; + pFunc->pNext = 0; + pFunc->wParamCount = 0; + pFunc->wStaticsBase = functions.pLast->wStaticsBase; + pFunc->pOwner = functions.pLast; + pFunc->bFlags = 0; + + functions.pLast = pFunc; +} + +void CodeBlockEnd() +{ + PFUNCTION pCodeblock; /* pointer to the current codeblock */ + PFUNCTION pFunc; /* poiter to a function that owns a codeblock */ + WORD wSize; + WORD wLocals = 0; /* number of referenced local variables */ + WORD wPos; + PVAR pVar, pFree; + + pCodeblock =functions.pLast; + + /* return to pcode buffer of function/codeblock in which the current + * codeblock was defined + */ + functions.pLast =pCodeblock->pOwner; + + /* find the function that owns the codeblock */ + pFunc =pCodeblock->pOwner; + while( pFunc->pOwner ) + pFunc =pFunc->pOwner; + + /* generate a proper codeblock frame with a codeblock size and with + * a number of expected parameters + */ + /*QUESTION: would be 64kB enough for a codeblock size? + * we are assuming now a WORD for a size of codeblock + */ + + /* Count the number of referenced local variables */ + pVar =pCodeblock->pStatics; + while( pVar ) + { + pVar =pVar->pNext; + ++wLocals; + } + + /*NOTE: 8 = _PUSHBLOCK + WORD(size) + WORD(wParams) + WORD(wLocals) +_ENDBLOCK */ + wSize =( WORD ) pCodeblock->lPCodePos +8 +wLocals*2; + GenPCode3( _PUSHBLOCK, LOBYTE(wSize), HIBYTE(wSize) ); + GenPCode1( LOBYTE(pCodeblock->wParamCount) ); + GenPCode1( HIBYTE(pCodeblock->wParamCount) ); + GenPCode1( LOBYTE(wLocals) ); + GenPCode1( HIBYTE(wLocals) ); + + /* generate the table of referenced local variables */ + pVar =pCodeblock->pStatics; + while( wLocals-- ) + { + wPos =GetVarPos( pFunc->pLocals, pVar->szName ); + GenPCode1( LOBYTE(wPos) ); + GenPCode1( HIBYTE(wPos) ); + pFree =pVar; + pVar =pVar->pNext; + OurFree( pFree->szName ); + OurFree( pFree ); + } + + GenPCodeN( pCodeblock->pCode, pCodeblock->lPCodePos ); + GenPCode1( _ENDBLOCK ); /* finish the codeblock */ + + /* this fake-function is no longer needed */ + OurFree( pCodeblock->pCode ) + pVar =pCodeblock->pLocals; + while( pVar ) + { + /* free used variables */ + pFree =pVar; + pVar =pVar->pNext; + OurFree( pFree->szName ); + OurFree( pFree ); + } + OurFree( pCodeblock ); +} + +/* Set the name of an alias for the list of previously declared FIELDs + * + * szAlias -> name of the alias + * iField -> position of the first FIELD name to change + */ +void SetAlias( char * szAlias, int iField ) +{ + PVAR pVar; + + pVar = functions.pLast->pFields; + while( iField-- && pVar ) + pVar = pVar->pNext; + + while( pVar ) + { + pVar->szAlias =szAlias; + pVar =pVar->pNext; + } +} + +/* This functions counts the number of FIELD declaration in a function + * We will required this information in SetAlias function + */ +int FieldsCount() +{ + int iFields = 0; + PVAR pVar = functions.pLast->pFields; + + while( pVar ) + { + ++iFields; + pVar =pVar->pNext; + } + + return iFields; +} + +void * OurMalloc( LONG lSize ) +{ + void * pMem = malloc( lSize ); + + if( ! pMem ) + yyerror( "\nCan't allocate memory!\n" ); + + return pMem; +} + +void * OurRealloc( void * p, LONG lSize ) +{ + void * pMem = realloc( p, lSize ); + + if( ! pMem ) + yyerror( "\nCan't reallocate memory!\n" ); + + return pMem; +} + +#ifndef HAVE_STRUPR +char * strupr( char * p ) +{ + char * p1; + + for ( p1 = p; * p1; p1++ ) + * p1 = toupper( * p1 ); + return( p ); +} +#endif + + diff --git a/harbour/source/rtl/arrays.c b/harbour/source/rtl/arrays.c new file mode 100644 index 0000000000..20c402b55c --- /dev/null +++ b/harbour/source/rtl/arrays.c @@ -0,0 +1,473 @@ +#include +#include + +extern STACK stack; +extern SYMBOL symEval; + +// ------------- +// Internal +// ------------- +void Array( PITEM pItem, ULONG ulLen ) /* creates a new array */ +{ + PBASEARRAY pBaseArray = ( PBASEARRAY ) _xgrab( sizeof( BASEARRAY ) ); + ULONG ul; + + ItemRelease( pItem ); + + pItem->wType = IT_ARRAY; + + if( ulLen ) + pBaseArray->pItems = ( PITEM ) _xgrab( sizeof( ITEM ) * ulLen ); + else + pBaseArray->pItems = 0; + + pBaseArray->ulLen = ulLen; + pBaseArray->wHolders = 1; + pBaseArray->wClass = 0; + + for( ul = 0; ul < ulLen; ul++ ) + ( pBaseArray->pItems + ul )->wType = IT_NIL; + + pItem->value.pBaseArray = pBaseArray; +} + +void ArrayAdd( PITEM pArray, PITEM pValue ) +{ + PBASEARRAY pBaseArray = ( PBASEARRAY ) pArray->value.pBaseArray; + ArraySize( pArray, pBaseArray->ulLen + 1 ); + ItemCopy( pBaseArray->pItems + ( pBaseArray->ulLen - 1 ), pValue ); +} + +void ArrayGet( PITEM pArray, ULONG ulIndex, PITEM pItem ) +{ + if( IS_ARRAY( pArray ) ) + { + if( ulIndex <= ( unsigned ) ArrayLen( pArray ) ) + ItemCopy( pItem, + ( ( PBASEARRAY ) pArray->value.pBaseArray )->pItems + ( ulIndex - 1 ) ); + else + { + printf( "Error: Array access out of bounds\n" ); + exit( 1 ); + } + } + /* QUESTION: Should we raise an error here ? */ +} + +char * ArrayGetString( PITEM pArray, ULONG ulIndex ) +{ + PITEM pItem, pError; + + if( IS_ARRAY( pArray ) ) + { + if( ulIndex <= ( unsigned ) ArrayLen( pArray ) ) + { + pItem = ( ( PBASEARRAY ) pArray->value.pBaseArray )->pItems + ulIndex - 1; + + if( IS_STRING( pItem ) ) + return pItem->value.szText; + else + return ""; + } + else + { + pError = _errNew(); + _errPutDescription( pError, "Bound error: Array access" ); + _errLaunch( pError ); + _errRelease( pError ); + } + } + return ""; +} + +ULONG ArrayGetStringLen( PITEM pArray, ULONG ulIndex ) +{ + PITEM pItem, pError; + + if( IS_ARRAY( pArray ) ) + { + if( ulIndex <= ( unsigned ) ArrayLen( pArray ) ) + { + pItem = ( ( PBASEARRAY ) pArray->value.pBaseArray )->pItems + ulIndex - 1; + + if( IS_STRING( pItem ) ) + return pItem->wLength; + else + return 0; + } + else + { + pError = _errNew(); + _errPutDescription( pError, "Bound error: Array access" ); + _errLaunch( pError ); + _errRelease( pError ); + } + } + return 0; +} + +void ArrayLast( PITEM pArray, PITEM pResult ) +{ + if( ( ( PBASEARRAY ) pArray->value.pBaseArray )->ulLen ) + ItemCopy( pResult, ( ( PBASEARRAY ) pArray->value.pBaseArray )->pItems + + ( ( ( PBASEARRAY ) pArray->value.pBaseArray )->ulLen - 1 ) ); + /* QUESTION: Should we raise an error here ? */ +} + +int ArrayLen( PITEM pArray ) +{ + if( IS_ARRAY( pArray ) ) + return ( ( PBASEARRAY ) pArray->value.pBaseArray )->ulLen; + + /* QUESTION: Should we raise an error here ? */ + return 0; +} + +void ArraySet( PITEM pArray, ULONG ulIndex, PITEM pItem ) +{ + if( IS_ARRAY( pArray ) ) + { + if( ulIndex <= ( unsigned ) ArrayLen( pArray ) ) + ItemCopy( ( ( PBASEARRAY ) pArray->value.pBaseArray )->pItems + ( ulIndex - 1 ), + pItem ); + else + { + printf( "Error: Array access out of bounds\n" ); + exit( 1 ); + } + } + /* QUESTION: Should we raise an error here ? */ +} + +void ArraySize( PITEM pArray, ULONG ulLen ) +{ + if ( IS_ARRAY( pArray ) ) + { + PBASEARRAY pBaseArray = ( PBASEARRAY ) pArray->value.pBaseArray; + ULONG ul; + + if( ! pBaseArray->ulLen ) + { + pBaseArray->pItems = ( PITEM ) _xgrab( ulLen * sizeof( ITEM ) ); + for ( ul = 0; ul < ulLen; ul ++ ) + ( pBaseArray->pItems + ul )->wType = IT_NIL; + } + else + { + if( pBaseArray->ulLen < ulLen ) + { + pBaseArray->pItems = ( PITEM )_xrealloc( pBaseArray->pItems, + sizeof( ITEM ) * ulLen ); + + /* set value for new items */ + for( ul = pBaseArray->ulLen; ul < ulLen; ul++ ) + ( pBaseArray->pItems + ul )->wType = IT_NIL; + } + else if( pBaseArray->ulLen > ulLen ) + { + /* release old items */ + for( ul = ulLen; ul < pBaseArray->ulLen; ul++ ) + ItemRelease( pBaseArray->pItems + ul ); + + pBaseArray->pItems = ( PITEM )_xrealloc( pBaseArray->pItems, + sizeof( ITEM ) * ulLen ); + } + } + pBaseArray->ulLen = ulLen; + } + /* QUESTION: Should we raise an error here ? */ +} + +void ArrayFill( PITEM pArray, PITEM pValue, ULONG ulStart, ULONG ulCount ) +{ + if ( IS_ARRAY( pArray ) ) + { + PBASEARRAY pBaseArray; + ULONG ulLen = ArrayLen( pArray ); + + if ( ulStart == 0 ) /* if parameter is missing */ + ulStart = 1; + + if ( ulCount == 0 ) /* if parameter is missing */ + ulCount = ulLen - ulStart + 1; + + if ( ulStart + ulCount > ulLen ) /* check range */ + ulCount = ulLen - ulStart + 1; + + pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; + + for ( ; ulCount > 0; ulCount --, ulStart ++ ) /* set value items */ + ItemCopy( pBaseArray->pItems + ( ulStart - 1 ), pValue ); + } + /* QUESTION: Should we raise an error here ? */ +} + +void ArrayDel( PITEM pArray, ULONG ulIndex ) +{ + if ( IS_ARRAY( pArray ) ) + { + ULONG ulLen = ArrayLen( pArray ); + + if ( ulIndex > 0 && ulIndex <= ulLen ) + { + PBASEARRAY pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; + + ItemRelease( pBaseArray->pItems + ( ulIndex - 1 ) ); + + for ( ulIndex --; ulIndex < ulLen; ulIndex ++ ) /* move items */ + ItemCopy( pBaseArray->pItems + ulIndex, + pBaseArray->pItems + ( ulIndex + 1 ) ); + + ItemRelease( pBaseArray->pItems + ( ulLen - 1 ) ); +// ( pBaseArray->pItems + ( ulLen - 1 ) )->wType = IT_NIL; + } + } + /* QUESTION: Should we raise an error here ? */ +} + +void ArrayIns( PITEM pArray, ULONG ulIndex ) +{ + if ( IS_ARRAY( pArray ) ) + { + ULONG ulLen = ArrayLen( pArray ); + + if ( ulIndex > 0 && ulIndex <= ulLen ) + { + PBASEARRAY pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; + + ItemRelease( pBaseArray->pItems + ( ulLen - 1 ) ); + + for ( ulLen --; ulLen >= ulIndex; ulLen -- ) /* move items */ + ItemCopy( pBaseArray->pItems + ulLen, + pBaseArray->pItems + ( ulLen - 1 ) ); + + ItemRelease( pBaseArray->pItems + ulLen ); +// ( pBaseArray->pItems + ulLen )->wType = IT_NIL; /* set nil value */ + } + } +} + +int ArrayScan( PITEM pArray, PITEM pValue, ULONG ulStart, ULONG ulCount ) +{ + if ( IS_ARRAY( pArray ) && pValue->wType != IT_NIL ) + { + int iRet = 0; + PBASEARRAY pBaseArray; + ULONG ulLen = ArrayLen( pArray ); + + if ( ulStart == 0 ) /* if parameter is missing */ + ulStart = 1; + + if ( ulCount == 0 ) /* if parameter is missing */ + ulCount = ulLen - ulStart + 1; + + if ( ulStart + ulCount > ulLen ) /* check range */ + ulCount = ulLen - ulStart + 1; + + pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; + + for ( ulStart --; ulCount > 0; ulCount --, ulStart ++ ) + { + PITEM pItem = pBaseArray->pItems + ulStart; + + if ( pValue->wType == IT_BLOCK ) + { + PushSymbol( &symEval ); + Push( pValue ); + Push( pItem ); + Do( 1 ); + if ( stack.Return.value.iLogical ) + iRet = 1; + } + else + { + if ( pValue->wType == pItem->wType ) + { + switch( pItem->wType ) + { + case IT_INTEGER : + iRet = ( pValue->value.iNumber == pItem->value.iNumber ); + break; + + case IT_LONG : + iRet = ( pValue->value.lNumber == pItem->value.lNumber ); + break; + + case IT_DOUBLE : + iRet = ( pValue->value.dNumber == pItem->value.dNumber ); + break; + + case IT_DATE : + iRet = ( pValue->value.lDate == pItem->value.lDate ); + break; + + case IT_LOGICAL : + iRet = ( pValue->value.iLogical == pItem->value.iLogical ); + break; + + case IT_STRING : + iRet = ( OurStrCmp( pValue, pItem ) == 0 ); + break; + } + } + } + if ( iRet ) + return ulStart + 1; /* arrays start from 1 */ + } + } + return 0; +} + +void ArrayEval( PITEM pArray, PITEM bBlock, ULONG ulStart, ULONG ulCount ) +{ + if ( IS_ARRAY( pArray ) && IS_BLOCK( bBlock ) ) + { + PBASEARRAY pBaseArray; + ULONG ulLen = ArrayLen( pArray ); + + if ( ulStart == 0 ) /* if parameter is missing */ + ulStart = 1; + + if ( ulCount == 0 ) /* if parameter is missing */ + ulCount = ulLen - ulStart + 1; + + if ( ulStart + ulCount > ulLen ) /* check range */ + ulCount = ulLen - ulStart + 1; + + pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; + + for ( ulStart --; ulCount > 0; ulCount --, ulStart ++ ) + { + PITEM pItem = pBaseArray->pItems + ulStart; + + PushSymbol( &symEval ); + Push( bBlock ); + Push( pItem ); + Do( 1 ); + } + } +} + +void ArrayRelease( PITEM pArray ) +{ + if ( IS_ARRAY( pArray ) ) + { + ULONG ul, ulLen = ArrayLen( pArray ); + PBASEARRAY pBaseArray = ( PBASEARRAY )pArray->value.pBaseArray; + + for ( ul = 0; ul < ulLen; ul ++ ) + ItemRelease( pBaseArray->pItems + ul ); + + if( pBaseArray->pItems ) + _xfree( pBaseArray->pItems ); + _xfree( pBaseArray ); + + pArray->wType = IT_NIL; + pArray->value.pBaseArray = NULL; + } +} + +// ------------- +// HARBOUR +// ------------- +HARBOUR ARRAY( void ) +{ + Array( &stack.Return, _parnl( 1 ) ); +} + +HARBOUR AADD( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + PITEM pValue = _param( 2, 0xFFFF ); /* any type */ + + if ( pArray ) + ArrayAdd( pArray, pValue ); + + ItemCopy( &stack.Return, pValue ); +} + +HARBOUR ASIZE( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + + if ( pArray ) + { + ArraySize( pArray, _parnl( 2 ) ); + ItemCopy( &stack.Return, pArray ); /* ASize() returns the array itself */ + } + else + _ret(); /* QUESTION: Should we raise an error here ? */ +} + +HARBOUR ATAIL( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + + if ( pArray ) + ArrayLast( pArray, &stack.Return ); + else + _ret(); /* QUESTION: Should we raise an error here ? */ +} + +HARBOUR AINS( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + + if ( pArray ) + { + ArrayIns( pArray, _parnl( 2 ) ); + ItemCopy( &stack.Return, pArray ); /* AIns() returns the array itself */ + } + else + _ret(); +} + +HARBOUR ADEL( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + + if ( pArray ) + { + ArrayDel( pArray, _parnl( 2 ) ); + ItemCopy( &stack.Return, pArray ); /* ADel() returns the array itself */ + } + else + _ret(); +} + +HARBOUR AFILL( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + + if ( pArray ) + { + ArrayFill( pArray, _param( 2, IT_ANY ), _parnl( 3 ), _parnl( 4 ) ); + ItemCopy( &stack.Return, pArray ); /* AFill() returns the array itself */ + } + else + _ret(); +} + +HARBOUR ASCAN( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + + if ( pArray ) + _retnl( ArrayScan( pArray, _param( 2, IT_ANY ), _parnl( 3 ), _parnl( 4 ) ) ); + else + _retnl( 0 ); +} + +HARBOUR AEVAL( void ) +{ + PITEM pArray = _param( 1, IT_ARRAY ); + PITEM bBlock = _param( 2, IT_BLOCK ); + + if ( pArray ) + { + ArrayEval( pArray, bBlock, _parnl( 3 ), _parnl( 4 ) ); + ItemCopy( &stack.Return, pArray ); /* AEval() returns the array itself */ + } + else + _ret(); +} diff --git a/harbour/source/rtl/classes.c b/harbour/source/rtl/classes.c new file mode 100644 index 0000000000..867094e3f4 --- /dev/null +++ b/harbour/source/rtl/classes.c @@ -0,0 +1,411 @@ +#include + +void Push( PITEM ); +void PushNil( void ); +void PushSymbol( PSYMBOL ); +void Do( WORD wParams ); + +#define MET_METHOD 0 +#define MET_DATA 1 +#define MET_CLASSDATA 2 +#define MET_INLINE 3 +#define MET_VIRTUAL 4 + +typedef struct +{ + void * pMessage; /* pointer to dynamic symbol when they get ready */ + HARBOURFUNC pFunction; + WORD wData; + WORD wScope; + WORD wInitValue; +} METHOD, * PMETHOD; + +typedef struct +{ + char * szName; + WORD wDatas; + PMETHOD pMethods; + WORD wMethods; + WORD wHashKey; + ITEM aClassDatas; /* Array for ClassDatas */ + ITEM aInlines; /* Array for inline codeblocks */ + ITEM aInitValues; /* Array for Datas init values */ +} CLASS, * PCLASS; + +#define BUCKET 4 + +extern STACK stack; +extern SYMBOL symEval; + +PCLASS pClasses = 0; +WORD wClasses = 0; +PMETHOD pMethod = 0; +PDYNSYM msgClassName = 0, msgClassH = 0, msgEval = 0; + +HARBOUR CLASSCREATE() /* cClassName, nDatas --> hClass */ +{ + if( ! pClasses ) + pClasses = ( PCLASS ) _xgrab( sizeof( CLASS ) ); + else + pClasses = ( PCLASS ) _xrealloc( pClasses, sizeof( CLASS ) * ( wClasses + 1 ) ); + + pClasses[ wClasses ].szName = ( char * ) _xgrab( _parclen( 1 ) + 1 ); + strcpy( pClasses[ wClasses ].szName, _parc( 1 ) ); + + pClasses[ wClasses ].wDatas = _parni( 2 ); + pClasses[ wClasses ].pMethods = ( PMETHOD ) _xgrab( 100 * sizeof( METHOD ) ); + pClasses[ wClasses ].wHashKey = 25; /* BUCKET = 4 repetitions */ + pClasses[ wClasses ].wMethods = 0; + + pClasses[ wClasses ].aClassDatas.wType = IT_NIL; + pClasses[ wClasses ].aInlines.wType = IT_NIL; + pClasses[ wClasses ].aInitValues.wType = IT_NIL; + + Array( &pClasses[ wClasses ].aClassDatas, 0 ); + Array( &pClasses[ wClasses ].aInlines, 0 ); + /* Array( &pClasses[ wClasses ].aInitValues, 0 ); */ + + memset( pClasses[ wClasses ].pMethods, 0, 100 * sizeof( METHOD ) ); + + _retni( ++wClasses ); +} + +static HARBOUR ClassH( void ) +{ + _retni( ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass ); +} + +char * _GetClassName( PITEM pObject ) +{ + char * szClassName; + + if( IS_ARRAY( pObject ) ) + { + if( ! ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass ) + szClassName = "ARRAY"; + else + szClassName = ( pClasses + ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass - 1 )->szName; + } + else /* built in types */ + { + switch( pObject->wType ) + { + case IT_NIL: + szClassName = "NIL"; + break; + + case IT_STRING: + szClassName = "CHARACTER"; + break; + + case IT_BLOCK: + szClassName = "BLOCK"; + break; + + case IT_SYMBOL: + szClassName = "SYMBOL"; + break; + + case IT_DATE: + szClassName = "DATE"; + break; + + case IT_INTEGER: + case IT_LONG: + case IT_DOUBLE: + szClassName = "NUMERIC"; + break; + + case IT_LOGICAL: + szClassName = "LOGICAL"; + break; + + default: + szClassName = "UNKNOWN"; + break; + } + } + return szClassName; +} + +static HARBOUR GetData( void ) +{ + ArrayGet( stack.pBase + 1, pMethod->wData, &stack.Return ); +} + +static HARBOUR SetData( void ) +{ + ArraySet( stack.pBase + 1, pMethod->wData, stack.pBase + 2 ); +} + +static HARBOUR GetClassData( void ) +{ + WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; + + if( wClass && wClass <= wClasses ) + ArrayGet( &pClasses[ wClass - 1 ].aClassDatas, pMethod->wData, &stack.Return ); +} + +static HARBOUR SetClassData( void ) +{ + WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; + + if( wClass && wClass <= wClasses ) + ArraySet( &pClasses[ wClass - 1 ].aClassDatas, pMethod->wData, stack.pBase + 2 ); +} + +static HARBOUR EvalInline( void ) +{ + ITEM block; + WORD wClass = ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass; + WORD w; + + ArrayGet( &pClasses[ wClass - 1 ].aInlines, pMethod->wData, &block ); + + PushSymbol( &symEval ); + Push( &block ); + for( w = 1; w <= _pcount(); w++ ) + Push( _param( w, IT_ANY ) ); + Do( _pcount() ); +} + +static HARBOUR Virtual( void ) +{ + _ret(); +} + +static HARBOUR ClassName( void ) +{ + WORD wClass = IS_ARRAY( stack.pBase + 1 ) ? + ( ( PBASEARRAY ) ( stack.pBase + 1 )->value.pBaseArray )->wClass: 0; + PITEM pItemRef; + + /* Variables by reference */ + if( ( ! wClass ) && IS_BYREF( stack.pBase + 1 ) ) + { + pItemRef = stack.pItems + ( stack.pBase + 1 )->value.wItem; + if( IS_ARRAY( pItemRef ) ) + wClass = ( ( PBASEARRAY ) pItemRef->value.pBaseArray )->wClass; + } + + if( wClass && ( wClass <= wClasses ) ) + _retc( pClasses[ wClass - 1 ].szName ); + else + { + switch( ( stack.pBase )->wType ) + { + case IT_ARRAY: + _retc( "ARRAY" ); + break; + + case IT_BLOCK: + _retc( "BLOCK" ); + break; + + case IT_STRING: + _retc( "CHARACTER" ); + break; + + case IT_DATE: + _retc( "DATE" ); + break; + + case IT_LOGICAL: + _retc( "LOGICAL" ); + break; + + case IT_INTEGER: + case IT_LONG: + case IT_DOUBLE: + _retc( "NUMERIC" ); + break; + + default: + _retc( "NIL" ); + break; + } + } +} + +static void DictRealloc( PCLASS pClass ) +{ + /* TODO: Implement it for very large classes */ + if( pClass ) + { + printf( "classes.c DictRealloc not implemented yet\n" ); + exit( 1 ); + } +} + +HARBOUR CLASSADD() /* hClass, cMessage, pFunction, nType */ +{ + WORD wClass = _parnl( 1 ); + WORD wType = _parni( 4 ); + PCLASS pClass; + PDYNSYM pMessage; + WORD wAt, wLimit; + + if( wClass && wClass <= wClasses ) + { + pClass = &pClasses[ wClass - 1 ]; + pMessage = GetDynSym( _parc( 2 ) ); + wAt = ( ( ( unsigned ) pMessage ) % pClass->wHashKey ) * BUCKET; + wLimit = wAt + BUCKET; + + if( pClass->wMethods > ( pClass->wHashKey * BUCKET * 2/3 ) ) + DictRealloc( pClass ); + + while( ( wAt < wLimit ) && + ( pClass->pMethods[ wAt ].pMessage && + ( pClass->pMethods[ wAt ].pMessage != pMessage ) ) ) + wAt++; + + if( wAt <= wLimit ) + { + pClass->pMethods[ wAt ].pMessage = pMessage; + switch( wType ) + { + case MET_METHOD: + pClass->pMethods[ wAt ].pFunction = ( HARBOURFUNC ) _parnl( 3 ); + break; + + case MET_DATA: + pClass->pMethods[ wAt ].wData = _parnl( 3 ); + if( pMessage->pSymbol->szName[ 0 ] == '_' ) + pClass->pMethods[ wAt ].pFunction = SetData; + else + pClass->pMethods[ wAt ].pFunction = GetData; + break; + + case MET_CLASSDATA: + pClass->pMethods[ wAt ].wData = _parnl( 3 ); + if( ArrayLen( &pClass->aClassDatas ) < _parnl( 3 ) ) + ArraySize( &pClass->aClassDatas, _parnl( 3 ) ); + + if( pMessage->pSymbol->szName[ 0 ] == '_' ) + pClass->pMethods[ wAt ].pFunction = SetClassData; + else + pClass->pMethods[ wAt ].pFunction = GetClassData; + break; + + case MET_INLINE: + pClass->pMethods[ wAt ].wData = ArrayLen( &pClass->aInlines ) + 1; + ArraySize( &pClass->aInlines, pClass->pMethods[ wAt ].wData ); + ArraySet( &pClass->aInlines, pClass->pMethods[ wAt ].wData, + _param( 3, IT_BLOCK ) ); + pClass->pMethods[ wAt ].pFunction = EvalInline; + break; + + case MET_VIRTUAL: + pClass->pMethods[ wAt ].pFunction = Virtual; + break; + + default: + printf( "Invalid method type from ClassAdd\n" ); + exit( 1 ); + break; + } + pClass->wMethods++; + return; + } + } +} + +HARBOUR CLASSNAME() /* hClass --> cClassName */ +{ + PITEM pObject = _param( 0, IT_OBJECT ); + WORD wClass; + + if( pObject && ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass ) + { + wClass = ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass; + _retc( pClasses[ wClass - 1 ].szName ); + } + else + { + wClass = _parni( 1 ); + if( wClass <= wClasses ) + _retc( pClasses[ wClass - 1 ].szName ); + else + _retc( "" ); + } +} + +HARBOUR CLASSINSTANCE() /* hClass --> oNewObject */ +{ + WORD wClass = _parni( 1 ); + + if( wClass <= wClasses ) + { + Array( &stack.Return, pClasses[ wClass - 1 ].wDatas ); + ( ( PBASEARRAY ) stack.Return.value.pBaseArray )->wClass = wClass; + } + else + _ret(); +} + +HARBOURFUNC GetMethod( PITEM pObject, PSYMBOL pMessage ) +{ + PCLASS pClass; + WORD wAt, wLimit; + WORD wClass = ( ( PBASEARRAY ) pObject->value.pBaseArray )->wClass; + PDYNSYM pMsg = ( PDYNSYM ) pMessage->pDynSym; + + if( ! msgClassName ) + { + msgClassName = GetDynSym( "CLASSNAME" ); + msgClassH = GetDynSym( "CLASSH" ); + msgEval = GetDynSym( "EVAL" ); + } + + if( wClass && wClass <= wClasses ) + { + pClass = &pClasses[ wClass - 1 ]; + wAt = ( ( ( unsigned ) pMsg ) % pClass->wHashKey ) * BUCKET; + wLimit = wAt + BUCKET; + + pMethod = 0; + + while( wAt < wLimit ) + { + if( pClass->pMethods[ wAt ].pMessage == pMsg ) + { + pMethod = &pClass->pMethods[ wAt ]; + return pClass->pMethods[ wAt ].pFunction; + } + wAt++; + } + } + + if( pMsg == msgClassName ) + return ClassName; + + else if( pMsg == msgClassH ) + return ClassH; + + else if( pMsg == msgEval ) + return EvalInline; + + return 0; +} + +void ReleaseClass( PCLASS pClass ) +{ + _xfree( pClass->szName ); + _xfree( pClass->pMethods ); + + ArrayRelease( &pClass->aClassDatas ); + ArrayRelease( &pClass->aInlines ); + /* ArrayRelease( &pClass->aInitValues ); */ +} + +void ReleaseClasses( void ) +{ + WORD w; + + for( w = 0; w < wClasses; w++ ) + ReleaseClass( pClasses + w ); + + if( pClasses ) + _xfree( pClasses ); +} diff --git a/harbour/source/rtl/codebloc.c b/harbour/source/rtl/codebloc.c new file mode 100644 index 0000000000..835e227d08 --- /dev/null +++ b/harbour/source/rtl/codebloc.c @@ -0,0 +1,176 @@ +/* The Harbour implementation of codeblocks */ + +#include +#include + +extern STACK stack; + +#define FALSE 0 +#define TRUE 1 + +/* Uncomment this to trace codeblocks activity +#define CODEBLOCKDEBUG +*/ + +/* Creates the codeblock structure + * + * The buffer should contain: + * +0 bytes -> number of referenced local variables + * +2 bytes -> table of referenced local variables + * +2 + 2 *(number of referenced variables) -> codeblock pcode + */ +PCODEBLOCK CodeblockNew( BYTE * pBuffer, WORD wSize, PSYMBOL pSymbols ) +{ + PCODEBLOCK pCBlock; + WORD wVars; + + pCBlock =( PCODEBLOCK ) _xgrab( sizeof(CODEBLOCK) ); + + /* Check the number of referenced local variables + */ + wVars = * ( (WORD *) pBuffer ); + wSize -= ( wVars + 1 ) * 2; + pBuffer +=2; + pCBlock->wLocals =wVars; + if( wVars ) + { + WORD w = 0; + + /* Create the table with references to local variables + * If this codeblock will be exported from a function then + * all references will be replaced with current values of + * these variables + */ + pCBlock->pItems =(PITEM) _xgrab( sizeof(ITEM) * wVars ); + + while( wVars-- ) + { + pCBlock->pItems[ w ].wType =IT_INTEGER; /* not really integer */ + pCBlock->pItems[ w ].value.wItem = * ( (WORD*) pBuffer ); + ++w; + pBuffer +=2; + } + } + else + pCBlock->pItems =NULL; + + /* the codeblock initally contains references to local variables + */ + pCBlock->wDetached =FALSE; + /* since the only allowed operation on a codeblock is evaluating it then + * there is no need to duplicate its pcode -just store the poiter to it + */ + pCBlock->pCode = (BYTE *) _xgrab( wSize ); + memcpy( pCBlock->pCode, pBuffer, wSize ); + + pCBlock->pSymbols =pSymbols; + pCBlock->wDetached =FALSE; + pCBlock->lCounter =1; + +#ifdef CODEBLOCKDEBUG + printf( "codeblock created (%li)\n", pCBlock->lCounter ); +#endif + return pCBlock; +} + +/* Delete a codeblock + */ +void CodeblockDelete( PCODEBLOCK pCBlock ) +{ +#ifdef CODEBLOCKDEBUG + printf( "delete a codeblock (%li)\n", pCBlock->lCounter ); +#endif + if( --pCBlock->lCounter == 0 ) + { + WORD w = 0; + + /* free space allocated for local variables + */ + while( w < pCBlock->wLocals ) + ItemRelease( &pCBlock->pItems[ w++ ] ); + /* free space allocated for a codeblock pcodes + */ + _xfree( pCBlock->pCode ); + /* free space allocated for a CODEBLOCK structure + */ + _xfree( pCBlock ); + #ifdef CODEBLOCKDEBUG + printf( "codeblock deleted (%li)\n", pCBlock->lCounter ); + #endif + } +} + +/* Function to unlink variables referenced in a codeblock from a function + * where this codeblock was created + */ +void CodeblockDetach( PCODEBLOCK pCBlock ) +{ + if( pCBlock->wLocals && !pCBlock->wDetached ) + { + /* this codeblock refers to local variables */ + WORD w = 0; + PITEM pItem; + + while( w < pCBlock->wLocals ) + { + /* replace the position of local variable on the stack with + * it's current value + * stack.pBase still points to a stack frame of function + * where this codeblock was defined + */ + pItem =pCBlock->pItems + w; + pItem =stack.pBase +pItem->value.wItem + 1; + if( IS_BYREF( pItem ) ) + pItem =stack.pItems +pItem->value.wItem; + ItemCopy( pCBlock->pItems + w, pItem ); + ++w; + } + pCBlock->wDetached =TRUE; + } + #ifdef CODEBLOCKDEBUG + printf( "codeblock detached(%li)\n", pCBlock->lCounter ); + #endif +} + +/* Evaluate passed codeblock + * wStackBase is stack base of function where the codeblock was defined + * We need it because stack.pBase points to a stack base of EVAL function + */ +void CodeblockEvaluate( PCODEBLOCK pCBlock, WORD wStackBase ) +{ + pCBlock->wRefBase =wStackBase; + VirtualMachine( pCBlock->pCode, pCBlock->pSymbols ); +} + +/* Get local variable referenced in a codeblock + */ +PITEM CodeblockGetVar( PITEM pItem, SHORT iItemPos ) +{ + PCODEBLOCK pCBlock = (PCODEBLOCK)pItem->value.pCodeblock; + PITEM pLocalVar; + + pLocalVar =&pCBlock->pItems[ -iItemPos -1 ]; + /* if a codeblock have detached local variables then it stores their value */ + if( !pCBlock->wDetached ) + { + /* when variables are not detached then a codeblock stores the variable's + * position on the stack + */ + pLocalVar =stack.pItems +pCBlock->wRefBase +pLocalVar->value.wItem + 1; + } + + return pLocalVar; +} + +/* Copy the codeblock + * TODO: check if such simple pointer coping will allow to evaluate + * codeblocks recursively + */ +void CodeblockCopy( PITEM pDest, PITEM pSource ) +{ + pDest->value.pCodeblock =pSource->value.pCodeblock; + ((PCODEBLOCK) pDest->value.pCodeblock)->lCounter++; + #ifdef CODEBLOCKDEBUG + printf( "copy a codeblock (%li)\n", ((PCODEBLOCK) pDest->value.pCodeblock)->lCounter); + #endif +} diff --git a/harbour/source/rtl/console.c b/harbour/source/rtl/console.c new file mode 100644 index 0000000000..2d32b1fcbd --- /dev/null +++ b/harbour/source/rtl/console.c @@ -0,0 +1,112 @@ +#ifdef WINDOWS + #include +#endif + +#include +#include +#include +#include + +HARBOUR __ACCEPT( void ) /* Internal Clipper function used in ACCEPT command */ + /* Basically the simplest Clipper function to */ + /* receive data. Parameter : cPrompt. Returns : cRet */ +{ + char *szResult = ( char * ) _xgrab(256); /* Return parameter. Limited to 255 chars */ + char *szPrompt = _parc(1); /* Pass prompt */ + long lLen = _parclen(1); /* Please change to long later on */ + + if( _pcount() == 1 ) /* cPrompt passed */ + { + PushSymbol( GetDynSym( "QOUT" )->pSymbol ); /* push the symbol pointer to the Harbour stack */ + PushNil(); /* places nil at self, as we are not sending a msg */ + PushString( szPrompt, lLen ); /* places parameters on to the stack */ + Do( 1 ); /* 1 parameter supplied. Invoke the virtual machine */ + } + + gets( szResult ); /* Read the data. Using gets() */ + _retc( szResult ); + _xfree( szResult ); +} + +static void _outstd( WORD wParam ) +{ + char * szText; + ULONG ulLenText; + char szBuffer [11]; + + switch( _parinfo( wParam ) ) + { + case IT_DATE: + printf ("%s", hb_dtoc (_pards (wParam), szBuffer)); + break; + + case IT_INTEGER: + printf( "%10i", _parni( wParam ) ); + break; + + case IT_NIL: + printf( "NIL" ); + break; + + case IT_LOGICAL: + if( _parl( wParam ) ) + printf( ".T." ); + else + printf( ".F." ); + break; + + case IT_LONG: + printf( "%10li", _parnl( wParam ) ); + break; + + case IT_STRING: + szText = _parc( wParam ); + ulLenText = _parclen( wParam ); + while( ulLenText ) + { + printf( "%c", *szText ); + szText++; + ulLenText--; + } + break; + + case IT_DOUBLE: + printf( "%14.4f", _parnd( wParam ) ); + break; + + default: + break; + } +} + +HARBOUR OUTSTD( void ) /* writes a list of values to the standard output device */ +{ + WORD w; + + for( w = 0; w < _pcount(); w++ ) + { + _outstd( w + 1 ); + if( w < _pcount() - 1) printf( " " ); + } +} + +HARBOUR QQOUT( void ) +{ + WORD w; + + for( w = 0; w < _pcount(); w++ ) + { + _outstd( w + 1 ); + if( w < _pcount() - 1) printf( " " ); + } +} + +HARBOUR QOUT( void ) +{ + #ifdef WINDOWS + MessageBox( 0, _parc( 1 ), "Harbour", 0 ); + #else + printf( "\n" ); + QQOUT(); + #endif +} diff --git a/harbour/source/rtl/dates.c b/harbour/source/rtl/dates.c new file mode 100644 index 0000000000..ae8581a597 --- /dev/null +++ b/harbour/source/rtl/dates.c @@ -0,0 +1,360 @@ +#include +#include +#include +#include + +long greg2julian( long lDay, long lMonth, long lYear ) +{ + long lFactor = ( lMonth < 3 ) ? -1: 0; + + return ( 1461 * ( lFactor + 4800 + lYear ) / 4 ) + + ( ( lMonth - 2 - ( lFactor * 12 ) ) * 367 ) / 12 - + ( 3 * ( ( lYear + 4900 + lFactor ) / 100 ) / 4 ) + + lDay - 32075; +} + +void julian2greg( long julian, long * plDay, long * plMonth, long * plYear ) +{ + long U, V, W, X; + + julian += 68569; + W = ( julian * 4 ) / 146097; + julian -= ( ( 146097 * W ) + 3 ) / 4; + X = 4000 * ( julian + 1 ) / 1461001; + julian -= ( ( 1461 * X ) / 4 ) - 31; + V = 80 * julian / 2447; + U = V / 11; + * plDay = julian - ( 2447 * V / 80 ); + * plMonth = V + 2 - ( U * 12 ); + * plYear = X + U + ( W - 49 ) * 100; +} + +HARBOUR CTOD( void ) +{ + char * szDate = _parc( 1 ); + int d_value = 0, m_value = 0, y_value = 0; + int d_pos = 0, m_pos = 0, y_pos = 0; + int count, digit; + char szDateFormat[ 9 ]; + + for( count = 0; count < strlen (HB_set._SET_DATEFORMAT); count++) + { + switch (HB_set._SET_DATEFORMAT [count]) + { + case 'D': + case 'd': + if (d_pos == 0) + { + if (m_pos == 0 && y_pos == 0) d_pos = 1; + else if (m_pos == 0 || y_pos == 0) d_pos = 2; + else d_pos = 3; + } + break; + case 'M': + case 'm': + if (m_pos == 0) + { + if (d_pos == 0 && y_pos == 0) m_pos = 1; + else if (d_pos == 0 || y_pos == 0) m_pos = 2; + else m_pos = 3; + } + break; + case 'Y': + case 'y': + if (y_pos == 0) + { + if (m_pos == 0 && d_pos == 0) y_pos = 1; + else if (m_pos == 0 || d_pos == 0) y_pos = 2; + else y_pos = 3; + } + } + } + for( count = 0; count < strlen (szDate); count++) + { + digit = szDate [count]; + if (isdigit (digit)) + { + if (d_pos == 1) + { + d_value = (d_value * 10) + digit - '0'; + } + else if (m_pos == 1) + { + m_value = (m_value * 10) + digit - '0'; + } + else if (y_pos == 1) + { + y_value = (y_value * 10) + digit - '0'; + } + } + else + { + d_pos--; + m_pos--; + y_pos--; + } + } + if (y_value < 100) + { + count = HB_set._SET_EPOCH % 100; + digit = HB_set._SET_EPOCH / 100; + if (y_value >= count) y_value += (digit * 100); + else y_value += ((digit * 100) + 100); + } + sprintf (szDateFormat, "%04i%02i%02i", y_value, m_value, d_value); + _retds( szDateFormat ); +} + +char * hb_dtoc (char * szDate, char * szDateFormat) +{ + /* NOTE: szDateFormat must point to a buffer of at least 11 bytes */ + int d_digits = 0, m_digits = 0, y_digits = 0; + int d_pos = 0, m_pos = 0, y_pos = 0; + int add_sep, count, digit, delim_1, delim_2, delim_count; + char szTemp [5]; + + delim_count = 0; + delim_1 = delim_2 = '.'; + for( count = 0; count < strlen (HB_set._SET_DATEFORMAT); count++) + { + digit = HB_set._SET_DATEFORMAT [count]; + switch (digit) + { + case 'D': + case 'd': + d_digits++; + if (d_pos == 0) + { + if (m_pos == 0 && y_pos == 0) d_pos = 1; + else if (m_pos == 0 || y_pos == 0) d_pos = 2; + else d_pos = 3; + } + break; + case 'M': + case 'm': + m_digits++; + if (m_pos == 0) + { + if (d_pos == 0 && y_pos == 0) m_pos = 1; + else if (d_pos == 0 || y_pos == 0) m_pos = 2; + else m_pos = 3; + } + break; + case 'Y': + case 'y': + y_digits++; + if (y_pos == 0) + { + if (m_pos == 0 && d_pos == 0) y_pos = 1; + else if (m_pos == 0 || d_pos == 0) y_pos = 2; + else y_pos = 3; + } + break; + default: + delim_count++; + if (delim_count == 1) delim_1 = digit; + else if (delim_count == 2) delim_2 = digit; + break; + } + } + *szDateFormat = 0; + for (count = 0; count < 3; count++) + { + // Insert a converted date element. + add_sep = 0; + if (d_pos == 1 && d_digits > 0) + { + add_sep = 1; + while (d_digits > 2) + { + strcat (szDateFormat, "0"); + d_digits--; + } + if (d_digits == 1) + { + szTemp [0] = szDate [7]; + szTemp [1] = 0; + } + else + { + szTemp [0] = szDate [6]; + szTemp [1] = szDate [7]; + szTemp [2] = 0; + } + strcat (szDateFormat, szTemp); + } + if (m_pos == 1 && m_digits > 0) + { + add_sep = 1; + while (m_digits > 2) + { + strcat (szDateFormat, "0"); + m_digits--; + } + if (m_digits == 1) + { + szTemp [0] = szDate [5]; + szTemp [1] = 0; + } + else + { + szTemp [0] = szDate [4]; + szTemp [1] = szDate [5]; + szTemp [2] = 0; + } + strcat (szDateFormat, szTemp); + } + if (y_pos == 1 && y_digits > 0) + { + add_sep = 1; + while (y_digits > 4) + { + strcat (szDateFormat, "0"); + y_digits--; + } + if (y_digits == 1) + { + szTemp [0] = szDate [3]; + szTemp [1] = 0; + } + else if (y_digits == 2) + { + szTemp [0] = szDate [2]; + szTemp [1] = szDate [3]; + szTemp [2] = 0; + } + else if (y_digits == 3) + { + szTemp [0] = szDate [1]; + szTemp [1] = szDate [2]; + szTemp [2] = szDate [3]; + szTemp [3] = 0; + } + else + { + szTemp [0] = szDate [0]; + szTemp [1] = szDate [1]; + szTemp [2] = szDate [2]; + szTemp [3] = szDate [3]; + szTemp [4] = 0; + } + strcat (szDateFormat, szTemp); + } + // Insert a date field separator. + if (add_sep && delim_1) + { + szTemp [0] = delim_1; + szTemp [1] = 0; + strcat (szDateFormat, szTemp); + delim_1 = 0; + } + else if (add_sep && delim_2) + { + szTemp [0] = delim_2; + szTemp [1] = 0; + strcat (szDateFormat, szTemp); + delim_2 = 0; + } + // Get ready for the next date element. + d_pos--; + m_pos--; + y_pos--; + } + return (szDateFormat); +} + +HARBOUR DTOC( void ) +{ + char * szDate = _pards( 1 ); + char szDateFormat[ 11 ]; + _retc( hb_dtoc (szDate, szDateFormat) ); +} + +HARBOUR DTOS( void ) +{ + _retc( _pards( 1 ) ); +} + +HARBOUR STOD( void ) +{ + _retds( _parc( 1 ) ); +} + +HARBOUR DAY( void ) +{ + PITEM pDate = _param( 1, IT_DATE ); + long lDay, lMonth, lYear; + + if( pDate ) + { + julian2greg( pDate->value.lDate, &lDay, &lMonth, &lYear ); + _retni( lDay ); + } + else + { + /* TODO: generate a proper error object and raise an error */ + printf( "not a valid date item from Day()\n" ); + exit( 1 ); + } +} + +HARBOUR MONTH( void ) +{ + PITEM pDate = _param( 1, IT_DATE ); + long lDay, lMonth, lYear; + + if( pDate ) + { + julian2greg( pDate->value.lDate, &lDay, &lMonth, &lYear ); + _retni( lMonth ); + } + else + { + /* TODO: generate a proper error object and raise an error */ + printf( "not a valid date item from Day()\n" ); + exit( 1 ); + } +} + +HARBOUR YEAR( void ) +{ + PITEM pDate = _param( 1, IT_DATE ); + long lDay, lMonth, lYear; + + if( pDate ) + { + julian2greg( pDate->value.lDate, &lDay, &lMonth, &lYear ); + _retni( lYear ); + } + else + { + /* TODO: generate a proper error object and raise an error */ + printf( "not a valid date item from Day()\n" ); + exit( 1 ); + } +} + +HARBOUR TIME( void ) +{ + if( _pcount() == 0 ) + { + time_t t; + struct tm *oTime; + char szTime[9]; + + time(&t); + oTime = localtime(&t); + sprintf(szTime, "%02d:%02d:%02d", oTime->tm_hour, oTime->tm_min, +oTime->tm_sec); + _retclen(szTime, 8); + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: TIME"); + _errLaunch(pError); + _errRelease(pError); + } +} + diff --git a/harbour/source/rtl/environ.c b/harbour/source/rtl/environ.c new file mode 100644 index 0000000000..96d459a054 --- /dev/null +++ b/harbour/source/rtl/environ.c @@ -0,0 +1,32 @@ +#include + +HARBOUR VERSION() +{ + _retc( "Harbour alpha version" ); +} + +HARBOUR GETENV() +{ + if( _pcount() == 1 ) + { + char *szName = _parc(1); + long lName = _parclen(1); + + while( lName && szName[lName - 1] == '=' ) + { + /* strip the '=' or else it will clear the variable! */ + szName[lName - 1] = 0; + lName--; + } + if( lName ) + { + char *Value = getenv(szName); + _retc(Value? Value: ""); + } + else + _retc(""); + } + else + _retc(""); +} + diff --git a/harbour/source/rtl/error.prg b/harbour/source/rtl/error.prg new file mode 100644 index 0000000000..bd29152623 --- /dev/null +++ b/harbour/source/rtl/error.prg @@ -0,0 +1,33 @@ +// Class error. We are keeping Clipper compatibility here, instead of using +// TError():New() style and also avoiding hungarian notation. + +//----------------------------------------------------------------------------// + +function ErrorNew() + + static oClass + + if oClass == nil + oClass = TClass():New( "ERROR" ) + + oClass:AddData( "args" ) + oClass:AddData( "CanDefault" ) + oClass:AddData( "CanRetry" ) + oClass:AddData( "CanSubstitute" ) + oClass:AddData( "Cargo" ) + oClass:AddData( "description" ) + oClass:AddData( "filename" ) + oClass:AddData( "GenCode" ) + oClass:AddData( "Operation" ) + oClass:AddData( "OsCode" ) + oClass:AddData( "Severity" ) + oClass:AddData( "SubCode" ) + oClass:AddData( "SubSystem" ) + oClass:AddData( "Tries" ) + + oClass:Create() + endif + +return oClass:Instance() + +//----------------------------------------------------------------------------// diff --git a/harbour/source/rtl/errorapi.c b/harbour/source/rtl/errorapi.c new file mode 100644 index 0000000000..84a0a40c57 --- /dev/null +++ b/harbour/source/rtl/errorapi.c @@ -0,0 +1,39 @@ +#include +#include + +extern ITEM errorBlock; +extern STACK stack; +extern SYMBOL symEval; + +PITEM _errNew( void ) +{ + PushSymbol( GetDynSym( "ERRORNEW" )->pSymbol ); + PushNil(); + Do( 0 ); + + return &stack.Return; +} + +void _errPutDescription( PITEM pError, char * szDescription ) +{ + PushSymbol( GetDynSym( "_DESCRIPTION" )->pSymbol ); + Push( pError ); + PushString( szDescription, strlen( szDescription ) ); + Do( 1 ); +} + +WORD _errLaunch( PITEM pError ) +{ + PushSymbol( &symEval ); + Push( &errorBlock ); + Push( pError ); + Do( 1 ); + + return stack.Return.value.iNumber; /* TODO: _parnl( -1 ) */ +} + +void _errRelease( PITEM pError ) +{ + ItemRelease( pError ); +} + diff --git a/harbour/source/rtl/errorsys.prg b/harbour/source/rtl/errorsys.prg new file mode 100644 index 0000000000..c20e868e58 --- /dev/null +++ b/harbour/source/rtl/errorsys.prg @@ -0,0 +1,39 @@ +// Standard Harbour ErrorSys system + +//----------------------------------------------------------------------------// + +init procedure ClipInit + + // public getlist := {} TODO! + + ErrorSys() + +return + +//----------------------------------------------------------------------------// + +static function DefError( oError ) + + local cInfo := "" + local n := 2 + + while ! Empty( ProcName( n ) ) + cInfo += Chr( 13 ) + Chr( 10 ) + "Called from " + ProcName( n ) + ; + "(" + AllTrim( Str( ProcLine( n++ ) ) ) + ")" + end + + QOut( oError:Description + Chr( 13 ) + Chr( 10 ) + cInfo ) + + __Quit() + +return .t. + +//----------------------------------------------------------------------------// + +procedure ErrorSys + + ErrorBlock( { | oError | DefError( oError ) } ) + +return + +//----------------------------------------------------------------------------// diff --git a/harbour/source/rtl/extend.c b/harbour/source/rtl/extend.c new file mode 100644 index 0000000000..66062d308a --- /dev/null +++ b/harbour/source/rtl/extend.c @@ -0,0 +1,619 @@ +#include +#include +#include + +long greg2julian( long lDay, long lMonth, long lYear ); +void julian2greg( long julian, long * plDay, long * plMonth, long * plYear ); + +extern STACK stack; + +ULONG ulMemoryBlocks = 0, ulMemoryMaxBlocks = 0, ulMemoryMaxConsumed = 0, + ulMemoryConsumed = 0; + +PITEM _param( WORD wParam, WORD wMask ) +{ + WORD wType; + + if( wParam <= _pcount() ) + { + wType = ( stack.pBase + 1 + wParam )->wType; + + if( ( wType & wMask ) || ( wType == IT_NIL && wMask == IT_ANY ) ) + return stack.pBase + 1 + wParam; + else + return 0; + } + return 0; +} + +char * _parc( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) ) + if( wArrayIndex ) + return ArrayGetString( pItem, wArrayIndex ); + else + return ""; + + else if( IS_STRING( pItem ) ) + return pItem->value.szText; + + else + return ""; + } + return ""; +} + +ULONG _parclen( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) ) + if( wArrayIndex ) + return ArrayGetStringLen( pItem, wArrayIndex ); + else + return 0; + + else if( IS_STRING( pItem ) ) + return pItem->wLength; + + else + return 0; + } + return 0; +} + +char * _pards( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + long lDay, lMonth, lYear; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when retrieving an array element */ + return ""; + + else if( IS_DATE( pItem ) ) + { + julian2greg( pItem->value.lDate, &lDay, &lMonth, &lYear ); + + stack.szDate[ 0 ] = ( lYear / 1000 ) + '0'; + stack.szDate[ 1 ] = ( ( lYear % 1000 ) / 100 ) + '0'; + stack.szDate[ 2 ] = ( ( lYear % 100 ) / 10 ) + '0'; + stack.szDate[ 3 ] = ( lYear % 10 ) + '0'; + + stack.szDate[ 4 ] = ( lMonth / 10 ) + '0'; + stack.szDate[ 5 ] = ( lMonth % 10 ) + '0'; + + stack.szDate[ 6 ] = ( lDay / 10 ) + '0'; + stack.szDate[ 7 ] = ( lDay % 10 ) + '0'; + stack.szDate[ 8 ] = 0; + + return stack.szDate; /* this guaranties good behavior when multithreading */ + } + else + return "00000000"; + } + return "00000000"; +} + +int _parl( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when retrieving an array element */ + return 0; + + else if( IS_LOGICAL( pItem ) ) + return pItem->value.iLogical; + + else + return 0; + } + return 0; +} + +double _parnd( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when retrieving an array element */ + return 0; + + else if( IS_INTEGER( pItem ) ) + return pItem->value.iNumber; + + else if( IS_LONG( pItem ) ) + return pItem->value.lNumber; + + else if( IS_DOUBLE( pItem ) ) + return pItem->value.dNumber; + + else + return 0; + } + return 0; +} + +int _parni( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when retrieving an array element */ + return 0; + + else if( IS_INTEGER( pItem ) ) + return pItem->value.iNumber; + + else if( IS_LONG( pItem ) ) + return pItem->value.lNumber; + + else if( IS_DOUBLE( pItem ) ) + return pItem->value.dNumber; + + else + return 0; + } + return 0; +} + +long _parnl( WORD wParam, ... ) +{ + PITEM pItem; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = stack.pBase + 1 + wParam; + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when retrieving an array element */ + return 0; + + else if( IS_INTEGER( pItem ) ) + return pItem->value.iNumber; + + else if( IS_LONG( pItem ) ) + return pItem->value.lNumber; + + else if( IS_DOUBLE( pItem ) ) + return pItem->value.dNumber; + + else + return 0; + } + return 0; +} + +WORD _parinfo( WORD wParam ) +{ + if( ! wParam ) + return stack.pBase->wParams; + else + { + if( wParam <= _pcount() ) + return ( stack.pBase + 1 + wParam )->wType; + else + return 0; + } +} + +WORD _pcount( void ) +{ + return stack.pBase->wParams; +} + +void _ret( void ) +{ + ItemRelease( &stack.Return ); +} + +void _reta( ULONG ulLen ) /* undocumented _reta() */ +{ + Array( &stack.Return, ulLen ); +} + +void _retc( char * szText ) +{ + ULONG ulLen = strlen( szText ); + + ItemRelease( &stack.Return ); + stack.Return.wType = IT_STRING; + stack.Return.wLength = ulLen; + stack.Return.value.szText = ( char * ) _xgrab( ulLen + 1 ); + strcpy( stack.Return.value.szText, szText ); +} + +void _retclen( char * szText, ULONG ulLen ) +{ + ItemRelease( &stack.Return ); + stack.Return.wType = IT_STRING; + stack.Return.wLength = ulLen; + stack.Return.value.szText = ( char * ) _xgrab( ulLen + 1 ); + memcpy( stack.Return.value.szText, szText, ulLen ); + stack.Return.value.szText[ ulLen ] = 0; +} + +void _retds( char * szDate ) /* szDate must have yyyymmdd format */ +{ + long lDay, lMonth, lYear; + + lDay = ( ( szDate[ 6 ] - '0' ) * 10 ) + ( szDate[ 7 ] - '0' ); + lMonth = ( ( szDate[ 4 ] - '0' ) * 10 ) + ( szDate[ 5 ] - '0' ); + lYear = ( ( szDate[ 0 ] - '0' ) * 1000 ) + ( ( szDate[ 1 ] - '0' ) * 100 ) + + ( ( szDate[ 2 ] - '0' ) * 10 ) + ( szDate[ 3 ] - '0' ); + + ItemRelease( &stack.Return ); + + stack.Return.wType = IT_DATE; + stack.Return.wLength = 8; + /* QUESTION: Is this ok ? we are going to use a long to store the date */ + /* QUESTION: What happens if we use sizeof( LONG ) instead ? */ + /* QUESTION: Would it break Clipper language code ? */ + stack.Return.value.lDate = greg2julian( lDay, lMonth, lYear ); +} + +void _retnd( double dNumber ) +{ + ItemRelease( &stack.Return ); + stack.Return.wType = IT_DOUBLE; + stack.Return.wLength = sizeof( double ); /* QUESTION: Is this correct ? */ + stack.Return.value.dNumber = dNumber; +} + +void _retni( int iNumber ) +{ + ItemRelease( &stack.Return ); + stack.Return.wType = IT_INTEGER; + stack.Return.wLength = sizeof( int ); /* QUESTION: Is this correct ? */ + stack.Return.value.iNumber = iNumber; +} + +void _retl( int iTrueFalse ) +{ + ItemRelease( &stack.Return ); + stack.Return.wType = IT_LOGICAL; + stack.Return.wLength = 1; /* QUESTION: Is this correct ? */ + stack.Return.value.iLogical = iTrueFalse; +} + +void _retnl( long lNumber ) +{ + ItemRelease( &stack.Return ); + stack.Return.wType = IT_LONG; + stack.Return.wLength = sizeof( LONG ); /* QUESTION: Is this correct ? */ + stack.Return.value.lNumber = lNumber; +} + +void _storc( char * szText, WORD wParam, ... ) +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + ULONG ulLen; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, long ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + ulLen = strlen( szText ); + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_STRING; + pItemRef->wLength = ulLen; + pItemRef->value.szText = ( char * ) _xgrab( ulLen + 1 ); + strcpy( pItemRef->value.szText, szText ); + } + } +} + +void _storclen( char * fixText, WORD wLength, WORD wParam, ... ) +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, long ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_STRING; + pItemRef->wLength = wLength; + pItemRef->value.szText = ( char * ) _xgrab( wLength + 1 ); + memcpy( pItemRef->value.szText, fixText, wLength ); + pItemRef->value.szText[ wLength ] = '\0'; + } + } +} + +void _stords( char * szDate, WORD wParam, ... ) /* szDate must have yyyymmdd format */ +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + long lDay, lMonth, lYear; + + lDay = ( ( szDate[ 6 ] - '0' ) * 10 ) + ( szDate[ 7 ] - '0' ); + lMonth = ( ( szDate[ 4 ] - '0' ) * 10 ) + ( szDate[ 5 ] - '0' ); + lYear = ( ( szDate[ 0 ] - '0' ) * 1000 ) + ( ( szDate[ 1 ] - '0' ) * 100 ) + + ( ( szDate[ 2 ] - '0' ) * 10 ) + ( szDate[ 3 ] - '0' ); + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_DATE; + pItemRef->value.lDate = greg2julian( lDay, lMonth, lYear ); + } + } +} + +void _storl( int iLogical, WORD wParam, ... ) +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_LOGICAL; + pItemRef->value.iLogical = iLogical; + } + } +} + +void _storni( int iValue, WORD wParam, ... ) +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, int ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_INTEGER; + pItemRef->value.iNumber = iValue; + } + } +} + +void _stornl( long lValue, WORD wParam, ... ) +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, long ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_LONG; + pItemRef->value.lNumber = lValue; + } + } +} + +void _stornd( double dValue, WORD wParam, ... ) +{ + PITEM pItem, pItemRef; + va_list va; + WORD wArrayIndex = 0; + + va_start( va, wParam ); + wArrayIndex = va_arg( va, long ); + va_end( va ); + + if( wParam <= _pcount() ) + { + pItem = ( stack.pBase + 1 + wParam ); + + if( IS_ARRAY( pItem ) && wArrayIndex ) + /* TODO: implement wArrayIndex use when storing to an array element */ + return; + + if( IS_BYREF( pItem ) ) + { + pItemRef = stack.pItems + pItem->value.wItem; + ItemRelease( pItemRef ); + pItemRef->wType = IT_DOUBLE; + pItemRef->value.dNumber = dValue; + } + } +} + +void * _xgrab( ULONG ulSize ) /* allocates fixed memory */ +{ + void * pMem = malloc( ulSize + sizeof( ULONG ) ); + + if( ! pMem ) + { + printf( "\n_xgrab error: can't allocate memory!\n" ); + exit( 1 ); + } + + * ( ( ULONG * ) pMem ) = ulSize; /* we store the block size into it */ + + ulMemoryConsumed += ulSize; + ulMemoryMaxConsumed += ulSize; + ulMemoryBlocks++; + ulMemoryMaxBlocks++; + + return ( char * ) pMem + sizeof( ULONG ); +} + +void * _xrealloc( void * pMem, ULONG ulSize ) /* reallocates memory */ +{ + ULONG ulMemSize = * ( ULONG * ) ( ( char * ) pMem - sizeof( ULONG ) ); + void * pResult = realloc( ( char * ) pMem - sizeof( ULONG ), ulSize + sizeof( ULONG ) ); + + if( ! pResult ) + { + printf( "\n_xrealloc error: can't reallocate memory!\n" ); + exit( 1 ); + } + + * ( ( ULONG * ) pResult ) = ulSize; /* we store the block size into it */ + + if( ! ulSize ) + ulMemoryBlocks--; + + ulMemoryConsumed += ( ulSize - ulMemSize ); + if( ulSize > ulMemSize ) + ulMemoryMaxConsumed += ulSize - ulMemSize; + + return ( char * ) pResult + sizeof( ULONG ); +} + +void _xfree( void * pMem ) /* frees fixed memory */ +{ + ULONG ulMemSize = * ( ULONG * ) ( ( char * ) pMem - sizeof( ULONG ) ); + + if( pMem ) + free( ( char * ) pMem - sizeof( ULONG ) ); + else + printf( "\nCalling _xfree() with a null pointer!\n" ); + + ulMemoryConsumed -= ulMemSize; + ulMemoryBlocks--; +} diff --git a/harbour/source/rtl/files.c b/harbour/source/rtl/files.c new file mode 100644 index 0000000000..8c6e457867 --- /dev/null +++ b/harbour/source/rtl/files.c @@ -0,0 +1,337 @@ +#include + +#if defined(_SO_LINUX) +#include +#endif + +#if defined(__GNUC__) +#include +/* This is ugly, but we are using FOPEN, etc., and those names collide + with names in the standard C library. */ +extern int open _PARAMS ((const char *, int, ...)); +extern int creat _PARAMS ((const char *, mode_t)); +#endif + +#if defined(__WATCOMC__) + #include +#endif + +#if defined(__BORLANDC__) +#include +#include +#endif + +#if defined(_SO_DOS) + +#if defined(_CC_DJGPP) +#include +#include +#include +#endif + +#endif + +#ifndef __WATCOMC__ + extern int errno; +#endif + +HARBOUR BIN2I( void ); +HARBOUR I2BIN( void ); + +static int last_error = 0; + +#define MKLONG(_1,_2,_3,_4) (((long)_4)<<24)|(((long)_3)<<16)|(((long)_2)<<8)|_1 +#define MKINT(_1,_2) (((long)_2)<<8)|_1 + +HARBOUR FOPEN() +{ + PITEM arg1_it = _param(1,IT_STRING); + PITEM arg2_it = _param(1,IT_NUMERIC); + + int open_flags; + int file_handle = -1; + + if( arg1_it ) + { + if( arg2_it ) + open_flags = _parni(2); + else + open_flags = 0; + + /* TODO: Study equivalence between Clipper Flags & SO Flags + they are very so dependent */ + + file_handle = open(_parc(1),open_flags); + last_error = errno; + } + + _retni(file_handle); + return; +} + +HARBOUR FCREATE() +{ + PITEM arg1_it = _param(1,IT_STRING); + PITEM arg2_it = _param(1,IT_NUMERIC); + + int create_flags; + int file_handle = -1; + + if( arg1_it ) + { + if( arg2_it ) + create_flags = _parni(2); + else + create_flags = 0; + + /* TODO: Study equivalence between Clipper Flags & SO Flags + they are very so dependent */ + + file_handle = creat(_parc(1),create_flags); + last_error = errno; + } + + _retni(file_handle); + return; +} + +HARBOUR FREAD() +{ + PITEM arg1_it = _param(1,IT_NUMERIC); + PITEM arg2_it = _param(1,IT_STRING+IT_BYREF); + PITEM arg3_it = _param(1,IT_NUMERIC); + + long bytes=0; + + if( arg1_it && arg2_it && arg3_it ) + { + bytes = read(_parni(1),_parc(2),_parnl(3)); + last_error = errno; + } + + _retnl(bytes); + return; +} + +HARBOUR FWRITE() +{ + PITEM arg1_it = _param( 1, IT_NUMERIC ); + PITEM arg2_it = _param( 2, IT_STRING ); + long bytes = 0; + + if( arg1_it && arg2_it ) + { + bytes = write( _parni( 1 ), _parc( 2 ), + _parnl( 3 ) ? _parnl( 3 ): _parclen( 2 ) ); + last_error = errno; + } + _retnl( bytes ); +} + +HARBOUR FERROR() +{ + _retni(last_error); + return; +} + +HARBOUR FCLOSE() +{ + PITEM arg1_it = _param(1,IT_NUMERIC); + int result=-1; + + if( arg1_it ) + { + result=close(_parni(1)); + //last_error = errno; + } + + _retl(result>=0?1:0); + return; +} + +HARBOUR FERASE() +{ + PITEM arg1_it = _param(1,IT_STRING); + + int result = -1; + + if( arg1_it ) + { + result=unlink(_parc(1)); + last_error = errno; + } + + _retni(result); + return; +} + +HARBOUR FRENAME() +{ + PITEM arg1_it = _param(1,IT_STRING); + PITEM arg2_it = _param(1,IT_STRING); + + int result=-1; + + if( arg1_it && arg2_it ) + { + result = rename(_parc(1),_parc(1)); + last_error = errno; + } + + _retni(result); + return; +} + +HARBOUR FSEEK() +{ + PITEM arg1_it = _param(1,IT_NUMERIC); + PITEM arg2_it = _param(1,IT_NUMERIC); + PITEM arg3_it = _param(1,IT_NUMERIC); + + long bytes=0; + + if( arg1_it && arg2_it && arg3_it ) + { + bytes = lseek(_parni(1),_parnl(2),_parni(3)); + last_error = errno; + } + + _retnl(bytes); + return; +} + +HARBOUR File() +{ + PITEM arg1_it = _param( 1, IT_STRING ); + + if( arg1_it ) + { + // TODO: In this moment I'm thinking about two alternatives + } +} + +HARBOUR FREADSTR() +{ + PITEM arg1_it = _param( 1, IT_NUMERIC ); + + int handle; + long bytes; + long readed; + char * buffer; + char ch[1]; + + if( arg1_it ) + { + handle = _parni(1); + bytes = _parnl(2); + buffer = ( char * ) _xgrab(bytes); + + readed=0; ch[0]=1; + while( readed < bytes ) + { + bytes = read(handle,ch,1); + if( bytes < 1 || ch[0] == 0 ) + break; + buffer[readed]=ch[0]; + readed++; + } + + buffer[readed]=0; + _retc(buffer); + _xfree(buffer); + } + else + _retc(""); + + return; +} + +HARBOUR BIN2I() +{ + PITEM arg1_it = _param( 1, IT_STRING ); + char * s; + int result=0; + + if( arg1_it ) + { + s = _parc(1); + if( _parclen(1) >= 2 ) + result = MKINT(s[0],s[1]); + else + result = 0; + } + + _retni(result); + return; +} + +HARBOUR BIN2L() +{ + PITEM arg1_it = _param( 1, IT_STRING ); + char * s; + long result=0; + + if( arg1_it ) + { + s = _parc(1); + if( _parclen(1) >= 4 ) + result = MKLONG(s[0],s[1],s[2],s[3]); + else + result = 0; + } + + _retni(result); + return; +} + +HARBOUR BIN2W() +{ + BIN2I(); +} + +HARBOUR I2BIN() +{ + PITEM arg1_it = _param( 1, IT_INTEGER ); + int n; + char s[3]; + + if( arg1_it ) + { + n = _parni(1); + s[0] = n & 0xFF; + s[1] = (n & 0xFF00)>>8; + s[2] = 0; + _retclen(s,3); + } + else + _retclen("\0\0\0",3); + + return; +} + +HARBOUR L2BIN() +{ + PITEM arg1_it = _param( 1, IT_LONG ); + long n; + char s[5]; + + if( arg1_it ) + { + n = _parnl(1); + s[0] = n & 0x000000FF; + s[1] = (n & 0x0000FF00)>>8; + s[2] = (n & 0x00FF0000)>>16; + s[3] = (n & 0xFF000000)>>24; + s[4] = 0; + _retclen(s,5); + } + else + _retclen("\0\0\0\0\0",5); + + return; +} + +HARBOUR W2BIN() +{ + I2BIN(); +} diff --git a/harbour/source/rtl/itemapi.c b/harbour/source/rtl/itemapi.c new file mode 100644 index 0000000000..07c191992a --- /dev/null +++ b/harbour/source/rtl/itemapi.c @@ -0,0 +1,360 @@ +#include +#include +#include + +extern STACK stack; +extern PSYMBOL symEval; + +/* TODO: Someone make a dates.h so this isn't necessary! */ +long greg2julian( long lDay, long lMonth, long lYear ); +extern void julian2greg( long julian, long * plDay, long * plMonth, long * plYear ); + +BOOL _evalNew( PEVALINFO pEvalInfo, PITEM pItem ) +{ + BOOL bResult = FALSE; + + if( pEvalInfo ) + { + memset( pEvalInfo, 0, sizeof( EVALINFO ) ); + pEvalInfo->pItems[ 0 ] = _itemNew( 0 ); + ItemCopy( pEvalInfo->pItems[ 0 ], pItem ); + bResult = TRUE; + } + return bResult; +} + +BOOL _evalPutParam( PEVALINFO pEvalInfo, PITEM pItem ) +{ + BOOL bResult = FALSE; + WORD w; + + if( pEvalInfo ) + { + for( w = 1; w < 10; w++ ) /* note that 0 position is used by the codeblock or function name item */ + { + if( ! pEvalInfo->pItems[ w ] ) + { + pEvalInfo->pItems[ w ] = _itemNew( 0 ); + ItemCopy( pEvalInfo->pItems[ w ], pItem ); + bResult = TRUE; + break; + } + } + } + return bResult; +} + +BOOL _evalRelease( PEVALINFO pEvalInfo ) +{ + BOOL bResult = FALSE; + WORD w; + + if( pEvalInfo ) + { + for( w = 0; w < 10; w++ ) + _itemRelease( pEvalInfo->pItems[ w ] ); + bResult = TRUE; + } + return bResult; +} + +PITEM _evalLaunch( PEVALINFO pEvalInfo ) +{ + WORD w = 1; + PITEM pResult = 0; + + if( pEvalInfo ) + { + if( IS_STRING( pEvalInfo->pItems[ 0 ] ) ) + { + PushSymbol( GetDynSym( _itemGetC( pEvalInfo->pItems[ 0 ] ) )->pSymbol ); + PushNil(); + while( w < 10 && pEvalInfo->pItems[ w ] ) + Push( pEvalInfo->pItems[ w++ ] ); + Do( w - 1 ); + pResult = _itemNew( 0 ); + ItemCopy( pResult, &stack.Return ); + } + else if( IS_BLOCK( pEvalInfo->pItems[ 0 ] ) ) + { + PushSymbol( symEval ); + Push( pEvalInfo->pItems[ 0 ] ); + while( w < 10 && pEvalInfo->pItems[ w ] ) + Push( pEvalInfo->pItems[ w++ ] ); + Do( w - 1 ); + pResult = _itemNew( 0 ); + ItemCopy( pResult, &stack.Return ); + } + } + return pResult; +} + +PITEM _itemNew( PITEM pNull ) +{ + PITEM pItem = ( PITEM ) _xgrab( sizeof( ITEM ) ); + + if( pNull ) /* keep the C compiler silent */ + pNull->wType = 0; /* keep the C compiler silent */ + + memset( pItem, 0, sizeof( ITEM ) ); + pItem->wType = IT_NIL; + + return pItem; +} + +PITEM _itemParam( WORD wParam ) +{ + PITEM pNew = _itemNew( 0 ); + + if( _param( wParam, IT_ANY ) ) + ItemCopy( pNew, _param( wParam, IT_ANY ) ); + + return pNew; +} + +BOOL _itemRelease( PITEM pItem ) +{ + BOOL bResult = FALSE; + + if( pItem ) + { + _xfree( pItem ); + bResult = TRUE; + } + return bResult; +} + +PITEM _itemArrayNew( ULONG ulLen ) +{ + PITEM pItem = _itemNew(0); + + Array(pItem, ulLen); + + return pItem; +} + +PITEM _itemArrayGet( PITEM pArray, ULONG ulIndex ) +{ + PITEM pItem = _itemNew(0); + + ArrayGet(pArray, ulIndex, pItem); + + return pItem; +} + +PITEM _itemArrayPut( PITEM pArray, ULONG ulIndex, PITEM pItem ) +{ + ArraySet(pArray, ulIndex, pItem); + return pArray; +} + +PITEM _itemPutC( PITEM pItem, char * szText ) +{ + if( pItem ) + { + ItemRelease( pItem ); /* warning: this is hvm.c one not this one */ + pItem->wType = IT_STRING; + pItem->wLength = strlen( szText ); + pItem->value.szText = ( char * ) _xgrab( pItem->wLength + 1 ); + strcpy( pItem->value.szText, szText ); + } + return pItem; +} + +PITEM _itemPutCL( PITEM pItem, char * nszText, ULONG ulLen ) +{ + if( pItem ) + { + ItemRelease( pItem ); /* warning: this is hvm.c one not this one */ + pItem->wType = IT_STRING; + pItem->wLength = ulLen; + pItem->value.szText = ( char * ) _xgrab( ulLen + 1 ); + memcpy( pItem->value.szText, nszText, ulLen ); + pItem->value.szText[ ulLen ] = 0; + } + return pItem; +} + +char *_itemGetC( PITEM pItem ) +{ + if( pItem && IS_STRING( pItem ) ) + { + char *szResult = (char *)_xgrab(pItem->wLength + 1); + memcpy(szResult, pItem->value.szText, pItem->wLength); + szResult[pItem->wLength] = 0; + + return szResult; + } + else + return NULL; +} + +ULONG _itemCopyC( PITEM pItem, char *szBuffer, ULONG ulLen ) +{ + if( pItem && IS_STRING(pItem) ) + { + if( !ulLen ) + ulLen = pItem->wLength; + + memcpy(szBuffer, pItem->value.szText, ulLen); + return ulLen; + } + else + return 0; +} + +BOOL _itemFreeC( char *szText ) +{ + BOOL bResult = FALSE; + + if( szText ) + { + _xfree(szText); + bResult = TRUE; + } + return bResult; +} + +char *_itemGetDS( PITEM pItem, char *szDate ) +{ + if( pItem && IS_DATE(pItem) ) + { + long lDay, lMonth, lYear; + julian2greg(pItem->value.lDate, &lDay, &lMonth, &lYear); + + szDate[ 0 ] = ( lYear / 1000 ) + '0'; + szDate[ 1 ] = ( ( lYear % 1000 ) / 100 ) + '0'; + szDate[ 2 ] = ( ( lYear % 100 ) / 10 ) + '0'; + szDate[ 3 ] = ( lYear % 10 ) + '0'; + + szDate[ 4 ] = ( lMonth / 10 ) + '0'; + szDate[ 5 ] = ( lMonth % 10 ) + '0'; + + szDate[ 6 ] = ( lDay / 10 ) + '0'; + szDate[ 7 ] = ( lDay % 10 ) + '0'; + szDate[ 8 ] = 0; + + return szDate; + } + else + return "00000000"; +} + +BOOL _itemGetL( PITEM pItem ) +{ + if( pItem && IS_LOGICAL(pItem) ) + { + return pItem->value.iLogical; + } + else + return FALSE; +} + +double _itemGetND( PITEM pItem ) +{ + if( pItem ) + { + switch( pItem->wType ) + { + case IT_INTEGER: return pItem->value.iNumber; + case IT_DOUBLE: return pItem->value.dNumber; + case IT_LONG: return pItem->value.lNumber; + default: return 0; + } + } + else + return 0; +} + +long _itemGetNL( PITEM pItem ) +{ + if( pItem ) + { + switch( pItem->wType ) + { + case IT_INTEGER: return pItem->value.iNumber; + case IT_DOUBLE: return pItem->value.dNumber; + case IT_LONG: return pItem->value.lNumber; + default: return 0; + } + } + else + return 0; +} + +PITEM _itemReturn( PITEM pItem ) +{ + if( pItem ) + ItemCopy(&stack.Return, pItem); + + return pItem; +} + +PITEM _itemPutDS( PITEM pItem, char *szDate ) +{ + if( pItem ) + { + long lDay, lMonth, lYear; + + lDay = ((szDate[ 6 ] - '0') * 10) + (szDate[ 7 ] - '0'); + lMonth = ((szDate[ 4 ] - '0') * 10) + (szDate[ 5 ] - '0'); + lYear = ((szDate[ 0 ] - '0') * 1000) + ((szDate[ 1 ] - '0') * 100) + + ((szDate[ 2 ] - '0') * 10) + (szDate[ 3 ] - '0'); + + ItemRelease( pItem ); + pItem->wType = IT_DATE; + pItem->wLength = 8; + /* QUESTION: Is this ok ? we are going to use a long to store the date */ + /* QUESTION: What happens if we use sizeof( LONG ) instead ? */ + /* QUESTION: Would it break Clipper language code ? */ + pItem->value.lDate = greg2julian(lDay, lMonth, lYear); + } + return pItem; +} + +PITEM _itemPutL( PITEM pItem, BOOL bValue ) +{ + if( pItem ) + { + ItemRelease( pItem ); /* warning: this is hvm.c one not this one */ + pItem->wType = IT_LOGICAL; + pItem->wLength = 1; + pItem->value.iLogical = bValue; + } + return pItem; +} + +PITEM _itemPutND( PITEM pItem, double dNumber ) +{ + if( pItem ) + { + ItemRelease( pItem ); /* warning: this is hvm.c one not this one */ + pItem->wType = IT_DOUBLE; + pItem->wLength = sizeof( double ); + pItem->value.dNumber = dNumber; + } + return pItem; +} + +PITEM _itemPutNL( PITEM pItem, long lNumber ) +{ + if( pItem ) + { + ItemRelease( pItem ); /* warning: this is hvm.c one not this one */ + pItem->wType = IT_DOUBLE; + pItem->wLength = sizeof( double ); + pItem->value.lNumber = lNumber; + } + return pItem; +} + + +ULONG _itemSize( PITEM pItem ) +{ + return pItem->wLength; +} + +WORD _itemType( PITEM pItem ) +{ + return pItem->wType; +} diff --git a/harbour/source/rtl/math.c b/harbour/source/rtl/math.c new file mode 100644 index 0000000000..2667bd215a --- /dev/null +++ b/harbour/source/rtl/math.c @@ -0,0 +1,278 @@ +#include +#include + +HARBOUR ABS( void ) +{ + if( _pcount() == 1 ) + { + PITEM pNumber = _param(1, IT_NUMERIC); + + if( pNumber ) + { + double dNumber = _parnd(1); + + if( dNumber >= 0 ) + _retnd( dNumber ); + else + _retnd( -dNumber ); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: ABS"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: ABS"); + _errLaunch(pError); + _errRelease(pError); + } +} + +HARBOUR EXP( void ) +{ + if( _pcount() == 1 ) + { + PITEM pNumber = _param(1, IT_NUMERIC); + + if( pNumber ) + { + _retnd( exp(_parnd(1)) ); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: EXP"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: EXP"); + _errLaunch(pError); + _errRelease(pError); + } +} + +HARBOUR INT( void ) +{ + if( _pcount() == 1 ) + { + PITEM pNumber = _param(1, IT_NUMERIC); + + if( pNumber ) + { + _retnl( _parnd(1) ); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: INT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: INT"); + _errLaunch(pError); + _errRelease(pError); + } +} + +HARBOUR LOG( void ) +{ + if( _pcount() == 1 ) + { + PITEM pNumber = _param(1, IT_NUMERIC); + + if( pNumber ) + { + double dNumber = _parnd(1); + if( dNumber > 0 ) + _retnd( log(dNumber) ); + else + /* TODO: return OVERFLOW */ + _retnd(0); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: LOG"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: LOG"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns the maximum of two date or numerics */ +HARBOUR MAX( void ) +{ + if( _pcount() == 2 ) + { + PITEM p1 = _param(1, IT_NUMERIC + IT_DATE), p2 = _param(2, IT_NUMERIC + IT_DATE); + + if( p1 && p2 && p1->wType == p2->wType ) + { + if( p1->wType == IT_DATE ) + { + long l1 = p1->value.lDate, l2 = p2->value.lDate; + _retds(l1 > l2? _pards(1): _pards(2)); + } + else + { + double d1 = _parnd(1), d2 = _parnd(2); + _retnd(d1 > d2? d1: d2); + } + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: MAX"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: MAX"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns the minimum of two date or numerics */ +HARBOUR MIN( void ) +{ + if( _pcount() == 2 ) + { + PITEM p1 = _param(1, IT_NUMERIC + IT_DATE), p2 = _param(2, IT_NUMERIC + IT_DATE); + + if( p1 && p2 && p1->wType == p2->wType ) + { + if( p1->wType == IT_DATE ) + { + long l1 = p1->value.lDate, l2 = p2->value.lDate; + _retds(l1 < l2? _pards(1): _pards(2)); + } + else + { + double d1 = _parnd(1), d2 = _parnd(2); + _retnd(d1 < d2? d1: d2); + } + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: MIN"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: MIN"); + _errLaunch(pError); + _errRelease(pError); + } +} + +HARBOUR MOD( void ) +{ +/* +FUNCTION MOD(cl_num, cl_base) + + LOCAL cl_result + + cl_result = cl_num % cl_base + + RETURN IF( cl_base = 0, ; + cl_num,; + IF(cl_result * cl_base < 0, cl_result + cl_base, cl_result) ) +*/ + PITEM pNumber = _param(1, IT_NUMERIC); + PITEM pBase = _param(2, IT_NUMERIC); + + if( pNumber && pBase ) + { + double dNumber = _parnd(1); + double dBase = _parnd(2); /* dBase! Cool! */ + double dResult; + + if( dBase ) + { + dResult = dNumber - ((long)(dNumber / dBase) * dBase); + + if( dResult * dBase < 0 ) + _retnd(dResult + dBase); + else + _retnd(dResult); + } + else + _retnd(dNumber); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: %"); + _errLaunch(pError); + _errRelease(pError); + } +} + +HARBOUR SQRT( void ) +{ + if( _pcount() == 1 ) + { + PITEM pNumber = _param(1, IT_NUMERIC); + + if( pNumber ) + { + double dNumber = _parnd(1); + + if( dNumber > 0 ) + _retnd( sqrt(dNumber) ); + else + /* Clipper doesn't error! */ + _retnd(0); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: SQRT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: SQRT"); + _errLaunch(pError); + _errRelease(pError); + } +} + diff --git a/harbour/source/rtl/mathx.c b/harbour/source/rtl/mathx.c new file mode 100644 index 0000000000..3f5f56118d --- /dev/null +++ b/harbour/source/rtl/mathx.c @@ -0,0 +1,135 @@ +#include +#include + +#ifndef M_PI_2 +#define M_PI_2 1.57079632679489661923 +#endif + +HARBOUR ACOS( void ) +{ + if( _pcount() > 0 ) + { + double dNumber = _parnd(1); + + if( dNumber >= -1 && dNumber <= 1 ) + _retnd( acos(dNumber) ); + else + /* TODO: Error or return NAN */ + _retnd(0); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR ASIN( void ) +{ + if( _pcount() > 0 ) + { + double dNumber = _parnd(1); + + if( dNumber >= -1 && dNumber <= 1 ) + _retnd( asin(dNumber) ); + else + /* TODO: Error or return NAN */ + _retnd(0); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR ATAN( void ) +{ + if( _pcount() > 0 ) + { + double dNumber = _parnd(1); + + if( dNumber >= -M_PI_2 && dNumber <= M_PI_2 ) + _retnd( atan(dNumber) ); + else + /* TODO: Error or return NAN */ + _retnd(0); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR COS( void ) +{ + if( _pcount() > 0 ) + { + _retnd( cos( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR COSH( void ) +{ + if( _pcount() > 0 ) + { + _retnd( cosh( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR LOG10( void ) +{ + if( _pcount() > 0 ) + { + _retnd( log10( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR SIN( void ) +{ + if( _pcount() > 0 ) + { + _retnd( sin( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR SINH( void ) +{ + if( _pcount() > 0 ) + { + _retnd( sinh( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR TAN( void ) +{ + if( _pcount() > 0 ) + { + _retnd( tan( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + +HARBOUR TANH( void ) +{ + if( _pcount() > 0 ) + { + _retnd( tanh( _parnd(1) ) ); + } + else + /* TODO: Error or return NAN */ + _retnd(0); +} + diff --git a/harbour/source/rtl/set.c b/harbour/source/rtl/set.c new file mode 100644 index 0000000000..a8a6d43528 --- /dev/null +++ b/harbour/source/rtl/set.c @@ -0,0 +1,295 @@ +#include +#include +#include + +HB_set_struct HB_set; +BOOL HB_set_century; + +static BOOL set_logical (PITEM pItem) +{ + BOOL logical; + if (IS_LOGICAL (pItem)) logical = pItem->value.iLogical; + else logical = FALSE; + return (logical); +} + +static int set_number (PITEM pItem, int old_value) +{ + int number; + if (IS_INTEGER (pItem)) number = pItem->value.iNumber; + else if (IS_LONG (pItem)) number = (int)pItem->value.lNumber; + else if (IS_DOUBLE (pItem)) number = (int)pItem->value.dNumber; + else number = old_value; + return (number); +} + +static char * set_string (PITEM pItem, char * old_str, int size_limit) +{ + char * string; + if (IS_STRING (pItem)) + { + int size = pItem->wLength; + if (size_limit > 0 && size > size_limit) size = size_limit; + if (old_str) string = _xrealloc (old_str, size + 1); + else string = _xgrab (size + 1); + memcpy (string, pItem->value.szText, size); + string [size] = 0; + } + else string = old_str; + return (string); +} + +HARBOUR __SETCENTURY (void) +{ + PITEM pItem = _param (1, IT_ANY); + + _retl (HB_set_century); + if (IS_LOGICAL (pItem)) HB_set_century = pItem->value.iLogical; + else if (IS_STRING (pItem)) + { + if (pItem->wLength == 2 && toupper (pItem->value.szText [0]) == 'O' + && toupper (pItem->value.szText [1]) == 'N') + HB_set_century = TRUE; + else if (pItem->wLength == 3 && toupper (pItem->value.szText [0]) == 'O' + && toupper (pItem->value.szText [1]) == 'F' && toupper (pItem->value.szText [2]) == 'F') + HB_set_century = FALSE; + } +} + +HARBOUR SET (void) +{ + int args = _pcount(); + PITEM pArg2; + + HB_set_enum set_specifier = _parni(1); + if (args > 1) pArg2 = _param (2, IT_ANY); + + switch (set_specifier) + { + case _SET_ALTERNATE : + _retl (HB_set._SET_ALTERNATE); + if (args > 1) HB_set._SET_ALTERNATE = set_logical (pArg2); + break; + case _SET_ALTFILE : + if (HB_set._SET_ALTFILE) _retc (HB_set._SET_ALTFILE); + else _retc (""); + if (args > 1) HB_set._SET_ALTFILE = set_string (pArg2, HB_set._SET_ALTFILE, 0); + break; + case _SET_BELL : + _retl (HB_set._SET_BELL); + if (args > 1) HB_set._SET_BELL = set_logical (pArg2); + break; + case _SET_CANCEL : + _retl (HB_set._SET_CANCEL); + if (args > 1) HB_set._SET_CANCEL = set_logical (pArg2); + break; + case _SET_COLOR : + if (HB_set._SET_COLOR) _retc (HB_set._SET_COLOR); + else _retc (""); + if (args > 1) HB_set._SET_COLOR = set_string (pArg2, HB_set._SET_COLOR, 0); + break; + case _SET_CONFIRM : + _retl (HB_set._SET_CONFIRM); + if (args > 1) HB_set._SET_CONFIRM = set_logical (pArg2); + break; + case _SET_CONSOLE : + _retl (HB_set._SET_CONSOLE); + if (args > 1) HB_set._SET_CONSOLE = set_logical (pArg2); + break; + case _SET_CURSOR : + _retni (HB_set._SET_CURSOR); + if (args > 1) HB_set._SET_CURSOR = set_number (pArg2, HB_set._SET_CURSOR); + break; + case _SET_DATEFORMAT : + if (HB_set._SET_DATEFORMAT) _retc (HB_set._SET_DATEFORMAT); + else _retc (""); + if (args > 1) HB_set._SET_DATEFORMAT = set_string (pArg2, HB_set._SET_DATEFORMAT, 10); + break; + case _SET_DEBUG : + _retl (HB_set._SET_DEBUG); + if (args > 1) HB_set._SET_DEBUG = set_logical (pArg2); + break; + case _SET_DECIMALS : + _retni (HB_set._SET_DECIMALS); + if (args > 1) HB_set._SET_DECIMALS = set_number (pArg2, HB_set._SET_DECIMALS); + break; + case _SET_DEFAULT : + if (HB_set._SET_DEFAULT) _retc (HB_set._SET_DEFAULT); + else _retc (""); + if (args > 1) HB_set._SET_DEFAULT = set_string (pArg2, HB_set._SET_DEFAULT, 0); + break; + case _SET_DELETED : + _retl (HB_set._SET_DELETED); + if (args > 1) HB_set._SET_DELETED = set_logical (pArg2); + break; + case _SET_DELIMCHARS : + if (HB_set._SET_DELIMCHARS) _retc (HB_set._SET_DELIMCHARS); + else _retc (""); + if (args > 1) HB_set._SET_DELIMCHARS = set_string (pArg2, HB_set._SET_DELIMCHARS, 0); + break; + case _SET_DELIMITERS : + _retl (HB_set._SET_DELIMITERS); + if (args > 1) HB_set._SET_DELIMITERS = set_logical (pArg2); + break; + case _SET_DEVICE : + if (HB_set._SET_DEVICE) _retc (HB_set._SET_DEVICE); + else _retc (""); + if (args > 1) HB_set._SET_DEVICE = set_string (pArg2, HB_set._SET_DEVICE, 0); + break; + case _SET_EPOCH : + _retni (HB_set._SET_EPOCH); + if (args > 1) HB_set._SET_EPOCH = set_number (pArg2, HB_set._SET_EPOCH); + break; + case _SET_ESCAPE : + _retl (HB_set._SET_ESCAPE); + if (args > 1) HB_set._SET_ESCAPE = set_logical (pArg2); + break; + case _SET_EVENTMASK : + _retni (HB_set._SET_EVENTMASK); + if (args > 1) HB_set._SET_EVENTMASK = set_number (pArg2, HB_set._SET_EVENTMASK); + break; + case _SET_EXACT : + _retl (HB_set._SET_EXACT); + if (args > 1) HB_set._SET_EXACT = set_logical (pArg2); + break; + case _SET_EXCLUSIVE : + _retl (HB_set._SET_EXCLUSIVE); + if (args > 1) HB_set._SET_EXCLUSIVE = set_logical (pArg2); + break; + case _SET_EXIT : + _retl (HB_set._SET_EXIT); + if (args > 1) HB_set._SET_EXIT = set_logical (pArg2); + break; + case _SET_EXTRA : + _retl (HB_set._SET_EXTRA); + if (args > 1) HB_set._SET_EXTRA = set_logical (pArg2); + break; + case _SET_EXTRAFILE : + if (HB_set._SET_EXTRAFILE) _retc (HB_set._SET_EXTRAFILE); + else _retc (""); + if (args > 1) HB_set._SET_EXTRAFILE = set_string (pArg2, HB_set._SET_EXTRAFILE, 0); + break; + case _SET_FIXED : + _retl (HB_set._SET_FIXED); + if (args > 1) HB_set._SET_FIXED = set_logical (pArg2); + break; + case _SET_INSERT : + _retl (HB_set._SET_INSERT); + if (args > 1) HB_set._SET_INSERT = set_logical (pArg2); + break; + case _SET_INTENSITY : + _retl (HB_set._SET_INTENSITY); + if (args > 1) HB_set._SET_INTENSITY = set_logical (pArg2); + break; + case _SET_MARGIN : + _retni (HB_set._SET_MARGIN); + if (args > 1) HB_set._SET_MARGIN = set_number (pArg2, HB_set._SET_MARGIN); + break; + case _SET_MCENTER : + _retl (HB_set._SET_MCENTER); + if (args > 1) HB_set._SET_MCENTER = set_logical (pArg2); + break; + case _SET_MESSAGE : + _retni (HB_set._SET_MESSAGE); + if (args > 1) HB_set._SET_MESSAGE = set_number (pArg2, HB_set._SET_MESSAGE); + break; + case _SET_PATH : + if (HB_set._SET_PATH) _retc (HB_set._SET_PATH); + if (args > 1) HB_set._SET_PATH = set_string (pArg2, HB_set._SET_PATH, 0); + else _retc (""); + break; + case _SET_PRINTER : + _retl (HB_set._SET_PRINTER); + if (args > 1) HB_set._SET_PRINTER = set_logical (pArg2); + break; + case _SET_PRINTFILE : + if (HB_set._SET_PRINTFILE) _retc (HB_set._SET_PRINTFILE); + else _retc (""); + if (args > 1) HB_set._SET_PRINTFILE = set_string (pArg2, HB_set._SET_PRINTFILE, 0); + break; + case _SET_SCOREBOARD : + _retl (HB_set._SET_SCOREBOARD); + if (args > 1) HB_set._SET_SCOREBOARD = set_logical (pArg2); + break; + case _SET_SCROLLBREAK: + _retl (HB_set._SET_SCROLLBREAK); + if (args > 1) HB_set._SET_SCROLLBREAK = set_logical (pArg2); + break; + case _SET_SOFTSEEK : + _retl (HB_set._SET_SOFTSEEK); + if (args > 1) HB_set._SET_SOFTSEEK = set_logical (pArg2); + break; + case _SET_TYPEAHEAD : + _retni (HB_set._SET_TYPEAHEAD); + if (args > 1) HB_set._SET_TYPEAHEAD = set_logical (pArg2); + break; + case _SET_UNIQUE : + _retl (HB_set._SET_UNIQUE); + if (args > 1) HB_set._SET_UNIQUE = set_logical (pArg2); + break; + case _SET_WRAP : + _retl (HB_set._SET_WRAP); + if (args > 1) HB_set._SET_WRAP = set_logical (pArg2); + break; + } +} + +void HB_init_set (void) +{ + HB_set_century = FALSE; + HB_set._SET_ALTERNATE = FALSE; + HB_set._SET_ALTFILE = 0; /* NULL pointer */ + HB_set._SET_BELL = FALSE; + HB_set._SET_CANCEL = TRUE; + HB_set._SET_COLOR = _xgrab (20); + memcpy (HB_set._SET_COLOR, "W/N,N/W,N/N,N/N,N/W", 20); + HB_set._SET_CONFIRM = FALSE; + HB_set._SET_CONSOLE = TRUE; + HB_set._SET_CURSOR = SC_NORMAL; + HB_set._SET_DATEFORMAT = _xgrab (9); + memcpy (HB_set._SET_DATEFORMAT, "mm/dd/yy", 9); + HB_set._SET_DEBUG = FALSE; + HB_set._SET_DECIMALS = 2; + HB_set._SET_DEFAULT = _xgrab (1); + *HB_set._SET_DEFAULT = 0; + HB_set._SET_DELETED = FALSE; + HB_set._SET_DELIMCHARS = _xgrab (3); + memcpy (HB_set._SET_DELIMCHARS, "::", 3); + HB_set._SET_DELIMITERS = FALSE; + HB_set._SET_DEVICE = _xgrab (7); + memcpy (HB_set._SET_DEVICE, "SCREEN", 7); + HB_set._SET_EPOCH = 1900; + HB_set._SET_ESCAPE = 1; + HB_set._SET_EVENTMASK = INKEY_KEYBOARD; + HB_set._SET_EXACT = FALSE; + HB_set._SET_EXCLUSIVE = TRUE; + HB_set._SET_EXIT = FALSE; + HB_set._SET_EXTRA = FALSE; /* TODO: What is this for? */ + HB_set._SET_EXTRAFILE = 0; /* TODO: What is this for? */ + HB_set._SET_FIXED = FALSE; + HB_set._SET_INSERT = FALSE; + HB_set._SET_INTENSITY = TRUE; + HB_set._SET_MARGIN = 0; + HB_set._SET_MCENTER = FALSE; + HB_set._SET_MESSAGE = 0; + HB_set._SET_PATH = _xgrab (1); + *HB_set._SET_PATH = 0; + HB_set._SET_PRINTER = FALSE; + HB_set._SET_PRINTFILE = 0; /* NULL pointer */ + HB_set._SET_SCOREBOARD = TRUE; + HB_set._SET_SCROLLBREAK = TRUE; + HB_set._SET_SOFTSEEK = FALSE; + HB_set._SET_TYPEAHEAD = 50; + HB_set._SET_UNIQUE = FALSE; + HB_set._SET_WRAP = FALSE; +} + +void ReleaseSets (void) +{ + _xfree (HB_set._SET_COLOR); + _xfree (HB_set._SET_DATEFORMAT); + _xfree (HB_set._SET_DEFAULT); + _xfree (HB_set._SET_DELIMCHARS); + _xfree (HB_set._SET_DEVICE); + _xfree (HB_set._SET_PATH); +} diff --git a/harbour/source/rtl/strcmp.c b/harbour/source/rtl/strcmp.c new file mode 100644 index 0000000000..2b732b2e37 --- /dev/null +++ b/harbour/source/rtl/strcmp.c @@ -0,0 +1,41 @@ +#include + +int OurStrCmp( PITEM pFirst, PITEM pSecond ) /* Check whether two strings + are equal (0), smaller (-1), + or greater (1) */ +{ + char *szFirst = pFirst->value.szText; + char *szSecond = pSecond->value.szText; + long wLenFirst = pFirst->wLength; + long wLenSecond = pSecond->wLength; + long wMinLen = wLenFirst < wLenSecond ? wLenFirst : wLenSecond; + long wCounter; /* TODO : Should change w* to l* later on ... */ + /* TODO : Same applies to sz*. Any suggestions ? */ + int iRet = 0; /* Current status */ + + if( wMinLen ) /* One of the strings is empty */ + { + for( wCounter = 0; wCounter < wMinLen && !iRet; wCounter++ ) + { + if( *szFirst != *szSecond ) /* Difference found */ + iRet = (*szFirst < *szSecond) ? -1 : 1; + else /* TODO : #define some constants*/ + { + szFirst++; + szSecond++; + } + } + if( !iRet && wLenFirst != wLenSecond ) + /* If length is different ! */ + iRet = (wLenFirst < wLenSecond) ? -1 : 1; + } + else + { + if( wLenFirst != wLenSecond ) /* Both empty ? */ + iRet = (wLenFirst < wLenSecond) ? -1 : 1; + else + iRet = 0; /* Both empty => Equal ! */ + } + return(iRet); +} + diff --git a/harbour/source/rtl/strings.c b/harbour/source/rtl/strings.c new file mode 100644 index 0000000000..60d9f9f3b9 --- /dev/null +++ b/harbour/source/rtl/strings.c @@ -0,0 +1,1067 @@ +#include +#include + +/* TODO: search this file for TODO and find 'em! */ + +#define HB_ISSPACE(c) ((c) == 9 || (c) == 10 || (c) == 13 || (c) == 32) + +BOOL strempty( char * szText, long lLen ) +{ + BOOL bStillEmpty = TRUE; + char c; + + while( bStillEmpty && lLen-- ) /* Still blanks ? */ + { + c = *szText++; + if( !HB_ISSPACE(c) ) + bStillEmpty = FALSE; + } + return bStillEmpty; +} + +/* determines if first char of string is letter */ +/* TEST: QOUT( "isalpha( 'hello' ) = ", isalpha( 'hello' ) ) */ +/* TEST: QOUT( "isalpha( '12345' ) = ", isalpha( '12345' ) ) */ +HARBOUR ISALPHA( void ) +{ + _retl(isalpha(*_parc(1))); +} + +/* determines if first char of string is digit */ +/* TEST: QOUT( "isdigit( '12345' ) = ", isdigit( '12345' ) ) */ +/* TEST: QOUT( "isdigit( 'abcde' ) = ", isdigit( 'abcde' ) ) */ +HARBOUR ISDIGIT( void ) +{ + _retl(isdigit(*_parc(1))); +} + +/* determines if first char of string is upper-case */ +/* TEST: QOUT( "isupper( 'Abcde' ) = ", isupper( 'Abcde' ) ) */ +/* TEST: QOUT( "isupper( 'abcde' ) = ", isupper( 'abcde' ) ) */ +HARBOUR ISUPPER( void ) +{ + _retl(isupper(*_parc(1))); +} + +/* determines if first char of string is lower-case */ +/* TEST: QOUT( "islower( 'abcde' ) = ", islower( 'abcde' ) ) */ +/* TEST: QOUT( "islower( 'Abcde' ) = ", islower( 'Abcde' ) ) */ +HARBOUR ISLOWER( void ) +{ + _retl(islower(*_parc(1))); +} + +/* trims from the left, and returns a new pointer to szText */ +/* also returns the new length in lLen */ +char *LTrim( char *szText, long *lLen ) +{ + while( *lLen && HB_ISSPACE(*szText) ) + { + szText++; + (*lLen)--; + } + return szText; +} + +/* trims leading spaces from a string */ +/* TEST: QOUT( "ltrim( ' hello world ' ) = '" + ltrim( ' hello world ' ) + "'" ) */ +HARBOUR LTRIM( void ) +{ + if( _pcount() == 1 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + long lLen = pText->wLength; + char *szText = LTrim(pText->value.szText, &lLen); + + _retclen(szText, lLen); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: LTRIM"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: LTRIM"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns szText and the new length in lLen */ +long RTrimLen( char *szText, long lLen ) +{ + while( lLen && szText[lLen - 1] == ' ' ) + lLen--; + return lLen; +} + +/* trims trailing spaces from a string */ +/* TEST: QOUT( "rtrim( ' hello world ' ) = '" + rtrim( ' hello world ' ) + "'" ) */ +HARBOUR RTRIM( void ) +{ + if( _pcount() == 1 ) + { + PITEM pText = _param(1, IT_STRING); + if( pText ) + _retclen(pText->value.szText, RTrimLen(pText->value.szText, pText->wLength)); + else + /* Clipper doesn't error */ + _retc(""); + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: RTRIM"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* synonymn for RTRIM */ +HARBOUR TRIM( void ) +{ + RTRIM(); +} + +/* trims leading and trailing spaces from a string */ +/* TEST: QOUT( "alltrim( ' hello world ' ) = '" + alltrim( ' hello world ' ) + "'" ) */ +HARBOUR ALLTRIM( void ) +{ + if( _pcount() > 0 ) + { + char *szText = _parc(1); + long lLen = RTrimLen(szText, _parclen(1)); + + szText = LTrim(szText, &lLen); + + _retclen(szText, lLen); + } + else + /* Clipper doesn't error */ + _retc(""); +} + +/* right-pads a string with spaces or supplied character */ +/* TEST: QOUT( "padr( 'hello', 10 ) = '" + padr( 'hello', 10 ) + "'" ) */ +HARBOUR PADR( void ) +{ + char *szText = _parc(1); + if( _pcount() > 1 ) + { + long lLen = _parnl(2); + + if( lLen >= (long)_parclen(1) ) + { + char *szResult = (char *)_xgrab(lLen + 1); + long lPos; + char cPad; + + memcpy(szResult, szText, _parclen(1)); + + cPad = ( _pcount() > 2? *(_parc(3)): ' ' ); + + for( lPos = _parclen(1); lPos < lLen; lPos++ ) + szResult[lPos] = cPad; + + _retclen(szResult, lLen); + _xfree(szResult); + } + else if( lLen >= 0 ) + _retclen(szText, lLen); + else + _retc(""); + } + else + _retc(""); +} + +/* synonymn for PADR */ +HARBOUR PAD( void ) +{ + PADR(); +} + +/* left-pads a string with spaces or supplied character */ +/* TEST: QOUT( "padl( 'hello', 10 ) = '" + padl( 'hello', 10 ) + "'" ) */ +HARBOUR PADL( void ) +{ + char *szText = _parc(1); + + if( _pcount() > 1 ) + { + long lLen = _parnl(2); + + if( lLen > (long)_parclen(1) ) + { + char *szResult = (char *)_xgrab(lLen + 1); + long lPos = lLen - _parclen(1); + char cPad; + + memcpy(szResult + lPos, szText, _parclen(1)); + + cPad = (_pcount() > 2? *(_parc(3)): ' '); + + for(; lPos > 0; lPos--) + { + szResult[lPos - 1] = cPad; + } + + _retclen(szResult, lLen); + _xfree(szResult); + } + else if( lLen >= 0 ) + _retclen(szText, lLen); + else + _retc(""); + } + else + _retc(""); +} + +/* centre-pads a string with spaces or supplied character */ +/* TEST: QOUT( "padc( 'hello', 10 ) = '" + padc( 'hello', 10 ) + "'" ) */ +HARBOUR PADC( void ) +{ + char *szText = _parc(1); + + if( _pcount() > 1 ) + { + long lLen = _parnl(2); + + if( lLen > (long)_parclen(1) ) + { + char *szResult = (char *)_xgrab(lLen + 1); + char cPad; + long w, lPos = (lLen - _parclen(1)) / 2; + + memcpy(szResult + lPos, szText, _parclen(1) + 1); + + cPad = ( _pcount() > 2? *_parc(3): ' ' ); + + for( w = 0; w < lPos; w++ ) + szResult[w] = cPad; + + for( w = _parclen(1) + lPos; w < lLen; w++ ) + szResult[w] = cPad; + + szResult[lLen] = 0; + + _retclen(szResult, lLen); + _xfree(szResult); + } + else if( lLen >= 0 ) + _retclen(szText, lLen); + else + _retc(""); + } + else + _retc(""); +} + +ULONG At(char *szSub, long lSubLen, char *szText, long lLen) +{ + if( lSubLen ) + { + if( lLen > lSubLen ) + { + long lPos = 0, lSubPos = 0; + + while( lPos < lLen && lSubPos < lSubLen ) + { + if( *(szText + lPos) == *(szSub + lSubPos) ) + { + lSubPos++; + lPos++; + } + else if( lSubPos ) + lSubPos = 0; + else + lPos++; + } + return (lSubPos < lSubLen? 0: lPos - lSubLen + 1); + } + else + return 0; + } + else + return 1; +} + +/* locates a substring in a string */ +/* TEST: QOUT( "at( 'cde', 'abcdefgfedcba' ) = '" + at( 'cde', 'abcdefgfedcba' ) + "'" ) */ +HARBOUR AT( void ) +{ + PITEM pSub = _param(1, IT_ANY); + PITEM pText = _param(2, IT_ANY); + + if( pText && pSub ) + { + if( pText->wType == IT_STRING && pSub->wType == IT_STRING ) + { + _retnl( At(pSub->value.szText, pSub->wLength, pText->value.szText, pText->wLength) ); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: AT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: AT"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* locates a substring in a string starting at the end */ +/* TEST: QOUT( "rat( 'cde', 'abcdefgfedcba' ) = '" + rat( 'cde', 'abcdefgfedcba' ) + "'" ) */ +HARBOUR RAT( void ) +{ + long lSubLen = _parclen(1); + + if( lSubLen ) + { + long lPos = _parclen(2) - lSubLen; + if( lPos < 0 ) + _retni(0); + else + { + char *szSub = _parc(1); + char *szText = _parc(2); + int bFound = 0; + + while( lPos >= 0 && !bFound ) + { + if( *(szText + lPos) == *szSub ) + bFound = !memcmp(szSub, szText + lPos, lSubLen); + lPos--; + } + _retnl( bFound? lPos + 2: 0 ); + } + } + else + /* This function never seems to raise an error */ + _retni(0); +} + +/* converts an ASCII code to a character value */ +HARBOUR CHR( void ) +{ + if( _pcount() == 1 ) + { + PITEM pAsc = _param(1, IT_NUMERIC); + + if( pAsc ) + { + char chr[2]; + + /* Believe it or not, clipper does this! */ + chr[0] = _parnl(1) % 256; + chr[1] = 0; + _retclen(chr, 1); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: CHR"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: CHR"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* converts a character value to an ASCII code */ +HARBOUR ASC(void) +{ + if( _pcount() == 1 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + if( pText->wLength > 0 ) + _retni(*(pText->value.szText)); + else + _retni(0); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: ASC"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: ASC"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns the left-most n characters in string */ +HARBOUR LEFT( void ) +{ + if( _pcount() == 2 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + PITEM pLen = _param(2, IT_NUMERIC); + + if( pLen ) + { + long lLen = _parnl(2); + + if( lLen > pText->wLength ) + lLen = pText->wLength; + + else if( lLen < 0 ) + lLen = 0; + + _retclen(pText->value.szText, lLen); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: LEFT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: LEFT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: LEFT"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns the right-most n characters in string */ +HARBOUR RIGHT( void ) +{ + if( _pcount() == 2 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + PITEM pLen = _param(2, IT_NUMERIC); + + if( pLen ) + { + long lLen = _parnl(2); + + if( lLen > pText->wLength ) + lLen = pText->wLength; + + else if( lLen < 0 ) + lLen = 0; + + _retclen(pText->value.szText + pText->wLength - lLen, lLen); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: RIGHT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: RIGHT"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: RIGHT"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns l characters from n characters into string */ +HARBOUR SUBSTR( void ) +{ + if( _pcount() > 1 && _pcount() < 4 ) + { + PITEM pText = _param(1, IT_STRING); + PITEM pPos = _param(2, IT_NUMERIC); + + if( pText && pPos ) + { + long lPos = _parnl(2); + + if( lPos < 0 ) + { + lPos += pText->wLength; + if( lPos < 0 ) + lPos = 0; + } + else if( lPos ) + { + lPos--; + } + + if( lPos < pText->wLength ) + { + PITEM pLen = _param(3, IT_NUMERIC); + long lLen; + + if( pLen ) + { + lLen = _parnl(3); + + if( lLen > pText->wLength - lPos ) + lLen = pText->wLength - lPos; + } + else + lLen = pText->wLength - lPos; + + if( lLen > 0 ) + _retclen(pText->value.szText + lPos, lLen); + else + _retc(""); + } + else + _retc(""); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: SUBSTR"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: SUBSTR"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* converts szText to lower case. Does not create a new string! */ +char *Lower(char *szText, long lLen) +{ + long i; + for( i = 0; i < lLen; i++ ) + szText[i] = tolower(szText[i]); + return szText; +} + +/* converts string to lower case */ +HARBOUR LOWER( void ) +{ + if( _pcount() == 1 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + long lLen = pText->wLength; + + _retclen(Lower(pText->value.szText, lLen), lLen); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: LOWER"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: LOWER"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* converts szText to upper case. Does not create a new string! */ +char *Upper(char *szText, long lLen) +{ + long i; + for( i = 0; i < lLen; i++ ) + szText[i] = toupper(szText[i]); + return szText; +} + +/* converts string to upper case */ +HARBOUR UPPER( void ) +{ + if( _pcount() == 1 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + long lLen = pText->wLength; + + _retclen(Upper(pText->value.szText, lLen), lLen); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: LOWER"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: LOWER"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns n copies of given string */ +/* TEST: QOUT( "replicate( 'abc', 5 ) = " + replicate( 'abc', 5 ) ) */ +HARBOUR REPLICATE( void ) +{ + if( _pcount() == 2 ) + { + PITEM pText = _param(1, IT_STRING); + PITEM pTimes = _param(2, IT_NUMERIC); + + if( pText && pTimes ) + { + long lTimes = _parnl(2); + + if( lTimes > 0 ) + { + char *szText = pText->value.szText; + long lLen = pText->wLength; + char *szResult = (char *)_xgrab((lLen * lTimes) + 1); + char *szPtr = szResult; + long i; + + for( i = 0; i < lTimes; i++ ) + { + memcpy(szPtr, szText, lLen); + szPtr += lLen; + } + _retclen(szResult, lLen * lTimes); + _xfree(szResult); + } + else + _retc(""); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: REPLICATE"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: REPLICATE"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* returns n copies of a single space */ +/* TEST: QOUT( "space( 5 ) = '" + space( 5 ) + "'" ) */ +HARBOUR SPACE( void ) +{ + if( _pcount() == 1 ) + { + PITEM pLen = _param(1, IT_NUMERIC); + + if( pLen ) + { + long lLen = _parnl(1); + + if( lLen > 0 ) + { + char *szResult = (char *)_xgrab(lLen + 1); + + memset(szResult, ' ', lLen); + _retclen(szResult, lLen); + _xfree(szResult); + } + else + _retc(""); + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: SPACE"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: SPACE"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* replaces characters in a string */ +HARBOUR STUFF( void ) +{ + PITEM pText; + + pText = _param(1, IT_STRING); + if( pText ) + { + char *szText = pText->value.szText; + PITEM pPos, pDel, pInsert; + long lPos, lDel, lInsert, lTotalLen; + char *szInsert; + + pPos = _param(2, IT_NUMERIC); + lPos = (pPos? pPos->value.lNumber - 1: 0); + if( lPos > pText->wLength ) + lPos = pText->wLength; + + pDel = _param(3, IT_NUMERIC); + if( pDel ) + { + lDel = pDel->value.lNumber; + if( lDel > pText->wLength - lPos ) + lDel = pText->wLength - lPos; + } + else + lDel = 0; + + pInsert = _param(4, IT_STRING); + if( pInsert ) + { + szInsert = pInsert->value.szText; + lInsert = pInsert->wLength; + } + else + { + szInsert = ""; /* shouldn't matter that we don't allocate */ + lInsert = 0; + } + + if( (lTotalLen = pText->wLength + lInsert - lDel) > 0 ) + { + char *szResult = (char *)_xgrab(lTotalLen + 1); + + memcpy(szResult, szText, lPos); + memcpy(szResult + lPos, szInsert, lInsert); + memcpy(szResult + lPos + lInsert, szText + lPos + lDel, + pText->wLength - (lPos + lDel)); + + szResult[lTotalLen] = 0; + _retclen(szResult, lTotalLen); + _xfree(szResult); + } + else + _retc(""); + } + else + _retc(""); +} + +/* replaces lots of characters in a string */ +HARBOUR STRTRAN( void ) +{ + PITEM pText = _param(1, IT_STRING); + + if( pText ) + { + PITEM pSeek = _param(2, IT_STRING); + if( pSeek ) + { + char *szText = pText->value.szText; + if( pSeek->wLength && pSeek->wLength <= pText->wLength ) + { + char *szSeek = pSeek->value.szText; + PITEM pStart = _param(4, IT_NUMERIC); + char *szReplace; + long iStart; + + iStart = (pStart? _parnl(4): 1); + if( !iStart ) + { + /* Clipper seems to work this way */ + _retc(""); + } + else if( iStart > 0 ) + { + PITEM pReplace = _param(3, IT_STRING); + PITEM pCount = _param(5, IT_NUMERIC); + long iReplace; + long iCount, bAll; + + if( pReplace ) + { + szReplace = pReplace->value.szText; + iReplace = pReplace->wLength; + } + else + { + szReplace = ""; /* shouldn't matter that we don't allocate */ + iReplace = 0; + } + + if( pCount ) + { + iCount = pCount->value.lNumber; + bAll = 0; + } + else + { + iCount = 0; + bAll = 1; + } + + if( bAll || iCount > 0 ) + { + long iFound = 0; + long iReplaced = 0; + long i = 0; + long iLength = pText->wLength; + + while( i < pText->wLength ) + { + if( (bAll || iReplaced < iCount) && !memcmp(szText + i, szSeek, pSeek->wLength) ) + { + iFound++; + if( iFound >= iStart ) + { + iReplaced++; + iLength = iLength - pSeek->wLength + iReplace; + i += pSeek->wLength; + } + else + i++; + } + else + i++; + } + + if( iFound ) + { + char *szResult = (char *)_xgrab(iLength + 1); + char *szPtr = szResult; + + iFound = 0; + i = 0; + while( i < pText->wLength ) + { + if( iReplaced && !memcmp(szText + i, szSeek, pSeek->wLength) ) + { + iFound++; + if( iFound >= iStart ) + { + iReplaced--; + memcpy(szPtr, szReplace, iReplace); + szPtr += iReplace; + i += pSeek->wLength; + } + else + { + *szPtr = szText[i]; + szPtr++; + i++; + } + } + else + { + *szPtr = szText[i]; + szPtr++; + i++; + } + } + _retclen(szResult, iLength); + _xfree(szResult); + } + else + _retclen(szText, pText->wLength); + } + else + _retclen(szText, pText->wLength); + } + else + _retclen(szText, pText->wLength); + } + else + _retclen(szText, pText->wLength); + } + else + _retc(""); + } + else + _retc(""); +} + +/* returns an integer value of "numerical string" */ +double Val( char *szText ) +{ + return atof(szText); +} + +/* returns an integer value of "numerical string" */ +HARBOUR VAL( void ) +{ + if( _pcount() == 1 ) + { + PITEM pText = _param(1, IT_STRING); + + if( pText ) + _retnd(Val(pText->value.szText)); + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: VAL"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: VAL"); + _errLaunch(pError); + _errRelease(pError); + } +} + +/* converts a numberic to a string with given width & precision */ +HARBOUR STR( void ) +{ + if( _pcount() > 0 && _pcount() < 4 ) + { + PITEM pNumber = _param(1, IT_NUMERIC); + if( pNumber ) + { + double dNumber = _parnd(1); + char szResult[348]; /* QUESTION: what about _really_ long numbers? */ + + PITEM pWidth = _param(2, IT_NUMERIC); + PITEM pDec = _param(3, IT_NUMERIC); + int iDec = (pDec? _parnl(3): -1); + int iWidth; + + if( pWidth ) + { + iWidth = _parnl(2); + + if( pDec && iDec ) + { + if( sprintf(szResult, "%*.*f", iWidth, iDec, dNumber) > iWidth ) + memset(szResult, '*', iWidth); + } + else if( sprintf(szResult, "%*.0f", iWidth, dNumber) > iWidth ) + memset(szResult, '*', iWidth); + _retclen(szResult, iWidth); + } + else if( pDec ) + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: STR"); + _errLaunch(pError); + _errRelease(pError); + } + else + { + /* + TODO: Default formatting of Str() + + Numeric expression Length of the return character string + -------------------------------------------------------------- + Expressions/Constants At least ten digits plus decimal places + Field variable Field length including decimal places + Month()/Day() 3 digits + RecNo() 7 digits + Val() At least 3 digits + Year() 5 digits + */ + + /* get the width of the decimal places */ + int iDecWidth = sprintf(szResult, "%f", dNumber - (long)dNumber); + + /* now print it with width 10 + decimals (the 9 is due to the ".") */ + iWidth = sprintf(szResult, "%*f", 9 + iDecWidth, dNumber); + while( szResult[iWidth - 1] == '0' ) + iWidth--; + if( szResult[iWidth - 1] == '.' ) + iWidth--; + _retclen(szResult, iWidth); + } + } + else + { + PITEM pError = _errNew(); + _errPutDescription(pError, "Argument error: STR"); + _errLaunch(pError); + _errRelease(pError); + } + } + else + { + /* QUESTION: Clipper catches this at compile time! */ + PITEM pError = _errNew(); + _errPutDescription(pError, "Incorrect number of arguments: STR"); + _errLaunch(pError); + _errRelease(pError); + } +} + diff --git a/harbour/source/rtl/tclass.prg b/harbour/source/rtl/tclass.prg new file mode 100644 index 0000000000..26e97714c1 --- /dev/null +++ b/harbour/source/rtl/tclass.prg @@ -0,0 +1,157 @@ +// Harbour Class TClass to build classes + +#define MET_METHOD 0 +#define MET_DATA 1 +#define MET_CLASSDATA 2 +#define MET_INLINE 3 +#define MET_VIRTUAL 4 + +//----------------------------------------------------------------------------// + +function TClass() + + static hClass := 0 + + if hClass == 0 + hClass = ClassCreate( "TCLASS", 7 ) + + 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 ) + + 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 ) + endif + +return ClassInstance( hClass ) + +//----------------------------------------------------------------------------// + +static function New( cClassName ) + + local Self := QSelf() + + ::cName = cClassName + ::aDatas = {} + ::aMethods = {} + ::aClsDatas = {} + ::aInlines = {} + ::aVirtuals = {} + +return Self + +//----------------------------------------------------------------------------// + +static function Create() + + local Self := QSelf() + local n, nLen := Len( ::aDatas ) + local hClass := ClassCreate( ::cName, nLen ) + + ::hClass = hClass + + for n = 1 to nLen + ClassAdd( hClass, ::aDatas[ n ], n, MET_DATA ) + ClassAdd( hClass, "_" + ::aDatas[ n ], n, MET_DATA ) + next + + nLen = Len( ::aMethods ) + for n = 1 to nLen + ClassAdd( hClass, ::aMethods[ n ][ 1 ], ::aMethods[ n ][ 2 ], MET_METHOD ) + next + + nLen = Len( ::aClsDatas ) + for n = 1 to nLen + ClassAdd( hClass, ::aClsDatas[ n ], n, MET_CLASSDATA ) + ClassAdd( hClass, "_" + ::aClsDatas[ n ], n, MET_CLASSDATA ) + next + + nLen = Len( ::aInlines ) + for n = 1 to nLen + ClassAdd( hClass, ::aInlines[ n ][ 1 ], ::aInlines[ n ][ 2 ],; + MET_INLINE ) + next + + nLen = Len( ::aVirtuals ) + for n = 1 to nLen + ClassAdd( hClass, ::aVirtuals[ n ], n, MET_VIRTUAL ) + next + +return nil + +//----------------------------------------------------------------------------// + +static function Instance() + + local Self := QSelf() + +return ClassInstance( ::hClass ) + +//----------------------------------------------------------------------------// + +static function AddData( cData ) + + local Self := QSelf() + + AAdd( ::aDatas, cData ) + +return nil + +//----------------------------------------------------------------------------// + +static function AddClassData( cData ) + + local Self := QSelf() + + AAdd( ::aClsDatas, cData ) + +return nil + +//----------------------------------------------------------------------------// + +static function AddInline( cMethod, bCode ) + + local Self := QSelf() + + AAdd( ::aInlines, { cMethod, bCode } ) + +return nil + +//----------------------------------------------------------------------------// + +static function AddMethod( cMethod, nFuncPtr ) + + local Self := QSelf() + + AAdd( ::aMethods, { cMethod, nFuncPtr } ) + +return nil + +//----------------------------------------------------------------------------// + +static function AddVirtual( cMethod ) + + local Self := QSelf() + + AAdd( ::aVirtuals, cMethod ) + +return nil + +//----------------------------------------------------------------------------// diff --git a/harbour/source/rtl/transfrm.c b/harbour/source/rtl/transfrm.c new file mode 100644 index 0000000000..5342b21e8b --- /dev/null +++ b/harbour/source/rtl/transfrm.c @@ -0,0 +1,670 @@ +#include +#include +#include + +/* */ +/* Transform( xValue, cPicture ) */ +/* */ +/* Date : 29/04/1999 */ +/* */ + +extern STACK stack; + +void julian2greg(long, long*, long*, long*); /* TOFIX: Should go away */ +void StackPop( void ); /* TOFIX: Should go away */ + +/* Function flags */ + +#define PF_LEFT 0x0001 /* @B */ +#define PF_CREDIT 0x0002 /* @C */ +#define PF_DEBIT 0x0004 /* @D */ +#define PF_ZERO 0x0008 /* @0 */ +#define PF_PARNEG 0x0010 /* @( */ +#define PF_REMAIN 0x0020 /* @R */ +#define PF_UPPER 0x0040 /* @! */ +#define PF_DATE 0x0080 /* @D */ +#define PF_BRITISH 0x0100 /* @E */ +#define PF_EXCHANG 0x0100 /* @E. Also means exchange . and , */ +#define PF_EMPTY 0x0200 /* @Z */ +#define PF_NUMDATE 0x0400 /* Internal flag. Ignore decimal dot */ + +/* Date settings */ + +#define DF_CENTOFF 0 +#define DF_CENTURY 1 + +#define DF_DMY 0 +#define DF_MDY 1 +#define DF_YMD 2 +#define DF_EOT 3 /* End of table for Century */ + +BYTE bCentury = DF_CENTURY; /* Century on */ + +/* 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 *szDatePict = "DD/MM/YYYY"; /* TODO:Drop SET DATE */ +char *szBritish[] = { "DD/MM/YY", "DD/MM/YYYY" }; /* For @E */ + +/* + PictFunc -> Analyze function flags and return binary flags bits + + szPict : Pointer to the picture + lPicLen : Pointer to the length. Changed during execution. +*/ +int PictFunc( char **szPict, long *lPicLen ) +{ + int bDone = FALSE; + int iPicFlags = 0; + + char *szPic = *szPict; + + szPic++; + (*lPicLen)--; + while( *lPicLen && !bDone ) + { + switch( toupper(*szPic) ) + { + case ' ': /* End of function string */ + bDone = TRUE; + break; + case '!': + iPicFlags |= PF_UPPER; + break; + case '(': + iPicFlags |= PF_PARNEG; + break; + case '0': + iPicFlags |= PF_ZERO; + break; + case 'B': + iPicFlags |= PF_LEFT; + break; + case 'C': + iPicFlags |= PF_CREDIT; + break; + case 'D': + iPicFlags |= PF_DATE; + break; + case 'E': + iPicFlags |= PF_BRITISH; + break; + case 'R': + iPicFlags |= PF_REMAIN; + break; + case 'X': + iPicFlags |= PF_DEBIT; + break; + case 'Z': + iPicFlags |= PF_EMPTY; + break; + } + szPic++; + (*lPicLen)--; + } + return( iPicFlags ); +} + +/* + NumPicture -> Handle a numeric picture. + + This function is ALSO called by DatePicture. + + szPic : Picture + lPic : Length of picture + iPicFlags : Function flags. NUM_DATE tells whether its a number or date + dValue : Number to picture + lRetSize : The size of the returned string is passed here ! +*/ +char *NumPicture( char *szPic, long lPic, int iPicFlags, double dValue, + long *lRetSize ) +{ + int iWidth; /* Width of string */ + int iDecimals; /* Number of decimals */ + int i; + int iCount; + + char *szRet; + char *szStr; + char cPic; + + PITEM pItem = NULL; /* Suppress warning */ + + BYTE bFound = FALSE; + BYTE bEmpty; /* Suppress empty string */ + + double dPush; + + iCount = 0; + + szRet = (char *) _xgrab( lPic+4 ); /* Grab enough */ + *szRet = 0; + for( i=0; ipSymbol ); /* Push STR function */ + PushNil (); /* Function call. No object */ + + PushDouble ( dPush ); /* Push value to transform */ + PushInteger( iWidth ); /* Push numbers width */ + PushInteger( iDecimals ); /* Push decimals */ + Function( 3 ); /* 3 Parameters */ + pItem = &stack.Return; +// StackPop(); +// ItemCopy( pItem, &stack.Return ); /* Get return value */ + if( pItem->wType == IT_STRING ) /* Is it a string */ + { + szStr = pItem->value.szText; + iCount = 0; + + if( iPicFlags & PF_ZERO ) /* Pad with Zero's */ + { + for( i=0; szStr[i] == ' ' && i < iWidth; i++ ) + szStr[i] = '0'; + } + if( bEmpty && pItem->wLength ) /* Suppress empty value */ + { + szStr[pItem->wLength - 1] = ' '; + } + + if( iPicFlags & PF_LEFT ) /* Left align */ + { + for( i=0; szStr[i] == ' ' && i < iWidth; i++ ); + /* Find first non-space */ + + if( i && i != iWidth ) /* Any found or end of str */ + { + memcpy(szStr, szStr+i, iWidth-i); + for( i = iWidth-i; i < iWidth; i++ ) + szStr[i] = ' '; /* Pad with spaces */ + } + } + + for( i=0; i < lPic; i++ ) + { + cPic = szPic[i]; + if( cPic == '9' || cPic == '#' ) + szRet[i] = szStr[iCount++]; /* Just copy */ + else if( cPic == '.' ) + { + if( iPicFlags & PF_NUMDATE ) /* Dot in date */ + szRet[i] = cPic; + else /* Dot in number */ + { + if( iPicFlags & PF_EXCHANG ) /* Exchange . and , */ + { + szRet[i] = ','; + iCount++; + } + else + szRet[i] = szStr[iCount++]; + } + } + else if( cPic == '$' || cPic == '*' ) + { + if( szStr[iCount] == ' ' ) + { + szRet[i] = cPic; + iCount++; + } + else + szRet[i] = szStr[iCount++]; + } + else if( cPic == ',' ) /* Comma */ + { + if( iCount && isdigit(szStr[iCount-1]) ) /* May we place it */ + { + if( iPicFlags & PF_EXCHANG ) + szRet[i] = '.'; + else + szRet[i] = ','; + } + else + szRet[i] = ' '; + } + else + szRet[i] = cPic; + } + if( (iPicFlags & PF_CREDIT) && (dValue >= 0) ) + { + szRet[i++] = ' '; + szRet[i++] = 'C'; + szRet[i++] = 'R'; + } + + if( (iPicFlags & PF_DEBIT) && (dValue < 0) ) + { + szRet[i++] = ' '; + szRet[i++] = 'D'; + szRet[i++] = 'B'; + } + + if( (iPicFlags & PF_PARNEG) && (dValue < 0) ) + { + if( isdigit(*szRet) ) /* Overflow */ + { + for( iCount = 1; iCount < i; iCount++ ) + { + if( isdigit( szRet[iCount] ) ) + szRet[iCount] = '*'; + } + } + *szRet = '('; + szRet[i++] = ')'; + } + + *lRetSize = i; + szRet[i] = 0; + } + else + { + printf( "\nThis should never happen" ); /* TODO: Serious error */ + } +// ItemRelease( pItem ); + return(szRet); +} + + +/* + NumDefault -> Handle default numerics. + + dValue : Number to picture + lRetSize : The size of the returned string is passed here ! +*/ +PITEM NumDefault( double dValue ) +{ /* Default number */ + /* TODO: Change to str call */ + PushSymbol ( GetDynSym( "STR" )->pSymbol ); /* Push STR function */ + PushNil (); /* Function call. No object */ + + PushDouble ( dValue ); /* Push value to transform */ + Function ( 1 ); /* 1 Parameter */ + StackPop (); /* Pop return value */ + if( stack.pPos->wType != IT_STRING ) /* Is it a string */ + { + printf( "\nThis should never happen" ); /* TODO: Serious error */ + } + return( stack.pPos ); +} + + +/* + DatePicture -> Handle dates. + + lDate : Date to handle + iPicFlags : Function flags + lRetSize : The size of the returned string is passed here ! +*/ +char *DatePicture( long lDate, int iPicFlags, long *lRetSize ) +{ + BYTE bFormat; + + int n; + int iLenPic; /* Length picture */ + + char *szDateFormat; /* Date format to be used */ + char *szIntPicture; /* Internal picture used */ + char *szResult; + char c; + + long lDay; + long lMonth; + long lYear; + + double dIn; + + if( iPicFlags & PF_BRITISH ) + { + bFormat = DF_DMY; /* Just use british */ + szDateFormat = szBritish[ bCentury ]; + } + else + { + szDateFormat = szDatePict; /* Analyze date format */ + c = toupper( *szDateFormat ); + if( c == 'D' ) + bFormat = DF_DMY; + else if ( c == 'M' ) + bFormat = DF_MDY; + else if ( c == 'Y' ) + bFormat = DF_YMD; + else /* QUESTION: Error ? */ + bFormat = DF_DMY; + } + + if( lDate <= 0 ) /* Missing date */ + { + lDay = 0; + lMonth = 0; + lYear = 0; + iPicFlags |= PF_EMPTY; /* Suppress empty */ + } + else + { + iPicFlags |= PF_ZERO; /* Pad with zeros */ + julian2greg( lDate, &lDay, &lMonth, &lYear ); + /* Calculate d/m/y */ + } + iLenPic = strlen( szDateFormat ); + szIntPicture = (char *) _xgrab( iLenPic+1 ); + for( n = 0; n < iLenPic; n++ ) /* Create internal picture */ + { + c = toupper(szDateFormat[n]); + if( c == 'D' || c == 'M' || c == 'Y' ) /* Change format markers */ + { + szIntPicture[n] = lDay ? '9' : ' '; /* Empty date -> No picture */ + } + else + szIntPicture[n] = szDateFormat[n]; /* Copy the pattern */ + } + szIntPicture[n] = 0; /* Close the string */ + + iPicFlags |= PF_NUMDATE; /* Internal date flag */ + + if( bCentury ) + bFormat += DF_EOT; /* Use the second part */ + +/* */ +/* Transfer the date to a number. Example : */ +/* */ +/* bFormat == DMY 12/05/1925 => 12051925 d*1M + m*10K + y */ +/* bFormat == YMD 1998.05.25 => 19980525 d + m*100 + y*10K */ +/* */ + + dIn = ( (double) lDay ) * lFactDay [ bFormat ]; + dIn += ( (double) lMonth ) * lFactMonth[ bFormat ]; + if( iLenPic == 8 ) /* 2 digit year. Y2K? */ + dIn += ( (double) (lYear % 100) ) * lFactYear [ bFormat ]; + else /* 4 digit year */ + dIn += ( (double) lYear ) * lFactYear [ bFormat ]; + + szResult = NumPicture( szIntPicture, iLenPic, iPicFlags, dIn, lRetSize ); + /* And give to NumPicture */ + _xfree( szIntPicture ); + + return( szResult ); +} + + +HARBOUR TRANSFORM( void ) +{ + PITEM pPic = _param( 2, IT_STRING); /* Picture string */ + PITEM pExp = _param( 1, IT_ANY ); /* Input parameter */ + + char *szPic = pPic->value.szText; + char *szTemp; + char *szResult; + char *szExp; + + PITEM pItem; + + long lPic = pPic->wLength; + long lPicStart = 0; /* Start of template */ + long lExpPos = 0; + long lResultPos = 0; + + int iPicFlags = 0; /* Function flags */ + int n; + + BYTE bDone = FALSE; + + if( lPic ) + { + if( pPic->wLength ) + { + if( *szPic == '@' ) /* Function marker found */ + { + iPicFlags = PictFunc( &szPic, &lPic ); /* Get length of function*/ + lPicStart = pPic->wLength - lPic; /* Get start of template */ + } + + switch( pExp->wType ) + { + case IT_STRING: + { + szExp = pExp->value.szText; + szResult = (char *)_xgrab( ( (lPic-lPicStart) > pExp->wLength) ? + (lPic-lPicStart) + 1 : pExp->wLength + 1 ); + /* Grab enough */ + szPic += lPicStart; /* Skip functions */ + + if( iPicFlags & PF_UPPER ) /* Function : @! */ + { + szTemp = szExp; /* Convert to upper */ + for( n = pExp->wLength; n ; n--) + { + *szTemp = toupper( *szTemp ); + szTemp++; + } + } + + if( lPic ) /* Template string */ + { + while( lPic && lExpPos < pExp->wLength ) + { /* Analyze picture mask */ + switch( *szPic ) + { + case '!': /* Upper */ + { + szResult[lResultPos++] = toupper(szExp[lExpPos++]); + break; + } + case 'L': /* Ignored */ + case 'Y': + case '*': + case '$': + case '.': + case ',': + break; + + case '#': /* Out the character */ + case '9': + case 'A': + case 'N': + case 'X': + case ' ': + { + szResult[lResultPos++] = szExp[lExpPos++]; + break; + } + + default: /* Other choices */ + { + szResult[lResultPos++] = *szPic; + lExpPos++; + } + } + szPic++; + lPic--; + } + } + else if( iPicFlags & (PF_UPPER + PF_REMAIN) ) + { /* Without template */ + for( n = pExp->wLength; n; n--) + szResult[lResultPos++] = *szExp++; + } + + if( ( iPicFlags & PF_REMAIN ) && lPic ) /* Any chars left */ + { + for( n = lPic; n; n--) + szResult[lResultPos++] = *szPic; /* Export remainder */ + } + _retclen(szResult, lResultPos); + _xfree(szResult); + break; + } + + case IT_LOGICAL: + { + szExp = pExp->value.szText; + szResult = (char *) _xgrab( lPic + 1 ); + /* That's all folks */ + szPic += lPicStart; /* Skip functions */ + lResultPos = 1; + + if( lPic ) /* Template string */ + { + switch( *szPic ) + { + case 'Y': /* Yes/No */ + { + *szResult = pExp->value.iLogical ? 'Y' : 'N'; + szPic++; + lPic--; + bDone = TRUE; /* Logical written */ + break; + } + + case '#': + case 'L': /* True/False */ + { + *szResult = pExp->value.iLogical ? 'T' : 'F'; + szPic++; + lPic--; + bDone = TRUE; + break; + } + + default: + { + *szResult = *szPic++; + lPic--; + } + } + } + if( ( iPicFlags & PF_REMAIN ) && lPic ) /* Any chars left */ + { + for( n = lPic; n; n--) /* Copy remainder */ + szResult[lResultPos++] = *szPic++; + if( !bDone ) /* Logical written ? */ + szResult[lResultPos++] = pExp->value.iLogical ? 'T' : 'F'; + } + _retclen( szResult, lResultPos ); + _xfree( szResult ); + break; + } + case IT_INTEGER: + { + szResult = NumPicture( szPic + lPicStart, lPic, iPicFlags, + (double) pExp->value.iNumber, &lResultPos ); + _retclen( szResult, lResultPos ); + _xfree( szResult ); + break; + } + case IT_LONG: + { + szResult = NumPicture( szPic + lPicStart, lPic, iPicFlags, + (double) pExp->value.lNumber, &lResultPos ); + _retclen( szResult, lResultPos ); + _xfree( szResult ); + break; + } + case IT_DOUBLE: + { + szResult = NumPicture( szPic + lPicStart, lPic, iPicFlags, + (double) pExp->value.dNumber, &lResultPos ); + _retclen( szResult, lResultPos); + _xfree( szResult ); + break; + } + case IT_DATE: + { /* Date is currently British; Century is on */ + szResult = DatePicture( pExp->value.lDate, iPicFlags, &lResultPos ); + _retclen( szResult, lResultPos ); + _xfree( szResult ); + break; + } + default: + { + _retc( "Crash !" ); /* TODO: Crash */ + } + } + } + else + _retc( "Crash !" ); /* TODO: Crash */ + } + else /* No picture supplied */ + { + switch( pExp->wType ) /* Default behaviour */ + { + case IT_STRING: + { + _retclen( pExp->value.szText, pExp->wLength); + break; + } + case IT_LOGICAL: + { + _retclen( pExp->value.iLogical ? "T" : "F", 1); + break; + } + case IT_INTEGER: + { + pItem = NumDefault( (double) pExp->value.iNumber ); + _retclen( pItem->value.szText, pItem->wLength ); + ItemRelease( pItem ); + break; + } + case IT_LONG: + { + pItem = NumDefault( (double) pExp->value.lNumber ); + _retclen( pItem->value.szText, pItem->wLength ); + ItemRelease( pItem ); + break; + } + case IT_DOUBLE: + { + pItem = NumDefault( (double) pExp->value.dNumber ); + _retclen( pItem->value.szText, pItem->wLength ); + ItemRelease( pItem ); + break; + } + case IT_DATE: + { + szResult = DatePicture( pExp->value.lDate, iPicFlags, &lResultPos ); + _retclen( szResult, lResultPos ); + _xfree( szResult ); + break; + } + default: + { + _retc("Crash !"); + } + } + } +} + + diff --git a/harbour/source/vm/dynsym.c b/harbour/source/vm/dynsym.c new file mode 100644 index 0000000000..c6a679b864 --- /dev/null +++ b/harbour/source/vm/dynsym.c @@ -0,0 +1,230 @@ +/* Harbour dynamic symbol table management */ + +#include +#include + +typedef struct +{ + PDYNSYM pDynSym; /* Pointer to dynamic symbol */ +} DYNITEM, * PDYNITEM; + +#define SYM_ALLOCATED -1 + +PSYMBOL NewSymbol( char * szName ); +PDYNSYM FindDynSym( char * szName ); + +static PDYNITEM pDynItems = 0; /* Pointer to dynamic items */ +static WORD wDynSymbols = 0; /* Number of symbols present */ +static WORD wClosestDynSym = 0; + /* Closest symbol for match. FindDynSym will search for the name. */ + /* If it cannot find the name, it positions itself to the */ + /* closest symbol. */ + +void LogSymbols( void ) +{ + WORD w; + + for( w = 0; w < wDynSymbols; w++ ) /* For all dynamic symbols */ + printf( "%i %s\n", w + 1, pDynItems[ w ].pDynSym->pSymbol->szName ); +} + +#define RIGHT_GREATER 2 +#define LEFT_GREATER 1 +#define SYM_EQUAL 0 + +static WORD _strgreater( char * sz1, char * sz2 ) +{ + /* Values returned : SYM_EQUAL, LEFT_GREATER, RIGHT_GREATER */ + + while( *( sz1 ) && *( sz2 ) && *( sz1 ) == *( sz2 ) ) + { + sz1++; + sz2++; + } + if ( ( *( sz1 ) == 0 && *( sz2 ) != 0 ) || + ( *( sz2 ) > *( sz1 ) ) ) + return RIGHT_GREATER; + + if ( ( *( sz1 ) != 0 && *( sz2 ) == 0 ) || + ( *( sz1 ) > *( sz2 ) ) ) + return LEFT_GREATER; + return SYM_EQUAL; +} + +PSYMBOL NewSymbol( char * szName ) /* Create a new symbol */ +{ + PSYMBOL pSymbol = ( PSYMBOL ) _xgrab( sizeof( SYMBOL ) ); + + pSymbol->szName = ( char * ) _xgrab( strlen( szName ) + 1 ); + pSymbol->cScope = SYM_ALLOCATED; /* to know what symbols to release when exiting the app */ + strcpy( pSymbol->szName, szName ); + + return pSymbol; +} + +PDYNSYM NewDynSym( PSYMBOL pSymbol ) /* creates a new dynamic symbol */ +{ + PDYNSYM pDynSym = FindDynSym( pSymbol->szName ); /* Find position */ + WORD w; + + if( pDynSym ) /* If name exists */ + { + if( ! ( pSymbol->cScope & ( FS_STATIC | FS_INIT | FS_EXIT ) ) ) /* only for FS_PUBLIC */ + { + if( ( ! pDynSym->pFunPtr ) && pSymbol->pFunPtr ) /* The DynSym existed */ + pDynSym->pFunPtr = pSymbol->pFunPtr; /* but had no function ptr assigned */ + } + pSymbol->pDynSym = pDynSym; /* place a pointer to DynSym */ + return pDynSym; /* Return pointer to DynSym */ + } + + if( ! wDynSymbols ) /* Do we have any symbols ? */ + pDynSym = pDynItems[ 0 ].pDynSym; /* Point to first symbol */ + /* *<1>* Remember we already got this one */ + else + { /* We want more symbols ! */ + pDynItems = ( PDYNITEM ) _xrealloc( pDynItems, ( wDynSymbols + 1 ) * sizeof( DYNITEM ) ); + + if( wClosestDynSym <= wDynSymbols ) /* Closest < current !! */ + { /* Here it goes :-) */ + for( w = 0; w < ( wDynSymbols - wClosestDynSym ); w++ ) + memcpy( &pDynItems[ wDynSymbols - w ], + &pDynItems[ wDynSymbols - w - 1 ], sizeof( DYNITEM ) ); + } /* Insert element in array */ + pDynSym = ( PDYNSYM ) _xgrab( sizeof( DYNSYM ) ); + pDynItems[ wClosestDynSym ].pDynSym = pDynSym; /* Enter DynSym */ + } + + wDynSymbols++; /* Got one more symbol */ + pDynSym->pSymbol = pSymbol; + + if( ! ( pSymbol->cScope & ( FS_STATIC | FS_INIT | FS_EXIT ) ) ) /* only for FS_PUBLIC */ + { + if( pDynSym->pFunPtr != pSymbol->pFunPtr ) /* it contains a function pointer */ + pDynSym->pFunPtr = pSymbol->pFunPtr; /* place the function at DynSym */ + } + pSymbol->pDynSym = pDynSym; /* place a pointer to DynSym */ + + return pDynSym; +} + +static void OurStrUpr( char * szText ) +{ + char *p; + + for( p = szText; *p; p++ ) + *p = toupper( *p ); +} + +PDYNSYM GetDynSym( char * szName ) /* finds and creates a symbol if not found */ +{ + PDYNSYM pDynSym; + char * szUprName = ( char * ) _xgrab( strlen( szName ) + 1 ); + + strcpy( szUprName, szName ); /* make a copy as we may get a const string */ + OurStrUpr( szUprName ); /* turn it uppercase */ + + /* if( strlen( szUprName ) > 10 ) + szUprName[ 10 ] = 0; keeps this here for 10 chars /c compatibility mode */ + + pDynSym = FindDynSym( szUprName ); + if( ! pDynSym ) /* Does it exists ? */ + pDynSym = NewDynSym( NewSymbol( szUprName ) ); /* Make new symbol */ + + _xfree( szUprName ); /* release memory */ + + return pDynSym; +} + +PDYNSYM FindDynSym( char * szName ) +{ + WORD wFirst = 0, wLast = wDynSymbols, wMiddle = wLast / 2; + + if( ! pDynItems ) + { + pDynItems = ( PDYNITEM ) _xgrab( sizeof( DYNITEM ) ); /* Grab array */ + pDynItems->pDynSym = ( PDYNSYM ) _xgrab( sizeof( DYNSYM ) ); + /* Always grab a first symbol. Never an empty bucket. *<1>* */ + pDynItems->pDynSym->wMemvar = 0; + pDynItems->pDynSym->pSymbol = 0; + pDynItems->pDynSym->pFunPtr = 0; + return 0; + } + else + { /* Classic Tree Insert Sort Mechanism + // + // Insert Sort means the new item is entered alphabetically into + // the array. In this case pDynItems ! + // + // 1) We start in the middle of the array. + // 2a) If the symbols are equal -> we have found the symbol !! + // Champagne ! We're done. + // b) If the symbol we are looking for ('ge') is greater than the + // middle ('po'), we start looking left. + // Only the first part of the array is going to be searched. + // Go to (1) + // c) If the symbol we are looking for ('ge') is smaller than the + // middle ('ko'), we start looking right + // Only the last part of the array is going to be searched. + // Go to (1) + */ + wClosestDynSym = wMiddle; /* Start in the middle */ + + while( wFirst < wLast ) + { + switch( _strgreater( pDynItems[ wMiddle ].pDynSym->pSymbol->szName, szName ) ) + { + case SYM_EQUAL: /* they are equals */ + return pDynItems[ wMiddle ].pDynSym; + + case LEFT_GREATER: /* pMiddle is greater */ + wLast = wMiddle; + wClosestDynSym = wMiddle; + break; + + case RIGHT_GREATER: /* szName is greater */ + wFirst = wMiddle + 1; + wClosestDynSym = wFirst; + break; + } + wMiddle = wFirst + ( ( wLast - wFirst ) / 2 ); + } + } + return 0; +} + +void ReleaseDynamicSymbols( void ) +{ + WORD w; + + for( w = 0; w < wDynSymbols; w++ ) + { + /* it is a allocated symbol ? */ + if( ( pDynItems + w )->pDynSym->pSymbol->cScope == SYM_ALLOCATED ) + { + _xfree( ( pDynItems + w )->pDynSym->pSymbol->szName ); + _xfree( ( pDynItems + w )->pDynSym->pSymbol ); + } + + _xfree( ( pDynItems + w )->pDynSym ); + } + + _xfree( pDynItems ); +} + +HARBOUR DYNSYMNAME() /* Get name of symbol */ +{ /* cSymbol = DynSymName( dsIndex ) */ + _retc( pDynItems[ _parnl( 1 ) - 1 ].pDynSym->pSymbol->szName ); +} + +HARBOUR DYNSYMBOLS() /* How much symbols do we have */ +{ /* dsCount = DynSymbols() */ + _retnl( wDynSymbols ); +} + +HARBOUR GETDYNSYM() /* Gimme index number of symbol */ + /* dsIndex = GetDynSym( cSymbol ) */ +{ + _retnl( ( LONG ) GetDynSym( _parc( 1 ) ) ); +} + diff --git a/harbour/source/vm/hvm.c b/harbour/source/vm/hvm.c new file mode 100644 index 0000000000..f4fffa93c6 --- /dev/null +++ b/harbour/source/vm/hvm.c @@ -0,0 +1,1992 @@ +/* The Harbour virtual machine */ + +/* Please note the following comments we may use everywhere + TODO: something should be added here + TOFIX: something needs to be fixed + OBSOLETE: something could be removed from here + QUESTION: I had some questions at this point but I could not get an answer + OPT: something is commented out to improve performance + As an example: */ + +/* TODO: Add all the TODO comments. */ + +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +BOOL strempty( char * szText, long lLen ); + +HARBOUR ERRORSYS( void ); +HARBOUR ERRORNEW( void ); +HARBOUR EVAL( void ); /* Evaluates a codeblock from Harbour */ +HARBOUR MAIN( void ); /* fixed entry point by now */ +HARBOUR VALTYPE( void ); /* returns a string description of a value */ + +/* currently supported virtual machine actions */ +void And( void ); /* performs the logical AND on the latest two values, removes them and leaves result on the stack */ +void ArrayAt( void ); /* pushes an array element to the stack, removing the array and the index from the stack */ +void ArrayPut( void ); /* sets an array value and pushes the value on to the stack */ +void Dec( void ); /* decrements the latest numeric value on the stack */ +void Div( void ); /* divides the latest two values on the stack, removes them and leaves the result */ +void Do( WORD WParams ); /* invoke the virtual machine */ +HARBOUR DoBlock( void ); /* executes a codeblock */ +void Duplicate( void ); /* duplicates the latest value on the stack */ +void EndBlock( void ); /* copies the last codeblock pushed value into the return value */ +void Equal( void ); /* checks if the two latest values on the stack are equal, removes both and leaves result */ +void ForTest( void ); /* test for end condition of for */ +void Frame( BYTE bLocals, BYTE bParams ); /* increases the stack pointer for the amount of locals and params suplied */ +void FuncPtr( void ); /* pushes a function address pointer. Removes the symbol from the satck */ +void Function( WORD wParams ); /* executes a function saving its result */ +void GenArray( WORD wElements ); /* generates a wElements Array and fills it from the stack values */ +void Greater( void ); /* checks if the latest - 1 value is greater than the latest, removes both and leaves result */ +void GreaterEqual( void ); /* checks if the latest - 1 value is greater than or equal the latest, removes both and leaves result */ +void Inc( void ); /* increment the latest numeric value on the stack */ +void ItemCopy( PITEM pDest, PITEM pSource ); /* copies an item to one place to another respecting its containts */ +void Less( void ); /* checks if the latest - 1 value is less than the latest, removes both and leaves result */ +void LessEqual( void ); /* checks if the latest - 1 value is less than or equal the latest, removes both and leaves result */ +void Line( WORD wLine ); /* keeps track of the currently processed PRG line */ +void Message( PSYMBOL pSymMsg ); /* sends a message to an object */ +void Minus( void ); /* substracts the latest two values on the stack, removes them and leaves the result */ +void Modulus( void ); /* calculates the modulus of latest two values on the stack, removes them and leaves the result */ +void Mult( void ); /* multiplies the latest two values on the stack, removes them and leaves the result */ +void Negate( void ); /* negates (-) the latest value on the stack */ +void Not( void ); /* changes the latest logical value on the stack */ +void NotEqual( void ); /* checks if the two latest values on the stack are not equal, removes both and leaves result */ +void Or( void ); /* performs the logical OR on the latest two values, removes them and leaves result on the stack */ +void Plus( void ); /* sums the latest two values on the stack, removes them and leaves the result */ +long PopDate( void ); /* pops the stack latest value and returns its date value as a LONG */ +void PopDefStat( WORD wStatic ); /* pops the stack latest value onto a static as default init */ +double PopDouble( void ); /* pops the stack latest value and returns its double numeric format value */ +void PopLocal( SHORT wLocal ); /* pops the stack latest value onto a local */ +int PopLogical( void ); /* pops the stack latest value and returns its logical value */ +double PopNumber( void ); /* pops the stack latest value and returns its numeric value */ +void PopStatic( WORD wStatic ); /* pops the stack latest value onto a static */ +void Power( void ); /* power the latest two values on the stack, removes them and leaves the result */ +void Push( PITEM pItem ); /* pushes a generic item onto the stack */ +void PushBlock( BYTE * pCode, WORD wSize, WORD wParam, PSYMBOL pSymbols ); /* creates a codeblock */ +void PushDate( LONG lDate ); /* pushes a long date onto the stack */ +void PushDouble( double lNumber ); /* pushes a double number onto the stack */ +void PushLocal( SHORT iLocal ); /* pushes the containts of a local onto the stack */ +void PushLocalByRef( SHORT iLocal ); /* pushes a local by refrence onto the stack */ +void PushLogical( int iTrueFalse ); /* pushes a logical value onto the stack */ +void PushLong( long lNumber ); /* pushes a long number onto the stack */ +void PushNil( void ); /* in this case it places nil at self */ +void PushNumber( double dNumber ); /* pushes a number on to the stack and decides if it is integer, long or double */ +void PushStatic( WORD wStatic ); /* pushes the containts of a static onto the stack */ +void PushString( char * szText, WORD wLength ); /* pushes a string on to the stack */ +void PushSymbol( PSYMBOL pSym ); /* pushes a function pointer onto the stack */ +void PushInteger( int iNumber ); /* pushes a integer number onto the stack */ +void RetValue( void ); /* pops the latest stack value into stack.Return */ +void SFrame( PSYMBOL pSym ); /* sets the statics frame for a function */ +void Statics( PSYMBOL pSym ); /* increases the the global statics array to hold a PRG statics */ + +typedef struct _SYMBOLS +{ + PSYMBOL pModuleSymbols; /* pointer to a one module own symbol table */ + WORD wModuleSymbols; /* number of symbols on that table */ + struct _SYMBOLS * pNext;/* pointer to the next SYMBOLS structure */ +} SYMBOLS, * PSYMBOLS; /* structure to keep track of all modules symbol tables */ + +void ProcessSymbols( PSYMBOL pSymbols, WORD wSymbols ); /* statics symbols initialization */ +void DoInitFunctions( int argc, char * argv[] ); /* executes all defined PRGs INIT functions */ +void DoExitFunctions( void ); /* executes all defined PRGs EXIT functions */ +void LogSymbols( void ); /* displays all dynamic symbols */ +void ReleaseClasses( void ); /* releases all defined classes */ +void ReleaseLocalSymbols( void ); /* releases the memory of the local symbols linked list */ +void ReleaseDynamicSymbols( void ); /* releases the memory of the dynamic symbol table */ +void ReleaseSets( void ); /* releases Sets consumed memory */ + +/* stack management functions */ +void StackPop( void ); /* pops an item from the stack */ +void StackFree( void ); /* releases all memory used by the stack */ +void StackPush( void ); /* pushes an item on to the stack */ +void StackInit( void ); /* initializes the stack */ +void StackShow( void ); /* show the types of the items on the stack for HBDEBUGging purposes */ + +PCODEBLOCK CodeblockNew( BYTE *, WORD, PSYMBOL ); +void CodeblockDelete( PCODEBLOCK ); +PITEM CodeblockGetVar( PITEM, SHORT ); +void CodeblockEvaluate( PCODEBLOCK, WORD ); +void CodeblockCopy( PITEM, PITEM ); +void CodeblockDetach( PCODEBLOCK ); + +void ForceLink( void ); + +#define STACK_INITITEMS 100 +#define STACK_EXPANDITEMS 20 + +extern ULONG ulMemoryBlocks; /* memory blocks used */ +extern ULONG ulMemoryMaxBlocks; /* maximum number of used memory blocks */ +extern ULONG ulMemoryConsumed; /* memory size consumed */ +extern ULONG ulMemoryMaxConsumed; /* memory max size consumed */ + +STACK stack; +int iHBDEBUG = 0; /* if 1 traces the virtual machine activity */ +SYMBOL symEval = { "__EVAL", FS_PUBLIC, DoBlock, 0 }; /* symbol to evaluate codeblocks */ +PSYMBOL pSymStart; /* start symbol of the application. MAIN() is not required */ +ITEM aStatics; /* Harbour array to hold all application statics variables */ +ITEM errorBlock; /* errorblock */ +PSYMBOLS pSymbols = 0; /* to hold a linked list of all different modules symbol tables */ +BOOL bQuit = FALSE; /* inmediately exit the application */ +BYTE bErrorLevel = 0; /* application exit errorlevel */ + +#define HBDEBUG( x ) if( iHBDEBUG ) printf( x ) +#define HBDEBUG2( x, y ) if( iHBDEBUG ) printf( x, y ) + +/* application entry point */ + +#ifdef WINDOWS + int __stdcall WinMain( long hIns, long hPrev, char * szCmds, int iCmdShow ) + { + int argc = 1; + char * argv[] = { "Test" }; +#else + int main( int argc, char * argv[] ) + { +#endif + int i; + void ( * DontDiscardForceLink )( void ) = &ForceLink; + + if( ! DontDiscardForceLink ) /* just to avoid warnings from the C compiler */ + iHBDEBUG += ( int ) DontDiscardForceLink; /* just to avoid warnings from the C compiler */ + + HBDEBUG( "main\n" ); + aStatics.wType = IT_NIL; + errorBlock.wType = IT_NIL; + stack.Return.wType = IT_NIL; + StackInit(); + NewDynSym( &symEval ); /* initialize dynamic symbol for evaluating codeblocks */ + HB_init_set(); /* initialize Sets */ + DoInitFunctions( argc, argv ); /* process defined INIT functions */ + + PushSymbol( pSymStart ); /* pushes first FS_PUBLIC defined symbol to the stack */ + PushNil(); /* places NIL at self */ + + for( i = 1; i < argc; i++ ) /* places application parameters on the stack */ + PushString( argv[ i ], strlen( argv[ i ] ) ); + + Do( argc - 1 ); /* invoke it with number of supplied parameters */ + + DoExitFunctions(); /* process defined EXIT functions */ + + ItemRelease( &stack.Return ); + ArrayRelease( &aStatics ); + ItemRelease( &errorBlock ); + ReleaseClasses(); + ReleaseLocalSymbols(); /* releases the local modules linked list */ + ReleaseDynamicSymbols(); /* releases the dynamic symbol table */ + ReleaseSets(); /* releases Sets */ + StackFree(); + /* LogSymbols(); */ + HBDEBUG( "Done!\n" ); + + printf( "\n\ntotal memory blocks allocated: %lu\n", ulMemoryMaxBlocks ); + printf( "memory maximum size consumed: %ld\n", ulMemoryMaxConsumed ); + printf( "memory blocks not released: %ld\n", ulMemoryBlocks ); + printf( "memory size not released: %ld\n", ulMemoryConsumed ); + + return bErrorLevel; +} + +void VirtualMachine( PBYTE pCode, PSYMBOL pSymbols ) +{ + BYTE bCode; + WORD w = 0, wParams, wSize; + + HBDEBUG( "VirtualMachine\n" ); + + while( ( bCode = pCode[ w ] ) != _ENDPROC && ! bQuit ) + { + switch( bCode ) + { + case _AND: + And(); + w++; + break; + + case _ARRAYAT: + ArrayAt(); + w++; + break; + + case _ARRAYPUT: + ArrayPut(); + w++; + break; + + case _DEC: + Dec(); + w++; + break; + + case _DIVIDE: + Div(); + w++; + break; + + case _DO: + Do( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _DUPLICATE: + Duplicate(); + w++; + break; + + case _ENDBLOCK: + EndBlock(); + HBDEBUG( "EndProc\n" ); + return; /* end of a codeblock - stop evaluation */ + + case _EQUAL: + Equal(); + w++; + break; + + case _FALSE: + PushLogical( 0 ); + w++; + break; + + case _FORTEST: + ForTest(); + w++; + break; + + case _FRAME: + Frame( pCode[ w + 1 ], pCode[ w + 2 ] ); + w += 3; + break; + + case _FUNCPTR: + FuncPtr(); + w++; + break; + + case _FUNCTION: + Function( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _GENARRAY: + GenArray( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _GREATER: + Greater(); + w++; + break; + + case _GREATEREQUAL: + GreaterEqual(); + w++; + break; + + case _INC: + Inc(); + w++; + break; + + case _JUMP: + wParams = pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + if( wParams ) + w += wParams; + else + w += 3; + break; + + case _JUMPFALSE: + if( ! PopLogical() ) + w += pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + else + w += 3; + break; + + case _JUMPTRUE: + if( PopLogical() ) + w += pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + else + w += 3; + break; + + case _LESS: + Less(); + w++; + break; + + case _LESSEQUAL: + LessEqual(); + w++; + break; + + case _LINE: + Line( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _MESSAGE: + wParams = pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + Message( pSymbols + wParams ); + w += 3; + break; + + case _MINUS: + Minus(); + w++; + break; + + case _MODULUS: + Modulus(); + w++; + break; + + case _MULT: + Mult(); + w++; + break; + + case _NEGATE: + Negate(); + w++; + break; + + case _NOT: + Not(); + w++; + break; + + case _NOTEQUAL: + NotEqual(); + w++; + break; + + case _OR: + Or(); + w++; + break; + + case _PLUS: + Plus(); + w++; + break; + + case _POP: + StackPop(); + w++; + break; + + case _POPDEFSTAT: + PopDefStat( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _POPLOCAL: + PopLocal( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _POPSTATIC: + PopStatic( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _POWER: + Power(); + w++; + break; + + case _PUSHBLOCK: + /* +0 -> _pushblock + * +1 +2 -> size of codeblock + * +3 +4 -> number of expected parameters + * +5 +6 -> number of referenced local variables + * +7 -> start of table with referenced local variables + */ + wSize = pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + PushBlock( pCode + w + 5, + wSize - 5, + pCode[ w + 3 ] + ( pCode[ w + 4 ] * 256 ), + pSymbols ); + w += wSize; + break; + + case _PUSHDOUBLE: + PushDouble( * ( double * ) ( &pCode[ w + 1 ] ) ); + w += 1 + sizeof( double ); + break; + + case _PUSHINT: + PushInteger( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _PUSHLOCAL: + PushLocal( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _PUSHLOCALREF: + PushLocalByRef( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _PUSHLONG: + PushLong( * ( long * ) ( &pCode[ w + 1 ] ) ); + w += 5; + break; + + case _PUSHNIL: + PushNil(); + w++; + break; + + case _PUSHSELF: + Push( stack.pBase + 1 ); + w++; + break; + + case _PUSHSTATIC: + PushStatic( pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ) ); + w += 3; + break; + + case _PUSHSTR: + wSize =*( (WORD *) &( pCode[ w + 1 ] ) ); + PushString( (char*)pCode + w + 3, wSize ); + w += ( wSize + 3 ); + break; + + case _PUSHSYM: + wParams = pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + PushSymbol( pSymbols + wParams ); + w += 3; + break; + + case _RETVALUE: + RetValue(); + w++; + break; + + case _SFRAME: + wParams = pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + SFrame( pSymbols + wParams ); + w += 3; + break; + + case _STATICS: + wParams = pCode[ w + 1 ] + ( pCode[ w + 2 ] * 256 ); + Statics( pSymbols + wParams ); + w += 3; + break; + + case _TRUE: + PushLogical( 1 ); + w++; + break; + + case _ZERO: + PushInteger( 0 ); + w++; + break; + + default: + printf( "The Harbour virtual machine can't run yet this PRG\n(unsuported pcode opcode: %i)\n", bCode ); + printf( "Line number %i in %s", stack.pBase->wLine, stack.pBase->value.pSymbol->szName ); + exit( 1 ); + break; + } + } + HBDEBUG( "EndProc\n" ); +} + +void And( void ) +{ + PITEM pItem2 = stack.pPos - 1; + PITEM pItem1 = stack.pPos - 2; + PITEM pError; + int iResult; + + HBDEBUG( "And\n" ); + + if( IS_LOGICAL( pItem1 ) && IS_LOGICAL( pItem2 ) ) + { + iResult = pItem1->value.iLogical && pItem2->value.iLogical; + StackPop(); + StackPop(); + PushLogical( iResult ); + } + else + { + pError = _errNew(); + _errPutDescription( pError, "Argument error: conditional" ); + _errLaunch( pError ); + _errRelease( pError ); + } +} + +void ArrayAt( void ) +{ + double dIndex = PopNumber(); + PITEM pArray = stack.pPos - 1; + ITEM item; + + ArrayGet( pArray, dIndex, &item ); + StackPop(); + + ItemCopy( stack.pPos, &item ); + ItemRelease( &item ); + StackPush(); +} + +void ArrayPut( void ) +{ + PITEM pValue = stack.pPos - 1; + PITEM pIndex = stack.pPos - 2; + PITEM pArray = stack.pPos - 3; + ULONG ulIndex; + + if( IS_INTEGER( pIndex ) ) + ulIndex = pIndex->value.iNumber; + + else if( IS_LONG( pIndex ) ) + ulIndex = pIndex->value.lNumber; + + else if( IS_DOUBLE( pIndex ) ) + ulIndex = pIndex->value.dNumber; + + else ; + /* QUESTION: Should we raise an error here ? */ + + ArraySet( pArray, ulIndex, pValue ); + ItemCopy( pArray, pValue ); /* places pValue at pArray position */ + StackPop(); + StackPop(); +} + +void Dec( void ) +{ + double dNumber; + LONG lDate; + + if( IS_NUMERIC( stack.pPos - 1 ) ) + { + dNumber = PopDouble(); + PushNumber( --dNumber ); + } + else if( IS_DATE( stack.pPos - 1 ) ) + { + lDate = PopDate(); + PushDate( --lDate ); /* TOFIX: Dates should decreased other way */ + } + /* TODO: Should we check other types here and issue an error ? */ +} + +void Div( void ) +{ + double d2 = PopDouble(); + double d1 = PopDouble(); + + PushNumber( d1 / d2 ); +} + +void Do( WORD wParams ) +{ + PITEM pItem = stack.pPos - wParams - 2; + PSYMBOL pSym = pItem->value.pSymbol; + WORD wStackBase = stack.pBase - stack.pItems; /* as the stack memory block could change */ + WORD wItemIndex = pItem - stack.pItems; + PITEM pSelf = stack.pPos - wParams - 1; + HARBOURFUNC pFunc; + + if( ! IS_SYMBOL( pItem ) ) + { + StackShow(); + printf( "symbol item expected as a base from Do()\n" ); + exit( 1 ); + } + + if( ! ( ( IS_NIL( pSelf ) ) || ( IS_BLOCK( pSelf ) ) || ( IS_ARRAY( pSelf ) ) ) ) + { + StackShow(); + printf( "invalid symbol type for self from Do()\n" ); + exit( 1 ); + } + + pItem->wLine = 0; + pItem->wParams = wParams; + stack.pBase = stack.pItems + pItem->wBase; + pItem->wBase = wStackBase; + + HBDEBUG2( "Do with %i params\n", wParams ); + + if( IS_OBJECT( pSelf ) ) /* are we sending a message to an object ? */ + { + pFunc = GetMethod( pSelf, pSym ); + if( ! pFunc ) + { + printf( "error: message %s not implemented for class %s\n", pSym->szName, + _GetClassName( pSelf ) ); + exit( 1 ); + } + pFunc(); + } + else /* it is a function */ + { + pFunc = pSym->pFunPtr; + if( ! pFunc ) + { + printf( "error: invalid function pointer (%s) from Do()\n", pSym->szName ); + exit( 1 ); + } + pFunc(); + } + + while( stack.pPos > stack.pItems + wItemIndex ) + StackPop(); + + stack.pBase = stack.pItems + wStackBase; +} + +HARBOUR DoBlock( void ) +{ + PITEM pBlock = stack.pBase + 1; + WORD wStackBase = stack.pBase - stack.pItems; /* as the stack memory block could change */ + int iParam; + + if( ! IS_BLOCK( pBlock ) ) + { + printf( "error: codeblock expected from DoBlock()\n" ); + exit( 1 ); + } + + /* Check for valid count of parameters */ + iParam =pBlock->wParams -_pcount(); + /* add missing parameters */ + while( iParam-- > 0 ) + PushNil(); + + /* set pBaseCB to point to local variables of a function where + * the codeblock was defined + */ + stack.pBase->wLine =pBlock->wLine; + + CodeblockEvaluate( (PCODEBLOCK)pBlock->value.pCodeblock, pBlock->wBase ); + + /* restore stack pointers */ + stack.pBase = stack.pItems + wStackBase; + + HBDEBUG( "End of DoBlock\n" ); +} + +void Duplicate( void ) +{ + ItemCopy( stack.pPos, stack.pPos - 1 ); + StackPush(); +} + +HARBOUR EVAL( void ) +{ + PITEM pBlock = _param( 1, IT_BLOCK ); + + if( pBlock ) + { + WORD w; + + PushSymbol( &symEval ); + Push( pBlock ); + + for( w = 2; w <= _pcount(); w++ ) + Push( _param( w, IT_ANY ) ); + + Do( _pcount() - 1 ); + } + else + { + printf( "Not a valid codeblock on eval\n" ); + exit( 1 ); + } +} + +void EndBlock( void ) +{ + StackPop(); + ItemCopy( &stack.Return, stack.pPos ); + HBDEBUG( "EndBlock\n" ); +} + +void Equal( void ) +{ + PITEM pItem2 = stack.pPos - 1; + PITEM pItem1 = stack.pPos - 2; + int i; + + if( IS_NIL( pItem1 ) && IS_NIL( pItem2 ) ) + { + StackPop(); + StackPop(); + PushLogical( 1 ); + } + + else if ( IS_NIL( pItem1 ) || IS_NIL( pItem2 ) ) + { + StackPop(); + StackPop(); + PushLogical( 0 ); + } + + else if( IS_STRING( pItem1 ) && IS_STRING( pItem2 ) ) + { + i = OurStrCmp( pItem1, pItem2 ); + StackPop(); + StackPop(); + PushLogical( i == 0 ); + } + + else if( IS_NUMERIC( pItem1 ) && IS_NUMERIC( pItem2 ) ) + PushLogical( PopDouble() == PopDouble() ); + + else if( pItem1->wType != pItem2->wType ) + { + printf( "types not match on equal operation\n" ); + exit( 1 ); + } + + else + PushLogical( 0 ); +} + +static void ForceLink( void ) /* To force the link of some functions */ +{ + ERRORSYS(); + ERRORNEW(); +} + +void ForTest( void ) /* Test to check the end point of the FOR */ +{ + double dStep; + int iEqual; + + if( IS_NUMERIC( stack.pPos - 1 ) ) + { + dStep = PopNumber(); + if( dStep > 0 ) /* Positive loop. Use LESS */ + Less(); + else if( dStep < 0 ) /* Negative loop. Use GREATER */ + Greater(); + else + printf( "step of zero will cause endless loop" ); + /* Add some break code or so... */ + iEqual = PopLogical(); /* Logical should be on top of stack */ + PushNumber( dStep ); /* Push the step expression back on the stack */ + PushLogical( iEqual ); + } + else + printf( "step expression should be numerical" ); +} + +void Frame( BYTE bLocals, BYTE bParams ) +{ + int i, iTotal = bLocals + bParams; + + HBDEBUG( "Frame\n" ); + if( iTotal ) + for( i = 0; i < ( iTotal - stack.pBase->wParams ); i++ ) + PushNil(); +} + +void FuncPtr( void ) /* pushes a function address pointer. Removes the symbol from the satck */ +{ + PITEM pItem = stack.pPos - 1; + + if( IS_SYMBOL( pItem ) ) + { + StackPop(); + PushLong( ( ULONG ) pItem->value.pSymbol->pFunPtr ); + } + else + { + printf( "symbol item expected from FuncPtr()\n" ); + exit( 1 ); + } +} + +void Function( WORD wParams ) +{ + Do( wParams ); + ItemCopy( stack.pPos, &stack.Return ); + StackPush(); +} + +void GenArray( WORD wElements ) /* generates a wElements Array and fills it from the stack values */ +{ + ITEM itArray; + WORD w; + + itArray.wType = IT_NIL; + Array( &itArray, wElements ); + for( w = 0; w < wElements; w++ ) + ItemCopy( ( ( PBASEARRAY ) itArray.value.pBaseArray )->pItems + w, + stack.pPos - wElements + w ); + + for( w = 0; w < wElements; w++ ) + StackPop(); + + ItemCopy( stack.pPos, &itArray ); + ItemRelease( &itArray ); + StackPush(); +} + +void Greater( void ) +{ + double dNumber1, dNumber2; + LONG lDate1, lDate2; + int i; + + if( IS_STRING( stack.pPos - 2 ) && IS_STRING( stack.pPos - 1 ) ) + { + i = OurStrCmp( stack.pPos - 2, stack.pPos - 1 ); + StackPop(); + StackPop(); + PushLogical( i > 0 ); + } + + else if( IS_NUMERIC( stack.pPos - 1 ) && IS_NUMERIC( stack.pPos - 2 ) ) + { + dNumber2 = PopNumber(); + dNumber1 = PopNumber(); + PushLogical( dNumber1 > dNumber2 ); + } + + else if( IS_DATE( stack.pPos - 1 ) && IS_DATE( stack.pPos - 2 ) ) + { + lDate2 = PopDate(); + lDate1 = PopDate(); + PushLogical( lDate1 > lDate2 ); + } + + else if( ( stack.pPos - 2 )->wType != ( stack.pPos - 1 )->wType ) + { + printf( "types not match on greater operation\n" ); + exit( 1 ); + } +} + +void GreaterEqual( void ) +{ + double dNumber1, dNumber2; + LONG lDate1, lDate2; + int i; + + if( IS_STRING( stack.pPos - 2 ) && IS_STRING( stack.pPos - 1 ) ) + { + i = OurStrCmp( stack.pPos - 2, stack.pPos - 1 ); + StackPop(); + StackPop(); + PushLogical( i >= 0 ); + } + + else if( IS_NUMERIC( stack.pPos - 1 ) && IS_NUMERIC( stack.pPos - 2 ) ) + { + dNumber2 = PopNumber(); + dNumber1 = PopNumber(); + PushLogical( dNumber1 >= dNumber2 ); + } + + else if( IS_DATE( stack.pPos - 1 ) && IS_DATE( stack.pPos - 2 ) ) + { + lDate2 = PopDate(); + lDate1 = PopDate(); + PushLogical( lDate1 >= lDate2 ); + } + + else if( ( stack.pPos - 2 )->wType != ( stack.pPos - 1 )->wType ) + { + printf( "types not match on greaterequal operation\n" ); + exit( 1 ); + } +} + +void Inc( void ) +{ + double dNumber; + LONG lDate; + PITEM pError; + + if( IS_NUMERIC( stack.pPos - 1 ) ) + { + dNumber = PopDouble(); + PushNumber( ++dNumber ); + } + else if( IS_DATE( stack.pPos - 1 ) ) + { + lDate = PopDate(); + PushDate( ++lDate ); + } + else + { + pError = _errNew(); + _errPutDescription( pError, "Error BASE/1086 Argument error: ++" ); + _errLaunch( pError ); + } +} + +void ItemRelease( PITEM pItem ) +{ + if( IS_STRING( pItem ) ) + { + if( pItem->value.szText ) + { + _xfree( pItem->value.szText ); + pItem->value.szText = 0; + } + pItem->wLength = 0; + } + else if( IS_ARRAY( pItem ) ) + { + if( --( ( PBASEARRAY ) pItem->value.pBaseArray )->wHolders == 0 ) + ArrayRelease( pItem ); + } + else if( IS_BLOCK( pItem ) ) + { + CodeblockDelete( ( PCODEBLOCK ) pItem->value.pCodeblock ); + } + pItem->wType = IT_NIL; +} + +void ItemCopy( PITEM pDest, PITEM pSource ) +{ + ItemRelease( pDest ); + + if( pDest == pSource ) + { + printf( "an item was going to be copied to itself from ItemCopy()\n" ); + exit( 1 ); + } + + memcpy( pDest, pSource, sizeof( ITEM ) ); + + if( IS_STRING( pSource ) ) + { + pDest->value.szText = ( char * ) _xgrab( pSource->wLength + 1 ); + memcpy( pDest->value.szText, pSource->value.szText, pSource->wLength ); + pDest->value.szText[ pSource->wLength ] = 0; + } + + else if( IS_ARRAY( pSource ) ) + ( ( PBASEARRAY ) pSource->value.pBaseArray )->wHolders++; + + else if( IS_BLOCK( pSource ) ) + { + CodeblockCopy( pDest, pSource ); + } +} + +void Less( void ) +{ + double dNumber1, dNumber2; + LONG lDate1, lDate2; + int i; + + if( IS_STRING( stack.pPos - 2 ) && IS_STRING( stack.pPos - 1 ) ) + { + i = OurStrCmp( stack.pPos - 2, stack.pPos - 1 ); + StackPop(); + StackPop(); + PushLogical( i < 0 ); + } + + else if( IS_NUMERIC( stack.pPos - 1 ) && IS_NUMERIC( stack.pPos - 2 ) ) + { + dNumber2 = PopNumber(); + dNumber1 = PopNumber(); + PushLogical( dNumber1 < dNumber2 ); + } + + else if( IS_DATE( stack.pPos - 1 ) && IS_DATE( stack.pPos - 2 ) ) + { + lDate2 = PopDate(); + lDate1 = PopDate(); + PushLogical( lDate1 < lDate2 ); + } + + else if( ( stack.pPos - 2 )->wType != ( stack.pPos - 1 )->wType ) + { + printf( "types not match on less operation\n" ); + exit( 1 ); + } +} + +void LessEqual( void ) +{ + double dNumber1, dNumber2; + LONG lDate1, lDate2; + int i; + + if( IS_STRING( stack.pPos - 2 ) && IS_STRING( stack.pPos - 1 ) ) + { + i = OurStrCmp( stack.pPos - 2, stack.pPos - 1 ); + StackPop(); + StackPop(); + PushLogical( i <= 0 ); + } + + else if( IS_NUMERIC( stack.pPos - 1 ) && IS_NUMERIC( stack.pPos - 2 ) ) + { + dNumber2 = PopNumber(); + dNumber1 = PopNumber(); + PushLogical( dNumber1 <= dNumber2 ); + } + + else if( IS_DATE( stack.pPos - 1 ) && IS_DATE( stack.pPos - 2 ) ) + { + lDate2 = PopDate(); + lDate1 = PopDate(); + PushLogical( lDate1 <= lDate2 ); + } + + else if( ( stack.pPos - 2 )->wType != ( stack.pPos - 1 )->wType ) + { + printf( "types not match on lessequal operation\n" ); + exit( 1 ); + } +} + +void Message( PSYMBOL pSymMsg ) /* sends a message to an object */ +{ + ItemCopy( stack.pPos, stack.pPos - 1 ); /* moves the object forward */ + ItemRelease( stack.pPos - 1 ); + ( stack.pPos - 1 )->wType = IT_SYMBOL; + ( stack.pPos - 1 )->value.pSymbol = pSymMsg; + ( stack.pPos - 1 )->wBase = ( stack.pPos - 1 ) - stack.pItems; + StackPush(); + HBDEBUG2( "Message: %s\n", pSymMsg->szName ); +} + +void Line( WORD wLine ) +{ + stack.pBase->wLine = wLine; + HBDEBUG( "line\n" ); +} + +void Negate( void ) +{ + if( IS_INTEGER( stack.pPos - 1 ) ) + ( stack.pPos - 1 )->value.iNumber = -( stack.pPos - 1 )->value.iNumber; + + else if( IS_LONG( stack.pPos - 1 ) ) + ( stack.pPos - 1 )->value.lNumber = -( stack.pPos - 1 )->value.lNumber; + + else if( IS_DOUBLE( stack.pPos - 1 ) ) + ( stack.pPos - 1 )->value.dNumber = -( stack.pPos - 1 )->value.dNumber; +} + +void Not( void ) +{ + PITEM pItem = stack.pPos - 1; + + if( IS_LOGICAL( pItem ) ) + pItem->value.iLogical = ! pItem->value.iLogical; + else + ; /* TODO: Raise an error here ? */ +} + +void NotEqual( void ) +{ + PITEM pItem2 = stack.pPos - 1; + PITEM pItem1 = stack.pPos - 2; + int i; + + if( IS_NIL( pItem1 ) && IS_NIL( pItem2 ) ) + { + StackPop(); + StackPop(); + PushLogical( 0 ); + } + + else if ( IS_NIL( pItem1 ) || IS_NIL( pItem2 ) ) + { + StackPop(); + StackPop(); + PushLogical( 1 ); /* TOFIX: Is this correct ? */ + } + + else if( IS_STRING( pItem1 ) && IS_STRING( pItem2 ) ) + { + i = OurStrCmp( pItem1, pItem2 ); + StackPop(); + StackPop(); + PushLogical( i != 0 ); + } + + else if( IS_NUMERIC( pItem1 ) && IS_NUMERIC( pItem2 ) ) + PushLogical( PopDouble() != PopDouble() ); + + else if( pItem1->wType != pItem2->wType ) + { + printf( "types not match on equal operation\n" ); + exit( 1 ); + } + + else + PushLogical( 1 ); +} + +void Minus( void ) +{ + double dNumber1, dNumber2; + long lDate1, lDate2; + + if( IS_NUMERIC( stack.pPos - 1 ) && IS_NUMERIC( stack.pPos - 2 ) ) + { + dNumber2 = PopNumber(); + dNumber1 = PopNumber(); + PushNumber( dNumber1 - dNumber2 ); + } + else if( IS_DATE( stack.pPos - 1 ) && IS_DATE( stack.pPos - 2 ) ) + { + lDate2 = PopDate(); + lDate1 = PopDate(); + PushNumber( lDate1 - lDate2 ); + } + else if( IS_NUMERIC( stack.pPos - 1 ) && IS_DATE( stack.pPos - 2 ) ) + { + dNumber2 = PopNumber(); + lDate1 = PopDate(); + PushDate( lDate1 - dNumber2 ); + } + /* TODO: We should substract strings also ? and generate an error it types + don't match */ +} + +void Modulus( void ) +{ + double d2 = PopDouble(); + double d1 = PopDouble(); + + PushNumber( ( long ) d1 % ( long ) d2 ); +} + +void Mult( void ) +{ + double d2 = PopDouble(); + double d1 = PopDouble(); + + PushNumber( d1 * d2 ); +} + +void Or( void ) +{ + PITEM pItem2 = stack.pPos - 1; + PITEM pItem1 = stack.pPos - 2; + PITEM pError; + int iResult; + + if( IS_LOGICAL( pItem1 ) && IS_LOGICAL( pItem2 ) ) + { + iResult = pItem1->value.iLogical || pItem2->value.iLogical; + StackPop(); + StackPop(); + PushLogical( iResult ); + } + else + { + pError = _errNew(); + _errPutDescription( pError, "Argument error: conditional" ); + _errLaunch( pError ); + _errRelease( pError ); + } +} + +void Plus( void ) +{ + PITEM pItem1 = stack.pPos - 2; + PITEM pItem2 = stack.pPos - 1; + double dNumber1, dNumber2; + long lDate1, lDate2; + + if( IS_STRING( pItem1 ) && IS_STRING( pItem2 ) ) + { + pItem1->value.szText = (char*)_xrealloc( pItem1->value.szText, pItem1->wLength + pItem2->wLength + 1 ); + memcpy( pItem1->value.szText + pItem1->wLength, + pItem2->value.szText, pItem2->wLength ); + pItem1->wLength += pItem2->wLength; + pItem1->value.szText[ pItem1->wLength ] = 0; + if( pItem2->value.szText ) + { + _xfree( pItem2->value.szText ); + pItem2->value.szText = 0; + } + StackPop(); + return; + } + + else if( IS_NUMERIC( pItem1 ) && IS_NUMERIC( pItem2 ) ) + { + dNumber2 = PopDouble(); + dNumber1 = PopDouble(); + PushNumber( dNumber1 + dNumber2 ); + } + + else if( IS_DATE( pItem1 ) && IS_DATE( pItem2 ) ) + { + lDate2 = PopDate(); + lDate1 = PopDate(); + PushDate( lDate1 + lDate2 ); + } + + else if( IS_DATE( pItem1 ) && IS_NUMERIC( pItem2 ) ) + { + dNumber2 = PopDouble(); + lDate1 = PopDate(); + PushDate( lDate1 + dNumber2 ); + } + /* TODO: Generate an error if types don't match */ + HBDEBUG( "Plus\n" ); +} + +long PopDate( void ) +{ + StackPop(); + + if( IS_DATE( stack.pPos ) ) + return stack.pPos->value.lDate; + else + { + printf( "incorrect item value trying to Pop a date value\n" ); + exit( 1 ); + return 0; + } +} + +void PopDefStat( WORD wStatic ) /* Pops a default value to a STATIC */ +{ + PITEM pStatic; + + StackPop(); + pStatic = ( ( PBASEARRAY ) aStatics.value.pBaseArray )->pItems + stack.iStatics + + wStatic - 1; + + if( IS_BYREF( pStatic ) ) + { + if( ( stack.pItems + pStatic->value.wItem )->wType == IT_NIL ) + /* Only initialize when NIL */ + ItemCopy( stack.pItems + pStatic->value.wItem, stack.pPos ); + } + else + if( pStatic->wType == IT_NIL ) /* Only initialize when NIL */ + ItemCopy( pStatic, stack.pPos ); + + ItemRelease( stack.pPos ); + HBDEBUG( "PopDefStat\n" ); +} + +double PopDouble( void ) +{ + double d; + + StackPop(); + + switch( stack.pPos->wType ) + { + case IT_INTEGER: + d = stack.pPos->value.iNumber; + break; + + case IT_LONG: + d = stack.pPos->value.lNumber; + break; + + case IT_DOUBLE: + d = stack.pPos->value.dNumber; + break; + + default: + printf( "Incorrect item type trying to Pop a double\n" ); + exit( 1 ); + d = 0; + } + HBDEBUG( "PopDouble\n" ); + return d; +} + +void PopLocal( SHORT iLocal ) +{ + PITEM pLocal; + + StackPop(); + + if( iLocal >= 0 ) + { + /* local variable or local parameter */ + pLocal = stack.pBase + 1 + iLocal; + if( IS_BYREF( pLocal ) ) + ItemCopy( stack.pItems + pLocal->value.wItem, stack.pPos ); + else + ItemCopy( pLocal, stack.pPos ); + } + else + /* local variable referenced in a codeblock */ + ItemCopy( CodeblockGetVar( stack.pBase + 1, iLocal ), stack.pPos ); + + ItemRelease( stack.pPos ); + HBDEBUG( "PopLocal\n" ); +} + +int PopLogical( void ) +{ + PITEM pError; + + StackPop(); + + if( IS_LOGICAL( stack.pPos ) ) + return stack.pPos->value.iLogical; + else + { + pError = _errNew(); + _errPutDescription( pError, "Argument error: conditional" ); + _errLaunch( pError ); + _errRelease( pError ); + return 0; + } +} + +double PopNumber( void ) +{ + PITEM pItem = stack.pPos - 1; + double dNumber; + + StackPop(); + + switch( pItem->wType ) + { + case IT_INTEGER: + dNumber = ( double ) pItem->value.iNumber; + break; + + case IT_LONG: + dNumber = ( double ) pItem->value.lNumber; + break; + + case IT_DOUBLE: + dNumber = pItem->value.dNumber; + break; + + default: + printf( "Incorrect item on the stack trying to pop a number\n" ); + exit( 1 ); + break; + } + return dNumber; +} + +void PopStatic( WORD wStatic ) +{ + PITEM pStatic; + + StackPop(); + pStatic = ( ( PBASEARRAY ) aStatics.value.pBaseArray )->pItems + stack.iStatics + + wStatic - 1; + + if( IS_BYREF( pStatic ) ) + ItemCopy( stack.pItems + pStatic->value.wItem, stack.pPos ); + else + ItemCopy( pStatic, stack.pPos ); + + ItemRelease( stack.pPos ); + HBDEBUG( "PopStatic\n" ); +} + +void Power( void ) +{ + double d2 = PopDouble(); + double d1 = PopDouble(); + + PushNumber( pow( d1, d2 ) ); +} + +void PushLogical( int iTrueFalse ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_LOGICAL; + stack.pPos->value.iLogical = iTrueFalse; + StackPush(); + HBDEBUG( "PushLogical\n" ); +} + +void PushLocal( SHORT iLocal ) +{ + if( iLocal >= 0 ) + /* local variable or local parameter */ + ItemCopy( stack.pPos, stack.pBase + 1 + iLocal ); + else + /* local variable referenced in a codeblock */ + ItemCopy( stack.pPos, CodeblockGetVar( stack.pBase + 1, iLocal ) ); + StackPush(); + HBDEBUG2( "PushLocal %i\n", iLocal ); +} + +void PushLocalByRef( SHORT iLocal ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_BYREF; + /* we store its stack offset instead of a pointer to support a dynamic stack */ + if( iLocal >= 0 ) + /* local variable or local parameter */ + stack.pPos->value.wItem = stack.pBase + 1 + iLocal - stack.pItems; + else + /* local variable referenced in a codeblock */ + stack.pPos->value.wItem = iLocal; + + StackPush(); + HBDEBUG2( "PushLocalByRef %i\n", iLocal ); +} + +void PushNil( void ) +{ + ItemRelease( stack.pPos ); + StackPush(); + HBDEBUG( "PushNil\n" ); +} + +void PushNumber( double dNumber ) +{ + if( ! dNumber ) + PushInteger( 0 ); + + /* QUESTION: Is this a valid way to check for decimals ? */ + else if( ( long ) dNumber < dNumber ) /* it contains decimals */ + PushDouble( dNumber ); + + else if( SHRT_MIN <= dNumber && dNumber <= SHRT_MAX ) + PushInteger( dNumber ); + + else if( LONG_MIN <= dNumber && dNumber <= LONG_MAX ) + PushLong( dNumber ); + + else + PushDouble( dNumber ); +} + +void PushStatic( WORD wStatic ) +{ + ItemCopy( stack.pPos, ( ( PBASEARRAY ) aStatics.value.pBaseArray )->pItems + + stack.iStatics + wStatic - 1 ); + StackPush(); + HBDEBUG2( "PushStatic %i\n", wStatic ); +} + +void PushString( char * szText, WORD wLength ) +{ + char * szTemp = ( char * ) _xgrab( wLength + 1 ); + WORD w = 0; + + while( w < wLength ) + szTemp[ w++ ] = szText[ w ]; + szTemp[ w ] = 0; + + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_STRING; + stack.pPos->wLength = wLength; + stack.pPos->value.szText = szTemp; + StackPush(); + HBDEBUG( "PushString\n" ); +} + +void PushSymbol( PSYMBOL pSym ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_SYMBOL; + stack.pPos->value.pSymbol = pSym; + stack.pPos->wBase = stack.pPos - stack.pItems; + StackPush(); + HBDEBUG2( "PushSymbol: %s\n", pSym->szName ); +} + +void Push( PITEM pItem ) +{ + ItemCopy( stack.pPos, pItem ); + StackPush(); + HBDEBUG( "Push\n" ); +} + +void PushBlock( BYTE * pCode, WORD wSize, WORD wParam, PSYMBOL pSymbols ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_BLOCK; + stack.pPos->value.pCodeblock = (BYTE *)CodeblockNew( pCode, wSize, pSymbols ); + /* store the stack base of function where the codeblock was defined */ + stack.pPos->wBase = stack.pBase - stack.pItems; + /* store the number of expected parameters */ + stack.pPos->wParams = wParam; + /* store the line number where the codeblock was defined */ + stack.pPos->wLine = stack.pBase->wLine; + StackPush(); + HBDEBUG( "PushBlock\n" ); +} + +void PushDate( LONG lDate ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_DATE; + stack.pPos->value.lDate = lDate; + StackPush(); + HBDEBUG( "PushDate\n" ); +} + +void PushDouble( double dNumber ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_DOUBLE; + stack.pPos->value.dNumber = dNumber; + StackPush(); + HBDEBUG( "PushDouble\n" ); +} + +void PushInteger( int iNumber ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_INTEGER; + stack.pPos->value.iNumber = iNumber; + StackPush(); + HBDEBUG( "PushInteger\n" ); +} + +void PushLong( long lNumber ) +{ + ItemRelease( stack.pPos ); + stack.pPos->wType = IT_LONG; + stack.pPos->value.lNumber = lNumber; + StackPush(); + HBDEBUG( "PushLong\n" ); +} + +void RetValue( void ) +{ + StackPop(); + ItemCopy( &stack.Return, stack.pPos ); + if( stack.Return.wType == IT_BLOCK ) + CodeblockDetach( (PCODEBLOCK)stack.Return.value.pCodeblock ); + HBDEBUG( "RetValue\n" ); +} + +void StackPop( void ) +{ + ItemRelease( stack.pPos ); + + if( --stack.pPos < stack.pItems ) + { + printf( "runtime error: stack underflow\n" ); + exit( 1 ); + } +} + +void StackFree( void ) +{ + _xfree( stack.pItems ); + HBDEBUG( "StackFree\n" ); +} + +void StackPush( void ) +{ + LONG CurrIndex, /* index of current top item */ + TopIndex; /* index of the topmost possible item */ + + CurrIndex = stack.pPos - stack.pItems; + TopIndex = stack.wItems - 1; + + /* enough room for another item ? */ + if( !( TopIndex > CurrIndex ) ) + { + LONG BaseIndex; /* index of stack base */ + + BaseIndex = stack.pBase - stack.pItems; + + /* no, make more headroom: */ + /* StackShow(); */ + stack.pItems = (PITEM)_xrealloc( stack.pItems, sizeof( ITEM ) * + ( stack.wItems + STACK_EXPANDITEMS ) ); + + /* fix possibly invalid pointers: */ + stack.pPos = stack.pItems + CurrIndex; + stack.pBase = stack.pItems + BaseIndex; + stack.wItems += STACK_EXPANDITEMS; + /* StackShow(); */ + } + + /* now, push it: */ + stack.pPos++; + stack.pPos->wType = IT_NIL; + return; +} + +void StackInit( void ) +{ + stack.pItems = ( PITEM ) _xgrab( sizeof( ITEM ) * STACK_INITITEMS ); + stack.pBase = stack.pItems; + stack.pPos = stack.pItems; /* points to the first stack item */ + stack.wItems = STACK_INITITEMS; + HBDEBUG( "StackInit\n" ); +} + + void StackShow( void ) +{ + PITEM p; + + for( p = stack.pBase; p <= stack.pPos; p++ ) + { + switch( p->wType ) + { + case IT_NIL: + printf( "NIL " ); + break; + + case IT_ARRAY: + if( ( ( PBASEARRAY ) p->value.pBaseArray )->wClass ) + printf( "OBJECT " ); + else + printf( "ARRAY " ); + break; + + case IT_BLOCK: + printf( "BLOCK " ); + break; + + case IT_DATE: + printf( "DATE " ); + break; + + case IT_DOUBLE: + printf( "DOUBLE " ); + break; + + case IT_LOGICAL: + printf( "LOGICAL[%i] ", p->value.iLogical ); + break; + + case IT_LONG: + break; + + case IT_INTEGER: + printf( "INTEGER[%i] ", p->value.iNumber ); + break; + + case IT_STRING: + printf( "STRING " ); + break; + + case IT_SYMBOL: + printf( "SYMBOL(%s) ", p->value.pSymbol->szName ); + break; + + default: + printf( "DUNNO[%i] ", p->wType ); + break; + } + } + printf( "\n" ); +} + +void SFrame( PSYMBOL pSym ) /* sets the statics frame for a function */ +{ + /* _INITSTATICS is now the statics frame. Statics() changed it! */ + stack.iStatics = ( int ) pSym->pFunPtr; /* pSym is { "_INITSTATICS", FS_INIT, _INITSTATICS } for each PRG */ + HBDEBUG( "SFrame\n" ); +} + +void Statics( PSYMBOL pSym ) /* initializes the global aStatics array or redimensionates it */ +{ + WORD wStatics = PopNumber(); + + if( IS_NIL( &aStatics ) ) + { + pSym->pFunPtr = 0; /* statics frame for this PRG */ + Array( &aStatics, wStatics ); + } + else + { + pSym->pFunPtr = ( HARBOURFUNC ) ArrayLen( &aStatics ); + ArraySize( &aStatics, ArrayLen( &aStatics ) + wStatics ); + } + + HBDEBUG2( "Statics %i\n", ArrayLen( &aStatics ) ); +} + +void ProcessSymbols( PSYMBOL pModuleSymbols, WORD wModuleSymbols ) /* module symbols initialization */ +{ + PSYMBOLS pNewSymbols, pLastSymbols; + WORD w; + + pNewSymbols = ( PSYMBOLS ) _xgrab( sizeof( SYMBOLS ) ); + pNewSymbols->pModuleSymbols = pModuleSymbols; + pNewSymbols->wModuleSymbols = wModuleSymbols; + pNewSymbols->pNext = 0; + + if( ! pSymbols ) + pSymbols = pNewSymbols; + else + { + pLastSymbols = pSymbols; + while( pLastSymbols->pNext ) /* locates the latest processed group of symbols */ + pLastSymbols = pLastSymbols->pNext; + pLastSymbols->pNext = pNewSymbols; + } + + for( w = 0; w < wModuleSymbols; w++ ) /* register each public symbol on the dynamic symbol table */ + { + if( ( ! pSymStart ) && ( ( pModuleSymbols + w )->cScope == FS_PUBLIC ) ) + pSymStart = pModuleSymbols + w; /* first public defined symbol to start execution */ + + if( ( ( pModuleSymbols + w )->cScope == FS_PUBLIC ) || + ( ( pModuleSymbols + w )->cScope & FS_MESSAGE ) ) + NewDynSym( pModuleSymbols + w ); + } +} + +void ReleaseLocalSymbols( void ) +{ + PSYMBOLS pDestroy; + + while( pSymbols ) + { + pDestroy = pSymbols; + pSymbols = pSymbols->pNext; + _xfree( pDestroy ); + } +} + +void DoExitFunctions( void ) +{ + PSYMBOLS pLastSymbols = pSymbols; + WORD w; + + do { + for( w = 0; w < pLastSymbols->wModuleSymbols; w++ ) + { + if( ( pLastSymbols->pModuleSymbols + w )->cScope & FS_EXIT ) + { + PushSymbol( pLastSymbols->pModuleSymbols + w ); + PushNil(); + Do( 0 ); + } + } + pLastSymbols = pLastSymbols->pNext; + } while( pLastSymbols ); +} + +void DoInitFunctions( int argc, char * argv[] ) +{ + PSYMBOLS pLastSymbols = pSymbols; + WORD w; + + do { + for( w = 0; w < pLastSymbols->wModuleSymbols; w++ ) + { + if( ( pLastSymbols->pModuleSymbols + w )->cScope & FS_INIT ) + { + int i; + + PushSymbol( pLastSymbols->pModuleSymbols + w ); + PushNil(); + + for( i = 1; i < argc; i++ ) /* places application parameters on the stack */ + PushString( argv[ i ], strlen( argv[ i ] ) ); + + Do( argc - 1 ); + } + } + pLastSymbols = pLastSymbols->pNext; + } while( pLastSymbols ); +} + +HARBOUR LEN( void ) +{ + PITEM pItem; + + if( _pcount() ) + { + pItem = _param( 1, IT_ANY ); + + switch( pItem->wType ) + { + case IT_ARRAY: + _retnl( ( ( PBASEARRAY ) pItem->value.pBaseArray )->ulLen ); + break; + + case IT_STRING: + _retnl( pItem->wLength ); + break; + + default: + _retni( 0 ); /* QUESTION: Should we raise an error here ? */ + break; + } + } + else + _retni( 0 ); /* QUESTION: Should we raise an error here ? */ +} + +HARBOUR EMPTY() +{ + PITEM pItem = _param( 1, IT_ANY ); + + if( pItem ) + { + switch( pItem->wType ) + { + case IT_ARRAY: + _retl( ( ( PBASEARRAY ) pItem->value.pBaseArray )->ulLen == 0 ); + break; + + case IT_STRING: + _retl( strempty( _parc( 1 ), _parclen( 1 ) ) ); + break; + + case IT_NUMERIC: + _retl( ! _parni( 1 ) ); + break; + + case IT_LONG: + _retl( ! _parnl( 1 ) ); + break; + + case IT_DOUBLE: + _retl( ! _parnd( 1 ) ); + break; + + case IT_DATE: + _retl( atol( _pards( 1 ) ) == 0 ); /* Convert to long */ + break; + + case IT_LOGICAL: + _retl( ! _parl( 1 ) ); + break; + + case IT_BLOCK: + _retl( FALSE ); + break; + + default: + _retl( TRUE ); + break; + } + } + else + _retl( TRUE ); +} + + +HARBOUR VALTYPE( void ) +{ + PITEM pItem; + + if( _pcount() ) + { + pItem = _param( 1, IT_ANY ); + + switch( pItem->wType ) + { + case IT_ARRAY: + if( ( ( PBASEARRAY ) pItem->value.pBaseArray )->wClass ) + _retc( "O" ); /* it is an object */ + else + _retc( "A" ); + break; + + case IT_BLOCK: + _retc( "B" ); + break; + + case IT_DATE: + _retc( "D" ); + break; + + case IT_LOGICAL: + _retc( "L" ); + break; + + case IT_INTEGER: + case IT_LONG: + case IT_DOUBLE: + _retc( "N" ); + break; + + case IT_STRING: + _retc( "C" ); + break; + + case IT_NIL: + default: + _retc( "U" ); + break; + } + } + else + _retc( "U" ); +} + +HARBOUR ERRORBLOCK() +{ + ITEM oldError; + PITEM pNewErrorBlock = _param( 1, IT_BLOCK ); + + oldError.wType = IT_NIL; + ItemCopy( &oldError, &errorBlock ); + + if( pNewErrorBlock ) + ItemCopy( &errorBlock, pNewErrorBlock ); + + ItemCopy( &stack.Return, &oldError ); + ItemRelease( &oldError ); +} + +HARBOUR PROCNAME() +{ + int iLevel = _parni( 1 ) + 1; /* we are already inside ProcName() */ + PITEM pBase = stack.pBase; + + while( ( iLevel-- > 0 ) && pBase != stack.pItems ) + pBase = stack.pItems + pBase->wBase; + + if( ( iLevel == -1 ) ) + _retc( pBase->value.pSymbol->szName ); + else + _retc( "" ); +} + +HARBOUR PROCLINE() +{ + int iLevel = _parni( 1 ) + 1; /* we are already inside ProcName() */ + PITEM pBase = stack.pBase; + + while( ( iLevel-- > 0 ) && pBase != stack.pItems ) + pBase = stack.pItems + pBase->wBase; + + if( iLevel == -1 ) + _retni( pBase->wLine ); + else + _retni( 0 ); +} + +HARBOUR __QUIT() +{ + bQuit = TRUE; +} + +HARBOUR ERRORLEVEL() +{ + BYTE bPrevValue = bErrorLevel; + + bErrorLevel = _parni( 1 ); + _retni( bPrevValue ); +} + +