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

Initial revision

Browse Source
This commit is contained in:
Antonio Linares
1999-05-04 22:24:43 +00:00
parent bc352ccd54
commit 9d457f6e48
23 changed files with 11172 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

368
harbour/source/compiler/harbour.l Normal file
View File

@@ -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 <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <limits.h>
#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;
<STRING1>[^'^\n]* GenError( ERR_STRING_TERMINATOR, yytext, NULL ); BEGIN 0;
<STRING2>[^\"^\n]* GenError( ERR_STRING_TERMINATOR, yytext, NULL ); BEGIN 0;
<STRING1>[^']*' { BEGIN 0; yylval.string = strdup( yytext + 1 );
yylval.string[ yyleng - 2 ] = 0; return LITERAL; }
<STRING2>[^\"]*\" { BEGIN 0; yylval.string = strdup( yytext + 1 );
yylval.string[ yyleng - 2 ] = 0; return LITERAL; }
"/*" BEGIN COMMENT3;
<COMMENT3>"*/" BEGIN 0;
<COMMENT3>[^"*/"\n]* ;
<COMMENT3>[\/\"]+ ;
<COMMENT3>\n ++iLine; if( ! _iQuiet ) printf( "\rline: %i", iLine );
"#"{SpaceTab}*"define" BEGIN DEFINE;
<DEFINE>{Identifier}/{SpaceTab}+ Define( yytext );
<DEFINE>{Identifier}/{SpaceTab}*\n Define( yytext ); BEGIN 0;
<DEFINE>{SpaceTab} ;
<DEFINE>{Identifier} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0;
<DEFINE>{PseudoFunc} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0;
<DEFINE>{String} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0;
<DEFINE>-?{Number} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0;
<DEFINE>{HexNumber} LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0;
<DEFINE>"/*".*"*/" ;
<DEFINE>{Number}{SpaceTab}*[\(] yyerror( "Syntax error in #define" );
<DEFINE>{String}{SpaceTab}*[\(] yyerror( "Syntax error in #define" );
<DEFINE>{Identifier}{SpaceTab}*[\(] Define( yytext ); BEGIN DEFINE_PARAMS;
<DEFINE_PARAMS>{SpaceTab} ;
<DEFINE_PARAMS>{Identifier} DefineKey( yytext );
<DEFINE_PARAMS>[\,] ;
<DEFINE_PARAMS>[\)] BEGIN DEFINE_EXPR;
<DEFINE_EXPR>.*/\n LastDef( pDefs )->szValue = strdup( yytext ); BEGIN 0;
"#"{SpaceTab}*"ifdef" BEGIN IFDEF;
<IFDEF>{Identifier} if( FindDef( yytext ) ) BEGIN 0;
<IFDEF>"#"{SpaceTab}*"else"\n ++iLine; BEGIN 0;
<IFDEF>"#"{SpaceTab}*"endif"\n ++iLine; BEGIN 0;
<IFDEF>\n ++iLine;
<IFDEF>[\(\),\"\/\.]* ;
<IFDEF>"#"{SpaceTab}*"ifdef" ;
<IFDEF>"#"{SpaceTab}*"else" BEGIN 0;
"#"{SpaceTab}*"else" BEGIN IFDEF;
"#"{SpaceTab}*"endif" BEGIN 0;
"#"{SpaceTab}*"ifndef" BEGIN IFNDEF;
<IFNDEF>{Identifier} if( ! FindDef( yytext ) ) BEGIN 0;
<IFNDEF>"#endif"\n ++iLine; BEGIN 0;
<IFNDEF>\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;
}

2948
harbour/source/compiler/harbour.y Normal file
View File

File diff suppressed because it is too large Load Diff

473
harbour/source/rtl/arrays.c Normal file
View File

@@ -0,0 +1,473 @@
#include <extend.h>
#include <ctoharb.h>
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();
}

411
harbour/source/rtl/classes.c Normal file
View File

@@ -0,0 +1,411 @@
#include <extend.h>
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 );
}

176
harbour/source/rtl/codebloc.c Normal file
View File

@@ -0,0 +1,176 @@
/* The Harbour implementation of codeblocks */
#include <extend.h>
#include <string.h>
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
}

112
harbour/source/rtl/console.c Normal file
View File

@@ -0,0 +1,112 @@
#ifdef WINDOWS
#include <windows.h>
#endif
#include <stdio.h>
#include <extend.h>
#include <ctoharb.h>
#include <dates.h>
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
}

360
harbour/source/rtl/dates.c Normal file
View File

@@ -0,0 +1,360 @@
#include <extend.h>
#include <set.h>
#include <ctype.h>
#include <time.h>
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);
}
}

