Deleted Added
sdiff udiff text old ( 82960 ) new ( 94290 )
full compact
words.c (82960) words.c (94290)
1/*******************************************************************
2** w o r d s . c
3** Forth Inspired Command Language
4** ANS Forth CORE word-set written in C
5** Author: John Sadler (john_sadler@alum.mit.edu)
6** Created: 19 July 1997
1/*******************************************************************
2** w o r d s . c
3** Forth Inspired Command Language
4** ANS Forth CORE word-set written in C
5** Author: John Sadler (john_sadler@alum.mit.edu)
6** Created: 19 July 1997
7** $Id: words.c,v 1.11 2001-04-26 21:41:15-07 jsadler Exp jsadler $
7** $Id: words.c,v 1.17 2001/12/05 07:21:34 jsadler Exp $
8*******************************************************************/
9/*
10** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11** All rights reserved.
12**
13** Get the latest Ficl release at http://ficl.sourceforge.net
14**
8*******************************************************************/
9/*
10** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11** All rights reserved.
12**
13** Get the latest Ficl release at http://ficl.sourceforge.net
14**
15** I am interested in hearing from anyone who uses ficl. If you have
16** a problem, a success story, a defect, an enhancement request, or
17** if you would like to contribute to the ficl release, please
18** contact me by email at the address above.
19**
15** L I C E N S E and D I S C L A I M E R
16**
17** Redistribution and use in source and binary forms, with or without
18** modification, are permitted provided that the following conditions
19** are met:
20** 1. Redistributions of source code must retain the above copyright
21** notice, this list of conditions and the following disclaimer.
22** 2. Redistributions in binary form must reproduce the above copyright

--- 6 unchanged lines hidden (view full) ---

29** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
30** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
31** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
32** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
33** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
34** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
35** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
36** SUCH DAMAGE.
20** L I C E N S E and D I S C L A I M E R
21**
22** Redistribution and use in source and binary forms, with or without
23** modification, are permitted provided that the following conditions
24** are met:
25** 1. Redistributions of source code must retain the above copyright
26** notice, this list of conditions and the following disclaimer.
27** 2. Redistributions in binary form must reproduce the above copyright

--- 6 unchanged lines hidden (view full) ---

34** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41** SUCH DAMAGE.
37**
38** I am interested in hearing from anyone who uses ficl. If you have
39** a problem, a success story, a defect, an enhancement request, or
40** if you would like to contribute to the ficl release, please send
41** contact me by email at the address above.
42**
43** $Id: words.c,v 1.11 2001-04-26 21:41:15-07 jsadler Exp jsadler $
44*/
45
42*/
43
46/* $FreeBSD: head/sys/boot/ficl/words.c 82960 2001-09-04 13:13:12Z dfr $ */
44/* $FreeBSD: head/sys/boot/ficl/words.c 94290 2002-04-09 17:45:28Z dcs $ */
47
48#ifdef TESTMAIN
49#include <stdlib.h>
50#include <stdio.h>
51#include <ctype.h>
52#include <fcntl.h>
53#else
54#include <stand.h>

--- 13 unchanged lines hidden (view full) ---

68*/
69static char doTag[] = "do";
70static char colonTag[] = "colon";
71static char leaveTag[] = "leave";
72
73static char destTag[] = "target";
74static char origTag[] = "origin";
75
45
46#ifdef TESTMAIN
47#include <stdlib.h>
48#include <stdio.h>
49#include <ctype.h>
50#include <fcntl.h>
51#else
52#include <stand.h>

--- 13 unchanged lines hidden (view full) ---

