initial commit
[freebsd-arm:freebsd-arm.git] / boot / ficl / words.c
1 /*******************************************************************
2 ** w o r d s . c
3 ** Forth Inspired Command Language
4 ** ANS Forth CORE word-set written in C
5 ** Author: John Sadler (john_sadler@alum.mit.edu)
6 ** Created: 19 July 1997
7 ** $Id: words.c,v 1.17 2001/12/05 07:21:34 jsadler Exp $
8 *******************************************************************/
9 /*
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
12 **
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
14 **
15 ** I am interested in hearing from anyone who uses ficl. If you have
16 ** a problem, a success story, a defect, an enhancement request, or
17 ** if you would like to contribute to the ficl release, please
18 ** contact me by email at the address above.
19 **
20 ** L I C E N S E  and  D I S C L A I M E R
21 ** 
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
24 ** are met:
25 ** 1. Redistributions of source code must retain the above copyright
26 **    notice, this list of conditions and the following disclaimer.
27 ** 2. Redistributions in binary form must reproduce the above copyright
28 **    notice, this list of conditions and the following disclaimer in the
29 **    documentation and/or other materials provided with the distribution.
30 **
31 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34 ** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41 ** SUCH DAMAGE.
42 */
43
44 /* $FreeBSD$ */
45
46 #ifdef TESTMAIN
47 #include <stdlib.h>
48 #include <stdio.h>
49 #include <ctype.h>
50 #include <fcntl.h>
51 #else
52 #include <stand.h>
53 #endif
54 #include <string.h>
55 #include "ficl.h"
56 #include "math64.h"
57
58 static void colonParen(FICL_VM *pVM);
59 static void literalIm(FICL_VM *pVM);
60 static int  ficlParseWord(FICL_VM *pVM, STRINGINFO si);
61
62 /*
63 ** Control structure building words use these
64 ** strings' addresses as markers on the stack to 
65 ** check for structure completion.
66 */
67 static char doTag[]    = "do";
68 static char colonTag[] = "colon";
69 static char leaveTag[] = "leave";
70
71 static char destTag[]  = "target";
72 static char origTag[]  = "origin";
73
74 static char caseTag[]  = "case";
75 static char ofTag[]  = "of";
76 static char fallthroughTag[]  = "fallthrough";
77
78 #if FICL_WANT_LOCALS
79 static void doLocalIm(FICL_VM *pVM);
80 static void do2LocalIm(FICL_VM *pVM);
81 #endif
82
83
84 /*
85 ** C O N T R O L   S T R U C T U R E   B U I L D E R S
86 **
87 ** Push current dict location for later branch resolution.
88 ** The location may be either a branch target or a patch address...
89 */
90 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
91 {
92     PUSHPTR(dp->here);
93     PUSHPTR(tag);
94     return;
95 }
96
97 static void markControlTag(FICL_VM *pVM, char *tag)
98 {
99     PUSHPTR(tag);
100     return;
101 }
102
103 static void matchControlTag(FICL_VM *pVM, char *tag)
104 {
105     char *cp;
106 #if FICL_ROBUST > 1
107     vmCheckStack(pVM, 1, 0);
108 #endif
109     cp = (char *)stackPopPtr(pVM->pStack);
110     /*
111     ** Changed the code below to compare the pointers first (by popular demand)
112     */
113     if ( (cp != tag) && strcmp(cp, tag) )
114     {
115         vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
116     }
117
118     return;
119 }
120
121 /*
122 ** Expect a branch target address on the param stack,
123 ** compile a literal offset from the current dict location
124 ** to the target address
125 */
126 static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
127 {
128     FICL_INT offset;
129     CELL *patchAddr;
130
131     matchControlTag(pVM, tag);
132
133 #if FICL_ROBUST > 1
134     vmCheckStack(pVM, 1, 0);
135 #endif
136     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
137     offset = patchAddr - dp->here;
138     dictAppendCell(dp, LVALUEtoCELL(offset));
139
140     return;
141 }
142
143
144 /*
145 ** Expect a branch patch address on the param stack,
146 ** compile a literal offset from the patch location
147 ** to the current dict location
148 */
149 static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
150 {
151     FICL_INT offset;
152     CELL *patchAddr;
153
154     matchControlTag(pVM, tag);
155
156 #if FICL_ROBUST > 1
157     vmCheckStack(pVM, 1, 0);
158 #endif
159     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
160     offset = dp->here - patchAddr;
161     *patchAddr = LVALUEtoCELL(offset);
162
163     return;
164 }
165
166 /*
167 ** Match the tag to the top of the stack. If success,
168 ** sopy "here" address into the cell whose address is next
169 ** on the stack. Used by do..leave..loop.
170 */
171 static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
172 {
173     CELL *patchAddr;
174     char *cp;
175
176 #if FICL_ROBUST > 1
177     vmCheckStack(pVM, 2, 0);
178 #endif
179     cp = stackPopPtr(pVM->pStack);
180     /*
181     ** Changed the comparison below to compare the pointers first (by popular demand)
182     */
183     if ((cp != tag) && strcmp(cp, tag))
184     {
185         vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
186         vmTextOut(pVM, tag, 1);
187     }
188
189     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
190     *patchAddr = LVALUEtoCELL(dp->here);
191
192     return;
193 }
194
195
196 /**************************************************************************
197                         f i c l P a r s e N u m b e r
198 ** Attempts to convert the NULL terminated string in the VM's pad to 
199 ** a number using the VM's current base. If successful, pushes the number
200 ** onto the param stack and returns TRUE. Otherwise, returns FALSE.
201 ** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
202 ** the standard for DOUBLE wordset.
203 **************************************************************************/
204
205 int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
206 {
207     FICL_INT accum  = 0;
208     char isNeg      = FALSE;
209         char hasDP      = FALSE;
210     unsigned base   = pVM->base;
211     char *cp        = SI_PTR(si);
212     FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
213     unsigned ch;
214     unsigned digit;
215
216     if (count > 1)
217     {
218         switch (*cp)
219         {
220         case '-':
221             cp++;
222             count--;
223             isNeg = TRUE;
224             break;
225         case '+':
226             cp++;
227             count--;
228             isNeg = FALSE;
229             break;
230         default:
231             break;
232         }
233     }
234
235     if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
236     {
237         hasDP = TRUE;
238         count--;
239     }
240
241     if (count == 0)        /* detect "+", "-", ".", "+." etc */
242         return FALSE;
243
244     while ((count--) && ((ch = *cp++) != '\0'))
245     {
246         if (!isalnum(ch))
247             return FALSE;
248
249         digit = ch - '0';
250
251         if (digit > 9)
252             digit = tolower(ch) - 'a' + 10;
253
254         if (digit >= base)
255             return FALSE;
256
257         accum = accum * base + digit;
258     }
259
260         if (hasDP)              /* simple (required) DOUBLE support */
261                 PUSHINT(0);
262
263     if (isNeg)
264         accum = -accum;
265
266     PUSHINT(accum);
267     if (pVM->state == COMPILE)
268         literalIm(pVM);
269
270     return TRUE;
271 }
272
273
274 /**************************************************************************
275                         a d d   &   f r i e n d s
276 ** 
277 **************************************************************************/
278
279 static void add(FICL_VM *pVM)
280 {
281     FICL_INT i;
282 #if FICL_ROBUST > 1
283     vmCheckStack(pVM, 2, 1);
284 #endif
285     i = stackPopINT(pVM->pStack);
286     i += stackGetTop(pVM->pStack).i;
287     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
288     return;
289 }
290
291 static void sub(FICL_VM *pVM)
292 {
293     FICL_INT i;
294 #if FICL_ROBUST > 1
295     vmCheckStack(pVM, 2, 1);
296 #endif
297     i = stackPopINT(pVM->pStack);
298     i = stackGetTop(pVM->pStack).i - i;
299     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
300     return;
301 }
302
303 static void mul(FICL_VM *pVM)
304 {
305     FICL_INT i;
306 #if FICL_ROBUST > 1
307     vmCheckStack(pVM, 2, 1);
308 #endif
309     i = stackPopINT(pVM->pStack);
310     i *= stackGetTop(pVM->pStack).i;
311     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
312     return;
313 }
314
315 static void negate(FICL_VM *pVM)
316 {
317     FICL_INT i;
318 #if FICL_ROBUST > 1
319     vmCheckStack(pVM, 1, 1);
320 #endif
321     i = -stackPopINT(pVM->pStack);
322     PUSHINT(i);
323     return;
324 }
325
326 static void ficlDiv(FICL_VM *pVM)
327 {
328     FICL_INT i;
329 #if FICL_ROBUST > 1
330     vmCheckStack(pVM, 2, 1);
331 #endif
332     i = stackPopINT(pVM->pStack);
333     i = stackGetTop(pVM->pStack).i / i;
334     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
335     return;
336 }
337
338 /*
339 ** slash-mod        CORE ( n1 n2 -- n3 n4 )
340 ** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
341 ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
342 ** differ in sign, the implementation-defined result returned will be the
343 ** same as that returned by either the phrase
344 ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . 
345 ** NOTE: Ficl complies with the second phrase (symmetric division)
346 */
347 static void slashMod(FICL_VM *pVM)
348 {
349     DPINT n1;
350     FICL_INT n2;
351     INTQR qr;
352
353 #if FICL_ROBUST > 1
354     vmCheckStack(pVM, 2, 2);
355 #endif
356     n2    = stackPopINT(pVM->pStack);
357     n1.lo = stackPopINT(pVM->pStack);
358     i64Extend(n1);
359
360     qr = m64SymmetricDivI(n1, n2);
361     PUSHINT(qr.rem);
362     PUSHINT(qr.quot);
363     return;
364 }
365
366 static void onePlus(FICL_VM *pVM)
367 {
368     FICL_INT i;
369 #if FICL_ROBUST > 1
370     vmCheckStack(pVM, 1, 1);
371 #endif
372     i = stackGetTop(pVM->pStack).i;
373     i += 1;
374     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
375     return;
376 }
377
378 static void oneMinus(FICL_VM *pVM)
379 {
380     FICL_INT i;
381 #if FICL_ROBUST > 1
382     vmCheckStack(pVM, 1, 1);
383 #endif
384     i = stackGetTop(pVM->pStack).i;
385     i -= 1;
386     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
387     return;
388 }
389
390 static void twoMul(FICL_VM *pVM)
391 {
392     FICL_INT i;
393 #if FICL_ROBUST > 1
394     vmCheckStack(pVM, 1, 1);
395 #endif
396     i = stackGetTop(pVM->pStack).i;
397     i *= 2;
398     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
399     return;
400 }
401
402 static void twoDiv(FICL_VM *pVM)
403 {
404     FICL_INT i;
405 #if FICL_ROBUST > 1
406     vmCheckStack(pVM, 1, 1);
407 #endif
408     i = stackGetTop(pVM->pStack).i;
409     i >>= 1;
410     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
411     return;
412 }
413
414 static void mulDiv(FICL_VM *pVM)
415 {
416     FICL_INT x, y, z;
417     DPINT prod;
418 #if FICL_ROBUST > 1
419     vmCheckStack(pVM, 3, 1);
420 #endif
421     z = stackPopINT(pVM->pStack);
422     y = stackPopINT(pVM->pStack);
423     x = stackPopINT(pVM->pStack);
424
425     prod = m64MulI(x,y);
426     x    = m64SymmetricDivI(prod, z).quot;
427
428     PUSHINT(x);
429     return;
430 }
431
432
433 static void mulDivRem(FICL_VM *pVM)
434 {
435     FICL_INT x, y, z;
436     DPINT prod;
437     INTQR qr;
438 #if FICL_ROBUST > 1
439     vmCheckStack(pVM, 3, 2);
440 #endif
441     z = stackPopINT(pVM->pStack);
442     y = stackPopINT(pVM->pStack);
443     x = stackPopINT(pVM->pStack);
444
445     prod = m64MulI(x,y);
446     qr   = m64SymmetricDivI(prod, z);
447
448     PUSHINT(qr.rem);
449     PUSHINT(qr.quot);
450     return;
451 }
452
453
454 /**************************************************************************
455                         c o l o n   d e f i n i t i o n s
456 ** Code to begin compiling a colon definition
457 ** This function sets the state to COMPILE, then creates a
458 ** new word whose name is the next word in the input stream
459 ** and whose code is colonParen.
460 **************************************************************************/
461
462 static void colon(FICL_VM *pVM)
463 {
464     FICL_DICT *dp = vmGetDict(pVM);
465     STRINGINFO si = vmGetWord(pVM);
466
467     dictCheckThreshold(dp);
468
469     pVM->state = COMPILE;
470     markControlTag(pVM, colonTag);
471     dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
472 #if FICL_WANT_LOCALS
473     pVM->pSys->nLocals = 0;
474 #endif
475     return;
476 }
477
478
479 /**************************************************************************
480                         c o l o n P a r e n
481 ** This is the code that executes a colon definition. It assumes that the
482 ** virtual machine is running a "next" loop (See the vm.c
483 ** for its implementation of member function vmExecute()). The colon
484 ** code simply copies the address of the first word in the list of words
485 ** to interpret into IP after saving its old value. When we return to the
486 ** "next" loop, the virtual machine will call the code for each word in 
487 ** turn.
488 **
489 **************************************************************************/
490        
491 static void colonParen(FICL_VM *pVM)
492 {
493     IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
494     vmPushIP(pVM, tempIP);
495
496     return;
497 }
498
499
500 /**************************************************************************
501                         s e m i c o l o n C o I m
502 ** 
503 ** IMMEDIATE code for ";". This function sets the state to INTERPRET and
504 ** terminates a word under compilation by appending code for "(;)" to
505 ** the definition. TO DO: checks for leftover branch target tags on the
506 ** return stack and complains if any are found.
507 **************************************************************************/
508 static void semiParen(FICL_VM *pVM)
509 {
510     vmPopIP(pVM);
511     return;
512 }
513
514
515 static void semicolonCoIm(FICL_VM *pVM)
516 {
517     FICL_DICT *dp = vmGetDict(pVM);
518
519     assert(pVM->pSys->pSemiParen);
520     matchControlTag(pVM, colonTag);
521
522 #if FICL_WANT_LOCALS
523     assert(pVM->pSys->pUnLinkParen);
524     if (pVM->pSys->nLocals > 0)
525     {
526         FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
527         dictEmpty(pLoc, pLoc->pForthWords->size);
528         dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
529     }
530     pVM->pSys->nLocals = 0;
531 #endif
532
533     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
534     pVM->state = INTERPRET;
535     dictUnsmudge(dp);
536     return;
537 }
538
539
540 /**************************************************************************
541                         e x i t
542 ** CORE
543 ** This function simply pops the previous instruction
544 ** pointer and returns to the "next" loop. Used for exiting from within
545 ** a definition. Note that exitParen is identical to semiParen - they
546 ** are in two different functions so that "see" can correctly identify
547 ** the end of a colon definition, even if it uses "exit".
548 **************************************************************************/
549 static void exitParen(FICL_VM *pVM)
550 {
551     vmPopIP(pVM);
552     return;
553 }
554
555 static void exitCoIm(FICL_VM *pVM)
556 {
557     FICL_DICT *dp = vmGetDict(pVM);
558     assert(pVM->pSys->pExitParen);
559     IGNORE(pVM);
560
561 #if FICL_WANT_LOCALS
562     if (pVM->pSys->nLocals > 0)
563     {
564         dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
565     }
566 #endif
567     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
568     return;
569 }
570
571
572 /**************************************************************************
573                         c o n s t a n t P a r e n
574 ** This is the run-time code for "constant". It simply returns the 
575 ** contents of its word's first data cell.
576 **
577 **************************************************************************/
578
579 void constantParen(FICL_VM *pVM)
580 {
581     FICL_WORD *pFW = pVM->runningWord;
582 #if FICL_ROBUST > 1
583     vmCheckStack(pVM, 0, 1);
584 #endif
585     stackPush(pVM->pStack, pFW->param[0]);
586     return;
587 }
588
589 void twoConstParen(FICL_VM *pVM)
590 {
591     FICL_WORD *pFW = pVM->runningWord;
592 #if FICL_ROBUST > 1
593     vmCheckStack(pVM, 0, 2);
594 #endif
595     stackPush(pVM->pStack, pFW->param[0]); /* lo */
596     stackPush(pVM->pStack, pFW->param[1]); /* hi */
597     return;
598 }
599
600
601 /**************************************************************************
602                         c o n s t a n t
603 ** IMMEDIATE
604 ** Compiles a constant into the dictionary. Constants return their
605 ** value when invoked. Expects a value on top of the parm stack.
606 **************************************************************************/
607
608 static void constant(FICL_VM *pVM)
609 {
610     FICL_DICT *dp = vmGetDict(pVM);
611     STRINGINFO si = vmGetWord(pVM);
612
613 #if FICL_ROBUST > 1
614     vmCheckStack(pVM, 1, 0);
615 #endif
616     dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
617     dictAppendCell(dp, stackPop(pVM->pStack));
618     return;
619 }
620
621
622 static void twoConstant(FICL_VM *pVM)
623 {
624     FICL_DICT *dp = vmGetDict(pVM);
625     STRINGINFO si = vmGetWord(pVM);
626     CELL c;
627     
628 #if FICL_ROBUST > 1
629     vmCheckStack(pVM, 2, 0);
630 #endif
631     c = stackPop(pVM->pStack);
632     dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
633     dictAppendCell(dp, stackPop(pVM->pStack));
634     dictAppendCell(dp, c);
635     return;
636 }
637
638
639 /**************************************************************************
640                         d i s p l a y C e l l
641 ** Drop and print the contents of the cell at the top of the param
642 ** stack
643 **************************************************************************/
644
645 static void displayCell(FICL_VM *pVM)
646 {
647     CELL c;
648 #if FICL_ROBUST > 1
649     vmCheckStack(pVM, 1, 0);
650 #endif
651     c = stackPop(pVM->pStack);
652     ltoa((c).i, pVM->pad, pVM->base);
653     strcat(pVM->pad, " ");
654     vmTextOut(pVM, pVM->pad, 0);
655     return;
656 }
657
658 static void uDot(FICL_VM *pVM)
659 {
660     FICL_UNS u;
661 #if FICL_ROBUST > 1
662     vmCheckStack(pVM, 1, 0);
663 #endif
664     u = stackPopUNS(pVM->pStack);
665     ultoa(u, pVM->pad, pVM->base);
666     strcat(pVM->pad, " ");
667     vmTextOut(pVM, pVM->pad, 0);
668     return;
669 }
670
671
672 static void hexDot(FICL_VM *pVM)
673 {
674     FICL_UNS u;
675 #if FICL_ROBUST > 1
676     vmCheckStack(pVM, 1, 0);
677 #endif
678     u = stackPopUNS(pVM->pStack);
679     ultoa(u, pVM->pad, 16);
680     strcat(pVM->pad, " ");
681     vmTextOut(pVM, pVM->pad, 0);
682     return;
683 }
684
685
686 /**************************************************************************
687                         s t r l e n
688 ** FICL   ( c-string -- length )
689 **
690 ** Returns the length of a C-style (zero-terminated) string.
691 **
692 ** --lch
693 **/
694 static void ficlStrlen(FICL_VM *ficlVM)
695         {
696         char *address = (char *)stackPopPtr(ficlVM->pStack);
697         stackPushINT(ficlVM->pStack, strlen(address));
698         }
699
700
701 /**************************************************************************
702                         s p r i n t f
703 ** FICL   ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
704 ** Similar to the C sprintf() function.  It formats into a buffer based on
705 ** a "format" string.  Each character in the format string is copied verbatim
706 ** to the output buffer, until SPRINTF encounters a percent sign ("%").
707 ** SPRINTF then skips the percent sign, and examines the next character
708 ** (the "format character").  Here are the valid format characters:
709 **    s - read a C-ADDR U-LENGTH string from the stack and copy it to
710 **        the buffer
711 **    d - read a cell from the stack, format it as a string (base-10,
712 **        signed), and copy it to the buffer
713 **    x - same as d, except in base-16
714 **    u - same as d, but unsigned
715 **    % - output a literal percent-sign to the buffer
716 ** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
717 ** written, and a flag indicating whether or not it ran out of space while
718 ** writing to the output buffer (TRUE if it ran out of space).
719 **
720 ** If SPRINTF runs out of space in the buffer to store the formatted string,
721 ** it still continues parsing, in an effort to preserve your stack (otherwise
722 ** it might leave uneaten arguments behind).
723 **
724 ** --lch
725 **************************************************************************/
726 static void ficlSprintf(FICL_VM *pVM) /*  */
727 {
728         int bufferLength = stackPopINT(pVM->pStack);
729         char *buffer = (char *)stackPopPtr(pVM->pStack);
730         char *bufferStart = buffer;
731
732         int formatLength = stackPopINT(pVM->pStack);
733         char *format = (char *)stackPopPtr(pVM->pStack);
734         char *formatStop = format + formatLength;
735
736         int base = 10;
737         int unsignedInteger = FALSE;
738
739         FICL_INT append = FICL_TRUE;
740
741         while (format < formatStop)
742         {
743                 char scratch[64];
744                 char *source;
745                 int actualLength;
746                 int desiredLength;
747                 int leadingZeroes;
748
749
750                 if (*format != '%')
751                 {
752                         source = format;
753                         actualLength = desiredLength = 1;
754                         leadingZeroes = 0;
755                 }
756                 else
757                 {
758                         format++;
759                         if (format == formatStop)
760                                 break;
761
762                         leadingZeroes = (*format == '0');
763                         if (leadingZeroes)
764                                 {
765                                 format++;
766                                 if (format == formatStop)
767                                         break;
768                                 }
769
770                         desiredLength = isdigit(*format);
771                         if (desiredLength)
772                                 {
773                                 desiredLength = strtol(format, &format, 10);
774                                 if (format == formatStop)
775                                         break;
776                                 }
777                         else if (*format == '*')
778                                 {
779                                 desiredLength = stackPopINT(pVM->pStack);
780                                 format++;
781                                 if (format == formatStop)
782                                         break;
783                                 }
784
785
786                         switch (*format)
787                         {
788                                 case 's':
789                                 case 'S':
790                                 {
791                                         actualLength = stackPopINT(pVM->pStack);
792                                         source = (char *)stackPopPtr(pVM->pStack);
793                                         break;
794                                 }
795                                 case 'x':
796                                 case 'X':
797                                         base = 16;
798                                 case 'u':
799                                 case 'U':
800                                         unsignedInteger = TRUE;
801                                 case 'd':
802                                 case 'D':
803                                 {
804                                         int integer = stackPopINT(pVM->pStack);
805                                         if (unsignedInteger)
806                                                 ultoa(integer, scratch, base);
807                                         else
808                                                 ltoa(integer, scratch, base);
809                                         base = 10;
810                                         unsignedInteger = FALSE;
811                                         source = scratch;
812                                         actualLength = strlen(scratch);
813                                         break;
814                                 }
815                                 case '%':
816                                         source = format;
817                                         actualLength = 1;
818                                 default:
819                                         continue;
820                         }
821                 }
822
823                 if (append != FICL_FALSE)
824                 {
825                         if (!desiredLength)
826                                 desiredLength = actualLength;
827                         if (desiredLength > bufferLength)
828                         {
829                                 append = FICL_FALSE;
830                                 desiredLength = bufferLength;
831                         }
832                         while (desiredLength > actualLength)
833                                 {
834                                 *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
835                                 bufferLength--;
836                                 desiredLength--;
837                                 }
838                         memcpy(buffer, source, actualLength);
839                         buffer += actualLength;
840                         bufferLength -= actualLength;
841                 }
842
843                 format++;
844         }
845
846         stackPushPtr(pVM->pStack, bufferStart);
847         stackPushINT(pVM->pStack, buffer - bufferStart);
848         stackPushINT(pVM->pStack, append);
849 }
850
851
852 /**************************************************************************
853                         d u p   &   f r i e n d s
854 ** 
855 **************************************************************************/
856
857 static void depth(FICL_VM *pVM)
858 {
859     int i;
860 #if FICL_ROBUST > 1
861     vmCheckStack(pVM, 0, 1);
862 #endif
863     i = stackDepth(pVM->pStack);
864     PUSHINT(i);
865     return;
866 }
867
868
869 static void drop(FICL_VM *pVM)
870 {
871 #if FICL_ROBUST > 1
872     vmCheckStack(pVM, 1, 0);
873 #endif
874     stackDrop(pVM->pStack, 1);
875     return;
876 }
877
878
879 static void twoDrop(FICL_VM *pVM)
880 {
881 #if FICL_ROBUST > 1
882     vmCheckStack(pVM, 2, 0);
883 #endif
884     stackDrop(pVM->pStack, 2);
885     return;
886 }
887
888
889 static void dup(FICL_VM *pVM)
890 {
891 #if FICL_ROBUST > 1
892     vmCheckStack(pVM, 1, 2);
893 #endif
894     stackPick(pVM->pStack, 0);
895     return;
896 }
897
898
899 static void twoDup(FICL_VM *pVM)
900 {
901 #if FICL_ROBUST > 1
902     vmCheckStack(pVM, 2, 4);
903 #endif
904     stackPick(pVM->pStack, 1);
905     stackPick(pVM->pStack, 1);
906     return;
907 }
908
909
910 static void over(FICL_VM *pVM)
911 {
912 #if FICL_ROBUST > 1
913     vmCheckStack(pVM, 2, 3);
914 #endif
915     stackPick(pVM->pStack, 1);
916     return;
917 }
918
919 static void twoOver(FICL_VM *pVM)
920 {
921 #if FICL_ROBUST > 1
922     vmCheckStack(pVM, 4, 6);
923 #endif
924     stackPick(pVM->pStack, 3);
925     stackPick(pVM->pStack, 3);
926     return;
927 }
928
929
930 static void pick(FICL_VM *pVM)
931 {
932     CELL c = stackPop(pVM->pStack);
933 #if FICL_ROBUST > 1
934     vmCheckStack(pVM, c.i+1, c.i+2);
935 #endif
936     stackPick(pVM->pStack, c.i);
937     return;
938 }
939
940
941 static void questionDup(FICL_VM *pVM)
942 {
943     CELL c;
944 #if FICL_ROBUST > 1
945     vmCheckStack(pVM, 1, 2);
946 #endif
947     c = stackGetTop(pVM->pStack);
948
949     if (c.i != 0)
950         stackPick(pVM->pStack, 0);
951
952     return;
953 }
954
955
956 static void roll(FICL_VM *pVM)
957 {
958     int i = stackPop(pVM->pStack).i;
959     i = (i > 0) ? i : 0;
960 #if FICL_ROBUST > 1
961     vmCheckStack(pVM, i+1, i+1);
962 #endif
963     stackRoll(pVM->pStack, i);
964     return;
965 }
966
967
968 static void minusRoll(FICL_VM *pVM)
969 {
970     int i = stackPop(pVM->pStack).i;
971     i = (i > 0) ? i : 0;
972 #if FICL_ROBUST > 1
973     vmCheckStack(pVM, i+1, i+1);
974 #endif
975     stackRoll(pVM->pStack, -i);
976     return;
977 }
978
979
980 static void rot(FICL_VM *pVM)
981 {
982 #if FICL_ROBUST > 1
983     vmCheckStack(pVM, 3, 3);
984 #endif
985     stackRoll(pVM->pStack, 2);
986     return;
987 }
988
989
990 static void swap(FICL_VM *pVM)
991 {
992 #if FICL_ROBUST > 1
993     vmCheckStack(pVM, 2, 2);
994 #endif
995     stackRoll(pVM->pStack, 1);
996     return;
997 }
998
999
1000 static void twoSwap(FICL_VM *pVM)
1001 {
1002 #if FICL_ROBUST > 1
1003     vmCheckStack(pVM, 4, 4);
1004 #endif
1005     stackRoll(pVM->pStack, 3);
1006     stackRoll(pVM->pStack, 3);
1007     return;
1008 }
1009
1010
1011 /**************************************************************************
1012                         e m i t   &   f r i e n d s
1013 ** 
1014 **************************************************************************/
1015
1016 static void emit(FICL_VM *pVM)
1017 {
1018     char *cp = pVM->pad;
1019     int i;
1020
1021 #if FICL_ROBUST > 1
1022     vmCheckStack(pVM, 1, 0);
1023 #endif
1024     i = stackPopINT(pVM->pStack);
1025     cp[0] = (char)i;
1026     cp[1] = '\0';
1027     vmTextOut(pVM, cp, 0);
1028     return;
1029 }
1030
1031
1032 static void cr(FICL_VM *pVM)
1033 {
1034     vmTextOut(pVM, "", 1);
1035     return;
1036 }
1037
1038
1039 static void commentLine(FICL_VM *pVM)
1040 {
1041     char *cp        = vmGetInBuf(pVM);
1042     char *pEnd      = vmGetInBufEnd(pVM);
1043     char ch = *cp;
1044
1045     while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
1046     {
1047         ch = *++cp;
1048     }
1049
1050     /*
1051     ** Cope with DOS or UNIX-style EOLs -
1052     ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
1053     ** and point cp to next char. If EOL is \0, we're done.
1054     */
1055     if (cp != pEnd)
1056     {
1057         cp++;
1058
1059         if ( (cp != pEnd) && (ch != *cp) 
1060              && ((*cp == '\r') || (*cp == '\n')) )
1061             cp++;
1062     }
1063
1064     vmUpdateTib(pVM, cp);
1065     return;
1066 }
1067
1068
1069 /*
1070 ** paren CORE 
1071 ** Compilation: Perform the execution semantics given below.
1072 ** Execution: ( "ccc<paren>" -- )
1073 ** Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 
1074 ** The number of characters in ccc may be zero to the number of characters
1075 ** in the parse area. 
1076 ** 
1077 */
1078 static void commentHang(FICL_VM *pVM)
1079 {
1080     vmParseStringEx(pVM, ')', 0);
1081     return;
1082 }
1083
1084
1085 /**************************************************************************
1086                         F E T C H   &   S T O R E
1087 ** 
1088 **************************************************************************/
1089
1090 static void fetch(FICL_VM *pVM)
1091 {
1092     CELL *pCell;
1093 #if FICL_ROBUST > 1
1094     vmCheckStack(pVM, 1, 1);
1095 #endif
1096     pCell = (CELL *)stackPopPtr(pVM->pStack);
1097     stackPush(pVM->pStack, *pCell);
1098     return;
1099 }
1100
1101 /*
1102 ** two-fetch    CORE ( a-addr -- x1 x2 )
1103 ** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
1104 ** x1 at the next consecutive cell. It is equivalent to the sequence
1105 ** DUP CELL+ @ SWAP @ . 
1106 */
1107 static void twoFetch(FICL_VM *pVM)
1108 {
1109     CELL *pCell;
1110 #if FICL_ROBUST > 1
1111     vmCheckStack(pVM, 1, 2);
1112 #endif
1113     pCell = (CELL *)stackPopPtr(pVM->pStack);
1114     stackPush(pVM->pStack, *pCell++);
1115     stackPush(pVM->pStack, *pCell);
1116     swap(pVM);
1117     return;
1118 }
1119
1120 /*
1121 ** store        CORE ( x a-addr -- )
1122 ** Store x at a-addr. 
1123 */
1124 static void store(FICL_VM *pVM)
1125 {
1126     CELL *pCell;
1127 #if FICL_ROBUST > 1
1128     vmCheckStack(pVM, 2, 0);
1129 #endif
1130     pCell = (CELL *)stackPopPtr(pVM->pStack);
1131     *pCell = stackPop(pVM->pStack);
1132 }
1133
1134 /*
1135 ** two-store    CORE ( x1 x2 a-addr -- )
1136 ** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
1137 ** next consecutive cell. It is equivalent to the sequence
1138 ** SWAP OVER ! CELL+ ! . 
1139 */
1140 static void twoStore(FICL_VM *pVM)
1141 {
1142     CELL *pCell;
1143 #if FICL_ROBUST > 1
1144     vmCheckStack(pVM, 3, 0);
1145 #endif
1146     pCell = (CELL *)stackPopPtr(pVM->pStack);
1147     *pCell++    = stackPop(pVM->pStack);
1148     *pCell      = stackPop(pVM->pStack);
1149 }
1150
1151 static void plusStore(FICL_VM *pVM)
1152 {
1153     CELL *pCell;
1154 #if FICL_ROBUST > 1
1155     vmCheckStack(pVM, 2, 0);
1156 #endif
1157     pCell = (CELL *)stackPopPtr(pVM->pStack);
1158     pCell->i += stackPop(pVM->pStack).i;
1159 }
1160
1161
1162 static void quadFetch(FICL_VM *pVM)
1163 {
1164     UNS32 *pw;
1165 #if FICL_ROBUST > 1
1166     vmCheckStack(pVM, 1, 1);
1167 #endif
1168     pw = (UNS32 *)stackPopPtr(pVM->pStack);
1169     PUSHUNS((FICL_UNS)*pw);
1170     return;
1171 }
1172
1173 static void quadStore(FICL_VM *pVM)
1174 {
1175     UNS32 *pw;
1176 #if FICL_ROBUST > 1
1177     vmCheckStack(pVM, 2, 0);
1178 #endif
1179     pw = (UNS32 *)stackPopPtr(pVM->pStack);
1180     *pw = (UNS32)(stackPop(pVM->pStack).u);
1181 }
1182
1183 static void wFetch(FICL_VM *pVM)
1184 {
1185     UNS16 *pw;
1186 #if FICL_ROBUST > 1
1187     vmCheckStack(pVM, 1, 1);
1188 #endif
1189     pw = (UNS16 *)stackPopPtr(pVM->pStack);
1190     PUSHUNS((FICL_UNS)*pw);
1191     return;
1192 }
1193
1194 static void wStore(FICL_VM *pVM)
1195 {
1196     UNS16 *pw;
1197 #if FICL_ROBUST > 1
1198     vmCheckStack(pVM, 2, 0);
1199 #endif
1200     pw = (UNS16 *)stackPopPtr(pVM->pStack);
1201     *pw = (UNS16)(stackPop(pVM->pStack).u);
1202 }
1203
1204 static void cFetch(FICL_VM *pVM)
1205 {
1206     UNS8 *pc;
1207 #if FICL_ROBUST > 1
1208     vmCheckStack(pVM, 1, 1);
1209 #endif
1210     pc = (UNS8 *)stackPopPtr(pVM->pStack);
1211     PUSHUNS((FICL_UNS)*pc);
1212     return;
1213 }
1214
1215 static void cStore(FICL_VM *pVM)
1216 {
1217     UNS8 *pc;
1218 #if FICL_ROBUST > 1
1219     vmCheckStack(pVM, 2, 0);
1220 #endif
1221     pc = (UNS8 *)stackPopPtr(pVM->pStack);
1222     *pc = (UNS8)(stackPop(pVM->pStack).u);
1223 }
1224
1225
1226 /**************************************************************************
1227                         b r a n c h P a r e n
1228 ** 
1229 ** Runtime for "(branch)" -- expects a literal offset in the next
1230 ** compilation address, and branches to that location.
1231 **************************************************************************/
1232
1233 static void branchParen(FICL_VM *pVM)
1234 {
1235     vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1236     return;
1237 }
1238
1239
1240 /**************************************************************************
1241                         b r a n c h 0
1242 ** Runtime code for "(branch0)"; pop a flag from the stack,
1243 ** branch if 0. fall through otherwise.  The heart of "if" and "until".
1244 **************************************************************************/
1245
1246 static void branch0(FICL_VM *pVM)
1247 {
1248     FICL_UNS flag;
1249     
1250 #if FICL_ROBUST > 1
1251     vmCheckStack(pVM, 1, 0);
1252 #endif
1253     flag = stackPopUNS(pVM->pStack);
1254
1255     if (flag) 
1256     {                           /* fall through */
1257         vmBranchRelative(pVM, 1);
1258     }
1259     else 
1260     {                           /* take branch (to else/endif/begin) */
1261         vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1262     }
1263
1264     return;
1265 }
1266
1267
1268 /**************************************************************************
1269                         i f C o I m
1270 ** IMMEDIATE COMPILE-ONLY
1271 ** Compiles code for a conditional branch into the dictionary
1272 ** and pushes the branch patch address on the stack for later
1273 ** patching by ELSE or THEN/ENDIF. 
1274 **************************************************************************/
1275
1276 static void ifCoIm(FICL_VM *pVM)
1277 {
1278     FICL_DICT *dp = vmGetDict(pVM);
1279
1280     assert(pVM->pSys->pBranch0);
1281
1282     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
1283     markBranch(dp, pVM, origTag);
1284     dictAppendUNS(dp, 1);
1285     return;
1286 }
1287
1288
1289 /**************************************************************************
1290                         e l s e C o I m
1291 ** 
1292 ** IMMEDIATE COMPILE-ONLY
1293 ** compiles an "else"...
1294 ** 1) Compile a branch and a patch address; the address gets patched
1295 **    by "endif" to point past the "else" code.
1296 ** 2) Pop the the "if" patch address
1297 ** 3) Patch the "if" branch to point to the current compile address.
1298 ** 4) Push the "else" patch address. ("endif" patches this to jump past 
1299 **    the "else" code.
1300 **************************************************************************/
1301
1302 static void elseCoIm(FICL_VM *pVM)
1303 {
1304     CELL *patchAddr;
1305     FICL_INT offset;
1306     FICL_DICT *dp = vmGetDict(pVM);
1307
1308     assert(pVM->pSys->pBranchParen);
1309                                             /* (1) compile branch runtime */
1310     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1311     matchControlTag(pVM, origTag);
1312     patchAddr = 
1313         (CELL *)stackPopPtr(pVM->pStack);   /* (2) pop "if" patch addr */
1314     markBranch(dp, pVM, origTag);           /* (4) push "else" patch addr */
1315     dictAppendUNS(dp, 1);                 /* (1) compile patch placeholder */
1316     offset = dp->here - patchAddr;
1317     *patchAddr = LVALUEtoCELL(offset);      /* (3) Patch "if" */
1318
1319     return;
1320 }
1321
1322
1323 /**************************************************************************
1324                         e n d i f C o I m
1325 ** IMMEDIATE COMPILE-ONLY
1326 **************************************************************************/
1327
1328 static void endifCoIm(FICL_VM *pVM)
1329 {
1330     FICL_DICT *dp = vmGetDict(pVM);
1331     resolveForwardBranch(dp, pVM, origTag);
1332     return;
1333 }
1334
1335
1336 /**************************************************************************
1337                         c a s e C o I m
1338 ** IMMEDIATE COMPILE-ONLY
1339 **
1340 **
1341 ** At compile-time, a CASE-SYS (see DPANS94 6.2.0873) looks like this:
1342 **                      i*addr i caseTag
1343 ** and an OF-SYS (see DPANS94 6.2.1950) looks like this:
1344 **                      i*addr i caseTag addr ofTag
1345 ** The integer under caseTag is the count of fixup addresses that branch
1346 ** to ENDCASE.
1347 **************************************************************************/
1348
1349 static void caseCoIm(FICL_VM *pVM)
1350 {
1351 #if FICL_ROBUST > 1
1352     vmCheckStack(pVM, 0, 2);
1353 #endif
1354
1355         PUSHUNS(0);
1356         markControlTag(pVM, caseTag);
1357     return;
1358 }
1359
1360
1361 /**************************************************************************
1362                         e n d c a s eC o I m
1363 ** IMMEDIATE COMPILE-ONLY
1364 **************************************************************************/
1365
1366 static void endcaseCoIm(FICL_VM *pVM)
1367 {
1368         FICL_UNS fixupCount;
1369     FICL_DICT *dp;
1370     CELL *patchAddr;
1371     FICL_INT offset;
1372
1373     assert(pVM->pSys->pDrop);
1374
1375         /*
1376         ** if the last OF ended with FALLTHROUGH,
1377         ** just add the FALLTHROUGH fixup to the
1378         ** ENDOF fixups
1379         */
1380         if (stackGetTop(pVM->pStack).p == fallthroughTag)
1381         {
1382                 matchControlTag(pVM, fallthroughTag);
1383                 patchAddr = POPPTR();
1384             matchControlTag(pVM, caseTag);
1385                 fixupCount = POPUNS();
1386                 PUSHPTR(patchAddr);
1387                 PUSHUNS(fixupCount + 1);
1388                 markControlTag(pVM, caseTag);
1389         }
1390
1391     matchControlTag(pVM, caseTag);
1392
1393 #if FICL_ROBUST > 1
1394     vmCheckStack(pVM, 1, 0);
1395 #endif
1396         fixupCount = POPUNS();
1397 #if FICL_ROBUST > 1
1398     vmCheckStack(pVM, fixupCount, 0);
1399 #endif
1400
1401     dp = vmGetDict(pVM);
1402
1403     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop));
1404
1405         while (fixupCount--)
1406         {
1407                 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1408                 offset = dp->here - patchAddr;
1409                 *patchAddr = LVALUEtoCELL(offset);
1410         }
1411     return;
1412 }
1413
1414
1415 static void ofParen(FICL_VM *pVM)
1416 {
1417         FICL_UNS a, b;
1418
1419 #if FICL_ROBUST > 1
1420     vmCheckStack(pVM, 2, 1);
1421 #endif
1422
1423         a = POPUNS();
1424         b = stackGetTop(pVM->pStack).u;
1425
1426     if (a == b)
1427     {                           /* fall through */
1428                 stackDrop(pVM->pStack, 1);
1429         vmBranchRelative(pVM, 1);
1430     }
1431     else 
1432     {                           /* take branch to next of or endswitch */
1433         vmBranchRelative(pVM, *(int *)(pVM->ip));
1434     }
1435
1436     return;
1437 }
1438
1439
1440 /**************************************************************************
1441                         o f C o I m
1442 ** IMMEDIATE COMPILE-ONLY
1443 **************************************************************************/
1444
1445 static void ofCoIm(FICL_VM *pVM)
1446 {
1447     FICL_DICT *dp = vmGetDict(pVM);
1448         CELL *fallthroughFixup = NULL;
1449
1450     assert(pVM->pSys->pBranch0);
1451
1452 #if FICL_ROBUST > 1
1453     vmCheckStack(pVM, 1, 3);
1454 #endif
1455
1456         if (stackGetTop(pVM->pStack).p == fallthroughTag)
1457         {
1458                 matchControlTag(pVM, fallthroughTag);
1459                 fallthroughFixup = POPPTR();
1460         }
1461
1462         matchControlTag(pVM, caseTag);
1463
1464         markControlTag(pVM, caseTag);
1465
1466     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen));
1467     markBranch(dp, pVM, ofTag);
1468     dictAppendUNS(dp, 2);
1469
1470         if (fallthroughFixup != NULL)
1471         {
1472                 FICL_INT offset = dp->here - fallthroughFixup;
1473                 *fallthroughFixup = LVALUEtoCELL(offset);
1474         }
1475
1476     return;
1477 }
1478
1479
1480 /**************************************************************************
1481                     e n d o f C o I m
1482 ** IMMEDIATE COMPILE-ONLY
1483 **************************************************************************/
1484
1485 static void endofCoIm(FICL_VM *pVM)
1486 {
1487     CELL *patchAddr;
1488     FICL_UNS fixupCount;
1489     FICL_INT offset;
1490     FICL_DICT *dp = vmGetDict(pVM);
1491
1492 #if FICL_ROBUST > 1
1493     vmCheckStack(pVM, 4, 3);
1494 #endif
1495
1496     assert(pVM->pSys->pBranchParen);
1497
1498         /* ensure we're in an OF, */
1499     matchControlTag(pVM, ofTag);
1500         /* grab the address of the branch location after the OF */
1501     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1502         /* ensure we're also in a "case" */
1503     matchControlTag(pVM, caseTag);
1504         /* grab the current number of ENDOF fixups */
1505         fixupCount = POPUNS();
1506
1507     /* compile branch runtime */
1508     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1509
1510         /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */
1511     PUSHPTR(dp->here);
1512     PUSHUNS(fixupCount + 1);
1513         markControlTag(pVM, caseTag);
1514
1515         /* reserve space for the ENDOF fixup */
1516     dictAppendUNS(dp, 2);
1517
1518         /* and patch the original OF */
1519     offset = dp->here - patchAddr;
1520     *patchAddr = LVALUEtoCELL(offset);
1521 }
1522
1523
1524 /**************************************************************************
1525                     f a l l t h r o u g h C o I m
1526 ** IMMEDIATE COMPILE-ONLY
1527 **************************************************************************/
1528
1529 static void fallthroughCoIm(FICL_VM *pVM)
1530 {
1531     CELL *patchAddr;
1532     FICL_INT offset;
1533     FICL_DICT *dp = vmGetDict(pVM);
1534
1535 #if FICL_ROBUST > 1
1536     vmCheckStack(pVM, 4, 3);
1537 #endif
1538
1539         /* ensure we're in an OF, */
1540     matchControlTag(pVM, ofTag);
1541         /* grab the address of the branch location after the OF */
1542     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1543         /* ensure we're also in a "case" */
1544     matchControlTag(pVM, caseTag);
1545
1546         /* okay, here we go.  put the case tag back. */
1547         markControlTag(pVM, caseTag);
1548
1549     /* compile branch runtime */
1550     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1551
1552         /* push a new FALLTHROUGH fixup and the fallthroughTag */
1553     PUSHPTR(dp->here);
1554         markControlTag(pVM, fallthroughTag);
1555
1556         /* reserve space for the FALLTHROUGH fixup */
1557     dictAppendUNS(dp, 2);
1558
1559         /* and patch the original OF */
1560     offset = dp->here - patchAddr;
1561     *patchAddr = LVALUEtoCELL(offset);
1562 }
1563
1564 /**************************************************************************
1565                         h a s h
1566 ** hash ( c-addr u -- code)
1567 ** calculates hashcode of specified string and leaves it on the stack
1568 **************************************************************************/
1569
1570 static void hash(FICL_VM *pVM)
1571 {
1572     STRINGINFO si;
1573     SI_SETLEN(si, stackPopUNS(pVM->pStack));
1574     SI_SETPTR(si, stackPopPtr(pVM->pStack));
1575     PUSHUNS(hashHashCode(si));
1576     return;
1577 }
1578
1579
1580 /**************************************************************************
1581                         i n t e r p r e t 
1582 ** This is the "user interface" of a Forth. It does the following:
1583 **   while there are words in the VM's Text Input Buffer
1584 **     Copy next word into the pad (vmGetWord)
1585 **     Attempt to find the word in the dictionary (dictLookup)
1586 **     If successful, execute the word.
1587 **     Otherwise, attempt to convert the word to a number (isNumber)
1588 **     If successful, push the number onto the parameter stack.
1589 **     Otherwise, print an error message and exit loop...
1590 **   End Loop
1591 **
1592 ** From the standard, section 3.4
1593 ** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1594 ** repeat the following steps until either the parse area is empty or an 
1595 ** ambiguous condition exists: 
1596 ** a) Skip leading spaces and parse a name (see 3.4.1); 
1597 **************************************************************************/
1598
1599 static void interpret(FICL_VM *pVM)
1600 {
1601     STRINGINFO si;
1602     int i;
1603     FICL_SYSTEM *pSys;
1604
1605     assert(pVM);
1606
1607     pSys = pVM->pSys;
1608     si   = vmGetWord0(pVM);
1609
1610     /*
1611     ** Get next word...if out of text, we're done.
1612     */
1613     if (si.count == 0)
1614     {
1615         vmThrow(pVM, VM_OUTOFTEXT);
1616     }
1617
1618     /*
1619     ** Attempt to find the incoming token in the dictionary. If that fails...
1620     ** run the parse chain against the incoming token until somebody eats it.
1621     ** Otherwise emit an error message and give up.
1622     ** Although ficlParseWord could be part of the parse list, I've hard coded it
1623     ** in for robustness. ficlInitSystem adds the other default steps to the list.
1624     */
1625     if (ficlParseWord(pVM, si))
1626         return;
1627
1628     for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1629     {
1630         FICL_WORD *pFW = pSys->parseList[i];
1631            
1632         if (pFW == NULL)
1633             break;
1634
1635         if (pFW->code == parseStepParen)
1636         {
1637             FICL_PARSE_STEP pStep;
1638             pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1639             if ((*pStep)(pVM, si))
1640                 return;
1641         }
1642         else
1643         {
1644             stackPushPtr(pVM->pStack, SI_PTR(si));
1645             stackPushUNS(pVM->pStack, SI_COUNT(si));
1646             ficlExecXT(pVM, pFW);
1647             if (stackPopINT(pVM->pStack))
1648                 return;
1649         }
1650     }
1651
1652     i = SI_COUNT(si);
1653     vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1654
1655     return;                 /* back to inner interpreter */
1656 }
1657
1658
1659 /**************************************************************************
1660                         f i c l P a r s e W o r d
1661 ** From the standard, section 3.4
1662 ** b) Search the dictionary name space (see 3.4.2). If a definition name
1663 ** matching the string is found: 
1664 **  1.if interpreting, perform the interpretation semantics of the definition
1665 **  (see 3.4.3.2), and continue at a); 
1666 **  2.if compiling, perform the compilation semantics of the definition
1667 **  (see 3.4.3.3), and continue at a). 
1668 **
1669 ** c) If a definition name matching the string is not found, attempt to
1670 ** convert the string to a number (see 3.4.1.3). If successful: 
1671 **  1.if interpreting, place the number on the data stack, and continue at a); 
1672 **  2.if compiling, compile code that when executed will place the number on
1673 **  the stack (see 6.1.1780 LITERAL), and continue at a); 
1674 **
1675 ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 
1676 **
1677 ** (jws 4/01) Modified to be a FICL_PARSE_STEP
1678 **************************************************************************/
1679 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1680 {
1681     FICL_DICT *dp = vmGetDict(pVM);
1682     FICL_WORD *tempFW;
1683
1684 #if FICL_ROBUST
1685     dictCheck(dp, pVM, 0);
1686     vmCheckStack(pVM, 0, 0);
1687 #endif
1688
1689 #if FICL_WANT_LOCALS
1690     if (pVM->pSys->nLocals > 0)
1691     {
1692         tempFW = ficlLookupLoc(pVM->pSys, si);
1693     }
1694     else
1695 #endif
1696     tempFW = dictLookup(dp, si);
1697
1698     if (pVM->state == INTERPRET)
1699     {
1700         if (tempFW != NULL)
1701         {
1702             if (wordIsCompileOnly(tempFW))
1703             {
1704                 vmThrowErr(pVM, "Error: Compile only!");
1705             }
1706
1707             vmExecute(pVM, tempFW);
1708             return (int)FICL_TRUE;
1709         }
1710     }
1711
1712     else /* (pVM->state == COMPILE) */
1713     {
1714         if (tempFW != NULL)
1715         {
1716             if (wordIsImmediate(tempFW))
1717             {
1718                 vmExecute(pVM, tempFW);
1719             }
1720             else
1721             {
1722                 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1723             }
1724             return (int)FICL_TRUE;
1725         }
1726     }
1727
1728     return FICL_FALSE;
1729 }
1730
1731
1732 /*
1733 ** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in 
1734 ** INTERPRET)
1735 */
1736 static void lookup(FICL_VM *pVM)
1737 {
1738     STRINGINFO si;
1739     SI_SETLEN(si, stackPopUNS(pVM->pStack));
1740     SI_SETPTR(si, stackPopPtr(pVM->pStack));
1741     stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
1742     return;
1743 }
1744
1745
1746 /**************************************************************************
1747                         p a r e n P a r s e S t e p
1748 ** (parse-step)  ( c-addr u -- flag )
1749 ** runtime for a precompiled parse step - pop a counted string off the
1750 ** stack, run the parse step against it, and push the result flag (FICL_TRUE
1751 ** if success, FICL_FALSE otherwise).
1752 **************************************************************************/
1753
1754 void parseStepParen(FICL_VM *pVM)
1755 {
1756     STRINGINFO si;
1757     FICL_WORD *pFW = pVM->runningWord;
1758     FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1759
1760     SI_SETLEN(si, stackPopINT(pVM->pStack));
1761     SI_SETPTR(si, stackPopPtr(pVM->pStack));
1762     
1763     PUSHINT((*pStep)(pVM, si));
1764
1765     return;
1766 }
1767
1768
1769 static void addParseStep(FICL_VM *pVM)
1770 {
1771     FICL_WORD *pStep;
1772     FICL_DICT *pd = vmGetDict(pVM);
1773 #if FICL_ROBUST > 1
1774     vmCheckStack(pVM, 1, 0);
1775 #endif
1776     pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1777     if ((pStep != NULL) && isAFiclWord(pd, pStep))
1778         ficlAddParseStep(pVM->pSys, pStep);
1779     return;
1780 }
1781
1782
1783 /**************************************************************************
1784                         l i t e r a l P a r e n
1785 ** 
1786 ** This is the runtime for (literal). It assumes that it is part of a colon
1787 ** definition, and that the next CELL contains a value to be pushed on the
1788 ** parameter stack at runtime. This code is compiled by "literal".
1789 **
1790 **************************************************************************/
1791
1792 static void literalParen(FICL_VM *pVM)
1793 {
1794 #if FICL_ROBUST > 1
1795     vmCheckStack(pVM, 0, 1);
1796 #endif
1797     PUSHINT(*(FICL_INT *)(pVM->ip));
1798     vmBranchRelative(pVM, 1);
1799     return;
1800 }
1801
1802 static void twoLitParen(FICL_VM *pVM)
1803 {
1804 #if FICL_ROBUST > 1
1805     vmCheckStack(pVM, 0, 2);
1806 #endif
1807     PUSHINT(*((FICL_INT *)(pVM->ip)+1));
1808     PUSHINT(*(FICL_INT *)(pVM->ip));
1809     vmBranchRelative(pVM, 2);
1810     return;
1811 }
1812
1813
1814 /**************************************************************************
1815                         l i t e r a l I m
1816 ** 
1817 ** IMMEDIATE code for "literal". This function gets a value from the stack 
1818 ** and compiles it into the dictionary preceded by the code for "(literal)".
1819 ** IMMEDIATE
1820 **************************************************************************/
1821
1822 static void literalIm(FICL_VM *pVM)
1823 {
1824     FICL_DICT *dp = vmGetDict(pVM);
1825     assert(pVM->pSys->pLitParen);
1826
1827     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
1828     dictAppendCell(dp, stackPop(pVM->pStack));
1829
1830     return;
1831 }
1832
1833
1834 static void twoLiteralIm(FICL_VM *pVM)
1835 {
1836     FICL_DICT *dp = vmGetDict(pVM);
1837     assert(pVM->pSys->pTwoLitParen);
1838
1839     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
1840     dictAppendCell(dp, stackPop(pVM->pStack));
1841     dictAppendCell(dp, stackPop(pVM->pStack));
1842
1843     return;
1844 }
1845
1846 /**************************************************************************
1847                         l o g i c   a n d   c o m p a r i s o n s
1848 ** 
1849 **************************************************************************/
1850
1851 static void zeroEquals(FICL_VM *pVM)
1852 {
1853     CELL c;
1854 #if FICL_ROBUST > 1
1855     vmCheckStack(pVM, 1, 1);
1856 #endif
1857     c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
1858     stackPush(pVM->pStack, c);
1859     return;
1860 }
1861
1862 static void zeroLess(FICL_VM *pVM)
1863 {
1864     CELL c;
1865 #if FICL_ROBUST > 1
1866     vmCheckStack(pVM, 1, 1);
1867 #endif
1868     c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
1869     stackPush(pVM->pStack, c);
1870     return;
1871 }
1872
1873 static void zeroGreater(FICL_VM *pVM)
1874 {
1875     CELL c;
1876 #if FICL_ROBUST > 1
1877     vmCheckStack(pVM, 1, 1);
1878 #endif
1879     c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
1880     stackPush(pVM->pStack, c);
1881     return;
1882 }
1883
1884 static void isEqual(FICL_VM *pVM)
1885 {
1886     CELL x, y;
1887
1888 #if FICL_ROBUST > 1
1889     vmCheckStack(pVM, 2, 1);
1890 #endif
1891     x = stackPop(pVM->pStack);
1892     y = stackPop(pVM->pStack);
1893     PUSHINT(FICL_BOOL(x.i == y.i));
1894     return;
1895 }
1896
1897 static void isLess(FICL_VM *pVM)
1898 {
1899     CELL x, y;
1900 #if FICL_ROBUST > 1
1901     vmCheckStack(pVM, 2, 1);
1902 #endif
1903     y = stackPop(pVM->pStack);
1904     x = stackPop(pVM->pStack);
1905     PUSHINT(FICL_BOOL(x.i < y.i));
1906     return;
1907 }
1908
1909 static void uIsLess(FICL_VM *pVM)
1910 {
1911     FICL_UNS u1, u2;
1912 #if FICL_ROBUST > 1
1913     vmCheckStack(pVM, 2, 1);
1914 #endif
1915     u2 = stackPopUNS(pVM->pStack);
1916     u1 = stackPopUNS(pVM->pStack);
1917     PUSHINT(FICL_BOOL(u1 < u2));
1918     return;
1919 }
1920
1921 static void isGreater(FICL_VM *pVM)
1922 {
1923     CELL x, y;
1924 #if FICL_ROBUST > 1
1925     vmCheckStack(pVM, 2, 1);
1926 #endif
1927     y = stackPop(pVM->pStack);
1928     x = stackPop(pVM->pStack);
1929     PUSHINT(FICL_BOOL(x.i > y.i));
1930     return;
1931 }
1932
1933 static void bitwiseAnd(FICL_VM *pVM)
1934 {
1935     CELL x, y;
1936 #if FICL_ROBUST > 1
1937     vmCheckStack(pVM, 2, 1);
1938 #endif
1939     x = stackPop(pVM->pStack);
1940     y = stackPop(pVM->pStack);
1941     PUSHINT(x.i & y.i);
1942     return;
1943 }
1944
1945 static void bitwiseOr(FICL_VM *pVM)
1946 {
1947     CELL x, y;
1948 #if FICL_ROBUST > 1
1949     vmCheckStack(pVM, 2, 1);
1950 #endif
1951     x = stackPop(pVM->pStack);
1952     y = stackPop(pVM->pStack);
1953     PUSHINT(x.i | y.i);
1954     return;
1955 }
1956
1957 static void bitwiseXor(FICL_VM *pVM)
1958 {
1959     CELL x, y;
1960 #if FICL_ROBUST > 1
1961     vmCheckStack(pVM, 2, 1);
1962 #endif
1963     x = stackPop(pVM->pStack);
1964     y = stackPop(pVM->pStack);
1965     PUSHINT(x.i ^ y.i);
1966     return;
1967 }
1968
1969 static void bitwiseNot(FICL_VM *pVM)
1970 {
1971     CELL x;
1972 #if FICL_ROBUST > 1
1973     vmCheckStack(pVM, 1, 1);
1974 #endif
1975     x = stackPop(pVM->pStack);
1976     PUSHINT(~x.i);
1977     return;
1978 }
1979
1980
1981 /**************************************************************************
1982                                D o  /  L o o p
1983 ** do -- IMMEDIATE COMPILE ONLY
1984 **    Compiles code to initialize a loop: compile (do), 
1985 **    allot space to hold the "leave" address, push a branch
1986 **    target address for the loop.
1987 ** (do) -- runtime for "do"
1988 **    pops index and limit from the p stack and moves them
1989 **    to the r stack, then skips to the loop body.
1990 ** loop -- IMMEDIATE COMPILE ONLY
1991 ** +loop
1992 **    Compiles code for the test part of a loop:
1993 **    compile (loop), resolve forward branch from "do", and
1994 **    copy "here" address to the "leave" address allotted by "do"
1995 ** i,j,k -- COMPILE ONLY
1996 **    Runtime: Push loop indices on param stack (i is innermost loop...)
1997 **    Note: each loop has three values on the return stack:
1998 **    ( R: leave limit index )
1999 **    "leave" is the absolute address of the next cell after the loop
2000 **    limit and index are the loop control variables.
2001 ** leave -- COMPILE ONLY
2002 **    Runtime: pop the loop control variables, then pop the
2003 **    "leave" address and jump (absolute) there.
2004 **************************************************************************/
2005
2006 static void doCoIm(FICL_VM *pVM)
2007 {
2008     FICL_DICT *dp = vmGetDict(pVM);
2009
2010     assert(pVM->pSys->pDoParen);
2011
2012     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
2013     /*
2014     ** Allot space for a pointer to the end
2015     ** of the loop - "leave" uses this...
2016     */
2017     markBranch(dp, pVM, leaveTag);
2018     dictAppendUNS(dp, 0);
2019     /*
2020     ** Mark location of head of loop...
2021     */
2022     markBranch(dp, pVM, doTag);
2023
2024     return;
2025 }
2026
2027
2028 static void doParen(FICL_VM *pVM)
2029 {
2030     CELL index, limit;
2031 #if FICL_ROBUST > 1
2032     vmCheckStack(pVM, 2, 0);
2033 #endif
2034     index = stackPop(pVM->pStack);
2035     limit = stackPop(pVM->pStack);
2036
2037     /* copy "leave" target addr to stack */
2038     stackPushPtr(pVM->rStack, *(pVM->ip++));
2039     stackPush(pVM->rStack, limit);
2040     stackPush(pVM->rStack, index);
2041
2042     return;
2043 }
2044
2045
2046 static void qDoCoIm(FICL_VM *pVM)
2047 {
2048     FICL_DICT *dp = vmGetDict(pVM);
2049
2050     assert(pVM->pSys->pQDoParen);
2051
2052     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
2053     /*
2054     ** Allot space for a pointer to the end
2055     ** of the loop - "leave" uses this...
2056     */
2057     markBranch(dp, pVM, leaveTag);
2058     dictAppendUNS(dp, 0);
2059     /*
2060     ** Mark location of head of loop...
2061     */
2062     markBranch(dp, pVM, doTag);
2063
2064     return;
2065 }
2066
2067
2068 static void qDoParen(FICL_VM *pVM)
2069 {
2070     CELL index, limit;
2071 #if FICL_ROBUST > 1
2072     vmCheckStack(pVM, 2, 0);
2073 #endif
2074     index = stackPop(pVM->pStack);
2075     limit = stackPop(pVM->pStack);
2076
2077     /* copy "leave" target addr to stack */
2078     stackPushPtr(pVM->rStack, *(pVM->ip++));
2079
2080     if (limit.u == index.u)
2081     {
2082         vmPopIP(pVM);
2083     }
2084     else
2085     {
2086         stackPush(pVM->rStack, limit);
2087         stackPush(pVM->rStack, index);
2088     }
2089
2090     return;
2091 }
2092
2093
2094 /*
2095 ** Runtime code to break out of a do..loop construct
2096 ** Drop the loop control variables; the branch address
2097 ** past "loop" is next on the return stack.
2098 */
2099 static void leaveCo(FICL_VM *pVM)
2100 {
2101     /* almost unloop */
2102     stackDrop(pVM->rStack, 2);
2103     /* exit */
2104     vmPopIP(pVM);
2105     return;
2106 }
2107
2108
2109 static void unloopCo(FICL_VM *pVM)
2110 {
2111     stackDrop(pVM->rStack, 3);
2112     return;
2113 }
2114
2115
2116 static void loopCoIm(FICL_VM *pVM)
2117 {
2118     FICL_DICT *dp = vmGetDict(pVM);
2119
2120     assert(pVM->pSys->pLoopParen);
2121
2122     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
2123     resolveBackBranch(dp, pVM, doTag);
2124     resolveAbsBranch(dp, pVM, leaveTag);
2125     return;
2126 }
2127
2128
2129 static void plusLoopCoIm(FICL_VM *pVM)
2130 {
2131     FICL_DICT *dp = vmGetDict(pVM);
2132
2133     assert(pVM->pSys->pPLoopParen);
2134
2135     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
2136     resolveBackBranch(dp, pVM, doTag);
2137     resolveAbsBranch(dp, pVM, leaveTag);
2138     return;
2139 }
2140
2141
2142 static void loopParen(FICL_VM *pVM)
2143 {
2144     FICL_INT index = stackGetTop(pVM->rStack).i;
2145     FICL_INT limit = stackFetch(pVM->rStack, 1).i;
2146
2147     index++;
2148
2149     if (index >= limit) 
2150     {
2151         stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
2152         vmBranchRelative(pVM, 1);  /* fall through the loop */
2153     }
2154     else 
2155     {                       /* update index, branch to loop head */
2156         stackSetTop(pVM->rStack, LVALUEtoCELL(index));
2157         vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
2158     }
2159
2160     return;
2161 }
2162
2163
2164 static void plusLoopParen(FICL_VM *pVM)
2165 {
2166     FICL_INT index,limit,increment;
2167     int flag;
2168
2169 #if FICL_ROBUST > 1
2170     vmCheckStack(pVM, 1, 0);
2171 #endif
2172
2173     index = stackGetTop(pVM->rStack).i;
2174     limit = stackFetch(pVM->rStack, 1).i;
2175     increment = POP().i;
2176     
2177     index += increment;
2178
2179     if (increment < 0)
2180         flag = (index < limit);
2181     else
2182         flag = (index >= limit);
2183
2184     if (flag) 
2185     {
2186         stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
2187         vmBranchRelative(pVM, 1);  /* fall through the loop */
2188     }
2189     else 
2190     {                       /* update index, branch to loop head */
2191         stackSetTop(pVM->rStack, LVALUEtoCELL(index));
2192         vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
2193     }
2194
2195     return;
2196 }
2197
2198
2199 static void loopICo(FICL_VM *pVM)
2200 {
2201     CELL index = stackGetTop(pVM->rStack);
2202     stackPush(pVM->pStack, index);
2203
2204     return;
2205 }
2206
2207
2208 static void loopJCo(FICL_VM *pVM)
2209 {
2210     CELL index = stackFetch(pVM->rStack, 3);
2211     stackPush(pVM->pStack, index);
2212
2213     return;
2214 }
2215
2216
2217 static void loopKCo(FICL_VM *pVM)
2218 {
2219     CELL index = stackFetch(pVM->rStack, 6);
2220     stackPush(pVM->pStack, index);
2221
2222     return;
2223 }
2224
2225
2226 /**************************************************************************
2227                         r e t u r n   s t a c k
2228 ** 
2229 **************************************************************************/
2230 static void toRStack(FICL_VM *pVM)
2231 {
2232 #if FICL_ROBUST > 1
2233     vmCheckStack(pVM, 1, 0);
2234 #endif
2235
2236     stackPush(pVM->rStack, POP());
2237 }
2238
2239 static void fromRStack(FICL_VM *pVM)
2240 {
2241 #if FICL_ROBUST > 1
2242     vmCheckStack(pVM, 0, 1);
2243 #endif
2244
2245     PUSH(stackPop(pVM->rStack));
2246 }
2247
2248 static void fetchRStack(FICL_VM *pVM)
2249 {
2250 #if FICL_ROBUST > 1
2251     vmCheckStack(pVM, 0, 1);
2252 #endif
2253
2254     PUSH(stackGetTop(pVM->rStack));
2255 }
2256
2257 static void twoToR(FICL_VM *pVM)
2258 {
2259 #if FICL_ROBUST > 1
2260     vmCheckStack(pVM, 2, 0);
2261 #endif
2262     stackRoll(pVM->pStack, 1);
2263     stackPush(pVM->rStack, stackPop(pVM->pStack));
2264     stackPush(pVM->rStack, stackPop(pVM->pStack));
2265     return;
2266 }
2267
2268 static void twoRFrom(FICL_VM *pVM)
2269 {
2270 #if FICL_ROBUST > 1
2271     vmCheckStack(pVM, 0, 2);
2272 #endif
2273     stackPush(pVM->pStack, stackPop(pVM->rStack));
2274     stackPush(pVM->pStack, stackPop(pVM->rStack));
2275     stackRoll(pVM->pStack, 1);
2276     return;
2277 }
2278
2279 static void twoRFetch(FICL_VM *pVM)
2280 {
2281 #if FICL_ROBUST > 1
2282     vmCheckStack(pVM, 0, 2);
2283 #endif
2284     stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2285     stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2286     return;
2287 }
2288
2289
2290 /**************************************************************************
2291                         v a r i a b l e
2292 ** 
2293 **************************************************************************/
2294
2295 static void variableParen(FICL_VM *pVM)
2296 {
2297     FICL_WORD *fw;
2298 #if FICL_ROBUST > 1
2299     vmCheckStack(pVM, 0, 1);
2300 #endif
2301
2302     fw = pVM->runningWord;
2303     PUSHPTR(fw->param);
2304 }
2305
2306
2307 static void variable(FICL_VM *pVM)
2308 {
2309     FICL_DICT *dp = vmGetDict(pVM);
2310     STRINGINFO si = vmGetWord(pVM);
2311
2312     dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2313     dictAllotCells(dp, 1);
2314     return;
2315 }
2316
2317
2318 static void twoVariable(FICL_VM *pVM)
2319 {
2320     FICL_DICT *dp = vmGetDict(pVM);
2321     STRINGINFO si = vmGetWord(pVM);
2322
2323     dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2324     dictAllotCells(dp, 2);
2325     return;
2326 }
2327
2328
2329 /**************************************************************************
2330                         b a s e   &   f r i e n d s
2331 ** 
2332 **************************************************************************/
2333
2334 static void base(FICL_VM *pVM)
2335 {
2336     CELL *pBase;
2337 #if FICL_ROBUST > 1
2338     vmCheckStack(pVM, 0, 1);
2339 #endif
2340
2341     pBase = (CELL *)(&pVM->base);
2342     stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2343     return;
2344 }
2345
2346
2347 static void decimal(FICL_VM *pVM)
2348 {
2349     pVM->base = 10;
2350     return;
2351 }
2352
2353
2354 static void hex(FICL_VM *pVM)
2355 {
2356     pVM->base = 16;
2357     return;
2358 }
2359
2360
2361 /**************************************************************************
2362                         a l l o t   &   f r i e n d s
2363 ** 
2364 **************************************************************************/
2365
2366 static void allot(FICL_VM *pVM)
2367 {
2368     FICL_DICT *dp;
2369     FICL_INT i;
2370 #if FICL_ROBUST > 1
2371     vmCheckStack(pVM, 1, 0);
2372 #endif
2373
2374     dp = vmGetDict(pVM);
2375     i = POPINT();
2376
2377 #if FICL_ROBUST
2378     dictCheck(dp, pVM, i);
2379 #endif
2380
2381     dictAllot(dp, i);
2382     return;
2383 }
2384
2385
2386 static void here(FICL_VM *pVM)
2387 {
2388     FICL_DICT *dp;
2389 #if FICL_ROBUST > 1
2390     vmCheckStack(pVM, 0, 1);
2391 #endif
2392
2393     dp = vmGetDict(pVM);
2394     PUSHPTR(dp->here);
2395     return;
2396 }
2397
2398 static void comma(FICL_VM *pVM)
2399 {
2400     FICL_DICT *dp;
2401     CELL c;
2402 #if FICL_ROBUST > 1
2403     vmCheckStack(pVM, 1, 0);
2404 #endif
2405
2406     dp = vmGetDict(pVM);
2407     c = POP();
2408     dictAppendCell(dp, c);
2409     return;
2410 }
2411
2412 static void cComma(FICL_VM *pVM)
2413 {
2414     FICL_DICT *dp;
2415     char c;
2416 #if FICL_ROBUST > 1
2417     vmCheckStack(pVM, 1, 0);
2418 #endif
2419
2420     dp = vmGetDict(pVM);
2421     c = (char)POPINT();
2422     dictAppendChar(dp, c);
2423     return;
2424 }
2425
2426 static void cells(FICL_VM *pVM)
2427 {
2428     FICL_INT i;
2429 #if FICL_ROBUST > 1
2430     vmCheckStack(pVM, 1, 1);
2431 #endif
2432
2433     i = POPINT();
2434     PUSHINT(i * (FICL_INT)sizeof (CELL));
2435     return;
2436 }
2437
2438 static void cellPlus(FICL_VM *pVM)
2439 {
2440     char *cp;
2441 #if FICL_ROBUST > 1
2442     vmCheckStack(pVM, 1, 1);
2443 #endif
2444
2445     cp = POPPTR();
2446     PUSHPTR(cp + sizeof (CELL));
2447     return;
2448 }
2449
2450
2451
2452 /**************************************************************************
2453                         t i c k
2454 ** tick         CORE ( "<spaces>name" -- xt )
2455 ** Skip leading space delimiters. Parse name delimited by a space. Find
2456 ** name and return xt, the execution token for name. An ambiguous condition
2457 ** exists if name is not found. 
2458 **************************************************************************/
2459 void ficlTick(FICL_VM *pVM)
2460 {
2461     FICL_WORD *pFW = NULL;
2462     STRINGINFO si = vmGetWord(pVM);
2463 #if FICL_ROBUST > 1
2464     vmCheckStack(pVM, 0, 1);
2465 #endif
2466
2467     pFW = dictLookup(vmGetDict(pVM), si);
2468     if (!pFW)
2469     {
2470         int i = SI_COUNT(si);
2471         vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2472     }
2473     PUSHPTR(pFW);
2474     return;
2475 }
2476
2477
2478 static void bracketTickCoIm(FICL_VM *pVM)
2479 {
2480     ficlTick(pVM);
2481     literalIm(pVM);
2482     
2483     return;
2484 }
2485
2486
2487 /**************************************************************************
2488                         p o s t p o n e
2489 ** Lookup the next word in the input stream and compile code to 
2490 ** insert it into definitions created by the resulting word
2491 ** (defers compilation, even of immediate words)
2492 **************************************************************************/
2493
2494 static void postponeCoIm(FICL_VM *pVM)
2495 {
2496     FICL_DICT *dp  = vmGetDict(pVM);
2497     FICL_WORD *pFW;
2498     FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2499     assert(pComma);
2500
2501     ficlTick(pVM);
2502     pFW = stackGetTop(pVM->pStack).p;
2503     if (wordIsImmediate(pFW))
2504     {
2505         dictAppendCell(dp, stackPop(pVM->pStack));
2506     }
2507     else
2508     {
2509         literalIm(pVM);
2510         dictAppendCell(dp, LVALUEtoCELL(pComma));
2511     }
2512     
2513     return;
2514 }
2515
2516
2517
2518 /**************************************************************************
2519                         e x e c u t e
2520 ** Pop an execution token (pointer to a word) off the stack and
2521 ** run it
2522 **************************************************************************/
2523
2524 static void execute(FICL_VM *pVM)
2525 {
2526     FICL_WORD *pFW;
2527 #if FICL_ROBUST > 1
2528     vmCheckStack(pVM, 1, 0);
2529 #endif
2530
2531     pFW = stackPopPtr(pVM->pStack);
2532     vmExecute(pVM, pFW);
2533
2534     return;
2535 }
2536
2537
2538 /**************************************************************************
2539                         i m m e d i a t e
2540 ** Make the most recently compiled word IMMEDIATE -- it executes even
2541 ** in compile state (most often used for control compiling words
2542 ** such as IF, THEN, etc)
2543 **************************************************************************/
2544
2545 static void immediate(FICL_VM *pVM)
2546 {
2547     IGNORE(pVM);
2548     dictSetImmediate(vmGetDict(pVM));
2549     return;
2550 }
2551
2552
2553 static void compileOnly(FICL_VM *pVM)
2554 {
2555     IGNORE(pVM);
2556     dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2557     return;
2558 }
2559
2560
2561 static void setObjectFlag(FICL_VM *pVM)
2562 {
2563     IGNORE(pVM);
2564     dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2565     return;
2566 }
2567
2568 static void isObject(FICL_VM *pVM)
2569 {
2570     int flag;
2571     FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2572     
2573     flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2574     stackPushINT(pVM->pStack, flag);
2575     return;
2576 }
2577
2578 static void cstringLit(FICL_VM *pVM)
2579 {
2580     FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2581
2582     char *cp = sp->text;
2583     cp += sp->count + 1;
2584     cp = alignPtr(cp);
2585     pVM->ip = (IPTYPE)(void *)cp;
2586
2587     stackPushPtr(pVM->pStack, sp);
2588     return;
2589 }
2590
2591
2592 static void cstringQuoteIm(FICL_VM *pVM)
2593 {
2594     FICL_DICT *dp = vmGetDict(pVM);
2595
2596     if (pVM->state == INTERPRET)
2597     {
2598         FICL_STRING *sp = (FICL_STRING *) dp->here;
2599         vmGetString(pVM, sp, '\"');
2600         stackPushPtr(pVM->pStack, sp);
2601                 /* move HERE past string so it doesn't get overwritten.  --lch */
2602                 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2603     }
2604     else    /* COMPILE state */
2605     {
2606         dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2607         dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2608         dictAlign(dp);
2609     }
2610
2611     return;
2612 }
2613
2614 /**************************************************************************
2615                         d o t Q u o t e
2616 ** IMMEDIATE word that compiles a string literal for later display
2617 ** Compile stringLit, then copy the bytes of the string from the TIB
2618 ** to the dictionary. Backpatch the count byte and align the dictionary.
2619 **
2620 ** stringlit: Fetch the count from the dictionary, then push the address
2621 ** and count on the stack. Finally, update ip to point to the first
2622 ** aligned address after the string text.
2623 **************************************************************************/
2624
2625 static void stringLit(FICL_VM *pVM)
2626 {
2627     FICL_STRING *sp;
2628     FICL_COUNT count;
2629     char *cp;
2630 #if FICL_ROBUST > 1
2631     vmCheckStack(pVM, 0, 2);
2632 #endif
2633
2634     sp = (FICL_STRING *)(pVM->ip);
2635     count = sp->count;
2636     cp = sp->text;
2637     PUSHPTR(cp);
2638     PUSHUNS(count);
2639     cp += count + 1;
2640     cp = alignPtr(cp);
2641     pVM->ip = (IPTYPE)(void *)cp;
2642 }
2643
2644 static void dotQuoteCoIm(FICL_VM *pVM)
2645 {
2646     FICL_DICT *dp = vmGetDict(pVM);
2647     FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2648     assert(pType);
2649     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2650     dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2651     dictAlign(dp);
2652     dictAppendCell(dp, LVALUEtoCELL(pType));
2653     return;
2654 }
2655
2656
2657 static void dotParen(FICL_VM *pVM)
2658 {
2659     char *pSrc      = vmGetInBuf(pVM);
2660     char *pEnd      = vmGetInBufEnd(pVM);
2661     char *pDest     = pVM->pad;
2662     char ch;
2663
2664     /*
2665     ** Note: the standard does not want leading spaces skipped (apparently)
2666     */
2667     for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2668         *pDest++ = ch;
2669
2670     *pDest = '\0';
2671     if ((pEnd != pSrc) && (ch == ')'))
2672         pSrc++;
2673
2674     vmTextOut(pVM, pVM->pad, 0);
2675     vmUpdateTib(pVM, pSrc);
2676         
2677     return;
2678 }
2679
2680
2681 /**************************************************************************
2682                         s l i t e r a l
2683 ** STRING 
2684 ** Interpretation: Interpretation semantics for this word are undefined.
2685 ** Compilation: ( c-addr1 u -- )
2686 ** Append the run-time semantics given below to the current definition.
2687 ** Run-time:       ( -- c-addr2 u )
2688 ** Return c-addr2 u describing a string consisting of the characters
2689 ** specified by c-addr1 u during compilation. A program shall not alter
2690 ** the returned string. 
2691 **************************************************************************/
2692 static void sLiteralCoIm(FICL_VM *pVM)
2693 {
2694     FICL_DICT *dp;
2695     char *cp, *cpDest;
2696     FICL_UNS u;
2697
2698 #if FICL_ROBUST > 1
2699     vmCheckStack(pVM, 2, 0);
2700 #endif
2701
2702     dp = vmGetDict(pVM);
2703     u  = POPUNS();
2704     cp = POPPTR();
2705
2706     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2707     cpDest    = (char *) dp->here;
2708     *cpDest++ = (char)   u;
2709
2710     for (; u > 0; --u)
2711     {
2712         *cpDest++ = *cp++;
2713     }
2714
2715     *cpDest++ = 0;
2716     dp->here = PTRtoCELL alignPtr(cpDest);
2717     return;
2718 }
2719
2720
2721 /**************************************************************************
2722                         s t a t e
2723 ** Return the address of the VM's state member (must be sized the
2724 ** same as a CELL for this reason)
2725 **************************************************************************/
2726 static void state(FICL_VM *pVM)
2727 {
2728 #if FICL_ROBUST > 1
2729     vmCheckStack(pVM, 0, 1);
2730 #endif
2731     PUSHPTR(&pVM->state);
2732     return;
2733 }
2734
2735
2736 /**************************************************************************
2737                         c r e a t e . . . d o e s >
2738 ** Make a new word in the dictionary with the run-time effect of 
2739 ** a variable (push my address), but with extra space allotted
2740 ** for use by does> .
2741 **************************************************************************/
2742
2743 static void createParen(FICL_VM *pVM)
2744 {
2745     CELL *pCell;
2746
2747 #if FICL_ROBUST > 1
2748     vmCheckStack(pVM, 0, 1);
2749 #endif
2750
2751     pCell = pVM->runningWord->param;
2752     PUSHPTR(pCell+1);
2753     return;
2754 }
2755
2756
2757 static void create(FICL_VM *pVM)
2758 {
2759     FICL_DICT *dp = vmGetDict(pVM);
2760     STRINGINFO si = vmGetWord(pVM);
2761
2762     dictCheckThreshold(dp);
2763
2764     dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2765     dictAllotCells(dp, 1);
2766     return;
2767 }
2768
2769
2770 static void doDoes(FICL_VM *pVM)
2771 {
2772     CELL *pCell;
2773     IPTYPE tempIP;
2774 #if FICL_ROBUST > 1
2775     vmCheckStack(pVM, 0, 1);
2776 #endif
2777
2778     pCell = pVM->runningWord->param;
2779     tempIP = (IPTYPE)((*pCell).p);
2780     PUSHPTR(pCell+1);
2781     vmPushIP(pVM, tempIP);
2782     return;
2783 }
2784
2785
2786 static void doesParen(FICL_VM *pVM)
2787 {
2788     FICL_DICT *dp = vmGetDict(pVM);
2789     dp->smudge->code = doDoes;
2790     dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2791     vmPopIP(pVM);
2792     return;
2793 }
2794
2795
2796 static void doesCoIm(FICL_VM *pVM)
2797 {
2798     FICL_DICT *dp = vmGetDict(pVM);
2799 #if FICL_WANT_LOCALS
2800     assert(pVM->pSys->pUnLinkParen);
2801     if (pVM->pSys->nLocals > 0)
2802     {
2803         FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2804         dictEmpty(pLoc, pLoc->pForthWords->size);
2805         dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2806     }
2807
2808     pVM->pSys->nLocals = 0;
2809 #endif
2810     IGNORE(pVM);
2811
2812     dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2813     return;
2814 }
2815
2816
2817 /**************************************************************************
2818                         t o   b o d y
2819 ** to-body      CORE ( xt -- a-addr )
2820 ** a-addr is the data-field address corresponding to xt. An ambiguous
2821 ** condition exists if xt is not for a word defined via CREATE. 
2822 **************************************************************************/
2823 static void toBody(FICL_VM *pVM)
2824 {
2825     FICL_WORD *pFW;
2826 /*#$-GUY CHANGE: Added robustness.-$#*/
2827 #if FICL_ROBUST > 1
2828     vmCheckStack(pVM, 1, 1);
2829 #endif
2830
2831     pFW = POPPTR();
2832     PUSHPTR(pFW->param + 1);
2833     return;
2834 }
2835
2836
2837 /*
2838 ** from-body       ficl ( a-addr -- xt )
2839 ** Reverse effect of >body
2840 */
2841 static void fromBody(FICL_VM *pVM)
2842 {
2843     char *ptr;
2844 #if FICL_ROBUST > 1
2845     vmCheckStack(pVM, 1, 1);
2846 #endif
2847
2848     ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2849     PUSHPTR(ptr);
2850     return;
2851 }
2852
2853
2854 /*
2855 ** >name        ficl ( xt -- c-addr u )
2856 ** Push the address and length of a word's name given its address
2857 ** xt. 
2858 */
2859 static void toName(FICL_VM *pVM)
2860 {
2861     FICL_WORD *pFW;
2862 #if FICL_ROBUST > 1
2863     vmCheckStack(pVM, 1, 2);
2864 #endif
2865
2866     pFW = POPPTR();
2867     PUSHPTR(pFW->name);
2868     PUSHUNS(pFW->nName);
2869     return;
2870 }
2871
2872
2873 static void getLastWord(FICL_VM *pVM)
2874 {
2875     FICL_DICT *pDict = vmGetDict(pVM);
2876     FICL_WORD *wp = pDict->smudge;
2877     assert(wp);
2878     vmPush(pVM, LVALUEtoCELL(wp));
2879     return;
2880 }
2881
2882
2883 /**************************************************************************
2884                         l b r a c k e t   e t c
2885 ** 
2886 **************************************************************************/
2887
2888 static void lbracketCoIm(FICL_VM *pVM)
2889 {
2890     pVM->state = INTERPRET;
2891     return;
2892 }
2893
2894
2895 static void rbracket(FICL_VM *pVM)
2896 {
2897     pVM->state = COMPILE;
2898     return;
2899 }
2900
2901
2902 /**************************************************************************
2903                         p i c t u r e d   n u m e r i c   w o r d s
2904 **
2905 ** less-number-sign CORE ( -- )
2906 ** Initialize the pictured numeric output conversion process. 
2907 ** (clear the pad)
2908 **************************************************************************/
2909 static void lessNumberSign(FICL_VM *pVM)
2910 {
2911     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2912     sp->count = 0;
2913     return;
2914 }
2915
2916 /*
2917 ** number-sign      CORE ( ud1 -- ud2 )
2918 ** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2919 ** n. (n is the least-significant digit of ud1.) Convert n to external form
2920 ** and add the resulting character to the beginning of the pictured numeric
2921 ** output  string. An ambiguous condition exists if # executes outside of a
2922 ** <# #> delimited number conversion. 
2923 */
2924 static void numberSign(FICL_VM *pVM)
2925 {
2926     FICL_STRING *sp;
2927     DPUNS u;
2928     UNS16 rem;
2929 #if FICL_ROBUST > 1
2930     vmCheckStack(pVM, 2, 2);
2931 #endif
2932
2933     sp = PTRtoSTRING pVM->pad;
2934     u = u64Pop(pVM->pStack);
2935     rem = m64UMod(&u, (UNS16)(pVM->base));
2936     sp->text[sp->count++] = digit_to_char(rem);
2937     u64Push(pVM->pStack, u);
2938     return;
2939 }
2940
2941 /*
2942 ** number-sign-greater CORE ( xd -- c-addr u )
2943 ** Drop xd. Make the pictured numeric output string available as a character
2944 ** string. c-addr and u specify the resulting character string. A program
2945 ** may replace characters within the string. 
2946 */
2947 static void numberSignGreater(FICL_VM *pVM)
2948 {
2949     FICL_STRING *sp;
2950 #if FICL_ROBUST > 1
2951     vmCheckStack(pVM, 2, 2);
2952 #endif
2953
2954     sp = PTRtoSTRING pVM->pad;
2955     sp->text[sp->count] = 0;
2956     strrev(sp->text);
2957     DROP(2);
2958     PUSHPTR(sp->text);
2959     PUSHUNS(sp->count);
2960     return;
2961 }
2962
2963 /*
2964 ** number-sign-s    CORE ( ud1 -- ud2 )
2965 ** Convert one digit of ud1 according to the rule for #. Continue conversion
2966 ** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2967 ** #S executes outside of a <# #> delimited number conversion. 
2968 ** TO DO: presently does not use ud1 hi cell - use it!
2969 */
2970 static void numberSignS(FICL_VM *pVM)
2971 {
2972     FICL_STRING *sp;
2973     DPUNS u;
2974     UNS16 rem;
2975 #if FICL_ROBUST > 1
2976     vmCheckStack(pVM, 2, 2);
2977 #endif
2978
2979     sp = PTRtoSTRING pVM->pad;
2980     u = u64Pop(pVM->pStack);
2981
2982     do 
2983     {
2984         rem = m64UMod(&u, (UNS16)(pVM->base));
2985         sp->text[sp->count++] = digit_to_char(rem);
2986     }
2987     while (u.hi || u.lo);
2988
2989     u64Push(pVM->pStack, u);
2990     return;
2991 }
2992
2993 /*
2994 ** HOLD             CORE ( char -- )
2995 ** Add char to the beginning of the pictured numeric output string. An ambiguous
2996 ** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2997 */
2998 static void hold(FICL_VM *pVM)
2999 {
3000     FICL_STRING *sp;
3001     int i;
3002 #if FICL_ROBUST > 1
3003     vmCheckStack(pVM, 1, 0);
3004 #endif
3005
3006     sp = PTRtoSTRING pVM->pad;
3007     i = POPINT();
3008     sp->text[sp->count++] = (char) i;
3009     return;
3010 }
3011
3012 /*
3013 ** SIGN             CORE ( n -- )
3014 ** If n is negative, add a minus sign to the beginning of the pictured
3015 ** numeric output string. An ambiguous condition exists if SIGN
3016 ** executes outside of a <# #> delimited number conversion. 
3017 */
3018 static void sign(FICL_VM *pVM)
3019 {
3020     FICL_STRING *sp;
3021     int i;
3022 #if FICL_ROBUST > 1