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**
8*******************************************************************/
9
10#ifdef TESTMAIN
11#include <stdlib.h>
12#include <stdio.h>
13#include <ctype.h>
14#include <fcntl.h>
15#else
16#include <stand.h>
17#endif
18#include <string.h>
19#include "ficl.h"
20#include "math64.h"
21
22static void colonParen(FICL_VM *pVM);
23static void literalIm(FICL_VM *pVM);
24static void interpWord(FICL_VM *pVM, STRINGINFO si);
25
26/*
27** Control structure building words use these
28** strings' addresses as markers on the stack to
29** check for structure completion.
30*/
31static char doTag[] = "do";
32static char ifTag[] = "if";
33static char colonTag[] = "colon";
34static char leaveTag[] = "leave";
35static char beginTag[] = "begin";
36static char whileTag[] = "while";
37
38/*
39** Pointers to various words in the dictionary
40** -- initialized by ficlCompileCore, below --
41** for use by compiling words. Colon definitions
42** in ficl are lists of pointers to words. A bit
43** simple-minded...
44*/
45static FICL_WORD *pBranchParen = NULL;
46static FICL_WORD *pComma = NULL;
47static FICL_WORD *pDoParen = NULL;
48static FICL_WORD *pDoesParen = NULL;
49static FICL_WORD *pExitParen = NULL;
50static FICL_WORD *pIfParen = NULL;
51static FICL_WORD *pInterpret = NULL;
52static FICL_WORD *pLitParen = NULL;
53static FICL_WORD *pLoopParen = NULL;
54static FICL_WORD *pPLoopParen = NULL;
55static FICL_WORD *pQDoParen = NULL;
56static FICL_WORD *pSemiParen = NULL;
57static FICL_WORD *pStore = NULL;
58static FICL_WORD *pStringLit = NULL;
59static FICL_WORD *pType = NULL;
60
61#if FICL_WANT_LOCALS
62static FICL_WORD *pGetLocalParen= NULL;
63static FICL_WORD *pGetLocal0 = NULL;
64static FICL_WORD *pGetLocal1 = NULL;
65static FICL_WORD *pToLocalParen = NULL;
66static FICL_WORD *pToLocal0 = NULL;
67static FICL_WORD *pToLocal1 = NULL;
68static FICL_WORD *pLinkParen = NULL;
69static FICL_WORD *pUnLinkParen = NULL;
70static int nLocals = 0;
71#endif
72
73
74/*
75** C O N T R O L S T R U C T U R E B U I L D E R S
76**
77** Push current dict location for later branch resolution.
78** The location may be either a branch target or a patch address...
79*/
80static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
81{
82 stackPushPtr(pVM->pStack, dp->here);
83 stackPushPtr(pVM->pStack, tag);
84 return;
85}
86
87static void markControlTag(FICL_VM *pVM, char *tag)
88{
89 stackPushPtr(pVM->pStack, tag);
90 return;
91}
92
93static void matchControlTag(FICL_VM *pVM, char *tag)
94{
95 char *cp = (char *)stackPopPtr(pVM->pStack);
96 if ( strcmp(cp, tag) )
97 {
98 vmTextOut(pVM, "Warning -- unmatched control word: ", 0);
99 vmTextOut(pVM, tag, 1);
100 }
101
102 return;
103}
104
105/*
106** Expect a branch target address on the param stack,
107** compile a literal offset from the current dict location
108** to the target address
109*/
110static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
111{
112 long offset;
113 CELL *patchAddr;
114
115 matchControlTag(pVM, tag);
116
117 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
118 offset = patchAddr - dp->here;
119 dictAppendCell(dp, LVALUEtoCELL(offset));
120
121 return;
122}
123
124
125/*
126** Expect a branch patch address on the param stack,
127** compile a literal offset from the patch location
128** to the current dict location
129*/
130static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
131{
132 long offset;
133 CELL *patchAddr;
134
135 matchControlTag(pVM, tag);
136
137 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
138 offset = dp->here - patchAddr;
139 *patchAddr = LVALUEtoCELL(offset);
140
141 return;
142}
143
144/*
145** Match the tag to the top of the stack. If success,
146** sopy "here" address into the cell whose address is next
147** on the stack. Used by do..leave..loop.
148*/
149static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
150{
151 CELL *patchAddr;
152 char *cp;
153
154 cp = stackPopPtr(pVM->pStack);
155 if (strcmp(cp, tag))
156 {
157 vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
158 vmTextOut(pVM, tag, 1);
159 }
160
161 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
162 *patchAddr = LVALUEtoCELL(dp->here);
163
164 return;
165}
166
167
168/**************************************************************************
169 i s N u m b e r
170** Attempts to convert the NULL terminated string in the VM's pad to
171** a number using the VM's current base. If successful, pushes the number
172** onto the param stack and returns TRUE. Otherwise, returns FALSE.
173**************************************************************************/
174
175static int isNumber(FICL_VM *pVM, STRINGINFO si)
176{
177 INT32 accum = 0;
178 char isNeg = FALSE;
179 unsigned base = pVM->base;
180 char *cp = SI_PTR(si);
181 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
182 unsigned ch;
183 unsigned digit;
184
185 if (*cp == '-')
186 {
187 cp++;
188 count--;
189 isNeg = TRUE;
190 }
191 else if ((cp[0] == '0') && (cp[1] == 'x'))
192 { /* detect 0xNNNN format for hex numbers */
193 cp += 2;
194 count -= 2;
195 base = 16;
196 }
197
198 if (count == 0)
199 return FALSE;
200
201 while (count-- && ((ch = *cp++) != '\0'))
202 {
203 if (ch < '0')
204 return FALSE;
205
206 digit = ch - '0';
207
208 if (digit > 9)
209 digit = tolower(ch) - 'a' + 10;
210 /*
211 ** Note: following test also catches chars between 9 and a
212 ** because 'digit' is unsigned!
213 */
214 if (digit >= base)
215 return FALSE;
216
217 accum = accum * base + digit;
218 }
219
220 if (isNeg)
221 accum = -accum;
222
223 stackPushINT32(pVM->pStack, accum);
224
225 return TRUE;
226}
227
228
229/**************************************************************************
230 a d d & f r i e n d s
231**
232**************************************************************************/
233
234static void add(FICL_VM *pVM)
235{
236 INT32 i;
237#if FICL_ROBUST > 1
238 vmCheckStack(pVM, 2, 1);
239#endif
240 i = stackPopINT32(pVM->pStack);
241 i += stackGetTop(pVM->pStack).i;
242 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
243 return;
244}
245
246static void sub(FICL_VM *pVM)
247{
248 INT32 i;
249#if FICL_ROBUST > 1
250 vmCheckStack(pVM, 2, 1);
251#endif
252 i = stackPopINT32(pVM->pStack);
253 i = stackGetTop(pVM->pStack).i - i;
254 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
255 return;
256}
257
258static void mul(FICL_VM *pVM)
259{
260 INT32 i;
261#if FICL_ROBUST > 1
262 vmCheckStack(pVM, 2, 1);
263#endif
264 i = stackPopINT32(pVM->pStack);
265 i *= stackGetTop(pVM->pStack).i;
266 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
267 return;
268}
269
270static void negate(FICL_VM *pVM)
271{
272 INT32 i;
273#if FICL_ROBUST > 1
274 vmCheckStack(pVM, 1, 1);
275#endif
276 i = -stackPopINT32(pVM->pStack);
277 stackPushINT32(pVM->pStack, i);
278 return;
279}
280
281static void ficlDiv(FICL_VM *pVM)
282{
283 INT32 i;
284#if FICL_ROBUST > 1
285 vmCheckStack(pVM, 2, 1);
286#endif
287 i = stackPopINT32(pVM->pStack);
288 i = stackGetTop(pVM->pStack).i / i;
289 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
290 return;
291}
292
293/*
294** slash-mod CORE ( n1 n2 -- n3 n4 )
295** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
296** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
297** differ in sign, the implementation-defined result returned will be the
298** same as that returned by either the phrase
299** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
300** NOTE: Ficl complies with the second phrase (symmetric division)
301*/
302static void slashMod(FICL_VM *pVM)
303{
304 INT64 n1;
305 INT32 n2;
306 INTQR qr;
307
308#if FICL_ROBUST > 1
309 vmCheckStack(pVM, 2, 2);
310#endif
311 n2 = stackPopINT32(pVM->pStack);
312 n1.lo = stackPopINT32(pVM->pStack);
313 i64Extend(n1);
314
315 qr = m64SymmetricDivI(n1, n2);
316 stackPushINT32(pVM->pStack, qr.rem);
317 stackPushINT32(pVM->pStack, qr.quot);
318 return;
319}
320
321static void onePlus(FICL_VM *pVM)
322{
323 INT32 i;
324#if FICL_ROBUST > 1
325 vmCheckStack(pVM, 1, 1);
326#endif
327 i = stackGetTop(pVM->pStack).i;
328 i += 1;
329 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
330 return;
331}
332
333static void oneMinus(FICL_VM *pVM)
334{
335 INT32 i;
336#if FICL_ROBUST > 1
337 vmCheckStack(pVM, 1, 1);
338#endif
339 i = stackGetTop(pVM->pStack).i;
340 i -= 1;
341 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
342 return;
343}
344
345static void twoMul(FICL_VM *pVM)
346{
347 INT32 i;
348#if FICL_ROBUST > 1
349 vmCheckStack(pVM, 1, 1);
350#endif
351 i = stackGetTop(pVM->pStack).i;
352 i *= 2;
353 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
354 return;
355}
356
357static void twoDiv(FICL_VM *pVM)
358{
359 INT32 i;
360#if FICL_ROBUST > 1
361 vmCheckStack(pVM, 1, 1);
362#endif
363 i = stackGetTop(pVM->pStack).i;
364 i >>= 1;
365 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
366 return;
367}
368
369static void mulDiv(FICL_VM *pVM)
370{
371 INT32 x, y, z;
372 INT64 prod;
373#if FICL_ROBUST > 1
374 vmCheckStack(pVM, 3, 1);
375#endif
376 z = stackPopINT32(pVM->pStack);
377 y = stackPopINT32(pVM->pStack);
378 x = stackPopINT32(pVM->pStack);
379
380 prod = m64MulI(x,y);
381 x = m64SymmetricDivI(prod, z).quot;
382
383 stackPushINT32(pVM->pStack, x);
384 return;
385}
386
387
388static void mulDivRem(FICL_VM *pVM)
389{
390 INT32 x, y, z;
391 INT64 prod;
392 INTQR qr;
393#if FICL_ROBUST > 1
394 vmCheckStack(pVM, 3, 2);
395#endif
396 z = stackPopINT32(pVM->pStack);
397 y = stackPopINT32(pVM->pStack);
398 x = stackPopINT32(pVM->pStack);
399
400 prod = m64MulI(x,y);
401 qr = m64SymmetricDivI(prod, z);
402
403 stackPushINT32(pVM->pStack, qr.rem);
404 stackPushINT32(pVM->pStack, qr.quot);
405 return;
406}
407
408
409/**************************************************************************
410 b y e
411** TOOLS
412** Signal the system to shut down - this causes ficlExec to return
413** VM_USEREXIT. The rest is up to you.
414**************************************************************************/
415
416static void bye(FICL_VM *pVM)
417{
418 vmThrow(pVM, VM_USEREXIT);
419 return;
420}
421
422
423/**************************************************************************
424 c o l o n d e f i n i t i o n s
425** Code to begin compiling a colon definition
426** This function sets the state to COMPILE, then creates a
427** new word whose name is the next word in the input stream
428** and whose code is colonParen.
429**************************************************************************/
430
431static void colon(FICL_VM *pVM)
432{
433 FICL_DICT *dp = ficlGetDict();
434 STRINGINFO si = vmGetWord(pVM);
435
436 pVM->state = COMPILE;
437 markControlTag(pVM, colonTag);
438 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
439#if FICL_WANT_LOCALS
440 nLocals = 0;
441#endif
442 return;
443}
444
445
446/**************************************************************************
447 c o l o n P a r e n
448** This is the code that executes a colon definition. It assumes that the
449** virtual machine is running a "next" loop (See the vm.c
450** for its implementation of member function vmExecute()). The colon
451** code simply copies the address of the first word in the list of words
452** to interpret into IP after saving its old value. When we return to the
453** "next" loop, the virtual machine will call the code for each word in
454** turn.
455**
456**************************************************************************/
457
458static void colonParen(FICL_VM *pVM)
459{
460 IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
461 vmPushIP(pVM, tempIP);
462
463 return;
464}
465
466
467/**************************************************************************
468 s e m i c o l o n C o I m
469**
470** IMMEDIATE code for ";". This function sets the state to INTERPRET and
471** terminates a word under compilation by appending code for "(;)" to
472** the definition. TO DO: checks for leftover branch target tags on the
473** return stack and complains if any are found.
474**************************************************************************/
475static void semiParen(FICL_VM *pVM)
476{
477 vmPopIP(pVM);
478 return;
479}
480
481
482static void semicolonCoIm(FICL_VM *pVM)
483{
484 FICL_DICT *dp = ficlGetDict();
485
486 assert(pSemiParen);
487 matchControlTag(pVM, colonTag);
488
489#if FICL_WANT_LOCALS
490 assert(pUnLinkParen);
491 if (nLocals > 0)
492 {
493 FICL_DICT *pLoc = ficlGetLoc();
494 dictEmpty(pLoc, pLoc->pForthWords->size);
495 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
496 }
497 nLocals = 0;
498#endif
499
500 dictAppendCell(dp, LVALUEtoCELL(pSemiParen));
501 pVM->state = INTERPRET;
502 dictUnsmudge(dp);
503 return;
504}
505
506
507/**************************************************************************
508 e x i t
509** CORE
510** This function simply pops the previous instruction
511** pointer and returns to the "next" loop. Used for exiting from within
512** a definition. Note that exitParen is identical to semiParen - they
513** are in two different functions so that "see" can correctly identify
514** the end of a colon definition, even if it uses "exit".
515**************************************************************************/
516static void exitParen(FICL_VM *pVM)
517{
518 vmPopIP(pVM);
519 return;
520}
521
522static void exitCoIm(FICL_VM *pVM)
523{
524 FICL_DICT *dp = ficlGetDict();
525 assert(pExitParen);
526 IGNORE(pVM);
527
528#if FICL_WANT_LOCALS
529 if (nLocals > 0)
530 {
531 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
532 }
533#endif
534 dictAppendCell(dp, LVALUEtoCELL(pExitParen));
535 return;
536}
537
538
539/**************************************************************************
540 c o n s t a n t P a r e n
541** This is the run-time code for "constant". It simply returns the
542** contents of its word's first data cell.
543**
544**************************************************************************/
545
546void constantParen(FICL_VM *pVM)
547{
548 FICL_WORD *pFW = pVM->runningWord;
549#if FICL_ROBUST > 1
550 vmCheckStack(pVM, 0, 1);
551#endif
552 stackPush(pVM->pStack, pFW->param[0]);
553 return;
554}
555
556void twoConstParen(FICL_VM *pVM)
557{
558 FICL_WORD *pFW = pVM->runningWord;
559#if FICL_ROBUST > 1
560 vmCheckStack(pVM, 0, 2);
561#endif
562 stackPush(pVM->pStack, pFW->param[0]); /* lo */
563 stackPush(pVM->pStack, pFW->param[1]); /* hi */
564 return;
565}
566
567
568/**************************************************************************
569 c o n s t a n t
570** IMMEDIATE
571** Compiles a constant into the dictionary. Constants return their
572** value when invoked. Expects a value on top of the parm stack.
573**************************************************************************/
574
575static void constant(FICL_VM *pVM)
576{
577 FICL_DICT *dp = ficlGetDict();
578 STRINGINFO si = vmGetWord(pVM);
579
580#if FICL_ROBUST > 1
581 vmCheckStack(pVM, 1, 0);
582#endif
583 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
584 dictAppendCell(dp, stackPop(pVM->pStack));
585 return;
586}
587
588
589static void twoConstant(FICL_VM *pVM)
590{
591 FICL_DICT *dp = ficlGetDict();
592 STRINGINFO si = vmGetWord(pVM);
593 CELL c;
594
595#if FICL_ROBUST > 1
596 vmCheckStack(pVM, 2, 0);
597#endif
598 c = stackPop(pVM->pStack);
599 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
600 dictAppendCell(dp, stackPop(pVM->pStack));
601 dictAppendCell(dp, c);
602 return;
603}
604
605
606/**************************************************************************
607 d i s p l a y C e l l
608** Drop and print the contents of the cell at the top of the param
609** stack
610**************************************************************************/
611
612static void displayCell(FICL_VM *pVM)
613{
614 CELL c;
615#if FICL_ROBUST > 1
616 vmCheckStack(pVM, 1, 0);
617#endif
618 c = stackPop(pVM->pStack);
619 ltoa((c).i, pVM->pad, pVM->base);
620 strcat(pVM->pad, " ");
621 vmTextOut(pVM, pVM->pad, 0);
622 return;
623}
624
625static void displayCellNoPad(FICL_VM *pVM)
626{
627 CELL c;
628#if FICL_ROBUST > 1
629 vmCheckStack(pVM, 1, 0);
630#endif
631 c = stackPop(pVM->pStack);
632 ltoa((c).i, pVM->pad, pVM->base);
633 vmTextOut(pVM, pVM->pad, 0);
634 return;
635}
636
637static void uDot(FICL_VM *pVM)
638{
639 UNS32 u;
640#if FICL_ROBUST > 1
641 vmCheckStack(pVM, 1, 0);
642#endif
643 u = stackPopUNS32(pVM->pStack);
644 ultoa(u, pVM->pad, pVM->base);
645 strcat(pVM->pad, " ");
646 vmTextOut(pVM, pVM->pad, 0);
647 return;
648}
649
650
651static void hexDot(FICL_VM *pVM)
652{
653 UNS32 u;
654#if FICL_ROBUST > 1
655 vmCheckStack(pVM, 1, 0);
656#endif
657 u = stackPopUNS32(pVM->pStack);
658 ultoa(u, pVM->pad, 16);
659 strcat(pVM->pad, " ");
660 vmTextOut(pVM, pVM->pad, 0);
661 return;
662}
663
664
665/**************************************************************************
666 d i s p l a y S t a c k
667** Display the parameter stack (code for ".s")
668**************************************************************************/
669
670static void displayStack(FICL_VM *pVM)
671{
672 int d = stackDepth(pVM->pStack);
673 int i;
674 CELL *pCell;
675
676 vmCheckStack(pVM, 0, 0);
677
678 if (d == 0)
679 vmTextOut(pVM, "(Stack Empty)", 1);
680 else
681 {
682 pCell = pVM->pStack->sp;
683 for (i = 0; i < d; i++)
684 {
685 vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1);
686 }
687 }
688}
689
690
691/**************************************************************************
692 d u p & f r i e n d s
693**
694**************************************************************************/
695
696static void depth(FICL_VM *pVM)
697{
698 int i;
699#if FICL_ROBUST > 1
700 vmCheckStack(pVM, 0, 1);
701#endif
702 i = stackDepth(pVM->pStack);
703 stackPushINT32(pVM->pStack, i);
704 return;
705}
706
707
708static void drop(FICL_VM *pVM)
709{
710#if FICL_ROBUST > 1
711 vmCheckStack(pVM, 1, 0);
712#endif
713 stackDrop(pVM->pStack, 1);
714 return;
715}
716
717
718static void twoDrop(FICL_VM *pVM)
719{
720#if FICL_ROBUST > 1
721 vmCheckStack(pVM, 2, 0);
722#endif
723 stackDrop(pVM->pStack, 2);
724 return;
725}
726
727
728static void dup(FICL_VM *pVM)
729{
730#if FICL_ROBUST > 1
731 vmCheckStack(pVM, 1, 2);
732#endif
733 stackPick(pVM->pStack, 0);
734 return;
735}
736
737
738static void twoDup(FICL_VM *pVM)
739{
740#if FICL_ROBUST > 1
741 vmCheckStack(pVM, 2, 4);
742#endif
743 stackPick(pVM->pStack, 1);
744 stackPick(pVM->pStack, 1);
745 return;
746}
747
748
749static void over(FICL_VM *pVM)
750{
751#if FICL_ROBUST > 1
752 vmCheckStack(pVM, 2, 3);
753#endif
754 stackPick(pVM->pStack, 1);
755 return;
756}
757
758static void twoOver(FICL_VM *pVM)
759{
760#if FICL_ROBUST > 1
761 vmCheckStack(pVM, 4, 6);
762#endif
763 stackPick(pVM->pStack, 3);
764 stackPick(pVM->pStack, 3);
765 return;
766}
767
768
769static void pick(FICL_VM *pVM)
770{
771 CELL c = stackPop(pVM->pStack);
772#if FICL_ROBUST > 1
773 vmCheckStack(pVM, c.i+1, c.i+2);
774#endif
775 stackPick(pVM->pStack, c.i);
776 return;
777}
778
779
780static void questionDup(FICL_VM *pVM)
781{
782 CELL c;
783#if FICL_ROBUST > 1
784 vmCheckStack(pVM, 1, 2);
785#endif
786 c = stackGetTop(pVM->pStack);
787
788 if (c.i != 0)
789 stackPick(pVM->pStack, 0);
790
791 return;
792}
793
794
795static void roll(FICL_VM *pVM)
796{
797 int i = stackPop(pVM->pStack).i;
798 i = (i > 0) ? i : 0;
799#if FICL_ROBUST > 1
800 vmCheckStack(pVM, i+1, i+1);
801#endif
802 stackRoll(pVM->pStack, i);
803 return;
804}
805
806
807static void minusRoll(FICL_VM *pVM)
808{
809 int i = stackPop(pVM->pStack).i;
810 i = (i > 0) ? i : 0;
811#if FICL_ROBUST > 1
812 vmCheckStack(pVM, i+1, i+1);
813#endif
814 stackRoll(pVM->pStack, -i);
815 return;
816}
817
818
819static void rot(FICL_VM *pVM)
820{
821#if FICL_ROBUST > 1
822 vmCheckStack(pVM, 3, 3);
823#endif
824 stackRoll(pVM->pStack, 2);
825 return;
826}
827
828
829static void swap(FICL_VM *pVM)
830{
831#if FICL_ROBUST > 1
832 vmCheckStack(pVM, 2, 2);
833#endif
834 stackRoll(pVM->pStack, 1);
835 return;
836}
837
838
839static void twoSwap(FICL_VM *pVM)
840{
841#if FICL_ROBUST > 1
842 vmCheckStack(pVM, 4, 4);
843#endif
844 stackRoll(pVM->pStack, 3);
845 stackRoll(pVM->pStack, 3);
846 return;
847}
848
849
850/**************************************************************************
851 e m i t & f r i e n d s
852**
853**************************************************************************/
854
855static void emit(FICL_VM *pVM)
856{
857 char *cp = pVM->pad;
858 int i;
859
860#if FICL_ROBUST > 1
861 vmCheckStack(pVM, 1, 0);
862#endif
863 i = stackPopINT32(pVM->pStack);
864 cp[0] = (char)i;
865 cp[1] = '\0';
866 vmTextOut(pVM, cp, 0);
867 return;
868}
869
870
871static void cr(FICL_VM *pVM)
872{
873 vmTextOut(pVM, "", 1);
874 return;
875}
876
877
878static void commentLine(FICL_VM *pVM)
879{
880 char *cp = vmGetInBuf(pVM);
881 char ch = *cp;
882
883 while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n'))
884 {
885 ch = *++cp;
886 }
887
888 /*
889 ** Cope with DOS or UNIX-style EOLs -
890 ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
891 ** and point cp to next char. If EOL is \0, we're done.
892 */
893 if ((pVM->tib.end != cp) && (ch != '\0'))
894 {
895 cp++;
896
897 if ( (pVM->tib.end != cp) && (ch != *cp)
898 && ((*cp == '\r') || (*cp == '\n')) )
899 cp++;
900 }
901
902 vmUpdateTib(pVM, cp);
903 return;
904}
905
906
907/*
908** paren CORE
909** Compilation: Perform the execution semantics given below.
910** Execution: ( "ccc<paren>" -- )
911** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
912** The number of characters in ccc may be zero to the number of characters
913** in the parse area.
914**
915*/
916static void commentHang(FICL_VM *pVM)
917{
918 vmParseString(pVM, ')');
919 return;
920}
921
922
923/**************************************************************************
924 F E T C H & S T O R E
925**
926**************************************************************************/
927
928static void fetch(FICL_VM *pVM)
929{
930 CELL *pCell;
931#if FICL_ROBUST > 1
932 vmCheckStack(pVM, 1, 1);
933#endif
934 pCell = (CELL *)stackPopPtr(pVM->pStack);
935 stackPush(pVM->pStack, *pCell);
936 return;
937}
938
939/*
940** two-fetch CORE ( a-addr -- x1 x2 )
941** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
942** x1 at the next consecutive cell. It is equivalent to the sequence
943** DUP CELL+ @ SWAP @ .
944*/
945static void twoFetch(FICL_VM *pVM)
946{
947 CELL *pCell;
948#if FICL_ROBUST > 1
949 vmCheckStack(pVM, 1, 2);
950#endif
951 pCell = (CELL *)stackPopPtr(pVM->pStack);
952 stackPush(pVM->pStack, *pCell++);
953 stackPush(pVM->pStack, *pCell);
954 swap(pVM);
955 return;
956}
957
958/*
959** store CORE ( x a-addr -- )
960** Store x at a-addr.
961*/
962static void store(FICL_VM *pVM)
963{
964 CELL *pCell;
965#if FICL_ROBUST > 1
966 vmCheckStack(pVM, 2, 0);
967#endif
968 pCell = (CELL *)stackPopPtr(pVM->pStack);
969 *pCell = stackPop(pVM->pStack);
970}
971
972/*
973** two-store CORE ( x1 x2 a-addr -- )
974** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
975** next consecutive cell. It is equivalent to the sequence
976** SWAP OVER ! CELL+ ! .
977*/
978static void twoStore(FICL_VM *pVM)
979{
980 CELL *pCell;
981#if FICL_ROBUST > 1
982 vmCheckStack(pVM, 3, 0);
983#endif
984 pCell = (CELL *)stackPopPtr(pVM->pStack);
985 *pCell++ = stackPop(pVM->pStack);
986 *pCell = stackPop(pVM->pStack);
987}
988
989static void plusStore(FICL_VM *pVM)
990{
991 CELL *pCell;
992#if FICL_ROBUST > 1
993 vmCheckStack(pVM, 2, 0);
994#endif
995 pCell = (CELL *)stackPopPtr(pVM->pStack);
996 pCell->i += stackPop(pVM->pStack).i;
997}
998
999
1000static void wFetch(FICL_VM *pVM)
1001{
1002 UNS16 *pw;
1003#if FICL_ROBUST > 1
1004 vmCheckStack(pVM, 1, 1);
1005#endif
1006 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1007 stackPushUNS32(pVM->pStack, (UNS32)*pw);
1008 return;
1009}
1010
1011static void wStore(FICL_VM *pVM)
1012{
1013 UNS16 *pw;
1014#if FICL_ROBUST > 1
1015 vmCheckStack(pVM, 2, 0);
1016#endif
1017 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1018 *pw = (UNS16)(stackPop(pVM->pStack).u);
1019}
1020
1021static void cFetch(FICL_VM *pVM)
1022{
1023 UNS8 *pc;
1024#if FICL_ROBUST > 1
1025 vmCheckStack(pVM, 1, 1);
1026#endif
1027 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1028 stackPushUNS32(pVM->pStack, (UNS32)*pc);
1029 return;
1030}
1031
1032static void cStore(FICL_VM *pVM)
1033{
1034 UNS8 *pc;
1035#if FICL_ROBUST > 1
1036 vmCheckStack(pVM, 2, 0);
1037#endif
1038 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1039 *pc = (UNS8)(stackPop(pVM->pStack).u);
1040}
1041
1042
1043/**************************************************************************
1044 i f C o I m
1045** IMMEDIATE
1046** Compiles code for a conditional branch into the dictionary
1047** and pushes the branch patch address on the stack for later
1048** patching by ELSE or THEN/ENDIF.
1049**************************************************************************/
1050
1051static void ifCoIm(FICL_VM *pVM)
1052{
1053 FICL_DICT *dp = ficlGetDict();
1054
1055 assert(pIfParen);
1056
1057 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
1058 markBranch(dp, pVM, ifTag);
1059 dictAppendUNS32(dp, 1);
1060 return;
1061}
1062
1063
1064/**************************************************************************
1065 i f P a r e n
1066** Runtime code to do "if" or "until": pop a flag from the stack,
1067** fall through if true, branch if false. Probably ought to be
1068** called (not?branch) since it does "branch if false".
1069**************************************************************************/
1070
| 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**
8*******************************************************************/
9
10#ifdef TESTMAIN
11#include <stdlib.h>
12#include <stdio.h>
13#include <ctype.h>
14#include <fcntl.h>
15#else
16#include <stand.h>
17#endif
18#include <string.h>
19#include "ficl.h"
20#include "math64.h"
21
22static void colonParen(FICL_VM *pVM);
23static void literalIm(FICL_VM *pVM);
24static void interpWord(FICL_VM *pVM, STRINGINFO si);
25
26/*
27** Control structure building words use these
28** strings' addresses as markers on the stack to
29** check for structure completion.
30*/
31static char doTag[] = "do";
32static char ifTag[] = "if";
33static char colonTag[] = "colon";
34static char leaveTag[] = "leave";
35static char beginTag[] = "begin";
36static char whileTag[] = "while";
37
38/*
39** Pointers to various words in the dictionary
40** -- initialized by ficlCompileCore, below --
41** for use by compiling words. Colon definitions
42** in ficl are lists of pointers to words. A bit
43** simple-minded...
44*/
45static FICL_WORD *pBranchParen = NULL;
46static FICL_WORD *pComma = NULL;
47static FICL_WORD *pDoParen = NULL;
48static FICL_WORD *pDoesParen = NULL;
49static FICL_WORD *pExitParen = NULL;
50static FICL_WORD *pIfParen = NULL;
51static FICL_WORD *pInterpret = NULL;
52static FICL_WORD *pLitParen = NULL;
53static FICL_WORD *pLoopParen = NULL;
54static FICL_WORD *pPLoopParen = NULL;
55static FICL_WORD *pQDoParen = NULL;
56static FICL_WORD *pSemiParen = NULL;
57static FICL_WORD *pStore = NULL;
58static FICL_WORD *pStringLit = NULL;
59static FICL_WORD *pType = NULL;
60
61#if FICL_WANT_LOCALS
62static FICL_WORD *pGetLocalParen= NULL;
63static FICL_WORD *pGetLocal0 = NULL;
64static FICL_WORD *pGetLocal1 = NULL;
65static FICL_WORD *pToLocalParen = NULL;
66static FICL_WORD *pToLocal0 = NULL;
67static FICL_WORD *pToLocal1 = NULL;
68static FICL_WORD *pLinkParen = NULL;
69static FICL_WORD *pUnLinkParen = NULL;
70static int nLocals = 0;
71#endif
72
73
74/*
75** C O N T R O L S T R U C T U R E B U I L D E R S
76**
77** Push current dict location for later branch resolution.
78** The location may be either a branch target or a patch address...
79*/
80static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
81{
82 stackPushPtr(pVM->pStack, dp->here);
83 stackPushPtr(pVM->pStack, tag);
84 return;
85}
86
87static void markControlTag(FICL_VM *pVM, char *tag)
88{
89 stackPushPtr(pVM->pStack, tag);
90 return;
91}
92
93static void matchControlTag(FICL_VM *pVM, char *tag)
94{
95 char *cp = (char *)stackPopPtr(pVM->pStack);
96 if ( strcmp(cp, tag) )
97 {
98 vmTextOut(pVM, "Warning -- unmatched control word: ", 0);
99 vmTextOut(pVM, tag, 1);
100 }
101
102 return;
103}
104
105/*
106** Expect a branch target address on the param stack,
107** compile a literal offset from the current dict location
108** to the target address
109*/
110static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
111{
112 long offset;
113 CELL *patchAddr;
114
115 matchControlTag(pVM, tag);
116
117 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
118 offset = patchAddr - dp->here;
119 dictAppendCell(dp, LVALUEtoCELL(offset));
120
121 return;
122}
123
124
125/*
126** Expect a branch patch address on the param stack,
127** compile a literal offset from the patch location
128** to the current dict location
129*/
130static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
131{
132 long offset;
133 CELL *patchAddr;
134
135 matchControlTag(pVM, tag);
136
137 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
138 offset = dp->here - patchAddr;
139 *patchAddr = LVALUEtoCELL(offset);
140
141 return;
142}
143
144/*
145** Match the tag to the top of the stack. If success,
146** sopy "here" address into the cell whose address is next
147** on the stack. Used by do..leave..loop.
148*/
149static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
150{
151 CELL *patchAddr;
152 char *cp;
153
154 cp = stackPopPtr(pVM->pStack);
155 if (strcmp(cp, tag))
156 {
157 vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
158 vmTextOut(pVM, tag, 1);
159 }
160
161 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
162 *patchAddr = LVALUEtoCELL(dp->here);
163
164 return;
165}
166
167
168/**************************************************************************
169 i s N u m b e r
170** Attempts to convert the NULL terminated string in the VM's pad to
171** a number using the VM's current base. If successful, pushes the number
172** onto the param stack and returns TRUE. Otherwise, returns FALSE.
173**************************************************************************/
174
175static int isNumber(FICL_VM *pVM, STRINGINFO si)
176{
177 INT32 accum = 0;
178 char isNeg = FALSE;
179 unsigned base = pVM->base;
180 char *cp = SI_PTR(si);
181 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
182 unsigned ch;
183 unsigned digit;
184
185 if (*cp == '-')
186 {
187 cp++;
188 count--;
189 isNeg = TRUE;
190 }
191 else if ((cp[0] == '0') && (cp[1] == 'x'))
192 { /* detect 0xNNNN format for hex numbers */
193 cp += 2;
194 count -= 2;
195 base = 16;
196 }
197
198 if (count == 0)
199 return FALSE;
200
201 while (count-- && ((ch = *cp++) != '\0'))
202 {
203 if (ch < '0')
204 return FALSE;
205
206 digit = ch - '0';
207
208 if (digit > 9)
209 digit = tolower(ch) - 'a' + 10;
210 /*
211 ** Note: following test also catches chars between 9 and a
212 ** because 'digit' is unsigned!
213 */
214 if (digit >= base)
215 return FALSE;
216
217 accum = accum * base + digit;
218 }
219
220 if (isNeg)
221 accum = -accum;
222
223 stackPushINT32(pVM->pStack, accum);
224
225 return TRUE;
226}
227
228
229/**************************************************************************
230 a d d & f r i e n d s
231**
232**************************************************************************/
233
234static void add(FICL_VM *pVM)
235{
236 INT32 i;
237#if FICL_ROBUST > 1
238 vmCheckStack(pVM, 2, 1);
239#endif
240 i = stackPopINT32(pVM->pStack);
241 i += stackGetTop(pVM->pStack).i;
242 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
243 return;
244}
245
246static void sub(FICL_VM *pVM)
247{
248 INT32 i;
249#if FICL_ROBUST > 1
250 vmCheckStack(pVM, 2, 1);
251#endif
252 i = stackPopINT32(pVM->pStack);
253 i = stackGetTop(pVM->pStack).i - i;
254 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
255 return;
256}
257
258static void mul(FICL_VM *pVM)
259{
260 INT32 i;
261#if FICL_ROBUST > 1
262 vmCheckStack(pVM, 2, 1);
263#endif
264 i = stackPopINT32(pVM->pStack);
265 i *= stackGetTop(pVM->pStack).i;
266 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
267 return;
268}
269
270static void negate(FICL_VM *pVM)
271{
272 INT32 i;
273#if FICL_ROBUST > 1
274 vmCheckStack(pVM, 1, 1);
275#endif
276 i = -stackPopINT32(pVM->pStack);
277 stackPushINT32(pVM->pStack, i);
278 return;
279}
280
281static void ficlDiv(FICL_VM *pVM)
282{
283 INT32 i;
284#if FICL_ROBUST > 1
285 vmCheckStack(pVM, 2, 1);
286#endif
287 i = stackPopINT32(pVM->pStack);
288 i = stackGetTop(pVM->pStack).i / i;
289 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
290 return;
291}
292
293/*
294** slash-mod CORE ( n1 n2 -- n3 n4 )
295** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
296** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
297** differ in sign, the implementation-defined result returned will be the
298** same as that returned by either the phrase
299** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
300** NOTE: Ficl complies with the second phrase (symmetric division)
301*/
302static void slashMod(FICL_VM *pVM)
303{
304 INT64 n1;
305 INT32 n2;
306 INTQR qr;
307
308#if FICL_ROBUST > 1
309 vmCheckStack(pVM, 2, 2);
310#endif
311 n2 = stackPopINT32(pVM->pStack);
312 n1.lo = stackPopINT32(pVM->pStack);
313 i64Extend(n1);
314
315 qr = m64SymmetricDivI(n1, n2);
316 stackPushINT32(pVM->pStack, qr.rem);
317 stackPushINT32(pVM->pStack, qr.quot);
318 return;
319}
320
321static void onePlus(FICL_VM *pVM)
322{
323 INT32 i;
324#if FICL_ROBUST > 1
325 vmCheckStack(pVM, 1, 1);
326#endif
327 i = stackGetTop(pVM->pStack).i;
328 i += 1;
329 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
330 return;
331}
332
333static void oneMinus(FICL_VM *pVM)
334{
335 INT32 i;
336#if FICL_ROBUST > 1
337 vmCheckStack(pVM, 1, 1);
338#endif
339 i = stackGetTop(pVM->pStack).i;
340 i -= 1;
341 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
342 return;
343}
344
345static void twoMul(FICL_VM *pVM)
346{
347 INT32 i;
348#if FICL_ROBUST > 1
349 vmCheckStack(pVM, 1, 1);
350#endif
351 i = stackGetTop(pVM->pStack).i;
352 i *= 2;
353 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
354 return;
355}
356
357static void twoDiv(FICL_VM *pVM)
358{
359 INT32 i;
360#if FICL_ROBUST > 1
361 vmCheckStack(pVM, 1, 1);
362#endif
363 i = stackGetTop(pVM->pStack).i;
364 i >>= 1;
365 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
366 return;
367}
368
369static void mulDiv(FICL_VM *pVM)
370{
371 INT32 x, y, z;
372 INT64 prod;
373#if FICL_ROBUST > 1
374 vmCheckStack(pVM, 3, 1);
375#endif
376 z = stackPopINT32(pVM->pStack);
377 y = stackPopINT32(pVM->pStack);
378 x = stackPopINT32(pVM->pStack);
379
380 prod = m64MulI(x,y);
381 x = m64SymmetricDivI(prod, z).quot;
382
383 stackPushINT32(pVM->pStack, x);
384 return;
385}
386
387
388static void mulDivRem(FICL_VM *pVM)
389{
390 INT32 x, y, z;
391 INT64 prod;
392 INTQR qr;
393#if FICL_ROBUST > 1
394 vmCheckStack(pVM, 3, 2);
395#endif
396 z = stackPopINT32(pVM->pStack);
397 y = stackPopINT32(pVM->pStack);
398 x = stackPopINT32(pVM->pStack);
399
400 prod = m64MulI(x,y);
401 qr = m64SymmetricDivI(prod, z);
402
403 stackPushINT32(pVM->pStack, qr.rem);
404 stackPushINT32(pVM->pStack, qr.quot);
405 return;
406}
407
408
409/**************************************************************************
410 b y e
411** TOOLS
412** Signal the system to shut down - this causes ficlExec to return
413** VM_USEREXIT. The rest is up to you.
414**************************************************************************/
415
416static void bye(FICL_VM *pVM)
417{
418 vmThrow(pVM, VM_USEREXIT);
419 return;
420}
421
422
423/**************************************************************************
424 c o l o n d e f i n i t i o n s
425** Code to begin compiling a colon definition
426** This function sets the state to COMPILE, then creates a
427** new word whose name is the next word in the input stream
428** and whose code is colonParen.
429**************************************************************************/
430
431static void colon(FICL_VM *pVM)
432{
433 FICL_DICT *dp = ficlGetDict();
434 STRINGINFO si = vmGetWord(pVM);
435
436 pVM->state = COMPILE;
437 markControlTag(pVM, colonTag);
438 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
439#if FICL_WANT_LOCALS
440 nLocals = 0;
441#endif
442 return;
443}
444
445
446/**************************************************************************
447 c o l o n P a r e n
448** This is the code that executes a colon definition. It assumes that the
449** virtual machine is running a "next" loop (See the vm.c
450** for its implementation of member function vmExecute()). The colon
451** code simply copies the address of the first word in the list of words
452** to interpret into IP after saving its old value. When we return to the
453** "next" loop, the virtual machine will call the code for each word in
454** turn.
455**
456**************************************************************************/
457
458static void colonParen(FICL_VM *pVM)
459{
460 IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
461 vmPushIP(pVM, tempIP);
462
463 return;
464}
465
466
467/**************************************************************************
468 s e m i c o l o n C o I m
469**
470** IMMEDIATE code for ";". This function sets the state to INTERPRET and
471** terminates a word under compilation by appending code for "(;)" to
472** the definition. TO DO: checks for leftover branch target tags on the
473** return stack and complains if any are found.
474**************************************************************************/
475static void semiParen(FICL_VM *pVM)
476{
477 vmPopIP(pVM);
478 return;
479}
480
481
482static void semicolonCoIm(FICL_VM *pVM)
483{
484 FICL_DICT *dp = ficlGetDict();
485
486 assert(pSemiParen);
487 matchControlTag(pVM, colonTag);
488
489#if FICL_WANT_LOCALS
490 assert(pUnLinkParen);
491 if (nLocals > 0)
492 {
493 FICL_DICT *pLoc = ficlGetLoc();
494 dictEmpty(pLoc, pLoc->pForthWords->size);
495 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
496 }
497 nLocals = 0;
498#endif
499
500 dictAppendCell(dp, LVALUEtoCELL(pSemiParen));
501 pVM->state = INTERPRET;
502 dictUnsmudge(dp);
503 return;
504}
505
506
507/**************************************************************************
508 e x i t
509** CORE
510** This function simply pops the previous instruction
511** pointer and returns to the "next" loop. Used for exiting from within
512** a definition. Note that exitParen is identical to semiParen - they
513** are in two different functions so that "see" can correctly identify
514** the end of a colon definition, even if it uses "exit".
515**************************************************************************/
516static void exitParen(FICL_VM *pVM)
517{
518 vmPopIP(pVM);
519 return;
520}
521
522static void exitCoIm(FICL_VM *pVM)
523{
524 FICL_DICT *dp = ficlGetDict();
525 assert(pExitParen);
526 IGNORE(pVM);
527
528#if FICL_WANT_LOCALS
529 if (nLocals > 0)
530 {
531 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
532 }
533#endif
534 dictAppendCell(dp, LVALUEtoCELL(pExitParen));
535 return;
536}
537
538
539/**************************************************************************
540 c o n s t a n t P a r e n
541** This is the run-time code for "constant". It simply returns the
542** contents of its word's first data cell.
543**
544**************************************************************************/
545
546void constantParen(FICL_VM *pVM)
547{
548 FICL_WORD *pFW = pVM->runningWord;
549#if FICL_ROBUST > 1
550 vmCheckStack(pVM, 0, 1);
551#endif
552 stackPush(pVM->pStack, pFW->param[0]);
553 return;
554}
555
556void twoConstParen(FICL_VM *pVM)
557{
558 FICL_WORD *pFW = pVM->runningWord;
559#if FICL_ROBUST > 1
560 vmCheckStack(pVM, 0, 2);
561#endif
562 stackPush(pVM->pStack, pFW->param[0]); /* lo */
563 stackPush(pVM->pStack, pFW->param[1]); /* hi */
564 return;
565}
566
567
568/**************************************************************************
569 c o n s t a n t
570** IMMEDIATE
571** Compiles a constant into the dictionary. Constants return their
572** value when invoked. Expects a value on top of the parm stack.
573**************************************************************************/
574
575static void constant(FICL_VM *pVM)
576{
577 FICL_DICT *dp = ficlGetDict();
578 STRINGINFO si = vmGetWord(pVM);
579
580#if FICL_ROBUST > 1
581 vmCheckStack(pVM, 1, 0);
582#endif
583 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
584 dictAppendCell(dp, stackPop(pVM->pStack));
585 return;
586}
587
588
589static void twoConstant(FICL_VM *pVM)
590{
591 FICL_DICT *dp = ficlGetDict();
592 STRINGINFO si = vmGetWord(pVM);
593 CELL c;
594
595#if FICL_ROBUST > 1
596 vmCheckStack(pVM, 2, 0);
597#endif
598 c = stackPop(pVM->pStack);
599 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
600 dictAppendCell(dp, stackPop(pVM->pStack));
601 dictAppendCell(dp, c);
602 return;
603}
604
605
606/**************************************************************************
607 d i s p l a y C e l l
608** Drop and print the contents of the cell at the top of the param
609** stack
610**************************************************************************/
611
612static void displayCell(FICL_VM *pVM)
613{
614 CELL c;
615#if FICL_ROBUST > 1
616 vmCheckStack(pVM, 1, 0);
617#endif
618 c = stackPop(pVM->pStack);
619 ltoa((c).i, pVM->pad, pVM->base);
620 strcat(pVM->pad, " ");
621 vmTextOut(pVM, pVM->pad, 0);
622 return;
623}
624
625static void displayCellNoPad(FICL_VM *pVM)
626{
627 CELL c;
628#if FICL_ROBUST > 1
629 vmCheckStack(pVM, 1, 0);
630#endif
631 c = stackPop(pVM->pStack);
632 ltoa((c).i, pVM->pad, pVM->base);
633 vmTextOut(pVM, pVM->pad, 0);
634 return;
635}
636
637static void uDot(FICL_VM *pVM)
638{
639 UNS32 u;
640#if FICL_ROBUST > 1
641 vmCheckStack(pVM, 1, 0);
642#endif
643 u = stackPopUNS32(pVM->pStack);
644 ultoa(u, pVM->pad, pVM->base);
645 strcat(pVM->pad, " ");
646 vmTextOut(pVM, pVM->pad, 0);
647 return;
648}
649
650
651static void hexDot(FICL_VM *pVM)
652{
653 UNS32 u;
654#if FICL_ROBUST > 1
655 vmCheckStack(pVM, 1, 0);
656#endif
657 u = stackPopUNS32(pVM->pStack);
658 ultoa(u, pVM->pad, 16);
659 strcat(pVM->pad, " ");
660 vmTextOut(pVM, pVM->pad, 0);
661 return;
662}
663
664
665/**************************************************************************
666 d i s p l a y S t a c k
667** Display the parameter stack (code for ".s")
668**************************************************************************/
669
670static void displayStack(FICL_VM *pVM)
671{
672 int d = stackDepth(pVM->pStack);
673 int i;
674 CELL *pCell;
675
676 vmCheckStack(pVM, 0, 0);
677
678 if (d == 0)
679 vmTextOut(pVM, "(Stack Empty)", 1);
680 else
681 {
682 pCell = pVM->pStack->sp;
683 for (i = 0; i < d; i++)
684 {
685 vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1);
686 }
687 }
688}
689
690
691/**************************************************************************
692 d u p & f r i e n d s
693**
694**************************************************************************/
695
696static void depth(FICL_VM *pVM)
697{
698 int i;
699#if FICL_ROBUST > 1
700 vmCheckStack(pVM, 0, 1);
701#endif
702 i = stackDepth(pVM->pStack);
703 stackPushINT32(pVM->pStack, i);
704 return;
705}
706
707
708static void drop(FICL_VM *pVM)
709{
710#if FICL_ROBUST > 1
711 vmCheckStack(pVM, 1, 0);
712#endif
713 stackDrop(pVM->pStack, 1);
714 return;
715}
716
717
718static void twoDrop(FICL_VM *pVM)
719{
720#if FICL_ROBUST > 1
721 vmCheckStack(pVM, 2, 0);
722#endif
723 stackDrop(pVM->pStack, 2);
724 return;
725}
726
727
728static void dup(FICL_VM *pVM)
729{
730#if FICL_ROBUST > 1
731 vmCheckStack(pVM, 1, 2);
732#endif
733 stackPick(pVM->pStack, 0);
734 return;
735}
736
737
738static void twoDup(FICL_VM *pVM)
739{
740#if FICL_ROBUST > 1
741 vmCheckStack(pVM, 2, 4);
742#endif
743 stackPick(pVM->pStack, 1);
744 stackPick(pVM->pStack, 1);
745 return;
746}
747
748
749static void over(FICL_VM *pVM)
750{
751#if FICL_ROBUST > 1
752 vmCheckStack(pVM, 2, 3);
753#endif
754 stackPick(pVM->pStack, 1);
755 return;
756}
757
758static void twoOver(FICL_VM *pVM)
759{
760#if FICL_ROBUST > 1
761 vmCheckStack(pVM, 4, 6);
762#endif
763 stackPick(pVM->pStack, 3);
764 stackPick(pVM->pStack, 3);
765 return;
766}
767
768
769static void pick(FICL_VM *pVM)
770{
771 CELL c = stackPop(pVM->pStack);
772#if FICL_ROBUST > 1
773 vmCheckStack(pVM, c.i+1, c.i+2);
774#endif
775 stackPick(pVM->pStack, c.i);
776 return;
777}
778
779
780static void questionDup(FICL_VM *pVM)
781{
782 CELL c;
783#if FICL_ROBUST > 1
784 vmCheckStack(pVM, 1, 2);
785#endif
786 c = stackGetTop(pVM->pStack);
787
788 if (c.i != 0)
789 stackPick(pVM->pStack, 0);
790
791 return;
792}
793
794
795static void roll(FICL_VM *pVM)
796{
797 int i = stackPop(pVM->pStack).i;
798 i = (i > 0) ? i : 0;
799#if FICL_ROBUST > 1
800 vmCheckStack(pVM, i+1, i+1);
801#endif
802 stackRoll(pVM->pStack, i);
803 return;
804}
805
806
807static void minusRoll(FICL_VM *pVM)
808{
809 int i = stackPop(pVM->pStack).i;
810 i = (i > 0) ? i : 0;
811#if FICL_ROBUST > 1
812 vmCheckStack(pVM, i+1, i+1);
813#endif
814 stackRoll(pVM->pStack, -i);
815 return;
816}
817
818
819static void rot(FICL_VM *pVM)
820{
821#if FICL_ROBUST > 1
822 vmCheckStack(pVM, 3, 3);
823#endif
824 stackRoll(pVM->pStack, 2);
825 return;
826}
827
828
829static void swap(FICL_VM *pVM)
830{
831#if FICL_ROBUST > 1
832 vmCheckStack(pVM, 2, 2);
833#endif
834 stackRoll(pVM->pStack, 1);
835 return;
836}
837
838
839static void twoSwap(FICL_VM *pVM)
840{
841#if FICL_ROBUST > 1
842 vmCheckStack(pVM, 4, 4);
843#endif
844 stackRoll(pVM->pStack, 3);
845 stackRoll(pVM->pStack, 3);
846 return;
847}
848
849
850/**************************************************************************
851 e m i t & f r i e n d s
852**
853**************************************************************************/
854
855static void emit(FICL_VM *pVM)
856{
857 char *cp = pVM->pad;
858 int i;
859
860#if FICL_ROBUST > 1
861 vmCheckStack(pVM, 1, 0);
862#endif
863 i = stackPopINT32(pVM->pStack);
864 cp[0] = (char)i;
865 cp[1] = '\0';
866 vmTextOut(pVM, cp, 0);
867 return;
868}
869
870
871static void cr(FICL_VM *pVM)
872{
873 vmTextOut(pVM, "", 1);
874 return;
875}
876
877
878static void commentLine(FICL_VM *pVM)
879{
880 char *cp = vmGetInBuf(pVM);
881 char ch = *cp;
882
883 while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n'))
884 {
885 ch = *++cp;
886 }
887
888 /*
889 ** Cope with DOS or UNIX-style EOLs -
890 ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
891 ** and point cp to next char. If EOL is \0, we're done.
892 */
893 if ((pVM->tib.end != cp) && (ch != '\0'))
894 {
895 cp++;
896
897 if ( (pVM->tib.end != cp) && (ch != *cp)
898 && ((*cp == '\r') || (*cp == '\n')) )
899 cp++;
900 }
901
902 vmUpdateTib(pVM, cp);
903 return;
904}
905
906
907/*
908** paren CORE
909** Compilation: Perform the execution semantics given below.
910** Execution: ( "ccc<paren>" -- )
911** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
912** The number of characters in ccc may be zero to the number of characters
913** in the parse area.
914**
915*/
916static void commentHang(FICL_VM *pVM)
917{
918 vmParseString(pVM, ')');
919 return;
920}
921
922
923/**************************************************************************
924 F E T C H & S T O R E
925**
926**************************************************************************/
927
928static void fetch(FICL_VM *pVM)
929{
930 CELL *pCell;
931#if FICL_ROBUST > 1
932 vmCheckStack(pVM, 1, 1);
933#endif
934 pCell = (CELL *)stackPopPtr(pVM->pStack);
935 stackPush(pVM->pStack, *pCell);
936 return;
937}
938
939/*
940** two-fetch CORE ( a-addr -- x1 x2 )
941** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
942** x1 at the next consecutive cell. It is equivalent to the sequence
943** DUP CELL+ @ SWAP @ .
944*/
945static void twoFetch(FICL_VM *pVM)
946{
947 CELL *pCell;
948#if FICL_ROBUST > 1
949 vmCheckStack(pVM, 1, 2);
950#endif
951 pCell = (CELL *)stackPopPtr(pVM->pStack);
952 stackPush(pVM->pStack, *pCell++);
953 stackPush(pVM->pStack, *pCell);
954 swap(pVM);
955 return;
956}
957
958/*
959** store CORE ( x a-addr -- )
960** Store x at a-addr.
961*/
962static void store(FICL_VM *pVM)
963{
964 CELL *pCell;
965#if FICL_ROBUST > 1
966 vmCheckStack(pVM, 2, 0);
967#endif
968 pCell = (CELL *)stackPopPtr(pVM->pStack);
969 *pCell = stackPop(pVM->pStack);
970}
971
972/*
973** two-store CORE ( x1 x2 a-addr -- )
974** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
975** next consecutive cell. It is equivalent to the sequence
976** SWAP OVER ! CELL+ ! .
977*/
978static void twoStore(FICL_VM *pVM)
979{
980 CELL *pCell;
981#if FICL_ROBUST > 1
982 vmCheckStack(pVM, 3, 0);
983#endif
984 pCell = (CELL *)stackPopPtr(pVM->pStack);
985 *pCell++ = stackPop(pVM->pStack);
986 *pCell = stackPop(pVM->pStack);
987}
988
989static void plusStore(FICL_VM *pVM)
990{
991 CELL *pCell;
992#if FICL_ROBUST > 1
993 vmCheckStack(pVM, 2, 0);
994#endif
995 pCell = (CELL *)stackPopPtr(pVM->pStack);
996 pCell->i += stackPop(pVM->pStack).i;
997}
998
999
1000static void wFetch(FICL_VM *pVM)
1001{
1002 UNS16 *pw;
1003#if FICL_ROBUST > 1
1004 vmCheckStack(pVM, 1, 1);
1005#endif
1006 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1007 stackPushUNS32(pVM->pStack, (UNS32)*pw);
1008 return;
1009}
1010
1011static void wStore(FICL_VM *pVM)
1012{
1013 UNS16 *pw;
1014#if FICL_ROBUST > 1
1015 vmCheckStack(pVM, 2, 0);
1016#endif
1017 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1018 *pw = (UNS16)(stackPop(pVM->pStack).u);
1019}
1020
1021static void cFetch(FICL_VM *pVM)
1022{
1023 UNS8 *pc;
1024#if FICL_ROBUST > 1
1025 vmCheckStack(pVM, 1, 1);
1026#endif
1027 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1028 stackPushUNS32(pVM->pStack, (UNS32)*pc);
1029 return;
1030}
1031
1032static void cStore(FICL_VM *pVM)
1033{
1034 UNS8 *pc;
1035#if FICL_ROBUST > 1
1036 vmCheckStack(pVM, 2, 0);
1037#endif
1038 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1039 *pc = (UNS8)(stackPop(pVM->pStack).u);
1040}
1041
1042
1043/**************************************************************************
1044 i f C o I m
1045** IMMEDIATE
1046** Compiles code for a conditional branch into the dictionary
1047** and pushes the branch patch address on the stack for later
1048** patching by ELSE or THEN/ENDIF.
1049**************************************************************************/
1050
1051static void ifCoIm(FICL_VM *pVM)
1052{
1053 FICL_DICT *dp = ficlGetDict();
1054
1055 assert(pIfParen);
1056
1057 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
1058 markBranch(dp, pVM, ifTag);
1059 dictAppendUNS32(dp, 1);
1060 return;
1061}
1062
1063
1064/**************************************************************************
1065 i f P a r e n
1066** Runtime code to do "if" or "until": pop a flag from the stack,
1067** fall through if true, branch if false. Probably ought to be
1068** called (not?branch) since it does "branch if false".
1069**************************************************************************/
1070
|
| 1071#ifdef FICL_TRACE
1072void ifParen(FICL_VM *pVM)
1073#else
|
1071static void ifParen(FICL_VM *pVM)
| 1074static void ifParen(FICL_VM *pVM)
|
| 1075#endif
|
1072{
1073 UNS32 flag;
1074
1075#if FICL_ROBUST > 1
1076 vmCheckStack(pVM, 1, 0);
1077#endif
1078 flag = stackPopUNS32(pVM->pStack);
1079
1080 if (flag)
1081 { /* fall through */
1082 vmBranchRelative(pVM, 1);
1083 }
1084 else
1085 { /* take branch (to else/endif/begin) */
1086 vmBranchRelative(pVM, (int)(*pVM->ip));
1087 }
1088
1089 return;
1090}
1091
1092
1093/**************************************************************************
1094 e l s e C o I m
1095**
1096** IMMEDIATE -- compiles an "else"...
1097** 1) Compile a branch and a patch address; the address gets patched
1098** by "endif" to point past the "else" code.
1099** 2) Pop the the "if" patch address
1100** 3) Patch the "if" branch to point to the current compile address.
1101** 4) Push the "else" patch address. ("endif" patches this to jump past
1102** the "else" code.
1103**************************************************************************/
1104
1105static void elseCoIm(FICL_VM *pVM)
1106{
1107 CELL *patchAddr;
1108 int offset;
1109 FICL_DICT *dp = ficlGetDict();
1110
1111 assert(pBranchParen);
1112 /* (1) compile branch runtime */
1113 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
1114 matchControlTag(pVM, ifTag);
1115 patchAddr =
1116 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1117 markBranch(dp, pVM, ifTag); /* (4) push "else" patch addr */
1118 dictAppendUNS32(dp, 1); /* (1) compile patch placeholder */
1119 offset = dp->here - patchAddr;
1120 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1121
1122 return;
1123}
1124
1125
1126/**************************************************************************
1127 b r a n c h P a r e n
1128**
1129** Runtime for "(branch)" -- expects a literal offset in the next
1130** compilation address, and branches to that location.
1131**************************************************************************/
1132
| 1076{
1077 UNS32 flag;
1078
1079#if FICL_ROBUST > 1
1080 vmCheckStack(pVM, 1, 0);
1081#endif
1082 flag = stackPopUNS32(pVM->pStack);
1083
1084 if (flag)
1085 { /* fall through */
1086 vmBranchRelative(pVM, 1);
1087 }
1088 else
1089 { /* take branch (to else/endif/begin) */
1090 vmBranchRelative(pVM, (int)(*pVM->ip));
1091 }
1092
1093 return;
1094}
1095
1096
1097/**************************************************************************
1098 e l s e C o I m
1099**
1100** IMMEDIATE -- compiles an "else"...
1101** 1) Compile a branch and a patch address; the address gets patched
1102** by "endif" to point past the "else" code.
1103** 2) Pop the the "if" patch address
1104** 3) Patch the "if" branch to point to the current compile address.
1105** 4) Push the "else" patch address. ("endif" patches this to jump past
1106** the "else" code.
1107**************************************************************************/
1108
1109static void elseCoIm(FICL_VM *pVM)
1110{
1111 CELL *patchAddr;
1112 int offset;
1113 FICL_DICT *dp = ficlGetDict();
1114
1115 assert(pBranchParen);
1116 /* (1) compile branch runtime */
1117 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
1118 matchControlTag(pVM, ifTag);
1119 patchAddr =
1120 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1121 markBranch(dp, pVM, ifTag); /* (4) push "else" patch addr */
1122 dictAppendUNS32(dp, 1); /* (1) compile patch placeholder */
1123 offset = dp->here - patchAddr;
1124 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1125
1126 return;
1127}
1128
1129
1130/**************************************************************************
1131 b r a n c h P a r e n
1132**
1133** Runtime for "(branch)" -- expects a literal offset in the next
1134** compilation address, and branches to that location.
1135**************************************************************************/
1136
|
| 1137#ifdef FICL_TRACE
1138void branchParen(FICL_VM *pVM)
1139#else
|
1133static void branchParen(FICL_VM *pVM)
| 1140static void branchParen(FICL_VM *pVM)
|
| 1141#endif
|
1134{
1135 vmBranchRelative(pVM, *(int *)(pVM->ip));
1136 return;
1137}
1138
1139
1140/**************************************************************************
1141 e n d i f C o I m
1142**
1143**************************************************************************/
1144
1145static void endifCoIm(FICL_VM *pVM)
1146{
1147 FICL_DICT *dp = ficlGetDict();
1148 resolveForwardBranch(dp, pVM, ifTag);
1149 return;
1150}
1151
1152
1153/**************************************************************************
1154 i n t e r p r e t
1155** This is the "user interface" of a Forth. It does the following:
1156** while there are words in the VM's Text Input Buffer
1157** Copy next word into the pad (vmGetWord)
1158** Attempt to find the word in the dictionary (dictLookup)
1159** If successful, execute the word.
1160** Otherwise, attempt to convert the word to a number (isNumber)
1161** If successful, push the number onto the parameter stack.
1162** Otherwise, print an error message and exit loop...
1163** End Loop
1164**
1165** From the standard, section 3.4
1166** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1167** repeat the following steps until either the parse area is empty or an
1168** ambiguous condition exists:
1169** a) Skip leading spaces and parse a name (see 3.4.1);
1170**************************************************************************/
1171
1172static void interpret(FICL_VM *pVM)
1173{
1174 STRINGINFO si = vmGetWord0(pVM);
1175 assert(pVM);
1176
1177 vmBranchRelative(pVM, -1);
1178
1179 /*
1180 // Get next word...if out of text, we're done.
1181 */
1182 if (si.count == 0)
1183 vmThrow(pVM, VM_OUTOFTEXT);
1184
1185 interpWord(pVM, si);
1186
1187 return; /* back to inner interpreter */
1188}
1189
1190/**************************************************************************
1191** From the standard, section 3.4
1192** b) Search the dictionary name space (see 3.4.2). If a definition name
1193** matching the string is found:
1194** 1.if interpreting, perform the interpretation semantics of the definition
1195** (see 3.4.3.2), and continue at a);
1196** 2.if compiling, perform the compilation semantics of the definition
1197** (see 3.4.3.3), and continue at a).
1198**
1199** c) If a definition name matching the string is not found, attempt to
1200** convert the string to a number (see 3.4.1.3). If successful:
1201** 1.if interpreting, place the number on the data stack, and continue at a);
1202** 2.if compiling, compile code that when executed will place the number on
1203** the stack (see 6.1.1780 LITERAL), and continue at a);
1204**
1205** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1206**************************************************************************/
1207static void interpWord(FICL_VM *pVM, STRINGINFO si)
1208{
1209 FICL_DICT *dp = ficlGetDict();
1210 FICL_WORD *tempFW;
1211
1212#if FICL_ROBUST
1213 dictCheck(dp, pVM, 0);
1214 vmCheckStack(pVM, 0, 0);
1215#endif
1216
1217#if FICL_WANT_LOCALS
1218 if (nLocals > 0)
1219 {
1220 tempFW = dictLookupLoc(dp, si);
1221 }
1222 else
1223#endif
1224 tempFW = dictLookup(dp, si);
1225
1226 if (pVM->state == INTERPRET)
1227 {
1228 if (tempFW != NULL)
1229 {
1230 if (wordIsCompileOnly(tempFW))
1231 {
1232 vmThrowErr(pVM, "Error: Compile only!");
1233 }
1234 vmExecute(pVM, tempFW);
1235 }
1236
1237 else if (!isNumber(pVM, si))
1238 {
1239 int i = SI_COUNT(si);
1240 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1241 }
1242 }
1243
1244 else /* (pVM->state == COMPILE) */
1245 {
1246 if (tempFW != NULL)
1247 {
1248 if (wordIsImmediate(tempFW))
1249 {
1250 vmExecute(pVM, tempFW);
1251 }
1252 else
1253 {
1254 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1255 }
1256 }
1257 else if (isNumber(pVM, si))
1258 {
1259 literalIm(pVM);
1260 }
1261 else
1262 {
1263 int i = SI_COUNT(si);
1264 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1265 }
1266 }
1267
1268 return;
1269}
1270
1271
1272/**************************************************************************
1273 l i t e r a l P a r e n
1274**
1275** This is the runtime for (literal). It assumes that it is part of a colon
1276** definition, and that the next CELL contains a value to be pushed on the
1277** parameter stack at runtime. This code is compiled by "literal".
1278**
1279**************************************************************************/
| 1142{
1143 vmBranchRelative(pVM, *(int *)(pVM->ip));
1144 return;
1145}
1146
1147
1148/**************************************************************************
1149 e n d i f C o I m
1150**
1151**************************************************************************/
1152
1153static void endifCoIm(FICL_VM *pVM)
1154{
1155 FICL_DICT *dp = ficlGetDict();
1156 resolveForwardBranch(dp, pVM, ifTag);
1157 return;
1158}
1159
1160
1161/**************************************************************************
1162 i n t e r p r e t
1163** This is the "user interface" of a Forth. It does the following:
1164** while there are words in the VM's Text Input Buffer
1165** Copy next word into the pad (vmGetWord)
1166** Attempt to find the word in the dictionary (dictLookup)
1167** If successful, execute the word.
1168** Otherwise, attempt to convert the word to a number (isNumber)
1169** If successful, push the number onto the parameter stack.
1170** Otherwise, print an error message and exit loop...
1171** End Loop
1172**
1173** From the standard, section 3.4
1174** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1175** repeat the following steps until either the parse area is empty or an
1176** ambiguous condition exists:
1177** a) Skip leading spaces and parse a name (see 3.4.1);
1178**************************************************************************/
1179
1180static void interpret(FICL_VM *pVM)
1181{
1182 STRINGINFO si = vmGetWord0(pVM);
1183 assert(pVM);
1184
1185 vmBranchRelative(pVM, -1);
1186
1187 /*
1188 // Get next word...if out of text, we're done.
1189 */
1190 if (si.count == 0)
1191 vmThrow(pVM, VM_OUTOFTEXT);
1192
1193 interpWord(pVM, si);
1194
1195 return; /* back to inner interpreter */
1196}
1197
1198/**************************************************************************
1199** From the standard, section 3.4
1200** b) Search the dictionary name space (see 3.4.2). If a definition name
1201** matching the string is found:
1202** 1.if interpreting, perform the interpretation semantics of the definition
1203** (see 3.4.3.2), and continue at a);
1204** 2.if compiling, perform the compilation semantics of the definition
1205** (see 3.4.3.3), and continue at a).
1206**
1207** c) If a definition name matching the string is not found, attempt to
1208** convert the string to a number (see 3.4.1.3). If successful:
1209** 1.if interpreting, place the number on the data stack, and continue at a);
1210** 2.if compiling, compile code that when executed will place the number on
1211** the stack (see 6.1.1780 LITERAL), and continue at a);
1212**
1213** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1214**************************************************************************/
1215static void interpWord(FICL_VM *pVM, STRINGINFO si)
1216{
1217 FICL_DICT *dp = ficlGetDict();
1218 FICL_WORD *tempFW;
1219
1220#if FICL_ROBUST
1221 dictCheck(dp, pVM, 0);
1222 vmCheckStack(pVM, 0, 0);
1223#endif
1224
1225#if FICL_WANT_LOCALS
1226 if (nLocals > 0)
1227 {
1228 tempFW = dictLookupLoc(dp, si);
1229 }
1230 else
1231#endif
1232 tempFW = dictLookup(dp, si);
1233
1234 if (pVM->state == INTERPRET)
1235 {
1236 if (tempFW != NULL)
1237 {
1238 if (wordIsCompileOnly(tempFW))
1239 {
1240 vmThrowErr(pVM, "Error: Compile only!");
1241 }
1242 vmExecute(pVM, tempFW);
1243 }
1244
1245 else if (!isNumber(pVM, si))
1246 {
1247 int i = SI_COUNT(si);
1248 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1249 }
1250 }
1251
1252 else /* (pVM->state == COMPILE) */
1253 {
1254 if (tempFW != NULL)
1255 {
1256 if (wordIsImmediate(tempFW))
1257 {
1258 vmExecute(pVM, tempFW);
1259 }
1260 else
1261 {
1262 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1263 }
1264 }
1265 else if (isNumber(pVM, si))
1266 {
1267 literalIm(pVM);
1268 }
1269 else
1270 {
1271 int i = SI_COUNT(si);
1272 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1273 }
1274 }
1275
1276 return;
1277}
1278
1279
1280/**************************************************************************
1281 l i t e r a l P a r e n
1282**
1283** This is the runtime for (literal). It assumes that it is part of a colon
1284** definition, and that the next CELL contains a value to be pushed on the
1285** parameter stack at runtime. This code is compiled by "literal".
1286**
1287**************************************************************************/
|
1280
| 1288#ifdef FICL_TRACE
1289void literalParen(FICL_VM *pVM)
1290#else
|
1281static void literalParen(FICL_VM *pVM)
| 1291static void literalParen(FICL_VM *pVM)
|
| 1292#endif
|
1282{
1283#if FICL_ROBUST > 1
1284 vmCheckStack(pVM, 0, 1);
1285#endif
1286 stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip));
1287 vmBranchRelative(pVM, 1);
1288 return;
1289}
1290
1291
1292/**************************************************************************
1293 l i t e r a l I m
1294**
1295** IMMEDIATE code for "literal". This function gets a value from the stack
1296** and compiles it into the dictionary preceded by the code for "(literal)".
1297** IMMEDIATE
1298**************************************************************************/
1299
1300static void literalIm(FICL_VM *pVM)
1301{
1302 FICL_DICT *dp = ficlGetDict();
1303 assert(pLitParen);
1304
1305 dictAppendCell(dp, LVALUEtoCELL(pLitParen));
1306 dictAppendCell(dp, stackPop(pVM->pStack));
1307
1308 return;
1309}
1310
1311
1312/**************************************************************************
1313 l i s t W o r d s
1314**
1315**************************************************************************/
1316#define nCOLWIDTH 8
1317static void listWords(FICL_VM *pVM)
1318{
1319 FICL_DICT *dp = ficlGetDict();
1320 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
1321 FICL_WORD *wp;
1322 int nChars = 0;
1323 int len;
1324 int y = 0;
1325 unsigned i;
1326 int nWords = 0;
1327 char *cp;
1328 char *pPad = pVM->pad;
1329
1330 for (i = 0; i < pHash->size; i++)
1331 {
1332 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
1333 {
1334 if (wp->nName == 0) /* ignore :noname defs */
1335 continue;
1336
1337 cp = wp->name;
1338 nChars += sprintf(pPad + nChars, "%s", cp);
1339
1340 if (nChars > 70)
1341 {
1342 pPad[nChars] = '\0';
1343 nChars = 0;
1344 y++;
1345 if(y>23) {
1346 y=0;
1347 vmTextOut(pVM, "--- Press Enter to continue ---",0);
1348 getchar();
1349 vmTextOut(pVM,"\r",0);
1350 }
1351 vmTextOut(pVM, pPad, 1);
1352 }
1353 else
1354 {
1355 len = nCOLWIDTH - nChars % nCOLWIDTH;
1356 while (len-- > 0)
1357 pPad[nChars++] = ' ';
1358 }
1359
1360 if (nChars > 70)
1361 {
1362 pPad[nChars] = '\0';
1363 nChars = 0;
1364 y++;
1365 if(y>23) {
1366 y=0;
1367 vmTextOut(pVM, "--- Press Enter to continue ---",0);
1368 getchar();
1369 vmTextOut(pVM,"\r",0);
1370 }
1371 vmTextOut(pVM, pPad, 1);
1372 }
1373 }
1374 }
1375
1376 if (nChars > 0)
1377 {
1378 pPad[nChars] = '\0';
1379 nChars = 0;
1380 vmTextOut(pVM, pPad, 1);
1381 }
1382
1383 sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %lu total",
1384 nWords, dp->here - dp->dict, dp->size);
1385 vmTextOut(pVM, pVM->pad, 1);
1386 return;
1387}
1388
1389
1390static void listEnv(FICL_VM *pVM)
1391{
1392 FICL_DICT *dp = ficlGetEnv();
1393 FICL_HASH *pHash = dp->pForthWords;
1394 FICL_WORD *wp;
1395 unsigned i;
1396 int nWords = 0;
1397
1398 for (i = 0; i < pHash->size; i++)
1399 {
1400 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
1401 {
1402 vmTextOut(pVM, wp->name, 1);
1403 }
1404 }
1405
1406 sprintf(pVM->pad, "Environment: %d words, %ld cells used of %lu total",
1407 nWords, dp->here - dp->dict, dp->size);
1408 vmTextOut(pVM, pVM->pad, 1);
1409 return;
1410}
1411
1412
1413/**************************************************************************
1414 l o g i c a n d c o m p a r i s o n s
1415**
1416**************************************************************************/
1417
1418static void zeroEquals(FICL_VM *pVM)
1419{
1420 CELL c;
1421#if FICL_ROBUST > 1
1422 vmCheckStack(pVM, 1, 1);
1423#endif
1424 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) == 0);
1425 stackPush(pVM->pStack, c);
1426 return;
1427}
1428
1429static void zeroLess(FICL_VM *pVM)
1430{
1431 CELL c;
1432#if FICL_ROBUST > 1
1433 vmCheckStack(pVM, 1, 1);
1434#endif
1435 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) < 0);
1436 stackPush(pVM->pStack, c);
1437 return;
1438}
1439
1440static void zeroGreater(FICL_VM *pVM)
1441{
1442 CELL c;
1443#if FICL_ROBUST > 1
1444 vmCheckStack(pVM, 1, 1);
1445#endif
1446 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) > 0);
1447 stackPush(pVM->pStack, c);
1448 return;
1449}
1450
1451static void isEqual(FICL_VM *pVM)
1452{
1453 CELL x, y;
1454
1455#if FICL_ROBUST > 1
1456 vmCheckStack(pVM, 2, 1);
1457#endif
1458 x = stackPop(pVM->pStack);
1459 y = stackPop(pVM->pStack);
1460 stackPushINT32(pVM->pStack, FICL_BOOL(x.i == y.i));
1461 return;
1462}
1463
1464static void isLess(FICL_VM *pVM)
1465{
1466 CELL x, y;
1467#if FICL_ROBUST > 1
1468 vmCheckStack(pVM, 2, 1);
1469#endif
1470 y = stackPop(pVM->pStack);
1471 x = stackPop(pVM->pStack);
1472 stackPushINT32(pVM->pStack, FICL_BOOL(x.i < y.i));
1473 return;
1474}
1475
1476static void uIsLess(FICL_VM *pVM)
1477{
1478 UNS32 u1, u2;
1479#if FICL_ROBUST > 1
1480 vmCheckStack(pVM, 2, 1);
1481#endif
1482 u2 = stackPopUNS32(pVM->pStack);
1483 u1 = stackPopUNS32(pVM->pStack);
1484 stackPushINT32(pVM->pStack, FICL_BOOL(u1 < u2));
1485 return;
1486}
1487
1488static void isGreater(FICL_VM *pVM)
1489{
1490 CELL x, y;
1491#if FICL_ROBUST > 1
1492 vmCheckStack(pVM, 2, 1);
1493#endif
1494 y = stackPop(pVM->pStack);
1495 x = stackPop(pVM->pStack);
1496 stackPushINT32(pVM->pStack, FICL_BOOL(x.i > y.i));
1497 return;
1498}
1499
1500static void bitwiseAnd(FICL_VM *pVM)
1501{
1502 CELL x, y;
1503#if FICL_ROBUST > 1
1504 vmCheckStack(pVM, 2, 1);
1505#endif
1506 x = stackPop(pVM->pStack);
1507 y = stackPop(pVM->pStack);
1508 stackPushINT32(pVM->pStack, x.i & y.i);
1509 return;
1510}
1511
1512static void bitwiseOr(FICL_VM *pVM)
1513{
1514 CELL x, y;
1515#if FICL_ROBUST > 1
1516 vmCheckStack(pVM, 2, 1);
1517#endif
1518 x = stackPop(pVM->pStack);
1519 y = stackPop(pVM->pStack);
1520 stackPushINT32(pVM->pStack, x.i | y.i);
1521 return;
1522}
1523
1524static void bitwiseXor(FICL_VM *pVM)
1525{
1526 CELL x, y;
1527#if FICL_ROBUST > 1
1528 vmCheckStack(pVM, 2, 1);
1529#endif
1530 x = stackPop(pVM->pStack);
1531 y = stackPop(pVM->pStack);
1532 stackPushINT32(pVM->pStack, x.i ^ y.i);
1533 return;
1534}
1535
1536static void bitwiseNot(FICL_VM *pVM)
1537{
1538 CELL x;
1539#if FICL_ROBUST > 1
1540 vmCheckStack(pVM, 1, 1);
1541#endif
1542 x = stackPop(pVM->pStack);
1543 stackPushINT32(pVM->pStack, ~x.i);
1544 return;
1545}
1546
1547
1548/**************************************************************************
1549 D o / L o o p
1550** do -- IMMEDIATE COMPILE ONLY
1551** Compiles code to initialize a loop: compile (do),
1552** allot space to hold the "leave" address, push a branch
1553** target address for the loop.
1554** (do) -- runtime for "do"
1555** pops index and limit from the p stack and moves them
1556** to the r stack, then skips to the loop body.
1557** loop -- IMMEDIATE COMPILE ONLY
1558** +loop
1559** Compiles code for the test part of a loop:
1560** compile (loop), resolve forward branch from "do", and
1561** copy "here" address to the "leave" address allotted by "do"
1562** i,j,k -- COMPILE ONLY
1563** Runtime: Push loop indices on param stack (i is innermost loop...)
1564** Note: each loop has three values on the return stack:
1565** ( R: leave limit index )
1566** "leave" is the absolute address of the next cell after the loop
1567** limit and index are the loop control variables.
1568** leave -- COMPILE ONLY
1569** Runtime: pop the loop control variables, then pop the
1570** "leave" address and jump (absolute) there.
1571**************************************************************************/
1572
1573static void doCoIm(FICL_VM *pVM)
1574{
1575 FICL_DICT *dp = ficlGetDict();
1576
1577 assert(pDoParen);
1578
1579 dictAppendCell(dp, LVALUEtoCELL(pDoParen));
1580 /*
1581 ** Allot space for a pointer to the end
1582 ** of the loop - "leave" uses this...
1583 */
1584 markBranch(dp, pVM, leaveTag);
1585 dictAppendUNS32(dp, 0);
1586 /*
1587 ** Mark location of head of loop...
1588 */
1589 markBranch(dp, pVM, doTag);
1590
1591 return;
1592}
1593
| 1293{
1294#if FICL_ROBUST > 1
1295 vmCheckStack(pVM, 0, 1);
1296#endif
1297 stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip));
1298 vmBranchRelative(pVM, 1);
1299 return;
1300}
1301
1302
1303/**************************************************************************
1304 l i t e r a l I m
1305**
1306** IMMEDIATE code for "literal". This function gets a value from the stack
1307** and compiles it into the dictionary preceded by the code for "(literal)".
1308** IMMEDIATE
1309**************************************************************************/
1310
1311static void literalIm(FICL_VM *pVM)
1312{
1313 FICL_DICT *dp = ficlGetDict();
1314 assert(pLitParen);
1315
1316 dictAppendCell(dp, LVALUEtoCELL(pLitParen));
1317 dictAppendCell(dp, stackPop(pVM->pStack));
1318
1319 return;
1320}
1321
1322
1323/**************************************************************************
1324 l i s t W o r d s
1325**
1326**************************************************************************/
1327#define nCOLWIDTH 8
1328static void listWords(FICL_VM *pVM)
1329{
1330 FICL_DICT *dp = ficlGetDict();
1331 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
1332 FICL_WORD *wp;
1333 int nChars = 0;
1334 int len;
1335 int y = 0;
1336 unsigned i;
1337 int nWords = 0;
1338 char *cp;
1339 char *pPad = pVM->pad;
1340
1341 for (i = 0; i < pHash->size; i++)
1342 {
1343 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
1344 {
1345 if (wp->nName == 0) /* ignore :noname defs */
1346 continue;
1347
1348 cp = wp->name;
1349 nChars += sprintf(pPad + nChars, "%s", cp);
1350
1351 if (nChars > 70)
1352 {
1353 pPad[nChars] = '\0';
1354 nChars = 0;
1355 y++;
1356 if(y>23) {
1357 y=0;
1358 vmTextOut(pVM, "--- Press Enter to continue ---",0);
1359 getchar();
1360 vmTextOut(pVM,"\r",0);
1361 }
1362 vmTextOut(pVM, pPad, 1);
1363 }
1364 else
1365 {
1366 len = nCOLWIDTH - nChars % nCOLWIDTH;
1367 while (len-- > 0)
1368 pPad[nChars++] = ' ';
1369 }
1370
1371 if (nChars > 70)
1372 {
1373 pPad[nChars] = '\0';
1374 nChars = 0;
1375 y++;
1376 if(y>23) {
1377 y=0;
1378 vmTextOut(pVM, "--- Press Enter to continue ---",0);
1379 getchar();
1380 vmTextOut(pVM,"\r",0);
1381 }
1382 vmTextOut(pVM, pPad, 1);
1383 }
1384 }
1385 }
1386
1387 if (nChars > 0)
1388 {
1389 pPad[nChars] = '\0';
1390 nChars = 0;
1391 vmTextOut(pVM, pPad, 1);
1392 }
1393
1394 sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %lu total",
1395 nWords, dp->here - dp->dict, dp->size);
1396 vmTextOut(pVM, pVM->pad, 1);
1397 return;
1398}
1399
1400
1401static void listEnv(FICL_VM *pVM)
1402{
1403 FICL_DICT *dp = ficlGetEnv();
1404 FICL_HASH *pHash = dp->pForthWords;
1405 FICL_WORD *wp;
1406 unsigned i;
1407 int nWords = 0;
1408
1409 for (i = 0; i < pHash->size; i++)
1410 {
1411 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
1412 {
1413 vmTextOut(pVM, wp->name, 1);
1414 }
1415 }
1416
1417 sprintf(pVM->pad, "Environment: %d words, %ld cells used of %lu total",
1418 nWords, dp->here - dp->dict, dp->size);
1419 vmTextOut(pVM, pVM->pad, 1);
1420 return;
1421}
1422
1423
1424/**************************************************************************
1425 l o g i c a n d c o m p a r i s o n s
1426**
1427**************************************************************************/
1428
1429static void zeroEquals(FICL_VM *pVM)
1430{
1431 CELL c;
1432#if FICL_ROBUST > 1
1433 vmCheckStack(pVM, 1, 1);
1434#endif
1435 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) == 0);
1436 stackPush(pVM->pStack, c);
1437 return;
1438}
1439
1440static void zeroLess(FICL_VM *pVM)
1441{
1442 CELL c;
1443#if FICL_ROBUST > 1
1444 vmCheckStack(pVM, 1, 1);
1445#endif
1446 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) < 0);
1447 stackPush(pVM->pStack, c);
1448 return;
1449}
1450
1451static void zeroGreater(FICL_VM *pVM)
1452{
1453 CELL c;
1454#if FICL_ROBUST > 1
1455 vmCheckStack(pVM, 1, 1);
1456#endif
1457 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) > 0);
1458 stackPush(pVM->pStack, c);
1459 return;
1460}
1461
1462static void isEqual(FICL_VM *pVM)
1463{
1464 CELL x, y;
1465
1466#if FICL_ROBUST > 1
1467 vmCheckStack(pVM, 2, 1);
1468#endif
1469 x = stackPop(pVM->pStack);
1470 y = stackPop(pVM->pStack);
1471 stackPushINT32(pVM->pStack, FICL_BOOL(x.i == y.i));
1472 return;
1473}
1474
1475static void isLess(FICL_VM *pVM)
1476{
1477 CELL x, y;
1478#if FICL_ROBUST > 1
1479 vmCheckStack(pVM, 2, 1);
1480#endif
1481 y = stackPop(pVM->pStack);
1482 x = stackPop(pVM->pStack);
1483 stackPushINT32(pVM->pStack, FICL_BOOL(x.i < y.i));
1484 return;
1485}
1486
1487static void uIsLess(FICL_VM *pVM)
1488{
1489 UNS32 u1, u2;
1490#if FICL_ROBUST > 1
1491 vmCheckStack(pVM, 2, 1);
1492#endif
1493 u2 = stackPopUNS32(pVM->pStack);
1494 u1 = stackPopUNS32(pVM->pStack);
1495 stackPushINT32(pVM->pStack, FICL_BOOL(u1 < u2));
1496 return;
1497}
1498
1499static void isGreater(FICL_VM *pVM)
1500{
1501 CELL x, y;
1502#if FICL_ROBUST > 1
1503 vmCheckStack(pVM, 2, 1);
1504#endif
1505 y = stackPop(pVM->pStack);
1506 x = stackPop(pVM->pStack);
1507 stackPushINT32(pVM->pStack, FICL_BOOL(x.i > y.i));
1508 return;
1509}
1510
1511static void bitwiseAnd(FICL_VM *pVM)
1512{
1513 CELL x, y;
1514#if FICL_ROBUST > 1
1515 vmCheckStack(pVM, 2, 1);
1516#endif
1517 x = stackPop(pVM->pStack);
1518 y = stackPop(pVM->pStack);
1519 stackPushINT32(pVM->pStack, x.i & y.i);
1520 return;
1521}
1522
1523static void bitwiseOr(FICL_VM *pVM)
1524{
1525 CELL x, y;
1526#if FICL_ROBUST > 1
1527 vmCheckStack(pVM, 2, 1);
1528#endif
1529 x = stackPop(pVM->pStack);
1530 y = stackPop(pVM->pStack);
1531 stackPushINT32(pVM->pStack, x.i | y.i);
1532 return;
1533}
1534
1535static void bitwiseXor(FICL_VM *pVM)
1536{
1537 CELL x, y;
1538#if FICL_ROBUST > 1
1539 vmCheckStack(pVM, 2, 1);
1540#endif
1541 x = stackPop(pVM->pStack);
1542 y = stackPop(pVM->pStack);
1543 stackPushINT32(pVM->pStack, x.i ^ y.i);
1544 return;
1545}
1546
1547static void bitwiseNot(FICL_VM *pVM)
1548{
1549 CELL x;
1550#if FICL_ROBUST > 1
1551 vmCheckStack(pVM, 1, 1);
1552#endif
1553 x = stackPop(pVM->pStack);
1554 stackPushINT32(pVM->pStack, ~x.i);
1555 return;
1556}
1557
1558
1559/**************************************************************************
1560 D o / L o o p
1561** do -- IMMEDIATE COMPILE ONLY
1562** Compiles code to initialize a loop: compile (do),
1563** allot space to hold the "leave" address, push a branch
1564** target address for the loop.
1565** (do) -- runtime for "do"
1566** pops index and limit from the p stack and moves them
1567** to the r stack, then skips to the loop body.
1568** loop -- IMMEDIATE COMPILE ONLY
1569** +loop
1570** Compiles code for the test part of a loop:
1571** compile (loop), resolve forward branch from "do", and
1572** copy "here" address to the "leave" address allotted by "do"
1573** i,j,k -- COMPILE ONLY
1574** Runtime: Push loop indices on param stack (i is innermost loop...)
1575** Note: each loop has three values on the return stack:
1576** ( R: leave limit index )
1577** "leave" is the absolute address of the next cell after the loop
1578** limit and index are the loop control variables.
1579** leave -- COMPILE ONLY
1580** Runtime: pop the loop control variables, then pop the
1581** "leave" address and jump (absolute) there.
1582**************************************************************************/
1583
1584static void doCoIm(FICL_VM *pVM)
1585{
1586 FICL_DICT *dp = ficlGetDict();
1587
1588 assert(pDoParen);
1589
1590 dictAppendCell(dp, LVALUEtoCELL(pDoParen));
1591 /*
1592 ** Allot space for a pointer to the end
1593 ** of the loop - "leave" uses this...
1594 */
1595 markBranch(dp, pVM, leaveTag);
1596 dictAppendUNS32(dp, 0);
1597 /*
1598 ** Mark location of head of loop...
1599 */
1600 markBranch(dp, pVM, doTag);
1601
1602 return;
1603}
1604
|
1594
| 1605#ifdef FICL_TRACE
1606void doParen(FICL_VM *pVM)
1607#else
|
1595static void doParen(FICL_VM *pVM)
| 1608static void doParen(FICL_VM *pVM)
|
| 1609#endif
|
1596{
1597 CELL index, limit;
1598#if FICL_ROBUST > 1
1599 vmCheckStack(pVM, 2, 0);
1600#endif
1601 index = stackPop(pVM->pStack);
1602 limit = stackPop(pVM->pStack);
1603
1604 /* copy "leave" target addr to stack */
1605 stackPushPtr(pVM->rStack, *(pVM->ip++));
1606 stackPush(pVM->rStack, limit);
1607 stackPush(pVM->rStack, index);
1608
1609 return;
1610}
1611
1612
1613static void qDoCoIm(FICL_VM *pVM)
1614{
1615 FICL_DICT *dp = ficlGetDict();
1616
1617 assert(pQDoParen);
1618
1619 dictAppendCell(dp, LVALUEtoCELL(pQDoParen));
1620 /*
1621 ** Allot space for a pointer to the end
1622 ** of the loop - "leave" uses this...
1623 */
1624 markBranch(dp, pVM, leaveTag);
1625 dictAppendUNS32(dp, 0);
1626 /*
1627 ** Mark location of head of loop...
1628 */
1629 markBranch(dp, pVM, doTag);
1630
1631 return;
1632}
1633
| 1610{
1611 CELL index, limit;
1612#if FICL_ROBUST > 1
1613 vmCheckStack(pVM, 2, 0);
1614#endif
1615 index = stackPop(pVM->pStack);
1616 limit = stackPop(pVM->pStack);
1617
1618 /* copy "leave" target addr to stack */
1619 stackPushPtr(pVM->rStack, *(pVM->ip++));
1620 stackPush(pVM->rStack, limit);
1621 stackPush(pVM->rStack, index);
1622
1623 return;
1624}
1625
1626
1627static void qDoCoIm(FICL_VM *pVM)
1628{
1629 FICL_DICT *dp = ficlGetDict();
1630
1631 assert(pQDoParen);
1632
1633 dictAppendCell(dp, LVALUEtoCELL(pQDoParen));
1634 /*
1635 ** Allot space for a pointer to the end
1636 ** of the loop - "leave" uses this...
1637 */
1638 markBranch(dp, pVM, leaveTag);
1639 dictAppendUNS32(dp, 0);
1640 /*
1641 ** Mark location of head of loop...
1642 */
1643 markBranch(dp, pVM, doTag);
1644
1645 return;
1646}
1647
|
1634
| 1648#ifdef FICL_TRACE
1649void qDoParen(FICL_VM *pVM)
1650#else
|
1635static void qDoParen(FICL_VM *pVM)
| 1651static void qDoParen(FICL_VM *pVM)
|
| 1652#endif
|
1636{
1637 CELL index, limit;
1638#if FICL_ROBUST > 1
1639 vmCheckStack(pVM, 2, 0);
1640#endif
1641 index = stackPop(pVM->pStack);
1642 limit = stackPop(pVM->pStack);
1643
1644 /* copy "leave" target addr to stack */
1645 stackPushPtr(pVM->rStack, *(pVM->ip++));
1646
1647 if (limit.u == index.u)
1648 {
1649 vmPopIP(pVM);
1650 }
1651 else
1652 {
1653 stackPush(pVM->rStack, limit);
1654 stackPush(pVM->rStack, index);
1655 }
1656
1657 return;
1658}
1659
1660
1661/*
1662** Runtime code to break out of a do..loop construct
1663** Drop the loop control variables; the branch address
1664** past "loop" is next on the return stack.
1665*/
1666static void leaveCo(FICL_VM *pVM)
1667{
1668 /* almost unloop */
1669 stackDrop(pVM->rStack, 2);
1670 /* exit */
1671 vmPopIP(pVM);
1672 return;
1673}
1674
1675
1676static void unloopCo(FICL_VM *pVM)
1677{
1678 stackDrop(pVM->rStack, 3);
1679 return;
1680}
1681
1682
1683static void loopCoIm(FICL_VM *pVM)
1684{
1685 FICL_DICT *dp = ficlGetDict();
1686
1687 assert(pLoopParen);
1688
1689 dictAppendCell(dp, LVALUEtoCELL(pLoopParen));
1690 resolveBackBranch(dp, pVM, doTag);
1691 resolveAbsBranch(dp, pVM, leaveTag);
1692 return;
1693}
1694
1695
1696static void plusLoopCoIm(FICL_VM *pVM)
1697{
1698 FICL_DICT *dp = ficlGetDict();
1699
1700 assert(pPLoopParen);
1701
1702 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
1703 resolveBackBranch(dp, pVM, doTag);
1704 resolveAbsBranch(dp, pVM, leaveTag);
1705 return;
1706}
1707
| 1653{
1654 CELL index, limit;
1655#if FICL_ROBUST > 1
1656 vmCheckStack(pVM, 2, 0);
1657#endif
1658 index = stackPop(pVM->pStack);
1659 limit = stackPop(pVM->pStack);
1660
1661 /* copy "leave" target addr to stack */
1662 stackPushPtr(pVM->rStack, *(pVM->ip++));
1663
1664 if (limit.u == index.u)
1665 {
1666 vmPopIP(pVM);
1667 }
1668 else
1669 {
1670 stackPush(pVM->rStack, limit);
1671 stackPush(pVM->rStack, index);
1672 }
1673
1674 return;
1675}
1676
1677
1678/*
1679** Runtime code to break out of a do..loop construct
1680** Drop the loop control variables; the branch address
1681** past "loop" is next on the return stack.
1682*/
1683static void leaveCo(FICL_VM *pVM)
1684{
1685 /* almost unloop */
1686 stackDrop(pVM->rStack, 2);
1687 /* exit */
1688 vmPopIP(pVM);
1689 return;
1690}
1691
1692
1693static void unloopCo(FICL_VM *pVM)
1694{
1695 stackDrop(pVM->rStack, 3);
1696 return;
1697}
1698
1699
1700static void loopCoIm(FICL_VM *pVM)
1701{
1702 FICL_DICT *dp = ficlGetDict();
1703
1704 assert(pLoopParen);
1705
1706 dictAppendCell(dp, LVALUEtoCELL(pLoopParen));
1707 resolveBackBranch(dp, pVM, doTag);
1708 resolveAbsBranch(dp, pVM, leaveTag);
1709 return;
1710}
1711
1712
1713static void plusLoopCoIm(FICL_VM *pVM)
1714{
1715 FICL_DICT *dp = ficlGetDict();
1716
1717 assert(pPLoopParen);
1718
1719 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
1720 resolveBackBranch(dp, pVM, doTag);
1721 resolveAbsBranch(dp, pVM, leaveTag);
1722 return;
1723}
1724
|
1708
| 1725#ifdef FICL_TRACE
1726void loopParen(FICL_VM *pVM)
1727#else
|
1709static void loopParen(FICL_VM *pVM)
| 1728static void loopParen(FICL_VM *pVM)
|
| 1729#endif
|
1710{
1711 INT32 index = stackGetTop(pVM->rStack).i;
1712 INT32 limit = stackFetch(pVM->rStack, 1).i;
1713
1714 index++;
1715
1716 if (index >= limit)
1717 {
1718 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1719 vmBranchRelative(pVM, 1); /* fall through the loop */
1720 }
1721 else
1722 { /* update index, branch to loop head */
1723 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1724 vmBranchRelative(pVM, *(int *)(pVM->ip));
1725 }
1726
1727 return;
1728}
1729
| 1730{
1731 INT32 index = stackGetTop(pVM->rStack).i;
1732 INT32 limit = stackFetch(pVM->rStack, 1).i;
1733
1734 index++;
1735
1736 if (index >= limit)
1737 {
1738 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1739 vmBranchRelative(pVM, 1); /* fall through the loop */
1740 }
1741 else
1742 { /* update index, branch to loop head */
1743 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1744 vmBranchRelative(pVM, *(int *)(pVM->ip));
1745 }
1746
1747 return;
1748}
1749
|
1730
| 1750#ifdef FICL_TRACE
1751void plusLoopParen(FICL_VM *pVM)
1752#else
|
1731static void plusLoopParen(FICL_VM *pVM)
| 1753static void plusLoopParen(FICL_VM *pVM)
|
| 1754#endif
|
1732{
1733 INT32 index = stackGetTop(pVM->rStack).i;
1734 INT32 limit = stackFetch(pVM->rStack, 1).i;
1735 INT32 increment = stackPop(pVM->pStack).i;
1736 int flag;
1737
1738 index += increment;
1739
1740 if (increment < 0)
1741 flag = (index < limit);
1742 else
1743 flag = (index >= limit);
1744
1745 if (flag)
1746 {
1747 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1748 vmBranchRelative(pVM, 1); /* fall through the loop */
1749 }
1750 else
1751 { /* update index, branch to loop head */
1752 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1753 vmBranchRelative(pVM, *(int *)(pVM->ip));
1754 }
1755
1756 return;
1757}
1758
1759
1760static void loopICo(FICL_VM *pVM)
1761{
1762 CELL index = stackGetTop(pVM->rStack);
1763 stackPush(pVM->pStack, index);
1764
1765 return;
1766}
1767
1768
1769static void loopJCo(FICL_VM *pVM)
1770{
1771 CELL index = stackFetch(pVM->rStack, 3);
1772 stackPush(pVM->pStack, index);
1773
1774 return;
1775}
1776
1777
1778static void loopKCo(FICL_VM *pVM)
1779{
1780 CELL index = stackFetch(pVM->rStack, 6);
1781 stackPush(pVM->pStack, index);
1782
1783 return;
1784}
1785
1786
1787/**************************************************************************
1788 r e t u r n s t a c k
1789**
1790**************************************************************************/
1791
1792static void toRStack(FICL_VM *pVM)
1793{
1794 stackPush(pVM->rStack, stackPop(pVM->pStack));
1795 return;
1796}
1797
1798static void fromRStack(FICL_VM *pVM)
1799{
1800 stackPush(pVM->pStack, stackPop(pVM->rStack));
1801 return;
1802}
1803
1804static void fetchRStack(FICL_VM *pVM)
1805{
1806 stackPush(pVM->pStack, stackGetTop(pVM->rStack));
1807 return;
1808}
1809
1810
1811/**************************************************************************
1812 v a r i a b l e
1813**
1814**************************************************************************/
1815
1816static void variableParen(FICL_VM *pVM)
1817{
1818 FICL_WORD *fw = pVM->runningWord;
1819 stackPushPtr(pVM->pStack, fw->param);
1820 return;
1821}
1822
1823
1824static void variable(FICL_VM *pVM)
1825{
1826 FICL_DICT *dp = ficlGetDict();
1827 STRINGINFO si = vmGetWord(pVM);
1828
1829 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
1830 dictAllotCells(dp, 1);
1831 return;
1832}
1833
1834
1835
1836/**************************************************************************
1837 b a s e & f r i e n d s
1838**
1839**************************************************************************/
1840
1841static void base(FICL_VM *pVM)
1842{
1843 CELL *pBase = (CELL *)(&pVM->base);
1844 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
1845 return;
1846}
1847
1848
1849static void decimal(FICL_VM *pVM)
1850{
1851 pVM->base = 10;
1852 return;
1853}
1854
1855
1856static void hex(FICL_VM *pVM)
1857{
1858 pVM->base = 16;
1859 return;
1860}
1861
1862
1863/**************************************************************************
1864 a l l o t & f r i e n d s
1865**
1866**************************************************************************/
1867
1868static void allot(FICL_VM *pVM)
1869{
1870 FICL_DICT *dp = ficlGetDict();
1871 INT32 i = stackPopINT32(pVM->pStack);
1872#if FICL_ROBUST
1873 dictCheck(dp, pVM, i);
1874#endif
1875 dictAllot(dp, i);
1876 return;
1877}
1878
1879
1880static void here(FICL_VM *pVM)
1881{
1882 FICL_DICT *dp = ficlGetDict();
1883 stackPushPtr(pVM->pStack, dp->here);
1884 return;
1885}
1886
1887
1888static void comma(FICL_VM *pVM)
1889{
1890 FICL_DICT *dp = ficlGetDict();
1891 CELL c = stackPop(pVM->pStack);
1892 dictAppendCell(dp, c);
1893 return;
1894}
1895
1896
1897static void cComma(FICL_VM *pVM)
1898{
1899 FICL_DICT *dp = ficlGetDict();
1900 char c = (char)stackPopINT32(pVM->pStack);
1901 dictAppendChar(dp, c);
1902 return;
1903}
1904
1905
1906static void cells(FICL_VM *pVM)
1907{
1908 INT32 i = stackPopINT32(pVM->pStack);
1909 stackPushINT32(pVM->pStack, i * (INT32)sizeof (CELL));
1910 return;
1911}
1912
1913
1914static void cellPlus(FICL_VM *pVM)
1915{
1916 char *cp = stackPopPtr(pVM->pStack);
1917 stackPushPtr(pVM->pStack, cp + sizeof (CELL));
1918 return;
1919}
1920
1921
1922/**************************************************************************
1923 t i c k
1924** tick CORE ( "<spaces>name" -- xt )
1925** Skip leading space delimiters. Parse name delimited by a space. Find
1926** name and return xt, the execution token for name. An ambiguous condition
1927** exists if name is not found.
1928**************************************************************************/
1929static void tick(FICL_VM *pVM)
1930{
1931 FICL_WORD *pFW = NULL;
1932 STRINGINFO si = vmGetWord(pVM);
1933
1934 pFW = dictLookup(ficlGetDict(), si);
1935 if (!pFW)
1936 {
1937 int i = SI_COUNT(si);
1938 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1939 }
1940 stackPushPtr(pVM->pStack, pFW);
1941 return;
1942}
1943
1944
1945static void bracketTickCoIm(FICL_VM *pVM)
1946{
1947 tick(pVM);
1948 literalIm(pVM);
1949
1950 return;
1951}
1952
1953
1954/**************************************************************************
1955 p o s t p o n e
1956** Lookup the next word in the input stream and compile code to
1957** insert it into definitions created by the resulting word
1958** (defers compilation, even of immediate words)
1959**************************************************************************/
1960
1961static void postponeCoIm(FICL_VM *pVM)
1962{
1963 FICL_DICT *dp = ficlGetDict();
1964 FICL_WORD *pFW;
1965 assert(pComma);
1966
1967 tick(pVM);
1968 pFW = stackGetTop(pVM->pStack).p;
1969 if (wordIsImmediate(pFW))
1970 {
1971 dictAppendCell(dp, stackPop(pVM->pStack));
1972 }
1973 else
1974 {
1975 literalIm(pVM);
1976 dictAppendCell(dp, LVALUEtoCELL(pComma));
1977 }
1978
1979 return;
1980}
1981
1982
1983
1984/**************************************************************************
1985 e x e c u t e
1986** Pop an execution token (pointer to a word) off the stack and
1987** run it
1988**************************************************************************/
1989
1990static void execute(FICL_VM *pVM)
1991{
1992 FICL_WORD *pFW;
1993#if FICL_ROBUST > 1
1994 vmCheckStack(pVM, 1, 0);
1995#endif
1996
1997 pFW = stackPopPtr(pVM->pStack);
1998 vmExecute(pVM, pFW);
1999
2000 return;
2001}
2002
2003
2004/**************************************************************************
2005 i m m e d i a t e
2006** Make the most recently compiled word IMMEDIATE -- it executes even
2007** in compile state (most often used for control compiling words
2008** such as IF, THEN, etc)
2009**************************************************************************/
2010
2011static void immediate(FICL_VM *pVM)
2012{
2013 IGNORE(pVM);
2014 dictSetImmediate(ficlGetDict());
2015 return;
2016}
2017
2018
2019static void compileOnly(FICL_VM *pVM)
2020{
2021 IGNORE(pVM);
2022 dictSetFlags(ficlGetDict(), FW_COMPILE, 0);
2023 return;
2024}
2025
2026
2027/**************************************************************************
2028 d o t Q u o t e
2029** IMMEDIATE word that compiles a string literal for later display
2030** Compile stringLit, then copy the bytes of the string from the TIB
2031** to the dictionary. Backpatch the count byte and align the dictionary.
2032**
2033** stringlit: Fetch the count from the dictionary, then push the address
2034** and count on the stack. Finally, update ip to point to the first
2035** aligned address after the string text.
2036**************************************************************************/
| 1755{
1756 INT32 index = stackGetTop(pVM->rStack).i;
1757 INT32 limit = stackFetch(pVM->rStack, 1).i;
1758 INT32 increment = stackPop(pVM->pStack).i;
1759 int flag;
1760
1761 index += increment;
1762
1763 if (increment < 0)
1764 flag = (index < limit);
1765 else
1766 flag = (index >= limit);
1767
1768 if (flag)
1769 {
1770 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1771 vmBranchRelative(pVM, 1); /* fall through the loop */
1772 }
1773 else
1774 { /* update index, branch to loop head */
1775 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1776 vmBranchRelative(pVM, *(int *)(pVM->ip));
1777 }
1778
1779 return;
1780}
1781
1782
1783static void loopICo(FICL_VM *pVM)
1784{
1785 CELL index = stackGetTop(pVM->rStack);
1786 stackPush(pVM->pStack, index);
1787
1788 return;
1789}
1790
1791
1792static void loopJCo(FICL_VM *pVM)
1793{
1794 CELL index = stackFetch(pVM->rStack, 3);
1795 stackPush(pVM->pStack, index);
1796
1797 return;
1798}
1799
1800
1801static void loopKCo(FICL_VM *pVM)
1802{
1803 CELL index = stackFetch(pVM->rStack, 6);
1804 stackPush(pVM->pStack, index);
1805
1806 return;
1807}
1808
1809
1810/**************************************************************************
1811 r e t u r n s t a c k
1812**
1813**************************************************************************/
1814
1815static void toRStack(FICL_VM *pVM)
1816{
1817 stackPush(pVM->rStack, stackPop(pVM->pStack));
1818 return;
1819}
1820
1821static void fromRStack(FICL_VM *pVM)
1822{
1823 stackPush(pVM->pStack, stackPop(pVM->rStack));
1824 return;
1825}
1826
1827static void fetchRStack(FICL_VM *pVM)
1828{
1829 stackPush(pVM->pStack, stackGetTop(pVM->rStack));
1830 return;
1831}
1832
1833
1834/**************************************************************************
1835 v a r i a b l e
1836**
1837**************************************************************************/
1838
1839static void variableParen(FICL_VM *pVM)
1840{
1841 FICL_WORD *fw = pVM->runningWord;
1842 stackPushPtr(pVM->pStack, fw->param);
1843 return;
1844}
1845
1846
1847static void variable(FICL_VM *pVM)
1848{
1849 FICL_DICT *dp = ficlGetDict();
1850 STRINGINFO si = vmGetWord(pVM);
1851
1852 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
1853 dictAllotCells(dp, 1);
1854 return;
1855}
1856
1857
1858
1859/**************************************************************************
1860 b a s e & f r i e n d s
1861**
1862**************************************************************************/
1863
1864static void base(FICL_VM *pVM)
1865{
1866 CELL *pBase = (CELL *)(&pVM->base);
1867 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
1868 return;
1869}
1870
1871
1872static void decimal(FICL_VM *pVM)
1873{
1874 pVM->base = 10;
1875 return;
1876}
1877
1878
1879static void hex(FICL_VM *pVM)
1880{
1881 pVM->base = 16;
1882 return;
1883}
1884
1885
1886/**************************************************************************
1887 a l l o t & f r i e n d s
1888**
1889**************************************************************************/
1890
1891static void allot(FICL_VM *pVM)
1892{
1893 FICL_DICT *dp = ficlGetDict();
1894 INT32 i = stackPopINT32(pVM->pStack);
1895#if FICL_ROBUST
1896 dictCheck(dp, pVM, i);
1897#endif
1898 dictAllot(dp, i);
1899 return;
1900}
1901
1902
1903static void here(FICL_VM *pVM)
1904{
1905 FICL_DICT *dp = ficlGetDict();
1906 stackPushPtr(pVM->pStack, dp->here);
1907 return;
1908}
1909
1910
1911static void comma(FICL_VM *pVM)
1912{
1913 FICL_DICT *dp = ficlGetDict();
1914 CELL c = stackPop(pVM->pStack);
1915 dictAppendCell(dp, c);
1916 return;
1917}
1918
1919
1920static void cComma(FICL_VM *pVM)
1921{
1922 FICL_DICT *dp = ficlGetDict();
1923 char c = (char)stackPopINT32(pVM->pStack);
1924 dictAppendChar(dp, c);
1925 return;
1926}
1927
1928
1929static void cells(FICL_VM *pVM)
1930{
1931 INT32 i = stackPopINT32(pVM->pStack);
1932 stackPushINT32(pVM->pStack, i * (INT32)sizeof (CELL));
1933 return;
1934}
1935
1936
1937static void cellPlus(FICL_VM *pVM)
1938{
1939 char *cp = stackPopPtr(pVM->pStack);
1940 stackPushPtr(pVM->pStack, cp + sizeof (CELL));
1941 return;
1942}
1943
1944
1945/**************************************************************************
1946 t i c k
1947** tick CORE ( "<spaces>name" -- xt )
1948** Skip leading space delimiters. Parse name delimited by a space. Find
1949** name and return xt, the execution token for name. An ambiguous condition
1950** exists if name is not found.
1951**************************************************************************/
1952static void tick(FICL_VM *pVM)
1953{
1954 FICL_WORD *pFW = NULL;
1955 STRINGINFO si = vmGetWord(pVM);
1956
1957 pFW = dictLookup(ficlGetDict(), si);
1958 if (!pFW)
1959 {
1960 int i = SI_COUNT(si);
1961 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1962 }
1963 stackPushPtr(pVM->pStack, pFW);
1964 return;
1965}
1966
1967
1968static void bracketTickCoIm(FICL_VM *pVM)
1969{
1970 tick(pVM);
1971 literalIm(pVM);
1972
1973 return;
1974}
1975
1976
1977/**************************************************************************
1978 p o s t p o n e
1979** Lookup the next word in the input stream and compile code to
1980** insert it into definitions created by the resulting word
1981** (defers compilation, even of immediate words)
1982**************************************************************************/
1983
1984static void postponeCoIm(FICL_VM *pVM)
1985{
1986 FICL_DICT *dp = ficlGetDict();
1987 FICL_WORD *pFW;
1988 assert(pComma);
1989
1990 tick(pVM);
1991 pFW = stackGetTop(pVM->pStack).p;
1992 if (wordIsImmediate(pFW))
1993 {
1994 dictAppendCell(dp, stackPop(pVM->pStack));
1995 }
1996 else
1997 {
1998 literalIm(pVM);
1999 dictAppendCell(dp, LVALUEtoCELL(pComma));
2000 }
2001
2002 return;
2003}
2004
2005
2006
2007/**************************************************************************
2008 e x e c u t e
2009** Pop an execution token (pointer to a word) off the stack and
2010** run it
2011**************************************************************************/
2012
2013static void execute(FICL_VM *pVM)
2014{
2015 FICL_WORD *pFW;
2016#if FICL_ROBUST > 1
2017 vmCheckStack(pVM, 1, 0);
2018#endif
2019
2020 pFW = stackPopPtr(pVM->pStack);
2021 vmExecute(pVM, pFW);
2022
2023 return;
2024}
2025
2026
2027/**************************************************************************
2028 i m m e d i a t e
2029** Make the most recently compiled word IMMEDIATE -- it executes even
2030** in compile state (most often used for control compiling words
2031** such as IF, THEN, etc)
2032**************************************************************************/
2033
2034static void immediate(FICL_VM *pVM)
2035{
2036 IGNORE(pVM);
2037 dictSetImmediate(ficlGetDict());
2038 return;
2039}
2040
2041
2042static void compileOnly(FICL_VM *pVM)
2043{
2044 IGNORE(pVM);
2045 dictSetFlags(ficlGetDict(), FW_COMPILE, 0);
2046 return;
2047}
2048
2049
2050/**************************************************************************
2051 d o t Q u o t e
2052** IMMEDIATE word that compiles a string literal for later display
2053** Compile stringLit, then copy the bytes of the string from the TIB
2054** to the dictionary. Backpatch the count byte and align the dictionary.
2055**
2056** stringlit: Fetch the count from the dictionary, then push the address
2057** and count on the stack. Finally, update ip to point to the first
2058** aligned address after the string text.
2059**************************************************************************/
|
2037
| 2060#ifdef FICL_TRACE
2061void stringLit(FICL_VM *pVM)
2062#else
|
2038static void stringLit(FICL_VM *pVM)
| 2063static void stringLit(FICL_VM *pVM)
|
| 2064#endif
|
2039{
2040 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2041 FICL_COUNT count = sp->count;
2042 char *cp = sp->text;
2043 stackPushPtr(pVM->pStack, cp);
2044 stackPushUNS32(pVM->pStack, count);
2045 cp += count + 1;
2046 cp = alignPtr(cp);
2047 pVM->ip = (IPTYPE)(void *)cp;
2048 return;
2049}
2050
2051static void dotQuoteCoIm(FICL_VM *pVM)
2052{
2053 FICL_DICT *dp = ficlGetDict();
2054 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2055 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2056 dictAlign(dp);
2057 dictAppendCell(dp, LVALUEtoCELL(pType));
2058 return;
2059}
2060
2061
2062static void dotParen(FICL_VM *pVM)
2063{
2064 char *pSrc = vmGetInBuf(pVM);
2065 char *pDest = pVM->pad;
2066 char ch;
2067
2068 pSrc = skipSpace(pSrc,pVM->tib.end);
2069
2070 for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc)
2071 *pDest++ = ch;
2072
2073 *pDest = '\0';
2074 if ((pVM->tib.end != pSrc) && (ch == ')'))
2075 pSrc++;
2076
2077 vmTextOut(pVM, pVM->pad, 0);
2078 vmUpdateTib(pVM, pSrc);
2079
2080 return;
2081}
2082
2083
2084/**************************************************************************
2085 s l i t e r a l
2086** STRING
2087** Interpretation: Interpretation semantics for this word are undefined.
2088** Compilation: ( c-addr1 u -- )
2089** Append the run-time semantics given below to the current definition.
2090** Run-time: ( -- c-addr2 u )
2091** Return c-addr2 u describing a string consisting of the characters
2092** specified by c-addr1 u during compilation. A program shall not alter
2093** the returned string.
2094**************************************************************************/
2095static void sLiteralCoIm(FICL_VM *pVM)
2096{
2097 FICL_DICT *dp = ficlGetDict();
2098 char *cp, *cpDest;
2099 UNS32 u;
2100 u = stackPopUNS32(pVM->pStack);
2101 cp = stackPopPtr(pVM->pStack);
2102
2103 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2104 cpDest = (char *) dp->here;
2105 *cpDest++ = (char) u;
2106
2107 for (; u > 0; --u)
2108 {
2109 *cpDest++ = *cp++;
2110 }
2111
2112 *cpDest++ = 0;
2113 dp->here = PTRtoCELL alignPtr(cpDest);
2114 return;
2115}
2116
2117
2118/**************************************************************************
2119 s t a t e
2120** Return the address of the VM's state member (must be sized the
2121** same as a CELL for this reason)
2122**************************************************************************/
2123static void state(FICL_VM *pVM)
2124{
2125 stackPushPtr(pVM->pStack, &pVM->state);
2126 return;
2127}
2128
2129
2130/**************************************************************************
2131 c r e a t e . . . d o e s >
2132** Make a new word in the dictionary with the run-time effect of
2133** a variable (push my address), but with extra space allotted
2134** for use by does> .
2135**************************************************************************/
2136
2137static void createParen(FICL_VM *pVM)
2138{
2139 CELL *pCell = pVM->runningWord->param;
2140 stackPushPtr(pVM->pStack, pCell+1);
2141 return;
2142}
2143
2144
2145static void create(FICL_VM *pVM)
2146{
2147 FICL_DICT *dp = ficlGetDict();
2148 STRINGINFO si = vmGetWord(pVM);
2149
2150 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2151 dictAllotCells(dp, 1);
2152 return;
2153}
2154
2155
2156static void doDoes(FICL_VM *pVM)
2157{
2158 CELL *pCell = pVM->runningWord->param;
2159 IPTYPE tempIP = (IPTYPE)((*pCell).p);
2160 stackPushPtr(pVM->pStack, pCell+1);
2161 vmPushIP(pVM, tempIP);
2162 return;
2163}
2164
2165
2166static void doesParen(FICL_VM *pVM)
2167{
2168 FICL_DICT *dp = ficlGetDict();
2169 dp->smudge->code = doDoes;
2170 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2171 vmPopIP(pVM);
2172 return;
2173}
2174
2175
2176static void doesCoIm(FICL_VM *pVM)
2177{
2178 FICL_DICT *dp = ficlGetDict();
2179#if FICL_WANT_LOCALS
2180 assert(pUnLinkParen);
2181 if (nLocals > 0)
2182 {
2183 FICL_DICT *pLoc = ficlGetLoc();
2184 dictEmpty(pLoc, pLoc->pForthWords->size);
2185 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
2186 }
2187
2188 nLocals = 0;
2189#endif
2190 IGNORE(pVM);
2191
2192 dictAppendCell(dp, LVALUEtoCELL(pDoesParen));
2193 return;
2194}
2195
2196
2197/**************************************************************************
2198 t o b o d y
2199** to-body CORE ( xt -- a-addr )
2200** a-addr is the data-field address corresponding to xt. An ambiguous
2201** condition exists if xt is not for a word defined via CREATE.
2202**************************************************************************/
2203static void toBody(FICL_VM *pVM)
2204{
2205 FICL_WORD *pFW = stackPopPtr(pVM->pStack);
2206 stackPushPtr(pVM->pStack, pFW->param + 1);
2207 return;
2208}
2209
2210
2211/*
2212** from-body ficl ( a-addr -- xt )
2213** Reverse effect of >body
2214*/
2215static void fromBody(FICL_VM *pVM)
2216{
2217 char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD);
2218 stackPushPtr(pVM->pStack, ptr);
2219 return;
2220}
2221
2222
2223/*
2224** >name ficl ( xt -- c-addr u )
2225** Push the address and length of a word's name given its address
2226** xt.
2227*/
2228static void toName(FICL_VM *pVM)
2229{
2230 FICL_WORD *pFW = stackPopPtr(pVM->pStack);
2231 stackPushPtr(pVM->pStack, pFW->name);
2232 stackPushUNS32(pVM->pStack, pFW->nName);
2233 return;
2234}
2235
2236
2237/**************************************************************************
2238 l b r a c k e t e t c
2239**
2240**************************************************************************/
2241
2242static void lbracketCoIm(FICL_VM *pVM)
2243{
2244 pVM->state = INTERPRET;
2245 return;
2246}
2247
2248
2249static void rbracket(FICL_VM *pVM)
2250{
2251 pVM->state = COMPILE;
2252 return;
2253}
2254
2255
2256/**************************************************************************
2257 p i c t u r e d n u m e r i c w o r d s
2258**
2259** less-number-sign CORE ( -- )
2260** Initialize the pictured numeric output conversion process.
2261** (clear the pad)
2262**************************************************************************/
2263static void lessNumberSign(FICL_VM *pVM)
2264{
2265 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2266 sp->count = 0;
2267 return;
2268}
2269
2270/*
2271** number-sign CORE ( ud1 -- ud2 )
2272** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2273** n. (n is the least-significant digit of ud1.) Convert n to external form
2274** and add the resulting character to the beginning of the pictured numeric
2275** output string. An ambiguous condition exists if # executes outside of a
2276** <# #> delimited number conversion.
2277*/
2278static void numberSign(FICL_VM *pVM)
2279{
2280 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2281 UNS64 u;
2282 UNS16 rem;
2283
2284 u = u64Pop(pVM->pStack);
2285 rem = m64UMod(&u, (UNS16)(pVM->base));
2286 sp->text[sp->count++] = digit_to_char(rem);
2287 u64Push(pVM->pStack, u);
2288 return;
2289}
2290
2291/*
2292** number-sign-greater CORE ( xd -- c-addr u )
2293** Drop xd. Make the pictured numeric output string available as a character
2294** string. c-addr and u specify the resulting character string. A program
2295** may replace characters within the string.
2296*/
2297static void numberSignGreater(FICL_VM *pVM)
2298{
2299 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2300 sp->text[sp->count] = '\0';
2301 strrev(sp->text);
2302 stackDrop(pVM->pStack, 2);
2303 stackPushPtr(pVM->pStack, sp->text);
2304 stackPushUNS32(pVM->pStack, sp->count);
2305 return;
2306}
2307
2308/*
2309** number-sign-s CORE ( ud1 -- ud2 )
2310** Convert one digit of ud1 according to the rule for #. Continue conversion
2311** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2312** #S executes outside of a <# #> delimited number conversion.
2313** TO DO: presently does not use ud1 hi cell - use it!
2314*/
2315static void numberSignS(FICL_VM *pVM)
2316{
2317 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2318 UNS64 u;
2319 UNS16 rem;
2320
2321 u = u64Pop(pVM->pStack);
2322
2323 do
2324 {
2325 rem = m64UMod(&u, (UNS16)(pVM->base));
2326 sp->text[sp->count++] = digit_to_char(rem);
2327 }
2328 while (u.hi || u.lo);
2329
2330 u64Push(pVM->pStack, u);
2331 return;
2332}
2333
2334/*
2335** HOLD CORE ( char -- )
2336** Add char to the beginning of the pictured numeric output string. An ambiguous
2337** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2338*/
2339static void hold(FICL_VM *pVM)
2340{
2341 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2342 int i = stackPopINT32(pVM->pStack);
2343 sp->text[sp->count++] = (char) i;
2344 return;
2345}
2346
2347/*
2348** SIGN CORE ( n -- )
2349** If n is negative, add a minus sign to the beginning of the pictured
2350** numeric output string. An ambiguous condition exists if SIGN
2351** executes outside of a <# #> delimited number conversion.
2352*/
2353static void sign(FICL_VM *pVM)
2354{
2355 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2356 int i = stackPopINT32(pVM->pStack);
2357 if (i < 0)
2358 sp->text[sp->count++] = '-';
2359 return;
2360}
2361
2362
2363/**************************************************************************
2364 t o N u m b e r
2365** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2366** ud2 is the unsigned result of converting the characters within the
2367** string specified by c-addr1 u1 into digits, using the number in BASE,
2368** and adding each into ud1 after multiplying ud1 by the number in BASE.
2369** Conversion continues left-to-right until a character that is not
2370** convertible, including any + or -, is encountered or the string is
2371** entirely converted. c-addr2 is the location of the first unconverted
2372** character or the first character past the end of the string if the string
2373** was entirely converted. u2 is the number of unconverted characters in the
2374** string. An ambiguous condition exists if ud2 overflows during the
2375** conversion.
2376** TO DO: presently does not use ud1 hi cell - use it!
2377**************************************************************************/
2378static void toNumber(FICL_VM *pVM)
2379{
2380 UNS32 count = stackPopUNS32(pVM->pStack);
2381 char *cp = (char *)stackPopPtr(pVM->pStack);
2382 UNS64 accum;
2383 UNS32 base = pVM->base;
2384 UNS32 ch;
2385 UNS32 digit;
2386
2387 accum = u64Pop(pVM->pStack);
2388
2389 for (ch = *cp; count > 0; ch = *++cp, count--)
2390 {
2391 if (ch < '0')
2392 break;
2393
2394 digit = ch - '0';
2395
2396 if (digit > 9)
2397 digit = tolower(ch) - 'a' + 10;
2398 /*
2399 ** Note: following test also catches chars between 9 and a
2400 ** because 'digit' is unsigned!
2401 */
2402 if (digit >= base)
2403 break;
2404
2405 accum = m64Mac(accum, base, digit);
2406 }
2407
2408 u64Push(pVM->pStack, accum);
2409 stackPushPtr (pVM->pStack, cp);
2410 stackPushUNS32(pVM->pStack, count);
2411
2412 return;
2413}
2414
2415
2416
2417/**************************************************************************
2418 q u i t & a b o r t
2419** quit CORE ( -- ) ( R: i*x -- )
2420** Empty the return stack, store zero in SOURCE-ID if it is present, make
2421** the user input device the input source, and enter interpretation state.
2422** Do not display a message. Repeat the following:
2423**
2424** Accept a line from the input source into the input buffer, set >IN to
2425** zero, and interpret.
2426** Display the implementation-defined system prompt if in
2427** interpretation state, all processing has been completed, and no
2428** ambiguous condition exists.
2429**************************************************************************/
2430
2431static void quit(FICL_VM *pVM)
2432{
2433 vmThrow(pVM, VM_QUIT);
2434 return;
2435}
2436
2437
2438static void ficlAbort(FICL_VM *pVM)
2439{
2440 vmThrow(pVM, VM_ABORT);
2441 return;
2442}
2443
2444
2445/**************************************************************************
2446 a c c e p t
2447** accept CORE ( c-addr +n1 -- +n2 )
2448** Receive a string of at most +n1 characters. An ambiguous condition
2449** exists if +n1 is zero or greater than 32,767. Display graphic characters
2450** as they are received. A program that depends on the presence or absence
2451** of non-graphic characters in the string has an environmental dependency.
2452** The editing functions, if any, that the system performs in order to
2453** construct the string are implementation-defined.
2454**
2455** (Although the standard text doesn't say so, I assume that the intent
2456** of 'accept' is to store the string at the address specified on
2457** the stack.)
2458** Implementation: if there's more text in the TIB, use it. Otherwise
2459** throw out for more text. Copy characters up to the max count into the
2460** address given, and return the number of actual characters copied.
2461**
2462** This may not strictly violate the standard, but I'm sure any programs
2463** asking for user input at load time will *not* be expecting this
2464** behavior. (sobral)
2465**************************************************************************/
2466static void accept(FICL_VM *pVM)
2467{
2468 UNS32 count, len;
2469 char *cp;
2470 char *pBuf = vmGetInBuf(pVM);
2471
2472 for (len = 0; pVM->tib.end != &pBuf[len] && pBuf[len]; len++);
2473 if (len == 0)
2474 vmThrow(pVM, VM_RESTART);
2475 /* OK - now we have something in the text buffer - use it */
2476 count = stackPopUNS32(pVM->pStack);
2477 cp = stackPopPtr(pVM->pStack);
2478
2479 strncpy(cp, vmGetInBuf(pVM), count);
2480 len = (count < len) ? count : len;
2481 pBuf += len;
2482 vmUpdateTib(pVM, pBuf);
2483 stackPushUNS32(pVM->pStack, len);
2484
2485 return;
2486}
2487
2488
2489/**************************************************************************
2490 a l i g n
2491** 6.1.0705 ALIGN CORE ( -- )
2492** If the data-space pointer is not aligned, reserve enough space to
2493** align it.
2494**************************************************************************/
2495static void align(FICL_VM *pVM)
2496{
2497 FICL_DICT *dp = ficlGetDict();
2498 IGNORE(pVM);
2499 dictAlign(dp);
2500 return;
2501}
2502
2503
2504/**************************************************************************
2505 a l i g n e d
2506**
2507**************************************************************************/
2508static void aligned(FICL_VM *pVM)
2509{
2510 void *addr = stackPopPtr(pVM->pStack);
2511 stackPushPtr(pVM->pStack, alignPtr(addr));
2512 return;
2513}
2514
2515
2516/**************************************************************************
2517 b e g i n & f r i e n d s
2518** Indefinite loop control structures
2519** A.6.1.0760 BEGIN
2520** Typical use:
2521** : X ... BEGIN ... test UNTIL ;
2522** or
2523** : X ... BEGIN ... test WHILE ... REPEAT ;
2524**************************************************************************/
2525static void beginCoIm(FICL_VM *pVM)
2526{
2527 FICL_DICT *dp = ficlGetDict();
2528 markBranch(dp, pVM, beginTag);
2529 return;
2530}
2531
2532static void untilCoIm(FICL_VM *pVM)
2533{
2534 FICL_DICT *dp = ficlGetDict();
2535
2536 assert(pIfParen);
2537
2538 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2539 resolveBackBranch(dp, pVM, beginTag);
2540 return;
2541}
2542
2543static void whileCoIm(FICL_VM *pVM)
2544{
2545 FICL_DICT *dp = ficlGetDict();
2546
2547 assert(pIfParen);
2548
2549 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2550 markBranch(dp, pVM, whileTag);
2551 twoSwap(pVM);
2552 dictAppendUNS32(dp, 1);
2553 return;
2554}
2555
2556static void repeatCoIm(FICL_VM *pVM)
2557{
2558 FICL_DICT *dp = ficlGetDict();
2559
2560 assert(pBranchParen);
2561 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
2562
2563 /* expect "begin" branch marker */
2564 resolveBackBranch(dp, pVM, beginTag);
2565 /* expect "while" branch marker */
2566 resolveForwardBranch(dp, pVM, whileTag);
2567 return;
2568}
2569
2570
2571/**************************************************************************
2572 c h a r & f r i e n d s
2573** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
2574** Skip leading space delimiters. Parse name delimited by a space.
2575** Put the value of its first character onto the stack.
2576**
2577** bracket-char CORE
2578** Interpretation: Interpretation semantics for this word are undefined.
2579** Compilation: ( "<spaces>name" -- )
2580** Skip leading space delimiters. Parse name delimited by a space.
2581** Append the run-time semantics given below to the current definition.
2582** Run-time: ( -- char )
2583** Place char, the value of the first character of name, on the stack.
2584**************************************************************************/
2585static void ficlChar(FICL_VM *pVM)
2586{
2587 STRINGINFO si = vmGetWord(pVM);
2588 stackPushUNS32(pVM->pStack, (UNS32)(si.cp[0]));
2589
2590 return;
2591}
2592
2593static void charCoIm(FICL_VM *pVM)
2594{
2595 ficlChar(pVM);
2596 literalIm(pVM);
2597 return;
2598}
2599
2600/**************************************************************************
2601 c h a r P l u s
2602** char-plus CORE ( c-addr1 -- c-addr2 )
2603** Add the size in address units of a character to c-addr1, giving c-addr2.
2604**************************************************************************/
2605static void charPlus(FICL_VM *pVM)
2606{
2607 char *cp = stackPopPtr(pVM->pStack);
2608 stackPushPtr(pVM->pStack, cp + 1);
2609 return;
2610}
2611
2612/**************************************************************************
2613 c h a r s
2614** chars CORE ( n1 -- n2 )
2615** n2 is the size in address units of n1 characters.
2616** For most processors, this function can be a no-op. To guarantee
2617** portability, we'll multiply by sizeof (char).
2618**************************************************************************/
2619#if defined (_M_IX86)
2620#pragma warning(disable: 4127)
2621#endif
2622static void ficlChars(FICL_VM *pVM)
2623{
2624 if (sizeof (char) > 1)
2625 {
2626 INT32 i = stackPopINT32(pVM->pStack);
2627 stackPushINT32(pVM->pStack, i * sizeof (char));
2628 }
2629 /* otherwise no-op! */
2630 return;
2631}
2632#if defined (_M_IX86)
2633#pragma warning(default: 4127)
2634#endif
2635
2636
2637/**************************************************************************
2638 c o u n t
2639** COUNT CORE ( c-addr1 -- c-addr2 u )
2640** Return the character string specification for the counted string stored
2641** at c-addr1. c-addr2 is the address of the first character after c-addr1.
2642** u is the contents of the character at c-addr1, which is the length in
2643** characters of the string at c-addr2.
2644**************************************************************************/
2645static void count(FICL_VM *pVM)
2646{
2647 FICL_STRING *sp = stackPopPtr(pVM->pStack);
2648 stackPushPtr(pVM->pStack, sp->text);
2649 stackPushUNS32(pVM->pStack, sp->count);
2650 return;
2651}
2652
2653/**************************************************************************
2654 e n v i r o n m e n t ?
2655** environment-query CORE ( c-addr u -- false | i*x true )
2656** c-addr is the address of a character string and u is the string's
2657** character count. u may have a value in the range from zero to an
2658** implementation-defined maximum which shall not be less than 31. The
2659** character string should contain a keyword from 3.2.6 Environmental
2660** queries or the optional word sets to be checked for correspondence
2661** with an attribute of the present environment. If the system treats the
2662** attribute as unknown, the returned flag is false; otherwise, the flag
2663** is true and the i*x returned is of the type specified in the table for
2664** the attribute queried.
2665**************************************************************************/
2666static void environmentQ(FICL_VM *pVM)
2667{
2668 FICL_DICT *envp = ficlGetEnv();
2669 FICL_COUNT len = (FICL_COUNT)stackPopUNS32(pVM->pStack);
2670 char *cp = stackPopPtr(pVM->pStack);
2671 FICL_WORD *pFW;
2672 STRINGINFO si;
2673
2674 SI_PSZ(si, cp);
2675 pFW = dictLookup(envp, si);
2676
2677 if (pFW != NULL)
2678 {
2679 vmExecute(pVM, pFW);
2680 stackPushINT32(pVM->pStack, FICL_TRUE);
2681 }
2682 else
2683 {
2684 stackPushINT32(pVM->pStack, FICL_FALSE);
2685 }
2686
2687 return;
2688}
2689
2690/**************************************************************************
2691 e v a l u a t e
2692** EVALUATE CORE ( i*x c-addr u -- j*x )
2693** Save the current input source specification. Store minus-one (-1) in
2694** SOURCE-ID if it is present. Make the string described by c-addr and u
2695** both the input source andinput buffer, set >IN to zero, and interpret.
2696** When the parse area is empty, restore the prior input source
2697** specification. Other stack effects are due to the words EVALUATEd.
2698**
2699** DEFICIENCY: this version does not handle restarts. Also, exceptions
2700** are just passed ahead. Is this the Right Thing? I don't know...
2701**************************************************************************/
2702static void evaluate(FICL_VM *pVM)
2703{
2704 INT32 count = stackPopINT32(pVM->pStack);
2705 char *cp = stackPopPtr(pVM->pStack);
2706 CELL id;
2707 int result;
2708
2709 id = pVM->sourceID;
2710 pVM->sourceID.i = -1;
2711 vmPushIP(pVM, &pInterpret);
2712 result = ficlExec(pVM, cp, count);
2713 vmPopIP(pVM);
2714 pVM->sourceID = id;
2715 if (result != VM_OUTOFTEXT)
2716 vmThrow(pVM, result);
2717 return;
2718}
2719
2720
2721/**************************************************************************
2722 s t r i n g q u o t e
2723** Intrpreting: get string delimited by a quote from the input stream,
2724** copy to a scratch area, and put its count and address on the stack.
2725** Compiling: compile code to push the address and count of a string
2726** literal, compile the string from the input stream, and align the dict
2727** pointer.
2728**************************************************************************/
2729static void stringQuoteIm(FICL_VM *pVM)
2730{
2731 FICL_DICT *dp = ficlGetDict();
2732
2733 if (pVM->state == INTERPRET)
2734 {
2735 FICL_STRING *sp = (FICL_STRING *) dp->here;
2736 vmGetString(pVM, sp, '\"');
2737 stackPushPtr(pVM->pStack, sp->text);
2738 stackPushUNS32(pVM->pStack, sp->count);
2739 }
2740 else /* COMPILE state */
2741 {
2742 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2743 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2744 dictAlign(dp);
2745 }
2746
2747 return;
2748}
2749
2750/**************************************************************************
2751 t y p e
2752** Pop count and char address from stack and print the designated string.
2753**************************************************************************/
2754static void type(FICL_VM *pVM)
2755{
2756 UNS32 count = stackPopUNS32(pVM->pStack);
2757 char *cp = stackPopPtr(pVM->pStack);
2758 char *pDest = (char *)ficlMalloc(count);
2759
2760 /*
2761 ** Since we don't have an output primitive for a counted string
2762 ** (oops), make sure the string is null terminated. If not, copy
2763 ** and terminate it.
2764 */
2765 if (!pDest)
2766 vmThrowErr(pVM, "Error: out of memory");
2767
2768 strncpy(pDest, cp, count);
2769 pDest[count] = '\0';
2770
2771 vmTextOut(pVM, cp, 0);
2772
2773 ficlFree(pDest);
2774 return;
2775}
2776
2777/**************************************************************************
2778 w o r d
2779** word CORE ( char "<chars>ccc<char>" -- c-addr )
2780** Skip leading delimiters. Parse characters ccc delimited by char. An
2781** ambiguous condition exists if the length of the parsed string is greater
2782** than the implementation-defined length of a counted string.
2783**
2784** c-addr is the address of a transient region containing the parsed word
2785** as a counted string. If the parse area was empty or contained no
2786** characters other than the delimiter, the resulting string has a zero
2787** length. A space, not included in the length, follows the string. A
2788** program may replace characters within the string.
2789** NOTE! Ficl also NULL-terminates the dest string.
2790**************************************************************************/
2791static void ficlWord(FICL_VM *pVM)
2792{
2793 FICL_STRING *sp = (FICL_STRING *)pVM->pad;
2794 char delim = (char)stackPopINT32(pVM->pStack);
2795 STRINGINFO si;
2796
2797 si = vmParseString(pVM, delim);
2798
2799 if (SI_COUNT(si) > nPAD-1)
2800 SI_SETLEN(si, nPAD-1);
2801
2802 sp->count = (FICL_COUNT)SI_COUNT(si);
2803 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
2804 strcat(sp->text, " ");
2805
2806 stackPushPtr(pVM->pStack, sp);
2807 return;
2808}
2809
2810
2811/**************************************************************************
2812 p a r s e - w o r d
2813** ficl PARSE-WORD ( <spaces>name -- c-addr u )
2814** Skip leading spaces and parse name delimited by a space. c-addr is the
2815** address within the input buffer and u is the length of the selected
2816** string. If the parse area is empty, the resulting string has a zero length.
2817**************************************************************************/
2818static void parseNoCopy(FICL_VM *pVM)
2819{
2820 STRINGINFO si = vmGetWord0(pVM);
2821 stackPushPtr(pVM->pStack, SI_PTR(si));
2822 stackPushUNS32(pVM->pStack, SI_COUNT(si));
2823 return;
2824}
2825
2826
2827/**************************************************************************
2828 p a r s e
2829** CORE EXT ( char "ccc<char>" -- c-addr u )
2830** Parse ccc delimited by the delimiter char.
2831** c-addr is the address (within the input buffer) and u is the length of
2832** the parsed string. If the parse area was empty, the resulting string has
2833** a zero length.
2834** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
2835**************************************************************************/
2836static void parse(FICL_VM *pVM)
2837{
2838 char *pSrc = vmGetInBuf(pVM);
2839 char *cp;
2840 UNS32 count;
2841 char delim = (char)stackPopINT32(pVM->pStack);
2842
2843 cp = pSrc; /* mark start of text */
2844
2845 while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0'))
2846 pSrc++; /* find next delimiter or end */
2847
2848 count = pSrc - cp; /* set length of result */
2849
2850 if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */
2851 pSrc++;
2852
2853 vmUpdateTib(pVM, pSrc);
2854 stackPushPtr(pVM->pStack, cp);
2855 stackPushUNS32(pVM->pStack, count);
2856 return;
2857}
2858
2859
2860/**************************************************************************
2861 f i l l
2862** CORE ( c-addr u char -- )
2863** If u is greater than zero, store char in each of u consecutive
2864** characters of memory beginning at c-addr.
2865**************************************************************************/
2866static void fill(FICL_VM *pVM)
2867{
2868 char ch = (char)stackPopINT32(pVM->pStack);
2869 UNS32 u = stackPopUNS32(pVM->pStack);
2870 char *cp = (char *)stackPopPtr(pVM->pStack);
2871
2872 while (u > 0)
2873 {
2874 *cp++ = ch;
2875 u--;
2876 }
2877
2878 return;
2879}
2880
2881
2882/**************************************************************************
2883 f i n d
2884** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2885** Find the definition named in the counted string at c-addr. If the
2886** definition is not found, return c-addr and zero. If the definition is
2887** found, return its execution token xt. If the definition is immediate,
2888** also return one (1), otherwise also return minus-one (-1). For a given
2889** string, the values returned by FIND while compiling may differ from
2890** those returned while not compiling.
2891**************************************************************************/
2892static void find(FICL_VM *pVM)
2893{
2894 FICL_STRING *sp = stackPopPtr(pVM->pStack);
2895 FICL_WORD *pFW;
2896 STRINGINFO si;
2897
2898 SI_PFS(si, sp);
2899 pFW = dictLookup(ficlGetDict(), si);
2900 if (pFW)
2901 {
2902 stackPushPtr(pVM->pStack, pFW);
2903 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
2904 }
2905 else
2906 {
2907 stackPushPtr(pVM->pStack, sp);
2908 stackPushUNS32(pVM->pStack, 0);
2909 }
2910 return;
2911}
2912
2913
2914/**************************************************************************
2915 f m S l a s h M o d
2916** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
2917** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
2918** Input and output stack arguments are signed. An ambiguous condition
2919** exists if n1 is zero or if the quotient lies outside the range of a
2920** single-cell signed integer.
2921**************************************************************************/
2922static void fmSlashMod(FICL_VM *pVM)
2923{
2924 INT64 d1;
2925 INT32 n1;
2926 INTQR qr;
2927
2928 n1 = stackPopINT32(pVM->pStack);
2929 d1 = i64Pop(pVM->pStack);
2930 qr = m64FlooredDivI(d1, n1);
2931 stackPushINT32(pVM->pStack, qr.rem);
2932 stackPushINT32(pVM->pStack, qr.quot);
2933 return;
2934}
2935
2936
2937/**************************************************************************
2938 s m S l a s h R e m
2939** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
2940** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
2941** Input and output stack arguments are signed. An ambiguous condition
2942** exists if n1 is zero or if the quotient lies outside the range of a
2943** single-cell signed integer.
2944**************************************************************************/
2945static void smSlashRem(FICL_VM *pVM)
2946{
2947 INT64 d1;
2948 INT32 n1;
2949 INTQR qr;
2950
2951 n1 = stackPopINT32(pVM->pStack);
2952 d1 = i64Pop(pVM->pStack);
2953 qr = m64SymmetricDivI(d1, n1);
2954 stackPushINT32(pVM->pStack, qr.rem);
2955 stackPushINT32(pVM->pStack, qr.quot);
2956 return;
2957}
2958
2959
2960static void ficlMod(FICL_VM *pVM)
2961{
2962 INT64 d1;
2963 INT32 n1;
2964 INTQR qr;
2965
2966 n1 = stackPopINT32(pVM->pStack);
2967 d1.lo = stackPopINT32(pVM->pStack);
2968 i64Extend(d1);
2969 qr = m64SymmetricDivI(d1, n1);
2970 stackPushINT32(pVM->pStack, qr.rem);
2971 return;
2972}
2973
2974
2975/**************************************************************************
2976 u m S l a s h M o d
2977** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
2978** Divide ud by u1, giving the quotient u3 and the remainder u2.
2979** All values and arithmetic are unsigned. An ambiguous condition
2980** exists if u1 is zero or if the quotient lies outside the range of a
2981** single-cell unsigned integer.
2982*************************************************************************/
2983static void umSlashMod(FICL_VM *pVM)
2984{
2985 UNS64 ud;
2986 UNS32 u1;
2987 UNSQR qr;
2988
2989 u1 = stackPopUNS32(pVM->pStack);
2990 ud = u64Pop(pVM->pStack);
2991 qr = ficlLongDiv(ud, u1);
2992 stackPushUNS32(pVM->pStack, qr.rem);
2993 stackPushUNS32(pVM->pStack, qr.quot);
2994 return;
2995}
2996
2997
2998/**************************************************************************
2999 l s h i f t
3000** l-shift CORE ( x1 u -- x2 )
3001** Perform a logical left shift of u bit-places on x1, giving x2.
3002** Put zeroes into the least significant bits vacated by the shift.
3003** An ambiguous condition exists if u is greater than or equal to the
3004** number of bits in a cell.
3005**
3006** r-shift CORE ( x1 u -- x2 )
3007** Perform a logical right shift of u bit-places on x1, giving x2.
3008** Put zeroes into the most significant bits vacated by the shift. An
3009** ambiguous condition exists if u is greater than or equal to the
3010** number of bits in a cell.
3011**************************************************************************/
3012static void lshift(FICL_VM *pVM)
3013{
3014 UNS32 nBits = stackPopUNS32(pVM->pStack);
3015 UNS32 x1 = stackPopUNS32(pVM->pStack);
3016
3017 stackPushUNS32(pVM->pStack, x1 << nBits);
3018 return;
3019}
3020
3021
3022static void rshift(FICL_VM *pVM)
3023{
3024 UNS32 nBits = stackPopUNS32(pVM->pStack);
3025 UNS32 x1 = stackPopUNS32(pVM->pStack);
3026
3027 stackPushUNS32(pVM->pStack, x1 >> nBits);
3028 return;
3029}
3030
3031
3032/**************************************************************************
3033 m S t a r
3034** m-star CORE ( n1 n2 -- d )
3035** d is the signed product of n1 times n2.
3036**************************************************************************/
3037static void mStar(FICL_VM *pVM)
3038{
3039 INT32 n2 = stackPopINT32(pVM->pStack);
3040 INT32 n1 = stackPopINT32(pVM->pStack);
3041 INT64 d;
3042
3043 d = m64MulI(n1, n2);
3044 i64Push(pVM->pStack, d);
3045 return;
3046}
3047
3048
3049static void umStar(FICL_VM *pVM)
3050{
3051 UNS32 u2 = stackPopUNS32(pVM->pStack);
3052 UNS32 u1 = stackPopUNS32(pVM->pStack);
3053 UNS64 ud;
3054
3055 ud = ficlLongMul(u1, u2);
3056 u64Push(pVM->pStack, ud);
3057 return;
3058}
3059
3060
3061/**************************************************************************
3062 m a x & m i n
3063**
3064**************************************************************************/
3065static void ficlMax(FICL_VM *pVM)
3066{
3067 INT32 n2 = stackPopINT32(pVM->pStack);
3068 INT32 n1 = stackPopINT32(pVM->pStack);
3069
3070 stackPushINT32(pVM->pStack, (n1 > n2) ? n1 : n2);
3071 return;
3072}
3073
3074static void ficlMin(FICL_VM *pVM)
3075{
3076 INT32 n2 = stackPopINT32(pVM->pStack);
3077 INT32 n1 = stackPopINT32(pVM->pStack);
3078
3079 stackPushINT32(pVM->pStack, (n1 < n2) ? n1 : n2);
3080 return;
3081}
3082
3083
3084/**************************************************************************
3085 m o v e
3086** CORE ( addr1 addr2 u -- )
3087** If u is greater than zero, copy the contents of u consecutive address
3088** units at addr1 to the u consecutive address units at addr2. After MOVE
3089** completes, the u consecutive address units at addr2 contain exactly
3090** what the u consecutive address units at addr1 contained before the move.
3091** NOTE! This implementation assumes that a char is the same size as
3092** an address unit.
3093**************************************************************************/
3094static void move(FICL_VM *pVM)
3095{
3096 UNS32 u = stackPopUNS32(pVM->pStack);
3097 char *addr2 = stackPopPtr(pVM->pStack);
3098 char *addr1 = stackPopPtr(pVM->pStack);
3099
3100 if (u == 0)
3101 return;
3102 /*
3103 ** Do the copy carefully, so as to be
3104 ** correct even if the two ranges overlap
3105 */
3106 if (addr1 >= addr2)
3107 {
3108 for (; u > 0; u--)
3109 *addr2++ = *addr1++;
3110 }
3111 else
3112 {
3113 addr2 += u-1;
3114 addr1 += u-1;
3115 for (; u > 0; u--)
3116 *addr2-- = *addr1--;
3117 }
3118
3119 return;
3120}
3121
3122
3123/**************************************************************************
3124 r e c u r s e
3125**
3126**************************************************************************/
3127static void recurseCoIm(FICL_VM *pVM)
3128{
3129 FICL_DICT *pDict = ficlGetDict();
3130
3131 IGNORE(pVM);
3132 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3133 return;
3134}
3135
3136
3137/**************************************************************************
3138 s t o d
3139** s-to-d CORE ( n -- d )
3140** Convert the number n to the double-cell number d with the same
3141** numerical value.
3142**************************************************************************/
3143static void sToD(FICL_VM *pVM)
3144{
3145 INT32 s = stackPopINT32(pVM->pStack);
3146
3147 /* sign extend to 64 bits.. */
3148 stackPushINT32(pVM->pStack, s);
3149 stackPushINT32(pVM->pStack, (s < 0) ? -1 : 0);
3150 return;
3151}
3152
3153
3154/**************************************************************************
3155 s o u r c e
3156** CORE ( -- c-addr u )
3157** c-addr is the address of, and u is the number of characters in, the
3158** input buffer.
3159**************************************************************************/
3160static void source(FICL_VM *pVM)
3161{ int i;
3162
3163 stackPushPtr(pVM->pStack, pVM->tib.cp);
3164 for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++);
3165 stackPushINT32(pVM->pStack, i);
3166 return;
3167}
3168
3169
3170/**************************************************************************
3171 v e r s i o n
3172** non-standard...
3173**************************************************************************/
3174static void ficlVersion(FICL_VM *pVM)
3175{
3176 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3177 return;
3178}
3179
3180
3181/**************************************************************************
3182 t o I n
3183** to-in CORE
3184**************************************************************************/
3185static void toIn(FICL_VM *pVM)
3186{
3187 stackPushPtr(pVM->pStack, &pVM->tib.index);
3188 return;
3189}
3190
3191
3192/**************************************************************************
3193 d e f i n i t i o n s
3194** SEARCH ( -- )
3195** Make the compilation word list the same as the first word list in the
3196** search order. Specifies that the names of subsequent definitions will
3197** be placed in the compilation word list. Subsequent changes in the search
3198** order will not affect the compilation word list.
3199**************************************************************************/
3200static void definitions(FICL_VM *pVM)
3201{
3202 FICL_DICT *pDict = ficlGetDict();
3203
3204 assert(pDict);
3205 if (pDict->nLists < 1)
3206 {
3207 vmThrowErr(pVM, "DEFINITIONS error - empty search order");
3208 }
3209
3210 pDict->pCompile = pDict->pSearch[pDict->nLists-1];
3211 return;
3212}
3213
3214
3215/**************************************************************************
3216 f o r t h - w o r d l i s t
3217** SEARCH ( -- wid )
3218** Return wid, the identifier of the word list that includes all standard
3219** words provided by the implementation. This word list is initially the
3220** compilation word list and is part of the initial search order.
3221**************************************************************************/
3222static void forthWordlist(FICL_VM *pVM)
3223{
3224 FICL_HASH *pHash = ficlGetDict()->pForthWords;
3225 stackPushPtr(pVM->pStack, pHash);
3226 return;
3227}
3228
3229
3230/**************************************************************************
3231 g e t - c u r r e n t
3232** SEARCH ( -- wid )
3233** Return wid, the identifier of the compilation word list.
3234**************************************************************************/
3235static void getCurrent(FICL_VM *pVM)
3236{
3237 ficlLockDictionary(TRUE);
3238 stackPushPtr(pVM->pStack, ficlGetDict()->pCompile);
3239 ficlLockDictionary(FALSE);
3240 return;
3241}
3242
3243
3244/**************************************************************************
3245 g e t - o r d e r
3246** SEARCH ( -- widn ... wid1 n )
3247** Returns the number of word lists n in the search order and the word list
3248** identifiers widn ... wid1 identifying these word lists. wid1 identifies
3249** the word list that is searched first, and widn the word list that is
3250** searched last. The search order is unaffected.
3251**************************************************************************/
3252static void getOrder(FICL_VM *pVM)
3253{
3254 FICL_DICT *pDict = ficlGetDict();
3255 int nLists = pDict->nLists;
3256 int i;
3257
3258 ficlLockDictionary(TRUE);
3259 for (i = 0; i < nLists; i++)
3260 {
3261 stackPushPtr(pVM->pStack, pDict->pSearch[i]);
3262 }
3263
3264 stackPushUNS32(pVM->pStack, nLists);
3265 ficlLockDictionary(FALSE);
3266 return;
3267}
3268
3269
3270/**************************************************************************
3271 s e a r c h - w o r d l i s t
3272** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
3273** Find the definition identified by the string c-addr u in the word list
3274** identified by wid. If the definition is not found, return zero. If the
3275** definition is found, return its execution token xt and one (1) if the
3276** definition is immediate, minus-one (-1) otherwise.
3277**************************************************************************/
3278static void searchWordlist(FICL_VM *pVM)
3279{
3280 STRINGINFO si;
3281 UNS16 hashCode;
3282 FICL_WORD *pFW;
3283 FICL_HASH *pHash = stackPopPtr(pVM->pStack);
3284
3285 si.count = (FICL_COUNT)stackPopUNS32(pVM->pStack);
3286 si.cp = stackPopPtr(pVM->pStack);
3287 hashCode = hashHashCode(si);
3288
3289 ficlLockDictionary(TRUE);
3290 pFW = hashLookup(pHash, si, hashCode);
3291 ficlLockDictionary(FALSE);
3292
3293 if (pFW)
3294 {
3295 stackPushPtr(pVM->pStack, pFW);
3296 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
3297 }
3298 else
3299 {
3300 stackPushUNS32(pVM->pStack, 0);
3301 }
3302
3303 return;
3304}
3305
3306
3307/**************************************************************************
3308 s e t - c u r r e n t
3309** SEARCH ( wid -- )
3310** Set the compilation word list to the word list identified by wid.
3311**************************************************************************/
3312static void setCurrent(FICL_VM *pVM)
3313{
3314 FICL_HASH *pHash = stackPopPtr(pVM->pStack);
3315 FICL_DICT *pDict = ficlGetDict();
3316 ficlLockDictionary(TRUE);
3317 pDict->pCompile = pHash;
3318 ficlLockDictionary(FALSE);
3319 return;
3320}
3321
3322
3323/**************************************************************************
3324 s e t - o r d e r
3325** SEARCH ( widn ... wid1 n -- )
3326** Set the search order to the word lists identified by widn ... wid1.
3327** Subsequently, word list wid1 will be searched first, and word list
3328** widn searched last. If n is zero, empty the search order. If n is minus
3329** one, set the search order to the implementation-defined minimum
3330** search order. The minimum search order shall include the words
3331** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
3332** be at least eight.
3333**************************************************************************/
3334static void setOrder(FICL_VM *pVM)
3335{
3336 int i;
3337 int nLists = stackPopINT32(pVM->pStack);
3338 FICL_DICT *dp = ficlGetDict();
3339
3340 if (nLists > FICL_DEFAULT_VOCS)
3341 {
3342 vmThrowErr(pVM, "set-order error: list would be too large");
3343 }
3344
3345 ficlLockDictionary(TRUE);
3346
3347 if (nLists >= 0)
3348 {
3349 dp->nLists = nLists;
3350 for (i = nLists-1; i >= 0; --i)
3351 {
3352 dp->pSearch[i] = stackPopPtr(pVM->pStack);
3353 }
3354 }
3355 else
3356 {
3357 dictResetSearchOrder(dp);
3358 }
3359
3360 ficlLockDictionary(FALSE);
3361 return;
3362}
3363
3364
3365/**************************************************************************
3366 w o r d l i s t
3367** SEARCH ( -- wid )
3368** Create a new empty word list, returning its word list identifier wid.
3369** The new word list may be returned from a pool of preallocated word
3370** lists or may be dynamically allocated in data space. A system shall
3371** allow the creation of at least 8 new word lists in addition to any
3372** provided as part of the system.
3373** Notes:
3374** 1. ficl creates a new single-list hash in the dictionary and returns
3375** its address.
3376** 2. ficl-wordlist takes an arg off the stack indicating the number of
3377** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
3378** : wordlist 1 ficl-wordlist ;
3379**************************************************************************/
3380static void wordlist(FICL_VM *pVM)
3381{
3382 FICL_DICT *dp = ficlGetDict();
3383 FICL_HASH *pHash;
3384 UNS32 nBuckets;
3385
3386#if FICL_ROBUST > 1
3387 vmCheckStack(pVM, 1, 1);
3388#endif
3389 nBuckets = stackPopUNS32(pVM->pStack);
3390
3391 dictAlign(dp);
3392 pHash = (FICL_HASH *)dp->here;
3393 dictAllot(dp, sizeof (FICL_HASH)
3394 + (nBuckets-1) * sizeof (FICL_WORD *));
3395
3396 pHash->size = nBuckets;
3397 hashReset(pHash);
3398
3399 stackPushPtr(pVM->pStack, pHash);
3400 return;
3401}
3402
3403
3404/**************************************************************************
3405 S E A R C H >
3406** ficl ( -- wid )
3407** Pop wid off the search order. Error if the search order is empty
3408**************************************************************************/
3409static void searchPop(FICL_VM *pVM)
3410{
3411 FICL_DICT *dp = ficlGetDict();
3412 int nLists;
3413
3414 ficlLockDictionary(TRUE);
3415 nLists = dp->nLists;
3416 if (nLists == 0)
3417 {
3418 vmThrowErr(pVM, "search> error: empty search order");
3419 }
3420 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
3421 ficlLockDictionary(FALSE);
3422 return;
3423}
3424
3425
3426/**************************************************************************
3427 > S E A R C H
3428** ficl ( wid -- )
3429** Push wid onto the search order. Error if the search order is full.
3430**************************************************************************/
3431static void searchPush(FICL_VM *pVM)
3432{
3433 FICL_DICT *dp = ficlGetDict();
3434
3435 ficlLockDictionary(TRUE);
3436 if (dp->nLists > FICL_DEFAULT_VOCS)
3437 {
3438 vmThrowErr(pVM, ">search error: search order overflow");
3439 }
3440 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
3441 ficlLockDictionary(FALSE);
3442 return;
3443}
3444
3445
3446/**************************************************************************
3447 c o l o n N o N a m e
3448** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3449** Create an unnamed colon definition and push its address.
3450** Change state to compile.
3451**************************************************************************/
3452static void colonNoName(FICL_VM *pVM)
3453{
3454 FICL_DICT *dp = ficlGetDict();
3455 FICL_WORD *pFW;
3456 STRINGINFO si;
3457
3458 SI_SETLEN(si, 0);
3459 SI_SETPTR(si, NULL);
3460
3461 pVM->state = COMPILE;
3462 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3463 stackPushPtr(pVM->pStack, pFW);
3464 markControlTag(pVM, colonTag);
3465 return;
3466}
3467
3468
3469/**************************************************************************
3470 u s e r V a r i a b l e
3471** user ( u -- ) "<spaces>name"
3472** Get a name from the input stream and create a user variable
3473** with the name and the index supplied. The run-time effect
3474** of a user variable is to push the address of the indexed cell
3475** in the running vm's user array.
3476**
3477** User variables are vm local cells. Each vm has an array of
3478** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3479** Ficl's user facility is implemented with two primitives,
3480** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3481** holds the index of the next free user cell, and a redefinition
3482** (also in softcore) of "user" that defines a user word and increments
3483** nUser.
3484**************************************************************************/
3485#if FICL_WANT_USER
3486static void userParen(FICL_VM *pVM)
3487{
3488 INT32 i = pVM->runningWord->param[0].i;
3489 stackPushPtr(pVM->pStack, &pVM->user[i]);
3490 return;
3491}
3492
3493
3494static void userVariable(FICL_VM *pVM)
3495{
3496 FICL_DICT *dp = ficlGetDict();
3497 STRINGINFO si = vmGetWord(pVM);
3498 CELL c;
3499
3500 c = stackPop(pVM->pStack);
3501 if (c.i >= FICL_USER_CELLS)
3502 {
3503 vmThrowErr(pVM, "Error - out of user space");
3504 }
3505
3506 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3507 dictAppendCell(dp, c);
3508 return;
3509}
3510#endif
3511
3512
3513/**************************************************************************
3514 t o V a l u e
3515** CORE EXT
3516** Interpretation: ( x "<spaces>name" -- )
3517** Skip leading spaces and parse name delimited by a space. Store x in
3518** name. An ambiguous condition exists if name was not defined by VALUE.
3519** NOTE: In ficl, VALUE is an alias of CONSTANT
3520**************************************************************************/
3521static void toValue(FICL_VM *pVM)
3522{
3523 STRINGINFO si = vmGetWord(pVM);
3524 FICL_DICT *dp = ficlGetDict();
3525 FICL_WORD *pFW;
3526
3527#if FICL_WANT_LOCALS
3528 FICL_DICT *pLoc = ficlGetLoc();
3529 if ((nLocals > 0) && (pVM->state == COMPILE))
3530 {
3531 pFW = dictLookup(pLoc, si);
3532 if (pFW)
3533 {
3534 dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
3535 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3536 return;
3537 }
3538 }
3539#endif
3540
3541 assert(pStore);
3542
3543 pFW = dictLookup(dp, si);
3544 if (!pFW)
3545 {
3546 int i = SI_COUNT(si);
3547 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3548 }
3549
3550 if (pVM->state == INTERPRET)
3551 pFW->param[0] = stackPop(pVM->pStack);
3552 else /* compile code to store to word's param */
3553 {
3554 stackPushPtr(pVM->pStack, &pFW->param[0]);
3555 literalIm(pVM);
3556 dictAppendCell(dp, LVALUEtoCELL(pStore));
3557 }
3558 return;
3559}
3560
3561
3562#if FICL_WANT_LOCALS
3563/**************************************************************************
3564 l i n k P a r e n
3565** ( -- )
3566** Link a frame on the return stack, reserving nCells of space for
3567** locals - the value of nCells is the next cell in the instruction
3568** stream.
3569**************************************************************************/
3570static void linkParen(FICL_VM *pVM)
3571{
3572 INT32 nLink = *(INT32 *)(pVM->ip);
3573 vmBranchRelative(pVM, 1);
3574 stackLink(pVM->rStack, nLink);
3575 return;
3576}
3577
3578
3579static void unlinkParen(FICL_VM *pVM)
3580{
3581 stackUnlink(pVM->rStack);
3582 return;
3583}
3584
3585
3586/**************************************************************************
3587 d o L o c a l I m
3588** Immediate - cfa of a local while compiling - when executed, compiles
3589** code to fetch the value of a local given the local's index in the
3590** word's pfa
3591**************************************************************************/
3592static void getLocalParen(FICL_VM *pVM)
3593{
3594 INT32 nLocal = *(INT32 *)(pVM->ip++);
3595 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3596 return;
3597}
3598
3599
3600static void toLocalParen(FICL_VM *pVM)
3601{
3602 INT32 nLocal = *(INT32 *)(pVM->ip++);
3603 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3604 return;
3605}
3606
3607
3608static void getLocal0(FICL_VM *pVM)
3609{
3610 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3611 return;
3612}
3613
3614
3615static void toLocal0(FICL_VM *pVM)
3616{
3617 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3618 return;
3619}
3620
3621
3622static void getLocal1(FICL_VM *pVM)
3623{
3624 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3625 return;
3626}
3627
3628
3629static void toLocal1(FICL_VM *pVM)
3630{
3631 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
3632 return;
3633}
3634
3635
3636/*
3637** Each local is recorded in a private locals dictionary as a
3638** word that does doLocalIm at runtime. DoLocalIm compiles code
3639** into the client definition to fetch the value of the
3640** corresponding local variable from the return stack.
3641** The private dictionary gets initialized at the end of each block
3642** that uses locals (in ; and does> for example).
3643*/
3644static void doLocalIm(FICL_VM *pVM)
3645{
3646 FICL_DICT *pDict = ficlGetDict();
3647 int nLocal = pVM->runningWord->param[0].i;
3648
3649 if (pVM->state == INTERPRET)
3650 {
3651 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3652 }
3653 else
3654 {
3655
3656 if (nLocal == 0)
3657 {
3658 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0));
3659 }
3660 else if (nLocal == 1)
3661 {
3662 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1));
3663 }
3664 else
3665 {
3666 dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen));
3667 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
3668 }
3669 }
3670 return;
3671}
3672
3673
3674/**************************************************************************
3675 l o c a l P a r e n
3676** paren-local-paren LOCAL
3677** Interpretation: Interpretation semantics for this word are undefined.
3678** Execution: ( c-addr u -- )
3679** When executed during compilation, (LOCAL) passes a message to the
3680** system that has one of two meanings. If u is non-zero,
3681** the message identifies a new local whose definition name is given by
3682** the string of characters identified by c-addr u. If u is zero,
3683** the message is last local and c-addr has no significance.
3684**
3685** The result of executing (LOCAL) during compilation of a definition is
3686** to create a set of named local identifiers, each of which is
3687** a definition name, that only have execution semantics within the scope
3688** of that definition's source.
3689**
3690** local Execution: ( -- x )
3691**
3692** Push the local's value, x, onto the stack. The local's value is
3693** initialized as described in 13.3.3 Processing locals and may be
3694** changed by preceding the local's name with TO. An ambiguous condition
3695** exists when local is executed while in interpretation state.
3696**************************************************************************/
3697static void localParen(FICL_VM *pVM)
3698{
3699 static CELL *pMark = NULL;
3700 FICL_DICT *pDict = ficlGetDict();
3701 STRINGINFO si;
3702 SI_SETLEN(si, stackPopUNS32(pVM->pStack));
3703 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
3704
3705 if (SI_COUNT(si) > 0)
3706 { /* add a local to the dict and update nLocals */
3707 FICL_DICT *pLoc = ficlGetLoc();
3708 if (nLocals >= FICL_MAX_LOCALS)
3709 {
3710 vmThrowErr(pVM, "Error: out of local space");
3711 }
3712
3713 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
3714 dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
3715
3716 if (nLocals == 0)
3717 { /* compile code to create a local stack frame */
3718 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
3719 /* save location in dictionary for #locals */
3720 pMark = pDict->here;
3721 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3722 /* compile code to initialize first local */
3723 dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
3724 }
3725 else if (nLocals == 1)
3726 {
3727 dictAppendCell(pDict, LVALUEtoCELL(pToLocal1));
3728 }
3729 else
3730 {
3731 dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen));
3732 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3733 }
3734
3735 nLocals++;
3736 }
3737 else if (nLocals > 0)
3738 { /* write nLocals to (link) param area in dictionary */
3739 *(INT32 *)pMark = nLocals;
3740 }
3741
3742 return;
3743}
3744
3745
3746#endif
3747/**************************************************************************
3748 setParentWid
3749** FICL
3750** setparentwid ( parent-wid wid -- )
3751** Set WID's link field to the parent-wid. search-wordlist will
3752** iterate through all the links when finding words in the child wid.
3753**************************************************************************/
3754static void setParentWid(FICL_VM *pVM)
3755{
3756 FICL_HASH *parent, *child;
3757#if FICL_ROBUST > 1
3758 vmCheckStack(pVM, 2, 0);
3759#endif
3760 child = (FICL_HASH *)stackPopPtr(pVM->pStack);
3761 parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
3762
3763 child->link = parent;
3764 return;
3765}
3766
3767
3768/**************************************************************************
3769 s e e
3770** TOOLS ( "<spaces>name" -- )
3771** Display a human-readable representation of the named word's definition.
3772** The source of the representation (object-code decompilation, source
3773** block, etc.) and the particular form of the display is implementation
3774** defined.
3775** NOTE: these funcs come late in the file because they reference all
3776** of the word-builder funcs without declaring them again. Call me lazy.
3777**************************************************************************/
3778/*
3779** isAFiclWord
3780** Vet a candidate pointer carefully to make sure
3781** it's not some chunk o' inline data...
3782** It has to have a name, and it has to look
3783** like it's in the dictionary address range.
3784** NOTE: this excludes :noname words!
3785*/
| 2065{
2066 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2067 FICL_COUNT count = sp->count;
2068 char *cp = sp->text;
2069 stackPushPtr(pVM->pStack, cp);
2070 stackPushUNS32(pVM->pStack, count);
2071 cp += count + 1;
2072 cp = alignPtr(cp);
2073 pVM->ip = (IPTYPE)(void *)cp;
2074 return;
2075}
2076
2077static void dotQuoteCoIm(FICL_VM *pVM)
2078{
2079 FICL_DICT *dp = ficlGetDict();
2080 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2081 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2082 dictAlign(dp);
2083 dictAppendCell(dp, LVALUEtoCELL(pType));
2084 return;
2085}
2086
2087
2088static void dotParen(FICL_VM *pVM)
2089{
2090 char *pSrc = vmGetInBuf(pVM);
2091 char *pDest = pVM->pad;
2092 char ch;
2093
2094 pSrc = skipSpace(pSrc,pVM->tib.end);
2095
2096 for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc)
2097 *pDest++ = ch;
2098
2099 *pDest = '\0';
2100 if ((pVM->tib.end != pSrc) && (ch == ')'))
2101 pSrc++;
2102
2103 vmTextOut(pVM, pVM->pad, 0);
2104 vmUpdateTib(pVM, pSrc);
2105
2106 return;
2107}
2108
2109
2110/**************************************************************************
2111 s l i t e r a l
2112** STRING
2113** Interpretation: Interpretation semantics for this word are undefined.
2114** Compilation: ( c-addr1 u -- )
2115** Append the run-time semantics given below to the current definition.
2116** Run-time: ( -- c-addr2 u )
2117** Return c-addr2 u describing a string consisting of the characters
2118** specified by c-addr1 u during compilation. A program shall not alter
2119** the returned string.
2120**************************************************************************/
2121static void sLiteralCoIm(FICL_VM *pVM)
2122{
2123 FICL_DICT *dp = ficlGetDict();
2124 char *cp, *cpDest;
2125 UNS32 u;
2126 u = stackPopUNS32(pVM->pStack);
2127 cp = stackPopPtr(pVM->pStack);
2128
2129 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2130 cpDest = (char *) dp->here;
2131 *cpDest++ = (char) u;
2132
2133 for (; u > 0; --u)
2134 {
2135 *cpDest++ = *cp++;
2136 }
2137
2138 *cpDest++ = 0;
2139 dp->here = PTRtoCELL alignPtr(cpDest);
2140 return;
2141}
2142
2143
2144/**************************************************************************
2145 s t a t e
2146** Return the address of the VM's state member (must be sized the
2147** same as a CELL for this reason)
2148**************************************************************************/
2149static void state(FICL_VM *pVM)
2150{
2151 stackPushPtr(pVM->pStack, &pVM->state);
2152 return;
2153}
2154
2155
2156/**************************************************************************
2157 c r e a t e . . . d o e s >
2158** Make a new word in the dictionary with the run-time effect of
2159** a variable (push my address), but with extra space allotted
2160** for use by does> .
2161**************************************************************************/
2162
2163static void createParen(FICL_VM *pVM)
2164{
2165 CELL *pCell = pVM->runningWord->param;
2166 stackPushPtr(pVM->pStack, pCell+1);
2167 return;
2168}
2169
2170
2171static void create(FICL_VM *pVM)
2172{
2173 FICL_DICT *dp = ficlGetDict();
2174 STRINGINFO si = vmGetWord(pVM);
2175
2176 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2177 dictAllotCells(dp, 1);
2178 return;
2179}
2180
2181
2182static void doDoes(FICL_VM *pVM)
2183{
2184 CELL *pCell = pVM->runningWord->param;
2185 IPTYPE tempIP = (IPTYPE)((*pCell).p);
2186 stackPushPtr(pVM->pStack, pCell+1);
2187 vmPushIP(pVM, tempIP);
2188 return;
2189}
2190
2191
2192static void doesParen(FICL_VM *pVM)
2193{
2194 FICL_DICT *dp = ficlGetDict();
2195 dp->smudge->code = doDoes;
2196 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2197 vmPopIP(pVM);
2198 return;
2199}
2200
2201
2202static void doesCoIm(FICL_VM *pVM)
2203{
2204 FICL_DICT *dp = ficlGetDict();
2205#if FICL_WANT_LOCALS
2206 assert(pUnLinkParen);
2207 if (nLocals > 0)
2208 {
2209 FICL_DICT *pLoc = ficlGetLoc();
2210 dictEmpty(pLoc, pLoc->pForthWords->size);
2211 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
2212 }
2213
2214 nLocals = 0;
2215#endif
2216 IGNORE(pVM);
2217
2218 dictAppendCell(dp, LVALUEtoCELL(pDoesParen));
2219 return;
2220}
2221
2222
2223/**************************************************************************
2224 t o b o d y
2225** to-body CORE ( xt -- a-addr )
2226** a-addr is the data-field address corresponding to xt. An ambiguous
2227** condition exists if xt is not for a word defined via CREATE.
2228**************************************************************************/
2229static void toBody(FICL_VM *pVM)
2230{
2231 FICL_WORD *pFW = stackPopPtr(pVM->pStack);
2232 stackPushPtr(pVM->pStack, pFW->param + 1);
2233 return;
2234}
2235
2236
2237/*
2238** from-body ficl ( a-addr -- xt )
2239** Reverse effect of >body
2240*/
2241static void fromBody(FICL_VM *pVM)
2242{
2243 char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD);
2244 stackPushPtr(pVM->pStack, ptr);
2245 return;
2246}
2247
2248
2249/*
2250** >name ficl ( xt -- c-addr u )
2251** Push the address and length of a word's name given its address
2252** xt.
2253*/
2254static void toName(FICL_VM *pVM)
2255{
2256 FICL_WORD *pFW = stackPopPtr(pVM->pStack);
2257 stackPushPtr(pVM->pStack, pFW->name);
2258 stackPushUNS32(pVM->pStack, pFW->nName);
2259 return;
2260}
2261
2262
2263/**************************************************************************
2264 l b r a c k e t e t c
2265**
2266**************************************************************************/
2267
2268static void lbracketCoIm(FICL_VM *pVM)
2269{
2270 pVM->state = INTERPRET;
2271 return;
2272}
2273
2274
2275static void rbracket(FICL_VM *pVM)
2276{
2277 pVM->state = COMPILE;
2278 return;
2279}
2280
2281
2282/**************************************************************************
2283 p i c t u r e d n u m e r i c w o r d s
2284**
2285** less-number-sign CORE ( -- )
2286** Initialize the pictured numeric output conversion process.
2287** (clear the pad)
2288**************************************************************************/
2289static void lessNumberSign(FICL_VM *pVM)
2290{
2291 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2292 sp->count = 0;
2293 return;
2294}
2295
2296/*
2297** number-sign CORE ( ud1 -- ud2 )
2298** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2299** n. (n is the least-significant digit of ud1.) Convert n to external form
2300** and add the resulting character to the beginning of the pictured numeric
2301** output string. An ambiguous condition exists if # executes outside of a
2302** <# #> delimited number conversion.
2303*/
2304static void numberSign(FICL_VM *pVM)
2305{
2306 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2307 UNS64 u;
2308 UNS16 rem;
2309
2310 u = u64Pop(pVM->pStack);
2311 rem = m64UMod(&u, (UNS16)(pVM->base));
2312 sp->text[sp->count++] = digit_to_char(rem);
2313 u64Push(pVM->pStack, u);
2314 return;
2315}
2316
2317/*
2318** number-sign-greater CORE ( xd -- c-addr u )
2319** Drop xd. Make the pictured numeric output string available as a character
2320** string. c-addr and u specify the resulting character string. A program
2321** may replace characters within the string.
2322*/
2323static void numberSignGreater(FICL_VM *pVM)
2324{
2325 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2326 sp->text[sp->count] = '\0';
2327 strrev(sp->text);
2328 stackDrop(pVM->pStack, 2);
2329 stackPushPtr(pVM->pStack, sp->text);
2330 stackPushUNS32(pVM->pStack, sp->count);
2331 return;
2332}
2333
2334/*
2335** number-sign-s CORE ( ud1 -- ud2 )
2336** Convert one digit of ud1 according to the rule for #. Continue conversion
2337** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2338** #S executes outside of a <# #> delimited number conversion.
2339** TO DO: presently does not use ud1 hi cell - use it!
2340*/
2341static void numberSignS(FICL_VM *pVM)
2342{
2343 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2344 UNS64 u;
2345 UNS16 rem;
2346
2347 u = u64Pop(pVM->pStack);
2348
2349 do
2350 {
2351 rem = m64UMod(&u, (UNS16)(pVM->base));
2352 sp->text[sp->count++] = digit_to_char(rem);
2353 }
2354 while (u.hi || u.lo);
2355
2356 u64Push(pVM->pStack, u);
2357 return;
2358}
2359
2360/*
2361** HOLD CORE ( char -- )
2362** Add char to the beginning of the pictured numeric output string. An ambiguous
2363** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2364*/
2365static void hold(FICL_VM *pVM)
2366{
2367 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2368 int i = stackPopINT32(pVM->pStack);
2369 sp->text[sp->count++] = (char) i;
2370 return;
2371}
2372
2373/*
2374** SIGN CORE ( n -- )
2375** If n is negative, add a minus sign to the beginning of the pictured
2376** numeric output string. An ambiguous condition exists if SIGN
2377** executes outside of a <# #> delimited number conversion.
2378*/
2379static void sign(FICL_VM *pVM)
2380{
2381 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2382 int i = stackPopINT32(pVM->pStack);
2383 if (i < 0)
2384 sp->text[sp->count++] = '-';
2385 return;
2386}
2387
2388
2389/**************************************************************************
2390 t o N u m b e r
2391** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2392** ud2 is the unsigned result of converting the characters within the
2393** string specified by c-addr1 u1 into digits, using the number in BASE,
2394** and adding each into ud1 after multiplying ud1 by the number in BASE.
2395** Conversion continues left-to-right until a character that is not
2396** convertible, including any + or -, is encountered or the string is
2397** entirely converted. c-addr2 is the location of the first unconverted
2398** character or the first character past the end of the string if the string
2399** was entirely converted. u2 is the number of unconverted characters in the
2400** string. An ambiguous condition exists if ud2 overflows during the
2401** conversion.
2402** TO DO: presently does not use ud1 hi cell - use it!
2403**************************************************************************/
2404static void toNumber(FICL_VM *pVM)
2405{
2406 UNS32 count = stackPopUNS32(pVM->pStack);
2407 char *cp = (char *)stackPopPtr(pVM->pStack);
2408 UNS64 accum;
2409 UNS32 base = pVM->base;
2410 UNS32 ch;
2411 UNS32 digit;
2412
2413 accum = u64Pop(pVM->pStack);
2414
2415 for (ch = *cp; count > 0; ch = *++cp, count--)
2416 {
2417 if (ch < '0')
2418 break;
2419
2420 digit = ch - '0';
2421
2422 if (digit > 9)
2423 digit = tolower(ch) - 'a' + 10;
2424 /*
2425 ** Note: following test also catches chars between 9 and a
2426 ** because 'digit' is unsigned!
2427 */
2428 if (digit >= base)
2429 break;
2430
2431 accum = m64Mac(accum, base, digit);
2432 }
2433
2434 u64Push(pVM->pStack, accum);
2435 stackPushPtr (pVM->pStack, cp);
2436 stackPushUNS32(pVM->pStack, count);
2437
2438 return;
2439}
2440
2441
2442
2443/**************************************************************************
2444 q u i t & a b o r t
2445** quit CORE ( -- ) ( R: i*x -- )
2446** Empty the return stack, store zero in SOURCE-ID if it is present, make
2447** the user input device the input source, and enter interpretation state.
2448** Do not display a message. Repeat the following:
2449**
2450** Accept a line from the input source into the input buffer, set >IN to
2451** zero, and interpret.
2452** Display the implementation-defined system prompt if in
2453** interpretation state, all processing has been completed, and no
2454** ambiguous condition exists.
2455**************************************************************************/
2456
2457static void quit(FICL_VM *pVM)
2458{
2459 vmThrow(pVM, VM_QUIT);
2460 return;
2461}
2462
2463
2464static void ficlAbort(FICL_VM *pVM)
2465{
2466 vmThrow(pVM, VM_ABORT);
2467 return;
2468}
2469
2470
2471/**************************************************************************
2472 a c c e p t
2473** accept CORE ( c-addr +n1 -- +n2 )
2474** Receive a string of at most +n1 characters. An ambiguous condition
2475** exists if +n1 is zero or greater than 32,767. Display graphic characters
2476** as they are received. A program that depends on the presence or absence
2477** of non-graphic characters in the string has an environmental dependency.
2478** The editing functions, if any, that the system performs in order to
2479** construct the string are implementation-defined.
2480**
2481** (Although the standard text doesn't say so, I assume that the intent
2482** of 'accept' is to store the string at the address specified on
2483** the stack.)
2484** Implementation: if there's more text in the TIB, use it. Otherwise
2485** throw out for more text. Copy characters up to the max count into the
2486** address given, and return the number of actual characters copied.
2487**
2488** This may not strictly violate the standard, but I'm sure any programs
2489** asking for user input at load time will *not* be expecting this
2490** behavior. (sobral)
2491**************************************************************************/
2492static void accept(FICL_VM *pVM)
2493{
2494 UNS32 count, len;
2495 char *cp;
2496 char *pBuf = vmGetInBuf(pVM);
2497
2498 for (len = 0; pVM->tib.end != &pBuf[len] && pBuf[len]; len++);
2499 if (len == 0)
2500 vmThrow(pVM, VM_RESTART);
2501 /* OK - now we have something in the text buffer - use it */
2502 count = stackPopUNS32(pVM->pStack);
2503 cp = stackPopPtr(pVM->pStack);
2504
2505 strncpy(cp, vmGetInBuf(pVM), count);
2506 len = (count < len) ? count : len;
2507 pBuf += len;
2508 vmUpdateTib(pVM, pBuf);
2509 stackPushUNS32(pVM->pStack, len);
2510
2511 return;
2512}
2513
2514
2515/**************************************************************************
2516 a l i g n
2517** 6.1.0705 ALIGN CORE ( -- )
2518** If the data-space pointer is not aligned, reserve enough space to
2519** align it.
2520**************************************************************************/
2521static void align(FICL_VM *pVM)
2522{
2523 FICL_DICT *dp = ficlGetDict();
2524 IGNORE(pVM);
2525 dictAlign(dp);
2526 return;
2527}
2528
2529
2530/**************************************************************************
2531 a l i g n e d
2532**
2533**************************************************************************/
2534static void aligned(FICL_VM *pVM)
2535{
2536 void *addr = stackPopPtr(pVM->pStack);
2537 stackPushPtr(pVM->pStack, alignPtr(addr));
2538 return;
2539}
2540
2541
2542/**************************************************************************
2543 b e g i n & f r i e n d s
2544** Indefinite loop control structures
2545** A.6.1.0760 BEGIN
2546** Typical use:
2547** : X ... BEGIN ... test UNTIL ;
2548** or
2549** : X ... BEGIN ... test WHILE ... REPEAT ;
2550**************************************************************************/
2551static void beginCoIm(FICL_VM *pVM)
2552{
2553 FICL_DICT *dp = ficlGetDict();
2554 markBranch(dp, pVM, beginTag);
2555 return;
2556}
2557
2558static void untilCoIm(FICL_VM *pVM)
2559{
2560 FICL_DICT *dp = ficlGetDict();
2561
2562 assert(pIfParen);
2563
2564 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2565 resolveBackBranch(dp, pVM, beginTag);
2566 return;
2567}
2568
2569static void whileCoIm(FICL_VM *pVM)
2570{
2571 FICL_DICT *dp = ficlGetDict();
2572
2573 assert(pIfParen);
2574
2575 dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2576 markBranch(dp, pVM, whileTag);
2577 twoSwap(pVM);
2578 dictAppendUNS32(dp, 1);
2579 return;
2580}
2581
2582static void repeatCoIm(FICL_VM *pVM)
2583{
2584 FICL_DICT *dp = ficlGetDict();
2585
2586 assert(pBranchParen);
2587 dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
2588
2589 /* expect "begin" branch marker */
2590 resolveBackBranch(dp, pVM, beginTag);
2591 /* expect "while" branch marker */
2592 resolveForwardBranch(dp, pVM, whileTag);
2593 return;
2594}
2595
2596
2597/**************************************************************************
2598 c h a r & f r i e n d s
2599** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
2600** Skip leading space delimiters. Parse name delimited by a space.
2601** Put the value of its first character onto the stack.
2602**
2603** bracket-char CORE
2604** Interpretation: Interpretation semantics for this word are undefined.
2605** Compilation: ( "<spaces>name" -- )
2606** Skip leading space delimiters. Parse name delimited by a space.
2607** Append the run-time semantics given below to the current definition.
2608** Run-time: ( -- char )
2609** Place char, the value of the first character of name, on the stack.
2610**************************************************************************/
2611static void ficlChar(FICL_VM *pVM)
2612{
2613 STRINGINFO si = vmGetWord(pVM);
2614 stackPushUNS32(pVM->pStack, (UNS32)(si.cp[0]));
2615
2616 return;
2617}
2618
2619static void charCoIm(FICL_VM *pVM)
2620{
2621 ficlChar(pVM);
2622 literalIm(pVM);
2623 return;
2624}
2625
2626/**************************************************************************
2627 c h a r P l u s
2628** char-plus CORE ( c-addr1 -- c-addr2 )
2629** Add the size in address units of a character to c-addr1, giving c-addr2.
2630**************************************************************************/
2631static void charPlus(FICL_VM *pVM)
2632{
2633 char *cp = stackPopPtr(pVM->pStack);
2634 stackPushPtr(pVM->pStack, cp + 1);
2635 return;
2636}
2637
2638/**************************************************************************
2639 c h a r s
2640** chars CORE ( n1 -- n2 )
2641** n2 is the size in address units of n1 characters.
2642** For most processors, this function can be a no-op. To guarantee
2643** portability, we'll multiply by sizeof (char).
2644**************************************************************************/
2645#if defined (_M_IX86)
2646#pragma warning(disable: 4127)
2647#endif
2648static void ficlChars(FICL_VM *pVM)
2649{
2650 if (sizeof (char) > 1)
2651 {
2652 INT32 i = stackPopINT32(pVM->pStack);
2653 stackPushINT32(pVM->pStack, i * sizeof (char));
2654 }
2655 /* otherwise no-op! */
2656 return;
2657}
2658#if defined (_M_IX86)
2659#pragma warning(default: 4127)
2660#endif
2661
2662
2663/**************************************************************************
2664 c o u n t
2665** COUNT CORE ( c-addr1 -- c-addr2 u )
2666** Return the character string specification for the counted string stored
2667** at c-addr1. c-addr2 is the address of the first character after c-addr1.
2668** u is the contents of the character at c-addr1, which is the length in
2669** characters of the string at c-addr2.
2670**************************************************************************/
2671static void count(FICL_VM *pVM)
2672{
2673 FICL_STRING *sp = stackPopPtr(pVM->pStack);
2674 stackPushPtr(pVM->pStack, sp->text);
2675 stackPushUNS32(pVM->pStack, sp->count);
2676 return;
2677}
2678
2679/**************************************************************************
2680 e n v i r o n m e n t ?
2681** environment-query CORE ( c-addr u -- false | i*x true )
2682** c-addr is the address of a character string and u is the string's
2683** character count. u may have a value in the range from zero to an
2684** implementation-defined maximum which shall not be less than 31. The
2685** character string should contain a keyword from 3.2.6 Environmental
2686** queries or the optional word sets to be checked for correspondence
2687** with an attribute of the present environment. If the system treats the
2688** attribute as unknown, the returned flag is false; otherwise, the flag
2689** is true and the i*x returned is of the type specified in the table for
2690** the attribute queried.
2691**************************************************************************/
2692static void environmentQ(FICL_VM *pVM)
2693{
2694 FICL_DICT *envp = ficlGetEnv();
2695 FICL_COUNT len = (FICL_COUNT)stackPopUNS32(pVM->pStack);
2696 char *cp = stackPopPtr(pVM->pStack);
2697 FICL_WORD *pFW;
2698 STRINGINFO si;
2699
2700 SI_PSZ(si, cp);
2701 pFW = dictLookup(envp, si);
2702
2703 if (pFW != NULL)
2704 {
2705 vmExecute(pVM, pFW);
2706 stackPushINT32(pVM->pStack, FICL_TRUE);
2707 }
2708 else
2709 {
2710 stackPushINT32(pVM->pStack, FICL_FALSE);
2711 }
2712
2713 return;
2714}
2715
2716/**************************************************************************
2717 e v a l u a t e
2718** EVALUATE CORE ( i*x c-addr u -- j*x )
2719** Save the current input source specification. Store minus-one (-1) in
2720** SOURCE-ID if it is present. Make the string described by c-addr and u
2721** both the input source andinput buffer, set >IN to zero, and interpret.
2722** When the parse area is empty, restore the prior input source
2723** specification. Other stack effects are due to the words EVALUATEd.
2724**
2725** DEFICIENCY: this version does not handle restarts. Also, exceptions
2726** are just passed ahead. Is this the Right Thing? I don't know...
2727**************************************************************************/
2728static void evaluate(FICL_VM *pVM)
2729{
2730 INT32 count = stackPopINT32(pVM->pStack);
2731 char *cp = stackPopPtr(pVM->pStack);
2732 CELL id;
2733 int result;
2734
2735 id = pVM->sourceID;
2736 pVM->sourceID.i = -1;
2737 vmPushIP(pVM, &pInterpret);
2738 result = ficlExec(pVM, cp, count);
2739 vmPopIP(pVM);
2740 pVM->sourceID = id;
2741 if (result != VM_OUTOFTEXT)
2742 vmThrow(pVM, result);
2743 return;
2744}
2745
2746
2747/**************************************************************************
2748 s t r i n g q u o t e
2749** Intrpreting: get string delimited by a quote from the input stream,
2750** copy to a scratch area, and put its count and address on the stack.
2751** Compiling: compile code to push the address and count of a string
2752** literal, compile the string from the input stream, and align the dict
2753** pointer.
2754**************************************************************************/
2755static void stringQuoteIm(FICL_VM *pVM)
2756{
2757 FICL_DICT *dp = ficlGetDict();
2758
2759 if (pVM->state == INTERPRET)
2760 {
2761 FICL_STRING *sp = (FICL_STRING *) dp->here;
2762 vmGetString(pVM, sp, '\"');
2763 stackPushPtr(pVM->pStack, sp->text);
2764 stackPushUNS32(pVM->pStack, sp->count);
2765 }
2766 else /* COMPILE state */
2767 {
2768 dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2769 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2770 dictAlign(dp);
2771 }
2772
2773 return;
2774}
2775
2776/**************************************************************************
2777 t y p e
2778** Pop count and char address from stack and print the designated string.
2779**************************************************************************/
2780static void type(FICL_VM *pVM)
2781{
2782 UNS32 count = stackPopUNS32(pVM->pStack);
2783 char *cp = stackPopPtr(pVM->pStack);
2784 char *pDest = (char *)ficlMalloc(count);
2785
2786 /*
2787 ** Since we don't have an output primitive for a counted string
2788 ** (oops), make sure the string is null terminated. If not, copy
2789 ** and terminate it.
2790 */
2791 if (!pDest)
2792 vmThrowErr(pVM, "Error: out of memory");
2793
2794 strncpy(pDest, cp, count);
2795 pDest[count] = '\0';
2796
2797 vmTextOut(pVM, cp, 0);
2798
2799 ficlFree(pDest);
2800 return;
2801}
2802
2803/**************************************************************************
2804 w o r d
2805** word CORE ( char "<chars>ccc<char>" -- c-addr )
2806** Skip leading delimiters. Parse characters ccc delimited by char. An
2807** ambiguous condition exists if the length of the parsed string is greater
2808** than the implementation-defined length of a counted string.
2809**
2810** c-addr is the address of a transient region containing the parsed word
2811** as a counted string. If the parse area was empty or contained no
2812** characters other than the delimiter, the resulting string has a zero
2813** length. A space, not included in the length, follows the string. A
2814** program may replace characters within the string.
2815** NOTE! Ficl also NULL-terminates the dest string.
2816**************************************************************************/
2817static void ficlWord(FICL_VM *pVM)
2818{
2819 FICL_STRING *sp = (FICL_STRING *)pVM->pad;
2820 char delim = (char)stackPopINT32(pVM->pStack);
2821 STRINGINFO si;
2822
2823 si = vmParseString(pVM, delim);
2824
2825 if (SI_COUNT(si) > nPAD-1)
2826 SI_SETLEN(si, nPAD-1);
2827
2828 sp->count = (FICL_COUNT)SI_COUNT(si);
2829 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
2830 strcat(sp->text, " ");
2831
2832 stackPushPtr(pVM->pStack, sp);
2833 return;
2834}
2835
2836
2837/**************************************************************************
2838 p a r s e - w o r d
2839** ficl PARSE-WORD ( <spaces>name -- c-addr u )
2840** Skip leading spaces and parse name delimited by a space. c-addr is the
2841** address within the input buffer and u is the length of the selected
2842** string. If the parse area is empty, the resulting string has a zero length.
2843**************************************************************************/
2844static void parseNoCopy(FICL_VM *pVM)
2845{
2846 STRINGINFO si = vmGetWord0(pVM);
2847 stackPushPtr(pVM->pStack, SI_PTR(si));
2848 stackPushUNS32(pVM->pStack, SI_COUNT(si));
2849 return;
2850}
2851
2852
2853/**************************************************************************
2854 p a r s e
2855** CORE EXT ( char "ccc<char>" -- c-addr u )
2856** Parse ccc delimited by the delimiter char.
2857** c-addr is the address (within the input buffer) and u is the length of
2858** the parsed string. If the parse area was empty, the resulting string has
2859** a zero length.
2860** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
2861**************************************************************************/
2862static void parse(FICL_VM *pVM)
2863{
2864 char *pSrc = vmGetInBuf(pVM);
2865 char *cp;
2866 UNS32 count;
2867 char delim = (char)stackPopINT32(pVM->pStack);
2868
2869 cp = pSrc; /* mark start of text */
2870
2871 while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0'))
2872 pSrc++; /* find next delimiter or end */
2873
2874 count = pSrc - cp; /* set length of result */
2875
2876 if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */
2877 pSrc++;
2878
2879 vmUpdateTib(pVM, pSrc);
2880 stackPushPtr(pVM->pStack, cp);
2881 stackPushUNS32(pVM->pStack, count);
2882 return;
2883}
2884
2885
2886/**************************************************************************
2887 f i l l
2888** CORE ( c-addr u char -- )
2889** If u is greater than zero, store char in each of u consecutive
2890** characters of memory beginning at c-addr.
2891**************************************************************************/
2892static void fill(FICL_VM *pVM)
2893{
2894 char ch = (char)stackPopINT32(pVM->pStack);
2895 UNS32 u = stackPopUNS32(pVM->pStack);
2896 char *cp = (char *)stackPopPtr(pVM->pStack);
2897
2898 while (u > 0)
2899 {
2900 *cp++ = ch;
2901 u--;
2902 }
2903
2904 return;
2905}
2906
2907
2908/**************************************************************************
2909 f i n d
2910** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2911** Find the definition named in the counted string at c-addr. If the
2912** definition is not found, return c-addr and zero. If the definition is
2913** found, return its execution token xt. If the definition is immediate,
2914** also return one (1), otherwise also return minus-one (-1). For a given
2915** string, the values returned by FIND while compiling may differ from
2916** those returned while not compiling.
2917**************************************************************************/
2918static void find(FICL_VM *pVM)
2919{
2920 FICL_STRING *sp = stackPopPtr(pVM->pStack);
2921 FICL_WORD *pFW;
2922 STRINGINFO si;
2923
2924 SI_PFS(si, sp);
2925 pFW = dictLookup(ficlGetDict(), si);
2926 if (pFW)
2927 {
2928 stackPushPtr(pVM->pStack, pFW);
2929 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
2930 }
2931 else
2932 {
2933 stackPushPtr(pVM->pStack, sp);
2934 stackPushUNS32(pVM->pStack, 0);
2935 }
2936 return;
2937}
2938
2939
2940/**************************************************************************
2941 f m S l a s h M o d
2942** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
2943** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
2944** Input and output stack arguments are signed. An ambiguous condition
2945** exists if n1 is zero or if the quotient lies outside the range of a
2946** single-cell signed integer.
2947**************************************************************************/
2948static void fmSlashMod(FICL_VM *pVM)
2949{
2950 INT64 d1;
2951 INT32 n1;
2952 INTQR qr;
2953
2954 n1 = stackPopINT32(pVM->pStack);
2955 d1 = i64Pop(pVM->pStack);
2956 qr = m64FlooredDivI(d1, n1);
2957 stackPushINT32(pVM->pStack, qr.rem);
2958 stackPushINT32(pVM->pStack, qr.quot);
2959 return;
2960}
2961
2962
2963/**************************************************************************
2964 s m S l a s h R e m
2965** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
2966** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
2967** Input and output stack arguments are signed. An ambiguous condition
2968** exists if n1 is zero or if the quotient lies outside the range of a
2969** single-cell signed integer.
2970**************************************************************************/
2971static void smSlashRem(FICL_VM *pVM)
2972{
2973 INT64 d1;
2974 INT32 n1;
2975 INTQR qr;
2976
2977 n1 = stackPopINT32(pVM->pStack);
2978 d1 = i64Pop(pVM->pStack);
2979 qr = m64SymmetricDivI(d1, n1);
2980 stackPushINT32(pVM->pStack, qr.rem);
2981 stackPushINT32(pVM->pStack, qr.quot);
2982 return;
2983}
2984
2985
2986static void ficlMod(FICL_VM *pVM)
2987{
2988 INT64 d1;
2989 INT32 n1;
2990 INTQR qr;
2991
2992 n1 = stackPopINT32(pVM->pStack);
2993 d1.lo = stackPopINT32(pVM->pStack);
2994 i64Extend(d1);
2995 qr = m64SymmetricDivI(d1, n1);
2996 stackPushINT32(pVM->pStack, qr.rem);
2997 return;
2998}
2999
3000
3001/**************************************************************************
3002 u m S l a s h M o d
3003** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3004** Divide ud by u1, giving the quotient u3 and the remainder u2.
3005** All values and arithmetic are unsigned. An ambiguous condition
3006** exists if u1 is zero or if the quotient lies outside the range of a
3007** single-cell unsigned integer.
3008*************************************************************************/
3009static void umSlashMod(FICL_VM *pVM)
3010{
3011 UNS64 ud;
3012 UNS32 u1;
3013 UNSQR qr;
3014
3015 u1 = stackPopUNS32(pVM->pStack);
3016 ud = u64Pop(pVM->pStack);
3017 qr = ficlLongDiv(ud, u1);
3018 stackPushUNS32(pVM->pStack, qr.rem);
3019 stackPushUNS32(pVM->pStack, qr.quot);
3020 return;
3021}
3022
3023
3024/**************************************************************************
3025 l s h i f t
3026** l-shift CORE ( x1 u -- x2 )
3027** Perform a logical left shift of u bit-places on x1, giving x2.
3028** Put zeroes into the least significant bits vacated by the shift.
3029** An ambiguous condition exists if u is greater than or equal to the
3030** number of bits in a cell.
3031**
3032** r-shift CORE ( x1 u -- x2 )
3033** Perform a logical right shift of u bit-places on x1, giving x2.
3034** Put zeroes into the most significant bits vacated by the shift. An
3035** ambiguous condition exists if u is greater than or equal to the
3036** number of bits in a cell.
3037**************************************************************************/
3038static void lshift(FICL_VM *pVM)
3039{
3040 UNS32 nBits = stackPopUNS32(pVM->pStack);
3041 UNS32 x1 = stackPopUNS32(pVM->pStack);
3042
3043 stackPushUNS32(pVM->pStack, x1 << nBits);
3044 return;
3045}
3046
3047
3048static void rshift(FICL_VM *pVM)
3049{
3050 UNS32 nBits = stackPopUNS32(pVM->pStack);
3051 UNS32 x1 = stackPopUNS32(pVM->pStack);
3052
3053 stackPushUNS32(pVM->pStack, x1 >> nBits);
3054 return;
3055}
3056
3057
3058/**************************************************************************
3059 m S t a r
3060** m-star CORE ( n1 n2 -- d )
3061** d is the signed product of n1 times n2.
3062**************************************************************************/
3063static void mStar(FICL_VM *pVM)
3064{
3065 INT32 n2 = stackPopINT32(pVM->pStack);
3066 INT32 n1 = stackPopINT32(pVM->pStack);
3067 INT64 d;
3068
3069 d = m64MulI(n1, n2);
3070 i64Push(pVM->pStack, d);
3071 return;
3072}
3073
3074
3075static void umStar(FICL_VM *pVM)
3076{
3077 UNS32 u2 = stackPopUNS32(pVM->pStack);
3078 UNS32 u1 = stackPopUNS32(pVM->pStack);
3079 UNS64 ud;
3080
3081 ud = ficlLongMul(u1, u2);
3082 u64Push(pVM->pStack, ud);
3083 return;
3084}
3085
3086
3087/**************************************************************************
3088 m a x & m i n
3089**
3090**************************************************************************/
3091static void ficlMax(FICL_VM *pVM)
3092{
3093 INT32 n2 = stackPopINT32(pVM->pStack);
3094 INT32 n1 = stackPopINT32(pVM->pStack);
3095
3096 stackPushINT32(pVM->pStack, (n1 > n2) ? n1 : n2);
3097 return;
3098}
3099
3100static void ficlMin(FICL_VM *pVM)
3101{
3102 INT32 n2 = stackPopINT32(pVM->pStack);
3103 INT32 n1 = stackPopINT32(pVM->pStack);
3104
3105 stackPushINT32(pVM->pStack, (n1 < n2) ? n1 : n2);
3106 return;
3107}
3108
3109
3110/**************************************************************************
3111 m o v e
3112** CORE ( addr1 addr2 u -- )
3113** If u is greater than zero, copy the contents of u consecutive address
3114** units at addr1 to the u consecutive address units at addr2. After MOVE
3115** completes, the u consecutive address units at addr2 contain exactly
3116** what the u consecutive address units at addr1 contained before the move.
3117** NOTE! This implementation assumes that a char is the same size as
3118** an address unit.
3119**************************************************************************/
3120static void move(FICL_VM *pVM)
3121{
3122 UNS32 u = stackPopUNS32(pVM->pStack);
3123 char *addr2 = stackPopPtr(pVM->pStack);
3124 char *addr1 = stackPopPtr(pVM->pStack);
3125
3126 if (u == 0)
3127 return;
3128 /*
3129 ** Do the copy carefully, so as to be
3130 ** correct even if the two ranges overlap
3131 */
3132 if (addr1 >= addr2)
3133 {
3134 for (; u > 0; u--)
3135 *addr2++ = *addr1++;
3136 }
3137 else
3138 {
3139 addr2 += u-1;
3140 addr1 += u-1;
3141 for (; u > 0; u--)
3142 *addr2-- = *addr1--;
3143 }
3144
3145 return;
3146}
3147
3148
3149/**************************************************************************
3150 r e c u r s e
3151**
3152**************************************************************************/
3153static void recurseCoIm(FICL_VM *pVM)
3154{
3155 FICL_DICT *pDict = ficlGetDict();
3156
3157 IGNORE(pVM);
3158 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3159 return;
3160}
3161
3162
3163/**************************************************************************
3164 s t o d
3165** s-to-d CORE ( n -- d )
3166** Convert the number n to the double-cell number d with the same
3167** numerical value.
3168**************************************************************************/
3169static void sToD(FICL_VM *pVM)
3170{
3171 INT32 s = stackPopINT32(pVM->pStack);
3172
3173 /* sign extend to 64 bits.. */
3174 stackPushINT32(pVM->pStack, s);
3175 stackPushINT32(pVM->pStack, (s < 0) ? -1 : 0);
3176 return;
3177}
3178
3179
3180/**************************************************************************
3181 s o u r c e
3182** CORE ( -- c-addr u )
3183** c-addr is the address of, and u is the number of characters in, the
3184** input buffer.
3185**************************************************************************/
3186static void source(FICL_VM *pVM)
3187{ int i;
3188
3189 stackPushPtr(pVM->pStack, pVM->tib.cp);
3190 for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++);
3191 stackPushINT32(pVM->pStack, i);
3192 return;
3193}
3194
3195
3196/**************************************************************************
3197 v e r s i o n
3198** non-standard...
3199**************************************************************************/
3200static void ficlVersion(FICL_VM *pVM)
3201{
3202 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3203 return;
3204}
3205
3206
3207/**************************************************************************
3208 t o I n
3209** to-in CORE
3210**************************************************************************/
3211static void toIn(FICL_VM *pVM)
3212{
3213 stackPushPtr(pVM->pStack, &pVM->tib.index);
3214 return;
3215}
3216
3217
3218/**************************************************************************
3219 d e f i n i t i o n s
3220** SEARCH ( -- )
3221** Make the compilation word list the same as the first word list in the
3222** search order. Specifies that the names of subsequent definitions will
3223** be placed in the compilation word list. Subsequent changes in the search
3224** order will not affect the compilation word list.
3225**************************************************************************/
3226static void definitions(FICL_VM *pVM)
3227{
3228 FICL_DICT *pDict = ficlGetDict();
3229
3230 assert(pDict);
3231 if (pDict->nLists < 1)
3232 {
3233 vmThrowErr(pVM, "DEFINITIONS error - empty search order");
3234 }
3235
3236 pDict->pCompile = pDict->pSearch[pDict->nLists-1];
3237 return;
3238}
3239
3240
3241/**************************************************************************
3242 f o r t h - w o r d l i s t
3243** SEARCH ( -- wid )
3244** Return wid, the identifier of the word list that includes all standard
3245** words provided by the implementation. This word list is initially the
3246** compilation word list and is part of the initial search order.
3247**************************************************************************/
3248static void forthWordlist(FICL_VM *pVM)
3249{
3250 FICL_HASH *pHash = ficlGetDict()->pForthWords;
3251 stackPushPtr(pVM->pStack, pHash);
3252 return;
3253}
3254
3255
3256/**************************************************************************
3257 g e t - c u r r e n t
3258** SEARCH ( -- wid )
3259** Return wid, the identifier of the compilation word list.
3260**************************************************************************/
3261static void getCurrent(FICL_VM *pVM)
3262{
3263 ficlLockDictionary(TRUE);
3264 stackPushPtr(pVM->pStack, ficlGetDict()->pCompile);
3265 ficlLockDictionary(FALSE);
3266 return;
3267}
3268
3269
3270/**************************************************************************
3271 g e t - o r d e r
3272** SEARCH ( -- widn ... wid1 n )
3273** Returns the number of word lists n in the search order and the word list
3274** identifiers widn ... wid1 identifying these word lists. wid1 identifies
3275** the word list that is searched first, and widn the word list that is
3276** searched last. The search order is unaffected.
3277**************************************************************************/
3278static void getOrder(FICL_VM *pVM)
3279{
3280 FICL_DICT *pDict = ficlGetDict();
3281 int nLists = pDict->nLists;
3282 int i;
3283
3284 ficlLockDictionary(TRUE);
3285 for (i = 0; i < nLists; i++)
3286 {
3287 stackPushPtr(pVM->pStack, pDict->pSearch[i]);
3288 }
3289
3290 stackPushUNS32(pVM->pStack, nLists);
3291 ficlLockDictionary(FALSE);
3292 return;
3293}
3294
3295
3296/**************************************************************************
3297 s e a r c h - w o r d l i s t
3298** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
3299** Find the definition identified by the string c-addr u in the word list
3300** identified by wid. If the definition is not found, return zero. If the
3301** definition is found, return its execution token xt and one (1) if the
3302** definition is immediate, minus-one (-1) otherwise.
3303**************************************************************************/
3304static void searchWordlist(FICL_VM *pVM)
3305{
3306 STRINGINFO si;
3307 UNS16 hashCode;
3308 FICL_WORD *pFW;
3309 FICL_HASH *pHash = stackPopPtr(pVM->pStack);
3310
3311 si.count = (FICL_COUNT)stackPopUNS32(pVM->pStack);
3312 si.cp = stackPopPtr(pVM->pStack);
3313 hashCode = hashHashCode(si);
3314
3315 ficlLockDictionary(TRUE);
3316 pFW = hashLookup(pHash, si, hashCode);
3317 ficlLockDictionary(FALSE);
3318
3319 if (pFW)
3320 {
3321 stackPushPtr(pVM->pStack, pFW);
3322 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
3323 }
3324 else
3325 {
3326 stackPushUNS32(pVM->pStack, 0);
3327 }
3328
3329 return;
3330}
3331
3332
3333/**************************************************************************
3334 s e t - c u r r e n t
3335** SEARCH ( wid -- )
3336** Set the compilation word list to the word list identified by wid.
3337**************************************************************************/
3338static void setCurrent(FICL_VM *pVM)
3339{
3340 FICL_HASH *pHash = stackPopPtr(pVM->pStack);
3341 FICL_DICT *pDict = ficlGetDict();
3342 ficlLockDictionary(TRUE);
3343 pDict->pCompile = pHash;
3344 ficlLockDictionary(FALSE);
3345 return;
3346}
3347
3348
3349/**************************************************************************
3350 s e t - o r d e r
3351** SEARCH ( widn ... wid1 n -- )
3352** Set the search order to the word lists identified by widn ... wid1.
3353** Subsequently, word list wid1 will be searched first, and word list
3354** widn searched last. If n is zero, empty the search order. If n is minus
3355** one, set the search order to the implementation-defined minimum
3356** search order. The minimum search order shall include the words
3357** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
3358** be at least eight.
3359**************************************************************************/
3360static void setOrder(FICL_VM *pVM)
3361{
3362 int i;
3363 int nLists = stackPopINT32(pVM->pStack);
3364 FICL_DICT *dp = ficlGetDict();
3365
3366 if (nLists > FICL_DEFAULT_VOCS)
3367 {
3368 vmThrowErr(pVM, "set-order error: list would be too large");
3369 }
3370
3371 ficlLockDictionary(TRUE);
3372
3373 if (nLists >= 0)
3374 {
3375 dp->nLists = nLists;
3376 for (i = nLists-1; i >= 0; --i)
3377 {
3378 dp->pSearch[i] = stackPopPtr(pVM->pStack);
3379 }
3380 }
3381 else
3382 {
3383 dictResetSearchOrder(dp);
3384 }
3385
3386 ficlLockDictionary(FALSE);
3387 return;
3388}
3389
3390
3391/**************************************************************************
3392 w o r d l i s t
3393** SEARCH ( -- wid )
3394** Create a new empty word list, returning its word list identifier wid.
3395** The new word list may be returned from a pool of preallocated word
3396** lists or may be dynamically allocated in data space. A system shall
3397** allow the creation of at least 8 new word lists in addition to any
3398** provided as part of the system.
3399** Notes:
3400** 1. ficl creates a new single-list hash in the dictionary and returns
3401** its address.
3402** 2. ficl-wordlist takes an arg off the stack indicating the number of
3403** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
3404** : wordlist 1 ficl-wordlist ;
3405**************************************************************************/
3406static void wordlist(FICL_VM *pVM)
3407{
3408 FICL_DICT *dp = ficlGetDict();
3409 FICL_HASH *pHash;
3410 UNS32 nBuckets;
3411
3412#if FICL_ROBUST > 1
3413 vmCheckStack(pVM, 1, 1);
3414#endif
3415 nBuckets = stackPopUNS32(pVM->pStack);
3416
3417 dictAlign(dp);
3418 pHash = (FICL_HASH *)dp->here;
3419 dictAllot(dp, sizeof (FICL_HASH)
3420 + (nBuckets-1) * sizeof (FICL_WORD *));
3421
3422 pHash->size = nBuckets;
3423 hashReset(pHash);
3424
3425 stackPushPtr(pVM->pStack, pHash);
3426 return;
3427}
3428
3429
3430/**************************************************************************
3431 S E A R C H >
3432** ficl ( -- wid )
3433** Pop wid off the search order. Error if the search order is empty
3434**************************************************************************/
3435static void searchPop(FICL_VM *pVM)
3436{
3437 FICL_DICT *dp = ficlGetDict();
3438 int nLists;
3439
3440 ficlLockDictionary(TRUE);
3441 nLists = dp->nLists;
3442 if (nLists == 0)
3443 {
3444 vmThrowErr(pVM, "search> error: empty search order");
3445 }
3446 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
3447 ficlLockDictionary(FALSE);
3448 return;
3449}
3450
3451
3452/**************************************************************************
3453 > S E A R C H
3454** ficl ( wid -- )
3455** Push wid onto the search order. Error if the search order is full.
3456**************************************************************************/
3457static void searchPush(FICL_VM *pVM)
3458{
3459 FICL_DICT *dp = ficlGetDict();
3460
3461 ficlLockDictionary(TRUE);
3462 if (dp->nLists > FICL_DEFAULT_VOCS)
3463 {
3464 vmThrowErr(pVM, ">search error: search order overflow");
3465 }
3466 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
3467 ficlLockDictionary(FALSE);
3468 return;
3469}
3470
3471
3472/**************************************************************************
3473 c o l o n N o N a m e
3474** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3475** Create an unnamed colon definition and push its address.
3476** Change state to compile.
3477**************************************************************************/
3478static void colonNoName(FICL_VM *pVM)
3479{
3480 FICL_DICT *dp = ficlGetDict();
3481 FICL_WORD *pFW;
3482 STRINGINFO si;
3483
3484 SI_SETLEN(si, 0);
3485 SI_SETPTR(si, NULL);
3486
3487 pVM->state = COMPILE;
3488 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3489 stackPushPtr(pVM->pStack, pFW);
3490 markControlTag(pVM, colonTag);
3491 return;
3492}
3493
3494
3495/**************************************************************************
3496 u s e r V a r i a b l e
3497** user ( u -- ) "<spaces>name"
3498** Get a name from the input stream and create a user variable
3499** with the name and the index supplied. The run-time effect
3500** of a user variable is to push the address of the indexed cell
3501** in the running vm's user array.
3502**
3503** User variables are vm local cells. Each vm has an array of
3504** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3505** Ficl's user facility is implemented with two primitives,
3506** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3507** holds the index of the next free user cell, and a redefinition
3508** (also in softcore) of "user" that defines a user word and increments
3509** nUser.
3510**************************************************************************/
3511#if FICL_WANT_USER
3512static void userParen(FICL_VM *pVM)
3513{
3514 INT32 i = pVM->runningWord->param[0].i;
3515 stackPushPtr(pVM->pStack, &pVM->user[i]);
3516 return;
3517}
3518
3519
3520static void userVariable(FICL_VM *pVM)
3521{
3522 FICL_DICT *dp = ficlGetDict();
3523 STRINGINFO si = vmGetWord(pVM);
3524 CELL c;
3525
3526 c = stackPop(pVM->pStack);
3527 if (c.i >= FICL_USER_CELLS)
3528 {
3529 vmThrowErr(pVM, "Error - out of user space");
3530 }
3531
3532 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3533 dictAppendCell(dp, c);
3534 return;
3535}
3536#endif
3537
3538
3539/**************************************************************************
3540 t o V a l u e
3541** CORE EXT
3542** Interpretation: ( x "<spaces>name" -- )
3543** Skip leading spaces and parse name delimited by a space. Store x in
3544** name. An ambiguous condition exists if name was not defined by VALUE.
3545** NOTE: In ficl, VALUE is an alias of CONSTANT
3546**************************************************************************/
3547static void toValue(FICL_VM *pVM)
3548{
3549 STRINGINFO si = vmGetWord(pVM);
3550 FICL_DICT *dp = ficlGetDict();
3551 FICL_WORD *pFW;
3552
3553#if FICL_WANT_LOCALS
3554 FICL_DICT *pLoc = ficlGetLoc();
3555 if ((nLocals > 0) && (pVM->state == COMPILE))
3556 {
3557 pFW = dictLookup(pLoc, si);
3558 if (pFW)
3559 {
3560 dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
3561 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3562 return;
3563 }
3564 }
3565#endif
3566
3567 assert(pStore);
3568
3569 pFW = dictLookup(dp, si);
3570 if (!pFW)
3571 {
3572 int i = SI_COUNT(si);
3573 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3574 }
3575
3576 if (pVM->state == INTERPRET)
3577 pFW->param[0] = stackPop(pVM->pStack);
3578 else /* compile code to store to word's param */
3579 {
3580 stackPushPtr(pVM->pStack, &pFW->param[0]);
3581 literalIm(pVM);
3582 dictAppendCell(dp, LVALUEtoCELL(pStore));
3583 }
3584 return;
3585}
3586
3587
3588#if FICL_WANT_LOCALS
3589/**************************************************************************
3590 l i n k P a r e n
3591** ( -- )
3592** Link a frame on the return stack, reserving nCells of space for
3593** locals - the value of nCells is the next cell in the instruction
3594** stream.
3595**************************************************************************/
3596static void linkParen(FICL_VM *pVM)
3597{
3598 INT32 nLink = *(INT32 *)(pVM->ip);
3599 vmBranchRelative(pVM, 1);
3600 stackLink(pVM->rStack, nLink);
3601 return;
3602}
3603
3604
3605static void unlinkParen(FICL_VM *pVM)
3606{
3607 stackUnlink(pVM->rStack);
3608 return;
3609}
3610
3611
3612/**************************************************************************
3613 d o L o c a l I m
3614** Immediate - cfa of a local while compiling - when executed, compiles
3615** code to fetch the value of a local given the local's index in the
3616** word's pfa
3617**************************************************************************/
3618static void getLocalParen(FICL_VM *pVM)
3619{
3620 INT32 nLocal = *(INT32 *)(pVM->ip++);
3621 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3622 return;
3623}
3624
3625
3626static void toLocalParen(FICL_VM *pVM)
3627{
3628 INT32 nLocal = *(INT32 *)(pVM->ip++);
3629 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3630 return;
3631}
3632
3633
3634static void getLocal0(FICL_VM *pVM)
3635{
3636 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3637 return;
3638}
3639
3640
3641static void toLocal0(FICL_VM *pVM)
3642{
3643 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3644 return;
3645}
3646
3647
3648static void getLocal1(FICL_VM *pVM)
3649{
3650 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3651 return;
3652}
3653
3654
3655static void toLocal1(FICL_VM *pVM)
3656{
3657 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
3658 return;
3659}
3660
3661
3662/*
3663** Each local is recorded in a private locals dictionary as a
3664** word that does doLocalIm at runtime. DoLocalIm compiles code
3665** into the client definition to fetch the value of the
3666** corresponding local variable from the return stack.
3667** The private dictionary gets initialized at the end of each block
3668** that uses locals (in ; and does> for example).
3669*/
3670static void doLocalIm(FICL_VM *pVM)
3671{
3672 FICL_DICT *pDict = ficlGetDict();
3673 int nLocal = pVM->runningWord->param[0].i;
3674
3675 if (pVM->state == INTERPRET)
3676 {
3677 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3678 }
3679 else
3680 {
3681
3682 if (nLocal == 0)
3683 {
3684 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0));
3685 }
3686 else if (nLocal == 1)
3687 {
3688 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1));
3689 }
3690 else
3691 {
3692 dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen));
3693 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
3694 }
3695 }
3696 return;
3697}
3698
3699
3700/**************************************************************************
3701 l o c a l P a r e n
3702** paren-local-paren LOCAL
3703** Interpretation: Interpretation semantics for this word are undefined.
3704** Execution: ( c-addr u -- )
3705** When executed during compilation, (LOCAL) passes a message to the
3706** system that has one of two meanings. If u is non-zero,
3707** the message identifies a new local whose definition name is given by
3708** the string of characters identified by c-addr u. If u is zero,
3709** the message is last local and c-addr has no significance.
3710**
3711** The result of executing (LOCAL) during compilation of a definition is
3712** to create a set of named local identifiers, each of which is
3713** a definition name, that only have execution semantics within the scope
3714** of that definition's source.
3715**
3716** local Execution: ( -- x )
3717**
3718** Push the local's value, x, onto the stack. The local's value is
3719** initialized as described in 13.3.3 Processing locals and may be
3720** changed by preceding the local's name with TO. An ambiguous condition
3721** exists when local is executed while in interpretation state.
3722**************************************************************************/
3723static void localParen(FICL_VM *pVM)
3724{
3725 static CELL *pMark = NULL;
3726 FICL_DICT *pDict = ficlGetDict();
3727 STRINGINFO si;
3728 SI_SETLEN(si, stackPopUNS32(pVM->pStack));
3729 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
3730
3731 if (SI_COUNT(si) > 0)
3732 { /* add a local to the dict and update nLocals */
3733 FICL_DICT *pLoc = ficlGetLoc();
3734 if (nLocals >= FICL_MAX_LOCALS)
3735 {
3736 vmThrowErr(pVM, "Error: out of local space");
3737 }
3738
3739 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
3740 dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
3741
3742 if (nLocals == 0)
3743 { /* compile code to create a local stack frame */
3744 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
3745 /* save location in dictionary for #locals */
3746 pMark = pDict->here;
3747 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3748 /* compile code to initialize first local */
3749 dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
3750 }
3751 else if (nLocals == 1)
3752 {
3753 dictAppendCell(pDict, LVALUEtoCELL(pToLocal1));
3754 }
3755 else
3756 {
3757 dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen));
3758 dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3759 }
3760
3761 nLocals++;
3762 }
3763 else if (nLocals > 0)
3764 { /* write nLocals to (link) param area in dictionary */
3765 *(INT32 *)pMark = nLocals;
3766 }
3767
3768 return;
3769}
3770
3771
3772#endif
3773/**************************************************************************
3774 setParentWid
3775** FICL
3776** setparentwid ( parent-wid wid -- )
3777** Set WID's link field to the parent-wid. search-wordlist will
3778** iterate through all the links when finding words in the child wid.
3779**************************************************************************/
3780static void setParentWid(FICL_VM *pVM)
3781{
3782 FICL_HASH *parent, *child;
3783#if FICL_ROBUST > 1
3784 vmCheckStack(pVM, 2, 0);
3785#endif
3786 child = (FICL_HASH *)stackPopPtr(pVM->pStack);
3787 parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
3788
3789 child->link = parent;
3790 return;
3791}
3792
3793
3794/**************************************************************************
3795 s e e
3796** TOOLS ( "<spaces>name" -- )
3797** Display a human-readable representation of the named word's definition.
3798** The source of the representation (object-code decompilation, source
3799** block, etc.) and the particular form of the display is implementation
3800** defined.
3801** NOTE: these funcs come late in the file because they reference all
3802** of the word-builder funcs without declaring them again. Call me lazy.
3803**************************************************************************/
3804/*
3805** isAFiclWord
3806** Vet a candidate pointer carefully to make sure
3807** it's not some chunk o' inline data...
3808** It has to have a name, and it has to look
3809** like it's in the dictionary address range.
3810** NOTE: this excludes :noname words!
3811*/
|
| 3812#ifdef FICL_TRACE
3813int isAFiclWord(FICL_WORD *pFW)
3814#else
|
3786static int isAFiclWord(FICL_WORD *pFW)
| 3815static int isAFiclWord(FICL_WORD *pFW)
|
| 3816#endif
|
3787{
3788 void *pv = (void *)pFW;
3789 FICL_DICT *pd = ficlGetDict();
3790
3791 if (!dictIncludes(pd, pFW))
3792 return 0;
3793
3794 if (!dictIncludes(pd, pFW->name))
3795 return 0;
3796
3797 return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0'));
3798}
3799
3800/*
3801** seeColon (for proctologists only)
3802** Walks a colon definition, decompiling
3803** on the fly. Knows about primitive control structures.
3804*/
3805static void seeColon(FICL_VM *pVM, CELL *pc)
3806{
3807 for (; pc->p != pSemiParen; pc++)
3808 {
3809 FICL_WORD *pFW = (FICL_WORD *)(pc->p);
3810
3811 if (isAFiclWord(pFW))
3812 {
3813 if (pFW->code == literalParen)
3814 {
3815 CELL v = *++pc;
3816 if (isAFiclWord(v.p))
3817 {
3818 FICL_WORD *pLit = (FICL_WORD *)v.p;
3819 sprintf(pVM->pad, " literal %.*s (%#lx)",
3820 pLit->nName, pLit->name, v.u);
3821 }
3822 else
3823 sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u);
3824 }
3825 else if (pFW->code == stringLit)
3826 {
3827 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
3828 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
3829 sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text);
3830 }
3831 else if (pFW->code == ifParen)
3832 {
3833 CELL c = *++pc;
3834 if (c.i > 0)
3835 sprintf(pVM->pad, " if / while (branch rel %ld)", c.i);
3836 else
3837 sprintf(pVM->pad, " until (branch rel %ld)", c.i);
3838 }
3839 else if (pFW->code == branchParen)
3840 {
3841 CELL c = *++pc;
3842 if (c.i > 0)
3843 sprintf(pVM->pad, " else (branch rel %ld)", c.i);
3844 else
3845 sprintf(pVM->pad, " repeat (branch rel %ld)", c.i);
3846 }
3847 else if (pFW->code == qDoParen)
3848 {
3849 CELL c = *++pc;
3850 sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u);
3851 }
3852 else if (pFW->code == doParen)
3853 {
3854 CELL c = *++pc;
3855 sprintf(pVM->pad, " do (leave abs %#lx)", c.u);
3856 }
3857 else if (pFW->code == loopParen)
3858 {
3859 CELL c = *++pc;
3860 sprintf(pVM->pad, " loop (branch rel %#ld)", c.i);
3861 }
3862 else if (pFW->code == plusLoopParen)
3863 {
3864 CELL c = *++pc;
3865 sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i);
3866 }
3867 else /* default: print word's name */
3868 {
3869 sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name);
3870 }
3871
3872 vmTextOut(pVM, pVM->pad, 1);
3873 }
3874 else /* probably not a word - punt and print value */
3875 {
3876 sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u);
3877 vmTextOut(pVM, pVM->pad, 1);
3878 }
3879 }
3880
3881 vmTextOut(pVM, ";", 1);
3882}
3883
3884/*
3885** Here's the outer part of the decompiler. It's
3886** just a big nested conditional that checks the
3887** CFA of the word to decompile for each kind of
3888** known word-builder code, and tries to do
3889** something appropriate. If the CFA is not recognized,
3890** just indicate that it is a primitive.
3891*/
3892static void see(FICL_VM *pVM)
3893{
3894 FICL_DICT *pd = ficlGetDict();
3895 FICL_WORD *pFW;
3896
3897 tick(pVM);
3898 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
3899
3900 if (pFW->code == colonParen)
3901 {
3902 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
3903 vmTextOut(pVM, pVM->pad, 1);
3904 seeColon(pVM, pFW->param);
3905 }
3906 else if (pFW->code == doDoes)
3907 {
3908 vmTextOut(pVM, "does>", 1);
3909 seeColon(pVM, (CELL *)pFW->param->p);
3910 }
3911 else if (pFW->code == createParen)
3912 {
3913 vmTextOut(pVM, "create", 1);
3914 }
3915 else if (pFW->code == variableParen)
3916 {
3917 sprintf(pVM->pad, "variable = %ld (%#lx)",
3918 pFW->param->i, pFW->param->u);
3919 vmTextOut(pVM, pVM->pad, 1);
3920 }
3921 else if (pFW->code == userParen)
3922 {
3923 sprintf(pVM->pad, "user variable %ld (%#lx)",
3924 pFW->param->i, pFW->param->u);
3925 vmTextOut(pVM, pVM->pad, 1);
3926 }
3927 else if (pFW->code == constantParen)
3928 {
3929 sprintf(pVM->pad, "constant = %ld (%#lx)",
3930 pFW->param->i, pFW->param->u);
3931 vmTextOut(pVM, pVM->pad, 1);
3932 }
3933 else
3934 {
3935 vmTextOut(pVM, "primitive", 1);
3936 }
3937
3938 if (pFW->flags & FW_IMMEDIATE)
3939 {
3940 vmTextOut(pVM, "immediate", 1);
3941 }
3942
3943 return;
3944}
3945
3946
3947/**************************************************************************
3948 c o m p a r e
3949** STRING ( c-addr1 u1 c-addr2 u2 -- n )
3950** Compare the string specified by c-addr1 u1 to the string specified by
3951** c-addr2 u2. The strings are compared, beginning at the given addresses,
3952** character by character, up to the length of the shorter string or until a
3953** difference is found. If the two strings are identical, n is zero. If the two
3954** strings are identical up to the length of the shorter string, n is minus-one
3955** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
3956** identical up to the length of the shorter string, n is minus-one (-1) if the
3957** first non-matching character in the string specified by c-addr1 u1 has a
3958** lesser numeric value than the corresponding character in the string specified
3959** by c-addr2 u2 and one (1) otherwise.
3960**************************************************************************/
3961static void compareString(FICL_VM *pVM)
3962{
3963 char *cp1, *cp2;
3964 UNS32 u1, u2, uMin;
3965 int n = 0;
3966
3967 vmCheckStack(pVM, 4, 1);
3968 u2 = stackPopUNS32(pVM->pStack);
3969 cp2 = (char *)stackPopPtr(pVM->pStack);
3970 u1 = stackPopUNS32(pVM->pStack);
3971 cp1 = (char *)stackPopPtr(pVM->pStack);
3972
3973 uMin = (u1 < u2)? u1 : u2;
3974 for ( ; (uMin > 0) && (n == 0); uMin--)
3975 {
3976 n = (int)(*cp1++ - *cp2++);
3977 }
3978
3979 if (n == 0)
3980 n = (int)(u1 - u2);
3981
3982 if (n < 0)
3983 n = -1;
3984 else if (n > 0)
3985 n = 1;
3986
3987 stackPushINT32(pVM->pStack, n);
3988 return;
3989}
3990
3991
3992/**************************************************************************
3993 r e f i l l
3994** CORE EXT ( -- flag )
3995** Attempt to fill the input buffer from the input source, returning a true
3996** flag if successful.
3997** When the input source is the user input device, attempt to receive input
3998** into the terminal input buffer. If successful, make the result the input
3999** buffer, set >IN to zero, and return true. Receipt of a line containing no
4000** characters is considered successful. If there is no input available from
4001** the current input source, return false.
4002** When the input source is a string from EVALUATE, return false and
4003** perform no other action.
4004**************************************************************************/
4005static void refill(FICL_VM *pVM)
4006{
4007 INT32 ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4008 stackPushINT32(pVM->pStack, ret);
4009 if (ret)
4010 vmThrow(pVM, VM_OUTOFTEXT);
4011 return;
4012}
4013
4014
4015/**************************************************************************
4016 f o r g e t
4017** TOOLS EXT ( "<spaces>name" -- )
4018** Skip leading space delimiters. Parse name delimited by a space.
4019** Find name, then delete name from the dictionary along with all
4020** words added to the dictionary after name. An ambiguous
4021** condition exists if name cannot be found.
4022**
4023** If the Search-Order word set is present, FORGET searches the
4024** compilation word list. An ambiguous condition exists if the
4025** compilation word list is deleted.
4026**************************************************************************/
4027static void forgetWid(FICL_VM *pVM)
4028{
4029 FICL_DICT *pDict = ficlGetDict();
4030 FICL_HASH *pHash;
4031
4032 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
4033 hashForget(pHash, pDict->here);
4034
4035 return;
4036}
4037
4038
4039static void forget(FICL_VM *pVM)
4040{
4041 void *where;
4042 FICL_DICT *pDict = ficlGetDict();
4043 FICL_HASH *pHash = pDict->pCompile;
4044
4045 tick(pVM);
4046 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
4047 hashForget(pHash, where);
4048 pDict->here = PTRtoCELL where;
4049
4050 return;
4051}
4052
4053/*************** freebsd added memory-alloc handling words ******************/
4054
4055static void allocate(FICL_VM *pVM)
4056{
4057 size_t size;
4058 void *p;
4059
4060 size = stackPopINT32(pVM->pStack);
4061 p = ficlMalloc(size);
4062 stackPushPtr(pVM->pStack, p);
4063 if (p)
4064 stackPushINT32(pVM->pStack, 0);
4065 else
4066 stackPushINT32(pVM->pStack, 1);
4067}
4068
4069static void free4th(FICL_VM *pVM)
4070{
4071 void *p;
4072
4073 p = stackPopPtr(pVM->pStack);
4074 ficlFree(p);
4075 stackPushINT32(pVM->pStack, 0);
4076}
4077
4078static void resize(FICL_VM *pVM)
4079{
4080 size_t size;
4081 void *new, *old;
4082
4083 size = stackPopINT32(pVM->pStack);
4084 old = stackPopPtr(pVM->pStack);
4085 new = ficlRealloc(old, size);
4086 if (new) {
4087 stackPushPtr(pVM->pStack, new);
4088 stackPushINT32(pVM->pStack, 0);
4089 } else {
4090 stackPushPtr(pVM->pStack, old);
4091 stackPushINT32(pVM->pStack, 1);
4092 }
4093}
4094
4095/***************** freebsd added exception handling words *******************/
4096
4097/*
4098 * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4099 * the word in ToS. If an exception happens, restore the state to what
4100 * it was before, and pushes the exception value on the stack. If not,
4101 * push zero.
4102 *
4103 * Notice that Catch implements an inner interpreter. This is ugly,
4104 * but given how ficl works, it cannot be helped. The problem is that
4105 * colon definitions will be executed *after* the function returns,
4106 * while "code" definitions will be executed immediately. I considered
4107 * other solutions to this problem, but all of them shared the same
4108 * basic problem (with added disadvantages): if ficl ever changes it's
4109 * inner thread modus operandi, one would have to fix this word.
4110 *
4111 * More comments can be found throughout catch's code.
4112 *
4113 * BUGS: do not handle locals unnesting correctly... I think...
4114 *
4115 * Daniel C. Sobral Jan 09/1999
4116 */
4117
4118static void catch(FICL_VM *pVM)
4119{
4120 int except;
4121 jmp_buf vmState;
4122 FICL_VM VM;
4123 FICL_STACK pStack;
4124 FICL_STACK rStack;
4125 FICL_WORD *pFW;
4126 IPTYPE exitIP;
4127
4128 /*
4129 * Get xt.
4130 * We need this *before* we save the stack pointer, or
4131 * we'll have to pop one element out of the stack after
4132 * an exception. I prefer to get done with it up front. :-)
4133 */
4134#if FICL_ROBUST > 1
4135 vmCheckStack(pVM, 1, 0);
4136#endif
4137 pFW = stackPopPtr(pVM->pStack);
4138
4139 /*
4140 * Save vm's state -- a catch will not back out environmental
4141 * changes.
4142 *
4143 * We are *not* saving dictionary state, since it is
4144 * global instead of per vm, and we are not saving
4145 * stack contents, since we are not required to (and,
4146 * thus, it would be useless). We save pVM, and pVM
4147 * "stacks" (a structure containing general information
4148 * about it, including the current stack pointer).
4149 */
4150 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4151 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4152 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4153
4154 /*
4155 * Give pVM a jmp_buf
4156 */
4157 pVM->pState = &vmState;
4158
4159 /*
4160 * Safety net
4161 */
4162 except = setjmp(vmState);
4163
4164 /*
4165 * And now, choose what to do depending on except.
4166 */
4167
4168 /* Things having gone wrong... */
4169 if(except) {
4170 /* Restore vm's state */
4171 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4172 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4173 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4174
4175 /* Push error */
4176 stackPushINT32(pVM->pStack, except);
4177
4178 /* Things being ok... */
4179 } else {
4180 /*
4181 * We need to know when to exit the inner loop
4182 * Colonp, the "code" for colon words, just pushes
4183 * the word's IP onto the RP, and expect the inner
4184 * interpreter to do the rest. Well, I'd rather have
4185 * it done *before* I return from this function,
4186 * losing the automatic variables I'm using to save
4187 * state. Sure, I could save this on dynamic memory
4188 * and save state on RP, or I could even implement
4189 * the poor man's version of this word in Forth with
4190 * sp@, sp!, rp@ and rp!, but we have a lot of state
4191 * neatly tucked away in pVM, so why not save it?
4192 */
4193 exitIP = pVM->ip;
4194
4195 /* Execute the xt -- inline code for vmExecute */
4196
4197 pVM->runningWord = pFW;
4198 pFW->code(pVM);
4199
4200 /*
4201 * Run the inner loop until we get back to exitIP
4202 */
4203 for (; pVM->ip != exitIP;) {
4204 pFW = *pVM->ip++;
4205
4206 /* Inline code for vmExecute */
4207 pVM->runningWord = pFW;
4208 pFW->code(pVM);
4209 }
4210
4211
4212 /* Restore just the setjmp vector */
4213 pVM->pState = VM.pState;
4214
4215 /* Push 0 -- everything is ok */
4216 stackPushINT32(pVM->pStack, 0);
4217 }
4218}
4219
4220/*
4221 * Throw -- maybe vmThow already do what's required, but I don't really
4222 * know what happens when you longjmp(buf, 0). From ANS Forth standard.
4223 *
4224 * Anyway, throw takes the ToS and, if that's different from zero,
4225 * returns to the last executed catch context. Further throws will
4226 * unstack previously executed "catches", in LIFO mode.
4227 *
4228 * Daniel C. Sobral Jan 09/1999
4229 */
4230
4231static void throw(FICL_VM *pVM)
4232{
4233 int except;
4234
4235 except = stackPopINT32(pVM->pStack);
4236
4237 if (except)
4238 vmThrow(pVM, except);
4239}
4240
4241/************************* freebsd added I/O words **************************/
4242
4243/* fopen - open a file and return new fd on stack.
4244 *
4245 * fopen ( count ptr -- fd )
4246 */
4247static void pfopen(FICL_VM *pVM)
4248{
4249 int fd;
4250 char *p;
4251
4252#if FICL_ROBUST > 1
4253 vmCheckStack(pVM, 2, 1);
4254#endif
4255 (void)stackPopINT32(pVM->pStack); /* don't need count value */
4256 p = stackPopPtr(pVM->pStack);
4257 fd = open(p, O_RDONLY);
4258 stackPushINT32(pVM->pStack, fd);
4259 return;
4260}
4261
4262/* fclose - close a file who's fd is on stack.
4263 *
4264 * fclose ( fd -- )
4265 */
4266static void pfclose(FICL_VM *pVM)
4267{
4268 int fd;
4269
4270#if FICL_ROBUST > 1
4271 vmCheckStack(pVM, 1, 0);
4272#endif
4273 fd = stackPopINT32(pVM->pStack); /* get fd */
4274 if (fd != -1)
4275 close(fd);
4276 return;
4277}
4278
4279/* fread - read file contents
4280 *
4281 * fread ( fd buf nbytes -- nread )
4282 */
4283static void pfread(FICL_VM *pVM)
4284{
4285 int fd, len;
4286 char *buf;
4287
4288#if FICL_ROBUST > 1
4289 vmCheckStack(pVM, 3, 1);
4290#endif
4291 len = stackPopINT32(pVM->pStack); /* get number of bytes to read */
4292 buf = stackPopPtr(pVM->pStack); /* get buffer */
4293 fd = stackPopINT32(pVM->pStack); /* get fd */
4294 if (len > 0 && buf && fd != -1)
4295 stackPushINT32(pVM->pStack, read(fd, buf, len));
4296 else
4297 stackPushINT32(pVM->pStack, -1);
4298 return;
4299}
4300
4301/* fload - interpret file contents
4302 *
4303 * fload ( fd -- )
4304 */
4305static void pfload(FICL_VM *pVM)
4306{
4307 int fd;
4308
4309#if FICL_ROBUST > 1
4310 vmCheckStack(pVM, 1, 0);
4311#endif
4312 fd = stackPopINT32(pVM->pStack); /* get fd */
4313 if (fd != -1)
4314 ficlExecFD(pVM, fd);
4315 return;
4316}
4317
4318/* key - get a character from stdin
4319 *
4320 * key ( -- char )
4321 */
4322static void key(FICL_VM *pVM)
4323{
4324#if FICL_ROBUST > 1
4325 vmCheckStack(pVM, 0, 1);
4326#endif
4327 stackPushINT32(pVM->pStack, getchar());
4328 return;
4329}
4330
4331/* key? - check for a character from stdin (FACILITY)
4332 *
4333 * key? ( -- flag )
4334 */
4335static void keyQuestion(FICL_VM *pVM)
4336{
4337#if FICL_ROBUST > 1
4338 vmCheckStack(pVM, 0, 1);
4339#endif
4340#ifdef TESTMAIN
4341 /* XXX Since we don't fiddle with termios, let it always succeed... */
4342 stackPushINT32(pVM->pStack, FICL_TRUE);
4343#else
4344 /* But here do the right thing. */
4345 stackPushINT32(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
4346#endif
4347 return;
4348}
4349
4350/* seconds - gives number of seconds since beginning of time
4351 *
4352 * beginning of time is defined as:
4353 *
4354 * BTX - number of seconds since midnight
4355 * FreeBSD - number of seconds since Jan 1 1970
4356 *
4357 * seconds ( -- u )
4358 */
4359static void pseconds(FICL_VM *pVM)
4360{
4361#if FICL_ROBUST > 1
4362 vmCheckStack(pVM,0,1);
4363#endif
4364 stackPushUNS32(pVM->pStack, (u_int32_t) time(NULL));
4365 return;
4366}
4367
4368/* ms - wait at least that many milliseconds (FACILITY)
4369 *
4370 * ms ( u -- )
4371 *
4372 */
4373static void ms(FICL_VM *pVM)
4374{
4375#if FICL_ROBUST > 1
4376 vmCheckStack(pVM,1,0);
4377#endif
4378#ifdef TESTMAIN
4379 usleep(stackPopUNS32(pVM->pStack)*1000);
4380#else
4381 delay(stackPopUNS32(pVM->pStack)*1000);
4382#endif
4383 return;
4384}
4385
4386/* fkey - get a character from a file
4387 *
4388 * fkey ( file -- char )
4389 */
4390static void fkey(FICL_VM *pVM)
4391{
4392 int i, fd;
4393 char ch;
4394
4395#if FICL_ROBUST > 1
4396 vmCheckStack(pVM, 1, 1);
4397#endif
4398 fd = stackPopINT32(pVM->pStack);
4399 i = read(fd, &ch, 1);
4400 stackPushINT32(pVM->pStack, i > 0 ? ch : -1);
4401 return;
4402}
4403
| 3817{
3818 void *pv = (void *)pFW;
3819 FICL_DICT *pd = ficlGetDict();
3820
3821 if (!dictIncludes(pd, pFW))
3822 return 0;
3823
3824 if (!dictIncludes(pd, pFW->name))
3825 return 0;
3826
3827 return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0'));
3828}
3829
3830/*
3831** seeColon (for proctologists only)
3832** Walks a colon definition, decompiling
3833** on the fly. Knows about primitive control structures.
3834*/
3835static void seeColon(FICL_VM *pVM, CELL *pc)
3836{
3837 for (; pc->p != pSemiParen; pc++)
3838 {
3839 FICL_WORD *pFW = (FICL_WORD *)(pc->p);
3840
3841 if (isAFiclWord(pFW))
3842 {
3843 if (pFW->code == literalParen)
3844 {
3845 CELL v = *++pc;
3846 if (isAFiclWord(v.p))
3847 {
3848 FICL_WORD *pLit = (FICL_WORD *)v.p;
3849 sprintf(pVM->pad, " literal %.*s (%#lx)",
3850 pLit->nName, pLit->name, v.u);
3851 }
3852 else
3853 sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u);
3854 }
3855 else if (pFW->code == stringLit)
3856 {
3857 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
3858 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
3859 sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text);
3860 }
3861 else if (pFW->code == ifParen)
3862 {
3863 CELL c = *++pc;
3864 if (c.i > 0)
3865 sprintf(pVM->pad, " if / while (branch rel %ld)", c.i);
3866 else
3867 sprintf(pVM->pad, " until (branch rel %ld)", c.i);
3868 }
3869 else if (pFW->code == branchParen)
3870 {
3871 CELL c = *++pc;
3872 if (c.i > 0)
3873 sprintf(pVM->pad, " else (branch rel %ld)", c.i);
3874 else
3875 sprintf(pVM->pad, " repeat (branch rel %ld)", c.i);
3876 }
3877 else if (pFW->code == qDoParen)
3878 {
3879 CELL c = *++pc;
3880 sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u);
3881 }
3882 else if (pFW->code == doParen)
3883 {
3884 CELL c = *++pc;
3885 sprintf(pVM->pad, " do (leave abs %#lx)", c.u);
3886 }
3887 else if (pFW->code == loopParen)
3888 {
3889 CELL c = *++pc;
3890 sprintf(pVM->pad, " loop (branch rel %#ld)", c.i);
3891 }
3892 else if (pFW->code == plusLoopParen)
3893 {
3894 CELL c = *++pc;
3895 sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i);
3896 }
3897 else /* default: print word's name */
3898 {
3899 sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name);
3900 }
3901
3902 vmTextOut(pVM, pVM->pad, 1);
3903 }
3904 else /* probably not a word - punt and print value */
3905 {
3906 sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u);
3907 vmTextOut(pVM, pVM->pad, 1);
3908 }
3909 }
3910
3911 vmTextOut(pVM, ";", 1);
3912}
3913
3914/*
3915** Here's the outer part of the decompiler. It's
3916** just a big nested conditional that checks the
3917** CFA of the word to decompile for each kind of
3918** known word-builder code, and tries to do
3919** something appropriate. If the CFA is not recognized,
3920** just indicate that it is a primitive.
3921*/
3922static void see(FICL_VM *pVM)
3923{
3924 FICL_DICT *pd = ficlGetDict();
3925 FICL_WORD *pFW;
3926
3927 tick(pVM);
3928 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
3929
3930 if (pFW->code == colonParen)
3931 {
3932 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
3933 vmTextOut(pVM, pVM->pad, 1);
3934 seeColon(pVM, pFW->param);
3935 }
3936 else if (pFW->code == doDoes)
3937 {
3938 vmTextOut(pVM, "does>", 1);
3939 seeColon(pVM, (CELL *)pFW->param->p);
3940 }
3941 else if (pFW->code == createParen)
3942 {
3943 vmTextOut(pVM, "create", 1);
3944 }
3945 else if (pFW->code == variableParen)
3946 {
3947 sprintf(pVM->pad, "variable = %ld (%#lx)",
3948 pFW->param->i, pFW->param->u);
3949 vmTextOut(pVM, pVM->pad, 1);
3950 }
3951 else if (pFW->code == userParen)
3952 {
3953 sprintf(pVM->pad, "user variable %ld (%#lx)",
3954 pFW->param->i, pFW->param->u);
3955 vmTextOut(pVM, pVM->pad, 1);
3956 }
3957 else if (pFW->code == constantParen)
3958 {
3959 sprintf(pVM->pad, "constant = %ld (%#lx)",
3960 pFW->param->i, pFW->param->u);
3961 vmTextOut(pVM, pVM->pad, 1);
3962 }
3963 else
3964 {
3965 vmTextOut(pVM, "primitive", 1);
3966 }
3967
3968 if (pFW->flags & FW_IMMEDIATE)
3969 {
3970 vmTextOut(pVM, "immediate", 1);
3971 }
3972
3973 return;
3974}
3975
3976
3977/**************************************************************************
3978 c o m p a r e
3979** STRING ( c-addr1 u1 c-addr2 u2 -- n )
3980** Compare the string specified by c-addr1 u1 to the string specified by
3981** c-addr2 u2. The strings are compared, beginning at the given addresses,
3982** character by character, up to the length of the shorter string or until a
3983** difference is found. If the two strings are identical, n is zero. If the two
3984** strings are identical up to the length of the shorter string, n is minus-one
3985** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
3986** identical up to the length of the shorter string, n is minus-one (-1) if the
3987** first non-matching character in the string specified by c-addr1 u1 has a
3988** lesser numeric value than the corresponding character in the string specified
3989** by c-addr2 u2 and one (1) otherwise.
3990**************************************************************************/
3991static void compareString(FICL_VM *pVM)
3992{
3993 char *cp1, *cp2;
3994 UNS32 u1, u2, uMin;
3995 int n = 0;
3996
3997 vmCheckStack(pVM, 4, 1);
3998 u2 = stackPopUNS32(pVM->pStack);
3999 cp2 = (char *)stackPopPtr(pVM->pStack);
4000 u1 = stackPopUNS32(pVM->pStack);
4001 cp1 = (char *)stackPopPtr(pVM->pStack);
4002
4003 uMin = (u1 < u2)? u1 : u2;
4004 for ( ; (uMin > 0) && (n == 0); uMin--)
4005 {
4006 n = (int)(*cp1++ - *cp2++);
4007 }
4008
4009 if (n == 0)
4010 n = (int)(u1 - u2);
4011
4012 if (n < 0)
4013 n = -1;
4014 else if (n > 0)
4015 n = 1;
4016
4017 stackPushINT32(pVM->pStack, n);
4018 return;
4019}
4020
4021
4022/**************************************************************************
4023 r e f i l l
4024** CORE EXT ( -- flag )
4025** Attempt to fill the input buffer from the input source, returning a true
4026** flag if successful.
4027** When the input source is the user input device, attempt to receive input
4028** into the terminal input buffer. If successful, make the result the input
4029** buffer, set >IN to zero, and return true. Receipt of a line containing no
4030** characters is considered successful. If there is no input available from
4031** the current input source, return false.
4032** When the input source is a string from EVALUATE, return false and
4033** perform no other action.
4034**************************************************************************/
4035static void refill(FICL_VM *pVM)
4036{
4037 INT32 ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4038 stackPushINT32(pVM->pStack, ret);
4039 if (ret)
4040 vmThrow(pVM, VM_OUTOFTEXT);
4041 return;
4042}
4043
4044
4045/**************************************************************************
4046 f o r g e t
4047** TOOLS EXT ( "<spaces>name" -- )
4048** Skip leading space delimiters. Parse name delimited by a space.
4049** Find name, then delete name from the dictionary along with all
4050** words added to the dictionary after name. An ambiguous
4051** condition exists if name cannot be found.
4052**
4053** If the Search-Order word set is present, FORGET searches the
4054** compilation word list. An ambiguous condition exists if the
4055** compilation word list is deleted.
4056**************************************************************************/
4057static void forgetWid(FICL_VM *pVM)
4058{
4059 FICL_DICT *pDict = ficlGetDict();
4060 FICL_HASH *pHash;
4061
4062 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
4063 hashForget(pHash, pDict->here);
4064
4065 return;
4066}
4067
4068
4069static void forget(FICL_VM *pVM)
4070{
4071 void *where;
4072 FICL_DICT *pDict = ficlGetDict();
4073 FICL_HASH *pHash = pDict->pCompile;
4074
4075 tick(pVM);
4076 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
4077 hashForget(pHash, where);
4078 pDict->here = PTRtoCELL where;
4079
4080 return;
4081}
4082
4083/*************** freebsd added memory-alloc handling words ******************/
4084
4085static void allocate(FICL_VM *pVM)
4086{
4087 size_t size;
4088 void *p;
4089
4090 size = stackPopINT32(pVM->pStack);
4091 p = ficlMalloc(size);
4092 stackPushPtr(pVM->pStack, p);
4093 if (p)
4094 stackPushINT32(pVM->pStack, 0);
4095 else
4096 stackPushINT32(pVM->pStack, 1);
4097}
4098
4099static void free4th(FICL_VM *pVM)
4100{
4101 void *p;
4102
4103 p = stackPopPtr(pVM->pStack);
4104 ficlFree(p);
4105 stackPushINT32(pVM->pStack, 0);
4106}
4107
4108static void resize(FICL_VM *pVM)
4109{
4110 size_t size;
4111 void *new, *old;
4112
4113 size = stackPopINT32(pVM->pStack);
4114 old = stackPopPtr(pVM->pStack);
4115 new = ficlRealloc(old, size);
4116 if (new) {
4117 stackPushPtr(pVM->pStack, new);
4118 stackPushINT32(pVM->pStack, 0);
4119 } else {
4120 stackPushPtr(pVM->pStack, old);
4121 stackPushINT32(pVM->pStack, 1);
4122 }
4123}
4124
4125/***************** freebsd added exception handling words *******************/
4126
4127/*
4128 * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4129 * the word in ToS. If an exception happens, restore the state to what
4130 * it was before, and pushes the exception value on the stack. If not,
4131 * push zero.
4132 *
4133 * Notice that Catch implements an inner interpreter. This is ugly,
4134 * but given how ficl works, it cannot be helped. The problem is that
4135 * colon definitions will be executed *after* the function returns,
4136 * while "code" definitions will be executed immediately. I considered
4137 * other solutions to this problem, but all of them shared the same
4138 * basic problem (with added disadvantages): if ficl ever changes it's
4139 * inner thread modus operandi, one would have to fix this word.
4140 *
4141 * More comments can be found throughout catch's code.
4142 *
4143 * BUGS: do not handle locals unnesting correctly... I think...
4144 *
4145 * Daniel C. Sobral Jan 09/1999
4146 */
4147
4148static void catch(FICL_VM *pVM)
4149{
4150 int except;
4151 jmp_buf vmState;
4152 FICL_VM VM;
4153 FICL_STACK pStack;
4154 FICL_STACK rStack;
4155 FICL_WORD *pFW;
4156 IPTYPE exitIP;
4157
4158 /*
4159 * Get xt.
4160 * We need this *before* we save the stack pointer, or
4161 * we'll have to pop one element out of the stack after
4162 * an exception. I prefer to get done with it up front. :-)
4163 */
4164#if FICL_ROBUST > 1
4165 vmCheckStack(pVM, 1, 0);
4166#endif
4167 pFW = stackPopPtr(pVM->pStack);
4168
4169 /*
4170 * Save vm's state -- a catch will not back out environmental
4171 * changes.
4172 *
4173 * We are *not* saving dictionary state, since it is
4174 * global instead of per vm, and we are not saving
4175 * stack contents, since we are not required to (and,
4176 * thus, it would be useless). We save pVM, and pVM
4177 * "stacks" (a structure containing general information
4178 * about it, including the current stack pointer).
4179 */
4180 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4181 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4182 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4183
4184 /*
4185 * Give pVM a jmp_buf
4186 */
4187 pVM->pState = &vmState;
4188
4189 /*
4190 * Safety net
4191 */
4192 except = setjmp(vmState);
4193
4194 /*
4195 * And now, choose what to do depending on except.
4196 */
4197
4198 /* Things having gone wrong... */
4199 if(except) {
4200 /* Restore vm's state */
4201 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4202 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4203 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4204
4205 /* Push error */
4206 stackPushINT32(pVM->pStack, except);
4207
4208 /* Things being ok... */
4209 } else {
4210 /*
4211 * We need to know when to exit the inner loop
4212 * Colonp, the "code" for colon words, just pushes
4213 * the word's IP onto the RP, and expect the inner
4214 * interpreter to do the rest. Well, I'd rather have
4215 * it done *before* I return from this function,
4216 * losing the automatic variables I'm using to save
4217 * state. Sure, I could save this on dynamic memory
4218 * and save state on RP, or I could even implement
4219 * the poor man's version of this word in Forth with
4220 * sp@, sp!, rp@ and rp!, but we have a lot of state
4221 * neatly tucked away in pVM, so why not save it?
4222 */
4223 exitIP = pVM->ip;
4224
4225 /* Execute the xt -- inline code for vmExecute */
4226
4227 pVM->runningWord = pFW;
4228 pFW->code(pVM);
4229
4230 /*
4231 * Run the inner loop until we get back to exitIP
4232 */
4233 for (; pVM->ip != exitIP;) {
4234 pFW = *pVM->ip++;
4235
4236 /* Inline code for vmExecute */
4237 pVM->runningWord = pFW;
4238 pFW->code(pVM);
4239 }
4240
4241
4242 /* Restore just the setjmp vector */
4243 pVM->pState = VM.pState;
4244
4245 /* Push 0 -- everything is ok */
4246 stackPushINT32(pVM->pStack, 0);
4247 }
4248}
4249
4250/*
4251 * Throw -- maybe vmThow already do what's required, but I don't really
4252 * know what happens when you longjmp(buf, 0). From ANS Forth standard.
4253 *
4254 * Anyway, throw takes the ToS and, if that's different from zero,
4255 * returns to the last executed catch context. Further throws will
4256 * unstack previously executed "catches", in LIFO mode.
4257 *
4258 * Daniel C. Sobral Jan 09/1999
4259 */
4260
4261static void throw(FICL_VM *pVM)
4262{
4263 int except;
4264
4265 except = stackPopINT32(pVM->pStack);
4266
4267 if (except)
4268 vmThrow(pVM, except);
4269}
4270
4271/************************* freebsd added I/O words **************************/
4272
4273/* fopen - open a file and return new fd on stack.
4274 *
4275 * fopen ( count ptr -- fd )
4276 */
4277static void pfopen(FICL_VM *pVM)
4278{
4279 int fd;
4280 char *p;
4281
4282#if FICL_ROBUST > 1
4283 vmCheckStack(pVM, 2, 1);
4284#endif
4285 (void)stackPopINT32(pVM->pStack); /* don't need count value */
4286 p = stackPopPtr(pVM->pStack);
4287 fd = open(p, O_RDONLY);
4288 stackPushINT32(pVM->pStack, fd);
4289 return;
4290}
4291
4292/* fclose - close a file who's fd is on stack.
4293 *
4294 * fclose ( fd -- )
4295 */
4296static void pfclose(FICL_VM *pVM)
4297{
4298 int fd;
4299
4300#if FICL_ROBUST > 1
4301 vmCheckStack(pVM, 1, 0);
4302#endif
4303 fd = stackPopINT32(pVM->pStack); /* get fd */
4304 if (fd != -1)
4305 close(fd);
4306 return;
4307}
4308
4309/* fread - read file contents
4310 *
4311 * fread ( fd buf nbytes -- nread )
4312 */
4313static void pfread(FICL_VM *pVM)
4314{
4315 int fd, len;
4316 char *buf;
4317
4318#if FICL_ROBUST > 1
4319 vmCheckStack(pVM, 3, 1);
4320#endif
4321 len = stackPopINT32(pVM->pStack); /* get number of bytes to read */
4322 buf = stackPopPtr(pVM->pStack); /* get buffer */
4323 fd = stackPopINT32(pVM->pStack); /* get fd */
4324 if (len > 0 && buf && fd != -1)
4325 stackPushINT32(pVM->pStack, read(fd, buf, len));
4326 else
4327 stackPushINT32(pVM->pStack, -1);
4328 return;
4329}
4330
4331/* fload - interpret file contents
4332 *
4333 * fload ( fd -- )
4334 */
4335static void pfload(FICL_VM *pVM)
4336{
4337 int fd;
4338
4339#if FICL_ROBUST > 1
4340 vmCheckStack(pVM, 1, 0);
4341#endif
4342 fd = stackPopINT32(pVM->pStack); /* get fd */
4343 if (fd != -1)
4344 ficlExecFD(pVM, fd);
4345 return;
4346}
4347
4348/* key - get a character from stdin
4349 *
4350 * key ( -- char )
4351 */
4352static void key(FICL_VM *pVM)
4353{
4354#if FICL_ROBUST > 1
4355 vmCheckStack(pVM, 0, 1);
4356#endif
4357 stackPushINT32(pVM->pStack, getchar());
4358 return;
4359}
4360
4361/* key? - check for a character from stdin (FACILITY)
4362 *
4363 * key? ( -- flag )
4364 */
4365static void keyQuestion(FICL_VM *pVM)
4366{
4367#if FICL_ROBUST > 1
4368 vmCheckStack(pVM, 0, 1);
4369#endif
4370#ifdef TESTMAIN
4371 /* XXX Since we don't fiddle with termios, let it always succeed... */
4372 stackPushINT32(pVM->pStack, FICL_TRUE);
4373#else
4374 /* But here do the right thing. */
4375 stackPushINT32(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
4376#endif
4377 return;
4378}
4379
4380/* seconds - gives number of seconds since beginning of time
4381 *
4382 * beginning of time is defined as:
4383 *
4384 * BTX - number of seconds since midnight
4385 * FreeBSD - number of seconds since Jan 1 1970
4386 *
4387 * seconds ( -- u )
4388 */
4389static void pseconds(FICL_VM *pVM)
4390{
4391#if FICL_ROBUST > 1
4392 vmCheckStack(pVM,0,1);
4393#endif
4394 stackPushUNS32(pVM->pStack, (u_int32_t) time(NULL));
4395 return;
4396}
4397
4398/* ms - wait at least that many milliseconds (FACILITY)
4399 *
4400 * ms ( u -- )
4401 *
4402 */
4403static void ms(FICL_VM *pVM)
4404{
4405#if FICL_ROBUST > 1
4406 vmCheckStack(pVM,1,0);
4407#endif
4408#ifdef TESTMAIN
4409 usleep(stackPopUNS32(pVM->pStack)*1000);
4410#else
4411 delay(stackPopUNS32(pVM->pStack)*1000);
4412#endif
4413 return;
4414}
4415
4416/* fkey - get a character from a file
4417 *
4418 * fkey ( file -- char )
4419 */
4420static void fkey(FICL_VM *pVM)
4421{
4422 int i, fd;
4423 char ch;
4424
4425#if FICL_ROBUST > 1
4426 vmCheckStack(pVM, 1, 1);
4427#endif
4428 fd = stackPopINT32(pVM->pStack);
4429 i = read(fd, &ch, 1);
4430 stackPushINT32(pVM->pStack, i > 0 ? ch : -1);
4431 return;
4432}
4433
|
| 4434/************************* freebsd added trace ***************************/
|
4404
| 4435
|
| 4436#ifdef FICL_TRACE
4437static void ficlTrace(FICL_VM *pVM)
4438{
4439#if FICL_ROBUST > 1
4440 vmCheckStack(pVM, 1, 1);
4441#endif
4442
4443 ficl_trace = stackPopINT32(pVM->pStack);
4444}
4445#endif
4446
|
4405/**************************************************************************
4406 f i c l C o m p i l e C o r e
4407** Builds the primitive wordset and the environment-query namespace.
4408**************************************************************************/
4409
4410void ficlCompileCore(FICL_DICT *dp)
4411{
4412 assert (dp);
4413
4414 /*
4415 ** CORE word set
4416 ** see softcore.c for definitions of: abs bl space spaces abort"
4417 */
4418 pStore =
4419 dictAppendWord(dp, "!", store, FW_DEFAULT);
4420 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4421 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4422 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4423 dictAppendWord(dp, "\'", tick, FW_DEFAULT);
4424 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4425 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4426 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4427 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4428 dictAppendWord(dp, "+", add, FW_DEFAULT);
4429 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4430 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4431 pComma =
4432 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4433 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4434 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4435 dictAppendWord(dp, ".#", displayCellNoPad, FW_DEFAULT);
4436 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4437 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4438 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4439 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4440 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4441 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4442 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4443 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4444 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4445 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4446 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4447 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4448 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4449 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4450 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4451 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4452 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4453 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4454 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4455 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4456 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4457 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4458 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4459 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4460 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4461 dictAppendWord(dp, ">r", toRStack, FW_DEFAULT);
4462 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4463 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4464 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4465 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4466 dictAppendWord(dp, "align", align, FW_DEFAULT);
4467 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4468 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4469 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4470 dictAppendWord(dp, "base", base, FW_DEFAULT);
4471 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4472 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4473 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4474 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4475 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4476 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4477 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4478 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4479 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4480 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4481 dictAppendWord(dp, "count", count, FW_DEFAULT);
4482 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4483 dictAppendWord(dp, "create", create, FW_DEFAULT);
4484 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4485 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4486 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4487 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4488 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4489 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4490 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4491 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4492 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4493 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4494 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4495 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4496 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4497 dictAppendWord(dp, "find", find, FW_DEFAULT);
4498 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4499 dictAppendWord(dp, "here", here, FW_DEFAULT);
4500 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4501 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4502 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4503 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4504 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4505 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4506 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4507 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4508 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4509 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4510 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4511 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4512 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4513 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4514 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4515 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4516 dictAppendWord(dp, "move", move, FW_DEFAULT);
4517 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4518 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4519 dictAppendWord(dp, "over", over, FW_DEFAULT);
4520 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4521 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4522 dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT);
4523 dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT);
4524 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4525 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4526 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4527 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4528 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4529 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4530 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4531 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4532 dictAppendWord(dp, "source", source, FW_DEFAULT);
4533 dictAppendWord(dp, "state", state, FW_DEFAULT);
4534 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4535 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4536 pType =
4537 dictAppendWord(dp, "type", type, FW_DEFAULT);
4538 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4539 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4540 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4541 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4542 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4543 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4544 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4545 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4546 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4547 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4548 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4549 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4550 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4551 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4552 /*
4553 ** CORE EXT word set...
4554 ** see softcore.c for other definitions
4555 */
4556 dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);
4557 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4558 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4559 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4560 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4561 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4562 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4563 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4564 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4565 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4566
4567 /* FreeBSD extension words */
4568 dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT);
4569 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT);
4570 dictAppendWord(dp, "fread", pfread, FW_DEFAULT);
4571 dictAppendWord(dp, "fload", pfload, FW_DEFAULT);
4572 dictAppendWord(dp, "fkey", fkey, FW_DEFAULT);
4573 dictAppendWord(dp, "key", key, FW_DEFAULT);
4574 dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT);
4575 dictAppendWord(dp, "ms", ms, FW_DEFAULT);
4576 dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT);
| 4447/**************************************************************************
4448 f i c l C o m p i l e C o r e
4449** Builds the primitive wordset and the environment-query namespace.
4450**************************************************************************/
4451
4452void ficlCompileCore(FICL_DICT *dp)
4453{
4454 assert (dp);
4455
4456 /*
4457 ** CORE word set
4458 ** see softcore.c for definitions of: abs bl space spaces abort"
4459 */
4460 pStore =
4461 dictAppendWord(dp, "!", store, FW_DEFAULT);
4462 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4463 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4464 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4465 dictAppendWord(dp, "\'", tick, FW_DEFAULT);
4466 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4467 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4468 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4469 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4470 dictAppendWord(dp, "+", add, FW_DEFAULT);
4471 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4472 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4473 pComma =
4474 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4475 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4476 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4477 dictAppendWord(dp, ".#", displayCellNoPad, FW_DEFAULT);
4478 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4479 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4480 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4481 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4482 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4483 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4484 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4485 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4486 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4487 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4488 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4489 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4490 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4491 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4492 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4493 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4494 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4495 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4496 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4497 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4498 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4499 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4500 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4501 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4502 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4503 dictAppendWord(dp, ">r", toRStack, FW_DEFAULT);
4504 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4505 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4506 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4507 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4508 dictAppendWord(dp, "align", align, FW_DEFAULT);
4509 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4510 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4511 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4512 dictAppendWord(dp, "base", base, FW_DEFAULT);
4513 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4514 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4515 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4516 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4517 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4518 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4519 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4520 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4521 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4522 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4523 dictAppendWord(dp, "count", count, FW_DEFAULT);
4524 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4525 dictAppendWord(dp, "create", create, FW_DEFAULT);
4526 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4527 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4528 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4529 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4530 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4531 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4532 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4533 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4534 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4535 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4536 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4537 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4538 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4539 dictAppendWord(dp, "find", find, FW_DEFAULT);
4540 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4541 dictAppendWord(dp, "here", here, FW_DEFAULT);
4542 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4543 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4544 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4545 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4546 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4547 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4548 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4549 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4550 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4551 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4552 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4553 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4554 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4555 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4556 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4557 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4558 dictAppendWord(dp, "move", move, FW_DEFAULT);
4559 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4560 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4561 dictAppendWord(dp, "over", over, FW_DEFAULT);
4562 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4563 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4564 dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT);
4565 dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT);
4566 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4567 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4568 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4569 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4570 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4571 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4572 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4573 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4574 dictAppendWord(dp, "source", source, FW_DEFAULT);
4575 dictAppendWord(dp, "state", state, FW_DEFAULT);
4576 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4577 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4578 pType =
4579 dictAppendWord(dp, "type", type, FW_DEFAULT);
4580 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4581 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4582 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4583 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4584 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4585 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4586 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4587 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4588 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4589 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4590 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4591 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4592 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4593 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4594 /*
4595 ** CORE EXT word set...
4596 ** see softcore.c for other definitions
4597 */
4598 dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);
4599 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4600 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4601 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4602 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4603 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4604 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4605 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4606 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4607 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4608
4609 /* FreeBSD extension words */
4610 dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT);
4611 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT);
4612 dictAppendWord(dp, "fread", pfread, FW_DEFAULT);
4613 dictAppendWord(dp, "fload", pfload, FW_DEFAULT);
4614 dictAppendWord(dp, "fkey", fkey, FW_DEFAULT);
4615 dictAppendWord(dp, "key", key, FW_DEFAULT);
4616 dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT);
4617 dictAppendWord(dp, "ms", ms, FW_DEFAULT);
4618 dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT);
|
| 4619#ifdef FICL_TRACE
4620 dictAppendWord(dp, "trace!", ficlTrace, FW_DEFAULT);
4621#endif
|
4577 /*
4578 ** EXCEPTION word set
4579 */
4580 dictAppendWord(dp, "catch", catch, FW_DEFAULT);
4581 dictAppendWord(dp, "throw", throw, FW_DEFAULT);
4582
4583 ficlSetEnv("exception", FICL_TRUE);
4584 ficlSetEnv("exception-ext", FICL_TRUE);
4585
4586 /*
4587 ** MEMORY-ALLOC word set
4588 */
4589 dictAppendWord(dp, "allocate", allocate, FW_DEFAULT);
4590 dictAppendWord(dp, "free", free4th, FW_DEFAULT);
4591 dictAppendWord(dp, "resize", resize, FW_DEFAULT);
4592
4593 ficlSetEnv("memory-alloc", FICL_TRUE);
4594
4595#ifndef TESTMAIN
4596#ifdef __i386__
4597 dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT);
4598 dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT);
4599#endif
4600#endif
4601
4602#if defined(__i386__)
4603 ficlSetEnv("arch-i386", FICL_TRUE);
4604 ficlSetEnv("arch-alpha", FICL_FALSE);
4605#elif defined(__alpha__)
4606 ficlSetEnv("arch-i386", FICL_FALSE);
4607 ficlSetEnv("arch-alpha", FICL_TRUE);
4608#endif
4609
4610 /*
4611 ** Set CORE environment query values
4612 */
4613 ficlSetEnv("/counted-string", FICL_STRING_MAX);
4614 ficlSetEnv("/hold", nPAD);
4615 ficlSetEnv("/pad", nPAD);
4616 ficlSetEnv("address-unit-bits", 8);
4617 ficlSetEnv("core", FICL_TRUE);
4618 ficlSetEnv("core-ext", FICL_FALSE);
4619 ficlSetEnv("floored", FICL_FALSE);
4620 ficlSetEnv("max-char", UCHAR_MAX);
4621 ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff );
4622 ficlSetEnv("max-n", 0x7fffffff);
4623 ficlSetEnv("max-u", 0xffffffff);
4624 ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff);
4625 ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK);
4626 ficlSetEnv("stack-cells", FICL_DEFAULT_STACK);
4627
4628 /*
4629 ** LOCAL and LOCAL EXT
4630 ** see softcore.c for implementation of locals|
4631 */
4632#if FICL_WANT_LOCALS
4633 pLinkParen =
4634 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4635 pUnLinkParen =
4636 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4637 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4638 pGetLocalParen =
4639 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4640 pToLocalParen =
4641 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4642 pGetLocal0 =
4643 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4644 pToLocal0 =
4645 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4646 pGetLocal1 =
4647 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4648 pToLocal1 =
4649 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4650 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4651
4652 ficlSetEnv("locals", FICL_TRUE);
4653 ficlSetEnv("locals-ext", FICL_TRUE);
4654 ficlSetEnv("#locals", FICL_MAX_LOCALS);
4655#endif
4656
4657 /*
4658 ** optional SEARCH-ORDER word set
4659 */
4660 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT);
4661 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT);
4662 dictAppendWord(dp, "definitions",
4663 definitions, FW_DEFAULT);
4664 dictAppendWord(dp, "forth-wordlist",
4665 forthWordlist, FW_DEFAULT);
4666 dictAppendWord(dp, "get-current",
4667 getCurrent, FW_DEFAULT);
4668 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT);
4669 dictAppendWord(dp, "search-wordlist",
4670 searchWordlist, FW_DEFAULT);
4671 dictAppendWord(dp, "set-current",
4672 setCurrent, FW_DEFAULT);
4673 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT);
4674 dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT);
4675
4676 /*
4677 ** Set SEARCH environment query values
4678 */
4679 ficlSetEnv("search-order", FICL_TRUE);
4680 ficlSetEnv("search-order-ext", FICL_TRUE);
4681 ficlSetEnv("wordlists", FICL_DEFAULT_VOCS);
4682
4683 /*
4684 ** TOOLS and TOOLS EXT
4685 */
4686 dictAppendWord(dp, ".s", displayStack, FW_DEFAULT);
4687 dictAppendWord(dp, "bye", bye, FW_DEFAULT);
4688 dictAppendWord(dp, "forget", forget, FW_DEFAULT);
4689 dictAppendWord(dp, "see", see, FW_DEFAULT);
4690 dictAppendWord(dp, "words", listWords, FW_DEFAULT);
4691
4692 /*
4693 ** Set TOOLS environment query values
4694 */
4695 ficlSetEnv("tools", FICL_TRUE);
4696 ficlSetEnv("tools-ext", FICL_FALSE);
4697
4698 /*
4699 ** Ficl extras
4700 */
4701 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
4702 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4703 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4704 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4705 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); /* DOUBLE */
4706 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4707 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4708 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4709 dictAppendWord(dp, "compile-only",
4710 compileOnly, FW_DEFAULT);
4711 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4712 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
4713 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4714 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4715 dictAppendWord(dp, "wid-set-super",
4716 setParentWid, FW_DEFAULT);
4717 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4718 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4719 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4720#if FICL_WANT_USER
4721 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4722 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4723#endif
4724 /*
4725 ** internal support words
4726 */
4727 pExitParen =
4728 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4729 pSemiParen =
4730 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4731 pLitParen =
4732 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4733 pStringLit =
4734 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4735 pIfParen =
4736 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4737 pBranchParen =
4738 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4739 pDoParen =
4740 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4741 pDoesParen =
4742 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4743 pQDoParen =
4744 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4745 pLoopParen =
4746 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4747 pPLoopParen =
4748 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4749 pInterpret =
4750 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4751 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4752 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4753
4754 return;
4755}
4756
| 4622 /*
4623 ** EXCEPTION word set
4624 */
4625 dictAppendWord(dp, "catch", catch, FW_DEFAULT);
4626 dictAppendWord(dp, "throw", throw, FW_DEFAULT);
4627
4628 ficlSetEnv("exception", FICL_TRUE);
4629 ficlSetEnv("exception-ext", FICL_TRUE);
4630
4631 /*
4632 ** MEMORY-ALLOC word set
4633 */
4634 dictAppendWord(dp, "allocate", allocate, FW_DEFAULT);
4635 dictAppendWord(dp, "free", free4th, FW_DEFAULT);
4636 dictAppendWord(dp, "resize", resize, FW_DEFAULT);
4637
4638 ficlSetEnv("memory-alloc", FICL_TRUE);
4639
4640#ifndef TESTMAIN
4641#ifdef __i386__
4642 dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT);
4643 dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT);
4644#endif
4645#endif
4646
4647#if defined(__i386__)
4648 ficlSetEnv("arch-i386", FICL_TRUE);
4649 ficlSetEnv("arch-alpha", FICL_FALSE);
4650#elif defined(__alpha__)
4651 ficlSetEnv("arch-i386", FICL_FALSE);
4652 ficlSetEnv("arch-alpha", FICL_TRUE);
4653#endif
4654
4655 /*
4656 ** Set CORE environment query values
4657 */
4658 ficlSetEnv("/counted-string", FICL_STRING_MAX);
4659 ficlSetEnv("/hold", nPAD);
4660 ficlSetEnv("/pad", nPAD);
4661 ficlSetEnv("address-unit-bits", 8);
4662 ficlSetEnv("core", FICL_TRUE);
4663 ficlSetEnv("core-ext", FICL_FALSE);
4664 ficlSetEnv("floored", FICL_FALSE);
4665 ficlSetEnv("max-char", UCHAR_MAX);
4666 ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff );
4667 ficlSetEnv("max-n", 0x7fffffff);
4668 ficlSetEnv("max-u", 0xffffffff);
4669 ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff);
4670 ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK);
4671 ficlSetEnv("stack-cells", FICL_DEFAULT_STACK);
4672
4673 /*
4674 ** LOCAL and LOCAL EXT
4675 ** see softcore.c for implementation of locals|
4676 */
4677#if FICL_WANT_LOCALS
4678 pLinkParen =
4679 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4680 pUnLinkParen =
4681 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4682 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4683 pGetLocalParen =
4684 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4685 pToLocalParen =
4686 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4687 pGetLocal0 =
4688 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4689 pToLocal0 =
4690 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4691 pGetLocal1 =
4692 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4693 pToLocal1 =
4694 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4695 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4696
4697 ficlSetEnv("locals", FICL_TRUE);
4698 ficlSetEnv("locals-ext", FICL_TRUE);
4699 ficlSetEnv("#locals", FICL_MAX_LOCALS);
4700#endif
4701
4702 /*
4703 ** optional SEARCH-ORDER word set
4704 */
4705 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT);
4706 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT);
4707 dictAppendWord(dp, "definitions",
4708 definitions, FW_DEFAULT);
4709 dictAppendWord(dp, "forth-wordlist",
4710 forthWordlist, FW_DEFAULT);
4711 dictAppendWord(dp, "get-current",
4712 getCurrent, FW_DEFAULT);
4713 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT);
4714 dictAppendWord(dp, "search-wordlist",
4715 searchWordlist, FW_DEFAULT);
4716 dictAppendWord(dp, "set-current",
4717 setCurrent, FW_DEFAULT);
4718 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT);
4719 dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT);
4720
4721 /*
4722 ** Set SEARCH environment query values
4723 */
4724 ficlSetEnv("search-order", FICL_TRUE);
4725 ficlSetEnv("search-order-ext", FICL_TRUE);
4726 ficlSetEnv("wordlists", FICL_DEFAULT_VOCS);
4727
4728 /*
4729 ** TOOLS and TOOLS EXT
4730 */
4731 dictAppendWord(dp, ".s", displayStack, FW_DEFAULT);
4732 dictAppendWord(dp, "bye", bye, FW_DEFAULT);
4733 dictAppendWord(dp, "forget", forget, FW_DEFAULT);
4734 dictAppendWord(dp, "see", see, FW_DEFAULT);
4735 dictAppendWord(dp, "words", listWords, FW_DEFAULT);
4736
4737 /*
4738 ** Set TOOLS environment query values
4739 */
4740 ficlSetEnv("tools", FICL_TRUE);
4741 ficlSetEnv("tools-ext", FICL_FALSE);
4742
4743 /*
4744 ** Ficl extras
4745 */
4746 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
4747 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4748 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4749 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4750 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); /* DOUBLE */
4751 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4752 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4753 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4754 dictAppendWord(dp, "compile-only",
4755 compileOnly, FW_DEFAULT);
4756 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4757 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
4758 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4759 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4760 dictAppendWord(dp, "wid-set-super",
4761 setParentWid, FW_DEFAULT);
4762 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4763 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4764 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4765#if FICL_WANT_USER
4766 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4767 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4768#endif
4769 /*
4770 ** internal support words
4771 */
4772 pExitParen =
4773 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4774 pSemiParen =
4775 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4776 pLitParen =
4777 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4778 pStringLit =
4779 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4780 pIfParen =
4781 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4782 pBranchParen =
4783 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4784 pDoParen =
4785 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4786 pDoesParen =
4787 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4788 pQDoParen =
4789 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4790 pLoopParen =
4791 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4792 pPLoopParen =
4793 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4794 pInterpret =
4795 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4796 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4797 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4798
4799 return;
4800}
4801
|