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