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