Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | /* @(#) pf_words.c 96/12/18 1.10 */ |
2 | /*************************************************************** | |
3 | ** Forth words for PForth based on 'C' | |
4 | ** | |
5 | ** Author: Phil Burk | |
6 | ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom | |
7 | ** | |
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. | |
16 | ** | |
17 | ** | |
18 | ** 941031 rdg fix ffScan() to look for CRs and LFs | |
19 | ** | |
20 | ***************************************************************/ | |
21 | ||
22 | #include "pf_all.h" | |
23 | ||
24 | ||
25 | /*************************************************************** | |
26 | ** Print number in current base to output stream. | |
27 | ** This version does not handle double precision. | |
28 | */ | |
29 | void ffDot( cell_t n ) | |
30 | { | |
31 | MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) ); | |
32 | EMIT(' '); | |
33 | } | |
34 | ||
35 | /*************************************************************** | |
36 | ** Print number in current base to output stream. | |
37 | ** This version does not handle double precision. | |
38 | */ | |
39 | void ffDotHex( cell_t n ) | |
40 | { | |
41 | MSG( ConvertNumberToText( n, 16, FALSE, 1 ) ); | |
42 | EMIT(' '); | |
43 | } | |
44 | ||
45 | /* ( ... --- ... , print stack ) */ | |
46 | void ffDotS( void ) | |
47 | { | |
48 | cell_t *sp; | |
49 | cell_t i, Depth; | |
50 | ||
51 | MSG("Stack<"); | |
52 | MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */ | |
53 | MSG("> "); | |
54 | ||
55 | Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr; | |
56 | sp = gCurrentTask->td_StackBase; | |
57 | ||
58 | if( Depth < 0 ) | |
59 | { | |
60 | MSG("UNDERFLOW!"); | |
61 | } | |
62 | else | |
63 | { | |
64 | for( i=0; i<Depth; i++ ) | |
65 | { | |
66 | /* Print as unsigned if not base 10. */ | |
67 | MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) ); | |
68 | EMIT(' '); | |
69 | } | |
70 | } | |
71 | MSG("\n"); | |
72 | } | |
73 | ||
74 | /* ( addr cnt char -- addr' cnt' , skip leading characters ) */ | |
75 | cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut ) | |
76 | { | |
77 | char *s; | |
78 | ||
79 | s = AddrIn; | |
80 | ||
81 | if( c == BLANK ) | |
82 | { | |
83 | while( ( Cnt > 0 ) && | |
84 | (( *s == BLANK) || ( *s == '\t')) ) | |
85 | { | |
86 | DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt )); | |
87 | s++; | |
88 | Cnt--; | |
89 | } | |
90 | } | |
91 | else | |
92 | { | |
93 | while(( Cnt > 0 ) && ( *s == c )) | |
94 | { | |
95 | DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt )); | |
96 | s++; | |
97 | Cnt--; | |
98 | } | |
99 | } | |
100 | *AddrOut = s; | |
101 | return Cnt; | |
102 | } | |
103 | ||
104 | /* ( addr cnt char -- addr' cnt' , scan for char ) */ | |
105 | cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut ) | |
106 | { | |
107 | char *s; | |
108 | ||
109 | s = AddrIn; | |
110 | ||
111 | if( c == BLANK ) | |
112 | { | |
113 | while(( Cnt > 0 ) && | |
114 | ( *s != BLANK) && | |
115 | ( *s != '\r') && | |
116 | ( *s != '\n') && | |
117 | ( *s != '\t')) | |
118 | { | |
119 | DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt )); | |
120 | s++; | |
121 | Cnt--; | |
122 | } | |
123 | } | |
124 | else | |
125 | { | |
126 | while(( Cnt > 0 ) && ( *s != c )) | |
127 | { | |
128 | DBUGX(("ffScan: %c, %d\n", *s, Cnt )); | |
129 | s++; | |
130 | Cnt--; | |
131 | } | |
132 | } | |
133 | *AddrOut = s; | |
134 | return Cnt; | |
135 | } | |
136 | ||
137 | /*************************************************************** | |
138 | ** Forth equivalent 'C' functions. | |
139 | ***************************************************************/ | |
140 | ||
141 | /* Convert a single digit to the corresponding hex number. */ | |
142 | static cell_t HexDigitToNumber( char c ) | |
143 | { | |
144 | if( (c >= '0') && (c <= '9') ) | |
145 | { | |
146 | return( c - '0' ); | |
147 | } | |
148 | else if ( (c >= 'A') && (c <= 'F') ) | |
149 | { | |
150 | return( c - 'A' + 0x0A ); | |
151 | } | |
152 | else | |
153 | { | |
154 | return -1; | |
155 | } | |
156 | } | |
157 | ||
158 | /* Convert a string to the corresponding number using BASE. */ | |
159 | cell_t ffNumberQ( const char *FWord, cell_t *Num ) | |
160 | { | |
40c6f87f | 161 | cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase; |
8e9db35f PB |
162 | const char *s; |
163 | ||
164 | /* get count */ | |
165 | Len = *FWord++; | |
166 | s = FWord; | |
167 | ||
40c6f87f HE |
168 | switch (*s) { |
169 | case '#': Base = 10; s++; Len--; break; | |
170 | case '$': Base = 16; s++; Len--; break; | |
171 | case '%': Base = 2; s++; Len--; break; | |
172 | case '\'': | |
173 | if( Len == 3 && s[2] == '\'' ) | |
174 | { | |
175 | *Num = s[1]; | |
176 | return NUM_TYPE_SINGLE; | |
177 | } | |
178 | } | |
179 | ||
8e9db35f PB |
180 | /* process initial minus sign */ |
181 | if( *s == '-' ) | |
182 | { | |
183 | Sign = -1; | |
184 | s++; | |
185 | Len--; | |
186 | } | |
187 | ||
188 | for( i=0; i<Len; i++) | |
189 | { | |
190 | n = HexDigitToNumber( *s++ ); | |
40c6f87f | 191 | if( (n < 0) || (n >= Base) ) |
8e9db35f PB |
192 | { |
193 | return NUM_TYPE_BAD; | |
194 | } | |
195 | ||
40c6f87f | 196 | Accum = (Accum * Base) + n; |
8e9db35f PB |
197 | } |
198 | *Num = Accum * Sign; | |
199 | return NUM_TYPE_SINGLE; | |
200 | } | |
201 | ||
202 | /*************************************************************** | |
203 | ** Compiler Support | |
204 | ***************************************************************/ | |
205 | ||
f7548536 HE |
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 | |
208 | * gScratch. | |
209 | */ | |
210 | static char * Word ( char c, int Upcase ) | |
8e9db35f PB |
211 | { |
212 | char *s1,*s2,*s3; | |
213 | cell_t n1, n2, n3; | |
214 | cell_t i, nc; | |
215 | ||
216 | s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN; | |
217 | n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN; | |
218 | n2 = ffSkip( s1, n1, c, &s2 ); | |
f7548536 | 219 | DBUGX(("Word: s2=%c, %d\n", *s2, n2 )); |
8e9db35f | 220 | n3 = ffScan( s2, n2, c, &s3 ); |
f7548536 | 221 | DBUGX(("Word: s3=%c, %d\n", *s3, n3 )); |
8e9db35f PB |
222 | nc = n2-n3; |
223 | if (nc > 0) | |
224 | { | |
225 | gScratch[0] = (char) nc; | |
226 | for( i=0; i<nc; i++ ) | |
227 | { | |
f7548536 | 228 | gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ; |
8e9db35f PB |
229 | } |
230 | } | |
231 | else | |
232 | { | |
233 | ||
234 | gScratch[0] = 0; | |
235 | } | |
236 | gCurrentTask->td_IN += (n1-n3) + 1; | |
237 | return &gScratch[0]; | |
238 | } | |
f7548536 HE |
239 | |
240 | /* ( char -- c-addr , parse word ) */ | |
241 | char * ffWord( char c ) | |
242 | { | |
243 | return Word( c, TRUE ); | |
244 | } | |
245 | ||
246 | /* ( char -- c-addr , parse word, preserving case ) */ | |
247 | char * ffLWord( char c ) | |
248 | { | |
249 | return Word( c, FALSE ); | |
250 | } |