projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix cell increment error in RESIZE
[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
44#define M_PUSH(n) {*(--(STKPTR)) = (cell) (n);}\r
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
77#define M_R_PUSH(n) {*(--(TORPTR)) = (cell) (n);}\r
78\r
79/***************************************************************\r
80** Misc Forth macros\r
81***************************************************************/\r
82 \r
83#define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_DIC(InsPtr)); }\r
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
127#define DO_VAR(varname) { PUSH_TOS; TOS = (cell) &varname; }\r
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
157static void TraceNames( ExecToken Token, int32 Level )\r
158{\r
159 char *DebugName;\r
160 int32 i;\r
161 \r
162 if( ffTokenToName( Token, &DebugName ) )\r
163 {\r
164 cell NumSpaces;\r
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
194#define LOCAL_CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CodeBase))\r
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
256 register cell TopOfStack; /* Cache for faster execution. */\r
257 register cell *DataStackPtr;\r
258 register cell *ReturnStackPtr;\r
259 register cell *InsPtr = NULL;\r
260 register cell Token;\r
261 cell Scratch;\r
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
271 int32 Level = 0;\r
272#endif\r
273 cell *LocalsPtr = NULL;\r
274 cell Temp;\r
275 cell *InitialReturnStack;\r
276 cell *InitialDataStack;\r
277 cell FakeSecondary[2];\r
278 char *CharPtr;\r
279 cell *CellPtr;\r
280 FileStream *FileID;\r
281 uint8 *CodeBase = CODE_BASE;\r
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
330 InsPtr = (cell *) ( LOCAL_CODEREL_TO_ABS(Token) );\r
331\r
332/* Fetch token at IP. */\r
333 Token = READ_LONG_DIC(InsPtr++);\r
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
354 InsPtr = ( cell *) M_R_POP;\r
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
374 TOS = READ_LONG_DIC(InsPtr++);\r
375 M_PUSH(READ_LONG_DIC(InsPtr++));\r
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
437 TOS = (cell) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr++) );\r
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
444 if ( TOS < sizeof(cell) )\r
445 {\r
446 Temp = sizeof(cell);\r
447 }\r
448 else\r
449 {\r
450 Temp = TOS;\r
451 }\r
452 /* Allocate extra cells worth because we store validation info. */\r
453 CellPtr = (cell *) pfAllocMem( Temp + sizeof(cell) );\r
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
458 Temp = (int32)CellPtr ^ PF_MEMORY_VALIDATOR;\r
459 *CellPtr++ = Temp;\r
460 M_PUSH( (cell) CellPtr );\r
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
507 Scratch = READ_LONG_DIC(InsPtr++);\r
508 CallUserFunction( Scratch & 0xFFFF,\r
509 (Scratch >> 31) & 1,\r
510 (Scratch >> 24) & 0x7F );\r
511 LOAD_REGISTERS;\r
512 endcase;\r
513\r
514 case ID_CFETCH: TOS = *((uint8 *) TOS); endcase;\r
515\r
516 case ID_CMOVE: /* ( src dst n -- ) */\r
517 {\r
518 register char *DstPtr = (char *) M_POP; /* dst */\r
519 CharPtr = (char *) M_POP; /* src */\r
520 for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ )\r
521 {\r
522 *DstPtr++ = *CharPtr++;\r
523 }\r
524 M_DROP;\r
525 }\r
526 endcase;\r
527 \r
528 case ID_CMOVE_UP: /* ( src dst n -- ) */\r
529 {\r
530 register char *DstPtr = ((char *) M_POP) + TOS; /* dst */\r
531 CharPtr = ((char *) M_POP) + TOS;; /* src */\r
532 for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ )\r
533 {\r
534 *(--DstPtr) = *(--CharPtr);\r
535 }\r
536 M_DROP;\r
537 }\r
538 endcase;\r
539 \r
540#ifndef PF_NO_SHELL\r
541 case ID_COLON:\r
542 SAVE_REGISTERS;\r
543 ffColon( );\r
544 LOAD_REGISTERS;\r
545 endcase;\r
546 case ID_COLON_P: /* ( $name xt -- ) */\r
547 CreateDicEntry( TOS, (char *) M_POP, 0 );\r
548 M_DROP;\r
549 endcase;\r
550#endif /* !PF_NO_SHELL */\r
551\r
552 case ID_COMPARE:\r
553 {\r
554 const char *s1, *s2;\r
555 int32 len1;\r
556 s2 = (const char *) M_POP;\r
557 len1 = M_POP;\r
558 s1 = (const char *) M_POP;\r
559 TOS = ffCompare( s1, len1, s2, TOS );\r
560 }\r
561 endcase;\r
562 \r
563/* ( a b -- flag , Comparisons ) */\r
564 case ID_COMP_EQUAL:\r
565 TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;\r
566 endcase;\r
567 case ID_COMP_NOT_EQUAL:\r
568 TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;\r
569 endcase;\r
570 case ID_COMP_GREATERTHAN:\r
571 TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;\r
572 endcase;\r
573 case ID_COMP_LESSTHAN:\r
574 TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ;\r
575 endcase;\r
576 case ID_COMP_U_GREATERTHAN:\r
577 TOS = ( ((uint32)M_POP) > ((uint32)TOS) ) ? FTRUE : FFALSE ;\r
578 endcase;\r
579 case ID_COMP_U_LESSTHAN:\r
580 TOS = ( ((uint32)M_POP) < ((uint32)TOS) ) ? FTRUE : FFALSE ;\r
581 endcase;\r
582 case ID_COMP_ZERO_EQUAL:\r
583 TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;\r
584 endcase;\r
585 case ID_COMP_ZERO_NOT_EQUAL:\r
586 TOS = ( TOS != 0 ) ? FTRUE : FALSE ;\r
587 endcase;\r
588 case ID_COMP_ZERO_GREATERTHAN:\r
589 TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;\r
590 endcase;\r
591 case ID_COMP_ZERO_LESSTHAN:\r
592 TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;\r
593 endcase;\r
594 \r
595 case ID_CR:\r
596 EMIT_CR;\r
597 endcase;\r
598 \r
599#ifndef PF_NO_SHELL\r
600 case ID_CREATE:\r
601 SAVE_REGISTERS;\r
602 ffCreate();\r
603 LOAD_REGISTERS;\r
604 endcase;\r
605#endif /* !PF_NO_SHELL */\r
606\r
607 case ID_CREATE_P:\r
608 PUSH_TOS;\r
609/* Put address of body on stack. Insptr points after code start. */\r
610 TOS = (cell) ((char *)InsPtr - sizeof(cell) + CREATE_BODY_OFFSET );\r
611 endcase;\r
612 \r
613 case ID_CSTORE: /* ( c caddr -- ) */\r
614 *((uint8 *) TOS) = (uint8) M_POP;\r
615 M_DROP;\r
616 endcase;\r
617\r
618/* Double precision add. */\r
619 case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ \r
620 {\r
621 register ucell ah,al,bl,sh,sl;\r
622#define bh TOS\r
623 bl = M_POP;\r
624 ah = M_POP;\r
625 al = M_POP;\r
626 sh = 0;\r
627 sl = al + bl;\r
628 if( sl < bl ) sh = 1; /* Carry */\r
629 sh += ah + bh;\r
630 M_PUSH( sl );\r
631 TOS = sh;\r
632#undef bh\r
633 }\r
634 endcase;\r
635 \r
636/* Double precision subtract. */\r
637 case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */ \r
638 {\r
639 register ucell ah,al,bl,sh,sl;\r
640#define bh TOS\r
641 bl = M_POP;\r
642 ah = M_POP;\r
643 al = M_POP;\r
644 sh = 0;\r
645 sl = al - bl;\r
646 if( al < bl ) sh = 1; /* Borrow */\r
647 sh = ah - bh - sh;\r
648 M_PUSH( sl );\r
649 TOS = sh;\r
650#undef bh\r
651 }\r
652 endcase;\r
653 \r
654/* Perform 32*32 bit multiply for 64 bit result, by factoring into 16 bit quantities. */\r
655/* Using an improved algorithm suggested by Steve Green. */\r
656 case ID_D_UMTIMES: /* M* ( a b -- pl ph ) */ \r
657 {\r
658 ucell ahi, alo, bhi, blo, temp;\r
659 ucell pl, ph;\r
660/* Get values from stack. */\r
661 ahi = M_POP;\r
662 bhi = TOS;\r
663/* Break into hi and lo 16 bit parts. */\r
664 alo = ahi & 0xFFFF;\r
665 ahi = ahi>>16;\r
666 blo = bhi & 0xFFFF;\r
667 bhi = bhi>>16;\r
668 ph = 0;\r
669/* ahi * bhi */\r
670 pl = ahi * bhi;\r
671 ph = pl >> 16; /* shift 64 bit value by 16 */\r
672 pl = pl << 16;\r
673/* ahi * blo */\r
674 temp = ahi * blo;\r
675 pl += temp;\r
676 if( pl < temp ) ph += 1; /* Carry */\r
677/* alo * bhi */\r
678 temp = alo * bhi;\r
679 pl += temp;\r
680 if( pl < temp ) ph += 1; /* Carry */\r
681 ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */\r
682 pl = pl << 16;\r
683/* alo * blo */\r
684 temp = alo * blo;\r
685 pl += temp;\r
686 if( pl < temp ) ph += 1; /* Carry */\r
687\r
688 M_PUSH( pl );\r
689 TOS = ph;\r
690 }\r
691 endcase;\r
692 \r
693/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */\r
694 case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ \r
695 {\r
696 cell a,b;\r
697 ucell ap,bp, ahi, alo, bhi, blo, temp;\r
698 ucell pl, ph;\r
699/* Get values from stack. */\r
700 a = M_POP;\r
701 b = TOS;\r
702 ap = (a < 0) ? -a : a ; /* Positive A */\r
703 bp = (b < 0) ? -b : b ; /* Positive B */\r
704/* Break into hi and lo 16 bit parts. */\r
705 alo = ap & 0xFFFF;\r
706 ahi = ap>>16;\r
707 blo = bp & 0xFFFF;\r
708 bhi = bp>>16;\r
709 ph = 0;\r
710/* ahi * bhi */\r
711 pl = ahi * bhi;\r
712 ph = pl >> 16; /* shift 64 bit value by 16 */\r
713 pl = pl << 16;\r
714/* ahi * blo */\r
715 temp = ahi * blo;\r
716 pl += temp;\r
717 if( pl < temp ) ph += 1; /* Carry */\r
718/* alo * bhi */\r
719 temp = alo * bhi;\r
720 pl += temp;\r
721 if( pl < temp ) ph += 1; /* Carry */\r
722 ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */\r
723 pl = pl << 16;\r
724/* alo * blo */\r
725 temp = alo * blo;\r
726 pl += temp;\r
727 if( pl < temp ) ph += 1; /* Carry */\r
728\r
729/* Negate product if one operand negative. */\r
730 if( ((a ^ b) & 0x80000000) )\r
731 {\r
732 pl = 0-pl;\r
733 if( pl & 0x80000000 )\r
734 {\r
735 ph = -1 - ph; /* Borrow */\r
736 }\r
737 else\r
738 {\r
739 ph = 0 - ph;\r
740 }\r
741 }\r
742\r
743 M_PUSH( pl );\r
744 TOS = ph;\r
745 }\r
746 endcase;\r
747\r
748#define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )\r
749/* Perform 64/32 bit divide for 32 bit result, using shift and subtract. */\r
750 case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */ \r
751 {\r
752 ucell ah,al, q,di, bl,bh, sl,sh;\r
753 ah = M_POP;\r
754 al = M_POP;\r
755 bh = TOS;\r
756 bl = 0;\r
757 q = 0;\r
758 for( di=0; di<32; di++ )\r
759 {\r
760 if( !DULT(al,ah,bl,bh) )\r
761 {\r
762 sh = 0;\r
763 sl = al - bl;\r
764 if( al < bl ) sh = 1; /* Borrow */\r
765 sh = ah - bh - sh;\r
766 ah = sh;\r
767 al = sl;\r
768 q |= 1;\r
769 }\r
770 q = q << 1;\r
771 bl = (bl >> 1) | (bh << 31);\r
772 bh = bh >> 1;\r
773 }\r
774 if( !DULT(al,ah,bl,bh) )\r
775 {\r
776 \r
777 al = al - bl;\r
778 q |= 1;\r
779 }\r
780 M_PUSH( al ); /* rem */\r
781 TOS = q;\r
782 }\r
783 endcase;\r
784\r
785/* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */\r
786 case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ \r
787 {\r
788 register ucell ah,am,al,ql,qh,di;\r
789#define bdiv ((ucell)TOS)\r
790 ah = 0;\r
791 am = M_POP;\r
792 al = M_POP;\r
793 qh = ql = 0;\r
794 for( di=0; di<64; di++ )\r
795 {\r
796 if( bdiv <= ah )\r
797 {\r
798 ah = ah - bdiv;\r
799 ql |= 1;\r
800 }\r
801 qh = (qh << 1) | (ql >> 31);\r
802 ql = ql << 1;\r
803 ah = (ah << 1) | (am >> 31);\r
804 am = (am << 1) | (al >> 31);\r
805 al = al << 1;\r
806DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));\r
807 }\r
808 if( bdiv <= ah )\r
809 {\r
810 ah = ah - bdiv;\r
811 ql |= 1;\r
812 }\r
813 M_PUSH( ah ); /* rem */\r
814 M_PUSH( ql );\r
815 TOS = qh;\r
816#undef bdiv\r
817 }\r
818 endcase;\r
819\r
820#ifndef PF_NO_SHELL\r
821 case ID_DEFER:\r
822 ffDefer( );\r
823 endcase;\r
824#endif /* !PF_NO_SHELL */\r
825\r
826 case ID_DEFER_P:\r
827 endcase;\r
828\r
829 case ID_DEPTH:\r
830 PUSH_TOS;\r
831 TOS = gCurrentTask->td_StackBase - STKPTR;\r
832 endcase;\r
833 \r
834 case ID_DIVIDE: BINARY_OP( / ); endcase;\r
835 \r
836 case ID_DOT:\r
837 ffDot( TOS );\r
838 M_DROP;\r
839 endcase;\r
840 \r
841 case ID_DOTS:\r
842 M_DOTS;\r
843 endcase;\r
844 \r
845 case ID_DROP: M_DROP; endcase;\r
846 \r
847 case ID_DUMP:\r
848 Scratch = M_POP;\r
849 DumpMemory( (char *) Scratch, TOS );\r
850 M_DROP;\r
851 endcase;\r
852\r
853 case ID_DUP: M_DUP; endcase;\r
854 \r
855 case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */\r
856 M_R_PUSH( TOS );\r
857 M_R_PUSH( M_POP );\r
858 M_DROP;\r
859 endcase;\r
860 \r
861 case ID_EOL: /* ( -- end_of_line_char ) */\r
862 PUSH_TOS;\r
863 TOS = (cell) '\n';\r
864 endcase;\r
865 \r
866 case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */\r
867 Scratch = TOS;\r
868 M_DROP;\r
869 if(TOS)\r
870 {\r
871 M_THROW(Scratch);\r
872 }\r
873 else\r
874 {\r
875 M_DROP;\r
876 }\r
877 endcase;\r
878 \r
879 case ID_EMIT_P:\r
880 EMIT( (char) TOS );\r
881 M_DROP;\r
882 endcase;\r
883 \r
884 case ID_EXECUTE:\r
885/* Save IP on return stack like a JSR. */\r
886 M_R_PUSH( InsPtr );\r
887#ifdef PF_SUPPORT_TRACE\r
888/* Bump level for trace. */\r
889 Level++;\r
890#endif\r
891 if( IsTokenPrimitive( TOS ) )\r
892 {\r
893 WRITE_LONG_DIC( (cell *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */\r
894 InsPtr = &FakeSecondary[0];\r
895 }\r
896 else\r
897 {\r
898 InsPtr = (cell *) LOCAL_CODEREL_TO_ABS(TOS);\r
899 }\r
900 M_DROP;\r
901 endcase;\r
902 \r
903 case ID_FETCH:\r
904#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
905 if( IN_DICS( TOS ) )\r
906 {\r
907 TOS = (cell) READ_LONG_DIC((cell *)TOS);\r
908 }\r
909 else\r
910 {\r
911 TOS = *((cell *)TOS);\r
912 }\r
913#else\r
914 TOS = *((cell *)TOS);\r
915#endif\r
916 endcase;\r
917 \r
918 case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */\r
919/* Build NUL terminated name string. */\r
920 Scratch = M_POP; /* u */\r
921 Temp = M_POP; /* caddr */\r
922 if( Scratch < TIB_SIZE-2 )\r
923 {\r
acc3c8bd 924 const char *famText = pfSelectFileModeCreate( TOS );\r
bb6b2dcd 925 pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch );\r
926 gScratch[Scratch] = '\0';\r
987bbb7d 927 DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));\r
bb6b2dcd 928 FileID = sdOpenFile( gScratch, famText );\r
929 TOS = ( FileID == NULL ) ? -1 : 0 ;\r
930 M_PUSH( (cell) FileID );\r
931 }\r
932 else\r
933 {\r
934 ERR("Filename too large for name buffer.\n");\r
935 M_PUSH( 0 );\r
936 TOS = -2;\r
937 }\r
938 endcase;\r
939\r
940 case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */\r
941/* Build NUL terminated name string. */\r
942 Scratch = M_POP; /* u */\r
943 Temp = M_POP; /* caddr */\r
944 if( Scratch < TIB_SIZE-2 )\r
945 {\r
acc3c8bd 946 const char *famText = pfSelectFileModeOpen( TOS );\r
bb6b2dcd 947 pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch );\r
948 gScratch[Scratch] = '\0';\r
949 DBUG(("Open file = %s\n", gScratch ));\r
950 FileID = sdOpenFile( gScratch, famText );\r
951\r
952 TOS = ( FileID == NULL ) ? -1 : 0 ;\r
953 M_PUSH( (cell) FileID );\r
954 }\r
955 else\r
956 {\r
957 ERR("Filename too large for name buffer.\n");\r
958 M_PUSH( 0 );\r
959 TOS = -2;\r
960 }\r
961 endcase;\r
962 \r
963 case ID_FILE_CLOSE: /* ( fid -- ior ) */\r
964 TOS = sdCloseFile( (FileStream *) TOS );\r
965 endcase;\r
966 \r
967 case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */\r
968 FileID = (FileStream *) TOS;\r
969 Scratch = M_POP;\r
970 CharPtr = (char *) M_POP;\r
971 Temp = sdReadFile( CharPtr, 1, Scratch, FileID );\r
972 M_PUSH(Temp);\r
973 TOS = 0;\r
974 endcase;\r
975 \r
976 case ID_FILE_SIZE: /* ( fid -- ud ior ) */\r
977/* Determine file size by seeking to end and returning position. */\r
978 FileID = (FileStream *) TOS;\r
979 Scratch = sdTellFile( FileID );\r
980 sdSeekFile( FileID, 0, PF_SEEK_END );\r
981 M_PUSH( sdTellFile( FileID ));\r
982 sdSeekFile( FileID, Scratch, PF_SEEK_SET );\r
983 TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */\r
984 endcase;\r
985\r
986 case ID_FILE_WRITE: /* ( addr len fid -- ior ) */\r
987 FileID = (FileStream *) TOS;\r
988 Scratch = M_POP;\r
989 CharPtr = (char *) M_POP;\r
990 Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );\r
991 TOS = (Temp != Scratch) ? -3 : 0;\r
992 endcase;\r
993\r
994 case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */\r
995 FileID = (FileStream *) TOS;\r
996 Scratch = M_POP;\r
997 TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET );\r
998 endcase;\r
999\r
1000 case ID_FILE_POSITION: /* ( pos fid -- ior ) */\r
1001 M_PUSH( sdTellFile( (FileStream *) TOS ));\r
1002 TOS = 0;\r
1003 endcase;\r
1004\r
1005 case ID_FILE_RO: /* ( -- fam ) */\r
1006 PUSH_TOS;\r
1007 TOS = PF_FAM_READ_ONLY;\r
1008 endcase;\r
1009 \r
1010 case ID_FILE_RW: /* ( -- fam ) */\r
1011 PUSH_TOS;\r
1012 TOS = PF_FAM_READ_WRITE;\r
1013 endcase;\r
1014\r
1015 case ID_FILE_WO: /* ( -- fam ) */\r
1016 PUSH_TOS;\r
1017 TOS = PF_FAM_WRITE_ONLY;\r
1018 endcase;\r
1019\r
1020 case ID_FILE_BIN: /* ( -- fam ) */\r
1021 TOS = TOS | PF_FAM_BINARY_FLAG;\r
1022 endcase;\r
1023 \r
1024 case ID_FILL: /* ( caddr num charval -- ) */\r
1025 {\r
1026 register char *DstPtr;\r
1027 Temp = M_POP; /* num */\r
1028 DstPtr = (char *) M_POP; /* dst */\r
1029 for( Scratch=0; (uint32) Scratch < (uint32) Temp ; Scratch++ )\r
1030 {\r
1031 *DstPtr++ = (char) TOS;\r
1032 }\r
1033 M_DROP;\r
1034 }\r
1035 endcase;\r
1036 \r
1037#ifndef PF_NO_SHELL\r
1038 case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */\r
1039 TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );\r
1040 M_PUSH( Temp );\r
1041 endcase;\r
1042 \r
1043 case ID_FINDNFA:\r
1044 TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );\r
1045 M_PUSH( (cell) Temp );\r
1046 endcase;\r
1047#endif /* !PF_NO_SHELL */\r
1048\r
1049 case ID_FLUSHEMIT:\r
1050 sdTerminalFlush();\r
1051 endcase;\r
1052 \r
1053/* Validate memory before freeing. Clobber validator and first word. */\r
1054 case ID_FREE: /* ( addr -- result ) */\r
1055 if( TOS == 0 )\r
1056 {\r
1057 ERR("FREE passed NULL!\n");\r
1058 TOS = -2; /* FIXME error code */\r
1059 }\r
1060 else\r
1061 {\r
1062 CellPtr = (cell *) TOS;\r
1063 CellPtr--;\r
1064 if( ((uint32)*CellPtr) != ((uint32)CellPtr ^ PF_MEMORY_VALIDATOR))\r
1065 {\r
1066 TOS = -2; /* FIXME error code */\r
1067 }\r
1068 else\r
1069 {\r
1070 CellPtr[0] = 0xDeadBeef;\r
1071 pfFreeMem((char *)CellPtr);\r
1072 TOS = 0;\r
1073 }\r
1074 }\r
1075 endcase;\r
1076 \r
1077#include "pfinnrfp.h"\r
1078\r
1079 case ID_HERE:\r
1080 PUSH_TOS;\r
1081 TOS = (cell)CODE_HERE;\r
1082 endcase;\r
1083 \r
1084 case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */\r
1085/* Convert using number converter in 'C'.\r
1086** Only supports single precision for bootstrap.\r
1087*/\r
1088 TOS = (cell) ffNumberQ( (char *) TOS, &Temp );\r
1089 if( TOS == NUM_TYPE_SINGLE)\r
1090 {\r
1091 M_PUSH( Temp ); /* Push single number */\r
1092 }\r
1093 endcase;\r
1094 \r
1095 case ID_I: /* ( -- i , DO LOOP index ) */\r
1096 PUSH_TOS;\r
1097 TOS = M_R_PICK(1);\r
1098 endcase;\r
1099\r
1100#ifndef PF_NO_SHELL\r
1101 case ID_INCLUDE_FILE:\r
1102 FileID = (FileStream *) TOS;\r
1103 M_DROP; /* Drop now so that INCLUDE has a clean stack. */\r
1104 SAVE_REGISTERS;\r
1105 Scratch = ffIncludeFile( FileID );\r
1106 LOAD_REGISTERS;\r
1107 if( Scratch ) M_THROW(Scratch)\r
1108 endcase;\r
1109#endif /* !PF_NO_SHELL */\r
1110 \r
1111#ifndef PF_NO_SHELL\r
1112 case ID_INTERPRET:\r
1113 SAVE_REGISTERS;\r
1114 Scratch = ffInterpret();\r
1115 LOAD_REGISTERS;\r
1116 if( Scratch ) M_THROW(Scratch)\r
1117 endcase;\r
1118#endif /* !PF_NO_SHELL */\r
1119\r
1120 case ID_J: /* ( -- j , second DO LOOP index ) */\r
1121 PUSH_TOS;\r
1122 TOS = M_R_PICK(3);\r
1123 endcase;\r
1124\r
1125 case ID_KEY:\r
1126 PUSH_TOS;\r
1127 TOS = ioKey();\r
1128 endcase;\r
1129 \r
1130#ifndef PF_NO_SHELL\r
1131 case ID_LITERAL:\r
1132 ffLiteral( TOS );\r
1133 M_DROP;\r
1134 endcase;\r
1135#endif /* !PF_NO_SHELL */\r
1136\r
1137 case ID_LITERAL_P:\r
1138 DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));\r
1139 PUSH_TOS;\r
1140 TOS = READ_LONG_DIC(InsPtr++);\r
1141 endcase;\r
1142 \r
1143#ifndef PF_NO_SHELL\r
1144 case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;\r
1145#endif /* !PF_NO_SHELL */\r
1146\r
1147 case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */\r
1148 TOS = *(LocalsPtr - TOS);\r
1149 endcase;\r
1150\r
1151#define LOCAL_FETCH_N(num) \\r
1152 case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \\r
1153 PUSH_TOS; \\r
1154 TOS = *(LocalsPtr -(num)); \\r
1155 endcase;\r
1156\r
1157 LOCAL_FETCH_N(1);\r
1158 LOCAL_FETCH_N(2);\r
1159 LOCAL_FETCH_N(3);\r
1160 LOCAL_FETCH_N(4);\r
1161 LOCAL_FETCH_N(5);\r
1162 LOCAL_FETCH_N(6);\r
1163 LOCAL_FETCH_N(7);\r
1164 LOCAL_FETCH_N(8);\r
1165 \r
1166 case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */\r
1167 *(LocalsPtr - TOS) = M_POP;\r
1168 M_DROP;\r
1169 endcase;\r
1170\r
1171#define LOCAL_STORE_N(num) \\r
1172 case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \\r
1173 *(LocalsPtr - (num)) = TOS; \\r
1174 M_DROP; \\r
1175 endcase;\r
1176\r
1177 LOCAL_STORE_N(1);\r
1178 LOCAL_STORE_N(2);\r
1179 LOCAL_STORE_N(3);\r
1180 LOCAL_STORE_N(4);\r
1181 LOCAL_STORE_N(5);\r
1182 LOCAL_STORE_N(6);\r
1183 LOCAL_STORE_N(7);\r
1184 LOCAL_STORE_N(8);\r
1185 \r
1186 case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */\r
1187 *(LocalsPtr - TOS) += M_POP;\r
1188 M_DROP;\r
1189 endcase;\r
1190 \r
1191 case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */\r
1192 /* create local stack frame */\r
1193 {\r
1194 int32 i = TOS;\r
1195 cell *lp;\r
1196 DBUG(("LocalEntry: n = %d\n", TOS));\r
1197 /* End of locals. Create stack frame */\r
1198 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",\r
1199 TORPTR, LocalsPtr));\r
1200 M_R_PUSH(LocalsPtr);\r
1201 LocalsPtr = TORPTR;\r
1202 TORPTR -= TOS;\r
1203 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",\r
1204 TORPTR, LocalsPtr));\r
1205 lp = TORPTR;\r
1206 while(i-- > 0)\r
1207 {\r
1208 *lp++ = M_POP; /* Load local vars from stack */\r
1209 }\r
1210 M_DROP;\r
1211 }\r
1212 endcase;\r
1213\r
1214 case ID_LOCAL_EXIT: /* cleanup up local stack frame */\r
1215 DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",\r
1216 TORPTR, LocalsPtr));\r
1217 TORPTR = LocalsPtr;\r
1218 LocalsPtr = (cell *) M_R_POP;\r
1219 DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",\r
1220 TORPTR, LocalsPtr));\r
1221 endcase;\r
1222 \r
1223#ifndef PF_NO_SHELL\r
1224 case ID_LOADSYS:\r
1225 MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;\r
1226 FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");\r
1227 if( FileID )\r
1228 {\r
1229 SAVE_REGISTERS;\r
1230 Scratch = ffIncludeFile( FileID );\r
1231 LOAD_REGISTERS;\r
1232 sdCloseFile( FileID );\r
1233 if( Scratch ) M_THROW(Scratch);\r
1234 }\r
1235 else\r
1236 {\r
1237 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");\r
1238 }\r
1239 endcase;\r
1240#endif /* !PF_NO_SHELL */\r
1241\r
1242 case ID_LEAVE_P: /* ( R: index limit -- ) */\r
1243 M_R_DROP;\r
1244 M_R_DROP;\r
1245 M_BRANCH;\r
1246 endcase;\r
1247\r
1248 case ID_LOOP_P: /* ( R: index limit -- | index limit ) */\r
1249 Temp = M_R_POP; /* limit */\r
1250 Scratch = M_R_POP + 1; /* index */\r
1251 if( Scratch == Temp )\r
1252 {\r
1253 InsPtr++; /* skip branch offset, exit loop */\r
1254 }\r
1255 else\r
1256 {\r
1257/* Push index and limit back to R */\r
1258 M_R_PUSH( Scratch );\r
1259 M_R_PUSH( Temp );\r
1260/* Branch back to just after (DO) */\r
1261 M_BRANCH;\r
1262 }\r
1263 endcase;\r
1264 \r
1265 case ID_LSHIFT: BINARY_OP( << ); endcase;\r
1266 \r
1267 case ID_MAX:\r
1268 Scratch = M_POP;\r
1269 TOS = ( TOS > Scratch ) ? TOS : Scratch ;\r
1270 endcase;\r
1271 \r
1272 case ID_MIN:\r
1273 Scratch = M_POP;\r
1274 TOS = ( TOS < Scratch ) ? TOS : Scratch ;\r
1275 endcase;\r
1276 \r
1277 case ID_MINUS: BINARY_OP( - ); endcase;\r
1278 \r
1279#ifndef PF_NO_SHELL\r
1280 case ID_NAME_TO_TOKEN:\r
1281 TOS = (cell) NameToToken((ForthString *)TOS);\r
1282 endcase;\r
1283 \r
1284 case ID_NAME_TO_PREVIOUS:\r
1285 TOS = (cell) NameToPrevious((ForthString *)TOS);\r
1286 endcase;\r
1287#endif\r
1288 \r
1289 case ID_NOOP:\r
1290 endcase;\r
1291 \r
1292 case ID_OR: BINARY_OP( | ); endcase;\r
1293 \r
1294 case ID_OVER:\r
1295 PUSH_TOS;\r
1296 TOS = M_STACK(1);\r
1297 endcase;\r
1298 \r
1299 case ID_PICK: /* ( ... n -- sp(n) ) */\r
1300 TOS = M_STACK(TOS);\r
1301 endcase;\r
1302\r
1303 case ID_PLUS: BINARY_OP( + ); endcase;\r
1304 \r
1305 case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */\r
1306#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1307 if( IN_DICS( TOS ) )\r
1308 {\r
1309 Scratch = READ_LONG_DIC((cell *)TOS);\r
1310 Scratch += M_POP;\r
1311 WRITE_LONG_DIC((cell *)TOS,Scratch);\r
1312 }\r
1313 else\r
1314 {\r
1315 *((cell *)TOS) += M_POP;\r
1316 }\r
1317#else\r
1318 *((cell *)TOS) += M_POP;\r
1319#endif\r
1320 M_DROP;\r
1321 endcase;\r
1322\r
1323 case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */\r
1324 {\r
1325 ucell OldIndex, NewIndex, Limit;\r
1326\r
1327 Limit = M_R_POP;\r
1328 OldIndex = M_R_POP;\r
1329 NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */\r
1330/* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
1331 if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r
1332 ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
1333 {\r
1334 InsPtr++; /* skip branch offset, exit loop */\r
1335 }\r
1336 else\r
1337 {\r
1338/* Push index and limit back to R */\r
1339 M_R_PUSH( NewIndex );\r
1340 M_R_PUSH( Limit );\r
1341/* Branch back to just after (DO) */\r
1342 M_BRANCH;\r
1343 }\r
1344 M_DROP;\r
1345 }\r
1346 endcase;\r
1347\r
1348 case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */\r
1349 Scratch = M_POP; /* limit */\r
1350 if( Scratch == TOS )\r
1351 {\r
1352/* Branch to just after (LOOP) */\r
1353 M_BRANCH;\r
1354 }\r
1355 else\r
1356 {\r
1357 M_R_PUSH( TOS );\r
1358 M_R_PUSH( Scratch );\r
1359 InsPtr++; /* skip branch offset, enter loop */\r
1360 }\r
1361 M_DROP;\r
1362 endcase;\r
1363\r
1364 case ID_QDUP: if( TOS ) M_DUP; endcase;\r
1365\r
1366 case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */\r
1367 PUSH_TOS;\r
1368 TOS = sdQueryTerminal();\r
1369 endcase;\r
1370 \r
1371 case ID_QUIT_P: /* Stop inner interpreter, go back to user. */\r
1372#ifdef PF_SUPPORT_TRACE\r
1373 Level = 0;\r
1374#endif\r
1375 M_THROW(THROW_QUIT);\r
1376 endcase;\r
1377 \r
1378 case ID_R_DROP:\r
1379 M_R_DROP;\r
1380 endcase;\r
1381\r
1382 case ID_R_FETCH:\r
1383 PUSH_TOS;\r
1384 TOS = (*(TORPTR));\r
1385 endcase;\r
1386 \r
1387 case ID_R_FROM:\r
1388 PUSH_TOS;\r
1389 TOS = M_R_POP;\r
1390 endcase;\r
1391 \r
1392 case ID_REFILL:\r
1393 PUSH_TOS;\r
1394 TOS = (ffRefill() > 0) ? FTRUE : FFALSE;\r
1395 endcase;\r
1396 \r
1397/* Resize memory allocated by ALLOCATE. */\r
1398 case ID_RESIZE: /* ( addr1 u -- addr2 result ) */\r
1399 {\r
07618dcb 1400 cell *Addr1 = (cell *) M_POP;\r
1401 // Point to validator below users address.\r
1402 cell *FreePtr = Addr1 - 1;\r
bb6b2dcd 1403 if( ((uint32)*FreePtr) != ((uint32)FreePtr ^ PF_MEMORY_VALIDATOR))\r
1404 {\r
07618dcb 1405 // 090218 - Fixed bug, was returning zero.\r
1406 M_PUSH( Addr1 );\r
bb6b2dcd 1407 TOS = -3;\r
1408 }\r
1409 else\r
1410 {\r
1411 /* Try to allocate. */\r
1412 CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) );\r
1413 if( CellPtr )\r
1414 {\r
1415 /* Copy memory including validation. */\r
1416 pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell) );\r
1417 *CellPtr = (cell)(((uint32)CellPtr) ^ (uint32)PF_MEMORY_VALIDATOR);\r
07618dcb 1418 // 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub.\r
1419 // Increment past validator to user address.\r
1420 M_PUSH( (cell) (CellPtr + 1) );\r
1421 TOS = 0; // Result code.\r
1422 // Mark old cell as dead so we can't free it twice.\r
bb6b2dcd 1423 FreePtr[0] = 0xDeadBeef;\r
1424 pfFreeMem((char *) FreePtr);\r
1425 }\r
1426 else\r
1427 {\r
07618dcb 1428 // 090218 - Fixed bug, was returning zero.\r
1429 M_PUSH( Addr1 );\r
bb6b2dcd 1430 TOS = -4; /* FIXME Fix error code. */\r
1431 }\r
1432 }\r
1433 }\r
1434 endcase;\r
1435 \r
1436/*\r
1437** RP@ and RP! are called secondaries so we must\r
1438** account for the return address pushed before calling.\r
1439*/\r
1440 case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */\r
1441 PUSH_TOS;\r
1442 TOS = (cell)TORPTR; /* value before calling RP@ */\r
1443 endcase;\r
1444 \r
1445 case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */\r
1446 TORPTR = (cell *) TOS;\r
1447 M_DROP;\r
1448 endcase;\r
1449 \r
1450 case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */\r
1451 {\r
1452 int32 ri;\r
1453 cell *srcPtr, *dstPtr;\r
1454 Scratch = M_STACK(TOS);\r
1455 srcPtr = &M_STACK(TOS-1);\r
1456 dstPtr = &M_STACK(TOS);\r
1457 for( ri=0; ri<TOS; ri++ )\r
1458 {\r
1459 *dstPtr-- = *srcPtr--;\r
1460 }\r
1461 TOS = Scratch;\r
1462 STKPTR++;\r
1463 }\r
1464 endcase;\r
1465\r
1466 case ID_ROT: /* ( a b c -- b c a ) */\r
1467 Scratch = M_POP; /* b */\r
1468 Temp = M_POP; /* a */\r
1469 M_PUSH( Scratch ); /* b */\r
1470 PUSH_TOS; /* c */\r
1471 TOS = Temp; /* a */\r
1472 endcase;\r
1473\r
1474/* Logical right shift */\r
1475 case ID_RSHIFT: { TOS = ((uint32)M_POP) >> TOS; } endcase; \r
1476 \r
1477#ifndef PF_NO_SHELL\r
1478 case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */\r
1479 {\r
1480 int32 NameSize, CodeSize, EntryPoint;\r
1481 CodeSize = TOS;\r
1482 NameSize = M_POP;\r
1483 EntryPoint = M_POP;\r
1484 ForthStringToC( gScratch, (char *) M_POP );\r
1485 TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );\r
1486 }\r
1487 endcase;\r
1488#endif\r
1489\r
1490/* Source Stack\r
1491** EVALUATE >IN SourceID=(-1) 1111\r
1492** keyboard >IN SourceID=(0) 2222\r
1493** file >IN lineNumber filePos SourceID=(fileID)\r
1494*/\r
1495 case ID_SAVE_INPUT: /* FIXME - finish */\r
1496 {\r
1497 }\r
1498 endcase;\r
1499\r
1500 case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */\r
1501 PUSH_TOS;\r
1502 TOS = (cell)STKPTR;\r
1503 endcase;\r
1504 \r
1505 case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */\r
1506 STKPTR = (cell *) TOS;\r
1507 M_DROP;\r
1508 endcase;\r
1509 \r
1510 case ID_STORE: /* ( n addr -- , write n to addr ) */\r
1511#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1512 if( IN_DICS( TOS ) )\r
1513 {\r
1514 WRITE_LONG_DIC((cell *)TOS,M_POP);\r
1515 }\r
1516 else\r
1517 {\r
1518 *((cell *)TOS) = M_POP;\r
1519 }\r
1520#else\r
1521 *((cell *)TOS) = M_POP;\r
1522#endif\r
1523 M_DROP;\r
1524 endcase;\r
1525\r
1526 case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */\r
1527 Scratch = M_POP; /* cnt */\r
1528 Temp = M_POP; /* addr */\r
1529 TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
1530 M_PUSH((cell) CharPtr);\r
1531 endcase;\r
1532 \r
1533#ifndef PF_NO_SHELL\r
1534 case ID_SEMICOLON:\r
1535 SAVE_REGISTERS;\r
1536 Scratch = ffSemiColon();\r
1537 LOAD_REGISTERS;\r
1538 if( Scratch ) M_THROW( Scratch );\r
1539 endcase;\r
1540#endif /* !PF_NO_SHELL */\r
1541 \r
1542 case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */\r
1543 Scratch = M_POP; /* cnt */\r
1544 Temp = M_POP; /* addr */\r
1545 TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
1546 M_PUSH((cell) CharPtr);\r
1547 endcase;\r
1548\r
1549 case ID_SOURCE: /* ( -- c-addr num ) */\r
1550 PUSH_TOS;\r
1551 M_PUSH( (cell) gCurrentTask->td_SourcePtr );\r
1552 TOS = (cell) gCurrentTask->td_SourceNum;\r
1553 endcase;\r
1554 \r
1555 case ID_SOURCE_SET: /* ( c-addr num -- ) */\r
1556 gCurrentTask->td_SourcePtr = (char *) M_POP;\r
1557 gCurrentTask->td_SourceNum = TOS;\r
1558 M_DROP;\r
1559 endcase;\r
1560 \r
1561 case ID_SOURCE_ID:\r
1562 PUSH_TOS;\r
1563 TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;\r
1564 endcase;\r
1565 \r
1566 case ID_SOURCE_ID_POP:\r
1567 PUSH_TOS;\r
1568 TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;\r
1569 endcase;\r
1570 \r
1571 case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */\r
1572 TOS = (cell)ffConvertSourceIDToStream( TOS );\r
1573 Scratch = ffPushInputStream((FileStream *) TOS );\r
1574 if( Scratch )\r
1575 {\r
1576 M_THROW(Scratch);\r
1577 }\r
1578 else M_DROP;\r
1579 endcase;\r
1580 \r
1581 case ID_SWAP:\r
1582 Scratch = TOS;\r
1583 TOS = *STKPTR;\r
1584 *STKPTR = Scratch;\r
1585 endcase;\r
1586 \r
1587 case ID_TEST1:\r
1588 PUSH_TOS;\r
1589 M_PUSH( 0x11 );\r
1590 M_PUSH( 0x22 );\r
1591 TOS = 0x33;\r
1592 endcase;\r
1593\r
1594 case ID_TEST2:\r
1595 endcase;\r
1596\r
1597 case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */\r
1598 if(TOS)\r
1599 {\r
1600 M_THROW(TOS);\r
1601 }\r
1602 else M_DROP;\r
1603 endcase;\r
1604\r
1605#ifndef PF_NO_SHELL\r
1606 case ID_TICK:\r
1607 PUSH_TOS;\r
1608 CharPtr = (char *) ffWord( (char) ' ' );\r
1609 TOS = ffFind( CharPtr, (ExecToken *) &Temp );\r
1610 if( TOS == 0 )\r
1611 {\r
1612 ERR("' could not find ");\r
1613 ioType( (char *) CharPtr+1, *CharPtr );\r
1614 M_THROW(-13);\r
1615 }\r
1616 else\r
1617 {\r
1618 TOS = Temp;\r
1619 }\r
1620 endcase;\r
1621#endif /* !PF_NO_SHELL */\r
1622 \r
1623 case ID_TIMES: BINARY_OP( * ); endcase;\r
1624 \r
1625 case ID_TYPE:\r
1626 Scratch = M_POP; /* addr */\r
1627 ioType( (char *) Scratch, TOS );\r
1628 M_DROP;\r
1629 endcase;\r
1630\r
1631 case ID_TO_R:\r
1632 M_R_PUSH( TOS );\r
1633 M_DROP;\r
1634 endcase;\r
1635\r
1636 case ID_VAR_BASE: DO_VAR(gVarBase); endcase;\r
1637 case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;\r
1638 case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;\r
1639 case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;\r
1640 case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;\r
1641 case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;\r
1642 case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;\r
1643 case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;\r
1644 case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr.Cell); endcase;\r
1645 case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;\r
1646 case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;\r
1647 case ID_VAR_STATE: DO_VAR(gVarState); endcase;\r
1648 case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;\r
1649 case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;\r
1650 case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;\r
1651 case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;\r
1652 case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;\r
1653\r
1654 case ID_WORD:\r
1655 TOS = (cell) ffWord( (char) TOS );\r
1656 endcase;\r
1657\r
1658 case ID_WORD_FETCH: /* ( waddr -- w ) */\r
1659#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1660 if( IN_DICS( TOS ) )\r
1661 {\r
1662 TOS = (uint16) READ_SHORT_DIC((uint16 *)TOS);\r
1663 }\r
1664 else\r
1665 {\r
1666 TOS = *((uint16 *)TOS);\r
1667 }\r
1668#else\r
1669 TOS = *((uint16 *)TOS);\r
1670#endif\r
1671 endcase;\r
1672\r
1673 case ID_WORD_STORE: /* ( w waddr -- ) */\r
1674 \r
1675#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
1676 if( IN_DICS( TOS ) )\r
1677 {\r
1678 WRITE_SHORT_DIC((uint16 *)TOS,(uint16)M_POP);\r
1679 }\r
1680 else\r
1681 {\r
1682 *((uint16 *)TOS) = (uint16) M_POP;\r
1683 }\r
1684#else\r
1685 *((uint16 *)TOS) = (uint16) M_POP;\r
1686#endif\r
1687 M_DROP;\r
1688 endcase;\r
1689\r
1690 case ID_XOR: BINARY_OP( ^ ); endcase;\r
1691 \r
1692 \r
1693/* Branch is followed by an offset relative to address of offset. */\r
1694 case ID_ZERO_BRANCH:\r
1695DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));\r
1696 if( TOS == 0 )\r
1697 {\r
1698 M_BRANCH;\r
1699 }\r
1700 else\r
1701 {\r
1702 InsPtr++; /* skip over offset */\r
1703 }\r
1704 M_DROP;\r
1705DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));\r
1706 endcase;\r
1707 \r
1708 default:\r
1709 ERR("pfCatch: Unrecognised token = 0x");\r
1710 ffDotHex(Token);\r
1711 ERR(" at 0x");\r
1712 ffDotHex((int32) InsPtr);\r
1713 EMIT_CR;\r
1714 InsPtr = 0;\r
1715 endcase;\r
1716 }\r
1717 \r
1718 if(InsPtr) Token = READ_LONG_DIC(InsPtr++); /* Traverse to next token in secondary. */\r
1719 \r
1720#ifdef PF_DEBUG\r
1721 M_DOTS;\r
1722#endif\r
1723\r
1724#if 0\r
1725 if( _CrtCheckMemory() == 0 )\r
1726 {\r
1727 ERR("_CrtCheckMemory abort: InsPtr = 0x");\r
1728 ffDotHex((int)InsPtr);\r
1729 ERR("\n");\r
1730 }\r
1731#endif\r
1732\r
1733 } while( (InitialReturnStack - TORPTR) > 0 );\r
1734\r
1735 SAVE_REGISTERS;\r
1736 \r
1737 return ExceptionReturnCode;\r
1738}\r
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.