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 |
336369a5 |
281 | uint8_t *CodeBase = (uint8_t *) 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 |
54b27a87 |
664 | /* Assume 8-bit char and calculate cell width. */\r |
665 | #define NBITS ((sizeof(ucell_t)) * 8)\r |
666 | /* Define half the number of bits in a cell. */\r |
667 | #define HNBITS (NBITS / 2)\r |
668 | /* Assume two-complement arithmetic to calculate lower half. */\r |
669 | #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))\r |
670 | #define HIGH_BIT ((ucell_t)1 << (NBITS - 1))\r |
671 | \r |
672 | /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.\r |
673 | * Using an improved algorithm suggested by Steve Green.\r |
674 | * Converted to 64-bit by Aleksej Saushev.\r |
675 | */\r |
676 | case ID_D_UMTIMES: /* UM* ( a b -- lo hi ) */ \r |
bb6b2dcd |
677 | {\r |
54b27a87 |
678 | ucell_t ahi, alo, bhi, blo; /* input parts */\r |
679 | ucell_t lo, hi, temp;\r |
bb6b2dcd |
680 | /* Get values from stack. */\r |
681 | ahi = M_POP;\r |
682 | bhi = TOS;\r |
683 | /* Break into hi and lo 16 bit parts. */\r |
54b27a87 |
684 | alo = LOWER_HALF(ahi);\r |
685 | ahi = ahi >> HNBITS;\r |
686 | blo = LOWER_HALF(bhi);\r |
687 | bhi = bhi >> HNBITS;\r |
688 | \r |
689 | lo = 0;\r |
690 | hi = 0;\r |
691 | /* higher part: ahi * bhi */\r |
692 | hi += ahi * bhi;\r |
693 | /* middle (overlapping) part: ahi * blo */\r |
bb6b2dcd |
694 | temp = ahi * blo;\r |
54b27a87 |
695 | lo += LOWER_HALF(temp);\r |
696 | hi += temp >> HNBITS;\r |
697 | /* middle (overlapping) part: alo * bhi */\r |
bb6b2dcd |
698 | temp = alo * bhi;\r |
54b27a87 |
699 | lo += LOWER_HALF(temp);\r |
700 | hi += temp >> HNBITS;\r |
701 | /* lower part: alo * blo */\r |
bb6b2dcd |
702 | temp = alo * blo;\r |
54b27a87 |
703 | /* its higher half overlaps with middle's lower half: */\r |
704 | lo += temp >> HNBITS;\r |
705 | /* process carry: */\r |
706 | hi += lo >> HNBITS;\r |
707 | lo = LOWER_HALF(lo);\r |
708 | /* combine lower part of result: */\r |
709 | lo = (lo << HNBITS) + LOWER_HALF(temp);\r |
710 | \r |
711 | M_PUSH( lo );\r |
712 | TOS = hi;\r |
bb6b2dcd |
713 | }\r |
714 | endcase;\r |
715 | \r |
54b27a87 |
716 | /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */\r |
bb6b2dcd |
717 | case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ \r |
718 | {\r |
54b27a87 |
719 | ucell_t ahi, alo, bhi, blo; /* input parts */\r |
720 | ucell_t lo, hi, temp;\r |
721 | int sg;\r |
bb6b2dcd |
722 | /* Get values from stack. */\r |
54b27a87 |
723 | ahi = M_POP;\r |
724 | bhi = TOS;\r |
725 | \r |
726 | /* Calculate product sign: */\r |
727 | sg = ((cell_t)(ahi ^ bhi) < 0);\r |
728 | /* Take absolute values and reduce to um* */\r |
729 | if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi);\r |
730 | if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi);\r |
731 | \r |
bb6b2dcd |
732 | /* Break into hi and lo 16 bit parts. */\r |
54b27a87 |
733 | alo = LOWER_HALF(ahi);\r |
734 | ahi = ahi >> HNBITS;\r |
735 | blo = LOWER_HALF(bhi);\r |
736 | bhi = bhi >> HNBITS;\r |
737 | \r |
738 | lo = 0;\r |
739 | hi = 0;\r |
740 | /* higher part: ahi * bhi */\r |
741 | hi += ahi * bhi;\r |
742 | /* middle (overlapping) part: ahi * blo */\r |
bb6b2dcd |
743 | temp = ahi * blo;\r |
54b27a87 |
744 | lo += LOWER_HALF(temp);\r |
745 | hi += temp >> HNBITS;\r |
746 | /* middle (overlapping) part: alo * bhi */\r |
bb6b2dcd |
747 | temp = alo * bhi;\r |
54b27a87 |
748 | lo += LOWER_HALF(temp);\r |
749 | hi += temp >> HNBITS;\r |
750 | /* lower part: alo * blo */\r |
bb6b2dcd |
751 | temp = alo * blo;\r |
54b27a87 |
752 | /* its higher half overlaps with middle's lower half: */\r |
753 | lo += temp >> HNBITS;\r |
754 | /* process carry: */\r |
755 | hi += lo >> HNBITS;\r |
756 | lo = LOWER_HALF(lo);\r |
757 | /* combine lower part of result: */\r |
758 | lo = (lo << HNBITS) + LOWER_HALF(temp);\r |
bb6b2dcd |
759 | \r |
760 | /* Negate product if one operand negative. */\r |
54b27a87 |
761 | if(sg)\r |
bb6b2dcd |
762 | {\r |
54b27a87 |
763 | /* lo = (ucell_t)(- lo); */\r |
764 | lo = ~lo + 1;\r |
765 | hi = ~hi + ((lo == 0) ? 1 : 0);\r |
bb6b2dcd |
766 | }\r |
767 | \r |
54b27a87 |
768 | M_PUSH( lo );\r |
769 | TOS = hi;\r |
bb6b2dcd |
770 | }\r |
771 | endcase;\r |
772 | \r |
773 | #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )\r |
54b27a87 |
774 | /* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */\r |
bb6b2dcd |
775 | case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */ \r |
776 | {\r |
1cb310e6 |
777 | ucell_t ah,al, q,di, bl,bh, sl,sh;\r |
bb6b2dcd |
778 | ah = M_POP;\r |
779 | al = M_POP;\r |
780 | bh = TOS;\r |
781 | bl = 0;\r |
782 | q = 0;\r |
54b27a87 |
783 | for( di=0; di<NBITS; di++ )\r |
bb6b2dcd |
784 | {\r |
785 | if( !DULT(al,ah,bl,bh) )\r |
786 | {\r |
787 | sh = 0;\r |
788 | sl = al - bl;\r |
789 | if( al < bl ) sh = 1; /* Borrow */\r |
790 | sh = ah - bh - sh;\r |
791 | ah = sh;\r |
792 | al = sl;\r |
793 | q |= 1;\r |
794 | }\r |
795 | q = q << 1;\r |
54b27a87 |
796 | bl = (bl >> 1) | (bh << (NBITS-1));\r |
bb6b2dcd |
797 | bh = bh >> 1;\r |
798 | }\r |
799 | if( !DULT(al,ah,bl,bh) )\r |
800 | {\r |
801 | \r |
802 | al = al - bl;\r |
803 | q |= 1;\r |
804 | }\r |
805 | M_PUSH( al ); /* rem */\r |
806 | TOS = q;\r |
807 | }\r |
808 | endcase;\r |
809 | \r |
54b27a87 |
810 | /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */\r |
bb6b2dcd |
811 | case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ \r |
812 | {\r |
1cb310e6 |
813 | register ucell_t ah,am,al,ql,qh,di;\r |
814 | #define bdiv ((ucell_t)TOS)\r |
bb6b2dcd |
815 | ah = 0;\r |
816 | am = M_POP;\r |
817 | al = M_POP;\r |
818 | qh = ql = 0;\r |
1cb310e6 |
819 | for( di=0; di<2*NBITS; di++ )\r |
bb6b2dcd |
820 | {\r |
821 | if( bdiv <= ah )\r |
822 | {\r |
823 | ah = ah - bdiv;\r |
824 | ql |= 1;\r |
825 | }\r |
1cb310e6 |
826 | qh = (qh << 1) | (ql >> (NBITS-1));\r |
bb6b2dcd |
827 | ql = ql << 1;\r |
1cb310e6 |
828 | ah = (ah << 1) | (am >> (NBITS-1));\r |
829 | am = (am << 1) | (al >> (NBITS-1));\r |
bb6b2dcd |
830 | al = al << 1;\r |
831 | DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));\r |
832 | }\r |
833 | if( bdiv <= ah )\r |
834 | {\r |
835 | ah = ah - bdiv;\r |
836 | ql |= 1;\r |
837 | }\r |
838 | M_PUSH( ah ); /* rem */\r |
839 | M_PUSH( ql );\r |
840 | TOS = qh;\r |
841 | #undef bdiv\r |
842 | }\r |
843 | endcase;\r |
844 | \r |
845 | #ifndef PF_NO_SHELL\r |
846 | case ID_DEFER:\r |
847 | ffDefer( );\r |
848 | endcase;\r |
849 | #endif /* !PF_NO_SHELL */\r |
850 | \r |
851 | case ID_DEFER_P:\r |
852 | endcase;\r |
853 | \r |
854 | case ID_DEPTH:\r |
855 | PUSH_TOS;\r |
856 | TOS = gCurrentTask->td_StackBase - STKPTR;\r |
857 | endcase;\r |
858 | \r |
859 | case ID_DIVIDE: BINARY_OP( / ); endcase;\r |
860 | \r |
861 | case ID_DOT:\r |
862 | ffDot( TOS );\r |
863 | M_DROP;\r |
864 | endcase;\r |
865 | \r |
866 | case ID_DOTS:\r |
867 | M_DOTS;\r |
868 | endcase;\r |
869 | \r |
870 | case ID_DROP: M_DROP; endcase;\r |
871 | \r |
872 | case ID_DUMP:\r |
873 | Scratch = M_POP;\r |
874 | DumpMemory( (char *) Scratch, TOS );\r |
875 | M_DROP;\r |
876 | endcase;\r |
877 | \r |
878 | case ID_DUP: M_DUP; endcase;\r |
879 | \r |
880 | case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */\r |
881 | M_R_PUSH( TOS );\r |
882 | M_R_PUSH( M_POP );\r |
883 | M_DROP;\r |
884 | endcase;\r |
885 | \r |
886 | case ID_EOL: /* ( -- end_of_line_char ) */\r |
887 | PUSH_TOS;\r |
1cb310e6 |
888 | TOS = (cell_t) '\n';\r |
bb6b2dcd |
889 | endcase;\r |
890 | \r |
891 | case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */\r |
892 | Scratch = TOS;\r |
893 | M_DROP;\r |
894 | if(TOS)\r |
895 | {\r |
896 | M_THROW(Scratch);\r |
897 | }\r |
898 | else\r |
899 | {\r |
900 | M_DROP;\r |
901 | }\r |
902 | endcase;\r |
903 | \r |
904 | case ID_EMIT_P:\r |
905 | EMIT( (char) TOS );\r |
906 | M_DROP;\r |
907 | endcase;\r |
908 | \r |
909 | case ID_EXECUTE:\r |
910 | /* Save IP on return stack like a JSR. */\r |
911 | M_R_PUSH( InsPtr );\r |
912 | #ifdef PF_SUPPORT_TRACE\r |
913 | /* Bump level for trace. */\r |
914 | Level++;\r |
915 | #endif\r |
916 | if( IsTokenPrimitive( TOS ) )\r |
917 | {\r |
1cb310e6 |
918 | WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */\r |
bb6b2dcd |
919 | InsPtr = &FakeSecondary[0];\r |
920 | }\r |
921 | else\r |
922 | {\r |
1cb310e6 |
923 | InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);\r |
bb6b2dcd |
924 | }\r |
925 | M_DROP;\r |
926 | endcase;\r |
927 | \r |
928 | case ID_FETCH:\r |
929 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
930 | if( IN_DICS( TOS ) )\r |
931 | {\r |
1cb310e6 |
932 | TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);\r |
bb6b2dcd |
933 | }\r |
934 | else\r |
935 | {\r |
1cb310e6 |
936 | TOS = *((cell_t *)TOS);\r |
bb6b2dcd |
937 | }\r |
938 | #else\r |
1cb310e6 |
939 | TOS = *((cell_t *)TOS);\r |
bb6b2dcd |
940 | #endif\r |
941 | endcase;\r |
942 | \r |
943 | case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */\r |
944 | /* Build NUL terminated name string. */\r |
945 | Scratch = M_POP; /* u */\r |
946 | Temp = M_POP; /* caddr */\r |
947 | if( Scratch < TIB_SIZE-2 )\r |
948 | {\r |
acc3c8bd |
949 | const char *famText = pfSelectFileModeCreate( TOS );\r |
1cb310e6 |
950 | pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r |
bb6b2dcd |
951 | gScratch[Scratch] = '\0';\r |
987bbb7d |
952 | DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));\r |
bb6b2dcd |
953 | FileID = sdOpenFile( gScratch, famText );\r |
954 | TOS = ( FileID == NULL ) ? -1 : 0 ;\r |
1cb310e6 |
955 | M_PUSH( (cell_t) FileID );\r |
bb6b2dcd |
956 | }\r |
957 | else\r |
958 | {\r |
959 | ERR("Filename too large for name buffer.\n");\r |
960 | M_PUSH( 0 );\r |
961 | TOS = -2;\r |
962 | }\r |
963 | endcase;\r |
964 | \r |
81dfa5e0 |
965 | case ID_FILE_DELETE: /* ( c-addr u -- ior ) */\r |
966 | /* Build NUL terminated name string. */\r |
967 | Temp = M_POP; /* caddr */\r |
968 | if( TOS < TIB_SIZE-2 )\r |
969 | {\r |
970 | pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );\r |
971 | gScratch[TOS] = '\0';\r |
972 | DBUG(("Delete file = %s\n", gScratch ));\r |
973 | TOS = sdDeleteFile( gScratch );\r |
974 | }\r |
975 | else\r |
976 | {\r |
977 | ERR("Filename too large for name buffer.\n");\r |
978 | TOS = -2;\r |
979 | }\r |
980 | endcase;\r |
981 | \r |
bb6b2dcd |
982 | case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */\r |
983 | /* Build NUL terminated name string. */\r |
984 | Scratch = M_POP; /* u */\r |
985 | Temp = M_POP; /* caddr */\r |
986 | if( Scratch < TIB_SIZE-2 )\r |
987 | {\r |
acc3c8bd |
988 | const char *famText = pfSelectFileModeOpen( TOS );\r |
1cb310e6 |
989 | pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r |
bb6b2dcd |
990 | gScratch[Scratch] = '\0';\r |
991 | DBUG(("Open file = %s\n", gScratch ));\r |
992 | FileID = sdOpenFile( gScratch, famText );\r |
993 | \r |
994 | TOS = ( FileID == NULL ) ? -1 : 0 ;\r |
1cb310e6 |
995 | M_PUSH( (cell_t) FileID );\r |
bb6b2dcd |
996 | }\r |
997 | else\r |
998 | {\r |
999 | ERR("Filename too large for name buffer.\n");\r |
1000 | M_PUSH( 0 );\r |
1001 | TOS = -2;\r |
1002 | }\r |
1003 | endcase;\r |
1004 | \r |
1005 | case ID_FILE_CLOSE: /* ( fid -- ior ) */\r |
1006 | TOS = sdCloseFile( (FileStream *) TOS );\r |
1007 | endcase;\r |
1008 | \r |
1009 | case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */\r |
1010 | FileID = (FileStream *) TOS;\r |
1011 | Scratch = M_POP;\r |
1012 | CharPtr = (char *) M_POP;\r |
1013 | Temp = sdReadFile( CharPtr, 1, Scratch, FileID );\r |
1014 | M_PUSH(Temp);\r |
1015 | TOS = 0;\r |
1016 | endcase;\r |
1017 | \r |
1018 | case ID_FILE_SIZE: /* ( fid -- ud ior ) */\r |
1019 | /* Determine file size by seeking to end and returning position. */\r |
1020 | FileID = (FileStream *) TOS;\r |
336369a5 |
1021 | {\r |
1022 | off_t endposition, offsetHi;\r |
1023 | off_t original = sdTellFile( FileID );\r |
1024 | sdSeekFile( FileID, 0, PF_SEEK_END );\r |
1025 | endposition = sdTellFile( FileID );\r |
1026 | M_PUSH(endposition);\r |
1027 | // Just use a 0 if they are the same size.\r |
1028 | offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (endposition >> (8*sizeof(cell_t))) : 0 ;\r |
1029 | M_PUSH(offsetHi);\r |
1030 | sdSeekFile( FileID, original, PF_SEEK_SET );\r |
1031 | TOS = (original < 0) ? -4 : 0 ; /* !!! err num */\r |
1032 | }\r |
bb6b2dcd |
1033 | endcase;\r |
1034 | \r |
1035 | case ID_FILE_WRITE: /* ( addr len fid -- ior ) */\r |
1036 | FileID = (FileStream *) TOS;\r |
1037 | Scratch = M_POP;\r |
1038 | CharPtr = (char *) M_POP;\r |
1039 | Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );\r |
1040 | TOS = (Temp != Scratch) ? -3 : 0;\r |
1041 | endcase;\r |
1042 | \r |
336369a5 |
1043 | case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */ \r |
1044 | {\r |
1045 | FileID = (FileStream *) TOS;\r |
1046 | off_t offset = M_POP;\r |
1047 | // Avoid compiler warnings on Mac.\r |
1048 | offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ;\r |
1049 | offset += M_POP;\r |
1050 | TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );\r |
1051 | }\r |
bb6b2dcd |
1052 | endcase;\r |
1053 | \r |
336369a5 |
1054 | case ID_FILE_POSITION: /* ( fid -- ud ior ) */\r |
1055 | {\r |
1056 | off_t offsetHi;\r |
1057 | FileID = (FileStream *) TOS;\r |
1058 | off_t position = sdTellFile( FileID );\r |
1059 | M_PUSH(position);\r |
1060 | // Just use a 0 if they are the same size.\r |
1061 | offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ;\r |
1062 | M_PUSH(offsetHi);\r |
1063 | TOS = (position < 0) ? -4 : 0 ; /* !!! err num */\r |
1064 | }\r |
bb6b2dcd |
1065 | endcase;\r |
1066 | \r |
1067 | case ID_FILE_RO: /* ( -- fam ) */\r |
1068 | PUSH_TOS;\r |
1069 | TOS = PF_FAM_READ_ONLY;\r |
1070 | endcase;\r |
1071 | \r |
1072 | case ID_FILE_RW: /* ( -- fam ) */\r |
1073 | PUSH_TOS;\r |
1074 | TOS = PF_FAM_READ_WRITE;\r |
1075 | endcase;\r |
1076 | \r |
1077 | case ID_FILE_WO: /* ( -- fam ) */\r |
1078 | PUSH_TOS;\r |
1079 | TOS = PF_FAM_WRITE_ONLY;\r |
1080 | endcase;\r |
1081 | \r |
1082 | case ID_FILE_BIN: /* ( -- fam ) */\r |
1083 | TOS = TOS | PF_FAM_BINARY_FLAG;\r |
1084 | endcase;\r |
1085 | \r |
1086 | case ID_FILL: /* ( caddr num charval -- ) */\r |
1087 | {\r |
1088 | register char *DstPtr;\r |
1089 | Temp = M_POP; /* num */\r |
1090 | DstPtr = (char *) M_POP; /* dst */\r |
1cb310e6 |
1091 | for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )\r |
bb6b2dcd |
1092 | {\r |
1093 | *DstPtr++ = (char) TOS;\r |
1094 | }\r |
1095 | M_DROP;\r |
1096 | }\r |
1097 | endcase;\r |
1098 | \r |
1099 | #ifndef PF_NO_SHELL\r |
1100 | case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */\r |
1101 | TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );\r |
1102 | M_PUSH( Temp );\r |
1103 | endcase;\r |
1104 | \r |
1105 | case ID_FINDNFA:\r |
1106 | TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );\r |
1cb310e6 |
1107 | M_PUSH( (cell_t) Temp );\r |
bb6b2dcd |
1108 | endcase;\r |
1109 | #endif /* !PF_NO_SHELL */\r |
1110 | \r |
1111 | case ID_FLUSHEMIT:\r |
1112 | sdTerminalFlush();\r |
1113 | endcase;\r |
1114 | \r |
1115 | /* Validate memory before freeing. Clobber validator and first word. */\r |
1116 | case ID_FREE: /* ( addr -- result ) */\r |
1117 | if( TOS == 0 )\r |
1118 | {\r |
1119 | ERR("FREE passed NULL!\n");\r |
1120 | TOS = -2; /* FIXME error code */\r |
1121 | }\r |
1122 | else\r |
1123 | {\r |
1cb310e6 |
1124 | CellPtr = (cell_t *) TOS;\r |
bb6b2dcd |
1125 | CellPtr--;\r |
1cb310e6 |
1126 | if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))\r |
bb6b2dcd |
1127 | {\r |
1128 | TOS = -2; /* FIXME error code */\r |
1129 | }\r |
1130 | else\r |
1131 | {\r |
1132 | CellPtr[0] = 0xDeadBeef;\r |
1133 | pfFreeMem((char *)CellPtr);\r |
1134 | TOS = 0;\r |
1135 | }\r |
1136 | }\r |
1137 | endcase;\r |
1138 | \r |
1139 | #include "pfinnrfp.h"\r |
1140 | \r |
1141 | case ID_HERE:\r |
1142 | PUSH_TOS;\r |
1cb310e6 |
1143 | TOS = (cell_t)CODE_HERE;\r |
bb6b2dcd |
1144 | endcase;\r |
1145 | \r |
1146 | case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */\r |
1147 | /* Convert using number converter in 'C'.\r |
1148 | ** Only supports single precision for bootstrap.\r |
1149 | */\r |
1cb310e6 |
1150 | TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );\r |
bb6b2dcd |
1151 | if( TOS == NUM_TYPE_SINGLE)\r |
1152 | {\r |
1153 | M_PUSH( Temp ); /* Push single number */\r |
1154 | }\r |
1155 | endcase;\r |
1156 | \r |
1157 | case ID_I: /* ( -- i , DO LOOP index ) */\r |
1158 | PUSH_TOS;\r |
1159 | TOS = M_R_PICK(1);\r |
1160 | endcase;\r |
1161 | \r |
1162 | #ifndef PF_NO_SHELL\r |
1163 | case ID_INCLUDE_FILE:\r |
1164 | FileID = (FileStream *) TOS;\r |
1165 | M_DROP; /* Drop now so that INCLUDE has a clean stack. */\r |
1166 | SAVE_REGISTERS;\r |
1167 | Scratch = ffIncludeFile( FileID );\r |
1168 | LOAD_REGISTERS;\r |
1169 | if( Scratch ) M_THROW(Scratch)\r |
1170 | endcase;\r |
1171 | #endif /* !PF_NO_SHELL */\r |
1172 | \r |
1173 | #ifndef PF_NO_SHELL\r |
1174 | case ID_INTERPRET:\r |
1175 | SAVE_REGISTERS;\r |
1176 | Scratch = ffInterpret();\r |
1177 | LOAD_REGISTERS;\r |
1178 | if( Scratch ) M_THROW(Scratch)\r |
1179 | endcase;\r |
1180 | #endif /* !PF_NO_SHELL */\r |
1181 | \r |
1182 | case ID_J: /* ( -- j , second DO LOOP index ) */\r |
1183 | PUSH_TOS;\r |
1184 | TOS = M_R_PICK(3);\r |
1185 | endcase;\r |
1186 | \r |
1187 | case ID_KEY:\r |
1188 | PUSH_TOS;\r |
1189 | TOS = ioKey();\r |
1190 | endcase;\r |
1191 | \r |
1192 | #ifndef PF_NO_SHELL\r |
1193 | case ID_LITERAL:\r |
1194 | ffLiteral( TOS );\r |
1195 | M_DROP;\r |
1196 | endcase;\r |
1197 | #endif /* !PF_NO_SHELL */\r |
1198 | \r |
1199 | case ID_LITERAL_P:\r |
1200 | DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));\r |
1201 | PUSH_TOS;\r |
1cb310e6 |
1202 | TOS = READ_CELL_DIC(InsPtr++);\r |
bb6b2dcd |
1203 | endcase;\r |
1204 | \r |
1205 | #ifndef PF_NO_SHELL\r |
1206 | case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;\r |
1207 | #endif /* !PF_NO_SHELL */\r |
1208 | \r |
1209 | case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */\r |
1210 | TOS = *(LocalsPtr - TOS);\r |
1211 | endcase;\r |
1212 | \r |
1213 | #define LOCAL_FETCH_N(num) \\r |
1214 | case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \\r |
1215 | PUSH_TOS; \\r |
1216 | TOS = *(LocalsPtr -(num)); \\r |
1217 | endcase;\r |
1218 | \r |
1219 | LOCAL_FETCH_N(1);\r |
1220 | LOCAL_FETCH_N(2);\r |
1221 | LOCAL_FETCH_N(3);\r |
1222 | LOCAL_FETCH_N(4);\r |
1223 | LOCAL_FETCH_N(5);\r |
1224 | LOCAL_FETCH_N(6);\r |
1225 | LOCAL_FETCH_N(7);\r |
1226 | LOCAL_FETCH_N(8);\r |
1227 | \r |
1228 | case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */\r |
1229 | *(LocalsPtr - TOS) = M_POP;\r |
1230 | M_DROP;\r |
1231 | endcase;\r |
1232 | \r |
1233 | #define LOCAL_STORE_N(num) \\r |
1234 | case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \\r |
1235 | *(LocalsPtr - (num)) = TOS; \\r |
1236 | M_DROP; \\r |
1237 | endcase;\r |
1238 | \r |
1239 | LOCAL_STORE_N(1);\r |
1240 | LOCAL_STORE_N(2);\r |
1241 | LOCAL_STORE_N(3);\r |
1242 | LOCAL_STORE_N(4);\r |
1243 | LOCAL_STORE_N(5);\r |
1244 | LOCAL_STORE_N(6);\r |
1245 | LOCAL_STORE_N(7);\r |
1246 | LOCAL_STORE_N(8);\r |
1247 | \r |
1248 | case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */\r |
1249 | *(LocalsPtr - TOS) += M_POP;\r |
1250 | M_DROP;\r |
1251 | endcase;\r |
1252 | \r |
1253 | case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */\r |
1254 | /* create local stack frame */\r |
1255 | {\r |
1cb310e6 |
1256 | cell_t i = TOS;\r |
1257 | cell_t *lp;\r |
bb6b2dcd |
1258 | DBUG(("LocalEntry: n = %d\n", TOS));\r |
1259 | /* End of locals. Create stack frame */\r |
1260 | DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",\r |
1261 | TORPTR, LocalsPtr));\r |
1262 | M_R_PUSH(LocalsPtr);\r |
1263 | LocalsPtr = TORPTR;\r |
1264 | TORPTR -= TOS;\r |
1265 | DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",\r |
1266 | TORPTR, LocalsPtr));\r |
1267 | lp = TORPTR;\r |
1268 | while(i-- > 0)\r |
1269 | {\r |
1270 | *lp++ = M_POP; /* Load local vars from stack */\r |
1271 | }\r |
1272 | M_DROP;\r |
1273 | }\r |
1274 | endcase;\r |
1275 | \r |
1276 | case ID_LOCAL_EXIT: /* cleanup up local stack frame */\r |
1277 | DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",\r |
1278 | TORPTR, LocalsPtr));\r |
1279 | TORPTR = LocalsPtr;\r |
1cb310e6 |
1280 | LocalsPtr = (cell_t *) M_R_POP;\r |
bb6b2dcd |
1281 | DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",\r |
1282 | TORPTR, LocalsPtr));\r |
1283 | endcase;\r |
1284 | \r |
1285 | #ifndef PF_NO_SHELL\r |
1286 | case ID_LOADSYS:\r |
1287 | MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;\r |
1288 | FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");\r |
1289 | if( FileID )\r |
1290 | {\r |
1291 | SAVE_REGISTERS;\r |
1292 | Scratch = ffIncludeFile( FileID );\r |
1293 | LOAD_REGISTERS;\r |
1294 | sdCloseFile( FileID );\r |
1295 | if( Scratch ) M_THROW(Scratch);\r |
1296 | }\r |
1297 | else\r |
1298 | {\r |
1299 | ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");\r |
1300 | }\r |
1301 | endcase;\r |
1302 | #endif /* !PF_NO_SHELL */\r |
1303 | \r |
1304 | case ID_LEAVE_P: /* ( R: index limit -- ) */\r |
1305 | M_R_DROP;\r |
1306 | M_R_DROP;\r |
1307 | M_BRANCH;\r |
1308 | endcase;\r |
1309 | \r |
1310 | case ID_LOOP_P: /* ( R: index limit -- | index limit ) */\r |
1311 | Temp = M_R_POP; /* limit */\r |
1312 | Scratch = M_R_POP + 1; /* index */\r |
1313 | if( Scratch == Temp )\r |
1314 | {\r |
1315 | InsPtr++; /* skip branch offset, exit loop */\r |
1316 | }\r |
1317 | else\r |
1318 | {\r |
1319 | /* Push index and limit back to R */\r |
1320 | M_R_PUSH( Scratch );\r |
1321 | M_R_PUSH( Temp );\r |
1322 | /* Branch back to just after (DO) */\r |
1323 | M_BRANCH;\r |
1324 | }\r |
1325 | endcase;\r |
1326 | \r |
1327 | case ID_LSHIFT: BINARY_OP( << ); endcase;\r |
1328 | \r |
1329 | case ID_MAX:\r |
1330 | Scratch = M_POP;\r |
1331 | TOS = ( TOS > Scratch ) ? TOS : Scratch ;\r |
1332 | endcase;\r |
1333 | \r |
1334 | case ID_MIN:\r |
1335 | Scratch = M_POP;\r |
1336 | TOS = ( TOS < Scratch ) ? TOS : Scratch ;\r |
1337 | endcase;\r |
1338 | \r |
1339 | case ID_MINUS: BINARY_OP( - ); endcase;\r |
1340 | \r |
1341 | #ifndef PF_NO_SHELL\r |
1342 | case ID_NAME_TO_TOKEN:\r |
1cb310e6 |
1343 | TOS = (cell_t) NameToToken((ForthString *)TOS);\r |
bb6b2dcd |
1344 | endcase;\r |
1345 | \r |
1346 | case ID_NAME_TO_PREVIOUS:\r |
1cb310e6 |
1347 | TOS = (cell_t) NameToPrevious((ForthString *)TOS);\r |
bb6b2dcd |
1348 | endcase;\r |
1349 | #endif\r |
1350 | \r |
1351 | case ID_NOOP:\r |
1352 | endcase;\r |
1353 | \r |
1354 | case ID_OR: BINARY_OP( | ); endcase;\r |
1355 | \r |
1356 | case ID_OVER:\r |
1357 | PUSH_TOS;\r |
1358 | TOS = M_STACK(1);\r |
1359 | endcase;\r |
1360 | \r |
1361 | case ID_PICK: /* ( ... n -- sp(n) ) */\r |
1362 | TOS = M_STACK(TOS);\r |
1363 | endcase;\r |
1364 | \r |
1365 | case ID_PLUS: BINARY_OP( + ); endcase;\r |
1366 | \r |
1367 | case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */\r |
1368 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1369 | if( IN_DICS( TOS ) )\r |
1370 | {\r |
1cb310e6 |
1371 | Scratch = READ_CELL_DIC((cell_t *)TOS);\r |
bb6b2dcd |
1372 | Scratch += M_POP;\r |
1cb310e6 |
1373 | WRITE_CELL_DIC((cell_t *)TOS,Scratch);\r |
bb6b2dcd |
1374 | }\r |
1375 | else\r |
1376 | {\r |
1cb310e6 |
1377 | *((cell_t *)TOS) += M_POP;\r |
bb6b2dcd |
1378 | }\r |
1379 | #else\r |
1cb310e6 |
1380 | *((cell_t *)TOS) += M_POP;\r |
bb6b2dcd |
1381 | #endif\r |
1382 | M_DROP;\r |
1383 | endcase;\r |
1384 | \r |
1385 | case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */\r |
1386 | {\r |
1cb310e6 |
1387 | ucell_t OldIndex, NewIndex, Limit;\r |
bb6b2dcd |
1388 | \r |
1389 | Limit = M_R_POP;\r |
1390 | OldIndex = M_R_POP;\r |
1391 | NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */\r |
1392 | /* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r |
1393 | if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r |
1394 | ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r |
1395 | {\r |
1396 | InsPtr++; /* skip branch offset, exit loop */\r |
1397 | }\r |
1398 | else\r |
1399 | {\r |
1400 | /* Push index and limit back to R */\r |
1401 | M_R_PUSH( NewIndex );\r |
1402 | M_R_PUSH( Limit );\r |
1403 | /* Branch back to just after (DO) */\r |
1404 | M_BRANCH;\r |
1405 | }\r |
1406 | M_DROP;\r |
1407 | }\r |
1408 | endcase;\r |
1409 | \r |
1410 | case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */\r |
1411 | Scratch = M_POP; /* limit */\r |
1412 | if( Scratch == TOS )\r |
1413 | {\r |
1414 | /* Branch to just after (LOOP) */\r |
1415 | M_BRANCH;\r |
1416 | }\r |
1417 | else\r |
1418 | {\r |
1419 | M_R_PUSH( TOS );\r |
1420 | M_R_PUSH( Scratch );\r |
1421 | InsPtr++; /* skip branch offset, enter loop */\r |
1422 | }\r |
1423 | M_DROP;\r |
1424 | endcase;\r |
1425 | \r |
1426 | case ID_QDUP: if( TOS ) M_DUP; endcase;\r |
1427 | \r |
1428 | case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */\r |
1429 | PUSH_TOS;\r |
1430 | TOS = sdQueryTerminal();\r |
1431 | endcase;\r |
1432 | \r |
1433 | case ID_QUIT_P: /* Stop inner interpreter, go back to user. */\r |
1434 | #ifdef PF_SUPPORT_TRACE\r |
1435 | Level = 0;\r |
1436 | #endif\r |
1437 | M_THROW(THROW_QUIT);\r |
1438 | endcase;\r |
1439 | \r |
1440 | case ID_R_DROP:\r |
1441 | M_R_DROP;\r |
1442 | endcase;\r |
1443 | \r |
1444 | case ID_R_FETCH:\r |
1445 | PUSH_TOS;\r |
1446 | TOS = (*(TORPTR));\r |
1447 | endcase;\r |
1448 | \r |
1449 | case ID_R_FROM:\r |
1450 | PUSH_TOS;\r |
1451 | TOS = M_R_POP;\r |
1452 | endcase;\r |
1453 | \r |
1454 | case ID_REFILL:\r |
1455 | PUSH_TOS;\r |
1456 | TOS = (ffRefill() > 0) ? FTRUE : FFALSE;\r |
1457 | endcase;\r |
1458 | \r |
1459 | /* Resize memory allocated by ALLOCATE. */\r |
1460 | case ID_RESIZE: /* ( addr1 u -- addr2 result ) */\r |
1461 | {\r |
1cb310e6 |
1462 | cell_t *Addr1 = (cell_t *) M_POP;\r |
07618dcb |
1463 | // Point to validator below users address.\r |
1cb310e6 |
1464 | cell_t *FreePtr = Addr1 - 1;\r |
1465 | if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))\r |
bb6b2dcd |
1466 | {\r |
07618dcb |
1467 | // 090218 - Fixed bug, was returning zero.\r |
1468 | M_PUSH( Addr1 );\r |
bb6b2dcd |
1469 | TOS = -3;\r |
1470 | }\r |
1471 | else\r |
1472 | {\r |
1473 | /* Try to allocate. */\r |
1cb310e6 |
1474 | CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );\r |
bb6b2dcd |
1475 | if( CellPtr )\r |
1476 | {\r |
1477 | /* Copy memory including validation. */\r |
1cb310e6 |
1478 | pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );\r |
1479 | *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);\r |
07618dcb |
1480 | // 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub.\r |
1481 | // Increment past validator to user address.\r |
1cb310e6 |
1482 | M_PUSH( (cell_t) (CellPtr + 1) );\r |
07618dcb |
1483 | TOS = 0; // Result code.\r |
1484 | // Mark old cell as dead so we can't free it twice.\r |
bb6b2dcd |
1485 | FreePtr[0] = 0xDeadBeef;\r |
1486 | pfFreeMem((char *) FreePtr);\r |
1487 | }\r |
1488 | else\r |
1489 | {\r |
07618dcb |
1490 | // 090218 - Fixed bug, was returning zero.\r |
1491 | M_PUSH( Addr1 );\r |
bb6b2dcd |
1492 | TOS = -4; /* FIXME Fix error code. */\r |
1493 | }\r |
1494 | }\r |
1495 | }\r |
1496 | endcase;\r |
1497 | \r |
1498 | /*\r |
1499 | ** RP@ and RP! are called secondaries so we must\r |
1500 | ** account for the return address pushed before calling.\r |
1501 | */\r |
1502 | case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */\r |
1503 | PUSH_TOS;\r |
1cb310e6 |
1504 | TOS = (cell_t)TORPTR; /* value before calling RP@ */\r |
bb6b2dcd |
1505 | endcase;\r |
1506 | \r |
1507 | case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */\r |
1cb310e6 |
1508 | TORPTR = (cell_t *) TOS;\r |
bb6b2dcd |
1509 | M_DROP;\r |
1510 | endcase;\r |
1511 | \r |
1512 | case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */\r |
1513 | {\r |
1cb310e6 |
1514 | cell_t ri;\r |
1515 | cell_t *srcPtr, *dstPtr;\r |
bb6b2dcd |
1516 | Scratch = M_STACK(TOS);\r |
1517 | srcPtr = &M_STACK(TOS-1);\r |
1518 | dstPtr = &M_STACK(TOS);\r |
1519 | for( ri=0; ri<TOS; ri++ )\r |
1520 | {\r |
1521 | *dstPtr-- = *srcPtr--;\r |
1522 | }\r |
1523 | TOS = Scratch;\r |
1524 | STKPTR++;\r |
1525 | }\r |
1526 | endcase;\r |
1527 | \r |
1528 | case ID_ROT: /* ( a b c -- b c a ) */\r |
1529 | Scratch = M_POP; /* b */\r |
1530 | Temp = M_POP; /* a */\r |
1531 | M_PUSH( Scratch ); /* b */\r |
1532 | PUSH_TOS; /* c */\r |
1533 | TOS = Temp; /* a */\r |
1534 | endcase;\r |
1535 | \r |
1536 | /* Logical right shift */\r |
1cb310e6 |
1537 | case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase; \r |
bb6b2dcd |
1538 | \r |
1539 | #ifndef PF_NO_SHELL\r |
1540 | case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */\r |
1541 | {\r |
1cb310e6 |
1542 | cell_t NameSize, CodeSize, EntryPoint;\r |
bb6b2dcd |
1543 | CodeSize = TOS;\r |
1544 | NameSize = M_POP;\r |
1545 | EntryPoint = M_POP;\r |
1546 | ForthStringToC( gScratch, (char *) M_POP );\r |
1547 | TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );\r |
1548 | }\r |
1549 | endcase;\r |
1550 | #endif\r |
1551 | \r |
1552 | /* Source Stack\r |
1553 | ** EVALUATE >IN SourceID=(-1) 1111\r |
1554 | ** keyboard >IN SourceID=(0) 2222\r |
1555 | ** file >IN lineNumber filePos SourceID=(fileID)\r |
1556 | */\r |
1557 | case ID_SAVE_INPUT: /* FIXME - finish */\r |
1558 | {\r |
1559 | }\r |
1560 | endcase;\r |
1561 | \r |
1562 | case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */\r |
1563 | PUSH_TOS;\r |
1cb310e6 |
1564 | TOS = (cell_t)STKPTR;\r |
bb6b2dcd |
1565 | endcase;\r |
1566 | \r |
1567 | case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */\r |
1cb310e6 |
1568 | STKPTR = (cell_t *) TOS;\r |
bb6b2dcd |
1569 | M_DROP;\r |
1570 | endcase;\r |
1571 | \r |
1572 | case ID_STORE: /* ( n addr -- , write n to addr ) */\r |
1573 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1574 | if( IN_DICS( TOS ) )\r |
1575 | {\r |
b3ad2602 |
1576 | WRITE_CELL_DIC((cell_t *)TOS,M_POP);\r |
bb6b2dcd |
1577 | }\r |
1578 | else\r |
1579 | {\r |
1cb310e6 |
1580 | *((cell_t *)TOS) = M_POP;\r |
bb6b2dcd |
1581 | }\r |
1582 | #else\r |
1cb310e6 |
1583 | *((cell_t *)TOS) = M_POP;\r |
bb6b2dcd |
1584 | #endif\r |
1585 | M_DROP;\r |
1586 | endcase;\r |
1587 | \r |
1588 | case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */\r |
1589 | Scratch = M_POP; /* cnt */\r |
1590 | Temp = M_POP; /* addr */\r |
1591 | TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r |
1cb310e6 |
1592 | M_PUSH((cell_t) CharPtr);\r |
bb6b2dcd |
1593 | endcase;\r |
1594 | \r |
1595 | #ifndef PF_NO_SHELL\r |
1596 | case ID_SEMICOLON:\r |
1597 | SAVE_REGISTERS;\r |
1598 | Scratch = ffSemiColon();\r |
1599 | LOAD_REGISTERS;\r |
1600 | if( Scratch ) M_THROW( Scratch );\r |
1601 | endcase;\r |
1602 | #endif /* !PF_NO_SHELL */\r |
1603 | \r |
1604 | case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */\r |
1605 | Scratch = M_POP; /* cnt */\r |
1606 | Temp = M_POP; /* addr */\r |
1607 | TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r |
1cb310e6 |
1608 | M_PUSH((cell_t) CharPtr);\r |
bb6b2dcd |
1609 | endcase;\r |
1610 | \r |
1611 | case ID_SOURCE: /* ( -- c-addr num ) */\r |
1612 | PUSH_TOS;\r |
1cb310e6 |
1613 | M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );\r |
1614 | TOS = (cell_t) gCurrentTask->td_SourceNum;\r |
bb6b2dcd |
1615 | endcase;\r |
1616 | \r |
1617 | case ID_SOURCE_SET: /* ( c-addr num -- ) */\r |
1618 | gCurrentTask->td_SourcePtr = (char *) M_POP;\r |
1619 | gCurrentTask->td_SourceNum = TOS;\r |
1620 | M_DROP;\r |
1621 | endcase;\r |
1622 | \r |
1623 | case ID_SOURCE_ID:\r |
1624 | PUSH_TOS;\r |
1625 | TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;\r |
1626 | endcase;\r |
1627 | \r |
1628 | case ID_SOURCE_ID_POP:\r |
1629 | PUSH_TOS;\r |
1630 | TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;\r |
1631 | endcase;\r |
1632 | \r |
1633 | case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */\r |
1cb310e6 |
1634 | TOS = (cell_t)ffConvertSourceIDToStream( TOS );\r |
bb6b2dcd |
1635 | Scratch = ffPushInputStream((FileStream *) TOS );\r |
1636 | if( Scratch )\r |
1637 | {\r |
1638 | M_THROW(Scratch);\r |
1639 | }\r |
1640 | else M_DROP;\r |
1641 | endcase;\r |
1642 | \r |
1643 | case ID_SWAP:\r |
1644 | Scratch = TOS;\r |
1645 | TOS = *STKPTR;\r |
1646 | *STKPTR = Scratch;\r |
1647 | endcase;\r |
1648 | \r |
1649 | case ID_TEST1:\r |
1650 | PUSH_TOS;\r |
1651 | M_PUSH( 0x11 );\r |
1652 | M_PUSH( 0x22 );\r |
1653 | TOS = 0x33;\r |
1654 | endcase;\r |
1655 | \r |
1656 | case ID_TEST2:\r |
1657 | endcase;\r |
1658 | \r |
1659 | case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */\r |
1660 | if(TOS)\r |
1661 | {\r |
1662 | M_THROW(TOS);\r |
1663 | }\r |
1664 | else M_DROP;\r |
1665 | endcase;\r |
1666 | \r |
1667 | #ifndef PF_NO_SHELL\r |
1668 | case ID_TICK:\r |
1669 | PUSH_TOS;\r |
1670 | CharPtr = (char *) ffWord( (char) ' ' );\r |
1671 | TOS = ffFind( CharPtr, (ExecToken *) &Temp );\r |
1672 | if( TOS == 0 )\r |
1673 | {\r |
1674 | ERR("' could not find ");\r |
1675 | ioType( (char *) CharPtr+1, *CharPtr );\r |
1676 | M_THROW(-13);\r |
1677 | }\r |
1678 | else\r |
1679 | {\r |
1680 | TOS = Temp;\r |
1681 | }\r |
1682 | endcase;\r |
1683 | #endif /* !PF_NO_SHELL */\r |
1684 | \r |
1685 | case ID_TIMES: BINARY_OP( * ); endcase;\r |
1686 | \r |
1687 | case ID_TYPE:\r |
1688 | Scratch = M_POP; /* addr */\r |
1689 | ioType( (char *) Scratch, TOS );\r |
1690 | M_DROP;\r |
1691 | endcase;\r |
1692 | \r |
1693 | case ID_TO_R:\r |
1694 | M_R_PUSH( TOS );\r |
1695 | M_DROP;\r |
1696 | endcase;\r |
1697 | \r |
1698 | case ID_VAR_BASE: DO_VAR(gVarBase); endcase;\r |
1699 | case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;\r |
1700 | case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;\r |
1701 | case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;\r |
1702 | case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;\r |
1703 | case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;\r |
1704 | case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;\r |
1705 | case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;\r |
b3ad2602 |
1706 | case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;\r |
bb6b2dcd |
1707 | case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;\r |
1708 | case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;\r |
1709 | case ID_VAR_STATE: DO_VAR(gVarState); endcase;\r |
1710 | case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;\r |
1711 | case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;\r |
1712 | case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;\r |
1713 | case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;\r |
1714 | case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;\r |
1715 | \r |
1716 | case ID_WORD:\r |
1cb310e6 |
1717 | TOS = (cell_t) ffWord( (char) TOS );\r |
bb6b2dcd |
1718 | endcase;\r |
1719 | \r |
1720 | case ID_WORD_FETCH: /* ( waddr -- w ) */\r |
1721 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1722 | if( IN_DICS( TOS ) )\r |
1723 | {\r |
b3ad2602 |
1724 | TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);\r |
bb6b2dcd |
1725 | }\r |
1726 | else\r |
1727 | {\r |
1cb310e6 |
1728 | TOS = *((uint16_t *)TOS);\r |
bb6b2dcd |
1729 | }\r |
1730 | #else\r |
1cb310e6 |
1731 | TOS = *((uint16_t *)TOS);\r |
bb6b2dcd |
1732 | #endif\r |
1733 | endcase;\r |
1734 | \r |
1735 | case ID_WORD_STORE: /* ( w waddr -- ) */\r |
1736 | \r |
1737 | #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r |
1738 | if( IN_DICS( TOS ) )\r |
1739 | {\r |
b3ad2602 |
1740 | WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);\r |
bb6b2dcd |
1741 | }\r |
1742 | else\r |
1743 | {\r |
1cb310e6 |
1744 | *((uint16_t *)TOS) = (uint16_t) M_POP;\r |
bb6b2dcd |
1745 | }\r |
1746 | #else\r |
1cb310e6 |
1747 | *((uint16_t *)TOS) = (uint16_t) M_POP;\r |
bb6b2dcd |
1748 | #endif\r |
1749 | M_DROP;\r |
1750 | endcase;\r |
1751 | \r |
1752 | case ID_XOR: BINARY_OP( ^ ); endcase;\r |
1753 | \r |
1754 | \r |
1755 | /* Branch is followed by an offset relative to address of offset. */\r |
1756 | case ID_ZERO_BRANCH:\r |
1757 | DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));\r |
1758 | if( TOS == 0 )\r |
1759 | {\r |
1760 | M_BRANCH;\r |
1761 | }\r |
1762 | else\r |
1763 | {\r |
1764 | InsPtr++; /* skip over offset */\r |
1765 | }\r |
1766 | M_DROP;\r |
1767 | DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));\r |
1768 | endcase;\r |
1769 | \r |
1770 | default:\r |
1771 | ERR("pfCatch: Unrecognised token = 0x");\r |
1772 | ffDotHex(Token);\r |
1773 | ERR(" at 0x");\r |
1cb310e6 |
1774 | ffDotHex((cell_t) InsPtr);\r |
bb6b2dcd |
1775 | EMIT_CR;\r |
1776 | InsPtr = 0;\r |
1777 | endcase;\r |
1778 | }\r |
1779 | \r |
1cb310e6 |
1780 | if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */\r |
bb6b2dcd |
1781 | \r |
1782 | #ifdef PF_DEBUG\r |
1783 | M_DOTS;\r |
1784 | #endif\r |
1785 | \r |
1786 | #if 0\r |
1787 | if( _CrtCheckMemory() == 0 )\r |
1788 | {\r |
1789 | ERR("_CrtCheckMemory abort: InsPtr = 0x");\r |
1790 | ffDotHex((int)InsPtr);\r |
1791 | ERR("\n");\r |
1792 | }\r |
1793 | #endif\r |
1794 | \r |
1795 | } while( (InitialReturnStack - TORPTR) > 0 );\r |
1796 | \r |
1797 | SAVE_REGISTERS;\r |
1798 | \r |
1799 | return ExceptionReturnCode;\r |
1800 | }\r |