66*/
67static char doTag[] = "do";
68static char colonTag[] = "colon";
69static char leaveTag[] = "leave";
70
71static char destTag[] = "target";
72static char origTag[] = "origin";
73
76/*
77** Pointers to various words in the dictionary
78** -- initialized by ficlCompileCore, below --
79** for use by compiling words. Colon definitions
80** in ficl are lists of pointers to words. A bit
81** simple-minded...
82*/
83static FICL_WORD *pBranchParen = NULL;
84static FICL_WORD *pComma = NULL;
85static FICL_WORD *pDoParen = NULL;
86static FICL_WORD *pDoesParen = NULL;
87static FICL_WORD *pExitParen = NULL;
88static FICL_WORD *pIfParen = NULL;
89static FICL_WORD *pInterpret = NULL;
90static FICL_WORD *pLitParen = NULL;
91static FICL_WORD *pTwoLitParen = NULL;
92static FICL_WORD *pLoopParen = NULL;
93static FICL_WORD *pPLoopParen = NULL;
94static FICL_WORD *pPlusStore = NULL;
95static FICL_WORD *pQDoParen = NULL;
96static FICL_WORD *pSemiParen = NULL;
97static FICL_WORD *pStore = NULL;
98static FICL_WORD *pStringLit = NULL;
99static FICL_WORD *pType = NULL;
100
101#if FICL_WANT_LOCALS
74#if FICL_WANT_LOCALS
102static FICL_WORD *pGetLocalParen= NULL;
103static FICL_WORD *pGet2LocalParen= NULL;
104static FICL_WORD *pGetLocal0 = NULL;
105static FICL_WORD *pGetLocal1 = NULL;
106static FICL_WORD *pToLocalParen = NULL;
107static FICL_WORD *pTo2LocalParen = NULL;
108static FICL_WORD *pToLocal0 = NULL;
109static FICL_WORD *pToLocal1 = NULL;
110static FICL_WORD *pLinkParen = NULL;
111static FICL_WORD *pUnLinkParen = NULL;
112static int nLocals = 0;
113static CELL *pMarkLocals = NULL;
114
115static void doLocalIm(FICL_VM *pVM);
116static void do2LocalIm(FICL_VM *pVM);
75static void doLocalIm(FICL_VM *pVM);
76static void do2LocalIm(FICL_VM *pVM);
117
118#endif
119
120
121/*
122** C O N T R O L S T R U C T U R E B U I L D E R S
123**
124** Push current dict location for later branch resolution.
125** The location may be either a branch target or a patch address...

--- 31 unchanged lines hidden (view full) ---

157
158/*
159** Expect a branch target address on the param stack,
160** compile a literal offset from the current dict location
161** to the target address
162*/
163static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
164{
77#endif
78
79
80/*
81** C O N T R O L S T R U C T U R E B U I L D E R S
82**
83** Push current dict location for later branch resolution.
84** The location may be either a branch target or a patch address...

--- 31 unchanged lines hidden (view full) ---

116
117/*
118** Expect a branch target address on the param stack,
119** compile a literal offset from the current dict location
120** to the target address
121*/
122static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
123{
165 long offset;
124 FICL_INT offset;
166 CELL *patchAddr;
167
168 matchControlTag(pVM, tag);
169
170#if FICL_ROBUST > 1
171 vmCheckStack(pVM, 1, 0);
172#endif
173 patchAddr = (CELL *)stackPopPtr(pVM->pStack);

--- 6 unchanged lines hidden (view full) ---

180
181/*
182** Expect a branch patch address on the param stack,
183** compile a literal offset from the patch location
184** to the current dict location
185*/
186static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
187{
125 CELL *patchAddr;
126
127 matchControlTag(pVM, tag);
128
129#if FICL_ROBUST > 1
130 vmCheckStack(pVM, 1, 0);
131#endif
132 patchAddr = (CELL *)stackPopPtr(pVM->pStack);

--- 6 unchanged lines hidden (view full) ---

139
140/*
141** Expect a branch patch address on the param stack,
142** compile a literal offset from the patch location
143** to the current dict location
144*/
145static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
146{
188 long offset;
147 FICL_INT offset;
189 CELL *patchAddr;
190
191 matchControlTag(pVM, tag);
192
193#if FICL_ROBUST > 1
194 vmCheckStack(pVM, 1, 0);
195#endif
196 patchAddr = (CELL *)stackPopPtr(pVM->pStack);

--- 33 unchanged lines hidden (view full) ---

230}
231
232
233/**************************************************************************
234 f i c l P a r s e N u m b e r
235** Attempts to convert the NULL terminated string in the VM's pad to
236** a number using the VM's current base. If successful, pushes the number
237** onto the param stack and returns TRUE. Otherwise, returns FALSE.
148 CELL *patchAddr;
149
150 matchControlTag(pVM, tag);
151
152#if FICL_ROBUST > 1
153 vmCheckStack(pVM, 1, 0);
154#endif
155 patchAddr = (CELL *)stackPopPtr(pVM->pStack);

--- 33 unchanged lines hidden (view full) ---

189}
190
191
192/**************************************************************************
193 f i c l P a r s e N u m b e r
194** Attempts to convert the NULL terminated string in the VM's pad to
195** a number using the VM's current base. If successful, pushes the number
196** onto the param stack and returns TRUE. Otherwise, returns FALSE.
197** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
198** the standard for DOUBLE wordset.
238**************************************************************************/
239
240int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
241{
242 FICL_INT accum = 0;
243 char isNeg = FALSE;
199**************************************************************************/
200
201int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
202{
203 FICL_INT accum = 0;
204 char isNeg = FALSE;
205 char hasDP = FALSE;
244 unsigned base = pVM->base;
245 char *cp = SI_PTR(si);
246 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
247 unsigned ch;
248 unsigned digit;
249
250 if (count > 1)
251 {

--- 9 unchanged lines hidden (view full) ---

261 count--;
262 isNeg = FALSE;
263 break;
264 default:
265 break;
266 }
267 }
268
206 unsigned base = pVM->base;
207 char *cp = SI_PTR(si);
208 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
209 unsigned ch;
210 unsigned digit;
211
212 if (count > 1)
213 {

--- 9 unchanged lines hidden (view full) ---

223 count--;
224 isNeg = FALSE;
225 break;
226 default:
227 break;
228 }
229 }
230
269 if (count == 0)
231 if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
232 {
233 hasDP = TRUE;
234 count--;
235 }
236
237 if (count == 0) /* detect "+", "-", ".", "+." etc */
270 return FALSE;
271
272 while ((count--) && ((ch = *cp++) != '\0'))
273 {
274 if (!isalnum(ch))
275 return FALSE;
276
277 digit = ch - '0';
278
279 if (digit > 9)
280 digit = tolower(ch) - 'a' + 10;
281
282 if (digit >= base)
283 return FALSE;
284
285 accum = accum * base + digit;
286 }
287
238 return FALSE;
239
240 while ((count--) && ((ch = *cp++) != '\0'))
241 {
242 if (!isalnum(ch))
243 return FALSE;
244
245 digit = ch - '0';
246
247 if (digit > 9)
248 digit = tolower(ch) - 'a' + 10;
249
250 if (digit >= base)
251 return FALSE;
252
253 accum = accum * base + digit;
254 }
255
256 if (hasDP) /* simple (required) DOUBLE support */
257 PUSHINT(0);
258
288 if (isNeg)
289 accum = -accum;
290
291 PUSHINT(accum);
292 if (pVM->state == COMPILE)
293 literalIm(pVM);
294
295 return TRUE;

--- 185 unchanged lines hidden (view full) ---

481** Code to begin compiling a colon definition
482** This function sets the state to COMPILE, then creates a
483** new word whose name is the next word in the input stream
484** and whose code is colonParen.
485**************************************************************************/
486
487static void colon(FICL_VM *pVM)
488{
259 if (isNeg)
260 accum = -accum;
261
262 PUSHINT(accum);
263 if (pVM->state == COMPILE)
264 literalIm(pVM);
265
266 return TRUE;

--- 185 unchanged lines hidden (view full) ---

452** Code to begin compiling a colon definition
453** This function sets the state to COMPILE, then creates a
454** new word whose name is the next word in the input stream
455** and whose code is colonParen.
456**************************************************************************/
457
458static void colon(FICL_VM *pVM)
459{
489 FICL_DICT *dp = ficlGetDict();
460 FICL_DICT *dp = vmGetDict(pVM);
490 STRINGINFO si = vmGetWord(pVM);
491
492 dictCheckThreshold(dp);
493
494 pVM->state = COMPILE;
495 markControlTag(pVM, colonTag);
496 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
497#if FICL_WANT_LOCALS
461 STRINGINFO si = vmGetWord(pVM);
462
463 dictCheckThreshold(dp);
464
465 pVM->state = COMPILE;
466 markControlTag(pVM, colonTag);
467 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
468#if FICL_WANT_LOCALS
498 nLocals = 0;
469 pVM->pSys->nLocals = 0;
499#endif
500 return;
501}
502
503
504/**************************************************************************
505 c o l o n P a r e n
506** This is the code that executes a colon definition. It assumes that the

--- 27 unchanged lines hidden (view full) ---

534{
535 vmPopIP(pVM);
536 return;
537}
538
539
540static void semicolonCoIm(FICL_VM *pVM)
541{
470#endif
471 return;
472}
473
474
475/**************************************************************************
476 c o l o n P a r e n
477** This is the code that executes a colon definition. It assumes that the

--- 27 unchanged lines hidden (view full) ---

505{
506 vmPopIP(pVM);
507 return;
508}
509
510
511static void semicolonCoIm(FICL_VM *pVM)
512{
542 FICL_DICT *dp = ficlGetDict();
513 FICL_DICT *dp = vmGetDict(pVM);
543
514
544 assert(pSemiParen);
515 assert(pVM->pSys->pSemiParen);
545 matchControlTag(pVM, colonTag);
546
547#if FICL_WANT_LOCALS
516 matchControlTag(pVM, colonTag);
517
518#if FICL_WANT_LOCALS
548 assert(pUnLinkParen);
549 if (nLocals > 0)
519 assert(pVM->pSys->pUnLinkParen);
520 if (pVM->pSys->nLocals > 0)
550 {
521 {
551 FICL_DICT *pLoc = ficlGetLoc();
522 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
552 dictEmpty(pLoc, pLoc->pForthWords->size);
523 dictEmpty(pLoc, pLoc->pForthWords->size);
553 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
524 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
554 }
525 }
555 nLocals = 0;
526 pVM->pSys->nLocals = 0;
556#endif
557
527#endif
528
558 dictAppendCell(dp, LVALUEtoCELL(pSemiParen));
529 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
559 pVM->state = INTERPRET;
560 dictUnsmudge(dp);
561 return;
562}
563
564
565/**************************************************************************
566 e x i t

--- 7 unchanged lines hidden (view full) ---

574static void exitParen(FICL_VM *pVM)
575{
576 vmPopIP(pVM);
577 return;
578}
579
580static void exitCoIm(FICL_VM *pVM)
581{
530 pVM->state = INTERPRET;
531 dictUnsmudge(dp);
532 return;
533}
534
535
536/**************************************************************************
537 e x i t

--- 7 unchanged lines hidden (view full) ---

545static void exitParen(FICL_VM *pVM)
546{
547 vmPopIP(pVM);
548 return;
549}
550
551static void exitCoIm(FICL_VM *pVM)
552{
582 FICL_DICT *dp = ficlGetDict();
583 assert(pExitParen);
553 FICL_DICT *dp = vmGetDict(pVM);
554 assert(pVM->pSys->pExitParen);
584 IGNORE(pVM);
585
586#if FICL_WANT_LOCALS
555 IGNORE(pVM);
556
557#if FICL_WANT_LOCALS
587 if (nLocals > 0)
558 if (pVM->pSys->nLocals > 0)
588 {
559 {
589 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
560 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
590 }
591#endif
561 }
562#endif
592 dictAppendCell(dp, LVALUEtoCELL(pExitParen));
563 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
593 return;
594}
595
596
597/**************************************************************************
598 c o n s t a n t P a r e n
599** This is the run-time code for "constant". It simply returns the
600** contents of its word's first data cell.

--- 26 unchanged lines hidden (view full) ---

627 c o n s t a n t
628** IMMEDIATE
629** Compiles a constant into the dictionary. Constants return their
630** value when invoked. Expects a value on top of the parm stack.
631**************************************************************************/
632
633static void constant(FICL_VM *pVM)
634{
564 return;
565}
566
567
568/**************************************************************************
569 c o n s t a n t P a r e n
570** This is the run-time code for "constant". It simply returns the
571** contents of its word's first data cell.

--- 26 unchanged lines hidden (view full) ---

598 c o n s t a n t
599** IMMEDIATE
600** Compiles a constant into the dictionary. Constants return their
601** value when invoked. Expects a value on top of the parm stack.
602**************************************************************************/
603
604static void constant(FICL_VM *pVM)
605{
635 FICL_DICT *dp = ficlGetDict();
606 FICL_DICT *dp = vmGetDict(pVM);
636 STRINGINFO si = vmGetWord(pVM);
637
638#if FICL_ROBUST > 1
639 vmCheckStack(pVM, 1, 0);
640#endif
641 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
642 dictAppendCell(dp, stackPop(pVM->pStack));
643 return;
644}
645
646
647static void twoConstant(FICL_VM *pVM)
648{
607 STRINGINFO si = vmGetWord(pVM);
608
609#if FICL_ROBUST > 1
610 vmCheckStack(pVM, 1, 0);
611#endif
612 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
613 dictAppendCell(dp, stackPop(pVM->pStack));
614 return;
615}
616
617
618static void twoConstant(FICL_VM *pVM)
619{
649 FICL_DICT *dp = ficlGetDict();
620 FICL_DICT *dp = vmGetDict(pVM);
650 STRINGINFO si = vmGetWord(pVM);
651 CELL c;
652
653#if FICL_ROBUST > 1
654 vmCheckStack(pVM, 2, 0);
655#endif
656 c = stackPop(pVM->pStack);
657 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);

--- 46 unchanged lines hidden (view full) ---

704 ultoa(u, pVM->pad, 16);
705 strcat(pVM->pad, " ");
706 vmTextOut(pVM, pVM->pad, 0);
707 return;
708}
709
710
711/**************************************************************************
621 STRINGINFO si = vmGetWord(pVM);
622 CELL c;
623
624#if FICL_ROBUST > 1
625 vmCheckStack(pVM, 2, 0);
626#endif
627 c = stackPop(pVM->pStack);
628 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);

--- 46 unchanged lines hidden (view full) ---

675 ultoa(u, pVM->pad, 16);
676 strcat(pVM->pad, " ");
677 vmTextOut(pVM, pVM->pad, 0);
678 return;
679}
680
681
682/**************************************************************************
683 s t r l e n
684** FICL ( c-string -- length )
685**
686** Returns the length of a C-style (zero-terminated) string.
687**
688** --lch
689**/
690static void ficlStrlen(FICL_VM *ficlVM)
691 {
692 char *address = (char *)stackPopPtr(ficlVM->pStack);
693 stackPushINT(ficlVM->pStack, strlen(address));
694 }
695
696
697/**************************************************************************
698 s p r i n t f
699** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
700** Similar to the C sprintf() function. It formats into a buffer based on
701** a "format" string. Each character in the format string is copied verbatim
702** to the output buffer, until SPRINTF encounters a percent sign ("%").
703** SPRINTF then skips the percent sign, and examines the next character
704** (the "format character"). Here are the valid format characters:
705** s - read a C-ADDR U-LENGTH string from the stack and copy it to
706** the buffer
707** d - read a cell from the stack, format it as a string (base-10,
708** signed), and copy it to the buffer
709** x - same as d, except in base-16
710** u - same as d, but unsigned
711** % - output a literal percent-sign to the buffer
712** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
713** written, and a flag indicating whether or not it ran out of space while
714** writing to the output buffer (TRUE if it ran out of space).
715**
716** If SPRINTF runs out of space in the buffer to store the formatted string,
717** it still continues parsing, in an effort to preserve your stack (otherwise
718** it might leave uneaten arguments behind).
719**
720** --lch
721**************************************************************************/
722static void ficlSprintf(FICL_VM *pVM) /* */
723{
724 int bufferLength = stackPopINT(pVM->pStack);
725 char *buffer = (char *)stackPopPtr(pVM->pStack);
726 char *bufferStart = buffer;
727
728 int formatLength = stackPopINT(pVM->pStack);
729 char *format = (char *)stackPopPtr(pVM->pStack);
730 char *formatStop = format + formatLength;
731
732 int base = 10;
733 int unsignedInteger = FALSE;
734
735 int append = FICL_TRUE;
736
737 while (format < formatStop)
738 {
739 char scratch[64];
740 char *source;
741 int actualLength;
742 int desiredLength;
743 int leadingZeroes;
744
745
746 if (*format != '%')
747 {
748 source = format;
749 actualLength = desiredLength = 1;
750 leadingZeroes = 0;
751 }
752 else
753 {
754 format++;
755 if (format == formatStop)
756 break;
757
758 leadingZeroes = (*format == '0');
759 if (leadingZeroes)
760 {
761 format++;
762 if (format == formatStop)
763 break;
764 }
765
766 desiredLength = isdigit(*format);
767 if (desiredLength)
768 {
769 desiredLength = strtol(format, &format, 10);
770 if (format == formatStop)
771 break;
772 }
773 else if (*format == '*')
774 {
775 desiredLength = stackPopINT(pVM->pStack);
776 format++;
777 if (format == formatStop)
778 break;
779 }
780
781
782 switch (*format)
783 {
784 case 's':
785 case 'S':
786 {
787 actualLength = stackPopINT(pVM->pStack);
788 source = (char *)stackPopPtr(pVM->pStack);
789 break;
790 }
791 case 'x':
792 case 'X':
793 base = 16;
794 case 'u':
795 case 'U':
796 unsignedInteger = TRUE;
797 case 'd':
798 case 'D':
799 {
800 int integer = stackPopINT(pVM->pStack);
801 if (unsignedInteger)
802 ultoa(integer, scratch, base);
803 else
804 ltoa(integer, scratch, base);
805 base = 10;
806 unsignedInteger = FALSE;
807 source = scratch;
808 actualLength = strlen(scratch);
809 break;
810 }
811 case '%':
812 source = format;
813 actualLength = 1;
814 default:
815 continue;
816 }
817 }
818
819 if (append == FICL_TRUE)
820 {
821 if (!desiredLength)
822 desiredLength = actualLength;
823 if (desiredLength > bufferLength)
824 {
825 append = FICL_FALSE;
826 desiredLength = bufferLength;
827 }
828 while (desiredLength > actualLength)
829 {
830 *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
831 bufferLength--;
832 desiredLength--;
833 }
834 memcpy(buffer, source, actualLength);
835 buffer += actualLength;
836 bufferLength -= actualLength;
837 }
838
839 format++;
840 }
841
842 stackPushPtr(pVM->pStack, bufferStart);
843 stackPushINT(pVM->pStack, buffer - bufferStart);
844 stackPushINT(pVM->pStack, append);
845}
846
847
848/**************************************************************************
712 d u p & f r i e n d s
713**
714**************************************************************************/
715
716static void depth(FICL_VM *pVM)
717{
718 int i;
719#if FICL_ROBUST > 1

--- 367 unchanged lines hidden (view full) ---

1087** IMMEDIATE
1088** Compiles code for a conditional branch into the dictionary
1089** and pushes the branch patch address on the stack for later
1090** patching by ELSE or THEN/ENDIF.
1091**************************************************************************/
1092
1093static void ifCoIm(FICL_VM *pVM)
1094{
849 d u p & f r i e n d s
850**
851**************************************************************************/
852
853static void depth(FICL_VM *pVM)
854{
855 int i;
856#if FICL_ROBUST > 1

--- 367 unchanged lines hidden (view full) ---

1224** IMMEDIATE
1225** Compiles code for a conditional branch into the dictionary
1226** and pushes the branch patch address on the stack for later
1227** patching by ELSE or THEN/ENDIF.
1228**************************************************************************/
1229
1230static void ifCoIm(FICL_VM *pVM)
1231{
1095 FICL_DICT *dp = ficlGetDict();
1232 FICL_DICT *dp = vmGetDict(pVM);
1096
1233
1097 assert(pIfParen);
1234 assert(pVM->pSys->pIfParen);
1098
1235
1099 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
1236 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
1100 markBranch(dp, pVM, origTag);
1101 dictAppendUNS(dp, 1);
1102 return;
1103}
1104
1105
1106/**************************************************************************
1107 i f P a r e n

--- 35 unchanged lines hidden (view full) ---

1143** 4) Push the "else" patch address. ("endif" patches this to jump past
1144** the "else" code.
1145**************************************************************************/
1146
1147static void elseCoIm(FICL_VM *pVM)
1148{
1149 CELL *patchAddr;
1150 FICL_INT offset;
1237 markBranch(dp, pVM, origTag);
1238 dictAppendUNS(dp, 1);
1239 return;
1240}
1241
1242
1243/**************************************************************************
1244 i f P a r e n

--- 35 unchanged lines hidden (view full) ---

1280** 4) Push the "else" patch address. ("endif" patches this to jump past
1281** the "else" code.
1282**************************************************************************/
1283
1284static void elseCoIm(FICL_VM *pVM)
1285{
1286 CELL *patchAddr;
1287 FICL_INT offset;
1151 FICL_DICT *dp = ficlGetDict();
1288 FICL_DICT *dp = vmGetDict(pVM);
1152
1289
1153 assert(pBranchParen);
1290 assert(pVM->pSys->pBranchParen);
1154 /* (1) compile branch runtime */
1291 /* (1) compile branch runtime */
1155 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
1292 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1156 matchControlTag(pVM, origTag);
1157 patchAddr =
1158 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1159 markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
1160 dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
1161 offset = dp->here - patchAddr;
1162 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1163

--- 17 unchanged lines hidden (view full) ---

1181
1182/**************************************************************************
1183 e n d i f C o I m
1184**
1185**************************************************************************/
1186
1187static void endifCoIm(FICL_VM *pVM)
1188{
1293 matchControlTag(pVM, origTag);
1294 patchAddr =
1295 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1296 markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
1297 dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
1298 offset = dp->here - patchAddr;
1299 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1300

--- 17 unchanged lines hidden (view full) ---

1318
1319/**************************************************************************
1320 e n d i f C o I m
1321**
1322**************************************************************************/
1323
1324static void endifCoIm(FICL_VM *pVM)
1325{
1189 FICL_DICT *dp = ficlGetDict();
1326 FICL_DICT *dp = vmGetDict(pVM);
1190 resolveForwardBranch(dp, pVM, origTag);
1191 return;
1192}
1193
1194
1195/**************************************************************************
1196 h a s h
1197** hash ( c-addr u -- code)

--- 31 unchanged lines hidden (view full) ---

1229
1230static void interpret(FICL_VM *pVM)
1231{
1232 STRINGINFO si;
1233 int i;
1234 FICL_SYSTEM *pSys;
1235
1236 assert(pVM);
1327 resolveForwardBranch(dp, pVM, origTag);
1328 return;
1329}
1330
1331
1332/**************************************************************************
1333 h a s h
1334** hash ( c-addr u -- code)

--- 31 unchanged lines hidden (view full) ---

1366
1367static void interpret(FICL_VM *pVM)
1368{
1369 STRINGINFO si;
1370 int i;
1371 FICL_SYSTEM *pSys;
1372
1373 assert(pVM);
1374
1237 pSys = pVM->pSys;
1238 si = vmGetWord0(pVM);
1239
1240 /*
1241 ** Get next word...if out of text, we're done.
1242 */
1243 if (si.count == 0)
1244 {

--- 8 unchanged lines hidden (view full) ---

1253 ** in for robustness. ficlInitSystem adds the other default steps to the list.
1254 */
1255 if (ficlParseWord(pVM, si))
1256 return;
1257
1258 for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1259 {
1260 FICL_WORD *pFW = pSys->parseList[i];
1375 pSys = pVM->pSys;
1376 si = vmGetWord0(pVM);
1377
1378 /*
1379 ** Get next word...if out of text, we're done.
1380 */
1381 if (si.count == 0)
1382 {

--- 8 unchanged lines hidden (view full) ---

1391 ** in for robustness. ficlInitSystem adds the other default steps to the list.
1392 */
1393 if (ficlParseWord(pVM, si))
1394 return;
1395
1396 for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1397 {
1398 FICL_WORD *pFW = pSys->parseList[i];
1261 FICL_PARSE_STEP pStep;
1262
1263 if (pFW == NULL)
1264 break;
1265
1399
1400 if (pFW == NULL)
1401 break;
1402
1266 pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1267 if ((*pStep)(pVM, si))
1268 return;
1403 if (pFW->code == parseStepParen)
1404 {
1405 FICL_PARSE_STEP pStep;
1406 pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1407 if ((*pStep)(pVM, si))
1408 return;
1409 }
1410 else
1411 {
1412 stackPushPtr(pVM->pStack, SI_PTR(si));
1413 stackPushUNS(pVM->pStack, SI_COUNT(si));
1414 ficlExecXT(pVM, pFW);
1415 if (stackPopINT(pVM->pStack))
1416 return;
1417 }
1269 }
1270
1271 i = SI_COUNT(si);
1272 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1273
1274 return; /* back to inner interpreter */
1275}
1276

--- 15 unchanged lines hidden (view full) ---

1292** the stack (see 6.1.1780 LITERAL), and continue at a);
1293**
1294** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1295**
1296** (jws 4/01) Modified to be a FICL_PARSE_STEP
1297**************************************************************************/
1298static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1299{
1418 }
1419
1420 i = SI_COUNT(si);
1421 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1422
1423 return; /* back to inner interpreter */
1424}
1425

--- 15 unchanged lines hidden (view full) ---

1441** the stack (see 6.1.1780 LITERAL), and continue at a);
1442**
1443** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1444**
1445** (jws 4/01) Modified to be a FICL_PARSE_STEP
1446**************************************************************************/
1447static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1448{
1300 FICL_DICT *dp = ficlGetDict();
1449 FICL_DICT *dp = vmGetDict(pVM);
1301 FICL_WORD *tempFW;
1302
1303#if FICL_ROBUST
1304 dictCheck(dp, pVM, 0);
1305 vmCheckStack(pVM, 0, 0);
1306#endif
1307
1308#if FICL_WANT_LOCALS
1450 FICL_WORD *tempFW;
1451
1452#if FICL_ROBUST
1453 dictCheck(dp, pVM, 0);
1454 vmCheckStack(pVM, 0, 0);
1455#endif
1456
1457#if FICL_WANT_LOCALS
1309 if (nLocals > 0)
1458 if (pVM->pSys->nLocals > 0)
1310 {
1459 {
1311 tempFW = dictLookupLoc(dp, si);
1460 tempFW = ficlLookupLoc(pVM->pSys, si);
1312 }
1313 else
1314#endif
1315 tempFW = dictLookup(dp, si);
1316
1317 if (pVM->state == INTERPRET)
1318 {
1319 if (tempFW != NULL)

--- 23 unchanged lines hidden (view full) ---

1343 return FICL_TRUE;
1344 }
1345 }
1346
1347 return FICL_FALSE;
1348}
1349
1350
1461 }
1462 else
1463#endif
1464 tempFW = dictLookup(dp, si);
1465
1466 if (pVM->state == INTERPRET)
1467 {
1468 if (tempFW != NULL)

--- 23 unchanged lines hidden (view full) ---

1492 return FICL_TRUE;
1493 }
1494 }
1495
1496 return FICL_FALSE;
1497}
1498
1499
1500/*
1501** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
1502** INTERPRET)
1503*/
1504static void lookup(FICL_VM *pVM)
1505{
1506 STRINGINFO si;
1507 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1508 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1509 stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
1510 return;
1511}
1512
1513
1351/**************************************************************************
1352 p a r e n P a r s e S t e p
1353** (parse-step) ( c-addr u -- flag )
1354** runtime for a precompiled parse step - pop a counted string off the
1355** stack, run the parse step against it, and push the result flag (FICL_TRUE
1356** if success, FICL_FALSE otherwise).
1357**************************************************************************/
1358

--- 10 unchanged lines hidden (view full) ---

1369
1370 return;
1371}
1372
1373
1374static void addParseStep(FICL_VM *pVM)
1375{
1376 FICL_WORD *pStep;
1514/**************************************************************************
1515 p a r e n P a r s e S t e p
1516** (parse-step) ( c-addr u -- flag )
1517** runtime for a precompiled parse step - pop a counted string off the
1518** stack, run the parse step against it, and push the result flag (FICL_TRUE
1519** if success, FICL_FALSE otherwise).
1520**************************************************************************/
1521

--- 10 unchanged lines hidden (view full) ---

1532
1533 return;
1534}
1535
1536
1537static void addParseStep(FICL_VM *pVM)
1538{
1539 FICL_WORD *pStep;
1540 FICL_DICT *pd = vmGetDict(pVM);
1377#if FICL_ROBUST > 1
1378 vmCheckStack(pVM, 1, 0);
1379#endif
1380 pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1541#if FICL_ROBUST > 1
1542 vmCheckStack(pVM, 1, 0);
1543#endif
1544 pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1381 if ((pStep != NULL) && isAFiclWord(pStep))
1545 if ((pStep != NULL) && isAFiclWord(pd, pStep))
1382 ficlAddParseStep(pVM->pSys, pStep);
1383 return;
1384}
1385
1386
1387/**************************************************************************
1388 l i t e r a l P a r e n
1389**

--- 30 unchanged lines hidden (view full) ---

1420**
1421** IMMEDIATE code for "literal". This function gets a value from the stack
1422** and compiles it into the dictionary preceded by the code for "(literal)".
1423** IMMEDIATE
1424**************************************************************************/
1425
1426static void literalIm(FICL_VM *pVM)
1427{
1546 ficlAddParseStep(pVM->pSys, pStep);
1547 return;
1548}
1549
1550
1551/**************************************************************************
1552 l i t e r a l P a r e n
1553**

--- 30 unchanged lines hidden (view full) ---

1584**
1585** IMMEDIATE code for "literal". This function gets a value from the stack
1586** and compiles it into the dictionary preceded by the code for "(literal)".
1587** IMMEDIATE
1588**************************************************************************/
1589
1590static void literalIm(FICL_VM *pVM)
1591{
1428 FICL_DICT *dp = ficlGetDict();
1429 assert(pLitParen);
1592 FICL_DICT *dp = vmGetDict(pVM);
1593 assert(pVM->pSys->pLitParen);
1430
1594
1431 dictAppendCell(dp, LVALUEtoCELL(pLitParen));
1595 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
1432 dictAppendCell(dp, stackPop(pVM->pStack));
1433
1434 return;
1435}
1436
1437
1438static void twoLiteralIm(FICL_VM *pVM)
1439{
1596 dictAppendCell(dp, stackPop(pVM->pStack));
1597
1598 return;
1599}
1600
1601
1602static void twoLiteralIm(FICL_VM *pVM)
1603{
1440 FICL_DICT *dp = ficlGetDict();
1441 assert(pTwoLitParen);
1604 FICL_DICT *dp = vmGetDict(pVM);
1605 assert(pVM->pSys->pTwoLitParen);
1442
1606
1443 dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen));
1607 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
1444 dictAppendCell(dp, stackPop(pVM->pStack));
1445 dictAppendCell(dp, stackPop(pVM->pStack));
1446
1447 return;
1448}
1449
1450/**************************************************************************
1451 l o g i c a n d c o m p a r i s o n s

--- 152 unchanged lines hidden (view full) ---

1604** limit and index are the loop control variables.
1605** leave -- COMPILE ONLY
1606** Runtime: pop the loop control variables, then pop the
1607** "leave" address and jump (absolute) there.
1608**************************************************************************/
1609
1610static void doCoIm(FICL_VM *pVM)
1611{
1608 dictAppendCell(dp, stackPop(pVM->pStack));
1609 dictAppendCell(dp, stackPop(pVM->pStack));
1610
1611 return;
1612}
1613
1614/**************************************************************************
1615 l o g i c a n d c o m p a r i s o n s

--- 152 unchanged lines hidden (view full) ---

1768** limit and index are the loop control variables.
1769** leave -- COMPILE ONLY
1770** Runtime: pop the loop control variables, then pop the
1771** "leave" address and jump (absolute) there.
1772**************************************************************************/
1773
1774static void doCoIm(FICL_VM *pVM)
1775{
1612 FICL_DICT *dp = ficlGetDict();
1776 FICL_DICT *dp = vmGetDict(pVM);
1613
1777
1614 assert(pDoParen);
1778 assert(pVM->pSys->pDoParen);
1615
1779
1616 dictAppendCell(dp, LVALUEtoCELL(pDoParen));
1780 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
1617 /*
1618 ** Allot space for a pointer to the end
1619 ** of the loop - "leave" uses this...
1620 */
1621 markBranch(dp, pVM, leaveTag);
1622 dictAppendUNS(dp, 0);
1623 /*
1624 ** Mark location of head of loop...

--- 19 unchanged lines hidden (view full) ---

1644 stackPush(pVM->rStack, index);
1645
1646 return;
1647}
1648
1649
1650static void qDoCoIm(FICL_VM *pVM)
1651{
1781 /*
1782 ** Allot space for a pointer to the end
1783 ** of the loop - "leave" uses this...
1784 */
1785 markBranch(dp, pVM, leaveTag);
1786 dictAppendUNS(dp, 0);
1787 /*
1788 ** Mark location of head of loop...

--- 19 unchanged lines hidden (view full) ---

1808 stackPush(pVM->rStack, index);
1809
1810 return;
1811}
1812
1813
1814static void qDoCoIm(FICL_VM *pVM)
1815{
1652 FICL_DICT *dp = ficlGetDict();
1816 FICL_DICT *dp = vmGetDict(pVM);
1653
1817
1654 assert(pQDoParen);
1818 assert(pVM->pSys->pQDoParen);
1655
1819
1656 dictAppendCell(dp, LVALUEtoCELL(pQDoParen));
1820 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
1657 /*
1658 ** Allot space for a pointer to the end
1659 ** of the loop - "leave" uses this...
1660 */
1661 markBranch(dp, pVM, leaveTag);
1662 dictAppendUNS(dp, 0);
1663 /*
1664 ** Mark location of head of loop...

--- 49 unchanged lines hidden (view full) ---

1714{
1715 stackDrop(pVM->rStack, 3);
1716 return;
1717}
1718
1719
1720static void loopCoIm(FICL_VM *pVM)
1721{
1821 /*
1822 ** Allot space for a pointer to the end
1823 ** of the loop - "leave" uses this...
1824 */
1825 markBranch(dp, pVM, leaveTag);
1826 dictAppendUNS(dp, 0);
1827 /*
1828 ** Mark location of head of loop...

--- 49 unchanged lines hidden (view full) ---

1878{
1879 stackDrop(pVM->rStack, 3);
1880 return;
1881}
1882
1883
1884static void loopCoIm(FICL_VM *pVM)
1885{
1722 FICL_DICT *dp = ficlGetDict();
1886 FICL_DICT *dp = vmGetDict(pVM);
1723
1887
1724 assert(pLoopParen);
1888 assert(pVM->pSys->pLoopParen);
1725
1889
1726 dictAppendCell(dp, LVALUEtoCELL(pLoopParen));
1890 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
1727 resolveBackBranch(dp, pVM, doTag);
1728 resolveAbsBranch(dp, pVM, leaveTag);
1729 return;
1730}
1731
1732
1733static void plusLoopCoIm(FICL_VM *pVM)
1734{
1891 resolveBackBranch(dp, pVM, doTag);
1892 resolveAbsBranch(dp, pVM, leaveTag);
1893 return;
1894}
1895
1896
1897static void plusLoopCoIm(FICL_VM *pVM)
1898{
1735 FICL_DICT *dp = ficlGetDict();
1899 FICL_DICT *dp = vmGetDict(pVM);
1736
1900
1737 assert(pPLoopParen);
1901 assert(pVM->pSys->pPLoopParen);
1738
1902
1739 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
1903 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
1740 resolveBackBranch(dp, pVM, doTag);
1741 resolveAbsBranch(dp, pVM, leaveTag);
1742 return;
1743}
1744
1745
1746static void loopParen(FICL_VM *pVM)
1747{

--- 14 unchanged lines hidden (view full) ---

1762 }
1763
1764 return;
1765}
1766
1767
1768static void plusLoopParen(FICL_VM *pVM)
1769{
1904 resolveBackBranch(dp, pVM, doTag);
1905 resolveAbsBranch(dp, pVM, leaveTag);
1906 return;
1907}
1908
1909
1910static void loopParen(FICL_VM *pVM)
1911{

--- 14 unchanged lines hidden (view full) ---

1926 }
1927
1928 return;
1929}
1930
1931
1932static void plusLoopParen(FICL_VM *pVM)
1933{
1770 FICL_INT index,limit,increment;
1771 int flag;
1934 FICL_INT index,limit,increment;
1935 int flag;
1772
1773#if FICL_ROBUST > 1
1936
1937#if FICL_ROBUST > 1
1774 vmCheckStack(pVM, 1, 0);
1938 vmCheckStack(pVM, 1, 0);
1775#endif
1776
1939#endif
1940
1777 index = stackGetTop(pVM->rStack).i;
1778 limit = stackFetch(pVM->rStack, 1).i;
1779 increment = POP().i;
1780
1781 index += increment;
1941 index = stackGetTop(pVM->rStack).i;
1942 limit = stackFetch(pVM->rStack, 1).i;
1943 increment = POP().i;
1944
1945 index += increment;
1782
1783 if (increment < 0)
1784 flag = (index < limit);
1785 else
1786 flag = (index >= limit);
1787
1788 if (flag)
1789 {

--- 39 unchanged lines hidden (view full) ---

1829
1830/**************************************************************************
1831 r e t u r n s t a c k
1832**
1833**************************************************************************/
1834static void toRStack(FICL_VM *pVM)
1835{
1836#if FICL_ROBUST > 1
1946
1947 if (increment < 0)
1948 flag = (index < limit);
1949 else
1950 flag = (index >= limit);
1951
1952 if (flag)
1953 {

--- 39 unchanged lines hidden (view full) ---

1993
1994/**************************************************************************
1995 r e t u r n s t a c k
1996**
1997**************************************************************************/
1998static void toRStack(FICL_VM *pVM)
1999{
2000#if FICL_ROBUST > 1
1837 vmCheckStack(pVM, 1, 0);
2001 vmCheckStack(pVM, 1, 0);
1838#endif
1839
2002#endif
2003
1840 stackPush(pVM->rStack, POP());
2004 stackPush(pVM->rStack, POP());
1841}
1842
1843static void fromRStack(FICL_VM *pVM)
1844{
1845#if FICL_ROBUST > 1
2005}
2006
2007static void fromRStack(FICL_VM *pVM)
2008{
2009#if FICL_ROBUST > 1
1846 vmCheckStack(pVM, 0, 1);
2010 vmCheckStack(pVM, 0, 1);
1847#endif
1848
2011#endif
2012
1849 PUSH(stackPop(pVM->rStack));
2013 PUSH(stackPop(pVM->rStack));
1850}
1851
1852static void fetchRStack(FICL_VM *pVM)
1853{
1854#if FICL_ROBUST > 1
2014}
2015
2016static void fetchRStack(FICL_VM *pVM)
2017{
2018#if FICL_ROBUST > 1
1855 vmCheckStack(pVM, 0, 1);
2019 vmCheckStack(pVM, 0, 1);
1856#endif
1857
2020#endif
2021
1858 PUSH(stackGetTop(pVM->rStack));
2022 PUSH(stackGetTop(pVM->rStack));
1859}
1860
1861static void twoToR(FICL_VM *pVM)
1862{
1863#if FICL_ROBUST > 1
1864 vmCheckStack(pVM, 2, 0);
1865#endif
1866 stackRoll(pVM->pStack, 1);

--- 26 unchanged lines hidden (view full) ---

1893
1894/**************************************************************************
1895 v a r i a b l e
1896**
1897**************************************************************************/
1898
1899static void variableParen(FICL_VM *pVM)
1900{
2023}
2024
2025static void twoToR(FICL_VM *pVM)
2026{
2027#if FICL_ROBUST > 1
2028 vmCheckStack(pVM, 2, 0);
2029#endif
2030 stackRoll(pVM->pStack, 1);

--- 26 unchanged lines hidden (view full) ---

2057
2058/**************************************************************************
2059 v a r i a b l e
2060**
2061**************************************************************************/
2062
2063static void variableParen(FICL_VM *pVM)
2064{
1901 FICL_WORD *fw;
2065 FICL_WORD *fw;
1902#if FICL_ROBUST > 1
2066#if FICL_ROBUST > 1
1903 vmCheckStack(pVM, 0, 1);
2067 vmCheckStack(pVM, 0, 1);
1904#endif
1905
2068#endif
2069
1906 fw = pVM->runningWord;
1907 PUSHPTR(fw->param);
2070 fw = pVM->runningWord;
2071 PUSHPTR(fw->param);
1908}
1909
1910
1911static void variable(FICL_VM *pVM)
1912{
2072}
2073
2074
2075static void variable(FICL_VM *pVM)
2076{
1913 FICL_DICT *dp = ficlGetDict();
2077 FICL_DICT *dp = vmGetDict(pVM);
1914 STRINGINFO si = vmGetWord(pVM);
1915
1916 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
1917 dictAllotCells(dp, 1);
1918 return;
1919}
1920
1921
1922static void twoVariable(FICL_VM *pVM)
1923{
2078 STRINGINFO si = vmGetWord(pVM);
2079
2080 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2081 dictAllotCells(dp, 1);
2082 return;
2083}
2084
2085
2086static void twoVariable(FICL_VM *pVM)
2087{
1924 FICL_DICT *dp = ficlGetDict();
2088 FICL_DICT *dp = vmGetDict(pVM);
1925 STRINGINFO si = vmGetWord(pVM);
1926
1927 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
1928 dictAllotCells(dp, 2);
1929 return;
1930}
1931
1932
1933/**************************************************************************
1934 b a s e & f r i e n d s
1935**
1936**************************************************************************/
1937
1938static void base(FICL_VM *pVM)
1939{
2089 STRINGINFO si = vmGetWord(pVM);
2090
2091 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2092 dictAllotCells(dp, 2);
2093 return;
2094}
2095
2096
2097/**************************************************************************
2098 b a s e & f r i e n d s
2099**
2100**************************************************************************/
2101
2102static void base(FICL_VM *pVM)
2103{
1940 CELL *pBase;
2104 CELL *pBase;
1941#if FICL_ROBUST > 1
2105#if FICL_ROBUST > 1
1942 vmCheckStack(pVM, 0, 1);
2106 vmCheckStack(pVM, 0, 1);
1943#endif
1944
2107#endif
2108
1945 pBase = (CELL *)(&pVM->base);
1946 PUSHPTR(pBase);
2109 pBase = (CELL *)(&pVM->base);
2110 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2111 return;
1947}
1948
1949
1950static void decimal(FICL_VM *pVM)
1951{
1952 pVM->base = 10;
1953 return;
1954}

--- 8 unchanged lines hidden (view full) ---

1963
1964/**************************************************************************
1965 a l l o t & f r i e n d s
1966**
1967**************************************************************************/
1968
1969static void allot(FICL_VM *pVM)
1970{
2112}
2113
2114
2115static void decimal(FICL_VM *pVM)
2116{
2117 pVM->base = 10;
2118 return;
2119}

--- 8 unchanged lines hidden (view full) ---

2128
2129/**************************************************************************
2130 a l l o t & f r i e n d s
2131**
2132**************************************************************************/
2133
2134static void allot(FICL_VM *pVM)
2135{
1971 FICL_DICT *dp;
1972 FICL_INT i;
2136 FICL_DICT *dp;
2137 FICL_INT i;
1973#if FICL_ROBUST > 1
2138#if FICL_ROBUST > 1
1974 vmCheckStack(pVM, 1, 0);
2139 vmCheckStack(pVM, 1, 0);
1975#endif
1976
2140#endif
2141
1977 dp = ficlGetDict();
1978 i = POPINT();
2142 dp = vmGetDict(pVM);
2143 i = POPINT();
1979
1980#if FICL_ROBUST
2144
2145#if FICL_ROBUST
1981 dictCheck(dp, pVM, i);
2146 dictCheck(dp, pVM, i);
1982#endif
1983
2147#endif
2148
1984 dictAllot(dp, i);
2149 dictAllot(dp, i);
1985 return;
1986}
1987
1988
1989static void here(FICL_VM *pVM)
1990{
2150 return;
2151}
2152
2153
2154static void here(FICL_VM *pVM)
2155{
1991 FICL_DICT *dp;
2156 FICL_DICT *dp;
1992#if FICL_ROBUST > 1
2157#if FICL_ROBUST > 1
1993 vmCheckStack(pVM, 0, 1);
2158 vmCheckStack(pVM, 0, 1);
1994#endif
1995
2159#endif
2160
1996 dp = ficlGetDict();
1997 PUSHPTR(dp->here);
2161 dp = vmGetDict(pVM);
2162 PUSHPTR(dp->here);
1998 return;
1999}
2000
2001static void comma(FICL_VM *pVM)
2002{
2163 return;
2164}
2165
2166static void comma(FICL_VM *pVM)
2167{
2003 FICL_DICT *dp;
2004 CELL c;
2168 FICL_DICT *dp;
2169 CELL c;
2005#if FICL_ROBUST > 1
2170#if FICL_ROBUST > 1
2006 vmCheckStack(pVM, 1, 0);
2171 vmCheckStack(pVM, 1, 0);
2007#endif
2008
2172#endif
2173
2009 dp = ficlGetDict();
2010 c = POP();
2011 dictAppendCell(dp, c);
2174 dp = vmGetDict(pVM);
2175 c = POP();
2176 dictAppendCell(dp, c);
2012 return;
2013}
2014
2015static void cComma(FICL_VM *pVM)
2016{
2177 return;
2178}
2179
2180static void cComma(FICL_VM *pVM)
2181{
2017 FICL_DICT *dp;
2018 char c;
2182 FICL_DICT *dp;
2183 char c;
2019#if FICL_ROBUST > 1
2184#if FICL_ROBUST > 1
2020 vmCheckStack(pVM, 1, 0);
2185 vmCheckStack(pVM, 1, 0);
2021#endif
2022
2186#endif
2187
2023 dp = ficlGetDict();
2024 c = (char)POPINT();
2025 dictAppendChar(dp, c);
2188 dp = vmGetDict(pVM);
2189 c = (char)POPINT();
2190 dictAppendChar(dp, c);
2026 return;
2027}
2028
2029static void cells(FICL_VM *pVM)
2030{
2191 return;
2192}
2193
2194static void cells(FICL_VM *pVM)
2195{
2031 FICL_INT i;
2196 FICL_INT i;
2032#if FICL_ROBUST > 1
2197#if FICL_ROBUST > 1
2033 vmCheckStack(pVM, 1, 1);
2198 vmCheckStack(pVM, 1, 1);
2034#endif
2035
2199#endif
2200
2036 i = POPINT();
2037 PUSHINT(i * (FICL_INT)sizeof (CELL));
2201 i = POPINT();
2202 PUSHINT(i * (FICL_INT)sizeof (CELL));
2038 return;
2039}
2040
2041static void cellPlus(FICL_VM *pVM)
2042{
2203 return;
2204}
2205
2206static void cellPlus(FICL_VM *pVM)
2207{
2043 char *cp;
2208 char *cp;
2044#if FICL_ROBUST > 1
2209#if FICL_ROBUST > 1
2045 vmCheckStack(pVM, 1, 1);
2210 vmCheckStack(pVM, 1, 1);
2046#endif
2047
2211#endif
2212
2048 cp = POPPTR();
2049 PUSHPTR(cp + sizeof (CELL));
2213 cp = POPPTR();
2214 PUSHPTR(cp + sizeof (CELL));
2050 return;
2051}
2052
2053
2054
2055/**************************************************************************
2056 t i c k
2057** tick CORE ( "<spaces>name" -- xt )
2058** Skip leading space delimiters. Parse name delimited by a space. Find
2059** name and return xt, the execution token for name. An ambiguous condition
2060** exists if name is not found.
2061**************************************************************************/
2062void ficlTick(FICL_VM *pVM)
2063{
2215 return;
2216}
2217
2218
2219
2220/**************************************************************************
2221 t i c k
2222** tick CORE ( "<spaces>name" -- xt )
2223** Skip leading space delimiters. Parse name delimited by a space. Find
2224** name and return xt, the execution token for name. An ambiguous condition
2225** exists if name is not found.
2226**************************************************************************/
2227void ficlTick(FICL_VM *pVM)
2228{
2064 FICL_WORD *pFW = NULL;
2065 STRINGINFO si = vmGetWord(pVM);
2229 FICL_WORD *pFW = NULL;
2230 STRINGINFO si = vmGetWord(pVM);
2066#if FICL_ROBUST > 1
2231#if FICL_ROBUST > 1
2067 vmCheckStack(pVM, 0, 1);
2232 vmCheckStack(pVM, 0, 1);
2068#endif
2069
2233#endif
2234
2070 pFW = dictLookup(ficlGetDict(), si);
2071 if (!pFW)
2072 {
2073 int i = SI_COUNT(si);
2074 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2075 }
2076 PUSHPTR(pFW);
2235 pFW = dictLookup(vmGetDict(pVM), si);
2236 if (!pFW)
2237 {
2238 int i = SI_COUNT(si);
2239 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2240 }
2241 PUSHPTR(pFW);
2077 return;
2078}
2079
2080
2081static void bracketTickCoIm(FICL_VM *pVM)
2082{
2083 ficlTick(pVM);
2084 literalIm(pVM);

--- 6 unchanged lines hidden (view full) ---

2091 p o s t p o n e
2092** Lookup the next word in the input stream and compile code to
2093** insert it into definitions created by the resulting word
2094** (defers compilation, even of immediate words)
2095**************************************************************************/
2096
2097static void postponeCoIm(FICL_VM *pVM)
2098{
2242 return;
2243}
2244
2245
2246static void bracketTickCoIm(FICL_VM *pVM)
2247{
2248 ficlTick(pVM);
2249 literalIm(pVM);

--- 6 unchanged lines hidden (view full) ---

2256 p o s t p o n e
2257** Lookup the next word in the input stream and compile code to
2258** insert it into definitions created by the resulting word
2259** (defers compilation, even of immediate words)
2260**************************************************************************/
2261
2262static void postponeCoIm(FICL_VM *pVM)
2263{
2099 FICL_DICT *dp = ficlGetDict();
2264 FICL_DICT *dp = vmGetDict(pVM);
2100 FICL_WORD *pFW;
2265 FICL_WORD *pFW;
2266 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2101 assert(pComma);
2102
2103 ficlTick(pVM);
2104 pFW = stackGetTop(pVM->pStack).p;
2105 if (wordIsImmediate(pFW))
2106 {
2107 dictAppendCell(dp, stackPop(pVM->pStack));
2108 }

--- 33 unchanged lines hidden (view full) ---

2142** Make the most recently compiled word IMMEDIATE -- it executes even
2143** in compile state (most often used for control compiling words
2144** such as IF, THEN, etc)
2145**************************************************************************/
2146
2147static void immediate(FICL_VM *pVM)
2148{
2149 IGNORE(pVM);
2267 assert(pComma);
2268
2269 ficlTick(pVM);
2270 pFW = stackGetTop(pVM->pStack).p;
2271 if (wordIsImmediate(pFW))
2272 {
2273 dictAppendCell(dp, stackPop(pVM->pStack));
2274 }

--- 33 unchanged lines hidden (view full) ---

2308** Make the most recently compiled word IMMEDIATE -- it executes even
2309** in compile state (most often used for control compiling words
2310** such as IF, THEN, etc)
2311**************************************************************************/
2312
2313static void immediate(FICL_VM *pVM)
2314{
2315 IGNORE(pVM);
2150 dictSetImmediate(ficlGetDict());
2316 dictSetImmediate(vmGetDict(pVM));
2151 return;
2152}
2153
2154
2155static void compileOnly(FICL_VM *pVM)
2156{
2157 IGNORE(pVM);
2317 return;
2318}
2319
2320
2321static void compileOnly(FICL_VM *pVM)
2322{
2323 IGNORE(pVM);
2158 dictSetFlags(ficlGetDict(), FW_COMPILE, 0);
2324 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2159 return;
2160}
2161
2162
2325 return;
2326}
2327
2328
2329static void setObjectFlag(FICL_VM *pVM)
2330{
2331 IGNORE(pVM);
2332 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2333 return;
2334}
2335
2336static void isObject(FICL_VM *pVM)
2337{
2338 int flag;
2339 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2340
2341 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2342 stackPushINT(pVM->pStack, flag);
2343 return;
2344}
2345
2346static void cstringLit(FICL_VM *pVM)
2347{
2348 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2349
2350 char *cp = sp->text;
2351 cp += sp->count + 1;
2352 cp = alignPtr(cp);
2353 pVM->ip = (IPTYPE)(void *)cp;
2354
2355 stackPushPtr(pVM->pStack, sp);
2356 return;
2357}
2358
2359
2360static void cstringQuoteIm(FICL_VM *pVM)
2361{
2362 FICL_DICT *dp = vmGetDict(pVM);
2363
2364 if (pVM->state == INTERPRET)
2365 {
2366 FICL_STRING *sp = (FICL_STRING *) dp->here;
2367 vmGetString(pVM, sp, '\"');
2368 stackPushPtr(pVM->pStack, sp);
2369 /* move HERE past string so it doesn't get overwritten. --lch */
2370 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2371 }
2372 else /* COMPILE state */
2373 {
2374 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2375 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2376 dictAlign(dp);
2377 }
2378
2379 return;
2380}
2381
2163/**************************************************************************
2164 d o t Q u o t e
2165** IMMEDIATE word that compiles a string literal for later display
2166** Compile stringLit, then copy the bytes of the string from the TIB
2167** to the dictionary. Backpatch the count byte and align the dictionary.
2168**
2169** stringlit: Fetch the count from the dictionary, then push the address
2170** and count on the stack. Finally, update ip to point to the first
2171** aligned address after the string text.
2172**************************************************************************/
2173
2174static void stringLit(FICL_VM *pVM)
2175{
2382/**************************************************************************
2383 d o t Q u o t e
2384** IMMEDIATE word that compiles a string literal for later display
2385** Compile stringLit, then copy the bytes of the string from the TIB
2386** to the dictionary. Backpatch the count byte and align the dictionary.
2387**
2388** stringlit: Fetch the count from the dictionary, then push the address
2389** and count on the stack. Finally, update ip to point to the first
2390** aligned address after the string text.
2391**************************************************************************/
2392
2393static void stringLit(FICL_VM *pVM)
2394{
2176 FICL_STRING *sp;
2177 FICL_COUNT count;
2178 char *cp;
2395 FICL_STRING *sp;
2396 FICL_COUNT count;
2397 char *cp;
2179#if FICL_ROBUST > 1
2398#if FICL_ROBUST > 1
2180 vmCheckStack(pVM, 0, 2);
2399 vmCheckStack(pVM, 0, 2);
2181#endif
2182
2400#endif
2401
2183 sp = (FICL_STRING *)(pVM->ip);
2184 count = sp->count;
2185 cp = sp->text;
2186 PUSHPTR(cp);
2187 PUSHUNS(count);
2188 cp += count + 1;
2189 cp = alignPtr(cp);
2190 pVM->ip = (IPTYPE)(void *)cp;
2402 sp = (FICL_STRING *)(pVM->ip);
2403 count = sp->count;
2404 cp = sp->text;
2405 PUSHPTR(cp);
2406 PUSHUNS(count);
2407 cp += count + 1;
2408 cp = alignPtr(cp);
2409 pVM->ip = (IPTYPE)(void *)cp;
2191}
2192
2193static void dotQuoteCoIm(FICL_VM *pVM)
2194{
2410}
2411
2412static void dotQuoteCoIm(FICL_VM *pVM)
2413{
2195 FICL_DICT *dp = ficlGetDict();
2196 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2414 FICL_DICT *dp = vmGetDict(pVM);
2415 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2416 assert(pType);
2417 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2197 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2198 dictAlign(dp);
2199 dictAppendCell(dp, LVALUEtoCELL(pType));
2200 return;
2201}
2202
2203
2204static void dotParen(FICL_VM *pVM)

--- 28 unchanged lines hidden (view full) ---

2233** Append the run-time semantics given below to the current definition.
2234** Run-time: ( -- c-addr2 u )
2235** Return c-addr2 u describing a string consisting of the characters
2236** specified by c-addr1 u during compilation. A program shall not alter
2237** the returned string.
2238**************************************************************************/
2239static void sLiteralCoIm(FICL_VM *pVM)
2240{
2418 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2419 dictAlign(dp);
2420 dictAppendCell(dp, LVALUEtoCELL(pType));
2421 return;
2422}
2423
2424
2425static void dotParen(FICL_VM *pVM)

--- 28 unchanged lines hidden (view full) ---

2454** Append the run-time semantics given below to the current definition.
2455** Run-time: ( -- c-addr2 u )
2456** Return c-addr2 u describing a string consisting of the characters
2457** specified by c-addr1 u during compilation. A program shall not alter
2458** the returned string.
2459**************************************************************************/
2460static void sLiteralCoIm(FICL_VM *pVM)
2461{
2241 FICL_DICT *dp;
2242 char *cp, *cpDest;
2243 FICL_UNS u;
2462 FICL_DICT *dp;
2463 char *cp, *cpDest;
2464 FICL_UNS u;
2244
2245#if FICL_ROBUST > 1
2465
2466#if FICL_ROBUST > 1
2246 vmCheckStack(pVM, 2, 0);
2467 vmCheckStack(pVM, 2, 0);
2247#endif
2248
2468#endif
2469
2249 dp = ficlGetDict();
2250 u = POPUNS();
2251 cp = POPPTR();
2470 dp = vmGetDict(pVM);
2471 u = POPUNS();
2472 cp = POPPTR();
2252
2473
2253 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2474 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2254 cpDest = (char *) dp->here;
2255 *cpDest++ = (char) u;
2256
2257 for (; u > 0; --u)
2258 {
2259 *cpDest++ = *cp++;
2260 }
2261

--- 6 unchanged lines hidden (view full) ---

2268/**************************************************************************
2269 s t a t e
2270** Return the address of the VM's state member (must be sized the
2271** same as a CELL for this reason)
2272**************************************************************************/
2273static void state(FICL_VM *pVM)
2274{
2275#if FICL_ROBUST > 1
2475 cpDest = (char *) dp->here;
2476 *cpDest++ = (char) u;
2477
2478 for (; u > 0; --u)
2479 {
2480 *cpDest++ = *cp++;
2481 }
2482

--- 6 unchanged lines hidden (view full) ---

2489/**************************************************************************
2490 s t a t e
2491** Return the address of the VM's state member (must be sized the
2492** same as a CELL for this reason)
2493**************************************************************************/
2494static void state(FICL_VM *pVM)
2495{
2496#if FICL_ROBUST > 1
2276 vmCheckStack(pVM, 0, 1);
2497 vmCheckStack(pVM, 0, 1);
2277#endif
2278 PUSHPTR(&pVM->state);
2279 return;
2280}
2281
2282
2283/**************************************************************************
2284 c r e a t e . . . d o e s >
2285** Make a new word in the dictionary with the run-time effect of
2286** a variable (push my address), but with extra space allotted
2287** for use by does> .
2288**************************************************************************/
2289
2290static void createParen(FICL_VM *pVM)
2291{
2498#endif
2499 PUSHPTR(&pVM->state);
2500 return;
2501}
2502
2503
2504/**************************************************************************
2505 c r e a t e . . . d o e s >
2506** Make a new word in the dictionary with the run-time effect of
2507** a variable (push my address), but with extra space allotted
2508** for use by does> .
2509**************************************************************************/
2510
2511static void createParen(FICL_VM *pVM)
2512{
2292 CELL *pCell;
2513 CELL *pCell;
2293
2294#if FICL_ROBUST > 1
2514
2515#if FICL_ROBUST > 1
2295 vmCheckStack(pVM, 0, 1);
2516 vmCheckStack(pVM, 0, 1);
2296#endif
2297
2517#endif
2518
2298 pCell = pVM->runningWord->param;
2299 PUSHPTR(pCell+1);
2519 pCell = pVM->runningWord->param;
2520 PUSHPTR(pCell+1);
2300 return;
2301}
2302
2303
2304static void create(FICL_VM *pVM)
2305{
2521 return;
2522}
2523
2524
2525static void create(FICL_VM *pVM)
2526{
2306 FICL_DICT *dp = ficlGetDict();
2527 FICL_DICT *dp = vmGetDict(pVM);
2307 STRINGINFO si = vmGetWord(pVM);
2308
2309 dictCheckThreshold(dp);
2310
2311 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2312 dictAllotCells(dp, 1);
2313 return;
2314}
2315
2316
2317static void doDoes(FICL_VM *pVM)
2318{
2528 STRINGINFO si = vmGetWord(pVM);
2529
2530 dictCheckThreshold(dp);
2531
2532 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2533 dictAllotCells(dp, 1);
2534 return;
2535}
2536
2537
2538static void doDoes(FICL_VM *pVM)
2539{
2319 CELL *pCell;
2320 IPTYPE tempIP;
2540 CELL *pCell;
2541 IPTYPE tempIP;
2321#if FICL_ROBUST > 1
2542#if FICL_ROBUST > 1
2322 vmCheckStack(pVM, 0, 1);
2543 vmCheckStack(pVM, 0, 1);
2323#endif
2324
2544#endif
2545
2325 pCell = pVM->runningWord->param;
2326 tempIP = (IPTYPE)((*pCell).p);
2327 PUSHPTR(pCell+1);
2328 vmPushIP(pVM, tempIP);
2546 pCell = pVM->runningWord->param;
2547 tempIP = (IPTYPE)((*pCell).p);
2548 PUSHPTR(pCell+1);
2549 vmPushIP(pVM, tempIP);
2329 return;
2330}
2331
2332
2333static void doesParen(FICL_VM *pVM)
2334{
2550 return;
2551}
2552
2553
2554static void doesParen(FICL_VM *pVM)
2555{
2335 FICL_DICT *dp = ficlGetDict();
2556 FICL_DICT *dp = vmGetDict(pVM);
2336 dp->smudge->code = doDoes;
2337 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2338 vmPopIP(pVM);
2339 return;
2340}
2341
2342
2343static void doesCoIm(FICL_VM *pVM)
2344{
2557 dp->smudge->code = doDoes;
2558 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2559 vmPopIP(pVM);
2560 return;
2561}
2562
2563
2564static void doesCoIm(FICL_VM *pVM)
2565{
2345 FICL_DICT *dp = ficlGetDict();
2566 FICL_DICT *dp = vmGetDict(pVM);
2346#if FICL_WANT_LOCALS
2567#if FICL_WANT_LOCALS
2347 assert(pUnLinkParen);
2348 if (nLocals > 0)
2568 assert(pVM->pSys->pUnLinkParen);
2569 if (pVM->pSys->nLocals > 0)
2349 {
2570 {
2350 FICL_DICT *pLoc = ficlGetLoc();
2571 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2351 dictEmpty(pLoc, pLoc->pForthWords->size);
2572 dictEmpty(pLoc, pLoc->pForthWords->size);
2352 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
2573 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2353 }
2354
2574 }
2575
2355 nLocals = 0;
2576 pVM->pSys->nLocals = 0;
2356#endif
2357 IGNORE(pVM);
2358
2577#endif
2578 IGNORE(pVM);
2579
2359 dictAppendCell(dp, LVALUEtoCELL(pDoesParen));
2580 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2360 return;
2361}
2362
2363
2364/**************************************************************************
2365 t o b o d y
2366** to-body CORE ( xt -- a-addr )
2367** a-addr is the data-field address corresponding to xt. An ambiguous
2368** condition exists if xt is not for a word defined via CREATE.
2369**************************************************************************/
2370static void toBody(FICL_VM *pVM)
2371{
2581 return;
2582}
2583
2584
2585/**************************************************************************
2586 t o b o d y
2587** to-body CORE ( xt -- a-addr )
2588** a-addr is the data-field address corresponding to xt. An ambiguous
2589** condition exists if xt is not for a word defined via CREATE.
2590**************************************************************************/
2591static void toBody(FICL_VM *pVM)
2592{
2372 FICL_WORD *pFW;
2593 FICL_WORD *pFW;
2373/*#$-GUY CHANGE: Added robustness.-$#*/
2374#if FICL_ROBUST > 1
2594/*#$-GUY CHANGE: Added robustness.-$#*/
2595#if FICL_ROBUST > 1
2375 vmCheckStack(pVM, 1, 1);
2596 vmCheckStack(pVM, 1, 1);
2376#endif
2377
2597#endif
2598
2378 pFW = POPPTR();
2379 PUSHPTR(pFW->param + 1);
2599 pFW = POPPTR();
2600 PUSHPTR(pFW->param + 1);
2380 return;
2381}
2382
2383
2384/*
2385** from-body ficl ( a-addr -- xt )
2386** Reverse effect of >body
2387*/
2388static void fromBody(FICL_VM *pVM)
2389{
2601 return;
2602}
2603
2604
2605/*
2606** from-body ficl ( a-addr -- xt )
2607** Reverse effect of >body
2608*/
2609static void fromBody(FICL_VM *pVM)
2610{
2390 char *ptr;
2611 char *ptr;
2391#if FICL_ROBUST > 1
2612#if FICL_ROBUST > 1
2392 vmCheckStack(pVM, 1, 1);
2613 vmCheckStack(pVM, 1, 1);
2393#endif
2394
2614#endif
2615
2395 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2396 PUSHPTR(ptr);
2616 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2617 PUSHPTR(ptr);
2397 return;
2398}
2399
2400
2401/*
2402** >name ficl ( xt -- c-addr u )
2403** Push the address and length of a word's name given its address
2404** xt.
2405*/
2406static void toName(FICL_VM *pVM)
2407{
2618 return;
2619}
2620
2621
2622/*
2623** >name ficl ( xt -- c-addr u )
2624** Push the address and length of a word's name given its address
2625** xt.
2626*/
2627static void toName(FICL_VM *pVM)
2628{
2408 FICL_WORD *pFW;
2629 FICL_WORD *pFW;
2409#if FICL_ROBUST > 1
2630#if FICL_ROBUST > 1
2410 vmCheckStack(pVM, 1, 2);
2631 vmCheckStack(pVM, 1, 2);
2411#endif
2412
2632#endif
2633
2413 pFW = POPPTR();
2414 PUSHPTR(pFW->name);
2415 PUSHUNS(pFW->nName);
2634 pFW = POPPTR();
2635 PUSHPTR(pFW->name);
2636 PUSHUNS(pFW->nName);
2416 return;
2417}
2418
2419
2420static void getLastWord(FICL_VM *pVM)
2421{
2637 return;
2638}
2639
2640
2641static void getLastWord(FICL_VM *pVM)
2642{
2422 FICL_DICT *pDict = ficlGetDict();
2643 FICL_DICT *pDict = vmGetDict(pVM);
2423 FICL_WORD *wp = pDict->smudge;
2424 assert(wp);
2425 vmPush(pVM, LVALUEtoCELL(wp));
2426 return;
2427}
2428
2429
2430/**************************************************************************

--- 34 unchanged lines hidden (view full) ---

2465** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2466** n. (n is the least-significant digit of ud1.) Convert n to external form
2467** and add the resulting character to the beginning of the pictured numeric
2468** output string. An ambiguous condition exists if # executes outside of a
2469** <# #> delimited number conversion.
2470*/
2471static void numberSign(FICL_VM *pVM)
2472{
2644 FICL_WORD *wp = pDict->smudge;
2645 assert(wp);
2646 vmPush(pVM, LVALUEtoCELL(wp));
2647 return;
2648}
2649
2650
2651/**************************************************************************

--- 34 unchanged lines hidden (view full) ---

2686** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2687** n. (n is the least-significant digit of ud1.) Convert n to external form
2688** and add the resulting character to the beginning of the pictured numeric
2689** output string. An ambiguous condition exists if # executes outside of a
2690** <# #> delimited number conversion.
2691*/
2692static void numberSign(FICL_VM *pVM)
2693{
2473 FICL_STRING *sp;
2474 DPUNS u;
2475 UNS16 rem;
2694 FICL_STRING *sp;
2695 DPUNS u;
2696 UNS16 rem;
2476#if FICL_ROBUST > 1
2697#if FICL_ROBUST > 1
2477 vmCheckStack(pVM, 2, 2);
2698 vmCheckStack(pVM, 2, 2);
2478#endif
2479
2699#endif
2700
2480 sp = PTRtoSTRING pVM->pad;
2481 u = u64Pop(pVM->pStack);
2482 rem = m64UMod(&u, (UNS16)(pVM->base));
2483 sp->text[sp->count++] = digit_to_char(rem);
2484 u64Push(pVM->pStack, u);
2701 sp = PTRtoSTRING pVM->pad;
2702 u = u64Pop(pVM->pStack);
2703 rem = m64UMod(&u, (UNS16)(pVM->base));
2704 sp->text[sp->count++] = digit_to_char(rem);
2705 u64Push(pVM->pStack, u);
2485 return;
2486}
2487
2488/*
2489** number-sign-greater CORE ( xd -- c-addr u )
2490** Drop xd. Make the pictured numeric output string available as a character
2491** string. c-addr and u specify the resulting character string. A program
2492** may replace characters within the string.
2493*/
2494static void numberSignGreater(FICL_VM *pVM)
2495{
2706 return;
2707}
2708
2709/*
2710** number-sign-greater CORE ( xd -- c-addr u )
2711** Drop xd. Make the pictured numeric output string available as a character
2712** string. c-addr and u specify the resulting character string. A program
2713** may replace characters within the string.
2714*/
2715static void numberSignGreater(FICL_VM *pVM)
2716{
2496 FICL_STRING *sp;
2717 FICL_STRING *sp;
2497#if FICL_ROBUST > 1
2718#if FICL_ROBUST > 1
2498 vmCheckStack(pVM, 2, 2);
2719 vmCheckStack(pVM, 2, 2);
2499#endif
2500
2720#endif
2721
2501 sp = PTRtoSTRING pVM->pad;
2502 sp->text[sp->count] = 0;
2503 strrev(sp->text);
2504 DROP(2);
2505 PUSHPTR(sp->text);
2506 PUSHUNS(sp->count);
2722 sp = PTRtoSTRING pVM->pad;
2723 sp->text[sp->count] = 0;
2724 strrev(sp->text);
2725 DROP(2);
2726 PUSHPTR(sp->text);
2727 PUSHUNS(sp->count);
2507 return;
2508}
2509
2510/*
2511** number-sign-s CORE ( ud1 -- ud2 )
2512** Convert one digit of ud1 according to the rule for #. Continue conversion
2513** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2514** #S executes outside of a <# #> delimited number conversion.
2515** TO DO: presently does not use ud1 hi cell - use it!
2516*/
2517static void numberSignS(FICL_VM *pVM)
2518{
2728 return;
2729}
2730
2731/*
2732** number-sign-s CORE ( ud1 -- ud2 )
2733** Convert one digit of ud1 according to the rule for #. Continue conversion
2734** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2735** #S executes outside of a <# #> delimited number conversion.
2736** TO DO: presently does not use ud1 hi cell - use it!
2737*/
2738static void numberSignS(FICL_VM *pVM)
2739{
2519 FICL_STRING *sp;
2520 DPUNS u;
2521 UNS16 rem;
2740 FICL_STRING *sp;
2741 DPUNS u;
2742 UNS16 rem;
2522#if FICL_ROBUST > 1
2743#if FICL_ROBUST > 1
2523 vmCheckStack(pVM, 2, 2);
2744 vmCheckStack(pVM, 2, 2);
2524#endif
2525
2745#endif
2746
2526 sp = PTRtoSTRING pVM->pad;
2527 u = u64Pop(pVM->pStack);
2747 sp = PTRtoSTRING pVM->pad;
2748 u = u64Pop(pVM->pStack);
2528
2749
2529 do
2530 {
2531 rem = m64UMod(&u, (UNS16)(pVM->base));
2532 sp->text[sp->count++] = digit_to_char(rem);
2533 }
2534 while (u.hi || u.lo);
2750 do
2751 {
2752 rem = m64UMod(&u, (UNS16)(pVM->base));
2753 sp->text[sp->count++] = digit_to_char(rem);
2754 }
2755 while (u.hi || u.lo);
2535
2756
2536 u64Push(pVM->pStack, u);
2757 u64Push(pVM->pStack, u);
2537 return;
2538}
2539
2540/*
2541** HOLD CORE ( char -- )
2542** Add char to the beginning of the pictured numeric output string. An ambiguous
2543** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2544*/
2545static void hold(FICL_VM *pVM)
2546{
2758 return;
2759}
2760
2761/*
2762** HOLD CORE ( char -- )
2763** Add char to the beginning of the pictured numeric output string. An ambiguous
2764** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2765*/
2766static void hold(FICL_VM *pVM)
2767{
2547 FICL_STRING *sp;
2548 int i;
2768 FICL_STRING *sp;
2769 int i;
2549#if FICL_ROBUST > 1
2770#if FICL_ROBUST > 1
2550 vmCheckStack(pVM, 1, 0);
2771 vmCheckStack(pVM, 1, 0);
2551#endif
2552
2772#endif
2773
2553 sp = PTRtoSTRING pVM->pad;
2554 i = POPINT();
2555 sp->text[sp->count++] = (char) i;
2774 sp = PTRtoSTRING pVM->pad;
2775 i = POPINT();
2776 sp->text[sp->count++] = (char) i;
2556 return;
2557}
2558
2559/*
2560** SIGN CORE ( n -- )
2561** If n is negative, add a minus sign to the beginning of the pictured
2562** numeric output string. An ambiguous condition exists if SIGN
2563** executes outside of a <# #> delimited number conversion.
2564*/
2565static void sign(FICL_VM *pVM)
2566{
2777 return;
2778}
2779
2780/*
2781** SIGN CORE ( n -- )
2782** If n is negative, add a minus sign to the beginning of the pictured
2783** numeric output string. An ambiguous condition exists if SIGN
2784** executes outside of a <# #> delimited number conversion.
2785*/
2786static void sign(FICL_VM *pVM)
2787{
2567 FICL_STRING *sp;
2568 int i;
2788 FICL_STRING *sp;
2789 int i;
2569#if FICL_ROBUST > 1
2790#if FICL_ROBUST > 1
2570 vmCheckStack(pVM, 1, 0);
2791 vmCheckStack(pVM, 1, 0);
2571#endif
2572
2792#endif
2793
2573 sp = PTRtoSTRING pVM->pad;
2574 i = POPINT();
2575 if (i < 0)
2576 sp->text[sp->count++] = '-';
2794 sp = PTRtoSTRING pVM->pad;
2795 i = POPINT();
2796 if (i < 0)
2797 sp->text[sp->count++] = '-';
2577 return;
2578}
2579
2580
2581/**************************************************************************
2582 t o N u m b e r
2583** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2584** ud2 is the unsigned result of converting the characters within the

--- 4 unchanged lines hidden (view full) ---

2589** entirely converted. c-addr2 is the location of the first unconverted
2590** character or the first character past the end of the string if the string
2591** was entirely converted. u2 is the number of unconverted characters in the
2592** string. An ambiguous condition exists if ud2 overflows during the
2593** conversion.
2594**************************************************************************/
2595static void toNumber(FICL_VM *pVM)
2596{
2798 return;
2799}
2800
2801
2802/**************************************************************************
2803 t o N u m b e r
2804** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2805** ud2 is the unsigned result of converting the characters within the

--- 4 unchanged lines hidden (view full) ---

2810** entirely converted. c-addr2 is the location of the first unconverted
2811** character or the first character past the end of the string if the string
2812** was entirely converted. u2 is the number of unconverted characters in the
2813** string. An ambiguous condition exists if ud2 overflows during the
2814** conversion.
2815**************************************************************************/
2816static void toNumber(FICL_VM *pVM)
2817{
2597 FICL_UNS count;
2598 char *cp;
2599 DPUNS accum;
2600 FICL_UNS base = pVM->base;
2601 FICL_UNS ch;
2602 FICL_UNS digit;
2818 FICL_UNS count;
2819 char *cp;
2820 DPUNS accum;
2821 FICL_UNS base = pVM->base;
2822 FICL_UNS ch;
2823 FICL_UNS digit;
2603
2604#if FICL_ROBUST > 1
2824
2825#if FICL_ROBUST > 1
2605 vmCheckStack(pVM,4,4);
2826 vmCheckStack(pVM,4,4);
2606#endif
2607
2827#endif
2828
2608 count = POPUNS();
2609 cp = (char *)POPPTR();
2829 count = POPUNS();
2830 cp = (char *)POPPTR();
2610 accum = u64Pop(pVM->pStack);
2611
2612 for (ch = *cp; count > 0; ch = *++cp, count--)
2613 {
2614 if (ch < '0')
2615 break;
2616
2617 digit = ch - '0';

--- 64 unchanged lines hidden (view full) ---

2682** throw out for more text. Copy characters up to the max count into the
2683** address given, and return the number of actual characters copied.
2684**
2685** Note (sobral) this may not be the behavior you'd expect if you're
2686** trying to get user input at load time!
2687**************************************************************************/
2688static void accept(FICL_VM *pVM)
2689{
2831 accum = u64Pop(pVM->pStack);
2832
2833 for (ch = *cp; count > 0; ch = *++cp, count--)
2834 {
2835 if (ch < '0')
2836 break;
2837
2838 digit = ch - '0';

--- 64 unchanged lines hidden (view full) ---

2903** throw out for more text. Copy characters up to the max count into the
2904** address given, and return the number of actual characters copied.
2905**
2906** Note (sobral) this may not be the behavior you'd expect if you're
2907** trying to get user input at load time!
2908**************************************************************************/
2909static void accept(FICL_VM *pVM)
2910{
2690 FICL_UNS count, len;
2691 char *cp;
2692 char *pBuf, *pEnd;
2911 FICL_UNS count, len;
2912 char *cp;
2913 char *pBuf, *pEnd;
2693
2694#if FICL_ROBUST > 1
2914
2915#if FICL_ROBUST > 1
2695 vmCheckStack(pVM,2,1);
2916 vmCheckStack(pVM,2,1);
2696#endif
2697
2917#endif
2918
2698 pBuf = vmGetInBuf(pVM);
2919 pBuf = vmGetInBuf(pVM);
2699 pEnd = vmGetInBufEnd(pVM);
2920 pEnd = vmGetInBufEnd(pVM);
2700 len = pEnd - pBuf;
2921 len = pEnd - pBuf;
2701 if (len == 0)
2702 vmThrow(pVM, VM_RESTART);
2703
2704 /*
2705 ** Now we have something in the text buffer - use it
2706 */
2707 count = stackPopINT(pVM->pStack);
2708 cp = stackPopPtr(pVM->pStack);

--- 11 unchanged lines hidden (view full) ---

2720/**************************************************************************
2721 a l i g n
2722** 6.1.0705 ALIGN CORE ( -- )
2723** If the data-space pointer is not aligned, reserve enough space to
2724** align it.
2725**************************************************************************/
2726static void align(FICL_VM *pVM)
2727{
2922 if (len == 0)
2923 vmThrow(pVM, VM_RESTART);
2924
2925 /*
2926 ** Now we have something in the text buffer - use it
2927 */
2928 count = stackPopINT(pVM->pStack);
2929 cp = stackPopPtr(pVM->pStack);

--- 11 unchanged lines hidden (view full) ---

2941/**************************************************************************
2942 a l i g n
2943** 6.1.0705 ALIGN CORE ( -- )
2944** If the data-space pointer is not aligned, reserve enough space to
2945** align it.
2946**************************************************************************/
2947static void align(FICL_VM *pVM)
2948{
2728 FICL_DICT *dp = ficlGetDict();
2949 FICL_DICT *dp = vmGetDict(pVM);
2729 IGNORE(pVM);
2730 dictAlign(dp);
2731 return;
2732}
2733
2734
2735/**************************************************************************
2736 a l i g n e d
2737**
2738**************************************************************************/
2739static void aligned(FICL_VM *pVM)
2740{
2950 IGNORE(pVM);
2951 dictAlign(dp);
2952 return;
2953}
2954
2955
2956/**************************************************************************
2957 a l i g n e d
2958**
2959**************************************************************************/
2960static void aligned(FICL_VM *pVM)
2961{
2741 void *addr;
2962 void *addr;
2742#if FICL_ROBUST > 1
2963#if FICL_ROBUST > 1
2743 vmCheckStack(pVM,1,1);
2964 vmCheckStack(pVM,1,1);
2744#endif
2745
2965#endif
2966
2746 addr = POPPTR();
2747 PUSHPTR(alignPtr(addr));
2967 addr = POPPTR();
2968 PUSHPTR(alignPtr(addr));
2748 return;
2749}
2750
2751
2752/**************************************************************************
2753 b e g i n & f r i e n d s
2754** Indefinite loop control structures
2755** A.6.1.0760 BEGIN
2756** Typical use:
2757** : X ... BEGIN ... test UNTIL ;
2758** or
2759** : X ... BEGIN ... test WHILE ... REPEAT ;
2760**************************************************************************/
2761static void beginCoIm(FICL_VM *pVM)
2762{
2969 return;
2970}
2971
2972
2973/**************************************************************************
2974 b e g i n & f r i e n d s
2975** Indefinite loop control structures
2976** A.6.1.0760 BEGIN
2977** Typical use:
2978** : X ... BEGIN ... test UNTIL ;
2979** or
2980** : X ... BEGIN ... test WHILE ... REPEAT ;
2981**************************************************************************/
2982static void beginCoIm(FICL_VM *pVM)
2983{
2763 FICL_DICT *dp = ficlGetDict();
2984 FICL_DICT *dp = vmGetDict(pVM);
2764 markBranch(dp, pVM, destTag);
2765 return;
2766}
2767
2768static void untilCoIm(FICL_VM *pVM)
2769{
2985 markBranch(dp, pVM, destTag);
2986 return;
2987}
2988
2989static void untilCoIm(FICL_VM *pVM)
2990{
2770 FICL_DICT *dp = ficlGetDict();
2991 FICL_DICT *dp = vmGetDict(pVM);
2771
2992
2772 assert(pIfParen);
2993 assert(pVM->pSys->pIfParen);
2773
2994
2774 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2995 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
2775 resolveBackBranch(dp, pVM, destTag);
2776 return;
2777}
2778
2779static void whileCoIm(FICL_VM *pVM)
2780{
2996 resolveBackBranch(dp, pVM, destTag);
2997 return;
2998}
2999
3000static void whileCoIm(FICL_VM *pVM)
3001{
2781 FICL_DICT *dp = ficlGetDict();
3002 FICL_DICT *dp = vmGetDict(pVM);
2782
3003
2783 assert(pIfParen);
3004 assert(pVM->pSys->pIfParen);
2784
3005
2785 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
3006 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
2786 markBranch(dp, pVM, origTag);
2787 twoSwap(pVM);
2788 dictAppendUNS(dp, 1);
2789 return;
2790}
2791
2792static void repeatCoIm(FICL_VM *pVM)
2793{
3007 markBranch(dp, pVM, origTag);
3008 twoSwap(pVM);
3009 dictAppendUNS(dp, 1);
3010 return;
3011}
3012
3013static void repeatCoIm(FICL_VM *pVM)
3014{
2794 FICL_DICT *dp = ficlGetDict();
3015 FICL_DICT *dp = vmGetDict(pVM);
2795
3016
2796 assert(pBranchParen);
2797 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
3017 assert(pVM->pSys->pBranchParen);
3018 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
2798
2799 /* expect "begin" branch marker */
2800 resolveBackBranch(dp, pVM, destTag);
2801 /* expect "while" branch marker */
2802 resolveForwardBranch(dp, pVM, origTag);
2803 return;
2804}
2805
2806
2807static void againCoIm(FICL_VM *pVM)
2808{
3019
3020 /* expect "begin" branch marker */
3021 resolveBackBranch(dp, pVM, destTag);
3022 /* expect "while" branch marker */
3023 resolveForwardBranch(dp, pVM, origTag);
3024 return;
3025}
3026
3027
3028static void againCoIm(FICL_VM *pVM)
3029{
2809 FICL_DICT *dp = ficlGetDict();
3030 FICL_DICT *dp = vmGetDict(pVM);
2810
3031
2811 assert(pBranchParen);
2812 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
3032 assert(pVM->pSys->pBranchParen);
3033 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
2813
2814 /* expect "begin" branch marker */
2815 resolveBackBranch(dp, pVM, destTag);
2816 return;
2817}
2818
2819
2820/**************************************************************************

--- 7 unchanged lines hidden (view full) ---

2828** Compilation: ( "<spaces>name" -- )
2829** Skip leading space delimiters. Parse name delimited by a space.
2830** Append the run-time semantics given below to the current definition.
2831** Run-time: ( -- char )
2832** Place char, the value of the first character of name, on the stack.
2833**************************************************************************/
2834static void ficlChar(FICL_VM *pVM)
2835{
3034
3035 /* expect "begin" branch marker */
3036 resolveBackBranch(dp, pVM, destTag);
3037 return;
3038}
3039
3040
3041/**************************************************************************

--- 7 unchanged lines hidden (view full) ---

3049** Compilation: ( "<spaces>name" -- )
3050** Skip leading space delimiters. Parse name delimited by a space.
3051** Append the run-time semantics given below to the current definition.
3052** Run-time: ( -- char )
3053** Place char, the value of the first character of name, on the stack.
3054**************************************************************************/
3055static void ficlChar(FICL_VM *pVM)
3056{
2836 STRINGINFO si;
3057 STRINGINFO si;
2837#if FICL_ROBUST > 1
3058#if FICL_ROBUST > 1
2838 vmCheckStack(pVM,0,1);
3059 vmCheckStack(pVM,0,1);
2839#endif
2840
3060#endif
3061
2841 si = vmGetWord(pVM);
2842 PUSHUNS((FICL_UNS)(si.cp[0]));
3062 si = vmGetWord(pVM);
3063 PUSHUNS((FICL_UNS)(si.cp[0]));
2843 return;
2844}
2845
2846static void charCoIm(FICL_VM *pVM)
2847{
2848 ficlChar(pVM);
2849 literalIm(pVM);
2850 return;
2851}
2852
2853/**************************************************************************
2854 c h a r P l u s
2855** char-plus CORE ( c-addr1 -- c-addr2 )
2856** Add the size in address units of a character to c-addr1, giving c-addr2.
2857**************************************************************************/
2858static void charPlus(FICL_VM *pVM)
2859{
3064 return;
3065}
3066
3067static void charCoIm(FICL_VM *pVM)
3068{
3069 ficlChar(pVM);
3070 literalIm(pVM);
3071 return;
3072}
3073
3074/**************************************************************************
3075 c h a r P l u s
3076** char-plus CORE ( c-addr1 -- c-addr2 )
3077** Add the size in address units of a character to c-addr1, giving c-addr2.
3078**************************************************************************/
3079static void charPlus(FICL_VM *pVM)
3080{
2860 char *cp;
3081 char *cp;
2861#if FICL_ROBUST > 1
3082#if FICL_ROBUST > 1
2862 vmCheckStack(pVM,1,1);
3083 vmCheckStack(pVM,1,1);
2863#endif
2864
3084#endif
3085
2865 cp = POPPTR();
2866 PUSHPTR(cp + 1);
3086 cp = POPPTR();
3087 PUSHPTR(cp + 1);
2867 return;
2868}
2869
2870/**************************************************************************
2871 c h a r s
2872** chars CORE ( n1 -- n2 )
2873** n2 is the size in address units of n1 characters.
2874** For most processors, this function can be a no-op. To guarantee
2875** portability, we'll multiply by sizeof (char).
2876**************************************************************************/
2877#if defined (_M_IX86)
2878#pragma warning(disable: 4127)
2879#endif
2880static void ficlChars(FICL_VM *pVM)
2881{
3088 return;
3089}
3090
3091/**************************************************************************
3092 c h a r s
3093** chars CORE ( n1 -- n2 )
3094** n2 is the size in address units of n1 characters.
3095** For most processors, this function can be a no-op. To guarantee
3096** portability, we'll multiply by sizeof (char).
3097**************************************************************************/
3098#if defined (_M_IX86)
3099#pragma warning(disable: 4127)
3100#endif
3101static void ficlChars(FICL_VM *pVM)
3102{
2882 if (sizeof (char) > 1)
2883 {
2884 FICL_INT i;
3103 if (sizeof (char) > 1)
3104 {
3105 FICL_INT i;
2885#if FICL_ROBUST > 1
3106#if FICL_ROBUST > 1
2886 vmCheckStack(pVM,1,1);
3107 vmCheckStack(pVM,1,1);
2887#endif
3108#endif
2888 i = POPINT();
2889 PUSHINT(i * sizeof (char));
2890 }
2891 /* otherwise no-op! */
3109 i = POPINT();
3110 PUSHINT(i * sizeof (char));
3111 }
3112 /* otherwise no-op! */
2892 return;
2893}
2894#if defined (_M_IX86)
2895#pragma warning(default: 4127)
2896#endif
2897
2898
2899/**************************************************************************
2900 c o u n t
2901** COUNT CORE ( c-addr1 -- c-addr2 u )
2902** Return the character string specification for the counted string stored
2903** at c-addr1. c-addr2 is the address of the first character after c-addr1.
2904** u is the contents of the character at c-addr1, which is the length in
2905** characters of the string at c-addr2.
2906**************************************************************************/
2907static void count(FICL_VM *pVM)
2908{
3113 return;
3114}
3115#if defined (_M_IX86)
3116#pragma warning(default: 4127)
3117#endif
3118
3119
3120/**************************************************************************
3121 c o u n t
3122** COUNT CORE ( c-addr1 -- c-addr2 u )
3123** Return the character string specification for the counted string stored
3124** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3125** u is the contents of the character at c-addr1, which is the length in
3126** characters of the string at c-addr2.
3127**************************************************************************/
3128static void count(FICL_VM *pVM)
3129{
2909 FICL_STRING *sp;
3130 FICL_STRING *sp;
2910#if FICL_ROBUST > 1
3131#if FICL_ROBUST > 1
2911 vmCheckStack(pVM,1,2);
3132 vmCheckStack(pVM,1,2);
2912#endif
2913
3133#endif
3134
2914 sp = POPPTR();
2915 PUSHPTR(sp->text);
2916 PUSHUNS(sp->count);
3135 sp = POPPTR();
3136 PUSHPTR(sp->text);
3137 PUSHUNS(sp->count);
2917 return;
2918}
2919
2920/**************************************************************************
2921 e n v i r o n m e n t ?
2922** environment-query CORE ( c-addr u -- false | i*x true )
2923** c-addr is the address of a character string and u is the string's
2924** character count. u may have a value in the range from zero to an
2925** implementation-defined maximum which shall not be less than 31. The
2926** character string should contain a keyword from 3.2.6 Environmental
2927** queries or the optional word sets to be checked for correspondence
2928** with an attribute of the present environment. If the system treats the
2929** attribute as unknown, the returned flag is false; otherwise, the flag
2930** is true and the i*x returned is of the type specified in the table for
2931** the attribute queried.
2932**************************************************************************/
2933static void environmentQ(FICL_VM *pVM)
2934{
3138 return;
3139}
3140
3141/**************************************************************************
3142 e n v i r o n m e n t ?
3143** environment-query CORE ( c-addr u -- false | i*x true )
3144** c-addr is the address of a character string and u is the string's
3145** character count. u may have a value in the range from zero to an
3146** implementation-defined maximum which shall not be less than 31. The
3147** character string should contain a keyword from 3.2.6 Environmental
3148** queries or the optional word sets to be checked for correspondence
3149** with an attribute of the present environment. If the system treats the
3150** attribute as unknown, the returned flag is false; otherwise, the flag
3151** is true and the i*x returned is of the type specified in the table for
3152** the attribute queried.
3153**************************************************************************/
3154static void environmentQ(FICL_VM *pVM)
3155{
2935 FICL_DICT *envp;
2936 FICL_COUNT len;
2937 char *cp;
2938 FICL_WORD *pFW;
2939 STRINGINFO si;
3156 FICL_DICT *envp;
3157 FICL_WORD *pFW;
3158 STRINGINFO si;
2940#if FICL_ROBUST > 1
3159#if FICL_ROBUST > 1
2941 vmCheckStack(pVM,2,1);
3160 vmCheckStack(pVM,2,1);
2942#endif
2943
3161#endif
3162
2944 envp = ficlGetEnv();
2945 len = (FICL_COUNT)POPUNS();
2946 cp = POPPTR();
3163 envp = pVM->pSys->envp;
3164 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3165 si.cp = stackPopPtr(pVM->pStack);
2947
3166
2948 IGNORE(len);
2949 SI_PSZ(si, cp);
2950 pFW = dictLookup(envp, si);
3167 pFW = dictLookup(envp, si);
2951
3168
2952 if (pFW != NULL)
2953 {
2954 vmExecute(pVM, pFW);
2955 PUSHINT(FICL_TRUE);
2956 }
2957 else
2958 {
2959 PUSHINT(FICL_FALSE);
2960 }
3169 if (pFW != NULL)
3170 {
3171 vmExecute(pVM, pFW);
3172 PUSHINT(FICL_TRUE);
3173 }
3174 else
3175 {
3176 PUSHINT(FICL_FALSE);
3177 }
2961 return;
2962}
2963
2964/**************************************************************************
2965 e v a l u a t e
2966** EVALUATE CORE ( i*x c-addr u -- j*x )
2967** Save the current input source specification. Store minus-one (-1) in
2968** SOURCE-ID if it is present. Make the string described by c-addr and u
2969** both the input source and input buffer, set >IN to zero, and interpret.
2970** When the parse area is empty, restore the prior input source
2971** specification. Other stack effects are due to the words EVALUATEd.
2972**
2973**************************************************************************/
2974static void evaluate(FICL_VM *pVM)
2975{
3178 return;
3179}
3180
3181/**************************************************************************
3182 e v a l u a t e
3183** EVALUATE CORE ( i*x c-addr u -- j*x )
3184** Save the current input source specification. Store minus-one (-1) in
3185** SOURCE-ID if it is present. Make the string described by c-addr and u
3186** both the input source and input buffer, set >IN to zero, and interpret.
3187** When the parse area is empty, restore the prior input source
3188** specification. Other stack effects are due to the words EVALUATEd.
3189**
3190**************************************************************************/
3191static void evaluate(FICL_VM *pVM)
3192{
2976 FICL_UNS count;
2977 char *cp;
2978 CELL id;
3193 FICL_UNS count;
3194 char *cp;
3195 CELL id;
2979 int result;
2980#if FICL_ROBUST > 1
3196 int result;
3197#if FICL_ROBUST > 1
2981 vmCheckStack(pVM,2,0);
3198 vmCheckStack(pVM,2,0);
2982#endif
2983
3199#endif
3200
2984 count = POPUNS();
2985 cp = POPPTR();
3201 count = POPUNS();
3202 cp = POPPTR();
2986
3203
2987 IGNORE(count);
2988 id = pVM->sourceID;
2989 pVM->sourceID.i = -1;
2990 result = ficlExecC(pVM, cp, count);
2991 pVM->sourceID = id;
2992 if (result != VM_OUTOFTEXT)
2993 vmThrow(pVM, result);
3204 IGNORE(count);
3205 id = pVM->sourceID;
3206 pVM->sourceID.i = -1;
3207 result = ficlExecC(pVM, cp, count);
3208 pVM->sourceID = id;
3209 if (result != VM_OUTOFTEXT)
3210 vmThrow(pVM, result);
2994
2995 return;
2996}
2997
2998
2999/**************************************************************************
3000 s t r i n g q u o t e
3001** Interpreting: get string delimited by a quote from the input stream,
3002** copy to a scratch area, and put its count and address on the stack.
3003** Compiling: compile code to push the address and count of a string
3004** literal, compile the string from the input stream, and align the dict
3005** pointer.
3006**************************************************************************/
3007static void stringQuoteIm(FICL_VM *pVM)
3008{
3211
3212 return;
3213}
3214
3215
3216/**************************************************************************
3217 s t r i n g q u o t e
3218** Interpreting: get string delimited by a quote from the input stream,
3219** copy to a scratch area, and put its count and address on the stack.
3220** Compiling: compile code to push the address and count of a string
3221** literal, compile the string from the input stream, and align the dict
3222** pointer.
3223**************************************************************************/
3224static void stringQuoteIm(FICL_VM *pVM)
3225{
3009 FICL_DICT *dp = ficlGetDict();
3226 FICL_DICT *dp = vmGetDict(pVM);
3010
3011 if (pVM->state == INTERPRET)
3012 {
3013 FICL_STRING *sp = (FICL_STRING *) dp->here;
3014 vmGetString(pVM, sp, '\"');
3015 PUSHPTR(sp->text);
3016 PUSHUNS(sp->count);
3017 }
3018 else /* COMPILE state */
3019 {
3227
3228 if (pVM->state == INTERPRET)
3229 {
3230 FICL_STRING *sp = (FICL_STRING *) dp->here;
3231 vmGetString(pVM, sp, '\"');
3232 PUSHPTR(sp->text);
3233 PUSHUNS(sp->count);
3234 }
3235 else /* COMPILE state */
3236 {
3020 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
3237 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3021 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3022 dictAlign(dp);
3023 }
3024
3025 return;
3026}
3027
3028

--- 9 unchanged lines hidden (view full) ---

3038
3039 /*
3040 ** Since we don't have an output primitive for a counted string
3041 ** (oops), make sure the string is null terminated. If not, copy
3042 ** and terminate it.
3043 */
3044 if (!pDest)
3045 vmThrowErr(pVM, "Error: out of memory");
3238 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3239 dictAlign(dp);
3240 }
3241
3242 return;
3243}
3244
3245

--- 9 unchanged lines hidden (view full) ---

3255
3256 /*
3257 ** Since we don't have an output primitive for a counted string
3258 ** (oops), make sure the string is null terminated. If not, copy
3259 ** and terminate it.
3260 */
3261 if (!pDest)
3262 vmThrowErr(pVM, "Error: out of memory");
3046
3263
3047 strncpy(pDest, cp, count);
3048 pDest[count] = '\0';
3264 strncpy(pDest, cp, count);
3265 pDest[count] = '\0';
3049
3266
3050 vmTextOut(pVM, pDest, 0);
3267 vmTextOut(pVM, pDest, 0);
3051
3268
3052 ficlFree(pDest);
3053 return;
3054}
3055
3056/**************************************************************************
3057 w o r d
3058** word CORE ( char "<chars>ccc<char>" -- c-addr )
3059** Skip leading delimiters. Parse characters ccc delimited by char. An

--- 4 unchanged lines hidden (view full) ---

3064** as a counted string. If the parse area was empty or contained no
3065** characters other than the delimiter, the resulting string has a zero
3066** length. A space, not included in the length, follows the string. A
3067** program may replace characters within the string.
3068** NOTE! Ficl also NULL-terminates the dest string.
3069**************************************************************************/
3070static void ficlWord(FICL_VM *pVM)
3071{
3269 ficlFree(pDest);
3270 return;
3271}
3272
3273/**************************************************************************
3274 w o r d
3275** word CORE ( char "<chars>ccc<char>" -- c-addr )
3276** Skip leading delimiters. Parse characters ccc delimited by char. An

--- 4 unchanged lines hidden (view full) ---

3281** as a counted string. If the parse area was empty or contained no
3282** characters other than the delimiter, the resulting string has a zero
3283** length. A space, not included in the length, follows the string. A
3284** program may replace characters within the string.
3285** NOTE! Ficl also NULL-terminates the dest string.
3286**************************************************************************/
3287static void ficlWord(FICL_VM *pVM)
3288{
3072 FICL_STRING *sp;
3073 char delim;
3074 STRINGINFO si;
3289 FICL_STRING *sp;
3290 char delim;
3291 STRINGINFO si;
3075#if FICL_ROBUST > 1
3292#if FICL_ROBUST > 1
3076 vmCheckStack(pVM,1,1);
3293 vmCheckStack(pVM,1,1);
3077#endif
3078
3294#endif
3295
3079 sp = (FICL_STRING *)pVM->pad;
3080 delim = (char)POPINT();
3296 sp = (FICL_STRING *)pVM->pad;
3297 delim = (char)POPINT();
3081 si = vmParseStringEx(pVM, delim, 1);
3082
3298 si = vmParseStringEx(pVM, delim, 1);
3299
3083 if (SI_COUNT(si) > nPAD-1)
3084 SI_SETLEN(si, nPAD-1);
3300 if (SI_COUNT(si) > nPAD-1)
3301 SI_SETLEN(si, nPAD-1);
3085
3302
3086 sp->count = (FICL_COUNT)SI_COUNT(si);
3087 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3088 /*#$-GUY CHANGE: I added this.-$#*/
3089 sp->text[sp->count] = 0;
3090 strcat(sp->text, " ");
3303 sp->count = (FICL_COUNT)SI_COUNT(si);
3304 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3305 /*#$-GUY CHANGE: I added this.-$#*/
3306 sp->text[sp->count] = 0;
3307 strcat(sp->text, " ");
3091
3308
3092 PUSHPTR(sp);
3309 PUSHPTR(sp);
3093 return;
3094}
3095
3096
3097/**************************************************************************
3098 p a r s e - w o r d
3099** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3100** Skip leading spaces and parse name delimited by a space. c-addr is the
3101** address within the input buffer and u is the length of the selected
3102** string. If the parse area is empty, the resulting string has a zero length.
3103**************************************************************************/
3104static void parseNoCopy(FICL_VM *pVM)
3105{
3310 return;
3311}
3312
3313
3314/**************************************************************************
3315 p a r s e - w o r d
3316** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3317** Skip leading spaces and parse name delimited by a space. c-addr is the
3318** address within the input buffer and u is the length of the selected
3319** string. If the parse area is empty, the resulting string has a zero length.
3320**************************************************************************/
3321static void parseNoCopy(FICL_VM *pVM)
3322{
3106 STRINGINFO si;
3323 STRINGINFO si;
3107#if FICL_ROBUST > 1
3324#if FICL_ROBUST > 1
3108 vmCheckStack(pVM,0,2);
3325 vmCheckStack(pVM,0,2);
3109#endif
3110
3326#endif
3327
3111 si = vmGetWord0(pVM);
3112 PUSHPTR(SI_PTR(si));
3113 PUSHUNS(SI_COUNT(si));
3328 si = vmGetWord0(pVM);
3329 PUSHPTR(SI_PTR(si));
3330 PUSHUNS(SI_COUNT(si));
3114 return;
3115}
3116
3117
3118/**************************************************************************
3119 p a r s e
3120** CORE EXT ( char "ccc<char>" -- c-addr u )
3121** Parse ccc delimited by the delimiter char.
3122** c-addr is the address (within the input buffer) and u is the length of
3123** the parsed string. If the parse area was empty, the resulting string has
3124** a zero length.
3125** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3126**************************************************************************/
3127static void parse(FICL_VM *pVM)
3128{
3331 return;
3332}
3333
3334
3335/**************************************************************************
3336 p a r s e
3337** CORE EXT ( char "ccc<char>" -- c-addr u )
3338** Parse ccc delimited by the delimiter char.
3339** c-addr is the address (within the input buffer) and u is the length of
3340** the parsed string. If the parse area was empty, the resulting string has
3341** a zero length.
3342** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3343**************************************************************************/
3344static void parse(FICL_VM *pVM)
3345{
3129 STRINGINFO si;
3130 char delim;
3346 STRINGINFO si;
3347 char delim;
3131
3132#if FICL_ROBUST > 1
3348
3349#if FICL_ROBUST > 1
3133 vmCheckStack(pVM,1,2);
3350 vmCheckStack(pVM,1,2);
3134#endif
3135
3351#endif
3352
3136 delim = (char)POPINT();
3353 delim = (char)POPINT();
3137
3354
3138 si = vmParseStringEx(pVM, delim, 0);
3139 PUSHPTR(SI_PTR(si));
3140 PUSHUNS(SI_COUNT(si));
3355 si = vmParseStringEx(pVM, delim, 0);
3356 PUSHPTR(SI_PTR(si));
3357 PUSHUNS(SI_COUNT(si));
3141 return;
3142}
3143
3144
3145/**************************************************************************
3146 f i l l
3147** CORE ( c-addr u char -- )
3148** If u is greater than zero, store char in each of u consecutive
3149** characters of memory beginning at c-addr.
3150**************************************************************************/
3151static void fill(FICL_VM *pVM)
3152{
3358 return;
3359}
3360
3361
3362/**************************************************************************
3363 f i l l
3364** CORE ( c-addr u char -- )
3365** If u is greater than zero, store char in each of u consecutive
3366** characters of memory beginning at c-addr.
3367**************************************************************************/
3368static void fill(FICL_VM *pVM)
3369{
3153 char ch;
3154 FICL_UNS u;
3155 char *cp;
3370 char ch;
3371 FICL_UNS u;
3372 char *cp;
3156#if FICL_ROBUST > 1
3373#if FICL_ROBUST > 1
3157 vmCheckStack(pVM,3,0);
3374 vmCheckStack(pVM,3,0);
3158#endif
3375#endif
3159 ch = (char)POPINT();
3160 u = POPUNS();
3161 cp = (char *)POPPTR();
3376 ch = (char)POPINT();
3377 u = POPUNS();
3378 cp = (char *)POPPTR();
3162
3379
3163 while (u > 0)
3164 {
3165 *cp++ = ch;
3166 u--;
3167 }
3380 while (u > 0)
3381 {
3382 *cp++ = ch;
3383 u--;
3384 }
3168 return;
3169}
3170
3171
3172/**************************************************************************
3173 f i n d
3174** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3175** Find the definition named in the counted string at c-addr. If the
3176** definition is not found, return c-addr and zero. If the definition is
3177** found, return its execution token xt. If the definition is immediate,
3178** also return one (1), otherwise also return minus-one (-1). For a given
3179** string, the values returned by FIND while compiling may differ from
3180** those returned while not compiling.
3181**************************************************************************/
3385 return;
3386}
3387
3388
3389/**************************************************************************
3390 f i n d
3391** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3392** Find the definition named in the counted string at c-addr. If the
3393** definition is not found, return c-addr and zero. If the definition is
3394** found, return its execution token xt. If the definition is immediate,
3395** also return one (1), otherwise also return minus-one (-1). For a given
3396** string, the values returned by FIND while compiling may differ from
3397** those returned while not compiling.
3398**************************************************************************/
3182static void find(FICL_VM *pVM)
3399static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3183{
3400{
3184 FICL_STRING *sp;
3185 FICL_WORD *pFW;
3186 STRINGINFO si;
3401 FICL_WORD *pFW;
3402
3403 pFW = dictLookup(vmGetDict(pVM), si);
3404 if (pFW)
3405 {
3406 PUSHPTR(pFW);
3407 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3408 }
3409 else
3410 {
3411 PUSHPTR(returnForFailure);
3412 PUSHUNS(0);
3413 }
3414 return;
3415}
3416
3417
3418
3419/**************************************************************************
3420 f i n d
3421** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3422** Find the definition named in the counted string at c-addr. If the
3423** definition is not found, return c-addr and zero. If the definition is
3424** found, return its execution token xt. If the definition is immediate,
3425** also return one (1), otherwise also return minus-one (-1). For a given
3426** string, the values returned by FIND while compiling may differ from
3427** those returned while not compiling.
3428**************************************************************************/
3429static void cFind(FICL_VM *pVM)
3430{
3431 FICL_STRING *sp;
3432 STRINGINFO si;
3433
3187#if FICL_ROBUST > 1
3434#if FICL_ROBUST > 1
3188 vmCheckStack(pVM,1,2);
3435 vmCheckStack(pVM,1,2);
3189#endif
3436#endif
3437 sp = POPPTR();
3438 SI_PFS(si, sp);
3439 do_find(pVM, si, sp);
3440}
3190
3441
3191 sp = POPPTR();
3192 SI_PFS(si, sp);
3193 pFW = dictLookup(ficlGetDict(), si);
3194 if (pFW)
3195 {
3196 PUSHPTR(pFW);
3197 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3198 }
3199 else
3200 {
3201 PUSHPTR(sp);
3202 PUSHUNS(0);
3203 }
3204 return;
3442
3443
3444/**************************************************************************
3445 s f i n d
3446** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3447** Like FIND, but takes "c-addr u" for the string.
3448**************************************************************************/
3449static void sFind(FICL_VM *pVM)
3450{
3451 STRINGINFO si;
3452
3453#if FICL_ROBUST > 1
3454 vmCheckStack(pVM,2,2);
3455#endif
3456
3457 si.count = stackPopINT(pVM->pStack);
3458 si.cp = stackPopPtr(pVM->pStack);
3459
3460 do_find(pVM, si, NULL);
3205}
3206
3207
3208
3209/**************************************************************************
3210 f m S l a s h M o d
3211** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3212** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3213** Input and output stack arguments are signed. An ambiguous condition
3214** exists if n1 is zero or if the quotient lies outside the range of a
3215** single-cell signed integer.
3216**************************************************************************/
3217static void fmSlashMod(FICL_VM *pVM)
3218{
3461}
3462
3463
3464
3465/**************************************************************************
3466 f m S l a s h M o d
3467** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3468** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3469** Input and output stack arguments are signed. An ambiguous condition
3470** exists if n1 is zero or if the quotient lies outside the range of a
3471** single-cell signed integer.
3472**************************************************************************/
3473static void fmSlashMod(FICL_VM *pVM)
3474{
3219 DPINT d1;
3220 FICL_INT n1;
3221 INTQR qr;
3475 DPINT d1;
3476 FICL_INT n1;
3477 INTQR qr;
3222#if FICL_ROBUST > 1
3478#if FICL_ROBUST > 1
3223 vmCheckStack(pVM,3,2);
3479 vmCheckStack(pVM,3,2);
3224#endif
3225
3480#endif
3481
3226 n1 = POPINT();
3227 d1 = i64Pop(pVM->pStack);
3228 qr = m64FlooredDivI(d1, n1);
3229 PUSHINT(qr.rem);
3230 PUSHINT(qr.quot);
3482 n1 = POPINT();
3483 d1 = i64Pop(pVM->pStack);
3484 qr = m64FlooredDivI(d1, n1);
3485 PUSHINT(qr.rem);
3486 PUSHINT(qr.quot);
3231 return;
3232}
3233
3234
3235/**************************************************************************
3236 s m S l a s h R e m
3237** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3238** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3239** Input and output stack arguments are signed. An ambiguous condition
3240** exists if n1 is zero or if the quotient lies outside the range of a
3241** single-cell signed integer.
3242**************************************************************************/
3243static void smSlashRem(FICL_VM *pVM)
3244{
3487 return;
3488}
3489
3490
3491/**************************************************************************
3492 s m S l a s h R e m
3493** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3494** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3495** Input and output stack arguments are signed. An ambiguous condition
3496** exists if n1 is zero or if the quotient lies outside the range of a
3497** single-cell signed integer.
3498**************************************************************************/
3499static void smSlashRem(FICL_VM *pVM)
3500{
3245 DPINT d1;
3246 FICL_INT n1;
3247 INTQR qr;
3501 DPINT d1;
3502 FICL_INT n1;
3503 INTQR qr;
3248#if FICL_ROBUST > 1
3504#if FICL_ROBUST > 1
3249 vmCheckStack(pVM,3,2);
3505 vmCheckStack(pVM,3,2);
3250#endif
3251
3506#endif
3507
3252 n1 = POPINT();
3253 d1 = i64Pop(pVM->pStack);
3254 qr = m64SymmetricDivI(d1, n1);
3255 PUSHINT(qr.rem);
3256 PUSHINT(qr.quot);
3508 n1 = POPINT();
3509 d1 = i64Pop(pVM->pStack);
3510 qr = m64SymmetricDivI(d1, n1);
3511 PUSHINT(qr.rem);
3512 PUSHINT(qr.quot);
3257 return;
3258}
3259
3260
3261static void ficlMod(FICL_VM *pVM)
3262{
3513 return;
3514}
3515
3516
3517static void ficlMod(FICL_VM *pVM)
3518{
3263 DPINT d1;
3264 FICL_INT n1;
3265 INTQR qr;
3519 DPINT d1;
3520 FICL_INT n1;
3521 INTQR qr;
3266#if FICL_ROBUST > 1
3522#if FICL_ROBUST > 1
3267 vmCheckStack(pVM,2,1);
3523 vmCheckStack(pVM,2,1);
3268#endif
3269
3524#endif
3525
3270 n1 = POPINT();
3271 d1.lo = POPINT();
3272 i64Extend(d1);
3273 qr = m64SymmetricDivI(d1, n1);
3274 PUSHINT(qr.rem);
3526 n1 = POPINT();
3527 d1.lo = POPINT();
3528 i64Extend(d1);
3529 qr = m64SymmetricDivI(d1, n1);
3530 PUSHINT(qr.rem);
3275 return;
3276}
3277
3278
3279/**************************************************************************
3280 u m S l a s h M o d
3281** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3282** Divide ud by u1, giving the quotient u3 and the remainder u2.

--- 27 unchanged lines hidden (view full) ---

3310** r-shift CORE ( x1 u -- x2 )
3311** Perform a logical right shift of u bit-places on x1, giving x2.
3312** Put zeroes into the most significant bits vacated by the shift. An
3313** ambiguous condition exists if u is greater than or equal to the
3314** number of bits in a cell.
3315**************************************************************************/
3316static void lshift(FICL_VM *pVM)
3317{
3531 return;
3532}
3533
3534
3535/**************************************************************************
3536 u m S l a s h M o d
3537** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3538** Divide ud by u1, giving the quotient u3 and the remainder u2.

--- 27 unchanged lines hidden (view full) ---

3566** r-shift CORE ( x1 u -- x2 )
3567** Perform a logical right shift of u bit-places on x1, giving x2.
3568** Put zeroes into the most significant bits vacated by the shift. An
3569** ambiguous condition exists if u is greater than or equal to the
3570** number of bits in a cell.
3571**************************************************************************/
3572static void lshift(FICL_VM *pVM)
3573{
3318 FICL_UNS nBits;
3319 FICL_UNS x1;
3574 FICL_UNS nBits;
3575 FICL_UNS x1;
3320#if FICL_ROBUST > 1
3576#if FICL_ROBUST > 1
3321 vmCheckStack(pVM,2,1);
3577 vmCheckStack(pVM,2,1);
3322#endif
3323
3578#endif
3579
3324 nBits = POPUNS();
3325 x1 = POPUNS();
3326 PUSHUNS(x1 << nBits);
3580 nBits = POPUNS();
3581 x1 = POPUNS();
3582 PUSHUNS(x1 << nBits);
3327 return;
3328}
3329
3330
3331static void rshift(FICL_VM *pVM)
3332{
3583 return;
3584}
3585
3586
3587static void rshift(FICL_VM *pVM)
3588{
3333 FICL_UNS nBits;
3334 FICL_UNS x1;
3589 FICL_UNS nBits;
3590 FICL_UNS x1;
3335#if FICL_ROBUST > 1
3591#if FICL_ROBUST > 1
3336 vmCheckStack(pVM,2,1);
3592 vmCheckStack(pVM,2,1);
3337#endif
3338
3593#endif
3594
3339 nBits = POPUNS();
3340 x1 = POPUNS();
3595 nBits = POPUNS();
3596 x1 = POPUNS();
3341
3597
3342 PUSHUNS(x1 >> nBits);
3598 PUSHUNS(x1 >> nBits);
3343 return;
3344}
3345
3346
3347/**************************************************************************
3348 m S t a r
3349** m-star CORE ( n1 n2 -- d )
3350** d is the signed product of n1 times n2.
3351**************************************************************************/
3352static void mStar(FICL_VM *pVM)
3353{
3599 return;
3600}
3601
3602
3603/**************************************************************************
3604 m S t a r
3605** m-star CORE ( n1 n2 -- d )
3606** d is the signed product of n1 times n2.
3607**************************************************************************/
3608static void mStar(FICL_VM *pVM)
3609{
3354 FICL_INT n2;
3355 FICL_INT n1;
3356 DPINT d;
3610 FICL_INT n2;
3611 FICL_INT n1;
3612 DPINT d;
3357#if FICL_ROBUST > 1
3613#if FICL_ROBUST > 1
3358 vmCheckStack(pVM,2,2);
3614 vmCheckStack(pVM,2,2);
3359#endif
3360
3615#endif
3616
3361 n2 = POPINT();
3362 n1 = POPINT();
3617 n2 = POPINT();
3618 n1 = POPINT();
3363
3619
3364 d = m64MulI(n1, n2);
3365 i64Push(pVM->pStack, d);
3620 d = m64MulI(n1, n2);
3621 i64Push(pVM->pStack, d);
3366 return;
3367}
3368
3369
3370static void umStar(FICL_VM *pVM)
3371{
3622 return;
3623}
3624
3625
3626static void umStar(FICL_VM *pVM)
3627{
3372 FICL_UNS u2;
3373 FICL_UNS u1;
3374 DPUNS ud;
3628 FICL_UNS u2;
3629 FICL_UNS u1;
3630 DPUNS ud;
3375#if FICL_ROBUST > 1
3631#if FICL_ROBUST > 1
3376 vmCheckStack(pVM,2,2);
3632 vmCheckStack(pVM,2,2);
3377#endif
3378
3633#endif
3634
3379 u2 = POPUNS();
3380 u1 = POPUNS();
3635 u2 = POPUNS();
3636 u1 = POPUNS();
3381
3637
3382 ud = ficlLongMul(u1, u2);
3383 u64Push(pVM->pStack, ud);
3638 ud = ficlLongMul(u1, u2);
3639 u64Push(pVM->pStack, ud);
3384 return;
3385}
3386
3387
3388/**************************************************************************
3389 m a x & m i n
3390**
3391**************************************************************************/
3392static void ficlMax(FICL_VM *pVM)
3393{
3640 return;
3641}
3642
3643
3644/**************************************************************************
3645 m a x & m i n
3646**
3647**************************************************************************/
3648static void ficlMax(FICL_VM *pVM)
3649{
3394 FICL_INT n2;
3395 FICL_INT n1;
3650 FICL_INT n2;
3651 FICL_INT n1;
3396#if FICL_ROBUST > 1
3652#if FICL_ROBUST > 1
3397 vmCheckStack(pVM,2,1);
3653 vmCheckStack(pVM,2,1);
3398#endif
3399
3654#endif
3655
3400 n2 = POPINT();
3401 n1 = POPINT();
3656 n2 = POPINT();
3657 n1 = POPINT();
3402
3658
3403 PUSHINT((n1 > n2) ? n1 : n2);
3659 PUSHINT((n1 > n2) ? n1 : n2);
3404 return;
3405}
3406
3407static void ficlMin(FICL_VM *pVM)
3408{
3660 return;
3661}
3662
3663static void ficlMin(FICL_VM *pVM)
3664{
3409 FICL_INT n2;
3410 FICL_INT n1;
3665 FICL_INT n2;
3666 FICL_INT n1;
3411#if FICL_ROBUST > 1
3667#if FICL_ROBUST > 1
3412 vmCheckStack(pVM,2,1);
3668 vmCheckStack(pVM,2,1);
3413#endif
3414
3669#endif
3670
3415 n2 = POPINT();
3416 n1 = POPINT();
3671 n2 = POPINT();
3672 n1 = POPINT();
3417
3673
3418 PUSHINT((n1 < n2) ? n1 : n2);
3674 PUSHINT((n1 < n2) ? n1 : n2);
3419 return;
3420}
3421
3422
3423/**************************************************************************
3424 m o v e
3425** CORE ( addr1 addr2 u -- )
3426** If u is greater than zero, copy the contents of u consecutive address
3427** units at addr1 to the u consecutive address units at addr2. After MOVE
3428** completes, the u consecutive address units at addr2 contain exactly
3429** what the u consecutive address units at addr1 contained before the move.
3430** NOTE! This implementation assumes that a char is the same size as
3431** an address unit.
3432**************************************************************************/
3433static void move(FICL_VM *pVM)
3434{
3675 return;
3676}
3677
3678
3679/**************************************************************************
3680 m o v e
3681** CORE ( addr1 addr2 u -- )
3682** If u is greater than zero, copy the contents of u consecutive address
3683** units at addr1 to the u consecutive address units at addr2. After MOVE
3684** completes, the u consecutive address units at addr2 contain exactly
3685** what the u consecutive address units at addr1 contained before the move.
3686** NOTE! This implementation assumes that a char is the same size as
3687** an address unit.
3688**************************************************************************/
3689static void move(FICL_VM *pVM)
3690{
3435 FICL_UNS u;
3436 char *addr2;
3437 char *addr1;
3691 FICL_UNS u;
3692 char *addr2;
3693 char *addr1;
3438#if FICL_ROBUST > 1
3694#if FICL_ROBUST > 1
3439 vmCheckStack(pVM,3,0);
3695 vmCheckStack(pVM,3,0);
3440#endif
3441
3696#endif
3697
3442 u = POPUNS();
3443 addr2 = POPPTR();
3444 addr1 = POPPTR();
3698 u = POPUNS();
3699 addr2 = POPPTR();
3700 addr1 = POPPTR();
3445
3446 if (u == 0)
3447 return;
3448 /*
3449 ** Do the copy carefully, so as to be
3450 ** correct even if the two ranges overlap
3451 */
3452 if (addr1 >= addr2)

--- 14 unchanged lines hidden (view full) ---

3467
3468
3469/**************************************************************************
3470 r e c u r s e
3471**
3472**************************************************************************/
3473static void recurseCoIm(FICL_VM *pVM)
3474{
3701
3702 if (u == 0)
3703 return;
3704 /*
3705 ** Do the copy carefully, so as to be
3706 ** correct even if the two ranges overlap
3707 */
3708 if (addr1 >= addr2)

--- 14 unchanged lines hidden (view full) ---

3723
3724
3725/**************************************************************************
3726 r e c u r s e
3727**
3728**************************************************************************/
3729static void recurseCoIm(FICL_VM *pVM)
3730{
3475 FICL_DICT *pDict = ficlGetDict();
3731 FICL_DICT *pDict = vmGetDict(pVM);
3476
3477 IGNORE(pVM);
3478 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3479 return;
3480}
3481
3482
3483/**************************************************************************
3484 s t o d
3485** s-to-d CORE ( n -- d )
3486** Convert the number n to the double-cell number d with the same
3487** numerical value.
3488**************************************************************************/
3489static void sToD(FICL_VM *pVM)
3490{
3732
3733 IGNORE(pVM);
3734 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3735 return;
3736}
3737
3738
3739/**************************************************************************
3740 s t o d
3741** s-to-d CORE ( n -- d )
3742** Convert the number n to the double-cell number d with the same
3743** numerical value.
3744**************************************************************************/
3745static void sToD(FICL_VM *pVM)
3746{
3491 FICL_INT s;
3747 FICL_INT s;
3492#if FICL_ROBUST > 1
3748#if FICL_ROBUST > 1
3493 vmCheckStack(pVM,1,2);
3749 vmCheckStack(pVM,1,2);
3494#endif
3495
3750#endif
3751
3496 s = POPINT();
3752 s = POPINT();
3497
3753
3498 /* sign extend to 64 bits.. */
3499 PUSHINT(s);
3500 PUSHINT((s < 0) ? -1 : 0);
3754 /* sign extend to 64 bits.. */
3755 PUSHINT(s);
3756 PUSHINT((s < 0) ? -1 : 0);
3501 return;
3502}
3503
3504
3505/**************************************************************************
3506 s o u r c e
3507** CORE ( -- c-addr u )
3508** c-addr is the address of, and u is the number of characters in, the
3509** input buffer.
3510**************************************************************************/
3511static void source(FICL_VM *pVM)
3512{
3513#if FICL_ROBUST > 1
3757 return;
3758}
3759
3760
3761/**************************************************************************
3762 s o u r c e
3763** CORE ( -- c-addr u )
3764** c-addr is the address of, and u is the number of characters in, the
3765** input buffer.
3766**************************************************************************/
3767static void source(FICL_VM *pVM)
3768{
3769#if FICL_ROBUST > 1
3514 vmCheckStack(pVM,0,2);
3770 vmCheckStack(pVM,0,2);
3515#endif
3771#endif
3516 PUSHPTR(pVM->tib.cp);
3772 PUSHPTR(pVM->tib.cp);
3517 PUSHINT(vmGetInBufLen(pVM));
3518 return;
3519}
3520
3521
3522/**************************************************************************
3523 v e r s i o n
3524** non-standard...

--- 7 unchanged lines hidden (view full) ---

3532
3533/**************************************************************************
3534 t o I n
3535** to-in CORE
3536**************************************************************************/
3537static void toIn(FICL_VM *pVM)
3538{
3539#if FICL_ROBUST > 1
3773 PUSHINT(vmGetInBufLen(pVM));
3774 return;
3775}
3776
3777
3778/**************************************************************************
3779 v e r s i o n
3780** non-standard...

--- 7 unchanged lines hidden (view full) ---

3788
3789/**************************************************************************
3790 t o I n
3791** to-in CORE
3792**************************************************************************/
3793static void toIn(FICL_VM *pVM)
3794{
3795#if FICL_ROBUST > 1
3540 vmCheckStack(pVM,0,1);
3796 vmCheckStack(pVM,0,1);
3541#endif
3797#endif
3542 PUSHPTR(&pVM->tib.index);
3798 PUSHPTR(&pVM->tib.index);
3543 return;
3544}
3545
3546
3547/**************************************************************************
3548 c o l o n N o N a m e
3549** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3550** Create an unnamed colon definition and push its address.
3551** Change state to compile.
3552**************************************************************************/
3553static void colonNoName(FICL_VM *pVM)
3554{
3799 return;
3800}
3801
3802
3803/**************************************************************************
3804 c o l o n N o N a m e
3805** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3806** Create an unnamed colon definition and push its address.
3807** Change state to compile.
3808**************************************************************************/
3809static void colonNoName(FICL_VM *pVM)
3810{
3555 FICL_DICT *dp = ficlGetDict();
3811 FICL_DICT *dp = vmGetDict(pVM);
3556 FICL_WORD *pFW;
3557 STRINGINFO si;
3558
3559 SI_SETLEN(si, 0);
3560 SI_SETPTR(si, NULL);
3561
3562 pVM->state = COMPILE;
3563 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);

--- 25 unchanged lines hidden (view full) ---

3589 FICL_INT i = pVM->runningWord->param[0].i;
3590 PUSHPTR(&pVM->user[i]);
3591 return;
3592}
3593
3594
3595static void userVariable(FICL_VM *pVM)
3596{
3812 FICL_WORD *pFW;
3813 STRINGINFO si;
3814
3815 SI_SETLEN(si, 0);
3816 SI_SETPTR(si, NULL);
3817
3818 pVM->state = COMPILE;
3819 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);

--- 25 unchanged lines hidden (view full) ---

3845 FICL_INT i = pVM->runningWord->param[0].i;
3846 PUSHPTR(&pVM->user[i]);
3847 return;
3848}
3849
3850
3851static void userVariable(FICL_VM *pVM)
3852{
3597 FICL_DICT *dp = ficlGetDict();
3853 FICL_DICT *dp = vmGetDict(pVM);
3598 STRINGINFO si = vmGetWord(pVM);
3599 CELL c;
3600
3601 c = stackPop(pVM->pStack);
3602 if (c.i >= FICL_USER_CELLS)
3603 {
3604 vmThrowErr(pVM, "Error - out of user space");
3605 }

--- 11 unchanged lines hidden (view full) ---

3617** Interpretation: ( x "<spaces>name" -- )
3618** Skip leading spaces and parse name delimited by a space. Store x in
3619** name. An ambiguous condition exists if name was not defined by VALUE.
3620** NOTE: In ficl, VALUE is an alias of CONSTANT
3621**************************************************************************/
3622static void toValue(FICL_VM *pVM)
3623{
3624 STRINGINFO si = vmGetWord(pVM);
3854 STRINGINFO si = vmGetWord(pVM);
3855 CELL c;
3856
3857 c = stackPop(pVM->pStack);
3858 if (c.i >= FICL_USER_CELLS)
3859 {
3860 vmThrowErr(pVM, "Error - out of user space");
3861 }

--- 11 unchanged lines hidden (view full) ---

3873** Interpretation: ( x "<spaces>name" -- )
3874** Skip leading spaces and parse name delimited by a space. Store x in
3875** name. An ambiguous condition exists if name was not defined by VALUE.
3876** NOTE: In ficl, VALUE is an alias of CONSTANT
3877**************************************************************************/
3878static void toValue(FICL_VM *pVM)
3879{
3880 STRINGINFO si = vmGetWord(pVM);
3625 FICL_DICT *dp = ficlGetDict();
3881 FICL_DICT *dp = vmGetDict(pVM);
3626 FICL_WORD *pFW;
3627
3628#if FICL_WANT_LOCALS
3882 FICL_WORD *pFW;
3883
3884#if FICL_WANT_LOCALS
3629 if ((nLocals > 0) && (pVM->state == COMPILE))
3885 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
3630 {
3886 {
3631 FICL_DICT *pLoc = ficlGetLoc();
3887 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
3632 pFW = dictLookup(pLoc, si);
3633 if (pFW && (pFW->code == doLocalIm))
3634 {
3888 pFW = dictLookup(pLoc, si);
3889 if (pFW && (pFW->code == doLocalIm))
3890 {
3635 dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
3891 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
3636 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3637 return;
3638 }
3639 else if (pFW && pFW->code == do2LocalIm)
3640 {
3892 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3893 return;
3894 }
3895 else if (pFW && pFW->code == do2LocalIm)
3896 {
3641 dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen));
3897 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
3642 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3643 return;
3644 }
3645 }
3646#endif
3647
3898 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3899 return;
3900 }
3901 }
3902#endif
3903
3648 assert(pStore);
3904 assert(pVM->pSys->pStore);
3649
3650 pFW = dictLookup(dp, si);
3651 if (!pFW)
3652 {
3653 int i = SI_COUNT(si);
3654 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3655 }
3656
3657 if (pVM->state == INTERPRET)
3658 pFW->param[0] = stackPop(pVM->pStack);
3659 else /* compile code to store to word's param */
3660 {
3661 PUSHPTR(&pFW->param[0]);
3662 literalIm(pVM);
3905
3906 pFW = dictLookup(dp, si);
3907 if (!pFW)
3908 {
3909 int i = SI_COUNT(si);
3910 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3911 }
3912
3913 if (pVM->state == INTERPRET)
3914 pFW->param[0] = stackPop(pVM->pStack);
3915 else /* compile code to store to word's param */
3916 {
3917 PUSHPTR(&pFW->param[0]);
3918 literalIm(pVM);
3663 dictAppendCell(dp, LVALUEtoCELL(pStore));
3919 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
3664 }
3665 return;
3666}
3667
3668
3669#if FICL_WANT_LOCALS
3670/**************************************************************************
3671 l i n k P a r e n

--- 73 unchanged lines hidden (view full) ---

3745** word that does doLocalIm at runtime. DoLocalIm compiles code
3746** into the client definition to fetch the value of the
3747** corresponding local variable from the return stack.
3748** The private dictionary gets initialized at the end of each block
3749** that uses locals (in ; and does> for example).
3750*/
3751static void doLocalIm(FICL_VM *pVM)
3752{
3920 }
3921 return;
3922}
3923
3924
3925#if FICL_WANT_LOCALS
3926/**************************************************************************
3927 l i n k P a r e n

--- 73 unchanged lines hidden (view full) ---

4001** word that does doLocalIm at runtime. DoLocalIm compiles code
4002** into the client definition to fetch the value of the
4003** corresponding local variable from the return stack.
4004** The private dictionary gets initialized at the end of each block
4005** that uses locals (in ; and does> for example).
4006*/
4007static void doLocalIm(FICL_VM *pVM)
4008{
3753 FICL_DICT *pDict = ficlGetDict();
3754 int nLocal = pVM->runningWord->param[0].i;
4009 FICL_DICT *pDict = vmGetDict(pVM);
4010 FICL_INT nLocal = pVM->runningWord->param[0].i;
3755
3756 if (pVM->state == INTERPRET)
3757 {
3758 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3759 }
3760 else
3761 {
3762
3763 if (nLocal == 0)
3764 {
4011
4012 if (pVM->state == INTERPRET)
4013 {
4014 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4015 }
4016 else
4017 {
4018
4019 if (nLocal == 0)
4020 {
3765 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0));
4021 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
3766 }
3767 else if (nLocal == 1)
3768 {
4022 }
4023 else if (nLocal == 1)
4024 {
3769 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1));
4025 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
3770 }
3771 else
3772 {
4026 }
4027 else
4028 {
3773 dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen));
4029 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
3774 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
3775 }
3776 }
3777 return;
3778}
3779
3780
3781/**************************************************************************

--- 16 unchanged lines hidden (view full) ---

3798**
3799** Push the local's value, x, onto the stack. The local's value is
3800** initialized as described in 13.3.3 Processing locals and may be
3801** changed by preceding the local's name with TO. An ambiguous condition
3802** exists when local is executed while in interpretation state.
3803**************************************************************************/
3804static void localParen(FICL_VM *pVM)
3805{
4030 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4031 }
4032 }
4033 return;
4034}
4035
4036
4037/**************************************************************************

--- 16 unchanged lines hidden (view full) ---

4054**
4055** Push the local's value, x, onto the stack. The local's value is
4056** initialized as described in 13.3.3 Processing locals and may be
4057** changed by preceding the local's name with TO. An ambiguous condition
4058** exists when local is executed while in interpretation state.
4059**************************************************************************/
4060static void localParen(FICL_VM *pVM)
4061{
3806 static CELL *pMark = NULL;
3807 FICL_DICT *pDict;
3808 STRINGINFO si;
4062 FICL_DICT *pDict;
4063 STRINGINFO si;
3809#if FICL_ROBUST > 1
4064#if FICL_ROBUST > 1
3810 vmCheckStack(pVM,2,0);
4065 vmCheckStack(pVM,2,0);
3811#endif
3812
4066#endif
4067
3813 pDict = ficlGetDict();
3814 SI_SETLEN(si, POPUNS());
3815 SI_SETPTR(si, (char *)POPPTR());
4068 pDict = vmGetDict(pVM);
4069 SI_SETLEN(si, POPUNS());
4070 SI_SETPTR(si, (char *)POPPTR());
3816
3817 if (SI_COUNT(si) > 0)
3818 { /* add a local to the **locals** dict and update nLocals */
4071
4072 if (SI_COUNT(si) > 0)
4073 { /* add a local to the **locals** dict and update nLocals */
3819 FICL_DICT *pLoc = ficlGetLoc();
3820 if (nLocals >= FICL_MAX_LOCALS)
4074 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4075 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
3821 {
3822 vmThrowErr(pVM, "Error: out of local space");
3823 }
3824
3825 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4076 {
4077 vmThrowErr(pVM, "Error: out of local space");
4078 }
4079
4080 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
3826 dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
4081 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
3827
4082
3828 if (nLocals == 0)
4083 if (pVM->pSys->nLocals == 0)
3829 { /* compile code to create a local stack frame */
4084 { /* compile code to create a local stack frame */
3830 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
4085 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
3831 /* save location in dictionary for #locals */
4086 /* save location in dictionary for #locals */
3832 pMarkLocals = pDict->here;
3833 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
4087 pVM->pSys->pMarkLocals = pDict->here;
4088 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
3834 /* compile code to initialize first local */
4089 /* compile code to initialize first local */
3835 dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
4090 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
3836 }
4091 }
3837 else if (nLocals == 1)
4092 else if (pVM->pSys->nLocals == 1)
3838 {
4093 {
3839 dictAppendCell(pDict, LVALUEtoCELL(pToLocal1));
4094 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
3840 }
3841 else
3842 {
4095 }
4096 else
4097 {
3843 dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen));
3844 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
4098 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4099 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
3845 }
3846
4100 }
4101
3847 nLocals++;
4102 (pVM->pSys->nLocals)++;
3848 }
4103 }
3849 else if (nLocals > 0)
4104 else if (pVM->pSys->nLocals > 0)
3850 { /* write nLocals to (link) param area in dictionary */
4105 { /* write nLocals to (link) param area in dictionary */
3851 *(FICL_INT *)pMarkLocals = nLocals;
4106 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
3852 }
3853
3854 return;
3855}
3856
3857
3858static void get2LocalParen(FICL_VM *pVM)
3859{
3860 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3861 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3862 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
3863 return;
3864}
3865
3866
3867static void do2LocalIm(FICL_VM *pVM)
3868{
4107 }
4108
4109 return;
4110}
4111
4112
4113static void get2LocalParen(FICL_VM *pVM)
4114{
4115 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4116 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4117 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4118 return;
4119}
4120
4121
4122static void do2LocalIm(FICL_VM *pVM)
4123{
3869 FICL_DICT *pDict = ficlGetDict();
3870 int nLocal = pVM->runningWord->param[0].i;
4124 FICL_DICT *pDict = vmGetDict(pVM);
4125 FICL_INT nLocal = pVM->runningWord->param[0].i;
3871
3872 if (pVM->state == INTERPRET)
3873 {
3874 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3875 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
3876 }
3877 else
3878 {
4126
4127 if (pVM->state == INTERPRET)
4128 {
4129 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4130 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4131 }
4132 else
4133 {
3879 dictAppendCell(pDict, LVALUEtoCELL(pGet2LocalParen));
4134 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
3880 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
3881 }
3882 return;
3883}
3884
3885
3886static void to2LocalParen(FICL_VM *pVM)
3887{
3888 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3889 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
3890 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3891 return;
3892}
3893
3894
3895static void twoLocalParen(FICL_VM *pVM)
3896{
4135 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4136 }
4137 return;
4138}
4139
4140
4141static void to2LocalParen(FICL_VM *pVM)
4142{
4143 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4144 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4145 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4146 return;
4147}
4148
4149
4150static void twoLocalParen(FICL_VM *pVM)
4151{
3897 FICL_DICT *pDict = ficlGetDict();
4152 FICL_DICT *pDict = vmGetDict(pVM);
3898 STRINGINFO si;
3899 SI_SETLEN(si, stackPopUNS(pVM->pStack));
3900 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
3901
3902 if (SI_COUNT(si) > 0)
3903 { /* add a local to the **locals** dict and update nLocals */
4153 STRINGINFO si;
4154 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4155 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4156
4157 if (SI_COUNT(si) > 0)
4158 { /* add a local to the **locals** dict and update nLocals */
3904 FICL_DICT *pLoc = ficlGetLoc();
3905 if (nLocals >= FICL_MAX_LOCALS)
4159 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4160 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
3906 {
3907 vmThrowErr(pVM, "Error: out of local space");
3908 }
3909
3910 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4161 {
4162 vmThrowErr(pVM, "Error: out of local space");
4163 }
4164
4165 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
3911 dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
4166 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
3912
4167
3913 if (nLocals == 0)
4168 if (pVM->pSys->nLocals == 0)
3914 { /* compile code to create a local stack frame */
4169 { /* compile code to create a local stack frame */
3915 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
4170 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
3916 /* save location in dictionary for #locals */
4171 /* save location in dictionary for #locals */
3917 pMarkLocals = pDict->here;
3918 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
4172 pVM->pSys->pMarkLocals = pDict->here;
4173 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
3919 }
3920
4174 }
4175
3921 dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen));
3922 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
4176 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4177 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
3923
4178
3924 nLocals += 2;
4179 pVM->pSys->nLocals += 2;
3925 }
4180 }
3926 else if (nLocals > 0)
4181 else if (pVM->pSys->nLocals > 0)
3927 { /* write nLocals to (link) param area in dictionary */
4182 { /* write nLocals to (link) param area in dictionary */
3928 *(FICL_INT *)pMarkLocals = nLocals;
4183 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
3929 }
3930
3931 return;
3932}
3933
3934
3935#endif
3936/**************************************************************************

--- 5 unchanged lines hidden (view full) ---

3942** difference is found. If the two strings are identical, n is zero. If the two
3943** strings are identical up to the length of the shorter string, n is minus-one
3944** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
3945** identical up to the length of the shorter string, n is minus-one (-1) if the
3946** first non-matching character in the string specified by c-addr1 u1 has a
3947** lesser numeric value than the corresponding character in the string specified
3948** by c-addr2 u2 and one (1) otherwise.
3949**************************************************************************/
4184 }
4185
4186 return;
4187}
4188
4189
4190#endif
4191/**************************************************************************

--- 5 unchanged lines hidden (view full) ---

4197** difference is found. If the two strings are identical, n is zero. If the two
4198** strings are identical up to the length of the shorter string, n is minus-one
4199** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4200** identical up to the length of the shorter string, n is minus-one (-1) if the
4201** first non-matching character in the string specified by c-addr1 u1 has a
4202** lesser numeric value than the corresponding character in the string specified
4203** by c-addr2 u2 and one (1) otherwise.
4204**************************************************************************/
3950static void compareString(FICL_VM *pVM)
4205static void compareInternal(FICL_VM *pVM, int caseInsensitive)
3951{
3952 char *cp1, *cp2;
3953 FICL_UNS u1, u2, uMin;
3954 int n = 0;
3955
3956 vmCheckStack(pVM, 4, 1);
3957 u2 = stackPopUNS(pVM->pStack);
3958 cp2 = (char *)stackPopPtr(pVM->pStack);
3959 u1 = stackPopUNS(pVM->pStack);
3960 cp1 = (char *)stackPopPtr(pVM->pStack);
3961
3962 uMin = (u1 < u2)? u1 : u2;
3963 for ( ; (uMin > 0) && (n == 0); uMin--)
3964 {
4206{
4207 char *cp1, *cp2;
4208 FICL_UNS u1, u2, uMin;
4209 int n = 0;
4210
4211 vmCheckStack(pVM, 4, 1);
4212 u2 = stackPopUNS(pVM->pStack);
4213 cp2 = (char *)stackPopPtr(pVM->pStack);
4214 u1 = stackPopUNS(pVM->pStack);
4215 cp1 = (char *)stackPopPtr(pVM->pStack);
4216
4217 uMin = (u1 < u2)? u1 : u2;
4218 for ( ; (uMin > 0) && (n == 0); uMin--)
4219 {
3965 n = (int)(*cp1++ - *cp2++);
4220 char c1 = *cp1++;
4221 char c2 = *cp2++;
4222 if (caseInsensitive)
4223 {
4224 c1 = (char)tolower(c1);
4225 c2 = (char)tolower(c2);
4226 }
4227 n = (int)(c1 - c2);
3966 }
3967
3968 if (n == 0)
3969 n = (int)(u1 - u2);
3970
3971 if (n < 0)
3972 n = -1;
3973 else if (n > 0)
3974 n = 1;
3975
3976 PUSHINT(n);
3977 return;
3978}
3979
3980
4228 }
4229
4230 if (n == 0)
4231 n = (int)(u1 - u2);
4232
4233 if (n < 0)
4234 n = -1;
4235 else if (n > 0)
4236 n = 1;
4237
4238 PUSHINT(n);
4239 return;
4240}
4241
4242
4243static void compareString(FICL_VM *pVM)
4244{
4245 compareInternal(pVM, FALSE);
4246}
4247
4248
4249static void compareStringInsensitive(FICL_VM *pVM)
4250{
4251 compareInternal(pVM, TRUE);
4252}
4253
4254
3981/**************************************************************************
4255/**************************************************************************
4256 p a d
4257** CORE EXT ( -- c-addr )
4258** c-addr is the address of a transient region that can be used to hold
4259** data for intermediate processing.
4260**************************************************************************/
4261static void pad(FICL_VM *pVM)
4262{
4263 stackPushPtr(pVM->pStack, pVM->pad);
4264}
4265
4266
4267/**************************************************************************
3982 s o u r c e - i d
3983** CORE EXT, FILE ( -- 0 | -1 | fileid )
3984** Identifies the input source as follows:
3985**
3986** SOURCE-ID Input source
3987** --------- ------------
3988** fileid Text file fileid
3989** -1 String (via EVALUATE)

--- 48 unchanged lines hidden (view full) ---

4038** More comments can be found throughout catch's code.
4039**
4040** Daniel C. Sobral Jan 09/1999
4041** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4042**************************************************************************/
4043
4044static void ficlCatch(FICL_VM *pVM)
4045{
4268 s o u r c e - i d
4269** CORE EXT, FILE ( -- 0 | -1 | fileid )
4270** Identifies the input source as follows:
4271**
4272** SOURCE-ID Input source
4273** --------- ------------
4274** fileid Text file fileid
4275** -1 String (via EVALUATE)

--- 48 unchanged lines hidden (view full) ---

4324** More comments can be found throughout catch's code.
4325**
4326** Daniel C. Sobral Jan 09/1999
4327** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4328**************************************************************************/
4329
4330static void ficlCatch(FICL_VM *pVM)
4331{
4046 static FICL_WORD *pQuit = NULL;
4047
4048 int except;
4049 jmp_buf vmState;
4050 FICL_VM VM;
4051 FICL_STACK pStack;
4052 FICL_STACK rStack;
4053 FICL_WORD *pFW;
4054
4332 int except;
4333 jmp_buf vmState;
4334 FICL_VM VM;
4335 FICL_STACK pStack;
4336 FICL_STACK rStack;
4337 FICL_WORD *pFW;
4338
4055 if (!pQuit)
4056 pQuit = ficlLookup("exit-inner");
4057
4058 assert(pVM);
4339 assert(pVM);
4059 assert(pQuit);
4340 assert(pVM->pSys->pExitInner);
4060
4061
4062 /*
4063 ** Get xt.
4064 ** We need this *before* we save the stack pointer, or
4065 ** we'll have to pop one element out of the stack after
4066 ** an exception. I prefer to get done with it up front. :-)
4067 */

--- 30 unchanged lines hidden (view full) ---

4098 switch (except)
4099 {
4100 /*
4101 ** Setup condition - push poison pill so that the VM throws
4102 ** VM_INNEREXIT if the XT terminates normally, then execute
4103 ** the XT
4104 */
4105 case 0:
4341
4342
4343 /*
4344 ** Get xt.
4345 ** We need this *before* we save the stack pointer, or
4346 ** we'll have to pop one element out of the stack after
4347 ** an exception. I prefer to get done with it up front. :-)
4348 */

--- 30 unchanged lines hidden (view full) ---

4379 switch (except)
4380 {
4381 /*
4382 ** Setup condition - push poison pill so that the VM throws
4383 ** VM_INNEREXIT if the XT terminates normally, then execute
4384 ** the XT
4385 */
4386 case 0:
4106 vmPushIP(pVM, &pQuit); /* Open mouth, insert emetic */
4387 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4107 vmExecute(pVM, pFW);
4108 vmInnerLoop(pVM);
4109 break;
4110
4111 /*
4112 ** Normal exit from XT - lose the poison pill,
4113 ** restore old setjmp vector and push a zero.
4114 */

--- 147 unchanged lines hidden (view full) ---

4262 typedef struct
4263 {
4264 WORDKIND kind;
4265 FICL_CODE code;
4266 } CODEtoKIND;
4267
4268 static CODEtoKIND codeMap[] =
4269 {
4388 vmExecute(pVM, pFW);
4389 vmInnerLoop(pVM);
4390 break;
4391
4392 /*
4393 ** Normal exit from XT - lose the poison pill,
4394 ** restore old setjmp vector and push a zero.
4395 */

--- 147 unchanged lines hidden (view full) ---

4543 typedef struct
4544 {
4545 WORDKIND kind;
4546 FICL_CODE code;
4547 } CODEtoKIND;
4548
4549 static CODEtoKIND codeMap[] =
4550 {
4270 {BRANCH, branchParen},
4271 {COLON, colonParen},
4551 {BRANCH, branchParen},
4552 {COLON, colonParen},
4272 {CONSTANT, constantParen},
4553 {CONSTANT, constantParen},
4273 {CREATE, createParen},
4274 {DO, doParen},
4275 {DOES, doDoes},
4276 {IF, ifParen},
4277 {LITERAL, literalParen},
4278 {LOOP, loopParen},
4279 {PLOOP, plusLoopParen},
4280 {QDO, qDoParen},
4281 {STRINGLIT, stringLit},
4282 {USER, userParen},
4554 {CREATE, createParen},
4555 {DO, doParen},
4556 {DOES, doDoes},
4557 {IF, ifParen},
4558 {LITERAL, literalParen},
4559 {LOOP, loopParen},
4560 {PLOOP, plusLoopParen},
4561 {QDO, qDoParen},
4562 {CSTRINGLIT, cstringLit},
4563 {STRINGLIT, stringLit},
4564#if FICL_WANT_USER
4565 {USER, userParen},
4566#endif
4283 {VARIABLE, variableParen},
4284 };
4285
4286#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4287
4288 FICL_CODE code = pFW->code;
4289 int i;
4290

--- 12 unchanged lines hidden (view full) ---

4303** Builds the primitive wordset and the environment-query namespace.
4304**************************************************************************/
4305
4306void ficlCompileCore(FICL_SYSTEM *pSys)
4307{
4308 FICL_DICT *dp = pSys->dp;
4309 assert (dp);
4310
4567 {VARIABLE, variableParen},
4568 };
4569
4570#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4571
4572 FICL_CODE code = pFW->code;
4573 int i;
4574

--- 12 unchanged lines hidden (view full) ---

4587** Builds the primitive wordset and the environment-query namespace.
4588**************************************************************************/
4589
4590void ficlCompileCore(FICL_SYSTEM *pSys)
4591{
4592 FICL_DICT *dp = pSys->dp;
4593 assert (dp);
4594
4595
4311 /*
4312 ** CORE word set
4313 ** see softcore.c for definitions of: abs bl space spaces abort"
4314 */
4596 /*
4597 ** CORE word set
4598 ** see softcore.c for definitions of: abs bl space spaces abort"
4599 */
4315 pStore =
4600 pSys->pStore =
4316 dictAppendWord(dp, "!", store, FW_DEFAULT);
4317 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4318 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4319 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4320 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4321 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4322 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4323 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4324 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4325 dictAppendWord(dp, "+", add, FW_DEFAULT);
4326 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4327 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4601 dictAppendWord(dp, "!", store, FW_DEFAULT);
4602 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4603 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4604 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4605 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4606 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4607 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4608 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4609 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4610 dictAppendWord(dp, "+", add, FW_DEFAULT);
4611 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4612 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4328 pComma =
4329 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4330 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4331 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4332 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4333 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4334 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4335 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4336 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4613 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4614 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4615 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4616 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4617 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4618 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4619 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4620 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4337 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4338 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4339 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4340 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4341 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4342 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4343 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4344 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4345 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);

--- 39 unchanged lines hidden (view full) ---

4385 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4386 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4387 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4388 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4389 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4390 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4391 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4392 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4621 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4622 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4623 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4624 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4625 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4626 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4627 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4628 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);

--- 39 unchanged lines hidden (view full) ---

4668 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4669 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4670 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4671 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4672 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4673 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4674 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4675 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4393 dictAppendWord(dp, "find", find, FW_DEFAULT);
4676 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4394 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4395 dictAppendWord(dp, "here", here, FW_DEFAULT);
4677 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4678 dictAppendWord(dp, "here", here, FW_DEFAULT);
4396 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4397 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4398 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4399 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4400 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4401 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4402 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4403 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4404 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);

--- 19 unchanged lines hidden (view full) ---

4424 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4425 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4426 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4427 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4428 dictAppendWord(dp, "source", source, FW_DEFAULT);
4429 dictAppendWord(dp, "state", state, FW_DEFAULT);
4430 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4431 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4679 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4680 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4681 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4682 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4683 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4684 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4685 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4686 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);

--- 19 unchanged lines hidden (view full) ---

4706 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4707 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4708 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4709 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4710 dictAppendWord(dp, "source", source, FW_DEFAULT);
4711 dictAppendWord(dp, "state", state, FW_DEFAULT);
4712 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4713 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4432 pType =
4433 dictAppendWord(dp, "type", type, FW_DEFAULT);
4434 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4435 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4436 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4437 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4438 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4439 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4440 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4441 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4442 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4443 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4444 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4445 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4446 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4447 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4448 /*
4449 ** CORE EXT word set...
4714 dictAppendWord(dp, "type", type, FW_DEFAULT);
4715 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4716 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4717 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4718 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4719 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4720 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4721 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4722 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4723 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4724 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4725 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4726 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4727 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4728 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4729 /*
4730 ** CORE EXT word set...
4450 ** see softcore.c for other definitions
4731 ** see softcore.fr for other definitions
4451 */
4732 */
4452 dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);
4453 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4733 /* "#tib" */
4734 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
4735 /* ".r" */
4736 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4454 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4455 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
4456 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
4737 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4738 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
4739 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
4740 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4457 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4458 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
4741 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4742 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
4743 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
4744 /* case of endof endcase */
4745 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4746 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
4459 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4460 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4747 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4748 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4749 /* query restore-input save-input tib u.r u> unused [compile] */
4461 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4462 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4463 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
4464 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4465 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4466 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4467
4468
4469 /*
4470 ** Set CORE environment query values
4471 */
4750 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4751 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4752 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
4753 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4754 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4755 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4756
4757
4758 /*
4759 ** Set CORE environment query values
4760 */
4472 ficlSetEnv("/counted-string", FICL_STRING_MAX);
4473 ficlSetEnv("/hold", nPAD);
4474 ficlSetEnv("/pad", nPAD);
4475 ficlSetEnv("address-unit-bits", 8);
4476 ficlSetEnv("core", FICL_TRUE);
4477 ficlSetEnv("core-ext", FICL_FALSE);
4478 ficlSetEnv("floored", FICL_FALSE);
4479 ficlSetEnv("max-char", UCHAR_MAX);
4480 ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff );
4481 ficlSetEnv("max-n", 0x7fffffff);
4482 ficlSetEnv("max-u", 0xffffffff);
4483 ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff);
4484 ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK);
4485 ficlSetEnv("stack-cells", FICL_DEFAULT_STACK);
4761 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
4762 ficlSetEnv(pSys, "/hold", nPAD);
4763 ficlSetEnv(pSys, "/pad", nPAD);
4764 ficlSetEnv(pSys, "address-unit-bits", 8);
4765 ficlSetEnv(pSys, "core", FICL_TRUE);
4766 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
4767 ficlSetEnv(pSys, "floored", FICL_FALSE);
4768 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
4769 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
4770 ficlSetEnv(pSys, "max-n", 0x7fffffff);
4771 ficlSetEnv(pSys, "max-u", 0xffffffff);
4772 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
4773 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
4774 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
4486
4487 /*
4488 ** DOUBLE word set (partial)
4489 */
4490 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
4491 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
4492 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
4493 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
4494
4495
4496 /*
4497 ** EXCEPTION word set
4498 */
4499 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
4500 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
4501
4775
4776 /*
4777 ** DOUBLE word set (partial)
4778 */
4779 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
4780 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
4781 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
4782 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
4783
4784
4785 /*
4786 ** EXCEPTION word set
4787 */
4788 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
4789 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
4790
4502 ficlSetEnv("exception", FICL_TRUE);
4503 ficlSetEnv("exception-ext", FICL_TRUE);
4791 ficlSetEnv(pSys, "exception", FICL_TRUE);
4792 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
4504
4505 /*
4506 ** LOCAL and LOCAL EXT
4507 ** see softcore.c for implementation of locals|
4508 */
4509#if FICL_WANT_LOCALS
4793
4794 /*
4795 ** LOCAL and LOCAL EXT
4796 ** see softcore.c for implementation of locals|
4797 */
4798#if FICL_WANT_LOCALS
4510 pLinkParen =
4799 pSys->pLinkParen =
4511 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4800 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4512 pUnLinkParen =
4801 pSys->pUnLinkParen =
4513 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4514 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4802 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4803 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4515 pGetLocalParen =
4804 pSys->pGetLocalParen =
4516 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4805 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4517 pToLocalParen =
4806 pSys->pToLocalParen =
4518 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4807 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4519 pGetLocal0 =
4808 pSys->pGetLocal0 =
4520 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4809 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4521 pToLocal0 =
4810 pSys->pToLocal0 =
4522 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4811 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4523 pGetLocal1 =
4812 pSys->pGetLocal1 =
4524 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4813 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4525 pToLocal1 =
4814 pSys->pToLocal1 =
4526 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4527 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4528
4815 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4816 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4817
4529 pGet2LocalParen =
4818 pSys->pGet2LocalParen =
4530 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4819 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4531 pTo2LocalParen =
4820 pSys->pTo2LocalParen =
4532 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
4533 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
4534
4821 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
4822 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
4823
4535 ficlSetEnv("locals", FICL_TRUE);
4536 ficlSetEnv("locals-ext", FICL_TRUE);
4537 ficlSetEnv("#locals", FICL_MAX_LOCALS);
4824 ficlSetEnv(pSys, "locals", FICL_TRUE);
4825 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
4826 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
4538#endif
4539
4540 /*
4541 ** Optional MEMORY-ALLOC word set
4542 */
4543
4544 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
4545 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
4546 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
4547
4827#endif
4828
4829 /*
4830 ** Optional MEMORY-ALLOC word set
4831 */
4832
4833 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
4834 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
4835 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
4836
4548 ficlSetEnv("memory-alloc", FICL_TRUE);
4549 ficlSetEnv("memory-alloc-ext", FICL_FALSE);
4837 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
4550
4551 /*
4552 ** optional SEARCH-ORDER word set
4553 */
4554 ficlCompileSearch(pSys);
4555
4556 /*
4557 ** TOOLS and TOOLS EXT
4558 */
4559 ficlCompileTools(pSys);
4560
4561 /*
4838
4839 /*
4840 ** optional SEARCH-ORDER word set
4841 */
4842 ficlCompileSearch(pSys);
4843
4844 /*
4845 ** TOOLS and TOOLS EXT
4846 */
4847 ficlCompileTools(pSys);
4848
4849 /*
4850 ** FILE and FILE EXT
4851 */
4852#if FICL_WANT_FILE
4853 ficlCompileFile(pSys);
4854#endif
4855
4856 /*
4562 ** Ficl extras
4563 */
4857 ** Ficl extras
4858 */
4859#if FICL_WANT_FLOAT
4860 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4861#endif
4564 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4565 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4566 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4567 dictAppendWord(dp, "add-parse-step",
4568 addParseStep, FW_DEFAULT);
4569 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4570 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4862 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4863 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4864 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4865 dictAppendWord(dp, "add-parse-step",
4866 addParseStep, FW_DEFAULT);
4867 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4868 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4869 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
4571 dictAppendWord(dp, "compile-only",
4572 compileOnly, FW_DEFAULT);
4573 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4574 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
4575 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
4870 dictAppendWord(dp, "compile-only",
4871 compileOnly, FW_DEFAULT);
4872 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4873 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
4874 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
4875 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
4876 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
4576 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4877 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4878 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
4577 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4879 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4880 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
4881 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
4578 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
4579 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
4580 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4581 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4582 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4583#if FICL_WANT_USER
4584 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4585 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4586#endif
4882 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
4883 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
4884 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4885 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4886 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4887#if FICL_WANT_USER
4888 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4889 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4890#endif
4891
4587 /*
4588 ** internal support words
4589 */
4590 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
4892 /*
4893 ** internal support words
4894 */
4895 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
4591 pExitParen =
4896 pSys->pExitParen =
4592 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4897 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4593 pSemiParen =
4898 pSys->pSemiParen =
4594 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4899 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4595 pLitParen =
4900 pSys->pLitParen =
4596 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4901 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4597 pTwoLitParen =
4902 pSys->pTwoLitParen =
4598 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
4903 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
4599 pStringLit =
4904 pSys->pStringLit =
4600 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4905 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4601 pIfParen =
4906 pSys->pCStringLit =
4907 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
4908 pSys->pIfParen =
4602 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4909 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4603 pBranchParen =
4910 pSys->pBranchParen =
4604 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4911 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4605 pDoParen =
4912 pSys->pDoParen =
4606 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4913 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4607 pDoesParen =
4914 pSys->pDoesParen =
4608 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4915 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4609 pQDoParen =
4916 pSys->pQDoParen =
4610 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4917 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4611 pLoopParen =
4918 pSys->pLoopParen =
4612 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4919 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4613 pPLoopParen =
4920 pSys->pPLoopParen =
4614 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4921 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4615 pInterpret =
4922 pSys->pInterpret =
4616 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4923 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4924 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
4617 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4618 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4619 dictAppendWord(dp, "(parse-step)",
4620 parseStepParen, FW_DEFAULT);
4925 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4926 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4927 dictAppendWord(dp, "(parse-step)",
4928 parseStepParen, FW_DEFAULT);
4929 pSys->pExitInner =
4621 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
4622
4930 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
4931
4932 /*
4933 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
4934 */
4935 pSys->pInterp[0] = pSys->pInterpret;
4936 pSys->pInterp[1] = pSys->pBranchParen;
4937 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
4938
4623 assert(dictCellsAvail(dp) > 0);
4624
4625 return;
4626}
4627
4939 assert(dictCellsAvail(dp) > 0);
4940
4941 return;
4942}
4943