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 | { | |
161 | cell_t Len, i, Accum=0, n, Sign=1; | |
162 | const char *s; | |
163 | ||
164 | /* get count */ | |
165 | Len = *FWord++; | |
166 | s = FWord; | |
167 | ||
168 | /* process initial minus sign */ | |
169 | if( *s == '-' ) | |
170 | { | |
171 | Sign = -1; | |
172 | s++; | |
173 | Len--; | |
174 | } | |
175 | ||
176 | for( i=0; i<Len; i++) | |
177 | { | |
178 | n = HexDigitToNumber( *s++ ); | |
179 | if( (n < 0) || (n >= gVarBase) ) | |
180 | { | |
181 | return NUM_TYPE_BAD; | |
182 | } | |
183 | ||
184 | Accum = (Accum * gVarBase) + n; | |
185 | } | |
186 | *Num = Accum * Sign; | |
187 | return NUM_TYPE_SINGLE; | |
188 | } | |
189 | ||
190 | /*************************************************************** | |
191 | ** Compiler Support | |
192 | ***************************************************************/ | |
193 | ||
194 | /* ( char -- c-addr , parse word ) */ | |
195 | char * ffWord( char c ) | |
196 | { | |
197 | char *s1,*s2,*s3; | |
198 | cell_t n1, n2, n3; | |
199 | cell_t i, nc; | |
200 | ||
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 )); | |
207 | nc = n2-n3; | |
208 | if (nc > 0) | |
209 | { | |
210 | gScratch[0] = (char) nc; | |
211 | for( i=0; i<nc; i++ ) | |
212 | { | |
213 | gScratch[i+1] = pfCharToUpper( s2[i] ); | |
214 | } | |
215 | } | |
216 | else | |
217 | { | |
218 | ||
219 | gScratch[0] = 0; | |
220 | } | |
221 | gCurrentTask->td_IN += (n1-n3) + 1; | |
222 | return &gScratch[0]; | |
223 | } |