bb6b2dcd |
1 | /* @(#) pf_inner.c 98/03/16 1.7 */\r |
2 | /***************************************************************\r |
3 | ** Inner Interpreter for Forth based on 'C'\r |
4 | **\r |
5 | ** Author: Phil Burk\r |
6 | ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r |
7 | **\r |
8 | ** The pForth software code is dedicated to the public domain,\r |
9 | ** and any third party may reproduce, distribute and modify\r |
10 | ** the pForth software code or any derivative works thereof\r |
11 | ** without any compensation or license. The pForth software\r |
12 | ** code is provided on an "as is" basis without any warranty\r |
13 | ** of any kind, including, without limitation, the implied\r |
14 | ** warranties of merchantability and fitness for a particular\r |
15 | ** purpose and their equivalents under the laws of any jurisdiction.\r |
16 | **\r |
17 | ****************************************************************\r |
18 | **\r |
19 | ** 940502 PLB Creation.\r |
20 | ** 940505 PLB More macros.\r |
21 | ** 940509 PLB Moved all stack stuff into pfCatch.\r |
22 | ** 941014 PLB Converted to flat secondary strusture.\r |
23 | ** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH, \r |
24 | ** and ID_HERE for armcc\r |
25 | ** 941130 PLB Made w@ unsigned\r |
26 | **\r |
27 | ***************************************************************/\r |
28 | \r |
29 | #include "pf_all.h"\r |
acc3c8bd |
30 | \r |
31 | #ifdef WIN32\r |
bb6b2dcd |
32 | #include <crtdbg.h>\r |
acc3c8bd |
33 | #endif\r |
bb6b2dcd |
34 | \r |
35 | #define SYSTEM_LOAD_FILE "system.fth"\r |
36 | \r |
37 | /***************************************************************\r |
38 | ** Macros for data stack access.\r |
39 | ** TOS is cached in a register in pfCatch.\r |
40 | ***************************************************************/\r |
41 | \r |
42 | #define STKPTR (DataStackPtr)\r |
43 | #define M_POP (*(STKPTR++))\r |
1cb310e6 |
44 | #define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}\r |
bb6b2dcd |
45 | #define M_STACK(n) (STKPTR[n])\r |
46 | \r |
47 | #define TOS (TopOfStack)\r |
48 | #define PUSH_TOS M_PUSH(TOS)\r |
49 | #define M_DUP PUSH_TOS;\r |
50 | #define M_DROP { TOS = M_POP; }\r |
51 | \r |
52 | \r |
53 | /***************************************************************\r |
54 | ** Macros for Floating Point stack access.\r |
55 | ***************************************************************/\r |
56 | #ifdef PF_SUPPORT_FP\r |
57 | #define FP_STKPTR (FloatStackPtr)\r |
58 | #define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)\r |
59 | #define M_FP_POP (*(FP_STKPTR++))\r |
60 | #define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}\r |
61 | #define M_FP_STACK(n) (FP_STKPTR[n])\r |
62 | \r |
63 | #define FP_TOS (fpTopOfStack)\r |
64 | #define PUSH_FP_TOS M_FP_PUSH(FP_TOS)\r |
65 | #define M_FP_DUP PUSH_FP_TOS;\r |
66 | #define M_FP_DROP { FP_TOS = M_FP_POP; }\r |
67 | #endif\r |
68 | \r |
69 | /***************************************************************\r |
70 | ** Macros for return stack access.\r |
71 | ***************************************************************/\r |
72 | \r |
73 | #define TORPTR (ReturnStackPtr)\r |
74 | #define M_R_DROP {TORPTR++;}\r |
75 | #define M_R_POP (*(TORPTR++))\r |
76 | #define M_R_PICK(n) (TORPTR[n])\r |
1cb310e6 |
77 | #define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}\r |
bb6b2dcd |
78 | \r |
79 | /***************************************************************\r |
80 | ** Misc Forth macros\r |
81 | ***************************************************************/\r |
82 | \r |
1cb310e6 |
83 | #define M_BRANCH { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }\r |
bb6b2dcd |
84 | \r |
85 | /* Cache top of data stack like in JForth. */\r |
86 | #ifdef PF_SUPPORT_FP\r |
87 | #define LOAD_REGISTERS \\r |
88 | { \\r |
89 | STKPTR = gCurrentTask->td_StackPtr; \\r |
90 | TOS = M_POP; \\r |
91 | FP_STKPTR = gCurrentTask->td_FloatStackPtr; \\r |
92 | FP_TOS = M_FP_POP; \\r |
93 | TORPTR = gCurrentTask->td_ReturnPtr; \\r |
94 | }\r |
95 | \r |
96 | #define SAVE_REGISTERS \\r |
97 | { \\r |
98 | gCurrentTask->td_ReturnPtr = TORPTR; \\r |
99 | M_PUSH( TOS ); \\r |
100 | gCurrentTask->td_StackPtr = STKPTR; \\r |
101 | M_FP_PUSH( FP_TOS ); \\r |
102 | gCurrentTask->td_FloatStackPtr = FP_STKPTR; \\r |
103 | }\r |
104 | \r |
105 | #else\r |
106 | /* Cache top of data stack like in JForth. */\r |
107 | #define LOAD_REGISTERS \\r |
108 | { \\r |
109 | STKPTR = gCurrentTask->td_StackPtr; \\r |
110 | TOS = M_POP; \\r |
111 | TORPTR = gCurrentTask->td_ReturnPtr; \\r |
112 | }\r |
113 | \r |
114 | #define SAVE_REGISTERS \\r |
115 | { \\r |
116 | gCurrentTask->td_ReturnPtr = TORPTR; \\r |
117 | M_PUSH( TOS ); \\r |
118 | gCurrentTask->td_StackPtr = STKPTR; \\r |
119 | }\r |
120 | #endif\r |
121 | \r |
122 | #define M_DOTS \\r |
123 | SAVE_REGISTERS; \\r |
124 | ffDotS( ); \\r |
125 | LOAD_REGISTERS;\r |
126 | \r |
1cb310e6 |
127 | #define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }\r |
bb6b2dcd |
128 | \r |
129 | #ifdef PF_SUPPORT_FP\r |
130 | #define M_THROW(err) \\r |
131 | { \\r |
132 | ExceptionReturnCode = (ThrowCode)(err); \\r |
133 | TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \\r |
134 | STKPTR = InitialDataStack; \\r |
135 | FP_STKPTR = InitialFloatStack; \\r |
136 | }\r |
137 | #else\r |
138 | #define M_THROW(err) \\r |
139 | { \\r |
140 | ExceptionReturnCode = (err); \\r |
141 | TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \\r |
142 | STKPTR = InitialDataStack; \\r |
143 | }\r |
144 | #endif\r |
145 | \r |
146 | /***************************************************************\r |
147 | ** Other macros\r |
148 | ***************************************************************/\r |
149 | \r |
150 | #define BINARY_OP( op ) { TOS = M_POP op TOS; }\r |
151 | #define endcase break\r |
152 | \r |
153 | #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)\r |
154 | #define TRACENAMES /* no names */\r |
155 | #else\r |
156 | /* Display name of executing routine. */\r |
1cb310e6 |
157 | static void TraceNames( ExecToken Token, cell_t Level )\r |
bb6b2dcd |
158 | {\r |
159 | char *DebugName;\r |
1cb310e6 |
160 | cell_t i;\r |
bb6b2dcd |
161 | \r |
162 | if( ffTokenToName( Token, &DebugName ) )\r |
163 | {\r |
1cb310e6 |
164 | cell_t NumSpaces;\r |
bb6b2dcd |
165 | if( gCurrentTask->td_OUT > 0 ) EMIT_CR;\r |
166 | EMIT( '>' );\r |
167 | for( i=0; i<Level; i++ )\r |
168 | {\r |
169 | MSG( " " );\r |
170 | }\r |
171 | TypeName( DebugName );\r |
172 | /* Space out to column N then .S */\r |
173 | NumSpaces = 30 - gCurrentTask->td_OUT;\r |
174 | for( i=0; i < NumSpaces; i++ )\r |
175 | {\r |
176 | EMIT( ' ' );\r |
177 | }\r |
178 | ffDotS();\r |
179 | /* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */\r |
180 | \r |
181 | }\r |
182 | else\r |
183 | {\r |
184 | MSG_NUM_H("Couldn't find Name for ", Token);\r |
185 | }\r |
186 | }\r |
187 | \r |
188 | #define TRACENAMES \\r |
189 | if( (gVarTraceLevel > Level) ) \\r |
190 | { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }\r |
191 | #endif /* PF_NO_SHELL */\r |
192 | \r |
193 | /* Use local copy of CODE_BASE for speed. */\r |
1cb310e6 |
194 | #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))\r |
bb6b2dcd |
195 | \r |
acc3c8bd |
196 | static const char *pfSelectFileModeCreate( int fam );\r |
197 | static const char *pfSelectFileModeOpen( int fam );\r |
198 | \r |
199 | /**************************************************************/\r |
200 | static const char *pfSelectFileModeCreate( int fam )\r |
201 | {\r |
202 | const char *famText = NULL;\r |
203 | switch( fam )\r |
204 | {\r |
205 | case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):\r |
206 | famText = PF_FAM_BIN_CREATE_WO;\r |
207 | break;\r |
208 | case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):\r |
209 | famText = PF_FAM_BIN_CREATE_RW;\r |
210 | break;\r |
211 | case PF_FAM_WRITE_ONLY:\r |
212 | famText = PF_FAM_CREATE_WO;\r |
213 | break;\r |
214 | case PF_FAM_READ_WRITE:\r |
215 | famText = PF_FAM_CREATE_RW;\r |
216 | break;\r |
217 | default:\r |
218 | famText = "illegal";\r |
219 | break;\r |
220 | }\r |
221 | return famText;\r |
222 | }\r |
223 | \r |
bb6b2dcd |
224 | /**************************************************************/\r |
acc3c8bd |
225 | static const char *pfSelectFileModeOpen( int fam )\r |
bb6b2dcd |
226 | {\r |
acc3c8bd |
227 | const char *famText = NULL;\r |
bb6b2dcd |
228 | switch( fam )\r |
229 | {\r |
230 | case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG):\r |
231 | famText = PF_FAM_BIN_OPEN_RO;\r |
232 | break;\r |
233 | case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):\r |
234 | famText = PF_FAM_BIN_CREATE_WO;\r |
235 | break;\r |
236 | case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):\r |
237 | famText = PF_FAM_BIN_OPEN_RW;\r |
238 | break;\r |
239 | case PF_FAM_READ_ONLY:\r |
240 | famText = PF_FAM_OPEN_RO;\r |
241 | break;\r |
242 | case PF_FAM_WRITE_ONLY:\r |
243 | famText = PF_FAM_CREATE_WO;\r |
244 | break;\r |
245 | case PF_FAM_READ_WRITE:\r |
246 | default:\r |
247 | famText = PF_FAM_OPEN_RW;\r |
248 | break;\r |
249 | }\r |
250 | return famText;\r |
251 | }\r |
252 | \r |
253 | /**************************************************************/\r |
254 | int pfCatch( ExecToken XT )\r |
255 | {\r |
1cb310e6 |
256 | register cell_t TopOfStack; /* Cache for faster execution. */\r |
257 | register cell_t *DataStackPtr;\r |
258 | register cell_t *ReturnStackPtr;\r |
259 | register cell_t *InsPtr = NULL;\r |
260 | register cell_t Token;\r |
261 | cell_t Scratch;\r |
bb6b2dcd |
262 | \r |
263 | #ifdef PF_SUPPORT_FP\r |
264 | PF_FLOAT fpTopOfStack;\r |
265 | PF_FLOAT *FloatStackPtr;\r |
266 | PF_FLOAT fpScratch;\r |
267 | PF_FLOAT fpTemp;\r |
268 | PF_FLOAT *InitialFloatStack;\r |
269 | #endif\r |
270 | #ifdef PF_SUPPORT_TRACE\r |
1cb310e6 |
271 | cell_t Level = 0;\r |
bb6b2dcd |
272 | #endif\r |
1cb310e6 |
273 | cell_t *LocalsPtr = NULL;\r |
274 | cell_t Temp;\r |
275 | cell_t *InitialReturnStack;\r |
276 | cell_t *InitialDataStack;\r |
277 | cell_t FakeSecondary[2];\r |
bb6b2dcd |
278 | char *CharPtr;\r |
1cb310e6 |
279 | cell_t *CellPtr;\r |
bb6b2dcd |
280 | FileStream *FileID;\r |
1cb310e6 |
281 | uint8_t *CodeBase = CODE_BASE;\r |
bb6b2dcd |
282 | ThrowCode ExceptionReturnCode = 0;\r |
283 | \r |
284 | /* FIXME\r |
285 | gExecutionDepth += 1;\r |
286 | PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));\r |
287 | */\r |
288 | \r |
289 | /*\r |
290 | ** Initialize FakeSecondary this way to avoid having stuff in the data section,\r |
291 | ** which is not supported for some embedded system loaders.\r |
292 | */\r |
293 | FakeSecondary[0] = 0;\r |
294 | FakeSecondary[1] = ID_EXIT; /* For EXECUTE */\r |
295 | \r |
296 | /* Move data from task structure to registers for speed. */\r |
297 | LOAD_REGISTERS;\r |
298 | \r |
299 | /* Save initial stack depths for THROW */\r |
300 | InitialReturnStack = TORPTR;\r |
301 | InitialDataStack = STKPTR ;\r |
302 | #ifdef PF_SUPPORT_FP\r |
303 | InitialFloatStack = FP_STKPTR;\r |
304 | #endif\r |
305 | \r |
306 | Token = XT;\r |
307 | \r |
308 | do\r |
309 | {\r |
310 | DBUG(("pfCatch: Token = 0x%x\n", Token ));\r |
311 | \r |
312 | /* --------------------------------------------------------------- */\r |
313 | /* If secondary, thread down code tree until we hit a primitive. */\r |
314 | while( !IsTokenPrimitive( Token ) )\r |
315 | {\r |
316 | #ifdef PF_SUPPORT_TRACE\r |
317 | if((gVarTraceFlags & TRACE_INNER) )\r |
318 | {\r |
319 | MSG("pfCatch: Secondary Token = 0x");\r |
320 | ffDotHex(Token);\r |
321 | MSG_NUM_H(", InsPtr = 0x", InsPtr);\r |
322 | }\r |
323 | TRACENAMES;\r |
324 | #endif\r |
325 | \r |
326 | /* Save IP on return stack like a JSR. */\r |
327 | M_R_PUSH( InsPtr );\r |
328 | \r |
329 | /* Convert execution token to absolute address. */\r |
1cb310e6 |
330 | InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );\r |
bb6b2dcd |
331 | \r |
332 | /* Fetch token at IP. */\r |
1cb310e6 |
333 | Token = READ_CELL_DIC(InsPtr++);\r |
bb6b2dcd |
334 | \r |
335 | #ifdef PF_SUPPORT_TRACE\r |
336 | /* Bump level for trace display */\r |
337 | Level++;\r |
338 | #endif\r |
339 | }\r |
340 | \r |
341 | \r |
342 | #ifdef PF_SUPPORT_TRACE\r |
343 | TRACENAMES;\r |
344 | #endif\r |
345 | \r |
346 | /* Execute primitive Token. */\r |
347 | switch( Token )\r |
348 | {\r |
349 | \r |
350 | /* Pop up a level in Forth inner interpreter.\r |
351 | ** Used to implement semicolon.\r |
352 | ** Put first in switch because ID_EXIT==0 */\r |
353 | case ID_EXIT:\r |
1cb310e6 |
354 | InsPtr = ( cell_t *) M_R_POP;\r |
bb6b2dcd |
355 | #ifdef PF_SUPPORT_TRACE\r |
356 | Level--;\r |
357 | #endif\r |
358 | endcase;\r |
359 | \r |
360 | case ID_1MINUS: TOS--; endcase;\r |
361 | \r |
362 | case ID_1PLUS: TOS++; endcase;\r |
363 | \r |
364 | #ifndef PF_NO_SHELL\r |
365 | case ID_2LITERAL:\r |
366 | ff2Literal( TOS, M_POP );\r |
367 | M_DROP;\r |
368 | endcase;\r |
369 | #endif /* !PF_NO_SHELL */\r |
370 | \r |
371 | case ID_2LITERAL_P:\r |
372 | /* hi part stored first, put on top of stack */\r |
373 | PUSH_TOS;\r |
1cb310e6 |
374 | TOS = READ_CELL_DIC(InsPtr++);\r |
375 | M_PUSH(READ_CELL_DIC(InsPtr++));\r |
bb6b2dcd |
376 | endcase;\r |
377 | \r |
378 | case ID_2MINUS: TOS -= 2; endcase;\r |
379 | \r |
380 | case ID_2PLUS: TOS += 2; endcase;\r |
381 | \r |
382 | \r |
383 | case ID_2OVER: /* ( a b c d -- a b c d a b ) */\r |
384 | PUSH_TOS;\r |
385 | Scratch = M_STACK(3);\r |
386 | M_PUSH(Scratch);\r |
387 | TOS = M_STACK(3);\r |
388 | endcase;\r |
389 | \r |
390 | case ID_2SWAP: /* ( a b c d -- c d a b ) */\r |
391 | Scratch = M_STACK(0); /* c */\r |
392 | M_STACK(0) = M_STACK(2); /* a */\r |
393 | M_STACK(2) = Scratch; /* c */\r |
394 | Scratch = TOS; /* d */\r |
395 | TOS = M_STACK(1); /* b */\r |
396 | M_STACK(1) = Scratch; /* d */\r |
397 | endcase;\r |
398 | \r |
399 | case ID_2DUP: /* ( a b -- a b a b ) */\r |
400 | PUSH_TOS;\r |
401 | Scratch = M_STACK(1);\r |
402 | M_PUSH(Scratch);\r |
403 | endcase;\r |
404 | \r |
405 | case ID_2_R_FETCH:\r |
406 | PUSH_TOS;\r |
407 | M_PUSH( (*(TORPTR+1)) );\r |
408 | TOS = (*(TORPTR));\r |
409 | endcase;\r |
410 | \r |
411 | case ID_2_R_FROM:\r |
412 | PUSH_TOS;\r |
413 | TOS = M_R_POP;\r |
414 | M_PUSH( M_R_POP );\r |
415 | endcase;\r |
416 | \r |
417 | case ID_2_TO_R:\r |
418 | M_R_PUSH( M_POP );\r |
419 | M_R_PUSH( TOS );\r |
420 | M_DROP;\r |
421 | endcase;\r |
422 | \r |
423 | case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */\r |
424 | CharPtr = (char *) M_POP;\r |
425 | TOS = ioAccept( CharPtr, TOS );\r |
426 | endcase;\r |
427 | \r |
428 | #ifndef PF_NO_SHELL\r |
429 | case ID_ALITERAL:\r |
430 | ffALiteral( ABS_TO_CODEREL(TOS) );\r |
431 | M_DROP;\r |
432 | endcase;\r |
433 | #endif /* !PF_NO_SHELL */\r |
434 | \r |
435 | case ID_ALITERAL_P:\r |
436 | PUSH_TOS;\r |
1cb310e6 |
437 | TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );\r |
bb6b2dcd |
438 | endcase;\r |
439 | \r |
440 | /* Allocate some extra and put validation identifier at base */\r |
441 | #define PF_MEMORY_VALIDATOR (0xA81B4D69)\r |
442 | case ID_ALLOCATE:\r |
443 | /* Allocate at least one cell's worth because we clobber first cell. */\r |
1cb310e6 |
444 | if ( TOS < sizeof(cell_t) )\r |
bb6b2dcd |
445 | {\r |
1cb310e6 |
446 | Temp = sizeof(cell_t);\r |
bb6b2dcd |
447 | }\r |
448 | else\r |
449 | {\r |
450 | Temp = TOS;\r |
451 | }\r |
452 | /* Allocate extra cells worth because we store validation info. */\r |
1cb310e6 |
453 | CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );\r |
bb6b2dcd |
454 | if( CellPtr )\r |
455 | {\r |
456 | /* This was broken into two steps because different compilers incremented\r |
457 | ** CellPtr before or after the XOR step. */\r |
1cb310e6 |
458 | Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;\r |
bb6b2dcd |
459 | *CellPtr++ = Temp;\r |
1cb310e6 |
460 | M_PUSH( (cell_t) CellPtr );\r |
bb6b2dcd |
461 | TOS = 0;\r |
462 | }\r |
463 | else\r |
464 | {\r |
465 | M_PUSH( 0 );\r |
466 | TOS = -1; /* FIXME Fix error code. */\r |
467 | }\r |
468 | endcase;\r |
469 | \r |
470 | case ID_AND: BINARY_OP( & ); endcase;\r |
471 | \r |
472 | case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */\r |
473 | \r |
474 | case ID_BODY_OFFSET:\r |
475 | PUSH_TOS;\r |
476 | TOS = CREATE_BODY_OFFSET;\r |
477 | endcase;\r |
478 | \r |
479 | /* Branch is followed by an offset relative to address of offset. */\r |
480 | case ID_BRANCH:\r |
481 | DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));\r |
482 | M_BRANCH;\r |
483 | DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));\r |
484 | endcase;\r |
485 | \r |
486 | case ID_BYE:\r |
487 | M_THROW( THROW_BYE );\r |
488 | endcase;\r |
489 | \r |
490 | case ID_BAIL:\r |
491 | MSG("Emergency exit.\n");\r |
492 | EXIT(1);\r |
493 | endcase;\r |
494 | \r |
495 | case ID_CATCH:\r |
496 | Scratch = TOS;\r |
497 | TOS = M_POP;\r |
498 | SAVE_REGISTERS;\r |
499 | Scratch = pfCatch( Scratch );\r |
500 | LOAD_REGISTERS;\r |
501 | M_PUSH( TOS );\r |
502 | TOS = Scratch;\r |
503 | endcase;\r |
504 | \r |
505 | case ID_CALL_C:\r |
506 | SAVE_REGISTERS;\r |
1cb310e6 |
507 | Scratch = READ_CELL_DIC(InsPtr++);\r |
bb6b2dcd |
508 | CallUserFunction( Scratch & 0xFFFF,\r |
509 | (Scratch >> 31) & 1,\r |
510 | (Scratch >> 24) & 0x7F );\r |
511 | LOAD_REGISTERS;\r |
512 | endcase;\r |
1cb310e6 |
513 | \r |
514 | /* Support 32/64 bit operation. */\r |
515 | case ID_CELL:\r |
516 | M_PUSH( TOS );\r |
517 | TOS = sizeof(cell_t);\r |
518 | endcase;\r |
519 | \r |
520 | case ID_CELLS:\r |
521 | TOS = TOS * sizeof(cell_t);\r |
522 | endcase;\r |
523 | \r |
524 | case ID_CFETCH: TOS = *((uint8_t *) TOS); endcase;\r |
bb6b2dcd |
525 | \r |
526 | case ID_CMOVE: /* ( src dst n -- ) */\r |
527 | {\r |
528 | register char *DstPtr = (char *) M_POP; /* dst */\r |
529 | CharPtr = (char *) M_POP; /* src */\r |
1cb310e6 |
530 | for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )\r |
bb6b2dcd |
531 | {\r |
532 | *DstPtr++ = *CharPtr++;\r |
533 | }\r |
534 | M_DROP;\r |
535 | }\r |
536 | endcase;\r |
537 | \r |
538 | case ID_CMOVE_UP: /* ( src dst n -- ) */\r |
539 | {\r |
540 | register char *DstPtr = ((char *) M_POP) + TOS; /* dst */\r |
541 | CharPtr = ((char *) M_POP) + TOS;; /* src */\r |
1cb310e6 |
542 | for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )\r |
bb6b2dcd |
543 | {\r |
544 | *(--DstPtr) = *(--CharPtr);\r |
545 | }\r |
546 | M_DROP;\r |
547 | }\r |
548 | endcase;\r |
549 | \r |
550 | #ifndef PF_NO_SHELL\r |
551 | case ID_COLON:\r |
552 | SAVE_REGISTERS;\r |
553 | ffColon( );\r |
554 | LOAD_REGISTERS;\r |
555 | endcase;\r |
556 | case ID_COLON_P: /* ( $name xt -- ) */\r |
557 | CreateDicEntry( TOS, (char *) M_POP, 0 );\r |
558 | M_DROP;\r |
559 | endcase;\r |
560 | #endif /* !PF_NO_SHELL */\r |
561 | \r |
562 | case ID_COMPARE:\r |
563 | {\r |
564 | const char *s1, *s2;\r |
1cb310e6 |
565 | cell_t len1;\r |
bb6b2dcd |
566 | s2 = (const char *) M_POP;\r |
567 | len1 = M_POP;\r |
568 | s1 = (const char *) M_POP;\r |
569 | TOS = ffCompare( s1, len1, s2, TOS );\r |
570 | }\r |
571 | endcase;\r |
572 | \r |
573 | /* ( a b -- flag , Comparisons ) */\r |
574 | case ID_COMP_EQUAL:\r |
575 | TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;\r |
576 | endcase;\r |
577 | case ID_COMP_NOT_EQUAL:\r |
578 | TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;\r |
579 | endcase;\r |
580 | case ID_COMP_GREATERTHAN:\r |
581 | TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;\r |
582 | endcase;\r |
583 | case ID_COMP_LESSTHAN:\r |
584 | TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ;\r |
585 | endcase;\r |
586 | case ID_COMP_U_GREATERTHAN:\r |
1cb310e6 |
587 | TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;\r |
bb6b2dcd |
588 | endcase;\r |
589 | case ID_COMP_U_LESSTHAN:\r |
1cb310e6 |
590 | TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;\r |
bb6b2dcd |
591 | endcase;\r |
592 | case ID_COMP_ZERO_EQUAL:\r |
593 | TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;\r |
594 | endcase;\r |
595 | case ID_COMP_ZERO_NOT_EQUAL:\r |
596 | TOS = ( TOS != 0 ) ? FTRUE : FALSE ;\r |
597 | endcase;\r |
598 | case ID_COMP_ZERO_GREATERTHAN:\r |
599 | TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;\r |
600 | endcase;\r |
601 | case ID_COMP_ZERO_LESSTHAN:\r |
602 | TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;\r |
603 | endcase;\r |
604 | \r |
605 | case ID_CR:\r |
606 | EMIT_CR;\r |
607 | endcase;\r |
608 | \r |
609 | #ifndef PF_NO_SHELL\r |
610 | case ID_CREATE:\r |
611 | SAVE_REGISTERS;\r |
612 | ffCreate();\r |
613 | LOAD_REGISTERS;\r |
614 | endcase;\r |
615 | #endif /* !PF_NO_SHELL */\r |
616 | \r |
617 | case ID_CREATE_P:\r |
618 | PUSH_TOS;\r |
619 | /* Put address of body on stack. Insptr points after code start. */\r |
1cb310e6 |
620 | TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );\r |
bb6b2dcd |
621 | endcase;\r |
622 | \r |
623 | case ID_CSTORE: /* ( c caddr -- ) */\r |
1cb310e6 |
624 | *((uint8_t *) TOS) = (uint8_t) M_POP;\r |
bb6b2dcd |
625 | M_DROP;\r |
626 | endcase;\r |
627 | \r |
628 | /* Double precision add. */\r |
629 | case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ \r |
630 | {\r |
1cb310e6 |
631 | register ucell_t ah,al,bl,sh,sl;\r |
bb6b2dcd |
632 | #define bh TOS\r |
633 | bl = M_POP;\r |
634 | ah = M_POP;\r |
635 | al = M_POP;\r |
636 | sh = 0;\r |
637 | sl = al + bl;\r |
638 | if( sl < bl ) sh = 1; /* Carry */\r |
639 | sh += ah + bh;\r |
640 | M_PUSH( sl );\r |
641 | TOS = sh;\r |
642 | #undef bh\r |
643 | }\r |
644 | endcase;\r |
645 | \r |
646 | /* Double precision subtract. */\r |
647 | case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */ \r |
648 | {\r |
1cb310e6 |
649 | register ucell_t ah,al,bl,sh,sl;\r |
bb6b2dcd |
650 | #define bh TOS\r |
651 | bl = M_POP;\r |
652 | ah = M_POP;\r |
653 | al = M_POP;\r |
654 | sh = 0;\r |
655 | sl = al - bl;\r |
656 | if( al < bl ) sh = 1; /* Borrow */\r |
657 | sh = ah - bh - sh;\r |
658 | M_PUSH( sl );\r |
659 | TOS = sh;\r |
660 | #undef bh\r |
661 | }\r |
662 | endcase;\r |
663 | \r |
664 | /* Perform 32*32 bit multiply for 64 bit result, by factoring into 16 bit quantities. */\r |
665 | /* Using an improved algorithm suggested by Steve Green. */\r |
1cb310e6 |
666 | case ID_D_UMTIMES: /* UM* ( a b -- pl ph ) */ \r |
bb6b2dcd |
667 | {\r |
1cb310e6 |
668 | ucell_t ahi, alo, bhi, blo, temp;\r |
669 | ucell_t pl, ph;\r |
bb6b2dcd |
670 | /* Get values from stack. */\r |
671 | ahi = M_POP;\r |
672 | bhi = TOS;\r |
673 | /* Break into hi and lo 16 bit parts. */\r |
674 | alo = ahi & 0xFFFF;\r |
675 | ahi = ahi>>16;\r |
676 | blo = bhi & 0xFFFF;\r |
677 | bhi = bhi>>16;\r |
678 | ph = 0;\r |
679 | /* ahi * bhi */\r |
680 | pl = ahi * bhi;\r |
681 | ph = pl >> 16; /* shift 64 bit value by 16 */\r |
682 | pl = pl << 16;\r |
683 | /* ahi * blo */\r |
684 | temp = ahi * blo;\r |
685 | pl += temp;\r |
686 | if( pl < temp ) ph += 1; /* Carry */\r |
687 | /* alo * bhi */\r |
688 | temp = alo * bhi;\r |
689 | pl += temp;\r |
690 | if( pl < temp ) ph += 1; /* Carry */\r |
691 | ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */\r |
692 | pl = pl << 16;\r |
693 | /* alo * blo */\r |
694 | temp = alo * blo;\r |
695 | pl += temp;\r |
696 | if( pl < temp ) ph += 1; /* Carry */\r |
697 | \r |
698 | M_PUSH( pl );\r |
699 | TOS = ph;\r |
700 | }\r |
701 | endcase;\r |
702 | \r |
703 | /* Perform 32*32 bit multiply for 64 bit result, using shift and add. */\r |
704 | case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ \r |
705 | {\r |
1cb310e6 |
706 | cell_t a,b;\r |
707 | ucell_t ap,bp, ahi, alo, bhi, blo, temp;\r |
708 | ucell_t pl, ph;\r |
bb6b2dcd |
709 | /* Get values from stack. */\r |
710 | a = M_POP;\r |
711 | b = TOS;\r |
712 | ap = (a < 0) ? -a : a ; /* Positive A */\r |
713 | bp = (b < 0) ? -b : b ; /* Positive B */\r |
714 | /* Break into hi and lo 16 bit parts. */\r |
715 | alo = ap & 0xFFFF;\r |
716 | ahi = ap>>16;\r |
717 | blo = bp & 0xFFFF;\r |
718 | bhi = bp>>16;\r |
719 | ph = 0;\r |
720 | /* ahi * bhi */\r |
721 | pl = ahi * bhi;\r |
722 | ph = pl >> 16; /* shift 64 bit value by 16 */\r |
723 | pl = pl << 16;\r |
724 | /* ahi * blo */\r |
725 | temp = ahi * blo;\r |
726 | pl += temp;\r |
727 | if( pl < temp ) ph += 1; /* Carry */\r |
728 | /* alo * bhi */\r |
729 | temp = alo * bhi;\r |
730 | pl += temp;\r |
731 | if( pl < temp ) ph += 1; /* Carry */\r |
732 | ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */\r |
733 | pl = pl << 16;\r |
734 | /* alo * blo */\r |
735 | temp = alo * blo;\r |
736 | pl += temp;\r |
737 | if( pl < temp ) ph += 1; /* Carry */\r |
738 | \r |
739 | /* Negate product if one operand negative. */\r |
740 | if( ((a ^ b) & 0x80000000) )\r |
741 | {\r |
742 | pl = 0-pl;\r |
743 | if( pl & 0x80000000 )\r |
744 | {\r |
745 | ph = -1 - ph; /* Borrow */\r |
746 | }\r |
747 | else\r |
748 | {\r |
749 | ph = 0 - ph;\r |
750 | }\r |
751 | }\r |
752 | \r |
753 | M_PUSH( pl );\r |
754 | TOS = ph;\r |
755 | }\r |
756 | endcase;\r |
757 | \r |
758 | #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )\r |
759 | /* Perform 64/32 bit divide for 32 bit result, using shift and subtract. */\r |
760 | case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */ \r |
761 | {\r |
1cb310e6 |
762 | ucell_t ah,al, q,di, bl,bh, sl,sh;\r |
bb6b2dcd |
763 | ah = M_POP;\r |
764 | al = M_POP;\r |
765 | bh = TOS;\r |
766 | bl = 0;\r |
767 | q = 0;\r |
768 | for( di=0; di<32; di++ )\r |
769 | {\r |
770 | if( !DULT(al,ah,bl,bh) )\r |
771 | {\r |
772 | sh = 0;\r |
773 | sl = al - bl;\r |
774 | if( al < bl ) sh = 1; /* Borrow */\r |
775 | sh = ah - bh - sh;\r |
776 | ah = sh;\r |
777 | al = sl;\r |
778 | q |= 1;\r |
779 | }\r |
780 | q = q << 1;\r |
781 | bl = (bl >> 1) | (bh << 31);\r |
782 | bh = bh >> 1;\r |
783 | }\r |
784 | if( !DULT(al,ah,bl,bh) )\r |
785 | {\r |
786 | \r |
787 | al = al - bl;\r |
788 | q |= 1;\r |
789 | }\r |
790 | M_PUSH( al ); /* rem */\r |
791 | TOS = q;\r |
792 | }\r |
793 | endcase;\r |
794 | \r |
795 | /* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */\r |
796 | case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ \r |
797 | {\r |
1cb310e6 |
798 | register ucell_t ah,am,al,ql,qh,di;\r |
799 | #define bdiv ((ucell_t)TOS)\r |
bb6b2dcd |
800 | ah = 0;\r |
801 | am = M_POP;\r |
802 | al = M_POP;\r |
803 | qh = ql = 0;\r |
1cb310e6 |
804 | #define NBITS (sizeof(cell_t)*8)\r |
805 | for( di=0; di<2*NBITS; di++ )\r |
bb6b2dcd |
806 | {\r |
807 | if( bdiv <= ah )\r |
808 | {\r |
809 | ah = ah - bdiv;\r |
810 | ql |= 1;\r |
811 | }\r |
1cb310e6 |
812 | qh = (qh << 1) | (ql >> (NBITS-1));\r |
bb6b2dcd |
813 | ql = ql << 1;\r |
1cb310e6 |
814 | ah = (ah << 1) | (am >> (NBITS-1));\r |
815 | am = (am << 1) | (al >> (NBITS-1));\r |
bb6b2dcd |
816 | al = al << 1;\r |
817 | DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));\r |
818 | }\r |
819 | if( bdiv <= ah )\r |
820 | {\r |
821 | ah = ah - bdiv;\r |
822 | ql |= 1;\r |
823 | }\r |
824 | M_PUSH( ah ); /* rem */\r |
825 | M_PUSH( ql );\r |
826 | TOS = qh;\r |
827 | #undef bdiv\r |
828 | }\r |
829 | endcase;\r |
830 | \r |
831 | #ifndef PF_NO_SHELL\r |
832 | case ID_DEFER:\r |
833 | ffDefer( );\r |
834 | endcase;\r |
835 | #endif /* !PF_NO_SHELL */\r |
836 | \r |
837 | case ID_DEFER_P:\r |
838 | endcase;\r |
839 | \r |
840 | case ID_DEPTH:\r |
841 | PUSH_TOS;\r |
842 | TOS = gCurrentTask->td_StackBase - STKPTR;\r |
843 | endcase;\r |
844 | \r |
845 | case ID_DIVIDE: BINARY_OP( / ); endcase;\r |
846 | \r |
847 | case ID_DOT:\r |
848 | ffDot( TOS );\r |
849 | M_DROP;\r |
850 | endcase;\r |
851 | \r |
852 | case ID_DOTS:\r |
853 | M_DOTS;\r |
854 | endcase;\r |
855 | \r |
856 | case ID_DROP: M_DROP; endcase;\r |
857 | \r |
858 | case ID_DUMP:\r |
859 | Scratch = M_POP;\r |
860 | DumpMemory( (char *) Scratch, TOS );\r |
861 | M_DROP;\r |
862 | endcase;\r |
863 | \r |
864 | case ID_DUP: M_DUP; endcase;\r |
865 | \r |
866 | case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */\r |
867 | M_R_PUSH( TOS );\r |
868 | M_R_PUSH( M_POP );\r |
869 | M_DROP;\r |
870 | endcase;\r |
871 | \r |
872 | case ID_EOL: /* ( -- end_of_line_char ) */\r |
873 | PUSH_TOS;\r |
1cb310e6 |
874 | TOS = (cell_t) '\n';\r |
bb6b2dcd |
875 | endcase;\r |
876 | \r |
877 | case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */\r |
878 | Scratch = TOS;\r |
879 | M_DROP;\r |
880 | if(TOS)\r |
881 | {\r |
882 | M_THROW(Scratch);\r |
883 | }\r |
884 | else\r |
885 | {\r |
886 | M_DROP;\r |
887 | }\r |
888 | endcase;\r |
889 | \r |
890 | case ID_EMIT_P:\r |
891 | EMIT( (char) TOS );\r |
892 | M_DROP;\r |
893 | endcase;\r |
894 | \r |
895 | case ID_EXECUTE:\r |
896 | /* Save IP on return stack like a JSR. */\r |
897 | M_R_PUSH( InsPtr );\r |
898 | #ifdef PF_SUPPORT_TRACE\r |
899 | /* Bump level for trace. */\r |
900 | Level++;\r |
901 | #endif\r |
902 | if( IsTokenPrimitive( TOS ) )\r |
903 | {\r |
1cb310e6 |
904 | WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */\r |
bb6b2dcd |
905 | InsPtr = &FakeSecondary[0];\r |
906 | }\r |
907 | else\r |
908 | {\r |
1cb310e6 |
909 | InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);\r |
bb6b2dcd |
910 | }\r |
911 | M_DROP;\r |
912 | endcase;\r |
913 | \r |
914 | case ID_FETCH:\r |
915 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
916 | if( IN_DICS( TOS ) )\r |
917 | {\r |
1cb310e6 |
918 | TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);\r |
bb6b2dcd |
919 | }\r |
920 | else\r |
921 | {\r |
1cb310e6 |
922 | TOS = *((cell_t *)TOS);\r |
bb6b2dcd |
923 | }\r |
924 | #else\r |
1cb310e6 |
925 | TOS = *((cell_t *)TOS);\r |
bb6b2dcd |
926 | #endif\r |
927 | endcase;\r |
928 | \r |
929 | case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */\r |
930 | /* Build NUL terminated name string. */\r |
931 | Scratch = M_POP; /* u */\r |
932 | Temp = M_POP; /* caddr */\r |
933 | if( Scratch < TIB_SIZE-2 )\r |
934 | {\r |
acc3c8bd |
935 | const char *famText = pfSelectFileModeCreate( TOS );\r |
1cb310e6 |
936 | pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r |
bb6b2dcd |
937 | gScratch[Scratch] = '\0';\r |
987bbb7d |
938 | DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));\r |
bb6b2dcd |
939 | FileID = sdOpenFile( gScratch, famText );\r |
940 | TOS = ( FileID == NULL ) ? -1 : 0 ;\r |
1cb310e6 |
941 | M_PUSH( (cell_t) FileID );\r |
bb6b2dcd |
942 | }\r |
943 | else\r |
944 | {\r |
945 | ERR("Filename too large for name buffer.\n");\r |
946 | M_PUSH( 0 );\r |
947 | TOS = -2;\r |
948 | }\r |
949 | endcase;\r |
950 | \r |
951 | case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */\r |
952 | /* Build NUL terminated name string. */\r |
953 | Scratch = M_POP; /* u */\r |
954 | Temp = M_POP; /* caddr */\r |
955 | if( Scratch < TIB_SIZE-2 )\r |
956 | {\r |
acc3c8bd |
957 | const char *famText = pfSelectFileModeOpen( TOS );\r |
1cb310e6 |
958 | pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r |
bb6b2dcd |
959 | gScratch[Scratch] = '\0';\r |
960 | DBUG(("Open file = %s\n", gScratch ));\r |
961 | FileID = sdOpenFile( gScratch, famText );\r |
962 | \r |
963 | TOS = ( FileID == NULL ) ? -1 : 0 ;\r |
1cb310e6 |
964 | M_PUSH( (cell_t) FileID );\r |
bb6b2dcd |
965 | }\r |
966 | else\r |
967 | {\r |
968 | ERR("Filename too large for name buffer.\n");\r |
969 | M_PUSH( 0 );\r |
970 | TOS = -2;\r |
971 | }\r |
972 | endcase;\r |
973 | \r |
974 | case ID_FILE_CLOSE: /* ( fid -- ior ) */\r |
975 | TOS = sdCloseFile( (FileStream *) TOS );\r |
976 | endcase;\r |
977 | \r |
978 | case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */\r |
979 | FileID = (FileStream *) TOS;\r |
980 | Scratch = M_POP;\r |
981 | CharPtr = (char *) M_POP;\r |
982 | Temp = sdReadFile( CharPtr, 1, Scratch, FileID );\r |
983 | M_PUSH(Temp);\r |
984 | TOS = 0;\r |
985 | endcase;\r |
986 | \r |
987 | case ID_FILE_SIZE: /* ( fid -- ud ior ) */\r |
988 | /* Determine file size by seeking to end and returning position. */\r |
989 | FileID = (FileStream *) TOS;\r |
990 | Scratch = sdTellFile( FileID );\r |
991 | sdSeekFile( FileID, 0, PF_SEEK_END );\r |
992 | M_PUSH( sdTellFile( FileID ));\r |
993 | sdSeekFile( FileID, Scratch, PF_SEEK_SET );\r |
994 | TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */\r |
995 | endcase;\r |
996 | \r |
997 | case ID_FILE_WRITE: /* ( addr len fid -- ior ) */\r |
998 | FileID = (FileStream *) TOS;\r |
999 | Scratch = M_POP;\r |
1000 | CharPtr = (char *) M_POP;\r |
1001 | Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );\r |
1002 | TOS = (Temp != Scratch) ? -3 : 0;\r |
1003 | endcase;\r |
1004 | \r |
1005 | case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */\r |
1006 | FileID = (FileStream *) TOS;\r |
1007 | Scratch = M_POP;\r |
1008 | TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET );\r |
1009 | endcase;\r |
1010 | \r |
1011 | case ID_FILE_POSITION: /* ( pos fid -- ior ) */\r |
1012 | M_PUSH( sdTellFile( (FileStream *) TOS ));\r |
1013 | TOS = 0;\r |
1014 | endcase;\r |
1015 | \r |
1016 | case ID_FILE_RO: /* ( -- fam ) */\r |
1017 | PUSH_TOS;\r |
1018 | TOS = PF_FAM_READ_ONLY;\r |
1019 | endcase;\r |
1020 | \r |
1021 | case ID_FILE_RW: /* ( -- fam ) */\r |
1022 | PUSH_TOS;\r |
1023 | TOS = PF_FAM_READ_WRITE;\r |
1024 | endcase;\r |
1025 | \r |
1026 | case ID_FILE_WO: /* ( -- fam ) */\r |
1027 | PUSH_TOS;\r |
1028 | TOS = PF_FAM_WRITE_ONLY;\r |
1029 | endcase;\r |
1030 | \r |
1031 | case ID_FILE_BIN: /* ( -- fam ) */\r |
1032 | TOS = TOS | PF_FAM_BINARY_FLAG;\r |
1033 | endcase;\r |
1034 | \r |
1035 | case ID_FILL: /* ( caddr num charval -- ) */\r |
1036 | {\r |
1037 | register char *DstPtr;\r |
1038 | Temp = M_POP; /* num */\r |
1039 | DstPtr = (char *) M_POP; /* dst */\r |
1cb310e6 |
1040 | for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )\r |
bb6b2dcd |
1041 | {\r |
1042 | *DstPtr++ = (char) TOS;\r |
1043 | }\r |
1044 | M_DROP;\r |
1045 | }\r |
1046 | endcase;\r |
1047 | \r |
1048 | #ifndef PF_NO_SHELL\r |
1049 | case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */\r |
1050 | TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );\r |
1051 | M_PUSH( Temp );\r |
1052 | endcase;\r |
1053 | \r |
1054 | case ID_FINDNFA:\r |
1055 | TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );\r |
1cb310e6 |
1056 | M_PUSH( (cell_t) Temp );\r |
bb6b2dcd |
1057 | endcase;\r |
1058 | #endif /* !PF_NO_SHELL */\r |
1059 | \r |
1060 | case ID_FLUSHEMIT:\r |
1061 | sdTerminalFlush();\r |
1062 | endcase;\r |
1063 | \r |
1064 | /* Validate memory before freeing. Clobber validator and first word. */\r |
1065 | case ID_FREE: /* ( addr -- result ) */\r |
1066 | if( TOS == 0 )\r |
1067 | {\r |
1068 | ERR("FREE passed NULL!\n");\r |
1069 | TOS = -2; /* FIXME error code */\r |
1070 | }\r |
1071 | else\r |
1072 | {\r |
1cb310e6 |
1073 | CellPtr = (cell_t *) TOS;\r |
bb6b2dcd |
1074 | CellPtr--;\r |
1cb310e6 |
1075 | if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))\r |
bb6b2dcd |
1076 | {\r |
1077 | TOS = -2; /* FIXME error code */\r |
1078 | }\r |
1079 | else\r |
1080 | {\r |
1081 | CellPtr[0] = 0xDeadBeef;\r |
1082 | pfFreeMem((char *)CellPtr);\r |
1083 | TOS = 0;\r |
1084 | }\r |
1085 | }\r |
1086 | endcase;\r |
1087 | \r |
1088 | #include "pfinnrfp.h"\r |
1089 | \r |
1090 | case ID_HERE:\r |
1091 | PUSH_TOS;\r |
1cb310e6 |
1092 | TOS = (cell_t)CODE_HERE;\r |
bb6b2dcd |
1093 | endcase;\r |
1094 | \r |
1095 | case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */\r |
1096 | /* Convert using number converter in 'C'.\r |
1097 | ** Only supports single precision for bootstrap.\r |
1098 | */\r |
1cb310e6 |
1099 | TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );\r |
bb6b2dcd |
1100 | if( TOS == NUM_TYPE_SINGLE)\r |
1101 | {\r |
1102 | M_PUSH( Temp ); /* Push single number */\r |
1103 | }\r |
1104 | endcase;\r |
1105 | \r |
1106 | case ID_I: /* ( -- i , DO LOOP index ) */\r |
1107 | PUSH_TOS;\r |
1108 | TOS = M_R_PICK(1);\r |
1109 | endcase;\r |
1110 | \r |
1111 | #ifndef PF_NO_SHELL\r |
1112 | case ID_INCLUDE_FILE:\r |
1113 | FileID = (FileStream *) TOS;\r |
1114 | M_DROP; /* Drop now so that INCLUDE has a clean stack. */\r |
1115 | SAVE_REGISTERS;\r |
1116 | Scratch = ffIncludeFile( FileID );\r |
1117 | LOAD_REGISTERS;\r |
1118 | if( Scratch ) M_THROW(Scratch)\r |
1119 | endcase;\r |
1120 | #endif /* !PF_NO_SHELL */\r |
1121 | \r |
1122 | #ifndef PF_NO_SHELL\r |
1123 | case ID_INTERPRET:\r |
1124 | SAVE_REGISTERS;\r |
1125 | Scratch = ffInterpret();\r |
1126 | LOAD_REGISTERS;\r |
1127 | if( Scratch ) M_THROW(Scratch)\r |
1128 | endcase;\r |
1129 | #endif /* !PF_NO_SHELL */\r |
1130 | \r |
1131 | case ID_J: /* ( -- j , second DO LOOP index ) */\r |
1132 | PUSH_TOS;\r |
1133 | TOS = M_R_PICK(3);\r |
1134 | endcase;\r |
1135 | \r |
1136 | case ID_KEY:\r |
1137 | PUSH_TOS;\r |
1138 | TOS = ioKey();\r |
1139 | endcase;\r |
1140 | \r |
1141 | #ifndef PF_NO_SHELL\r |
1142 | case ID_LITERAL:\r |
1143 | ffLiteral( TOS );\r |
1144 | M_DROP;\r |
1145 | endcase;\r |
1146 | #endif /* !PF_NO_SHELL */\r |
1147 | \r |
1148 | case ID_LITERAL_P:\r |
1149 | DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));\r |
1150 | PUSH_TOS;\r |
1cb310e6 |
1151 | TOS = READ_CELL_DIC(InsPtr++);\r |
bb6b2dcd |
1152 | endcase;\r |
1153 | \r |
1154 | #ifndef PF_NO_SHELL\r |
1155 | case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;\r |
1156 | #endif /* !PF_NO_SHELL */\r |
1157 | \r |
1158 | case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */\r |
1159 | TOS = *(LocalsPtr - TOS);\r |
1160 | endcase;\r |
1161 | \r |
1162 | #define LOCAL_FETCH_N(num) \\r |
1163 | case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \\r |
1164 | PUSH_TOS; \\r |
1165 | TOS = *(LocalsPtr -(num)); \\r |
1166 | endcase;\r |
1167 | \r |
1168 | LOCAL_FETCH_N(1);\r |
1169 | LOCAL_FETCH_N(2);\r |
1170 | LOCAL_FETCH_N(3);\r |
1171 | LOCAL_FETCH_N(4);\r |
1172 | LOCAL_FETCH_N(5);\r |
1173 | LOCAL_FETCH_N(6);\r |
1174 | LOCAL_FETCH_N(7);\r |
1175 | LOCAL_FETCH_N(8);\r |
1176 | \r |
1177 | case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */\r |
1178 | *(LocalsPtr - TOS) = M_POP;\r |
1179 | M_DROP;\r |
1180 | endcase;\r |
1181 | \r |
1182 | #define LOCAL_STORE_N(num) \\r |
1183 | case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \\r |
1184 | *(LocalsPtr - (num)) = TOS; \\r |
1185 | M_DROP; \\r |
1186 | endcase;\r |
1187 | \r |
1188 | LOCAL_STORE_N(1);\r |
1189 | LOCAL_STORE_N(2);\r |
1190 | LOCAL_STORE_N(3);\r |
1191 | LOCAL_STORE_N(4);\r |
1192 | LOCAL_STORE_N(5);\r |
1193 | LOCAL_STORE_N(6);\r |
1194 | LOCAL_STORE_N(7);\r |
1195 | LOCAL_STORE_N(8);\r |
1196 | \r |
1197 | case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */\r |
1198 | *(LocalsPtr - TOS) += M_POP;\r |
1199 | M_DROP;\r |
1200 | endcase;\r |
1201 | \r |
1202 | case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */\r |
1203 | /* create local stack frame */\r |
1204 | {\r |
1cb310e6 |
1205 | cell_t i = TOS;\r |
1206 | cell_t *lp;\r |
bb6b2dcd |
1207 | DBUG(("LocalEntry: n = %d\n", TOS));\r |
1208 | /* End of locals. Create stack frame */\r |
1209 | DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",\r |
1210 | TORPTR, LocalsPtr));\r |
1211 | M_R_PUSH(LocalsPtr);\r |
1212 | LocalsPtr = TORPTR;\r |
1213 | TORPTR -= TOS;\r |
1214 | DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",\r |
1215 | TORPTR, LocalsPtr));\r |
1216 | lp = TORPTR;\r |
1217 | while(i-- > 0)\r |
1218 | {\r |
1219 | *lp++ = M_POP; /* Load local vars from stack */\r |
1220 | }\r |
1221 | M_DROP;\r |
1222 | }\r |
1223 | endcase;\r |
1224 | \r |
1225 | case ID_LOCAL_EXIT: /* cleanup up local stack frame */\r |
1226 | DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",\r |
1227 | TORPTR, LocalsPtr));\r |
1228 | TORPTR = LocalsPtr;\r |
1cb310e6 |
1229 | LocalsPtr = (cell_t *) M_R_POP;\r |
bb6b2dcd |
1230 | DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",\r |
1231 | TORPTR, LocalsPtr));\r |
1232 | endcase;\r |
1233 | \r |
1234 | #ifndef PF_NO_SHELL\r |
1235 | case ID_LOADSYS:\r |
1236 | MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;\r |
1237 | FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");\r |
1238 | if( FileID )\r |
1239 | {\r |
1240 | SAVE_REGISTERS;\r |
1241 | Scratch = ffIncludeFile( FileID );\r |
1242 | LOAD_REGISTERS;\r |
1243 | sdCloseFile( FileID );\r |
1244 | if( Scratch ) M_THROW(Scratch);\r |
1245 | }\r |
1246 | else\r |
1247 | {\r |
1248 | ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");\r |
1249 | }\r |
1250 | endcase;\r |
1251 | #endif /* !PF_NO_SHELL */\r |
1252 | \r |
1253 | case ID_LEAVE_P: /* ( R: index limit -- ) */\r |
1254 | M_R_DROP;\r |
1255 | M_R_DROP;\r |
1256 | M_BRANCH;\r |
1257 | endcase;\r |
1258 | \r |
1259 | case ID_LOOP_P: /* ( R: index limit -- | index limit ) */\r |
1260 | Temp = M_R_POP; /* limit */\r |
1261 | Scratch = M_R_POP + 1; /* index */\r |
1262 | if( Scratch == Temp )\r |
1263 | {\r |
1264 | InsPtr++; /* skip branch offset, exit loop */\r |
1265 | }\r |
1266 | else\r |
1267 | {\r |
1268 | /* Push index and limit back to R */\r |
1269 | M_R_PUSH( Scratch );\r |
1270 | M_R_PUSH( Temp );\r |
1271 | /* Branch back to just after (DO) */\r |
1272 | M_BRANCH;\r |
1273 | }\r |
1274 | endcase;\r |
1275 | \r |
1276 | case ID_LSHIFT: BINARY_OP( << ); endcase;\r |
1277 | \r |
1278 | case ID_MAX:\r |
1279 | Scratch = M_POP;\r |
1280 | TOS = ( TOS > Scratch ) ? TOS : Scratch ;\r |
1281 | endcase;\r |
1282 | \r |
1283 | case ID_MIN:\r |
1284 | Scratch = M_POP;\r |
1285 | TOS = ( TOS < Scratch ) ? TOS : Scratch ;\r |
1286 | endcase;\r |
1287 | \r |
1288 | case ID_MINUS: BINARY_OP( - ); endcase;\r |
1289 | \r |
1290 | #ifndef PF_NO_SHELL\r |
1291 | case ID_NAME_TO_TOKEN:\r |
1cb310e6 |
1292 | TOS = (cell_t) NameToToken((ForthString *)TOS);\r |
bb6b2dcd |
1293 | endcase;\r |
1294 | \r |
1295 | case ID_NAME_TO_PREVIOUS:\r |
1cb310e6 |
1296 | TOS = (cell_t) NameToPrevious((ForthString *)TOS);\r |
bb6b2dcd |
1297 | endcase;\r |
1298 | #endif\r |
1299 | \r |
1300 | case ID_NOOP:\r |
1301 | endcase;\r |
1302 | \r |
1303 | case ID_OR: BINARY_OP( | ); endcase;\r |
1304 | \r |
1305 | case ID_OVER:\r |
1306 | PUSH_TOS;\r |
1307 | TOS = M_STACK(1);\r |
1308 | endcase;\r |
1309 | \r |
1310 | case ID_PICK: /* ( ... n -- sp(n) ) */\r |
1311 | TOS = M_STACK(TOS);\r |
1312 | endcase;\r |
1313 | \r |
1314 | case ID_PLUS: BINARY_OP( + ); endcase;\r |
1315 | \r |
1316 | case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */\r |
1317 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1318 | if( IN_DICS( TOS ) )\r |
1319 | {\r |
1cb310e6 |
1320 | Scratch = READ_CELL_DIC((cell_t *)TOS);\r |
bb6b2dcd |
1321 | Scratch += M_POP;\r |
1cb310e6 |
1322 | WRITE_CELL_DIC((cell_t *)TOS,Scratch);\r |
bb6b2dcd |
1323 | }\r |
1324 | else\r |
1325 | {\r |
1cb310e6 |
1326 | *((cell_t *)TOS) += M_POP;\r |
bb6b2dcd |
1327 | }\r |
1328 | #else\r |
1cb310e6 |
1329 | *((cell_t *)TOS) += M_POP;\r |
bb6b2dcd |
1330 | #endif\r |
1331 | M_DROP;\r |
1332 | endcase;\r |
1333 | \r |
1334 | case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */\r |
1335 | {\r |
1cb310e6 |
1336 | ucell_t OldIndex, NewIndex, Limit;\r |
bb6b2dcd |
1337 | \r |
1338 | Limit = M_R_POP;\r |
1339 | OldIndex = M_R_POP;\r |
1340 | NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */\r |
1341 | /* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r |
1342 | if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r |
1343 | ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r |
1344 | {\r |
1345 | InsPtr++; /* skip branch offset, exit loop */\r |
1346 | }\r |
1347 | else\r |
1348 | {\r |
1349 | /* Push index and limit back to R */\r |
1350 | M_R_PUSH( NewIndex );\r |
1351 | M_R_PUSH( Limit );\r |
1352 | /* Branch back to just after (DO) */\r |
1353 | M_BRANCH;\r |
1354 | }\r |
1355 | M_DROP;\r |
1356 | }\r |
1357 | endcase;\r |
1358 | \r |
1359 | case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */\r |
1360 | Scratch = M_POP; /* limit */\r |
1361 | if( Scratch == TOS )\r |
1362 | {\r |
1363 | /* Branch to just after (LOOP) */\r |
1364 | M_BRANCH;\r |
1365 | }\r |
1366 | else\r |
1367 | {\r |
1368 | M_R_PUSH( TOS );\r |
1369 | M_R_PUSH( Scratch );\r |
1370 | InsPtr++; /* skip branch offset, enter loop */\r |
1371 | }\r |
1372 | M_DROP;\r |
1373 | endcase;\r |
1374 | \r |
1375 | case ID_QDUP: if( TOS ) M_DUP; endcase;\r |
1376 | \r |
1377 | case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */\r |
1378 | PUSH_TOS;\r |
1379 | TOS = sdQueryTerminal();\r |
1380 | endcase;\r |
1381 | \r |
1382 | case ID_QUIT_P: /* Stop inner interpreter, go back to user. */\r |
1383 | #ifdef PF_SUPPORT_TRACE\r |
1384 | Level = 0;\r |
1385 | #endif\r |
1386 | M_THROW(THROW_QUIT);\r |
1387 | endcase;\r |
1388 | \r |
1389 | case ID_R_DROP:\r |
1390 | M_R_DROP;\r |
1391 | endcase;\r |
1392 | \r |
1393 | case ID_R_FETCH:\r |
1394 | PUSH_TOS;\r |
1395 | TOS = (*(TORPTR));\r |
1396 | endcase;\r |
1397 | \r |
1398 | case ID_R_FROM:\r |
1399 | PUSH_TOS;\r |
1400 | TOS = M_R_POP;\r |
1401 | endcase;\r |
1402 | \r |
1403 | case ID_REFILL:\r |
1404 | PUSH_TOS;\r |
1405 | TOS = (ffRefill() > 0) ? FTRUE : FFALSE;\r |
1406 | endcase;\r |
1407 | \r |
1408 | /* Resize memory allocated by ALLOCATE. */\r |
1409 | case ID_RESIZE: /* ( addr1 u -- addr2 result ) */\r |
1410 | {\r |
1cb310e6 |
1411 | cell_t *Addr1 = (cell_t *) M_POP;\r |
07618dcb |
1412 | // Point to validator below users address.\r |
1cb310e6 |
1413 | cell_t *FreePtr = Addr1 - 1;\r |
1414 | if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))\r |
bb6b2dcd |
1415 | {\r |
07618dcb |
1416 | // 090218 - Fixed bug, was returning zero.\r |
1417 | M_PUSH( Addr1 );\r |
bb6b2dcd |
1418 | TOS = -3;\r |
1419 | }\r |
1420 | else\r |
1421 | {\r |
1422 | /* Try to allocate. */\r |
1cb310e6 |
1423 | CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );\r |
bb6b2dcd |
1424 | if( CellPtr )\r |
1425 | {\r |
1426 | /* Copy memory including validation. */\r |
1cb310e6 |
1427 | pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );\r |
1428 | *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);\r |
07618dcb |
1429 | // 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub.\r |
1430 | // Increment past validator to user address.\r |
1cb310e6 |
1431 | M_PUSH( (cell_t) (CellPtr + 1) );\r |
07618dcb |
1432 | TOS = 0; // Result code.\r |
1433 | // Mark old cell as dead so we can't free it twice.\r |
bb6b2dcd |
1434 | FreePtr[0] = 0xDeadBeef;\r |
1435 | pfFreeMem((char *) FreePtr);\r |
1436 | }\r |
1437 | else\r |
1438 | {\r |
07618dcb |
1439 | // 090218 - Fixed bug, was returning zero.\r |
1440 | M_PUSH( Addr1 );\r |
bb6b2dcd |
1441 | TOS = -4; /* FIXME Fix error code. */\r |
1442 | }\r |
1443 | }\r |
1444 | }\r |
1445 | endcase;\r |
1446 | \r |
1447 | /*\r |
1448 | ** RP@ and RP! are called secondaries so we must\r |
1449 | ** account for the return address pushed before calling.\r |
1450 | */\r |
1451 | case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */\r |
1452 | PUSH_TOS;\r |
1cb310e6 |
1453 | TOS = (cell_t)TORPTR; /* value before calling RP@ */\r |
bb6b2dcd |
1454 | endcase;\r |
1455 | \r |
1456 | case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */\r |
1cb310e6 |
1457 | TORPTR = (cell_t *) TOS;\r |
bb6b2dcd |
1458 | M_DROP;\r |
1459 | endcase;\r |
1460 | \r |
1461 | case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */\r |
1462 | {\r |
1cb310e6 |
1463 | cell_t ri;\r |
1464 | cell_t *srcPtr, *dstPtr;\r |
bb6b2dcd |
1465 | Scratch = M_STACK(TOS);\r |
1466 | srcPtr = &M_STACK(TOS-1);\r |
1467 | dstPtr = &M_STACK(TOS);\r |
1468 | for( ri=0; ri<TOS; ri++ )\r |
1469 | {\r |
1470 | *dstPtr-- = *srcPtr--;\r |
1471 | }\r |
1472 | TOS = Scratch;\r |
1473 | STKPTR++;\r |
1474 | }\r |
1475 | endcase;\r |
1476 | \r |
1477 | case ID_ROT: /* ( a b c -- b c a ) */\r |
1478 | Scratch = M_POP; /* b */\r |
1479 | Temp = M_POP; /* a */\r |
1480 | M_PUSH( Scratch ); /* b */\r |
1481 | PUSH_TOS; /* c */\r |
1482 | TOS = Temp; /* a */\r |
1483 | endcase;\r |
1484 | \r |
1485 | /* Logical right shift */\r |
1cb310e6 |
1486 | case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase; \r |
bb6b2dcd |
1487 | \r |
1488 | #ifndef PF_NO_SHELL\r |
1489 | case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */\r |
1490 | {\r |
1cb310e6 |
1491 | cell_t NameSize, CodeSize, EntryPoint;\r |
bb6b2dcd |
1492 | CodeSize = TOS;\r |
1493 | NameSize = M_POP;\r |
1494 | EntryPoint = M_POP;\r |
1495 | ForthStringToC( gScratch, (char *) M_POP );\r |
1496 | TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );\r |
1497 | }\r |
1498 | endcase;\r |
1499 | #endif\r |
1500 | \r |
1501 | /* Source Stack\r |
1502 | ** EVALUATE >IN SourceID=(-1) 1111\r |
1503 | ** keyboard >IN SourceID=(0) 2222\r |
1504 | ** file >IN lineNumber filePos SourceID=(fileID)\r |
1505 | */\r |
1506 | case ID_SAVE_INPUT: /* FIXME - finish */\r |
1507 | {\r |
1508 | }\r |
1509 | endcase;\r |
1510 | \r |
1511 | case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */\r |
1512 | PUSH_TOS;\r |
1cb310e6 |
1513 | TOS = (cell_t)STKPTR;\r |
bb6b2dcd |
1514 | endcase;\r |
1515 | \r |
1516 | case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */\r |
1cb310e6 |
1517 | STKPTR = (cell_t *) TOS;\r |
bb6b2dcd |
1518 | M_DROP;\r |
1519 | endcase;\r |
1520 | \r |
1521 | case ID_STORE: /* ( n addr -- , write n to addr ) */\r |
1522 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1523 | if( IN_DICS( TOS ) )\r |
1524 | {\r |
1cb310e6 |
1525 | WRITE_CELL_DIC(TOS,M_POP);\r |
bb6b2dcd |
1526 | }\r |
1527 | else\r |
1528 | {\r |
1cb310e6 |
1529 | *((cell_t *)TOS) = M_POP;\r |
bb6b2dcd |
1530 | }\r |
1531 | #else\r |
1cb310e6 |
1532 | *((cell_t *)TOS) = M_POP;\r |
bb6b2dcd |
1533 | #endif\r |
1534 | M_DROP;\r |
1535 | endcase;\r |
1536 | \r |
1537 | case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */\r |
1538 | Scratch = M_POP; /* cnt */\r |
1539 | Temp = M_POP; /* addr */\r |
1540 | TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r |
1cb310e6 |
1541 | M_PUSH((cell_t) CharPtr);\r |
bb6b2dcd |
1542 | endcase;\r |
1543 | \r |
1544 | #ifndef PF_NO_SHELL\r |
1545 | case ID_SEMICOLON:\r |
1546 | SAVE_REGISTERS;\r |
1547 | Scratch = ffSemiColon();\r |
1548 | LOAD_REGISTERS;\r |
1549 | if( Scratch ) M_THROW( Scratch );\r |
1550 | endcase;\r |
1551 | #endif /* !PF_NO_SHELL */\r |
1552 | \r |
1553 | case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */\r |
1554 | Scratch = M_POP; /* cnt */\r |
1555 | Temp = M_POP; /* addr */\r |
1556 | TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r |
1cb310e6 |
1557 | M_PUSH((cell_t) CharPtr);\r |
bb6b2dcd |
1558 | endcase;\r |
1559 | \r |
1560 | case ID_SOURCE: /* ( -- c-addr num ) */\r |
1561 | PUSH_TOS;\r |
1cb310e6 |
1562 | M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );\r |
1563 | TOS = (cell_t) gCurrentTask->td_SourceNum;\r |
bb6b2dcd |
1564 | endcase;\r |
1565 | \r |
1566 | case ID_SOURCE_SET: /* ( c-addr num -- ) */\r |
1567 | gCurrentTask->td_SourcePtr = (char *) M_POP;\r |
1568 | gCurrentTask->td_SourceNum = TOS;\r |
1569 | M_DROP;\r |
1570 | endcase;\r |
1571 | \r |
1572 | case ID_SOURCE_ID:\r |
1573 | PUSH_TOS;\r |
1574 | TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;\r |
1575 | endcase;\r |
1576 | \r |
1577 | case ID_SOURCE_ID_POP:\r |
1578 | PUSH_TOS;\r |
1579 | TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;\r |
1580 | endcase;\r |
1581 | \r |
1582 | case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */\r |
1cb310e6 |
1583 | TOS = (cell_t)ffConvertSourceIDToStream( TOS );\r |
bb6b2dcd |
1584 | Scratch = ffPushInputStream((FileStream *) TOS );\r |
1585 | if( Scratch )\r |
1586 | {\r |
1587 | M_THROW(Scratch);\r |
1588 | }\r |
1589 | else M_DROP;\r |
1590 | endcase;\r |
1591 | \r |
1592 | case ID_SWAP:\r |
1593 | Scratch = TOS;\r |
1594 | TOS = *STKPTR;\r |
1595 | *STKPTR = Scratch;\r |
1596 | endcase;\r |
1597 | \r |
1598 | case ID_TEST1:\r |
1599 | PUSH_TOS;\r |
1600 | M_PUSH( 0x11 );\r |
1601 | M_PUSH( 0x22 );\r |
1602 | TOS = 0x33;\r |
1603 | endcase;\r |
1604 | \r |
1605 | case ID_TEST2:\r |
1606 | endcase;\r |
1607 | \r |
1608 | case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */\r |
1609 | if(TOS)\r |
1610 | {\r |
1611 | M_THROW(TOS);\r |
1612 | }\r |
1613 | else M_DROP;\r |
1614 | endcase;\r |
1615 | \r |
1616 | #ifndef PF_NO_SHELL\r |
1617 | case ID_TICK:\r |
1618 | PUSH_TOS;\r |
1619 | CharPtr = (char *) ffWord( (char) ' ' );\r |
1620 | TOS = ffFind( CharPtr, (ExecToken *) &Temp );\r |
1621 | if( TOS == 0 )\r |
1622 | {\r |
1623 | ERR("' could not find ");\r |
1624 | ioType( (char *) CharPtr+1, *CharPtr );\r |
1625 | M_THROW(-13);\r |
1626 | }\r |
1627 | else\r |
1628 | {\r |
1629 | TOS = Temp;\r |
1630 | }\r |
1631 | endcase;\r |
1632 | #endif /* !PF_NO_SHELL */\r |
1633 | \r |
1634 | case ID_TIMES: BINARY_OP( * ); endcase;\r |
1635 | \r |
1636 | case ID_TYPE:\r |
1637 | Scratch = M_POP; /* addr */\r |
1638 | ioType( (char *) Scratch, TOS );\r |
1639 | M_DROP;\r |
1640 | endcase;\r |
1641 | \r |
1642 | case ID_TO_R:\r |
1643 | M_R_PUSH( TOS );\r |
1644 | M_DROP;\r |
1645 | endcase;\r |
1646 | \r |
1647 | case ID_VAR_BASE: DO_VAR(gVarBase); endcase;\r |
1648 | case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;\r |
1649 | case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;\r |
1650 | case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;\r |
1651 | case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;\r |
1652 | case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;\r |
1653 | case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;\r |
1654 | case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;\r |
1655 | case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr.Cell); endcase;\r |
1656 | case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;\r |
1657 | case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;\r |
1658 | case ID_VAR_STATE: DO_VAR(gVarState); endcase;\r |
1659 | case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;\r |
1660 | case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;\r |
1661 | case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;\r |
1662 | case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;\r |
1663 | case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;\r |
1664 | \r |
1665 | case ID_WORD:\r |
1cb310e6 |
1666 | TOS = (cell_t) ffWord( (char) TOS );\r |
bb6b2dcd |
1667 | endcase;\r |
1668 | \r |
1669 | case ID_WORD_FETCH: /* ( waddr -- w ) */\r |
1670 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1671 | if( IN_DICS( TOS ) )\r |
1672 | {\r |
1cb310e6 |
1673 | TOS = (uint16_t) READ_SHORT_DIC((uint8_t *)TOS);\r |
bb6b2dcd |
1674 | }\r |
1675 | else\r |
1676 | {\r |
1cb310e6 |
1677 | TOS = *((uint16_t *)TOS);\r |
bb6b2dcd |
1678 | }\r |
1679 | #else\r |
1cb310e6 |
1680 | TOS = *((uint16_t *)TOS);\r |
bb6b2dcd |
1681 | #endif\r |
1682 | endcase;\r |
1683 | \r |
1684 | case ID_WORD_STORE: /* ( w waddr -- ) */\r |
1685 | \r |
1686 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1687 | if( IN_DICS( TOS ) )\r |
1688 | {\r |
1cb310e6 |
1689 | WRITE_SHORT_DIC(TOS,M_POP);\r |
bb6b2dcd |
1690 | }\r |
1691 | else\r |
1692 | {\r |
1cb310e6 |
1693 | *((uint16_t *)TOS) = (uint16_t) M_POP;\r |
bb6b2dcd |
1694 | }\r |
1695 | #else\r |
1cb310e6 |
1696 | *((uint16_t *)TOS) = (uint16_t) M_POP;\r |
bb6b2dcd |
1697 | #endif\r |
1698 | M_DROP;\r |
1699 | endcase;\r |
1700 | \r |
1701 | case ID_XOR: BINARY_OP( ^ ); endcase;\r |
1702 | \r |
1703 | \r |
1704 | /* Branch is followed by an offset relative to address of offset. */\r |
1705 | case ID_ZERO_BRANCH:\r |
1706 | DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));\r |
1707 | if( TOS == 0 )\r |
1708 | {\r |
1709 | M_BRANCH;\r |
1710 | }\r |
1711 | else\r |
1712 | {\r |
1713 | InsPtr++; /* skip over offset */\r |
1714 | }\r |
1715 | M_DROP;\r |
1716 | DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));\r |
1717 | endcase;\r |
1718 | \r |
1719 | default:\r |
1720 | ERR("pfCatch: Unrecognised token = 0x");\r |
1721 | ffDotHex(Token);\r |
1722 | ERR(" at 0x");\r |
1cb310e6 |
1723 | ffDotHex((cell_t) InsPtr);\r |
bb6b2dcd |
1724 | EMIT_CR;\r |
1725 | InsPtr = 0;\r |
1726 | endcase;\r |
1727 | }\r |
1728 | \r |
1cb310e6 |
1729 | if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */\r |
bb6b2dcd |
1730 | \r |
1731 | #ifdef PF_DEBUG\r |
1732 | M_DOTS;\r |
1733 | #endif\r |
1734 | \r |
1735 | #if 0\r |
1736 | if( _CrtCheckMemory() == 0 )\r |
1737 | {\r |
1738 | ERR("_CrtCheckMemory abort: InsPtr = 0x");\r |
1739 | ffDotHex((int)InsPtr);\r |
1740 | ERR("\n");\r |
1741 | }\r |
1742 | #endif\r |
1743 | \r |
1744 | } while( (InitialReturnStack - TORPTR) > 0 );\r |
1745 | \r |
1746 | SAVE_REGISTERS;\r |
1747 | \r |
1748 | return ExceptionReturnCode;\r |
1749 | }\r |