/* @(#) 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, Base
=gVarBase
;
case '#': Base
= 10; s
++; Len
--; break;
case '$': Base
= 16; s
++; Len
--; break;
case '%': Base
= 2; s
++; Len
--; break;
if( Len
== 3 && s
[2] == '\'' )
/* process initial minus sign */
n
= HexDigitToNumber( *s
++ );
if( (n
< 0) || (n
>= Base
) )
Accum
= (Accum
* Base
) + n
;
/***************************************************************
***************************************************************/
/* Skip whitespace, then parse input delimited by C. If UPCASE is true
* convert the word to upper case. The result is stored in
static char * Word ( char c
, int Upcase
)
s1
= gCurrentTask
->td_SourcePtr
+ gCurrentTask
->td_IN
;
n1
= gCurrentTask
->td_SourceNum
- gCurrentTask
->td_IN
;
n2
= ffSkip( s1
, n1
, c
, &s2
);
DBUGX(("Word: s2=%c, %d\n", *s2
, n2
));
n3
= ffScan( s2
, n2
, c
, &s3
);
DBUGX(("Word: s3=%c, %d\n", *s3
, n3
));
gScratch
[i
+1] = Upcase
? pfCharToUpper( s2
[i
] ) : s2
[i
] ;
gCurrentTask
->td_IN
+= (n1
-n3
) + 1;
/* ( char -- c-addr , parse word ) */
/* ( char -- c-addr , parse word, preserving case ) */