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 ** Permission to use, copy, modify, and/or distribute this
9 ** software for any purpose with or without fee is hereby granted.
11 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
12 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
13 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
14 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
15 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
16 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
17 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
18 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
21 ** 941031 rdg fix ffScan() to look for CRs and LFs
23 ***************************************************************/
28 /***************************************************************
29 ** Print number in current base to output stream.
30 ** This version does not handle double precision.
32 void ffDot( cell_t n )
34 MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
38 /***************************************************************
39 ** Print number in current base to output stream.
40 ** This version does not handle double precision.
42 void ffDotHex( cell_t n )
44 MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
48 /* ( ... --- ... , print stack ) */
55 MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
58 Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
59 sp = gCurrentTask->td_StackBase;
67 for( i=0; i<Depth; i++ )
69 /* Print as unsigned if not base 10. */
70 MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
77 /* ( addr cnt char -- addr' cnt' , skip leading characters ) */
78 cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
87 (( *s == BLANK) || ( *s == '\t')) )
89 DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
96 while(( Cnt > 0 ) && ( *s == c ))
98 DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
107 /* ( addr cnt char -- addr' cnt' , scan for char ) */
108 cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
122 DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
129 while(( Cnt > 0 ) && ( *s != c ))
131 DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
140 /***************************************************************
141 ** Forth equivalent 'C' functions.
142 ***************************************************************/
144 /* Convert a single digit to the corresponding hex number. */
145 static cell_t HexDigitToNumber( char c )
147 if( (c >= '0') && (c <= '9') )
151 else if ( (c >= 'A') && (c <= 'F') )
153 return( c - 'A' + 0x0A );
161 /* Convert a string to the corresponding number using BASE. */
162 cell_t ffNumberQ( const char *FWord, cell_t *Num )
164 cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase;
172 case '#': Base = 10; s++; Len--; break;
173 case '$': Base = 16; s++; Len--; break;
174 case '%': Base = 2; s++; Len--; break;
176 if( Len == 3 && s[2] == '\'' )
179 return NUM_TYPE_SINGLE;
183 /* process initial minus sign */
191 for( i=0; i<Len; i++)
193 n = HexDigitToNumber( *s++ );
194 if( (n < 0) || (n >= Base) )
199 Accum = (Accum * Base) + n;
202 return NUM_TYPE_SINGLE;
205 /***************************************************************
207 ***************************************************************/
209 /* Skip whitespace, then parse input delimited by C. If UPCASE is true
210 * convert the word to upper case. The result is stored in
213 static char * Word ( char c, int Upcase )
219 s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
220 n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
221 n2 = ffSkip( s1, n1, c, &s2 );
222 DBUGX(("Word: s2=%c, %d\n", *s2, n2 ));
223 n3 = ffScan( s2, n2, c, &s3 );
224 DBUGX(("Word: s3=%c, %d\n", *s3, n3 ));
228 gScratch[0] = (char) nc;
229 for( i=0; i<nc; i++ )
231 gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ;
239 gCurrentTask->td_IN += (n1-n3) + 1;
243 /* ( char -- c-addr , parse word ) */
244 char * ffWord( char c )
246 return Word( c, TRUE );
249 /* ( char -- c-addr , parse word, preserving case ) */
250 char * ffLWord( char c )
252 return Word( c, FALSE );