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