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