1 /* @(#) pf_words.c 96/12/18 1.10 */
\r
2 /***************************************************************
\r
3 ** Forth words for PForth based on 'C'
\r
6 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
\r
8 ** The pForth software code is dedicated to the public domain,
\r
9 ** and any third party may reproduce, distribute and modify
\r
10 ** the pForth software code or any derivative works thereof
\r
11 ** without any compensation or license. The pForth software
\r
12 ** code is provided on an "as is" basis without any warranty
\r
13 ** of any kind, including, without limitation, the implied
\r
14 ** warranties of merchantability and fitness for a particular
\r
15 ** purpose and their equivalents under the laws of any jurisdiction.
\r
18 ** 941031 rdg fix ffScan() to look for CRs and LFs
\r
20 ***************************************************************/
\r
25 /***************************************************************
\r
26 ** Print number in current base to output stream.
\r
27 ** This version does not handle double precision.
\r
29 void ffDot( cell_t n )
\r
31 MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
\r
35 /***************************************************************
\r
36 ** Print number in current base to output stream.
\r
37 ** This version does not handle double precision.
\r
39 void ffDotHex( cell_t n )
\r
41 MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
\r
45 /* ( ... --- ... , print stack ) */
\r
52 MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
\r
55 Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
\r
56 sp = gCurrentTask->td_StackBase;
\r
64 for( i=0; i<Depth; i++ )
\r
66 /* Print as unsigned if not base 10. */
\r
67 MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
\r
74 /* ( addr cnt char -- addr' cnt' , skip leading characters ) */
\r
75 cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
\r
83 while( ( Cnt > 0 ) &&
\r
84 (( *s == BLANK) || ( *s == '\t')) )
\r
86 DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
\r
93 while(( Cnt > 0 ) && ( *s == c ))
\r
95 DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
\r
104 /* ( addr cnt char -- addr' cnt' , scan for char ) */
\r
105 cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
\r
113 while(( Cnt > 0 ) &&
\r
119 DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
\r
126 while(( Cnt > 0 ) && ( *s != c ))
\r
128 DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
\r
137 /***************************************************************
\r
138 ** Forth equivalent 'C' functions.
\r
139 ***************************************************************/
\r
141 /* Convert a single digit to the corresponding hex number. */
\r
142 static cell_t HexDigitToNumber( char c )
\r
144 if( (c >= '0') && (c <= '9') )
\r
148 else if ( (c >= 'A') && (c <= 'F') )
\r
150 return( c - 'A' + 0x0A );
\r
158 /* Convert a string to the corresponding number using BASE. */
\r
159 cell_t ffNumberQ( const char *FWord, cell_t *Num )
\r
161 cell_t Len, i, Accum=0, n, Sign=1;
\r
168 /* process initial minus sign */
\r
176 for( i=0; i<Len; i++)
\r
178 n = HexDigitToNumber( *s++ );
\r
179 if( (n < 0) || (n >= gVarBase) )
\r
181 return NUM_TYPE_BAD;
\r
184 Accum = (Accum * gVarBase) + n;
\r
186 *Num = Accum * Sign;
\r
187 return NUM_TYPE_SINGLE;
\r
190 /***************************************************************
\r
191 ** Compiler Support
\r
192 ***************************************************************/
\r
194 /* ( char -- c-addr , parse word ) */
\r
195 char * ffWord( char c )
\r
201 s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
\r
202 n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
\r
203 n2 = ffSkip( s1, n1, c, &s2 );
\r
204 DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));
\r
205 n3 = ffScan( s2, n2, c, &s3 );
\r
206 DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));
\r
210 gScratch[0] = (char) nc;
\r
211 for( i=0; i<nc; i++ )
\r
213 gScratch[i+1] = pfCharToUpper( s2[i] );
\r
221 gCurrentTask->td_IN += (n1-n3) + 1;
\r
222 return &gScratch[0];
\r