projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fixed lots of warning and made code compatible with C89 and ANSI with -pedantic.
[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
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 157static 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 196static const char *pfSelectFileModeCreate( int fam );\r
197static const char *pfSelectFileModeOpen( int fam );\r
198\r
199/**************************************************************/\r
200static 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 225static 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
254int 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
310DBUG(("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
481DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));\r
482 M_BRANCH;\r
483DBUGX(("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
831DBUG(("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
a80283a7 1027 /* Just use a 0 if they are the same size. */\r
336369a5 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
a80283a7 1045 off_t offset;\r
336369a5 1046 FileID = (FileStream *) TOS;\r
a80283a7 1047 offset = M_POP;\r
1048 /* Avoid compiler warnings on Mac. */\r
336369a5 1049 offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ;\r
1050 offset += M_POP;\r
1051 TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );\r
1052 }\r
bb6b2dcd 1053 endcase;\r
1054\r
336369a5 1055 case ID_FILE_POSITION: /* ( fid -- ud ior ) */\r
1056 {\r
a80283a7 1057 off_t position;\r
336369a5 1058 off_t offsetHi;\r
1059 FileID = (FileStream *) TOS;\r
a80283a7 1060 position = sdTellFile( FileID );\r
336369a5 1061 M_PUSH(position);\r
a80283a7 1062 /* Just use a 0 if they are the same size. */\r
336369a5 1063 offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ;\r
1064 M_PUSH(offsetHi);\r
1065 TOS = (position < 0) ? -4 : 0 ; /* !!! err num */\r
1066 }\r
bb6b2dcd 1067 endcase;\r
1068\r
1069 case ID_FILE_RO: /* ( -- fam ) */\r
1070 PUSH_TOS;\r
1071 TOS = PF_FAM_READ_ONLY;\r
1072 endcase;\r
1073 \r
1074 case ID_FILE_RW: /* ( -- fam ) */\r
1075 PUSH_TOS;\r
1076 TOS = PF_FAM_READ_WRITE;\r
1077 endcase;\r
1078\r
1079 case ID_FILE_WO: /* ( -- fam ) */\r
1080 PUSH_TOS;\r
1081 TOS = PF_FAM_WRITE_ONLY;\r
1082 endcase;\r
1083\r
1084 case ID_FILE_BIN: /* ( -- fam ) */\r
1085 TOS = TOS | PF_FAM_BINARY_FLAG;\r
1086 endcase;\r
1087 \r
1088 case ID_FILL: /* ( caddr num charval -- ) */\r
1089 {\r
1090 register char *DstPtr;\r
1091 Temp = M_POP; /* num */\r
1092 DstPtr = (char *) M_POP; /* dst */\r
1cb310e6 1093 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )\r
bb6b2dcd 1094 {\r
1095 *DstPtr++ = (char) TOS;\r
1096 }\r
1097 M_DROP;\r
1098 }\r
1099 endcase;\r
1100 \r
1101#ifndef PF_NO_SHELL\r
1102 case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */\r
1103 TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );\r
1104 M_PUSH( Temp );\r
1105 endcase;\r
1106 \r
1107 case ID_FINDNFA:\r
1108 TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );\r
1cb310e6 1109 M_PUSH( (cell_t) Temp );\r
bb6b2dcd 1110 endcase;\r
1111#endif /* !PF_NO_SHELL */\r
1112\r
1113 case ID_FLUSHEMIT:\r
1114 sdTerminalFlush();\r
1115 endcase;\r
1116 \r
1117/* Validate memory before freeing. Clobber validator and first word. */\r
1118 case ID_FREE: /* ( addr -- result ) */\r
1119 if( TOS == 0 )\r
1120 {\r
1121 ERR("FREE passed NULL!\n");\r
1122 TOS = -2; /* FIXME error code */\r
1123 }\r
1124 else\r
1125 {\r
1cb310e6 1126 CellPtr = (cell_t *) TOS;\r
bb6b2dcd 1127 CellPtr--;\r
1cb310e6 1128 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))\r
bb6b2dcd 1129 {\r
1130 TOS = -2; /* FIXME error code */\r
1131 }\r
1132 else\r
1133 {\r
1134 CellPtr[0] = 0xDeadBeef;\r
1135 pfFreeMem((char *)CellPtr);\r
1136 TOS = 0;\r
1137 }\r
1138 }\r
1139 endcase;\r
1140 \r
1141#include "pfinnrfp.h"\r
1142\r
1143 case ID_HERE:\r
1144 PUSH_TOS;\r
1cb310e6 1145 TOS = (cell_t)CODE_HERE;\r
bb6b2dcd 1146 endcase;\r
1147 \r
1148 case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */\r
1149/* Convert using number converter in 'C'.\r
1150** Only supports single precision for bootstrap.\r
1151*/\r
1cb310e6 1152 TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );\r
bb6b2dcd 1153 if( TOS == NUM_TYPE_SINGLE)\r
1154 {\r
1155 M_PUSH( Temp ); /* Push single number */\r
1156 }\r
1157 endcase;\r
1158 \r
1159 case ID_I: /* ( -- i , DO LOOP index ) */\r
1160 PUSH_TOS;\r
1161 TOS = M_R_PICK(1);\r
1162 endcase;\r
1163\r
1164#ifndef PF_NO_SHELL\r
1165 case ID_INCLUDE_FILE:\r
1166 FileID = (FileStream *) TOS;\r
1167 M_DROP; /* Drop now so that INCLUDE has a clean stack. */\r
1168 SAVE_REGISTERS;\r
1169 Scratch = ffIncludeFile( FileID );\r
1170 LOAD_REGISTERS;\r
1171 if( Scratch ) M_THROW(Scratch)\r
1172 endcase;\r
1173#endif /* !PF_NO_SHELL */\r
1174 \r
1175#ifndef PF_NO_SHELL\r
1176 case ID_INTERPRET:\r
1177 SAVE_REGISTERS;\r
1178 Scratch = ffInterpret();\r
1179 LOAD_REGISTERS;\r
1180 if( Scratch ) M_THROW(Scratch)\r
1181 endcase;\r
1182#endif /* !PF_NO_SHELL */\r
1183\r
1184 case ID_J: /* ( -- j , second DO LOOP index ) */\r
1185 PUSH_TOS;\r
1186 TOS = M_R_PICK(3);\r
1187 endcase;\r
1188\r
1189 case ID_KEY:\r
1190 PUSH_TOS;\r
1191 TOS = ioKey();\r
1192 endcase;\r
1193 \r
1194#ifndef PF_NO_SHELL\r
1195 case ID_LITERAL:\r
1196 ffLiteral( TOS );\r
1197 M_DROP;\r
1198 endcase;\r
1199#endif /* !PF_NO_SHELL */\r
1200\r
1201 case ID_LITERAL_P:\r
1202 DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));\r
1203 PUSH_TOS;\r
1cb310e6 1204 TOS = READ_CELL_DIC(InsPtr++);\r
bb6b2dcd 1205 endcase;\r
1206 \r
1207#ifndef PF_NO_SHELL\r
1208 case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;\r
1209#endif /* !PF_NO_SHELL */\r
1210\r
1211 case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */\r
1212 TOS = *(LocalsPtr - TOS);\r
1213 endcase;\r
1214\r
1215#define LOCAL_FETCH_N(num) \\r
1216 case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \\r
1217 PUSH_TOS; \\r
1218 TOS = *(LocalsPtr -(num)); \\r
1219 endcase;\r
1220\r
1221 LOCAL_FETCH_N(1);\r
1222 LOCAL_FETCH_N(2);\r
1223 LOCAL_FETCH_N(3);\r
1224 LOCAL_FETCH_N(4);\r
1225 LOCAL_FETCH_N(5);\r
1226 LOCAL_FETCH_N(6);\r
1227 LOCAL_FETCH_N(7);\r
1228 LOCAL_FETCH_N(8);\r
1229 \r
1230 case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */\r
1231 *(LocalsPtr - TOS) = M_POP;\r
1232 M_DROP;\r
1233 endcase;\r
1234\r
1235#define LOCAL_STORE_N(num) \\r
1236 case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \\r
1237 *(LocalsPtr - (num)) = TOS; \\r
1238 M_DROP; \\r
1239 endcase;\r
1240\r
1241 LOCAL_STORE_N(1);\r
1242 LOCAL_STORE_N(2);\r
1243 LOCAL_STORE_N(3);\r
1244 LOCAL_STORE_N(4);\r
1245 LOCAL_STORE_N(5);\r
1246 LOCAL_STORE_N(6);\r
1247 LOCAL_STORE_N(7);\r
1248 LOCAL_STORE_N(8);\r
1249 \r
1250 case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */\r
1251 *(LocalsPtr - TOS) += M_POP;\r
1252 M_DROP;\r
1253 endcase;\r
1254 \r
1255 case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */\r
1256 /* create local stack frame */\r
1257 {\r
1cb310e6 1258 cell_t i = TOS;\r
1259 cell_t *lp;\r
bb6b2dcd 1260 DBUG(("LocalEntry: n = %d\n", TOS));\r
1261 /* End of locals. Create stack frame */\r
1262 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",\r
1263 TORPTR, LocalsPtr));\r
1264 M_R_PUSH(LocalsPtr);\r
1265 LocalsPtr = TORPTR;\r
1266 TORPTR -= TOS;\r
1267 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",\r
1268 TORPTR, LocalsPtr));\r
1269 lp = TORPTR;\r
1270 while(i-- > 0)\r
1271 {\r
1272 *lp++ = M_POP; /* Load local vars from stack */\r
1273 }\r
1274 M_DROP;\r
1275 }\r
1276 endcase;\r
1277\r
1278 case ID_LOCAL_EXIT: /* cleanup up local stack frame */\r
1279 DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",\r
1280 TORPTR, LocalsPtr));\r
1281 TORPTR = LocalsPtr;\r
1cb310e6 1282 LocalsPtr = (cell_t *) M_R_POP;\r
bb6b2dcd 1283 DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",\r
1284 TORPTR, LocalsPtr));\r
1285 endcase;\r
1286 \r
1287#ifndef PF_NO_SHELL\r
1288 case ID_LOADSYS:\r
1289 MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;\r
1290 FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");\r
1291 if( FileID )\r
1292 {\r
1293 SAVE_REGISTERS;\r
90975d26 1294 Scratch = ffIncludeFile( FileID ); /* Also closes the file. */\r
bb6b2dcd 1295 LOAD_REGISTERS;\r
bb6b2dcd 1296 if( Scratch ) M_THROW(Scratch);\r
1297 }\r
1298 else\r
1299 {\r
1300 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");\r
1301 }\r
1302 endcase;\r
1303#endif /* !PF_NO_SHELL */\r
1304\r
1305 case ID_LEAVE_P: /* ( R: index limit -- ) */\r
1306 M_R_DROP;\r
1307 M_R_DROP;\r
1308 M_BRANCH;\r
1309 endcase;\r
1310\r
1311 case ID_LOOP_P: /* ( R: index limit -- | index limit ) */\r
1312 Temp = M_R_POP; /* limit */\r
1313 Scratch = M_R_POP + 1; /* index */\r
1314 if( Scratch == Temp )\r
1315 {\r
1316 InsPtr++; /* skip branch offset, exit loop */\r
1317 }\r
1318 else\r
1319 {\r
1320/* Push index and limit back to R */\r
1321 M_R_PUSH( Scratch );\r
1322 M_R_PUSH( Temp );\r
1323/* Branch back to just after (DO) */\r
1324 M_BRANCH;\r
1325 }\r
1326 endcase;\r
1327 \r
1328 case ID_LSHIFT: BINARY_OP( << ); endcase;\r
1329 \r
1330 case ID_MAX:\r
1331 Scratch = M_POP;\r
1332 TOS = ( TOS > Scratch ) ? TOS : Scratch ;\r
1333 endcase;\r
1334 \r
1335 case ID_MIN:\r
1336 Scratch = M_POP;\r
1337 TOS = ( TOS < Scratch ) ? TOS : Scratch ;\r
1338 endcase;\r
1339 \r
1340 case ID_MINUS: BINARY_OP( - ); endcase;\r
1341 \r
1342#ifndef PF_NO_SHELL\r
1343 case ID_NAME_TO_TOKEN:\r
1cb310e6 1344 TOS = (cell_t) NameToToken((ForthString *)TOS);\r
bb6b2dcd 1345 endcase;\r
1346 \r
1347 case ID_NAME_TO_PREVIOUS:\r
1cb310e6 1348 TOS = (cell_t) NameToPrevious((ForthString *)TOS);\r
bb6b2dcd 1349 endcase;\r
1350#endif\r
1351 \r
1352 case ID_NOOP:\r
1353 endcase;\r
1354 \r
1355 case ID_OR: BINARY_OP( | ); endcase;\r
1356 \r
1357 case ID_OVER:\r
1358 PUSH_TOS;\r
1359 TOS = M_STACK(1);\r
1360 endcase;\r
1361 \r
1362 case ID_PICK: /* ( ... n -- sp(n) ) */\r
1363 TOS = M_STACK(TOS);\r
1364 endcase;\r
1365\r
1366 case ID_PLUS: BINARY_OP( + ); endcase;\r
1367 \r
1368 case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */\r
1369#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1370 if( IN_DICS( TOS ) )\r
1371 {\r
1cb310e6 1372 Scratch = READ_CELL_DIC((cell_t *)TOS);\r
bb6b2dcd 1373 Scratch += M_POP;\r
1cb310e6 1374 WRITE_CELL_DIC((cell_t *)TOS,Scratch);\r
bb6b2dcd 1375 }\r
1376 else\r
1377 {\r
1cb310e6 1378 *((cell_t *)TOS) += M_POP;\r
bb6b2dcd 1379 }\r
1380#else\r
1cb310e6 1381 *((cell_t *)TOS) += M_POP;\r
bb6b2dcd 1382#endif\r
1383 M_DROP;\r
1384 endcase;\r
1385\r
1386 case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */\r
1387 {\r
1cb310e6 1388 ucell_t OldIndex, NewIndex, Limit;\r
bb6b2dcd 1389\r
1390 Limit = M_R_POP;\r
1391 OldIndex = M_R_POP;\r
1392 NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */\r
1393/* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
1394 if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r
1395 ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
1396 {\r
1397 InsPtr++; /* skip branch offset, exit loop */\r
1398 }\r
1399 else\r
1400 {\r
1401/* Push index and limit back to R */\r
1402 M_R_PUSH( NewIndex );\r
1403 M_R_PUSH( Limit );\r
1404/* Branch back to just after (DO) */\r
1405 M_BRANCH;\r
1406 }\r
1407 M_DROP;\r
1408 }\r
1409 endcase;\r
1410\r
1411 case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */\r
1412 Scratch = M_POP; /* limit */\r
1413 if( Scratch == TOS )\r
1414 {\r
1415/* Branch to just after (LOOP) */\r
1416 M_BRANCH;\r
1417 }\r
1418 else\r
1419 {\r
1420 M_R_PUSH( TOS );\r
1421 M_R_PUSH( Scratch );\r
1422 InsPtr++; /* skip branch offset, enter loop */\r
1423 }\r
1424 M_DROP;\r
1425 endcase;\r
1426\r
1427 case ID_QDUP: if( TOS ) M_DUP; endcase;\r
1428\r
1429 case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */\r
1430 PUSH_TOS;\r
1431 TOS = sdQueryTerminal();\r
1432 endcase;\r
1433 \r
1434 case ID_QUIT_P: /* Stop inner interpreter, go back to user. */\r
1435#ifdef PF_SUPPORT_TRACE\r
1436 Level = 0;\r
1437#endif\r
1438 M_THROW(THROW_QUIT);\r
1439 endcase;\r
1440 \r
1441 case ID_R_DROP:\r
1442 M_R_DROP;\r
1443 endcase;\r
1444\r
1445 case ID_R_FETCH:\r
1446 PUSH_TOS;\r
1447 TOS = (*(TORPTR));\r
1448 endcase;\r
1449 \r
1450 case ID_R_FROM:\r
1451 PUSH_TOS;\r
1452 TOS = M_R_POP;\r
1453 endcase;\r
1454 \r
1455 case ID_REFILL:\r
1456 PUSH_TOS;\r
1457 TOS = (ffRefill() > 0) ? FTRUE : FFALSE;\r
1458 endcase;\r
1459 \r
1460/* Resize memory allocated by ALLOCATE. */\r
1461 case ID_RESIZE: /* ( addr1 u -- addr2 result ) */\r
1462 {\r
1cb310e6 1463 cell_t *Addr1 = (cell_t *) M_POP;\r
a80283a7 1464 /* Point to validator below users address. */\r
1cb310e6 1465 cell_t *FreePtr = Addr1 - 1;\r
1466 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))\r
bb6b2dcd 1467 {\r
a80283a7 1468 /* 090218 - Fixed bug, was returning zero. */\r
07618dcb 1469 M_PUSH( Addr1 );\r
bb6b2dcd 1470 TOS = -3;\r
1471 }\r
1472 else\r
1473 {\r
1474 /* Try to allocate. */\r
1cb310e6 1475 CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );\r
bb6b2dcd 1476 if( CellPtr )\r
1477 {\r
1478 /* Copy memory including validation. */\r
1cb310e6 1479 pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );\r
1480 *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);\r
a80283a7 1481 /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */\r
1482 /* Increment past validator to user address. */\r
1cb310e6 1483 M_PUSH( (cell_t) (CellPtr + 1) );\r
a80283a7 1484 TOS = 0; /* Result code. */\r
1485 /* Mark old cell as dead so we can't free it twice. */\r
bb6b2dcd 1486 FreePtr[0] = 0xDeadBeef;\r
1487 pfFreeMem((char *) FreePtr);\r
1488 }\r
1489 else\r
1490 {\r
a80283a7 1491 /* 090218 - Fixed bug, was returning zero. */\r
07618dcb 1492 M_PUSH( Addr1 );\r
bb6b2dcd 1493 TOS = -4; /* FIXME Fix error code. */\r
1494 }\r
1495 }\r
1496 }\r
1497 endcase;\r
1498 \r
1499/*\r
1500** RP@ and RP! are called secondaries so we must\r
1501** account for the return address pushed before calling.\r
1502*/\r
1503 case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */\r
1504 PUSH_TOS;\r
1cb310e6 1505 TOS = (cell_t)TORPTR; /* value before calling RP@ */\r
bb6b2dcd 1506 endcase;\r
1507 \r
1508 case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */\r
1cb310e6 1509 TORPTR = (cell_t *) TOS;\r
bb6b2dcd 1510 M_DROP;\r
1511 endcase;\r
1512 \r
1513 case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */\r
1514 {\r
1cb310e6 1515 cell_t ri;\r
1516 cell_t *srcPtr, *dstPtr;\r
bb6b2dcd 1517 Scratch = M_STACK(TOS);\r
1518 srcPtr = &M_STACK(TOS-1);\r
1519 dstPtr = &M_STACK(TOS);\r
1520 for( ri=0; ri<TOS; ri++ )\r
1521 {\r
1522 *dstPtr-- = *srcPtr--;\r
1523 }\r
1524 TOS = Scratch;\r
1525 STKPTR++;\r
1526 }\r
1527 endcase;\r
1528\r
1529 case ID_ROT: /* ( a b c -- b c a ) */\r
1530 Scratch = M_POP; /* b */\r
1531 Temp = M_POP; /* a */\r
1532 M_PUSH( Scratch ); /* b */\r
1533 PUSH_TOS; /* c */\r
1534 TOS = Temp; /* a */\r
1535 endcase;\r
1536\r
1537/* Logical right shift */\r
1cb310e6 1538 case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase; \r
bb6b2dcd 1539 \r
1540#ifndef PF_NO_SHELL\r
1541 case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */\r
1542 {\r
1cb310e6 1543 cell_t NameSize, CodeSize, EntryPoint;\r
bb6b2dcd 1544 CodeSize = TOS;\r
1545 NameSize = M_POP;\r
1546 EntryPoint = M_POP;\r
1547 ForthStringToC( gScratch, (char *) M_POP );\r
1548 TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );\r
1549 }\r
1550 endcase;\r
1551#endif\r
1552\r
1553/* Source Stack\r
1554** EVALUATE >IN SourceID=(-1) 1111\r
1555** keyboard >IN SourceID=(0) 2222\r
1556** file >IN lineNumber filePos SourceID=(fileID)\r
1557*/\r
1558 case ID_SAVE_INPUT: /* FIXME - finish */\r
1559 {\r
1560 }\r
1561 endcase;\r
1562\r
1563 case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */\r
1564 PUSH_TOS;\r
1cb310e6 1565 TOS = (cell_t)STKPTR;\r
bb6b2dcd 1566 endcase;\r
1567 \r
1568 case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */\r
1cb310e6 1569 STKPTR = (cell_t *) TOS;\r
bb6b2dcd 1570 M_DROP;\r
1571 endcase;\r
1572 \r
1573 case ID_STORE: /* ( n addr -- , write n to addr ) */\r
1574#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1575 if( IN_DICS( TOS ) )\r
1576 {\r
b3ad2602 1577 WRITE_CELL_DIC((cell_t *)TOS,M_POP);\r
bb6b2dcd 1578 }\r
1579 else\r
1580 {\r
1cb310e6 1581 *((cell_t *)TOS) = M_POP;\r
bb6b2dcd 1582 }\r
1583#else\r
1cb310e6 1584 *((cell_t *)TOS) = M_POP;\r
bb6b2dcd 1585#endif\r
1586 M_DROP;\r
1587 endcase;\r
1588\r
1589 case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */\r
1590 Scratch = M_POP; /* cnt */\r
1591 Temp = M_POP; /* addr */\r
1592 TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
1cb310e6 1593 M_PUSH((cell_t) CharPtr);\r
bb6b2dcd 1594 endcase;\r
1595 \r
1596#ifndef PF_NO_SHELL\r
1597 case ID_SEMICOLON:\r
1598 SAVE_REGISTERS;\r
1599 Scratch = ffSemiColon();\r
1600 LOAD_REGISTERS;\r
1601 if( Scratch ) M_THROW( Scratch );\r
1602 endcase;\r
1603#endif /* !PF_NO_SHELL */\r
1604 \r
1605 case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */\r
1606 Scratch = M_POP; /* cnt */\r
1607 Temp = M_POP; /* addr */\r
1608 TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
1cb310e6 1609 M_PUSH((cell_t) CharPtr);\r
bb6b2dcd 1610 endcase;\r
1611\r
1612 case ID_SOURCE: /* ( -- c-addr num ) */\r
1613 PUSH_TOS;\r
1cb310e6 1614 M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );\r
1615 TOS = (cell_t) gCurrentTask->td_SourceNum;\r
bb6b2dcd 1616 endcase;\r
1617 \r
1618 case ID_SOURCE_SET: /* ( c-addr num -- ) */\r
1619 gCurrentTask->td_SourcePtr = (char *) M_POP;\r
1620 gCurrentTask->td_SourceNum = TOS;\r
1621 M_DROP;\r
1622 endcase;\r
1623 \r
1624 case ID_SOURCE_ID:\r
1625 PUSH_TOS;\r
1626 TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;\r
1627 endcase;\r
1628 \r
1629 case ID_SOURCE_ID_POP:\r
1630 PUSH_TOS;\r
1631 TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;\r
1632 endcase;\r
1633 \r
1634 case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */\r
1cb310e6 1635 TOS = (cell_t)ffConvertSourceIDToStream( TOS );\r
bb6b2dcd 1636 Scratch = ffPushInputStream((FileStream *) TOS );\r
1637 if( Scratch )\r
1638 {\r
1639 M_THROW(Scratch);\r
1640 }\r
1641 else M_DROP;\r
1642 endcase;\r
1643 \r
1644 case ID_SWAP:\r
1645 Scratch = TOS;\r
1646 TOS = *STKPTR;\r
1647 *STKPTR = Scratch;\r
1648 endcase;\r
1649 \r
1650 case ID_TEST1:\r
1651 PUSH_TOS;\r
1652 M_PUSH( 0x11 );\r
1653 M_PUSH( 0x22 );\r
1654 TOS = 0x33;\r
1655 endcase;\r
1656\r
1657 case ID_TEST2:\r
1658 endcase;\r
1659\r
1660 case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */\r
1661 if(TOS)\r
1662 {\r
1663 M_THROW(TOS);\r
1664 }\r
1665 else M_DROP;\r
1666 endcase;\r
1667\r
1668#ifndef PF_NO_SHELL\r
1669 case ID_TICK:\r
1670 PUSH_TOS;\r
1671 CharPtr = (char *) ffWord( (char) ' ' );\r
1672 TOS = ffFind( CharPtr, (ExecToken *) &Temp );\r
1673 if( TOS == 0 )\r
1674 {\r
1675 ERR("' could not find ");\r
1676 ioType( (char *) CharPtr+1, *CharPtr );\r
1677 M_THROW(-13);\r
1678 }\r
1679 else\r
1680 {\r
1681 TOS = Temp;\r
1682 }\r
1683 endcase;\r
1684#endif /* !PF_NO_SHELL */\r
1685 \r
1686 case ID_TIMES: BINARY_OP( * ); endcase;\r
1687 \r
1688 case ID_TYPE:\r
1689 Scratch = M_POP; /* addr */\r
1690 ioType( (char *) Scratch, TOS );\r
1691 M_DROP;\r
1692 endcase;\r
1693\r
1694 case ID_TO_R:\r
1695 M_R_PUSH( TOS );\r
1696 M_DROP;\r
1697 endcase;\r
1698\r
1699 case ID_VAR_BASE: DO_VAR(gVarBase); endcase;\r
1700 case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;\r
1701 case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;\r
1702 case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;\r
1703 case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;\r
1704 case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;\r
1705 case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;\r
1706 case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;\r
b3ad2602 1707 case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;\r
bb6b2dcd 1708 case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;\r
1709 case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;\r
1710 case ID_VAR_STATE: DO_VAR(gVarState); endcase;\r
1711 case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;\r
1712 case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;\r
1713 case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;\r
1714 case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;\r
1715 case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;\r
1716\r
1717 case ID_WORD:\r
1cb310e6 1718 TOS = (cell_t) ffWord( (char) TOS );\r
bb6b2dcd 1719 endcase;\r
1720\r
1721 case ID_WORD_FETCH: /* ( waddr -- w ) */\r
1722#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1723 if( IN_DICS( TOS ) )\r
1724 {\r
b3ad2602 1725 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);\r
bb6b2dcd 1726 }\r
1727 else\r
1728 {\r
1cb310e6 1729 TOS = *((uint16_t *)TOS);\r
bb6b2dcd 1730 }\r
1731#else\r
1cb310e6 1732 TOS = *((uint16_t *)TOS);\r
bb6b2dcd 1733#endif\r
1734 endcase;\r
1735\r
1736 case ID_WORD_STORE: /* ( w waddr -- ) */\r
1737 \r
1738#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1739 if( IN_DICS( TOS ) )\r
1740 {\r
b3ad2602 1741 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);\r
bb6b2dcd 1742 }\r
1743 else\r
1744 {\r
1cb310e6 1745 *((uint16_t *)TOS) = (uint16_t) M_POP;\r
bb6b2dcd 1746 }\r
1747#else\r
1cb310e6 1748 *((uint16_t *)TOS) = (uint16_t) M_POP;\r
bb6b2dcd 1749#endif\r
1750 M_DROP;\r
1751 endcase;\r
1752\r
1753 case ID_XOR: BINARY_OP( ^ ); endcase;\r
1754 \r
1755 \r
1756/* Branch is followed by an offset relative to address of offset. */\r
1757 case ID_ZERO_BRANCH:\r
1758DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));\r
1759 if( TOS == 0 )\r
1760 {\r
1761 M_BRANCH;\r
1762 }\r
1763 else\r
1764 {\r
1765 InsPtr++; /* skip over offset */\r
1766 }\r
1767 M_DROP;\r
1768DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));\r
1769 endcase;\r
1770 \r
1771 default:\r
1772 ERR("pfCatch: Unrecognised token = 0x");\r
1773 ffDotHex(Token);\r
1774 ERR(" at 0x");\r
1cb310e6 1775 ffDotHex((cell_t) InsPtr);\r
bb6b2dcd 1776 EMIT_CR;\r
1777 InsPtr = 0;\r
1778 endcase;\r
1779 }\r
1780 \r
1cb310e6 1781 if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */\r
bb6b2dcd 1782 \r
1783#ifdef PF_DEBUG\r
1784 M_DOTS;\r
1785#endif\r
1786\r
1787#if 0\r
1788 if( _CrtCheckMemory() == 0 )\r
1789 {\r
1790 ERR("_CrtCheckMemory abort: InsPtr = 0x");\r
1791 ffDotHex((int)InsPtr);\r
1792 ERR("\n");\r
1793 }\r
1794#endif\r
1795\r
1796 } while( (InitialReturnStack - TORPTR) > 0 );\r
1797\r
1798 SAVE_REGISTERS;\r
1799 \r
1800 return ExceptionReturnCode;\r
1801}\r
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.