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;
168 /* process initial minus sign */
176 for( i=0; i<Len; i++)
178 n = HexDigitToNumber( *s++ );
179 if( (n < 0) || (n >= gVarBase) )
184 Accum = (Accum * gVarBase) + n;
187 return NUM_TYPE_SINGLE;
190 /***************************************************************
192 ***************************************************************/
194 /* ( char -- c-addr , parse word ) */
195 char * ffWord( char c )
201 s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
202 n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
203 n2 = ffSkip( s1, n1, c, &s2 );
204 DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));
205 n3 = ffScan( s2, n2, c, &s3 );
206 DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));
210 gScratch[0] = (char) nc;
211 for( i=0; i<nc; i++ )
213 gScratch[i+1] = pfCharToUpper( s2[i] );
221 gCurrentTask->td_IN += (n1-n3) + 1;