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