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