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