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