projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge pull request #13 from philburk/fixrom
[pforth] / csrc / pf_inner.c
CommitLineData
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 159static 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 198static const char *pfSelectFileModeCreate( int fam );\r
199static const char *pfSelectFileModeOpen( int fam );\r
200\r
201/**************************************************************/\r
202static 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 227static 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
256int 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
312DBUG(("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
483DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));\r
484 M_BRANCH;\r
485DBUGX(("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
833DBUG(("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
1760DBUGX(("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
1770DBUGX(("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
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.