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