32
harbour/source/rtl/environ.c Normal file
View File

@@ -0,0 +1,32 @@
#include <extend.h>
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("");
}

33
harbour/source/rtl/error.prg Normal file
View File

@@ -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()
//----------------------------------------------------------------------------//

39
harbour/source/rtl/errorapi.c Normal file
View File

@@ -0,0 +1,39 @@
#include <extend.h>
#include <CToHarb.h>
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 );
}

39
harbour/source/rtl/errorsys.prg Normal file
View File

@@ -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
//----------------------------------------------------------------------------//

619
harbour/source/rtl/extend.c Normal file
View File

@@ -0,0 +1,619 @@
#include <malloc.h>
#include <stdlib.h>
#include <extend.h>
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--;
}

337
harbour/source/rtl/files.c Normal file
View File

@@ -0,0 +1,337 @@
#include <extend.h>
#if defined(_SO_LINUX)
#include <unistd.h>
#endif
#if defined(__GNUC__)
#include <unistd.h>
/* 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 <unistd.h>
#endif
#if defined(__BORLANDC__)
#include <fcntl.h>
#include <io.h>
#endif
#if defined(_SO_DOS)
#if defined(_CC_DJGPP)
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#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();
}

360
harbour/source/rtl/itemapi.c Normal file
View File

@@ -0,0 +1,360 @@
#include <extend.h>
#include <itemapi.h>
#include <ctoharb.h>
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;
}

278
harbour/source/rtl/math.c Normal file
View File

@@ -0,0 +1,278 @@
#include <extend.h>
#include <math.h>
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);
}
}

135
harbour/source/rtl/mathx.c Normal file
View File

@@ -0,0 +1,135 @@
#include <extend.h>
#include <math.h>
#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);
}

295
harbour/source/rtl/set.c Normal file
View File

@@ -0,0 +1,295 @@
#include <ctype.h>
#include <extend.h>
#include <set.h>
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);
}

41
harbour/source/rtl/strcmp.c Normal file
View File

@@ -0,0 +1,41 @@
#include <extend.h>
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);
}

1067
harbour/source/rtl/strings.c Normal file
View File

File diff suppressed because it is too large Load Diff

157
harbour/source/rtl/tclass.prg Normal file
View File

@@ -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
//----------------------------------------------------------------------------//

670
harbour/source/rtl/transfrm.c Normal file
View File

@@ -0,0 +1,670 @@
#include <extend.h>
#include <CToHarb.h>
#include <ctype.h>
/* */
/* 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; i<lPic && !bFound; i++ ) /* Count number in front */
{
if( szPic[i] == '.' )
bFound = !(iPicFlags & PF_NUMDATE); /* Exit when numeric */
else if( szPic[i] == '9' || szPic[i] == '#' ||
szPic[i] == '$' || szPic[i] == '*' )
iCount++;
}
iWidth = iCount;
if( bFound ) /* Did we find a dot */
{
iDecimals = 0;
iWidth++; /* Also adjust iWidth */
for( ; i<lPic; i++ )
{
if( szPic[i] == '9' || szPic[i] == '#' ||
szPic[i] == '$' || szPic[i] == '*' )
{
iWidth++;
iDecimals++;
}
}
}
else
iDecimals = 0;
if( ( iPicFlags & (PF_DEBIT + PF_PARNEG) ) && ( dValue < 0 ) )
dPush = -dValue; /* Always push absolute val */
else
dPush = dValue;
bEmpty = !dPush && ( iPicFlags & PF_EMPTY ); /* Suppress 0 */
PushSymbol ( GetDynSym( "STR" )->pSymbol ); /* 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 !");
}
}
}
}

230
harbour/source/vm/dynsym.c Normal file
View File

@@ -0,0 +1,230 @@
/* Harbour dynamic symbol table management */
#include <extend.h>
#include <ctype.h>
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 ) ) );
}

1992
harbour/source/vm/hvm.c Normal file
View File

File diff suppressed because it is too large Load Diff