projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Implement RESIZE-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
e0701bfb
HE		 1109 case ID_FILE_RESIZE: /* ( ud fileid -- ior ) */
1110 {
1111 FileStream *File = (FileStream *) TOS;
1112 ucell_t SizeHi = (ucell_t) M_POP;
1113 ucell_t SizeLo = (ucell_t) M_POP;
1114 TOS = sdResizeFile( File, SizeLo, SizeHi );
1115 }
1116 endcase;
1117
8e9db35f
PB		 1118 case ID_FILL: /* ( caddr num charval -- ) */
1119 {
1120 register char *DstPtr;
1121 Temp = M_POP; /* num */
1122 DstPtr = (char *) M_POP; /* dst */
1123 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
1124 {
1125 *DstPtr++ = (char) TOS;
1126 }
1127 M_DROP;
1128 }
1129 endcase;
1130
1131#ifndef PF_NO_SHELL
1132 case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */
1133 TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
1134 M_PUSH( Temp );
1135 endcase;
1136
1137 case ID_FINDNFA:
1138 TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
1139 M_PUSH( (cell_t) Temp );
1140 endcase;
1141#endif /* !PF_NO_SHELL */
1142
1143 case ID_FLUSHEMIT:
1144 sdTerminalFlush();
1145 endcase;
1146
1147/* Validate memory before freeing. Clobber validator and first word. */
1148 case ID_FREE: /* ( addr -- result ) */
1149 if( TOS == 0 )
1150 {
1151 ERR("FREE passed NULL!\n");
1152 TOS = -2; /* FIXME error code */
1153 }
1154 else
1155 {
1156 CellPtr = (cell_t *) TOS;
1157 CellPtr--;
1158 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
1159 {
1160 TOS = -2; /* FIXME error code */
1161 }
1162 else
1163 {
1164 CellPtr[0] = 0xDeadBeef;
1165 pfFreeMem((char *)CellPtr);
1166 TOS = 0;
1167 }
1168 }
1169 endcase;
1170
1171#include "pfinnrfp.h"
1172
1173 case ID_HERE:
1174 PUSH_TOS;
1175 TOS = (cell_t)CODE_HERE;
1176 endcase;
1177
1178 case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */
1179/* Convert using number converter in 'C'.
1180** Only supports single precision for bootstrap.
1181*/
1182 TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
1183 if( TOS == NUM_TYPE_SINGLE)
1184 {
1185 M_PUSH( Temp ); /* Push single number */
1186 }
1187 endcase;
1188
1189 case ID_I: /* ( -- i , DO LOOP index ) */
1190 PUSH_TOS;
1191 TOS = M_R_PICK(1);
1192 endcase;
1193
1194#ifndef PF_NO_SHELL
1195 case ID_INCLUDE_FILE:
1196 FileID = (FileStream *) TOS;
1197 M_DROP; /* Drop now so that INCLUDE has a clean stack. */
1198 SAVE_REGISTERS;
1199 Scratch = ffIncludeFile( FileID );
1200 LOAD_REGISTERS;
1201 if( Scratch ) M_THROW(Scratch)
1202 endcase;
1203#endif /* !PF_NO_SHELL */
1204
1205#ifndef PF_NO_SHELL
1206 case ID_INTERPRET:
1207 SAVE_REGISTERS;
1208 Scratch = ffInterpret();
1209 LOAD_REGISTERS;
1210 if( Scratch ) M_THROW(Scratch)
1211 endcase;
1212#endif /* !PF_NO_SHELL */
1213
1214 case ID_J: /* ( -- j , second DO LOOP index ) */
1215 PUSH_TOS;
1216 TOS = M_R_PICK(3);
1217 endcase;
1218
1219 case ID_KEY:
1220 PUSH_TOS;
1221 TOS = ioKey();
1222 endcase;
1223
1224#ifndef PF_NO_SHELL
1225 case ID_LITERAL:
1226 ffLiteral( TOS );
1227 M_DROP;
1228 endcase;
1229#endif /* !PF_NO_SHELL */
1230
1231 case ID_LITERAL_P:
1232 DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
1233 PUSH_TOS;
1234 TOS = READ_CELL_DIC(InsPtr++);
1235 endcase;
1236
1237#ifndef PF_NO_SHELL
1238 case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
1239#endif /* !PF_NO_SHELL */
1240
1241 case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
1242 TOS = *(LocalsPtr - TOS);
1243 endcase;
1244
1245#define LOCAL_FETCH_N(num) \
1246 case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
1247 PUSH_TOS; \
1248 TOS = *(LocalsPtr -(num)); \
1249 endcase;
1250
1251 LOCAL_FETCH_N(1);
1252 LOCAL_FETCH_N(2);
1253 LOCAL_FETCH_N(3);
1254 LOCAL_FETCH_N(4);
1255 LOCAL_FETCH_N(5);
1256 LOCAL_FETCH_N(6);
1257 LOCAL_FETCH_N(7);
1258 LOCAL_FETCH_N(8);
1259
1260 case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */
1261 *(LocalsPtr - TOS) = M_POP;
1262 M_DROP;
1263 endcase;
1264
1265#define LOCAL_STORE_N(num) \
1266 case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \
1267 *(LocalsPtr - (num)) = TOS; \
1268 M_DROP; \
1269 endcase;
1270
1271 LOCAL_STORE_N(1);
1272 LOCAL_STORE_N(2);
1273 LOCAL_STORE_N(3);
1274 LOCAL_STORE_N(4);
1275 LOCAL_STORE_N(5);
1276 LOCAL_STORE_N(6);
1277 LOCAL_STORE_N(7);
1278 LOCAL_STORE_N(8);
1279
1280 case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */
1281 *(LocalsPtr - TOS) += M_POP;
1282 M_DROP;
1283 endcase;
1284
1285 case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
1286 /* create local stack frame */
1287 {
1288 cell_t i = TOS;
1289 cell_t *lp;
1290 DBUG(("LocalEntry: n = %d\n", TOS));
1291 /* End of locals. Create stack frame */
1292 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
1293 TORPTR, LocalsPtr));
1294 M_R_PUSH(LocalsPtr);
1295 LocalsPtr = TORPTR;
1296 TORPTR -= TOS;
1297 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
1298 TORPTR, LocalsPtr));
1299 lp = TORPTR;
1300 while(i-- > 0)
1301 {
1302 *lp++ = M_POP; /* Load local vars from stack */
1303 }
1304 M_DROP;
1305 }
1306 endcase;
1307
1308 case ID_LOCAL_EXIT: /* cleanup up local stack frame */
1309 DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
1310 TORPTR, LocalsPtr));
1311 TORPTR = LocalsPtr;
1312 LocalsPtr = (cell_t *) M_R_POP;
1313 DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
1314 TORPTR, LocalsPtr));
1315 endcase;
1316
1317#ifndef PF_NO_SHELL
1318 case ID_LOADSYS:
1319 MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
1320 FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
1321 if( FileID )
1322 {
1323 SAVE_REGISTERS;
1324 Scratch = ffIncludeFile( FileID ); /* Also closes the file. */
1325 LOAD_REGISTERS;
1326 if( Scratch ) M_THROW(Scratch);
1327 }
1328 else
1329 {
1330 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
1331 }
1332 endcase;
1333#endif /* !PF_NO_SHELL */
1334
1335 case ID_LEAVE_P: /* ( R: index limit -- ) */
1336 M_R_DROP;
1337 M_R_DROP;
1338 M_BRANCH;
1339 endcase;
1340
1341 case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
1342 Temp = M_R_POP; /* limit */
1343 Scratch = M_R_POP + 1; /* index */
1344 if( Scratch == Temp )
1345 {
1346 InsPtr++; /* skip branch offset, exit loop */
1347 }
1348 else
1349 {
1350/* Push index and limit back to R */
1351 M_R_PUSH( Scratch );
1352 M_R_PUSH( Temp );
1353/* Branch back to just after (DO) */
1354 M_BRANCH;
1355 }
1356 endcase;
1357
1358 case ID_LSHIFT: BINARY_OP( << ); endcase;
1359
1360 case ID_MAX:
1361 Scratch = M_POP;
1362 TOS = ( TOS > Scratch ) ? TOS : Scratch ;
1363 endcase;
1364
1365 case ID_MIN:
1366 Scratch = M_POP;
1367 TOS = ( TOS < Scratch ) ? TOS : Scratch ;
1368 endcase;
1369
1370 case ID_MINUS: BINARY_OP( - ); endcase;
1371
1372#ifndef PF_NO_SHELL
1373 case ID_NAME_TO_TOKEN:
1374 TOS = (cell_t) NameToToken((ForthString *)TOS);
1375 endcase;
1376
1377 case ID_NAME_TO_PREVIOUS:
1378 TOS = (cell_t) NameToPrevious((ForthString *)TOS);
1379 endcase;
1380#endif
1381
1382 case ID_NOOP:
1383 endcase;
1384
1385 case ID_OR: BINARY_OP( | ); endcase;
1386
1387 case ID_OVER:
1388 PUSH_TOS;
1389 TOS = M_STACK(1);
1390 endcase;
1391
1392 case ID_PICK: /* ( ... n -- sp(n) ) */
1393 TOS = M_STACK(TOS);
1394 endcase;
1395
1396 case ID_PLUS: BINARY_OP( + ); endcase;
1397
1398 case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */
1399#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1400 if( IN_DICS( TOS ) )
1401 {
1402 Scratch = READ_CELL_DIC((cell_t *)TOS);
1403 Scratch += M_POP;
1404 WRITE_CELL_DIC((cell_t *)TOS,Scratch);
1405 }
1406 else
1407 {
1408 *((cell_t *)TOS) += M_POP;
1409 }
1410#else
1411 *((cell_t *)TOS) += M_POP;
1412#endif
1413 M_DROP;
1414 endcase;
1415
1416 case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
1417 {
d98c27bb
HE		 1418 cell_t Limit = M_R_POP;
1419 cell_t OldIndex = M_R_POP;
1420 cell_t Delta = TOS; /* add TOS to index, not 1 */
1421 cell_t NewIndex = OldIndex + Delta;
1422 cell_t OldDiff = OldIndex - Limit;
1423
1424 /* This exploits this idea (lifted from Gforth):
1425 (x^y)<0 is equivalent to (x<0) != (y<0) */
1426 if( ((OldDiff ^ (OldDiff + Delta)) /* is the limit crossed? */
1427 & (OldDiff ^ Delta)) /* is it a wrap-around? */
1428 < 0 )
1429 {
8e9db35f
PB		 1430 InsPtr++; /* skip branch offset, exit loop */
1431 }
1432 else
1433 {
1434/* Push index and limit back to R */
1435 M_R_PUSH( NewIndex );
1436 M_R_PUSH( Limit );
1437/* Branch back to just after (DO) */
1438 M_BRANCH;
1439 }
1440 M_DROP;
1441 }
1442 endcase;
1443
1444 case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
1445 Scratch = M_POP; /* limit */
1446 if( Scratch == TOS )
1447 {
1448/* Branch to just after (LOOP) */
1449 M_BRANCH;
1450 }
1451 else
1452 {
1453 M_R_PUSH( TOS );
1454 M_R_PUSH( Scratch );
1455 InsPtr++; /* skip branch offset, enter loop */
1456 }
1457 M_DROP;
1458 endcase;
1459
1460 case ID_QDUP: if( TOS ) M_DUP; endcase;
1461
1462 case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */
1463 PUSH_TOS;
1464 TOS = sdQueryTerminal();
1465 endcase;
1466
1467 case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
1468#ifdef PF_SUPPORT_TRACE
1469 Level = 0;
1470#endif
1471 M_THROW(THROW_QUIT);
1472 endcase;
1473
1474 case ID_R_DROP:
1475 M_R_DROP;
1476 endcase;
1477
1478 case ID_R_FETCH:
1479 PUSH_TOS;
1480 TOS = (*(TORPTR));
1481 endcase;
1482
1483 case ID_R_FROM:
1484 PUSH_TOS;
1485 TOS = M_R_POP;
1486 endcase;
1487
1488 case ID_REFILL:
1489 PUSH_TOS;
1490 TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
1491 endcase;
1492
1493/* Resize memory allocated by ALLOCATE. */
1494 case ID_RESIZE: /* ( addr1 u -- addr2 result ) */
1495 {
1496 cell_t *Addr1 = (cell_t *) M_POP;
1497 /* Point to validator below users address. */
1498 cell_t *FreePtr = Addr1 - 1;
1499 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
1500 {
1501 /* 090218 - Fixed bug, was returning zero. */
1502 M_PUSH( Addr1 );
1503 TOS = -3;
1504 }
1505 else
1506 {
1507 /* Try to allocate. */
1508 CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
1509 if( CellPtr )
1510 {
1511 /* Copy memory including validation. */
1512 pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
1513 *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
1514 /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */
1515 /* Increment past validator to user address. */
1516 M_PUSH( (cell_t) (CellPtr + 1) );
1517 TOS = 0; /* Result code. */
1518 /* Mark old cell as dead so we can't free it twice. */
1519 FreePtr[0] = 0xDeadBeef;
1520 pfFreeMem((char *) FreePtr);
1521 }
1522 else
1523 {
1524 /* 090218 - Fixed bug, was returning zero. */
1525 M_PUSH( Addr1 );
1526 TOS = -4; /* FIXME Fix error code. */
1527 }
1528 }
1529 }
1530 endcase;
1531
1532/*
1533** RP@ and RP! are called secondaries so we must
1534** account for the return address pushed before calling.
1535*/
1536 case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */
1537 PUSH_TOS;
1538 TOS = (cell_t)TORPTR; /* value before calling RP@ */
1539 endcase;
1540
1541 case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */
1542 TORPTR = (cell_t *) TOS;
1543 M_DROP;
1544 endcase;
1545
1546 case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
1547 {
1548 cell_t ri;
1549 cell_t *srcPtr, *dstPtr;
1550 Scratch = M_STACK(TOS);
1551 srcPtr = &M_STACK(TOS-1);
1552 dstPtr = &M_STACK(TOS);
1553 for( ri=0; ri<TOS; ri++ )
1554 {
1555 *dstPtr-- = *srcPtr--;
1556 }
1557 TOS = Scratch;
1558 STKPTR++;
1559 }
1560 endcase;
1561
1562 case ID_ROT: /* ( a b c -- b c a ) */
1563 Scratch = M_POP; /* b */
1564 Temp = M_POP; /* a */
1565 M_PUSH( Scratch ); /* b */
1566 PUSH_TOS; /* c */
1567 TOS = Temp; /* a */
1568 endcase;
1569
1570/* Logical right shift */
1571 case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
1572
1573#ifndef PF_NO_SHELL
1574 case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */
1575 {
1576 cell_t NameSize, CodeSize, EntryPoint;
1577 CodeSize = TOS;
1578 NameSize = M_POP;
1579 EntryPoint = M_POP;
1580 ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );
1581 TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
1582 }
1583 endcase;
1584#endif
1585
8e9db35f
PB		 1586 case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */
1587 PUSH_TOS;
1588 TOS = (cell_t)STKPTR;
1589 endcase;
1590
1591 case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */
1592 STKPTR = (cell_t *) TOS;
1593 M_DROP;
1594 endcase;
1595
1596 case ID_STORE: /* ( n addr -- , write n to addr ) */
1597#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1598 if( IN_DICS( TOS ) )
1599 {
1600 WRITE_CELL_DIC((cell_t *)TOS,M_POP);
1601 }
1602 else
1603 {
1604 *((cell_t *)TOS) = M_POP;
1605 }
1606#else
1607 *((cell_t *)TOS) = M_POP;
1608#endif
1609 M_DROP;
1610 endcase;
1611
1612 case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
1613 Scratch = M_POP; /* cnt */
1614 Temp = M_POP; /* addr */
1615 TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1616 M_PUSH((cell_t) CharPtr);
1617 endcase;
1618
1619#ifndef PF_NO_SHELL
1620 case ID_SEMICOLON:
1621 SAVE_REGISTERS;
1622 Scratch = ffSemiColon();
1623 LOAD_REGISTERS;
1624 if( Scratch ) M_THROW( Scratch );
1625 endcase;
1626#endif /* !PF_NO_SHELL */
1627
1628 case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
1629 Scratch = M_POP; /* cnt */
1630 Temp = M_POP; /* addr */
1631 TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1632 M_PUSH((cell_t) CharPtr);
1633 endcase;
1634
1635 case ID_SOURCE: /* ( -- c-addr num ) */
1636 PUSH_TOS;
1637 M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
1638 TOS = (cell_t) gCurrentTask->td_SourceNum;
1639 endcase;
1640
1641 case ID_SOURCE_SET: /* ( c-addr num -- ) */
1642 gCurrentTask->td_SourcePtr = (char *) M_POP;
1643 gCurrentTask->td_SourceNum = TOS;
1644 M_DROP;
1645 endcase;
1646
1647 case ID_SOURCE_ID:
1648 PUSH_TOS;
1649 TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
1650 endcase;
1651
1652 case ID_SOURCE_ID_POP:
1653 PUSH_TOS;
1654 TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
1655 endcase;
1656
1657 case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */
1658 TOS = (cell_t)ffConvertSourceIDToStream( TOS );
1659 Scratch = ffPushInputStream((FileStream *) TOS );
1660 if( Scratch )
1661 {
1662 M_THROW(Scratch);
1663 }
1664 else M_DROP;
1665 endcase;
1666
08689895
HE		 1667 case ID_SOURCE_LINE_NUMBER_FETCH: /* ( -- linenr ) */
1668 PUSH_TOS;
1669 TOS = gCurrentTask->td_LineNumber;
1670 endcase;
1671
1672 case ID_SOURCE_LINE_NUMBER_STORE: /* ( linenr -- ) */
1673 gCurrentTask->td_LineNumber = TOS;
1674 TOS = M_POP;
1675 endcase;
1676
8e9db35f
PB		 1677 case ID_SWAP:
1678 Scratch = TOS;
1679 TOS = *STKPTR;
1680 *STKPTR = Scratch;
1681 endcase;
1682
1683 case ID_TEST1:
1684 PUSH_TOS;
1685 M_PUSH( 0x11 );
1686 M_PUSH( 0x22 );
1687 TOS = 0x33;
1688 endcase;
1689
1690 case ID_TEST2:
1691 endcase;
1692
1693 case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
1694 if(TOS)
1695 {
1696 M_THROW(TOS);
1697 }
1698 else M_DROP;
1699 endcase;
1700
1701#ifndef PF_NO_SHELL
1702 case ID_TICK:
1703 PUSH_TOS;
1704 CharPtr = (char *) ffWord( (char) ' ' );
1705 TOS = ffFind( CharPtr, (ExecToken *) &Temp );
1706 if( TOS == 0 )
1707 {
1708 ERR("' could not find ");
1709 ioType( (char *) CharPtr+1, *CharPtr );
1710 M_THROW(-13);
1711 }
1712 else
1713 {
1714 TOS = Temp;
1715 }
1716 endcase;
1717#endif /* !PF_NO_SHELL */
1718
1719 case ID_TIMES: BINARY_OP( * ); endcase;
1720
1721 case ID_TYPE:
1722 Scratch = M_POP; /* addr */
1723 ioType( (char *) Scratch, TOS );
1724 M_DROP;
1725 endcase;
1726
1727 case ID_TO_R:
1728 M_R_PUSH( TOS );
1729 M_DROP;
1730 endcase;
1731
1732 case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
1733 case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
1734 case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
1735 case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
1736 case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
1737 case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
1738 case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
1739 case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
1740 case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
1741 case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
1742 case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
1743 case ID_VAR_STATE: DO_VAR(gVarState); endcase;
1744 case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
1745 case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
1746 case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
1747 case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
1748 case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
1749
1750 case ID_WORD:
1751 TOS = (cell_t) ffWord( (char) TOS );
1752 endcase;
1753
1754 case ID_WORD_FETCH: /* ( waddr -- w ) */
1755#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1756 if( IN_DICS( TOS ) )
1757 {
1758 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
1759 }
1760 else
1761 {
1762 TOS = *((uint16_t *)TOS);
1763 }
1764#else
1765 TOS = *((uint16_t *)TOS);
1766#endif
1767 endcase;
1768
1769 case ID_WORD_STORE: /* ( w waddr -- ) */
1770
1771#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1772 if( IN_DICS( TOS ) )
1773 {
1774 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
1775 }
1776 else
1777 {
1778 *((uint16_t *)TOS) = (uint16_t) M_POP;
1779 }
1780#else
1781 *((uint16_t *)TOS) = (uint16_t) M_POP;
1782#endif
1783 M_DROP;
1784 endcase;
1785
1786 case ID_XOR: BINARY_OP( ^ ); endcase;
1787
1788
1789/* Branch is followed by an offset relative to address of offset. */
1790 case ID_ZERO_BRANCH:
1791DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
1792 if( TOS == 0 )
1793 {
1794 M_BRANCH;
1795 }
1796 else
1797 {
1798 InsPtr++; /* skip over offset */
1799 }
1800 M_DROP;
1801DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
1802 endcase;
1803
1804 default:
1805 ERR("pfCatch: Unrecognised token = 0x");
1806 ffDotHex(Token);
1807 ERR(" at 0x");
1808 ffDotHex((cell_t) InsPtr);
1809 EMIT_CR;
1810 InsPtr = 0;
1811 endcase;
1812 }
1813
1814 if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */
1815
1816#ifdef PF_DEBUG
1817 M_DOTS;
1818#endif
1819
1820#if 0
1821 if( _CrtCheckMemory() == 0 )
1822 {
1823 ERR("_CrtCheckMemory abort: InsPtr = 0x");
1824 ffDotHex((int)InsPtr);
1825 ERR("\n");
1826 }
1827#endif
1828
1829 } while( (InitialReturnStack - TORPTR) > 0 );
1830
1831 SAVE_REGISTERS;
1832
1833 return ExceptionReturnCode;
1834}
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.