1 /* @(#) pf_words.c 96/12/18 1.10 */
2 /***************************************************************
3 ** Forth words for PForth based on 'C'
6 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
8 ** The pForth software code is dedicated to the public domain,
9 ** and any third party may reproduce, distribute and modify
10 ** the pForth software code or any derivative works thereof
11 ** without any compensation or license. The pForth software
12 ** code is provided on an "as is" basis without any warranty
13 ** of any kind, including, without limitation, the implied
14 ** warranties of merchantability and fitness for a particular
15 ** purpose and their equivalents under the laws of any jurisdiction.
18 ** 941031 rdg fix ffScan() to look for CRs and LFs
20 ***************************************************************/
25 /***************************************************************
26 ** Print number in current base to output stream.
27 ** This version does not handle double precision.
29 void ffDot( cell_t n )
31 MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
35 /***************************************************************
36 ** Print number in current base to output stream.
37 ** This version does not handle double precision.
39 void ffDotHex( cell_t n )
41 MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
45 /* ( ... --- ... , print stack ) */
52 MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
55 Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
56 sp = gCurrentTask->td_StackBase;
64 for( i=0; i<Depth; i++ )
66 /* Print as unsigned if not base 10. */
67 MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
74 /* ( addr cnt char -- addr' cnt' , skip leading characters ) */
75 cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
84 (( *s == BLANK) || ( *s == '\t')) )
86 DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
93 while(( Cnt > 0 ) && ( *s == c ))
95 DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
104 /* ( addr cnt char -- addr' cnt' , scan for char ) */
105 cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
119 DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
126 while(( Cnt > 0 ) && ( *s != c ))
128 DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
137 /***************************************************************
138 ** Forth equivalent 'C' functions.
139 ***************************************************************/
141 /* Convert a single digit to the corresponding hex number. */
142 static cell_t HexDigitToNumber( char c )
144 if( (c >= '0') && (c <= '9') )
148 else if ( (c >= 'A') && (c <= 'F') )
150 return( c - 'A' + 0x0A );
158 /* Convert a string to the corresponding number using BASE. */
159 cell_t ffNumberQ( const char *FWord, cell_t *Num )
161 cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase;
169 case '#': Base = 10; s++; Len--; break;
170 case '$': Base = 16; s++; Len--; break;
171 case '%': Base = 2; s++; Len--; break;
173 if( Len == 3 && s[2] == '\'' )
176 return NUM_TYPE_SINGLE;
180 /* process initial minus sign */
188 for( i=0; i<Len; i++)
190 n = HexDigitToNumber( *s++ );
191 if( (n < 0) || (n >= Base) )
196 Accum = (Accum * Base) + n;
199 return NUM_TYPE_SINGLE;
202 /***************************************************************
204 ***************************************************************/
206 /* Skip whitespace, then parse input delimited by C. If UPCASE is true
207 * convert the word to upper case. The result is stored in
210 static char * Word ( char c, int Upcase )
216 s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
217 n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
218 n2 = ffSkip( s1, n1, c, &s2 );
219 DBUGX(("Word: s2=%c, %d\n", *s2, n2 ));
220 n3 = ffScan( s2, n2, c, &s3 );
221 DBUGX(("Word: s3=%c, %d\n", *s3, n3 ));
225 gScratch[0] = (char) nc;
226 for( i=0; i<nc; i++ )
228 gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ;
236 gCurrentTask->td_IN += (n1-n3) + 1;
240 /* ( char -- c-addr , parse word ) */
241 char * ffWord( char c )
243 return Word( c, TRUE );
246 /* ( char -- c-addr , parse word, preserving case ) */
247 char * ffLWord( char c )
249 return Word( c, FALSE );