V25 with 64-bit support

[pforth] / csrc / pf_words.c

/* @(#) pf_words.c 96/12/18 1.10 */\r
/***************************************************************\r
** Forth words for PForth based on 'C'\r
**\r
** Author: Phil Burk\r
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
**\r
** The pForth software code is dedicated to the public domain,\r
** and any third party may reproduce, distribute and modify\r
** the pForth software code or any derivative works thereof\r
** without any compensation or license.  The pForth software\r
** code is provided on an "as is" basis without any warranty\r
** of any kind, including, without limitation, the implied\r
** warranties of merchantability and fitness for a particular\r
** purpose and their equivalents under the laws of any jurisdiction.\r
**\r
**\r
**	941031	rdg		fix ffScan() to look for CRs and LFs\r
**\r
***************************************************************/\r
\r
#include "pf_all.h"\r
\r
\r
/***************************************************************\r
** Print number in current base to output stream.\r
** This version does not handle double precision.\r
*/\r
void ffDot( cell_t n )\r
{\r
	MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );\r
	EMIT(' ');\r
}\r
\r
/***************************************************************\r
** Print number in current base to output stream.\r
** This version does not handle double precision.\r
*/\r
void ffDotHex( cell_t n )\r
{\r
	MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );\r
	EMIT(' ');\r
}\r
\r
/* ( ... --- ... , print stack ) */\r
void ffDotS( void )\r
{\r
	cell_t *sp;\r
	cell_t i, Depth;\r
\r
	MSG("Stack<");\r
	MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */\r
	MSG("> ");\r
	\r
	Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;\r
	sp = gCurrentTask->td_StackBase;\r
	\r
	if( Depth < 0 )\r
	{\r
		MSG("UNDERFLOW!");\r
	}\r
	else\r
	{\r
		for( i=0; i<Depth; i++ )\r
		{\r
/* Print as unsigned if not base 10. */\r
			MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );\r
			EMIT(' ');\r
		}\r
	}\r
	MSG("\n");\r
}\r
\r
/* ( addr cnt char -- addr' cnt' , skip leading characters ) */\r
cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )\r
{\r
	char *s;\r
	\r
	s = AddrIn;\r
\r
	if( c == BLANK )\r
	{\r
		while( ( Cnt > 0 ) &&\r
			(( *s == BLANK) || ( *s == '\t')) )\r
		{\r
DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));\r
			s++;\r
			Cnt--;\r
		}\r
	}\r
	else\r
	{\r
		while(( Cnt > 0 ) && ( *s == c ))\r
		{\r
DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));\r
		s++;\r
		Cnt--;\r
		}\r
	}\r
	*AddrOut = s;\r
	return Cnt;\r
}\r
\r
/* ( addr cnt char -- addr' cnt' , scan for char ) */\r
cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )\r
{\r
	char *s;\r
	\r
	s = AddrIn;\r
\r
	if( c == BLANK )\r
	{\r
		while(( Cnt > 0 ) &&\r
			( *s != BLANK) &&\r
			( *s != '\r') &&\r
			( *s != '\n') &&\r
			( *s != '\t'))\r
		{\r
DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));\r
			s++;\r
			Cnt--;\r
		}\r
	}\r
	else\r
	{\r
		while(( Cnt > 0 ) && ( *s != c ))\r
		{\r
DBUGX(("ffScan: %c, %d\n", *s, Cnt ));\r
			s++;\r
			Cnt--;\r
		}\r
	}\r
	*AddrOut = s;\r
	return Cnt;\r
}\r
\r
/***************************************************************\r
** Forth equivalent 'C' functions.\r
***************************************************************/\r
\r
/* Convert a single digit to the corresponding hex number. */\r
static cell_t HexDigitToNumber( char c )\r
{	\r
	if( (c >= '0') && (c <= '9') )\r
	{\r
		return( c - '0' );\r
	}\r
	else if ( (c >= 'A') && (c <= 'F') )\r
	{\r
		return( c - 'A' + 0x0A );\r
	}\r
	else\r
	{\r
		return -1;\r
	}\r
}\r
\r
/* Convert a string to the corresponding number using BASE. */\r
cell_t ffNumberQ( const char *FWord, cell_t *Num )\r
{\r
	cell_t Len, i, Accum=0, n, Sign=1;\r
	const char *s;\r
	\r
/* get count */\r
	Len = *FWord++;\r
	s = FWord;\r
\r
/* process initial minus sign */\r
	if( *s == '-' )\r
	{\r
		Sign = -1;\r
		s++;\r
		Len--;\r
	}\r
\r
	for( i=0; i<Len; i++)\r
	{\r
		n = HexDigitToNumber( *s++ );\r
		if( (n < 0) || (n >= gVarBase) )\r
		{\r
			return NUM_TYPE_BAD;\r
		}\r
		\r
		Accum = (Accum * gVarBase) + n;\r
	}\r
	*Num = Accum * Sign;\r
	return NUM_TYPE_SINGLE;\r
}\r
\r
/***************************************************************\r
** Compiler Support\r
***************************************************************/\r
\r
/* ( char -- c-addr , parse word ) */\r
char * ffWord( char c )\r
{\r
	char *s1,*s2,*s3;\r
	cell_t n1, n2, n3;\r
	cell_t i, nc;\r
\r
	s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;\r
	n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;\r
	n2 = ffSkip( s1, n1, c, &s2 );\r
DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));\r
	n3 = ffScan( s2, n2, c, &s3 );\r
DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));\r
	nc = n2-n3;\r
	if (nc > 0)\r
	{\r
		gScratch[0] = (char) nc;\r
		for( i=0; i<nc; i++ )\r
		{\r
			gScratch[i+1] = pfCharToUpper( s2[i] );\r
		}\r
	}\r
	else\r
	{\r
	\r
		gScratch[0] = 0;\r
	}\r
	gCurrentTask->td_IN += (n1-n3) + 1;\r
	return &gScratch[0];\r
}\r