1 /*******************************************************************
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 *******************************************************************/
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
20 ** L I C E N S E and D I S C L A I M E R
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
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.
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
58 static void colonParen(FICL_VM *pVM);
59 static void literalIm(FICL_VM *pVM);
60 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si);
63 ** Control structure building words use these
64 ** strings' addresses as markers on the stack to
65 ** check for structure completion.
67 static char doTag[] = "do";
68 static char colonTag[] = "colon";
69 static char leaveTag[] = "leave";
71 static char destTag[] = "target";
72 static char origTag[] = "origin";
74 static char caseTag[] = "case";
75 static char ofTag[] = "of";
76 static char fallthroughTag[] = "fallthrough";
79 static void doLocalIm(FICL_VM *pVM);
80 static void do2LocalIm(FICL_VM *pVM);
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
87 ** Push current dict location for later branch resolution.
88 ** The location may be either a branch target or a patch address...
90 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
97 static void markControlTag(FICL_VM *pVM, char *tag)
103 static void matchControlTag(FICL_VM *pVM, char *tag)
107 vmCheckStack(pVM, 1, 0);
109 cp = (char *)stackPopPtr(pVM->pStack);
111 ** Changed the code below to compare the pointers first (by popular demand)
113 if ( (cp != tag) && strcmp(cp, tag) )
115 vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
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
126 static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
131 matchControlTag(pVM, tag);
134 vmCheckStack(pVM, 1, 0);
136 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
137 offset = patchAddr - dp->here;
138 dictAppendCell(dp, LVALUEtoCELL(offset));
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
149 static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
154 matchControlTag(pVM, tag);
157 vmCheckStack(pVM, 1, 0);
159 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
160 offset = dp->here - patchAddr;
161 *patchAddr = LVALUEtoCELL(offset);
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.
171 static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
177 vmCheckStack(pVM, 2, 0);
179 cp = stackPopPtr(pVM->pStack);
181 ** Changed the comparison below to compare the pointers first (by popular demand)
183 if ((cp != tag) && strcmp(cp, tag))
185 vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
186 vmTextOut(pVM, tag, 1);
189 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
190 *patchAddr = LVALUEtoCELL(dp->here);
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 **************************************************************************/
205 int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
210 unsigned base = pVM->base;
211 char *cp = SI_PTR(si);
212 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
235 if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
241 if (count == 0) /* detect "+", "-", ".", "+." etc */
244 while ((count--) && ((ch = *cp++) != '\0'))
252 digit = tolower(ch) - 'a' + 10;
257 accum = accum * base + digit;
260 if (hasDP) /* simple (required) DOUBLE support */
267 if (pVM->state == COMPILE)
274 /**************************************************************************
275 a d d & f r i e n d s
277 **************************************************************************/
279 static void add(FICL_VM *pVM)
283 vmCheckStack(pVM, 2, 1);
285 i = stackPopINT(pVM->pStack);
286 i += stackGetTop(pVM->pStack).i;
287 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
291 static void sub(FICL_VM *pVM)
295 vmCheckStack(pVM, 2, 1);
297 i = stackPopINT(pVM->pStack);
298 i = stackGetTop(pVM->pStack).i - i;
299 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
303 static void mul(FICL_VM *pVM)
307 vmCheckStack(pVM, 2, 1);
309 i = stackPopINT(pVM->pStack);
310 i *= stackGetTop(pVM->pStack).i;
311 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
315 static void negate(FICL_VM *pVM)
319 vmCheckStack(pVM, 1, 1);
321 i = -stackPopINT(pVM->pStack);
326 static void ficlDiv(FICL_VM *pVM)
330 vmCheckStack(pVM, 2, 1);
332 i = stackPopINT(pVM->pStack);
333 i = stackGetTop(pVM->pStack).i / i;
334 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
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)
347 static void slashMod(FICL_VM *pVM)
354 vmCheckStack(pVM, 2, 2);
356 n2 = stackPopINT(pVM->pStack);
357 n1.lo = stackPopINT(pVM->pStack);
360 qr = m64SymmetricDivI(n1, n2);
366 static void onePlus(FICL_VM *pVM)
370 vmCheckStack(pVM, 1, 1);
372 i = stackGetTop(pVM->pStack).i;
374 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
378 static void oneMinus(FICL_VM *pVM)
382 vmCheckStack(pVM, 1, 1);
384 i = stackGetTop(pVM->pStack).i;
386 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
390 static void twoMul(FICL_VM *pVM)
394 vmCheckStack(pVM, 1, 1);
396 i = stackGetTop(pVM->pStack).i;
398 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
402 static void twoDiv(FICL_VM *pVM)
406 vmCheckStack(pVM, 1, 1);
408 i = stackGetTop(pVM->pStack).i;
410 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
414 static void mulDiv(FICL_VM *pVM)
419 vmCheckStack(pVM, 3, 1);
421 z = stackPopINT(pVM->pStack);
422 y = stackPopINT(pVM->pStack);
423 x = stackPopINT(pVM->pStack);
426 x = m64SymmetricDivI(prod, z).quot;
433 static void mulDivRem(FICL_VM *pVM)
439 vmCheckStack(pVM, 3, 2);
441 z = stackPopINT(pVM->pStack);
442 y = stackPopINT(pVM->pStack);
443 x = stackPopINT(pVM->pStack);
446 qr = m64SymmetricDivI(prod, z);
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 **************************************************************************/
462 static void colon(FICL_VM *pVM)
464 FICL_DICT *dp = vmGetDict(pVM);
465 STRINGINFO si = vmGetWord(pVM);
467 dictCheckThreshold(dp);
469 pVM->state = COMPILE;
470 markControlTag(pVM, colonTag);
471 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
473 pVM->pSys->nLocals = 0;
479 /**************************************************************************
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
489 **************************************************************************/
491 static void colonParen(FICL_VM *pVM)
493 IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
494 vmPushIP(pVM, tempIP);
500 /**************************************************************************
501 s e m i c o l o n C o I m
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)
515 static void semicolonCoIm(FICL_VM *pVM)
517 FICL_DICT *dp = vmGetDict(pVM);
519 assert(pVM->pSys->pSemiParen);
520 matchControlTag(pVM, colonTag);
523 assert(pVM->pSys->pUnLinkParen);
524 if (pVM->pSys->nLocals > 0)
526 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
527 dictEmpty(pLoc, pLoc->pForthWords->size);
528 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
530 pVM->pSys->nLocals = 0;
533 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
534 pVM->state = INTERPRET;
540 /**************************************************************************
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)
555 static void exitCoIm(FICL_VM *pVM)
557 FICL_DICT *dp = vmGetDict(pVM);
558 assert(pVM->pSys->pExitParen);
562 if (pVM->pSys->nLocals > 0)
564 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
567 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
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.
577 **************************************************************************/
579 void constantParen(FICL_VM *pVM)
581 FICL_WORD *pFW = pVM->runningWord;
583 vmCheckStack(pVM, 0, 1);
585 stackPush(pVM->pStack, pFW->param[0]);
589 void twoConstParen(FICL_VM *pVM)
591 FICL_WORD *pFW = pVM->runningWord;
593 vmCheckStack(pVM, 0, 2);
595 stackPush(pVM->pStack, pFW->param[0]); /* lo */
596 stackPush(pVM->pStack, pFW->param[1]); /* hi */
601 /**************************************************************************
604 ** Compiles a constant into the dictionary. Constants return their
605 ** value when invoked. Expects a value on top of the parm stack.
606 **************************************************************************/
608 static void constant(FICL_VM *pVM)
610 FICL_DICT *dp = vmGetDict(pVM);
611 STRINGINFO si = vmGetWord(pVM);
614 vmCheckStack(pVM, 1, 0);
616 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
617 dictAppendCell(dp, stackPop(pVM->pStack));
622 static void twoConstant(FICL_VM *pVM)
624 FICL_DICT *dp = vmGetDict(pVM);
625 STRINGINFO si = vmGetWord(pVM);
629 vmCheckStack(pVM, 2, 0);
631 c = stackPop(pVM->pStack);
632 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
633 dictAppendCell(dp, stackPop(pVM->pStack));
634 dictAppendCell(dp, c);
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
643 **************************************************************************/
645 static void displayCell(FICL_VM *pVM)
649 vmCheckStack(pVM, 1, 0);
651 c = stackPop(pVM->pStack);
652 ltoa((c).i, pVM->pad, pVM->base);
653 strcat(pVM->pad, " ");
654 vmTextOut(pVM, pVM->pad, 0);
658 static void uDot(FICL_VM *pVM)
662 vmCheckStack(pVM, 1, 0);
664 u = stackPopUNS(pVM->pStack);
665 ultoa(u, pVM->pad, pVM->base);
666 strcat(pVM->pad, " ");
667 vmTextOut(pVM, pVM->pad, 0);
672 static void hexDot(FICL_VM *pVM)
676 vmCheckStack(pVM, 1, 0);
678 u = stackPopUNS(pVM->pStack);
679 ultoa(u, pVM->pad, 16);
680 strcat(pVM->pad, " ");
681 vmTextOut(pVM, pVM->pad, 0);
686 /**************************************************************************
688 ** FICL ( c-string -- length )
690 ** Returns the length of a C-style (zero-terminated) string.
694 static void ficlStrlen(FICL_VM *ficlVM)
696 char *address = (char *)stackPopPtr(ficlVM->pStack);
697 stackPushINT(ficlVM->pStack, strlen(address));
701 /**************************************************************************
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
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).
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).
725 **************************************************************************/
726 static void ficlSprintf(FICL_VM *pVM) /* */
728 int bufferLength = stackPopINT(pVM->pStack);
729 char *buffer = (char *)stackPopPtr(pVM->pStack);
730 char *bufferStart = buffer;
732 int formatLength = stackPopINT(pVM->pStack);
733 char *format = (char *)stackPopPtr(pVM->pStack);
734 char *formatStop = format + formatLength;
737 int unsignedInteger = FALSE;
739 FICL_INT append = FICL_TRUE;
741 while (format < formatStop)
753 actualLength = desiredLength = 1;
759 if (format == formatStop)
762 leadingZeroes = (*format == '0');
766 if (format == formatStop)
770 desiredLength = isdigit(*format);
773 desiredLength = strtol(format, &format, 10);
774 if (format == formatStop)
777 else if (*format == '*')
779 desiredLength = stackPopINT(pVM->pStack);
781 if (format == formatStop)
791 actualLength = stackPopINT(pVM->pStack);
792 source = (char *)stackPopPtr(pVM->pStack);
800 unsignedInteger = TRUE;
804 int integer = stackPopINT(pVM->pStack);
806 ultoa(integer, scratch, base);
808 ltoa(integer, scratch, base);
810 unsignedInteger = FALSE;
812 actualLength = strlen(scratch);
823 if (append != FICL_FALSE)
826 desiredLength = actualLength;
827 if (desiredLength > bufferLength)
830 desiredLength = bufferLength;
832 while (desiredLength > actualLength)
834 *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
838 memcpy(buffer, source, actualLength);
839 buffer += actualLength;
840 bufferLength -= actualLength;
846 stackPushPtr(pVM->pStack, bufferStart);
847 stackPushINT(pVM->pStack, buffer - bufferStart);
848 stackPushINT(pVM->pStack, append);
852 /**************************************************************************
853 d u p & f r i e n d s
855 **************************************************************************/
857 static void depth(FICL_VM *pVM)
861 vmCheckStack(pVM, 0, 1);
863 i = stackDepth(pVM->pStack);
869 static void drop(FICL_VM *pVM)
872 vmCheckStack(pVM, 1, 0);
874 stackDrop(pVM->pStack, 1);
879 static void twoDrop(FICL_VM *pVM)
882 vmCheckStack(pVM, 2, 0);
884 stackDrop(pVM->pStack, 2);
889 static void dup(FICL_VM *pVM)
892 vmCheckStack(pVM, 1, 2);
894 stackPick(pVM->pStack, 0);
899 static void twoDup(FICL_VM *pVM)
902 vmCheckStack(pVM, 2, 4);
904 stackPick(pVM->pStack, 1);
905 stackPick(pVM->pStack, 1);
910 static void over(FICL_VM *pVM)
913 vmCheckStack(pVM, 2, 3);
915 stackPick(pVM->pStack, 1);
919 static void twoOver(FICL_VM *pVM)
922 vmCheckStack(pVM, 4, 6);
924 stackPick(pVM->pStack, 3);
925 stackPick(pVM->pStack, 3);
930 static void pick(FICL_VM *pVM)
932 CELL c = stackPop(pVM->pStack);
934 vmCheckStack(pVM, c.i+1, c.i+2);
936 stackPick(pVM->pStack, c.i);
941 static void questionDup(FICL_VM *pVM)
945 vmCheckStack(pVM, 1, 2);
947 c = stackGetTop(pVM->pStack);
950 stackPick(pVM->pStack, 0);
956 static void roll(FICL_VM *pVM)
958 int i = stackPop(pVM->pStack).i;
961 vmCheckStack(pVM, i+1, i+1);
963 stackRoll(pVM->pStack, i);
968 static void minusRoll(FICL_VM *pVM)
970 int i = stackPop(pVM->pStack).i;
973 vmCheckStack(pVM, i+1, i+1);
975 stackRoll(pVM->pStack, -i);
980 static void rot(FICL_VM *pVM)
983 vmCheckStack(pVM, 3, 3);
985 stackRoll(pVM->pStack, 2);
990 static void swap(FICL_VM *pVM)
993 vmCheckStack(pVM, 2, 2);
995 stackRoll(pVM->pStack, 1);
1000 static void twoSwap(FICL_VM *pVM)
1003 vmCheckStack(pVM, 4, 4);
1005 stackRoll(pVM->pStack, 3);
1006 stackRoll(pVM->pStack, 3);
1011 /**************************************************************************
1012 e m i t & f r i e n d s
1014 **************************************************************************/
1016 static void emit(FICL_VM *pVM)
1018 char *cp = pVM->pad;
1022 vmCheckStack(pVM, 1, 0);
1024 i = stackPopINT(pVM->pStack);
1027 vmTextOut(pVM, cp, 0);
1032 static void cr(FICL_VM *pVM)
1034 vmTextOut(pVM, "", 1);
1039 static void commentLine(FICL_VM *pVM)
1041 char *cp = vmGetInBuf(pVM);
1042 char *pEnd = vmGetInBufEnd(pVM);
1045 while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
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.
1059 if ( (cp != pEnd) && (ch != *cp)
1060 && ((*cp == '\r') || (*cp == '\n')) )
1064 vmUpdateTib(pVM, cp);
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.
1078 static void commentHang(FICL_VM *pVM)
1080 vmParseStringEx(pVM, ')', 0);
1085 /**************************************************************************
1086 F E T C H & S T O R E
1088 **************************************************************************/
1090 static void fetch(FICL_VM *pVM)
1094 vmCheckStack(pVM, 1, 1);
1096 pCell = (CELL *)stackPopPtr(pVM->pStack);
1097 stackPush(pVM->pStack, *pCell);
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 @ .
1107 static void twoFetch(FICL_VM *pVM)
1111 vmCheckStack(pVM, 1, 2);
1113 pCell = (CELL *)stackPopPtr(pVM->pStack);
1114 stackPush(pVM->pStack, *pCell++);
1115 stackPush(pVM->pStack, *pCell);
1121 ** store CORE ( x a-addr -- )
1122 ** Store x at a-addr.
1124 static void store(FICL_VM *pVM)
1128 vmCheckStack(pVM, 2, 0);
1130 pCell = (CELL *)stackPopPtr(pVM->pStack);
1131 *pCell = stackPop(pVM->pStack);
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+ ! .
1140 static void twoStore(FICL_VM *pVM)
1144 vmCheckStack(pVM, 3, 0);
1146 pCell = (CELL *)stackPopPtr(pVM->pStack);
1147 *pCell++ = stackPop(pVM->pStack);
1148 *pCell = stackPop(pVM->pStack);
1151 static void plusStore(FICL_VM *pVM)
1155 vmCheckStack(pVM, 2, 0);
1157 pCell = (CELL *)stackPopPtr(pVM->pStack);
1158 pCell->i += stackPop(pVM->pStack).i;
1162 static void quadFetch(FICL_VM *pVM)
1166 vmCheckStack(pVM, 1, 1);
1168 pw = (UNS32 *)stackPopPtr(pVM->pStack);
1169 PUSHUNS((FICL_UNS)*pw);
1173 static void quadStore(FICL_VM *pVM)
1177 vmCheckStack(pVM, 2, 0);
1179 pw = (UNS32 *)stackPopPtr(pVM->pStack);
1180 *pw = (UNS32)(stackPop(pVM->pStack).u);
1183 static void wFetch(FICL_VM *pVM)
1187 vmCheckStack(pVM, 1, 1);
1189 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1190 PUSHUNS((FICL_UNS)*pw);
1194 static void wStore(FICL_VM *pVM)
1198 vmCheckStack(pVM, 2, 0);
1200 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1201 *pw = (UNS16)(stackPop(pVM->pStack).u);
1204 static void cFetch(FICL_VM *pVM)
1208 vmCheckStack(pVM, 1, 1);
1210 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1211 PUSHUNS((FICL_UNS)*pc);
1215 static void cStore(FICL_VM *pVM)
1219 vmCheckStack(pVM, 2, 0);
1221 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1222 *pc = (UNS8)(stackPop(pVM->pStack).u);
1226 /**************************************************************************
1227 b r a n c h P a r e n
1229 ** Runtime for "(branch)" -- expects a literal offset in the next
1230 ** compilation address, and branches to that location.
1231 **************************************************************************/
1233 static void branchParen(FICL_VM *pVM)
1235 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1240 /**************************************************************************
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 **************************************************************************/
1246 static void branch0(FICL_VM *pVM)
1251 vmCheckStack(pVM, 1, 0);
1253 flag = stackPopUNS(pVM->pStack);
1256 { /* fall through */
1257 vmBranchRelative(pVM, 1);
1260 { /* take branch (to else/endif/begin) */
1261 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1268 /**************************************************************************
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 **************************************************************************/
1276 static void ifCoIm(FICL_VM *pVM)
1278 FICL_DICT *dp = vmGetDict(pVM);
1280 assert(pVM->pSys->pBranch0);
1282 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
1283 markBranch(dp, pVM, origTag);
1284 dictAppendUNS(dp, 1);
1289 /**************************************************************************
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 "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
1300 **************************************************************************/
1302 static void elseCoIm(FICL_VM *pVM)
1306 FICL_DICT *dp = vmGetDict(pVM);
1308 assert(pVM->pSys->pBranchParen);
1309 /* (1) compile branch runtime */
1310 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1311 matchControlTag(pVM, origTag);
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" */
1323 /**************************************************************************
1325 ** IMMEDIATE COMPILE-ONLY
1326 **************************************************************************/
1328 static void endifCoIm(FICL_VM *pVM)
1330 FICL_DICT *dp = vmGetDict(pVM);
1331 resolveForwardBranch(dp, pVM, origTag);
1336 /**************************************************************************
1338 ** IMMEDIATE COMPILE-ONLY
1341 ** At compile-time, a CASE-SYS (see DPANS94 6.2.0873) looks like this:
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
1347 **************************************************************************/
1349 static void caseCoIm(FICL_VM *pVM)
1352 vmCheckStack(pVM, 0, 2);
1356 markControlTag(pVM, caseTag);
1361 /**************************************************************************
1362 e n d c a s eC o I m
1363 ** IMMEDIATE COMPILE-ONLY
1364 **************************************************************************/
1366 static void endcaseCoIm(FICL_VM *pVM)
1368 FICL_UNS fixupCount;
1373 assert(pVM->pSys->pDrop);
1376 ** if the last OF ended with FALLTHROUGH,
1377 ** just add the FALLTHROUGH fixup to the
1380 if (stackGetTop(pVM->pStack).p == fallthroughTag)
1382 matchControlTag(pVM, fallthroughTag);
1383 patchAddr = POPPTR();
1384 matchControlTag(pVM, caseTag);
1385 fixupCount = POPUNS();
1387 PUSHUNS(fixupCount + 1);
1388 markControlTag(pVM, caseTag);
1391 matchControlTag(pVM, caseTag);
1394 vmCheckStack(pVM, 1, 0);
1396 fixupCount = POPUNS();
1398 vmCheckStack(pVM, fixupCount, 0);
1401 dp = vmGetDict(pVM);
1403 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop));
1405 while (fixupCount--)
1407 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1408 offset = dp->here - patchAddr;
1409 *patchAddr = LVALUEtoCELL(offset);
1415 static void ofParen(FICL_VM *pVM)
1420 vmCheckStack(pVM, 2, 1);
1424 b = stackGetTop(pVM->pStack).u;
1427 { /* fall through */
1428 stackDrop(pVM->pStack, 1);
1429 vmBranchRelative(pVM, 1);
1432 { /* take branch to next of or endswitch */
1433 vmBranchRelative(pVM, *(int *)(pVM->ip));
1440 /**************************************************************************
1442 ** IMMEDIATE COMPILE-ONLY
1443 **************************************************************************/
1445 static void ofCoIm(FICL_VM *pVM)
1447 FICL_DICT *dp = vmGetDict(pVM);
1448 CELL *fallthroughFixup = NULL;
1450 assert(pVM->pSys->pBranch0);
1453 vmCheckStack(pVM, 1, 3);
1456 if (stackGetTop(pVM->pStack).p == fallthroughTag)
1458 matchControlTag(pVM, fallthroughTag);
1459 fallthroughFixup = POPPTR();
1462 matchControlTag(pVM, caseTag);
1464 markControlTag(pVM, caseTag);
1466 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen));
1467 markBranch(dp, pVM, ofTag);
1468 dictAppendUNS(dp, 2);
1470 if (fallthroughFixup != NULL)
1472 FICL_INT offset = dp->here - fallthroughFixup;
1473 *fallthroughFixup = LVALUEtoCELL(offset);
1480 /**************************************************************************
1482 ** IMMEDIATE COMPILE-ONLY
1483 **************************************************************************/
1485 static void endofCoIm(FICL_VM *pVM)
1488 FICL_UNS fixupCount;
1490 FICL_DICT *dp = vmGetDict(pVM);
1493 vmCheckStack(pVM, 4, 3);
1496 assert(pVM->pSys->pBranchParen);
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();
1507 /* compile branch runtime */
1508 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1510 /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */
1512 PUSHUNS(fixupCount + 1);
1513 markControlTag(pVM, caseTag);
1515 /* reserve space for the ENDOF fixup */
1516 dictAppendUNS(dp, 2);
1518 /* and patch the original OF */
1519 offset = dp->here - patchAddr;
1520 *patchAddr = LVALUEtoCELL(offset);
1524 /**************************************************************************
1525 f a l l t h r o u g h C o I m
1526 ** IMMEDIATE COMPILE-ONLY
1527 **************************************************************************/
1529 static void fallthroughCoIm(FICL_VM *pVM)
1533 FICL_DICT *dp = vmGetDict(pVM);
1536 vmCheckStack(pVM, 4, 3);
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);
1546 /* okay, here we go. put the case tag back. */
1547 markControlTag(pVM, caseTag);
1549 /* compile branch runtime */
1550 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1552 /* push a new FALLTHROUGH fixup and the fallthroughTag */
1554 markControlTag(pVM, fallthroughTag);
1556 /* reserve space for the FALLTHROUGH fixup */
1557 dictAppendUNS(dp, 2);
1559 /* and patch the original OF */
1560 offset = dp->here - patchAddr;
1561 *patchAddr = LVALUEtoCELL(offset);
1564 /**************************************************************************
1566 ** hash ( c-addr u -- code)
1567 ** calculates hashcode of specified string and leaves it on the stack
1568 **************************************************************************/
1570 static void hash(FICL_VM *pVM)
1573 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1574 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1575 PUSHUNS(hashHashCode(si));
1580 /**************************************************************************
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...
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 **************************************************************************/
1599 static void interpret(FICL_VM *pVM)
1608 si = vmGetWord0(pVM);
1611 ** Get next word...if out of text, we're done.
1615 vmThrow(pVM, VM_OUTOFTEXT);
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.
1625 if (ficlParseWord(pVM, si))
1628 for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1630 FICL_WORD *pFW = pSys->parseList[i];
1635 if (pFW->code == parseStepParen)
1637 FICL_PARSE_STEP pStep;
1638 pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1639 if ((*pStep)(pVM, si))
1644 stackPushPtr(pVM->pStack, SI_PTR(si));
1645 stackPushUNS(pVM->pStack, SI_COUNT(si));
1646 ficlExecXT(pVM, pFW);
1647 if (stackPopINT(pVM->pStack))
1653 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1655 return; /* back to inner interpreter */
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).
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);
1675 ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1677 ** (jws 4/01) Modified to be a FICL_PARSE_STEP
1678 **************************************************************************/
1679 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1681 FICL_DICT *dp = vmGetDict(pVM);
1685 dictCheck(dp, pVM, 0);
1686 vmCheckStack(pVM, 0, 0);
1689 #if FICL_WANT_LOCALS
1690 if (pVM->pSys->nLocals > 0)
1692 tempFW = ficlLookupLoc(pVM->pSys, si);
1696 tempFW = dictLookup(dp, si);
1698 if (pVM->state == INTERPRET)
1702 if (wordIsCompileOnly(tempFW))
1704 vmThrowErr(pVM, "Error: Compile only!");
1707 vmExecute(pVM, tempFW);
1708 return (int)FICL_TRUE;
1712 else /* (pVM->state == COMPILE) */
1716 if (wordIsImmediate(tempFW))
1718 vmExecute(pVM, tempFW);
1722 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1724 return (int)FICL_TRUE;
1733 ** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
1736 static void lookup(FICL_VM *pVM)
1739 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1740 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1741 stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
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 **************************************************************************/
1754 void parseStepParen(FICL_VM *pVM)
1757 FICL_WORD *pFW = pVM->runningWord;
1758 FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1760 SI_SETLEN(si, stackPopINT(pVM->pStack));
1761 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1763 PUSHINT((*pStep)(pVM, si));
1769 static void addParseStep(FICL_VM *pVM)
1772 FICL_DICT *pd = vmGetDict(pVM);
1774 vmCheckStack(pVM, 1, 0);
1776 pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1777 if ((pStep != NULL) && isAFiclWord(pd, pStep))
1778 ficlAddParseStep(pVM->pSys, pStep);
1783 /**************************************************************************
1784 l i t e r a l P a r e n
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".
1790 **************************************************************************/
1792 static void literalParen(FICL_VM *pVM)
1795 vmCheckStack(pVM, 0, 1);
1797 PUSHINT(*(FICL_INT *)(pVM->ip));
1798 vmBranchRelative(pVM, 1);
1802 static void twoLitParen(FICL_VM *pVM)
1805 vmCheckStack(pVM, 0, 2);
1807 PUSHINT(*((FICL_INT *)(pVM->ip)+1));
1808 PUSHINT(*(FICL_INT *)(pVM->ip));
1809 vmBranchRelative(pVM, 2);
1814 /**************************************************************************
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)".
1820 **************************************************************************/
1822 static void literalIm(FICL_VM *pVM)
1824 FICL_DICT *dp = vmGetDict(pVM);
1825 assert(pVM->pSys->pLitParen);
1827 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
1828 dictAppendCell(dp, stackPop(pVM->pStack));
1834 static void twoLiteralIm(FICL_VM *pVM)
1836 FICL_DICT *dp = vmGetDict(pVM);
1837 assert(pVM->pSys->pTwoLitParen);
1839 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
1840 dictAppendCell(dp, stackPop(pVM->pStack));
1841 dictAppendCell(dp, stackPop(pVM->pStack));
1846 /**************************************************************************
1847 l o g i c a n d c o m p a r i s o n s
1849 **************************************************************************/
1851 static void zeroEquals(FICL_VM *pVM)
1855 vmCheckStack(pVM, 1, 1);
1857 c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
1858 stackPush(pVM->pStack, c);
1862 static void zeroLess(FICL_VM *pVM)
1866 vmCheckStack(pVM, 1, 1);
1868 c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
1869 stackPush(pVM->pStack, c);
1873 static void zeroGreater(FICL_VM *pVM)
1877 vmCheckStack(pVM, 1, 1);
1879 c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
1880 stackPush(pVM->pStack, c);
1884 static void isEqual(FICL_VM *pVM)
1889 vmCheckStack(pVM, 2, 1);
1891 x = stackPop(pVM->pStack);
1892 y = stackPop(pVM->pStack);
1893 PUSHINT(FICL_BOOL(x.i == y.i));
1897 static void isLess(FICL_VM *pVM)
1901 vmCheckStack(pVM, 2, 1);
1903 y = stackPop(pVM->pStack);
1904 x = stackPop(pVM->pStack);
1905 PUSHINT(FICL_BOOL(x.i < y.i));
1909 static void uIsLess(FICL_VM *pVM)
1913 vmCheckStack(pVM, 2, 1);
1915 u2 = stackPopUNS(pVM->pStack);
1916 u1 = stackPopUNS(pVM->pStack);
1917 PUSHINT(FICL_BOOL(u1 < u2));
1921 static void isGreater(FICL_VM *pVM)
1925 vmCheckStack(pVM, 2, 1);
1927 y = stackPop(pVM->pStack);
1928 x = stackPop(pVM->pStack);
1929 PUSHINT(FICL_BOOL(x.i > y.i));
1933 static void bitwiseAnd(FICL_VM *pVM)
1937 vmCheckStack(pVM, 2, 1);
1939 x = stackPop(pVM->pStack);
1940 y = stackPop(pVM->pStack);
1945 static void bitwiseOr(FICL_VM *pVM)
1949 vmCheckStack(pVM, 2, 1);
1951 x = stackPop(pVM->pStack);
1952 y = stackPop(pVM->pStack);
1957 static void bitwiseXor(FICL_VM *pVM)
1961 vmCheckStack(pVM, 2, 1);
1963 x = stackPop(pVM->pStack);
1964 y = stackPop(pVM->pStack);
1969 static void bitwiseNot(FICL_VM *pVM)
1973 vmCheckStack(pVM, 1, 1);
1975 x = stackPop(pVM->pStack);
1981 /**************************************************************************
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
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 **************************************************************************/
2006 static void doCoIm(FICL_VM *pVM)
2008 FICL_DICT *dp = vmGetDict(pVM);
2010 assert(pVM->pSys->pDoParen);
2012 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
2014 ** Allot space for a pointer to the end
2015 ** of the loop - "leave" uses this...
2017 markBranch(dp, pVM, leaveTag);
2018 dictAppendUNS(dp, 0);
2020 ** Mark location of head of loop...
2022 markBranch(dp, pVM, doTag);
2028 static void doParen(FICL_VM *pVM)
2032 vmCheckStack(pVM, 2, 0);
2034 index = stackPop(pVM->pStack);
2035 limit = stackPop(pVM->pStack);
2037 /* copy "leave" target addr to stack */
2038 stackPushPtr(pVM->rStack, *(pVM->ip++));
2039 stackPush(pVM->rStack, limit);
2040 stackPush(pVM->rStack, index);
2046 static void qDoCoIm(FICL_VM *pVM)
2048 FICL_DICT *dp = vmGetDict(pVM);
2050 assert(pVM->pSys->pQDoParen);
2052 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
2054 ** Allot space for a pointer to the end
2055 ** of the loop - "leave" uses this...
2057 markBranch(dp, pVM, leaveTag);
2058 dictAppendUNS(dp, 0);
2060 ** Mark location of head of loop...
2062 markBranch(dp, pVM, doTag);
2068 static void qDoParen(FICL_VM *pVM)
2072 vmCheckStack(pVM, 2, 0);
2074 index = stackPop(pVM->pStack);
2075 limit = stackPop(pVM->pStack);
2077 /* copy "leave" target addr to stack */
2078 stackPushPtr(pVM->rStack, *(pVM->ip++));
2080 if (limit.u == index.u)
2086 stackPush(pVM->rStack, limit);
2087 stackPush(pVM->rStack, index);
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.
2099 static void leaveCo(FICL_VM *pVM)
2102 stackDrop(pVM->rStack, 2);
2109 static void unloopCo(FICL_VM *pVM)
2111 stackDrop(pVM->rStack, 3);
2116 static void loopCoIm(FICL_VM *pVM)
2118 FICL_DICT *dp = vmGetDict(pVM);
2120 assert(pVM->pSys->pLoopParen);
2122 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
2123 resolveBackBranch(dp, pVM, doTag);
2124 resolveAbsBranch(dp, pVM, leaveTag);
2129 static void plusLoopCoIm(FICL_VM *pVM)
2131 FICL_DICT *dp = vmGetDict(pVM);
2133 assert(pVM->pSys->pPLoopParen);
2135 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
2136 resolveBackBranch(dp, pVM, doTag);
2137 resolveAbsBranch(dp, pVM, leaveTag);
2142 static void loopParen(FICL_VM *pVM)
2144 FICL_INT index = stackGetTop(pVM->rStack).i;
2145 FICL_INT limit = stackFetch(pVM->rStack, 1).i;
2151 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
2152 vmBranchRelative(pVM, 1); /* fall through the loop */
2155 { /* update index, branch to loop head */
2156 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
2157 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
2164 static void plusLoopParen(FICL_VM *pVM)
2166 FICL_INT index,limit,increment;
2170 vmCheckStack(pVM, 1, 0);
2173 index = stackGetTop(pVM->rStack).i;
2174 limit = stackFetch(pVM->rStack, 1).i;
2175 increment = POP().i;
2180 flag = (index < limit);
2182 flag = (index >= limit);
2186 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
2187 vmBranchRelative(pVM, 1); /* fall through the loop */
2190 { /* update index, branch to loop head */
2191 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
2192 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
2199 static void loopICo(FICL_VM *pVM)
2201 CELL index = stackGetTop(pVM->rStack);
2202 stackPush(pVM->pStack, index);
2208 static void loopJCo(FICL_VM *pVM)
2210 CELL index = stackFetch(pVM->rStack, 3);
2211 stackPush(pVM->pStack, index);
2217 static void loopKCo(FICL_VM *pVM)
2219 CELL index = stackFetch(pVM->rStack, 6);
2220 stackPush(pVM->pStack, index);
2226 /**************************************************************************
2227 r e t u r n s t a c k
2229 **************************************************************************/
2230 static void toRStack(FICL_VM *pVM)
2233 vmCheckStack(pVM, 1, 0);
2236 stackPush(pVM->rStack, POP());
2239 static void fromRStack(FICL_VM *pVM)
2242 vmCheckStack(pVM, 0, 1);
2245 PUSH(stackPop(pVM->rStack));
2248 static void fetchRStack(FICL_VM *pVM)
2251 vmCheckStack(pVM, 0, 1);
2254 PUSH(stackGetTop(pVM->rStack));
2257 static void twoToR(FICL_VM *pVM)
2260 vmCheckStack(pVM, 2, 0);
2262 stackRoll(pVM->pStack, 1);
2263 stackPush(pVM->rStack, stackPop(pVM->pStack));
2264 stackPush(pVM->rStack, stackPop(pVM->pStack));
2268 static void twoRFrom(FICL_VM *pVM)
2271 vmCheckStack(pVM, 0, 2);
2273 stackPush(pVM->pStack, stackPop(pVM->rStack));
2274 stackPush(pVM->pStack, stackPop(pVM->rStack));
2275 stackRoll(pVM->pStack, 1);
2279 static void twoRFetch(FICL_VM *pVM)
2282 vmCheckStack(pVM, 0, 2);
2284 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2285 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2290 /**************************************************************************
2293 **************************************************************************/
2295 static void variableParen(FICL_VM *pVM)
2299 vmCheckStack(pVM, 0, 1);
2302 fw = pVM->runningWord;
2307 static void variable(FICL_VM *pVM)
2309 FICL_DICT *dp = vmGetDict(pVM);
2310 STRINGINFO si = vmGetWord(pVM);
2312 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2313 dictAllotCells(dp, 1);
2318 static void twoVariable(FICL_VM *pVM)
2320 FICL_DICT *dp = vmGetDict(pVM);
2321 STRINGINFO si = vmGetWord(pVM);
2323 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2324 dictAllotCells(dp, 2);
2329 /**************************************************************************
2330 b a s e & f r i e n d s
2332 **************************************************************************/
2334 static void base(FICL_VM *pVM)
2338 vmCheckStack(pVM, 0, 1);
2341 pBase = (CELL *)(&pVM->base);
2342 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2347 static void decimal(FICL_VM *pVM)
2354 static void hex(FICL_VM *pVM)
2361 /**************************************************************************
2362 a l l o t & f r i e n d s
2364 **************************************************************************/
2366 static void allot(FICL_VM *pVM)
2371 vmCheckStack(pVM, 1, 0);
2374 dp = vmGetDict(pVM);
2378 dictCheck(dp, pVM, i);
2386 static void here(FICL_VM *pVM)
2390 vmCheckStack(pVM, 0, 1);
2393 dp = vmGetDict(pVM);
2398 static void comma(FICL_VM *pVM)
2403 vmCheckStack(pVM, 1, 0);
2406 dp = vmGetDict(pVM);
2408 dictAppendCell(dp, c);
2412 static void cComma(FICL_VM *pVM)
2417 vmCheckStack(pVM, 1, 0);
2420 dp = vmGetDict(pVM);
2422 dictAppendChar(dp, c);
2426 static void cells(FICL_VM *pVM)
2430 vmCheckStack(pVM, 1, 1);
2434 PUSHINT(i * (FICL_INT)sizeof (CELL));
2438 static void cellPlus(FICL_VM *pVM)
2442 vmCheckStack(pVM, 1, 1);
2446 PUSHPTR(cp + sizeof (CELL));
2452 /**************************************************************************
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)
2461 FICL_WORD *pFW = NULL;
2462 STRINGINFO si = vmGetWord(pVM);
2464 vmCheckStack(pVM, 0, 1);
2467 pFW = dictLookup(vmGetDict(pVM), si);
2470 int i = SI_COUNT(si);
2471 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2478 static void bracketTickCoIm(FICL_VM *pVM)
2487 /**************************************************************************
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 **************************************************************************/
2494 static void postponeCoIm(FICL_VM *pVM)
2496 FICL_DICT *dp = vmGetDict(pVM);
2498 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2502 pFW = stackGetTop(pVM->pStack).p;
2503 if (wordIsImmediate(pFW))
2505 dictAppendCell(dp, stackPop(pVM->pStack));
2510 dictAppendCell(dp, LVALUEtoCELL(pComma));
2518 /**************************************************************************
2520 ** Pop an execution token (pointer to a word) off the stack and
2522 **************************************************************************/
2524 static void execute(FICL_VM *pVM)
2528 vmCheckStack(pVM, 1, 0);
2531 pFW = stackPopPtr(pVM->pStack);
2532 vmExecute(pVM, pFW);
2538 /**************************************************************************
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 **************************************************************************/
2545 static void immediate(FICL_VM *pVM)
2548 dictSetImmediate(vmGetDict(pVM));
2553 static void compileOnly(FICL_VM *pVM)
2556 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2561 static void setObjectFlag(FICL_VM *pVM)
2564 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2568 static void isObject(FICL_VM *pVM)
2571 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2573 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2574 stackPushINT(pVM->pStack, flag);
2578 static void cstringLit(FICL_VM *pVM)
2580 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2582 char *cp = sp->text;
2583 cp += sp->count + 1;
2585 pVM->ip = (IPTYPE)(void *)cp;
2587 stackPushPtr(pVM->pStack, sp);
2592 static void cstringQuoteIm(FICL_VM *pVM)
2594 FICL_DICT *dp = vmGetDict(pVM);
2596 if (pVM->state == INTERPRET)
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));
2604 else /* COMPILE state */
2606 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2607 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2614 /**************************************************************************
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.
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 **************************************************************************/
2625 static void stringLit(FICL_VM *pVM)
2631 vmCheckStack(pVM, 0, 2);
2634 sp = (FICL_STRING *)(pVM->ip);
2641 pVM->ip = (IPTYPE)(void *)cp;
2644 static void dotQuoteCoIm(FICL_VM *pVM)
2646 FICL_DICT *dp = vmGetDict(pVM);
2647 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2649 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2650 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2652 dictAppendCell(dp, LVALUEtoCELL(pType));
2657 static void dotParen(FICL_VM *pVM)
2659 char *pSrc = vmGetInBuf(pVM);
2660 char *pEnd = vmGetInBufEnd(pVM);
2661 char *pDest = pVM->pad;
2665 ** Note: the standard does not want leading spaces skipped (apparently)
2667 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2671 if ((pEnd != pSrc) && (ch == ')'))
2674 vmTextOut(pVM, pVM->pad, 0);
2675 vmUpdateTib(pVM, pSrc);
2681 /**************************************************************************
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)
2699 vmCheckStack(pVM, 2, 0);
2702 dp = vmGetDict(pVM);
2706 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2707 cpDest = (char *) dp->here;
2708 *cpDest++ = (char) u;
2716 dp->here = PTRtoCELL alignPtr(cpDest);
2721 /**************************************************************************
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)
2729 vmCheckStack(pVM, 0, 1);
2731 PUSHPTR(&pVM->state);
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 **************************************************************************/
2743 static void createParen(FICL_VM *pVM)
2748 vmCheckStack(pVM, 0, 1);
2751 pCell = pVM->runningWord->param;
2757 static void create(FICL_VM *pVM)
2759 FICL_DICT *dp = vmGetDict(pVM);
2760 STRINGINFO si = vmGetWord(pVM);
2762 dictCheckThreshold(dp);
2764 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2765 dictAllotCells(dp, 1);
2770 static void doDoes(FICL_VM *pVM)
2775 vmCheckStack(pVM, 0, 1);
2778 pCell = pVM->runningWord->param;
2779 tempIP = (IPTYPE)((*pCell).p);
2781 vmPushIP(pVM, tempIP);
2786 static void doesParen(FICL_VM *pVM)
2788 FICL_DICT *dp = vmGetDict(pVM);
2789 dp->smudge->code = doDoes;
2790 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2796 static void doesCoIm(FICL_VM *pVM)
2798 FICL_DICT *dp = vmGetDict(pVM);
2799 #if FICL_WANT_LOCALS
2800 assert(pVM->pSys->pUnLinkParen);
2801 if (pVM->pSys->nLocals > 0)
2803 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2804 dictEmpty(pLoc, pLoc->pForthWords->size);
2805 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2808 pVM->pSys->nLocals = 0;
2812 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2817 /**************************************************************************
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)
2826 /*#$-GUY CHANGE: Added robustness.-$#*/
2828 vmCheckStack(pVM, 1, 1);
2832 PUSHPTR(pFW->param + 1);
2838 ** from-body ficl ( a-addr -- xt )
2839 ** Reverse effect of >body
2841 static void fromBody(FICL_VM *pVM)
2845 vmCheckStack(pVM, 1, 1);
2848 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2855 ** >name ficl ( xt -- c-addr u )
2856 ** Push the address and length of a word's name given its address
2859 static void toName(FICL_VM *pVM)
2863 vmCheckStack(pVM, 1, 2);
2868 PUSHUNS(pFW->nName);
2873 static void getLastWord(FICL_VM *pVM)
2875 FICL_DICT *pDict = vmGetDict(pVM);
2876 FICL_WORD *wp = pDict->smudge;
2878 vmPush(pVM, LVALUEtoCELL(wp));
2883 /**************************************************************************
2884 l b r a c k e t e t c
2886 **************************************************************************/
2888 static void lbracketCoIm(FICL_VM *pVM)
2890 pVM->state = INTERPRET;
2895 static void rbracket(FICL_VM *pVM)
2897 pVM->state = COMPILE;
2902 /**************************************************************************
2903 p i c t u r e d n u m e r i c w o r d s
2905 ** less-number-sign CORE ( -- )
2906 ** Initialize the pictured numeric output conversion process.
2908 **************************************************************************/
2909 static void lessNumberSign(FICL_VM *pVM)
2911 FICL_STRING *sp = PTRtoSTRING pVM->pad;
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.
2924 static void numberSign(FICL_VM *pVM)
2930 vmCheckStack(pVM, 2, 2);
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);
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.
2947 static void numberSignGreater(FICL_VM *pVM)
2951 vmCheckStack(pVM, 2, 2);
2954 sp = PTRtoSTRING pVM->pad;
2955 sp->text[sp->count] = 0;
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!
2970 static void numberSignS(FICL_VM *pVM)
2976 vmCheckStack(pVM, 2, 2);
2979 sp = PTRtoSTRING pVM->pad;
2980 u = u64Pop(pVM->pStack);
2984 rem = m64UMod(&u, (UNS16)(pVM->base));
2985 sp->text[sp->count++] = digit_to_char(rem);
2987 while (u.hi || u.lo);
2989 u64Push(pVM->pStack, u);
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.
2998 static void hold(FICL_VM *pVM)
3003 vmCheckStack(pVM, 1, 0);
3006 sp = PTRtoSTRING pVM->pad;
3008 sp->text[sp->count++] = (char) i;
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.
3018 static void sign(FICL_VM *pVM)
3023 vmCheckStack(pVM, 1, 0);
3026 sp = PTRtoSTRING pVM->pad;
3029 sp->text[sp->count++] = '-';
3034 /**************************************************************************
3036 ** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
3037 ** ud2 is the unsigned result of converting the characters within the
3038 ** string specified by c-addr1 u1 into digits, using the number in BASE,
3039 ** and adding each into ud1 after multiplying ud1 by the number in BASE.
3040 ** Conversion continues left-to-right until a character that is not
3041 ** convertible, including any + or -, is encountered or the string is
3042 ** entirely converted. c-addr2 is the location of the first unconverted
3043 ** character or the first character past the end of the string if the string
3044 ** was entirely converted. u2 is the number of unconverted characters in the
3045 ** string. An ambiguous condition exists if ud2 overflows during the
3047 **************************************************************************/
3048 static void toNumber(FICL_VM *pVM)
3053 FICL_UNS base = pVM->base;
3058 vmCheckStack(pVM,4,4);
3062 cp = (char *)POPPTR();
3063 accum = u64Pop(pVM->pStack);
3065 for (ch = *cp; count > 0; ch = *++cp, count--)
3073 digit = tolower(ch) - 'a' + 10;
3075 ** Note: following test also catches chars between 9 and a
3076 ** because 'digit' is unsigned!
3081 accum = m64Mac(accum, base, digit);
3084 u64Push(pVM->pStack, accum);
3093 /**************************************************************************
3095 ** quit CORE ( -- ) ( R: i*x -- )
3096 ** Empty the return stack, store zero in SOURCE-ID if it is present, make
3097 ** the user input device the input source, and enter interpretation state.
3098 ** Do not display a message. Repeat the following:
3100 ** Accept a line from the input source into the input buffer, set >IN to
3101 ** zero, and interpret.
3102 ** Display the implementation-defined system prompt if in
3103 ** interpretation state, all processing has been completed, and no
3104 ** ambiguous condition exists.
3105 **************************************************************************/
3107 static void quit(FICL_VM *pVM)
3109 vmThrow(pVM, VM_QUIT);
3114 static void ficlAbort(FICL_VM *pVM)
3116 vmThrow(pVM, VM_ABORT);
3121 /**************************************************************************
3123 ** accept CORE ( c-addr +n1 -- +n2 )
3124 ** Receive a string of at most +n1 characters. An ambiguous condition
3125 ** exists if +n1 is zero or greater than 32,767. Display graphic characters
3126 ** as they are received. A program that depends on the presence or absence
3127 ** of non-graphic characters in the string has an environmental dependency.
3128 ** The editing functions, if any, that the system performs in order to
3129 ** construct the string are implementation-defined.
3131 ** (Although the standard text doesn't say so, I assume that the intent
3132 ** of 'accept' is to store the string at the address specified on
3134 ** Implementation: if there's more text in the TIB, use it. Otherwise
3135 ** throw out for more text. Copy characters up to the max count into the
3136 ** address given, and return the number of actual characters copied.
3138 ** Note (sobral) this may not be the behavior you'd expect if you're
3139 ** trying to get user input at load time!
3140 **************************************************************************/
3141 static void accept(FICL_VM *pVM)
3143 FICL_UNS count, len;
3148 vmCheckStack(pVM,2,1);
3151 pBuf = vmGetInBuf(pVM);
3152 pEnd = vmGetInBufEnd(pVM);
3155 vmThrow(pVM, VM_RESTART);
3158 ** Now we have something in the text buffer - use it
3160 count = stackPopINT(pVM->pStack);
3161 cp = stackPopPtr(pVM->pStack);
3163 len = (count < len) ? count : len;
3164 strncpy(cp, vmGetInBuf(pVM), len);
3166 vmUpdateTib(pVM, pBuf);
3173 /**************************************************************************
3175 ** 6.1.0705 ALIGN CORE ( -- )
3176 ** If the data-space pointer is not aligned, reserve enough space to
3178 **************************************************************************/
3179 static void align(FICL_VM *pVM)
3181 FICL_DICT *dp = vmGetDict(pVM);
3188 /**************************************************************************
3191 **************************************************************************/
3192 static void aligned(FICL_VM *pVM)
3196 vmCheckStack(pVM,1,1);
3200 PUSHPTR(alignPtr(addr));
3205 /**************************************************************************
3206 b e g i n & f r i e n d s
3207 ** Indefinite loop control structures
3210 ** : X ... BEGIN ... test UNTIL ;
3212 ** : X ... BEGIN ... test WHILE ... REPEAT ;
3213 **************************************************************************/
3214 static void beginCoIm(FICL_VM *pVM)
3216 FICL_DICT *dp = vmGetDict(pVM);
3217 markBranch(dp, pVM, destTag);
3221 static void untilCoIm(FICL_VM *pVM)
3223 FICL_DICT *dp = vmGetDict(pVM);
3225 assert(pVM->pSys->pBranch0);
3227 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
3228 resolveBackBranch(dp, pVM, destTag);
3232 static void whileCoIm(FICL_VM *pVM)
3234 FICL_DICT *dp = vmGetDict(pVM);
3236 assert(pVM->pSys->pBranch0);
3238 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
3239 markBranch(dp, pVM, origTag);
3241 dictAppendUNS(dp, 1);
3245 static void repeatCoIm(FICL_VM *pVM)
3247 FICL_DICT *dp = vmGetDict(pVM);
3249 assert(pVM->pSys->pBranchParen);
3250 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3252 /* expect "begin" branch marker */
3253 resolveBackBranch(dp, pVM, destTag);
3254 /* expect "while" branch marker */
3255 resolveForwardBranch(dp, pVM, origTag);
3260 static void againCoIm(FICL_VM *pVM)
3262 FICL_DICT *dp = vmGetDict(pVM);
3264 assert(pVM->pSys->pBranchParen);
3265 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3267 /* expect "begin" branch marker */
3268 resolveBackBranch(dp, pVM, destTag);
3273 /**************************************************************************
3274 c h a r & f r i e n d s
3275 ** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
3276 ** Skip leading space delimiters. Parse name delimited by a space.
3277 ** Put the value of its first character onto the stack.
3279 ** bracket-char CORE
3280 ** Interpretation: Interpretation semantics for this word are undefined.
3281 ** Compilation: ( "<spaces>name" -- )
3282 ** Skip leading space delimiters. Parse name delimited by a space.
3283 ** Append the run-time semantics given below to the current definition.
3284 ** Run-time: ( -- char )
3285 ** Place char, the value of the first character of name, on the stack.
3286 **************************************************************************/
3287 static void ficlChar(FICL_VM *pVM)
3291 vmCheckStack(pVM,0,1);
3294 si = vmGetWord(pVM);
3295 PUSHUNS((FICL_UNS)(si.cp[0]));
3299 static void charCoIm(FICL_VM *pVM)
3306 /**************************************************************************
3308 ** char-plus CORE ( c-addr1 -- c-addr2 )
3309 ** Add the size in address units of a character to c-addr1, giving c-addr2.
3310 **************************************************************************/
3311 static void charPlus(FICL_VM *pVM)
3315 vmCheckStack(pVM,1,1);
3323 /**************************************************************************
3325 ** chars CORE ( n1 -- n2 )
3326 ** n2 is the size in address units of n1 characters.
3327 ** For most processors, this function can be a no-op. To guarantee
3328 ** portability, we'll multiply by sizeof (char).
3329 **************************************************************************/
3330 #if defined (_M_IX86)
3331 #pragma warning(disable: 4127)
3333 static void ficlChars(FICL_VM *pVM)
3335 if (sizeof (char) > 1)
3339 vmCheckStack(pVM,1,1);
3342 PUSHINT(i * sizeof (char));
3344 /* otherwise no-op! */
3347 #if defined (_M_IX86)
3348 #pragma warning(default: 4127)
3352 /**************************************************************************
3354 ** COUNT CORE ( c-addr1 -- c-addr2 u )
3355 ** Return the character string specification for the counted string stored
3356 ** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3357 ** u is the contents of the character at c-addr1, which is the length in
3358 ** characters of the string at c-addr2.
3359 **************************************************************************/
3360 static void count(FICL_VM *pVM)
3364 vmCheckStack(pVM,1,2);
3373 /**************************************************************************
3374 e n v i r o n m e n t ?
3375 ** environment-query CORE ( c-addr u -- false | i*x true )
3376 ** c-addr is the address of a character string and u is the string's
3377 ** character count. u may have a value in the range from zero to an
3378 ** implementation-defined maximum which shall not be less than 31. The
3379 ** character string should contain a keyword from 3.2.6 Environmental
3380 ** queries or the optional word sets to be checked for correspondence
3381 ** with an attribute of the present environment. If the system treats the
3382 ** attribute as unknown, the returned flag is false; otherwise, the flag
3383 ** is true and the i*x returned is of the type specified in the table for
3384 ** the attribute queried.
3385 **************************************************************************/
3386 static void environmentQ(FICL_VM *pVM)
3392 vmCheckStack(pVM,2,1);
3395 envp = pVM->pSys->envp;
3396 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3397 si.cp = stackPopPtr(pVM->pStack);
3399 pFW = dictLookup(envp, si);
3403 vmExecute(pVM, pFW);
3408 PUSHINT(FICL_FALSE);
3413 /**************************************************************************
3415 ** EVALUATE CORE ( i*x c-addr u -- j*x )
3416 ** Save the current input source specification. Store minus-one (-1) in
3417 ** SOURCE-ID if it is present. Make the string described by c-addr and u
3418 ** both the input source and input buffer, set >IN to zero, and interpret.
3419 ** When the parse area is empty, restore the prior input source
3420 ** specification. Other stack effects are due to the words EVALUATEd.
3422 **************************************************************************/
3423 static void evaluate(FICL_VM *pVM)
3430 vmCheckStack(pVM,2,0);
3438 pVM->sourceID.i = -1;
3439 result = ficlExecC(pVM, cp, count);
3441 if (result != VM_OUTOFTEXT)
3442 vmThrow(pVM, result);
3448 /**************************************************************************
3449 s t r i n g q u o t e
3450 ** Interpreting: get string delimited by a quote from the input stream,
3451 ** copy to a scratch area, and put its count and address on the stack.
3452 ** Compiling: compile code to push the address and count of a string
3453 ** literal, compile the string from the input stream, and align the dict
3455 **************************************************************************/
3456 static void stringQuoteIm(FICL_VM *pVM)
3458 FICL_DICT *dp = vmGetDict(pVM);
3460 if (pVM->state == INTERPRET)
3462 FICL_STRING *sp = (FICL_STRING *) dp->here;
3463 vmGetString(pVM, sp, '\"');
3467 else /* COMPILE state */
3469 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3470 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3478 /**************************************************************************
3480 ** Pop count and char address from stack and print the designated string.
3481 **************************************************************************/
3482 static void type(FICL_VM *pVM)
3484 FICL_UNS count = stackPopUNS(pVM->pStack);
3485 char *cp = stackPopPtr(pVM->pStack);
3486 char *pDest = (char *)ficlMalloc(count + 1);
3489 ** Since we don't have an output primitive for a counted string
3490 ** (oops), make sure the string is null terminated. If not, copy
3491 ** and terminate it.
3494 vmThrowErr(pVM, "Error: out of memory");
3496 strncpy(pDest, cp, count);
3497 pDest[count] = '\0';
3499 vmTextOut(pVM, pDest, 0);
3505 /**************************************************************************
3507 ** word CORE ( char "<chars>ccc<char>" -- c-addr )
3508 ** Skip leading delimiters. Parse characters ccc delimited by char. An
3509 ** ambiguous condition exists if the length of the parsed string is greater
3510 ** than the implementation-defined length of a counted string.
3512 ** c-addr is the address of a transient region containing the parsed word
3513 ** as a counted string. If the parse area was empty or contained no
3514 ** characters other than the delimiter, the resulting string has a zero
3515 ** length. A space, not included in the length, follows the string. A
3516 ** program may replace characters within the string.
3517 ** NOTE! Ficl also NULL-terminates the dest string.
3518 **************************************************************************/
3519 static void ficlWord(FICL_VM *pVM)
3525 vmCheckStack(pVM,1,1);
3528 sp = (FICL_STRING *)pVM->pad;
3529 delim = (char)POPINT();
3530 si = vmParseStringEx(pVM, delim, 1);
3532 if (SI_COUNT(si) > nPAD-1)
3533 SI_SETLEN(si, nPAD-1);
3535 sp->count = (FICL_COUNT)SI_COUNT(si);
3536 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3537 /*#$-GUY CHANGE: I added this.-$#*/
3538 sp->text[sp->count] = 0;
3539 strcat(sp->text, " ");
3546 /**************************************************************************
3548 ** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3549 ** Skip leading spaces and parse name delimited by a space. c-addr is the
3550 ** address within the input buffer and u is the length of the selected
3551 ** string. If the parse area is empty, the resulting string has a zero length.
3552 **************************************************************************/
3553 static void parseNoCopy(FICL_VM *pVM)
3557 vmCheckStack(pVM,0,2);
3560 si = vmGetWord0(pVM);
3561 PUSHPTR(SI_PTR(si));
3562 PUSHUNS(SI_COUNT(si));
3567 /**************************************************************************
3569 ** CORE EXT ( char "ccc<char>" -- c-addr u )
3570 ** Parse ccc delimited by the delimiter char.
3571 ** c-addr is the address (within the input buffer) and u is the length of
3572 ** the parsed string. If the parse area was empty, the resulting string has
3574 ** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3575 **************************************************************************/
3576 static void parse(FICL_VM *pVM)
3582 vmCheckStack(pVM,1,2);
3585 delim = (char)POPINT();
3587 si = vmParseStringEx(pVM, delim, 0);
3588 PUSHPTR(SI_PTR(si));
3589 PUSHUNS(SI_COUNT(si));
3594 /**************************************************************************
3596 ** CORE ( c-addr u char -- )
3597 ** If u is greater than zero, store char in each of u consecutive
3598 ** characters of memory beginning at c-addr.
3599 **************************************************************************/
3600 static void fill(FICL_VM *pVM)
3606 vmCheckStack(pVM,3,0);
3608 ch = (char)POPINT();
3610 cp = (char *)POPPTR();
3621 /**************************************************************************
3623 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3624 ** Find the definition named in the counted string at c-addr. If the
3625 ** definition is not found, return c-addr and zero. If the definition is
3626 ** found, return its execution token xt. If the definition is immediate,
3627 ** also return one (1), otherwise also return minus-one (-1). For a given
3628 ** string, the values returned by FIND while compiling may differ from
3629 ** those returned while not compiling.
3630 **************************************************************************/
3631 static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3635 pFW = dictLookup(vmGetDict(pVM), si);
3639 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3643 PUSHPTR(returnForFailure);
3651 /**************************************************************************
3653 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3654 ** Find the definition named in the counted string at c-addr. If the
3655 ** definition is not found, return c-addr and zero. If the definition is
3656 ** found, return its execution token xt. If the definition is immediate,
3657 ** also return one (1), otherwise also return minus-one (-1). For a given
3658 ** string, the values returned by FIND while compiling may differ from
3659 ** those returned while not compiling.
3660 **************************************************************************/
3661 static void cFind(FICL_VM *pVM)
3667 vmCheckStack(pVM,1,2);
3671 do_find(pVM, si, sp);
3676 /**************************************************************************
3678 ** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3679 ** Like FIND, but takes "c-addr u" for the string.
3680 **************************************************************************/
3681 static void sFind(FICL_VM *pVM)
3686 vmCheckStack(pVM,2,2);
3689 si.count = stackPopINT(pVM->pStack);
3690 si.cp = stackPopPtr(pVM->pStack);
3692 do_find(pVM, si, NULL);
3697 /**************************************************************************
3699 ** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3700 ** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3701 ** Input and output stack arguments are signed. An ambiguous condition
3702 ** exists if n1 is zero or if the quotient lies outside the range of a
3703 ** single-cell signed integer.
3704 **************************************************************************/
3705 static void fmSlashMod(FICL_VM *pVM)
3711 vmCheckStack(pVM,3,2);
3715 d1 = i64Pop(pVM->pStack);
3716 qr = m64FlooredDivI(d1, n1);
3723 /**************************************************************************
3725 ** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3726 ** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3727 ** Input and output stack arguments are signed. An ambiguous condition
3728 ** exists if n1 is zero or if the quotient lies outside the range of a
3729 ** single-cell signed integer.
3730 **************************************************************************/
3731 static void smSlashRem(FICL_VM *pVM)
3737 vmCheckStack(pVM,3,2);
3741 d1 = i64Pop(pVM->pStack);
3742 qr = m64SymmetricDivI(d1, n1);
3749 static void ficlMod(FICL_VM *pVM)
3755 vmCheckStack(pVM,2,1);
3761 qr = m64SymmetricDivI(d1, n1);
3767 /**************************************************************************
3769 ** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3770 ** Divide ud by u1, giving the quotient u3 and the remainder u2.
3771 ** All values and arithmetic are unsigned. An ambiguous condition
3772 ** exists if u1 is zero or if the quotient lies outside the range of a
3773 ** single-cell unsigned integer.
3774 *************************************************************************/
3775 static void umSlashMod(FICL_VM *pVM)
3781 u1 = stackPopUNS(pVM->pStack);
3782 ud = u64Pop(pVM->pStack);
3783 qr = ficlLongDiv(ud, u1);
3790 /**************************************************************************
3792 ** l-shift CORE ( x1 u -- x2 )
3793 ** Perform a logical left shift of u bit-places on x1, giving x2.
3794 ** Put zeroes into the least significant bits vacated by the shift.
3795 ** An ambiguous condition exists if u is greater than or equal to the
3796 ** number of bits in a cell.
3798 ** r-shift CORE ( x1 u -- x2 )
3799 ** Perform a logical right shift of u bit-places on x1, giving x2.
3800 ** Put zeroes into the most significant bits vacated by the shift. An
3801 ** ambiguous condition exists if u is greater than or equal to the
3802 ** number of bits in a cell.
3803 **************************************************************************/
3804 static void lshift(FICL_VM *pVM)
3809 vmCheckStack(pVM,2,1);
3814 PUSHUNS(x1 << nBits);
3819 static void rshift(FICL_VM *pVM)
3824 vmCheckStack(pVM,2,1);
3830 PUSHUNS(x1 >> nBits);
3835 /**************************************************************************
3837 ** m-star CORE ( n1 n2 -- d )
3838 ** d is the signed product of n1 times n2.
3839 **************************************************************************/
3840 static void mStar(FICL_VM *pVM)
3846 vmCheckStack(pVM,2,2);
3852 d = m64MulI(n1, n2);
3853 i64Push(pVM->pStack, d);
3858 static void umStar(FICL_VM *pVM)
3864 vmCheckStack(pVM,2,2);
3870 ud = ficlLongMul(u1, u2);
3871 u64Push(pVM->pStack, ud);
3876 /**************************************************************************
3879 **************************************************************************/
3880 static void ficlMax(FICL_VM *pVM)
3885 vmCheckStack(pVM,2,1);
3891 PUSHINT((n1 > n2) ? n1 : n2);
3895 static void ficlMin(FICL_VM *pVM)
3900 vmCheckStack(pVM,2,1);
3906 PUSHINT((n1 < n2) ? n1 : n2);
3911 /**************************************************************************
3913 ** CORE ( addr1 addr2 u -- )
3914 ** If u is greater than zero, copy the contents of u consecutive address
3915 ** units at addr1 to the u consecutive address units at addr2. After MOVE
3916 ** completes, the u consecutive address units at addr2 contain exactly
3917 ** what the u consecutive address units at addr1 contained before the move.
3918 ** NOTE! This implementation assumes that a char is the same size as
3920 **************************************************************************/
3921 static void move(FICL_VM *pVM)
3927 vmCheckStack(pVM,3,0);
3937 ** Do the copy carefully, so as to be
3938 ** correct even if the two ranges overlap
3943 *addr2++ = *addr1++;
3950 *addr2-- = *addr1--;
3957 /**************************************************************************
3960 **************************************************************************/
3961 static void recurseCoIm(FICL_VM *pVM)
3963 FICL_DICT *pDict = vmGetDict(pVM);
3966 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3971 /**************************************************************************
3973 ** s-to-d CORE ( n -- d )
3974 ** Convert the number n to the double-cell number d with the same
3976 **************************************************************************/
3977 static void sToD(FICL_VM *pVM)
3981 vmCheckStack(pVM,1,2);
3986 /* sign extend to 64 bits.. */
3988 PUSHINT((s < 0) ? -1 : 0);
3993 /**************************************************************************
3995 ** CORE ( -- c-addr u )
3996 ** c-addr is the address of, and u is the number of characters in, the
3998 **************************************************************************/
3999 static void source(FICL_VM *pVM)
4002 vmCheckStack(pVM,0,2);
4004 PUSHPTR(pVM->tib.cp);
4005 PUSHINT(vmGetInBufLen(pVM));
4010 /**************************************************************************
4013 **************************************************************************/
4014 static void ficlVersion(FICL_VM *pVM)
4016 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
4021 /**************************************************************************
4024 **************************************************************************/
4025 static void toIn(FICL_VM *pVM)
4028 vmCheckStack(pVM,0,1);
4030 PUSHPTR(&pVM->tib.index);
4035 /**************************************************************************
4036 c o l o n N o N a m e
4037 ** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
4038 ** Create an unnamed colon definition and push its address.
4039 ** Change state to compile.
4040 **************************************************************************/
4041 static void colonNoName(FICL_VM *pVM)
4043 FICL_DICT *dp = vmGetDict(pVM);
4048 SI_SETPTR(si, NULL);
4050 pVM->state = COMPILE;
4051 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
4053 markControlTag(pVM, colonTag);
4058 /**************************************************************************
4059 u s e r V a r i a b l e
4060 ** user ( u -- ) "<spaces>name"
4061 ** Get a name from the input stream and create a user variable
4062 ** with the name and the index supplied. The run-time effect
4063 ** of a user variable is to push the address of the indexed cell
4064 ** in the running vm's user array.
4066 ** User variables are vm local cells. Each vm has an array of
4067 ** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
4068 ** Ficl's user facility is implemented with two primitives,
4069 ** "user" and "(user)", a variable ("nUser") (in softcore.c) that
4070 ** holds the index of the next free user cell, and a redefinition
4071 ** (also in softcore) of "user" that defines a user word and increments
4073 **************************************************************************/
4075 static void userParen(FICL_VM *pVM)
4077 FICL_INT i = pVM->runningWord->param[0].i;
4078 PUSHPTR(&pVM->user[i]);
4083 static void userVariable(FICL_VM *pVM)
4085 FICL_DICT *dp = vmGetDict(pVM);
4086 STRINGINFO si = vmGetWord(pVM);
4089 c = stackPop(pVM->pStack);
4090 if (c.i >= FICL_USER_CELLS)
4092 vmThrowErr(pVM, "Error - out of user space");
4095 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
4096 dictAppendCell(dp, c);
4102 /**************************************************************************
4105 ** Interpretation: ( x "<spaces>name" -- )
4106 ** Skip leading spaces and parse name delimited by a space. Store x in
4107 ** name. An ambiguous condition exists if name was not defined by VALUE.
4108 ** NOTE: In ficl, VALUE is an alias of CONSTANT
4109 **************************************************************************/
4110 static void toValue(FICL_VM *pVM)
4112 STRINGINFO si = vmGetWord(pVM);
4113 FICL_DICT *dp = vmGetDict(pVM);
4116 #if FICL_WANT_LOCALS
4117 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
4119 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4120 pFW = dictLookup(pLoc, si);
4121 if (pFW && (pFW->code == doLocalIm))
4123 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4124 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
4127 else if (pFW && pFW->code == do2LocalIm)
4129 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4130 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
4136 assert(pVM->pSys->pStore);
4138 pFW = dictLookup(dp, si);
4141 int i = SI_COUNT(si);
4142 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
4145 if (pVM->state == INTERPRET)
4146 pFW->param[0] = stackPop(pVM->pStack);
4147 else /* compile code to store to word's param */
4149 PUSHPTR(&pFW->param[0]);
4151 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
4157 #if FICL_WANT_LOCALS
4158 /**************************************************************************
4161 ** Link a frame on the return stack, reserving nCells of space for
4162 ** locals - the value of nCells is the next cell in the instruction
4164 **************************************************************************/
4165 static void linkParen(FICL_VM *pVM)
4167 FICL_INT nLink = *(FICL_INT *)(pVM->ip);
4168 vmBranchRelative(pVM, 1);
4169 stackLink(pVM->rStack, nLink);
4174 static void unlinkParen(FICL_VM *pVM)
4176 stackUnlink(pVM->rStack);
4181 /**************************************************************************
4183 ** Immediate - cfa of a local while compiling - when executed, compiles
4184 ** code to fetch the value of a local given the local's index in the
4186 **************************************************************************/
4187 static void getLocalParen(FICL_VM *pVM)
4189 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4190 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4195 static void toLocalParen(FICL_VM *pVM)
4197 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4198 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4203 static void getLocal0(FICL_VM *pVM)
4205 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
4210 static void toLocal0(FICL_VM *pVM)
4212 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
4217 static void getLocal1(FICL_VM *pVM)
4219 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
4224 static void toLocal1(FICL_VM *pVM)
4226 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
4232 ** Each local is recorded in a private locals dictionary as a
4233 ** word that does doLocalIm at runtime. DoLocalIm compiles code
4234 ** into the client definition to fetch the value of the
4235 ** corresponding local variable from the return stack.
4236 ** The private dictionary gets initialized at the end of each block
4237 ** that uses locals (in ; and does> for example).
4239 static void doLocalIm(FICL_VM *pVM)
4241 FICL_DICT *pDict = vmGetDict(pVM);
4242 FICL_INT nLocal = pVM->runningWord->param[0].i;
4244 if (pVM->state == INTERPRET)
4246 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4253 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
4255 else if (nLocal == 1)
4257 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
4261 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
4262 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4269 /**************************************************************************
4271 ** paren-local-paren LOCAL
4272 ** Interpretation: Interpretation semantics for this word are undefined.
4273 ** Execution: ( c-addr u -- )
4274 ** When executed during compilation, (LOCAL) passes a message to the
4275 ** system that has one of two meanings. If u is non-zero,
4276 ** the message identifies a new local whose definition name is given by
4277 ** the string of characters identified by c-addr u. If u is zero,
4278 ** the message is last local and c-addr has no significance.
4280 ** The result of executing (LOCAL) during compilation of a definition is
4281 ** to create a set of named local identifiers, each of which is
4282 ** a definition name, that only have execution semantics within the scope
4283 ** of that definition's source.
4285 ** local Execution: ( -- x )
4287 ** Push the local's value, x, onto the stack. The local's value is
4288 ** initialized as described in 13.3.3 Processing locals and may be
4289 ** changed by preceding the local's name with TO. An ambiguous condition
4290 ** exists when local is executed while in interpretation state.
4291 **************************************************************************/
4292 static void localParen(FICL_VM *pVM)
4297 vmCheckStack(pVM,2,0);
4300 pDict = vmGetDict(pVM);
4301 SI_SETLEN(si, POPUNS());
4302 SI_SETPTR(si, (char *)POPPTR());
4304 if (SI_COUNT(si) > 0)
4305 { /* add a local to the **locals** dict and update nLocals */
4306 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4307 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4309 vmThrowErr(pVM, "Error: out of local space");
4312 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4313 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4315 if (pVM->pSys->nLocals == 0)
4316 { /* compile code to create a local stack frame */
4317 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4318 /* save location in dictionary for #locals */
4319 pVM->pSys->pMarkLocals = pDict->here;
4320 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4321 /* compile code to initialize first local */
4322 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
4324 else if (pVM->pSys->nLocals == 1)
4326 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
4330 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4331 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4334 (pVM->pSys->nLocals)++;
4336 else if (pVM->pSys->nLocals > 0)
4337 { /* write nLocals to (link) param area in dictionary */
4338 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4345 static void get2LocalParen(FICL_VM *pVM)
4347 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4348 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4349 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4354 static void do2LocalIm(FICL_VM *pVM)
4356 FICL_DICT *pDict = vmGetDict(pVM);
4357 FICL_INT nLocal = pVM->runningWord->param[0].i;
4359 if (pVM->state == INTERPRET)
4361 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4362 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4366 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
4367 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4373 static void to2LocalParen(FICL_VM *pVM)
4375 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4376 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4377 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4382 static void twoLocalParen(FICL_VM *pVM)
4384 FICL_DICT *pDict = vmGetDict(pVM);
4386 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4387 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4389 if (SI_COUNT(si) > 0)
4390 { /* add a local to the **locals** dict and update nLocals */
4391 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4392 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4394 vmThrowErr(pVM, "Error: out of local space");
4397 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4398 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4400 if (pVM->pSys->nLocals == 0)
4401 { /* compile code to create a local stack frame */
4402 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4403 /* save location in dictionary for #locals */
4404 pVM->pSys->pMarkLocals = pDict->here;
4405 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4408 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4409 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4411 pVM->pSys->nLocals += 2;
4413 else if (pVM->pSys->nLocals > 0)
4414 { /* write nLocals to (link) param area in dictionary */
4415 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4423 /**************************************************************************
4425 ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4426 ** Compare the string specified by c-addr1 u1 to the string specified by
4427 ** c-addr2 u2. The strings are compared, beginning at the given addresses,
4428 ** character by character, up to the length of the shorter string or until a
4429 ** difference is found. If the two strings are identical, n is zero. If the two
4430 ** strings are identical up to the length of the shorter string, n is minus-one
4431 ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4432 ** identical up to the length of the shorter string, n is minus-one (-1) if the
4433 ** first non-matching character in the string specified by c-addr1 u1 has a
4434 ** lesser numeric value than the corresponding character in the string specified
4435 ** by c-addr2 u2 and one (1) otherwise.
4436 **************************************************************************/
4437 static void compareInternal(FICL_VM *pVM, int caseInsensitive)
4440 FICL_UNS u1, u2, uMin;
4443 vmCheckStack(pVM, 4, 1);
4444 u2 = stackPopUNS(pVM->pStack);
4445 cp2 = (char *)stackPopPtr(pVM->pStack);
4446 u1 = stackPopUNS(pVM->pStack);
4447 cp1 = (char *)stackPopPtr(pVM->pStack);
4449 uMin = (u1 < u2)? u1 : u2;
4450 for ( ; (uMin > 0) && (n == 0); uMin--)
4454 if (caseInsensitive)
4456 c1 = (char)tolower(c1);
4457 c2 = (char)tolower(c2);
4475 static void compareString(FICL_VM *pVM)
4477 compareInternal(pVM, FALSE);
4481 static void compareStringInsensitive(FICL_VM *pVM)
4483 compareInternal(pVM, TRUE);
4487 /**************************************************************************
4489 ** CORE EXT ( -- c-addr )
4490 ** c-addr is the address of a transient region that can be used to hold
4491 ** data for intermediate processing.
4492 **************************************************************************/
4493 static void pad(FICL_VM *pVM)
4495 stackPushPtr(pVM->pStack, pVM->pad);
4499 /**************************************************************************
4501 ** CORE EXT, FILE ( -- 0 | -1 | fileid )
4502 ** Identifies the input source as follows:
4504 ** SOURCE-ID Input source
4505 ** --------- ------------
4506 ** fileid Text file fileid
4507 ** -1 String (via EVALUATE)
4508 ** 0 User input device
4509 **************************************************************************/
4510 static void sourceid(FICL_VM *pVM)
4512 PUSHINT(pVM->sourceID.i);
4517 /**************************************************************************
4519 ** CORE EXT ( -- flag )
4520 ** Attempt to fill the input buffer from the input source, returning a true
4521 ** flag if successful.
4522 ** When the input source is the user input device, attempt to receive input
4523 ** into the terminal input buffer. If successful, make the result the input
4524 ** buffer, set >IN to zero, and return true. Receipt of a line containing no
4525 ** characters is considered successful. If there is no input available from
4526 ** the current input source, return false.
4527 ** When the input source is a string from EVALUATE, return false and
4528 ** perform no other action.
4529 **************************************************************************/
4530 static void refill(FICL_VM *pVM)
4532 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4533 if (ret && (pVM->fRestart == 0))
4534 vmThrow(pVM, VM_RESTART);
4541 /**************************************************************************
4542 freebsd exception handling words
4543 ** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4544 ** the word in ToS. If an exception happens, restore the state to what
4545 ** it was before, and pushes the exception value on the stack. If not,
4548 ** Notice that Catch implements an inner interpreter. This is ugly,
4549 ** but given how ficl works, it cannot be helped. The problem is that
4550 ** colon definitions will be executed *after* the function returns,
4551 ** while "code" definitions will be executed immediately. I considered
4552 ** other solutions to this problem, but all of them shared the same
4553 ** basic problem (with added disadvantages): if ficl ever changes it's
4554 ** inner thread modus operandi, one would have to fix this word.
4556 ** More comments can be found throughout catch's code.
4558 ** Daniel C. Sobral Jan 09/1999
4559 ** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4560 **************************************************************************/
4562 static void ficlCatch(FICL_VM *pVM)
4572 assert(pVM->pSys->pExitInner);
4577 ** We need this *before* we save the stack pointer, or
4578 ** we'll have to pop one element out of the stack after
4579 ** an exception. I prefer to get done with it up front. :-)
4582 vmCheckStack(pVM, 1, 0);
4584 pFW = stackPopPtr(pVM->pStack);
4587 ** Save vm's state -- a catch will not back out environmental
4590 ** We are *not* saving dictionary state, since it is
4591 ** global instead of per vm, and we are not saving
4592 ** stack contents, since we are not required to (and,
4593 ** thus, it would be useless). We save pVM, and pVM
4594 ** "stacks" (a structure containing general information
4595 ** about it, including the current stack pointer).
4597 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4598 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4599 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4602 ** Give pVM a jmp_buf
4604 pVM->pState = &vmState;
4609 except = setjmp(vmState);
4614 ** Setup condition - push poison pill so that the VM throws
4615 ** VM_INNEREXIT if the XT terminates normally, then execute
4619 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4620 vmExecute(pVM, pFW);
4625 ** Normal exit from XT - lose the poison pill,
4626 ** restore old setjmp vector and push a zero.
4629 vmPopIP(pVM); /* Gack - hurl poison pill */
4630 pVM->pState = VM.pState; /* Restore just the setjmp vector */
4631 PUSHINT(0); /* Push 0 -- everything is ok */
4635 ** Some other exception got thrown - restore pre-existing VM state
4636 ** and push the exception code
4639 /* Restore vm's state */
4640 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4641 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4642 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4644 PUSHINT(except);/* Push error */
4649 /**************************************************************************
4652 ** Throw -- From ANS Forth standard.
4654 ** Throw takes the ToS and, if that's different from zero,
4655 ** returns to the last executed catch context. Further throws will
4656 ** unstack previously executed "catches", in LIFO mode.
4658 ** Daniel C. Sobral Jan 09/1999
4659 **************************************************************************/
4660 static void ficlThrow(FICL_VM *pVM)
4664 except = stackPopINT(pVM->pStack);
4667 vmThrow(pVM, except);
4671 /**************************************************************************
4674 **************************************************************************/
4675 static void ansAllocate(FICL_VM *pVM)
4680 size = stackPopINT(pVM->pStack);
4681 p = ficlMalloc(size);
4690 /**************************************************************************
4693 **************************************************************************/
4694 static void ansFree(FICL_VM *pVM)
4698 p = stackPopPtr(pVM->pStack);
4704 /**************************************************************************
4707 **************************************************************************/
4708 static void ansResize(FICL_VM *pVM)
4713 size = stackPopINT(pVM->pStack);
4714 old = stackPopPtr(pVM->pStack);
4715 new = ficlRealloc(old, size);
4729 /**************************************************************************
4730 ** e x i t - i n n e r
4731 ** Signals execXT that an inner loop has completed
4732 **************************************************************************/
4733 static void ficlExitInner(FICL_VM *pVM)
4735 vmThrow(pVM, VM_INNEREXIT);
4739 /**************************************************************************
4741 ** DOUBLE ( d1 -- d2 )
4742 ** d2 is the negation of d1.
4743 **************************************************************************/
4744 static void dnegate(FICL_VM *pVM)
4746 DPINT i = i64Pop(pVM->pStack);
4748 i64Push(pVM->pStack, i);
4755 /**************************************************************************
4758 **************************************************************************/
4759 static void funcname(FICL_VM *pVM)
4767 /**************************************************************************
4768 f i c l W o r d C l a s s i f y
4769 ** This public function helps to classify word types for SEE
4770 ** and the deugger in tools.c. Given a pointer to a word, it returns
4772 **************************************************************************/
4773 WORDKIND ficlWordClassify(FICL_WORD *pFW)
4781 static CODEtoKIND codeMap[] =
4783 {BRANCH, branchParen},
4784 {COLON, colonParen},
4785 {CONSTANT, constantParen},
4786 {CREATE, createParen},
4790 {LITERAL, literalParen},
4793 {PLOOP, plusLoopParen},
4795 {CSTRINGLIT, cstringLit},
4796 {STRINGLIT, stringLit},
4800 {VARIABLE, variableParen},
4803 #define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4805 FICL_CODE code = pFW->code;
4808 for (i=0; i < nMAP; i++)
4810 if (codeMap[i].code == code)
4811 return codeMap[i].kind;
4819 /**************************************************************************
4822 **************************************************************************/
4823 static void ficlRandom(FICL_VM *pVM)
4829 /**************************************************************************
4830 ** s e e d - r a n d o m
4832 **************************************************************************/
4833 static void ficlSeedRandom(FICL_VM *pVM)
4840 /**************************************************************************
4841 f i c l C o m p i l e C o r e
4842 ** Builds the primitive wordset and the environment-query namespace.
4843 **************************************************************************/
4845 void ficlCompileCore(FICL_SYSTEM *pSys)
4847 FICL_DICT *dp = pSys->dp;
4853 ** see softcore.c for definitions of: abs bl space spaces abort"
4856 dictAppendWord(dp, "!", store, FW_DEFAULT);
4857 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4858 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4859 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4860 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4861 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4862 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4863 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4864 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4865 dictAppendWord(dp, "+", add, FW_DEFAULT);
4866 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4867 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4868 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4869 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4870 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4871 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4872 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4873 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4874 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4875 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4876 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4877 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4878 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4879 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4880 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4881 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4882 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4883 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4884 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4885 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4886 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4887 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4888 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4889 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4890 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4891 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4892 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4893 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4894 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4895 dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
4896 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4897 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4898 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4899 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4900 dictAppendWord(dp, "align", align, FW_DEFAULT);
4901 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4902 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4903 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4904 dictAppendWord(dp, "base", base, FW_DEFAULT);
4905 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4906 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4907 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4908 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4909 dictAppendWord(dp, "case", caseCoIm, FW_COMPIMMED);
4910 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4911 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4912 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4913 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4914 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4915 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4916 dictAppendWord(dp, "count", count, FW_DEFAULT);
4917 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4918 dictAppendWord(dp, "create", create, FW_DEFAULT);
4919 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4920 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4921 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4922 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4924 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4925 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4926 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4927 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4928 dictAppendWord(dp, "endcase", endcaseCoIm, FW_COMPIMMED);
4929 dictAppendWord(dp, "endof", endofCoIm, FW_COMPIMMED);
4930 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4931 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4932 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4933 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4934 dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED);
4935 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4936 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4937 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4938 dictAppendWord(dp, "here", here, FW_DEFAULT);
4939 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4940 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4941 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4942 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4943 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4944 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4945 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4946 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4947 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4948 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4949 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4950 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4951 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4952 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4953 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4954 dictAppendWord(dp, "move", move, FW_DEFAULT);
4955 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4956 dictAppendWord(dp, "of", ofCoIm, FW_COMPIMMED);
4957 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4958 dictAppendWord(dp, "over", over, FW_DEFAULT);
4959 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4960 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4961 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
4962 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
4963 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4964 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4965 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4966 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4967 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4968 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4969 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4970 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4971 dictAppendWord(dp, "source", source, FW_DEFAULT);
4972 dictAppendWord(dp, "state", state, FW_DEFAULT);
4973 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4974 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4975 dictAppendWord(dp, "type", type, FW_DEFAULT);
4976 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4977 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4978 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4979 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4980 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4981 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4982 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4983 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4984 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4985 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4986 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4987 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4988 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4989 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4991 ** CORE EXT word set...
4992 ** see softcore.fr for other definitions
4995 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
4997 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4998 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4999 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
5000 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
5001 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
5002 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
5003 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
5004 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
5005 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
5006 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
5007 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
5008 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
5009 /* query restore-input save-input tib u.r u> unused [compile] */
5010 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
5011 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
5012 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
5013 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
5014 dictAppendWord(dp, "value", constant, FW_DEFAULT);
5015 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
5019 ** Set CORE environment query values
5021 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
5022 ficlSetEnv(pSys, "/hold", nPAD);
5023 ficlSetEnv(pSys, "/pad", nPAD);
5024 ficlSetEnv(pSys, "address-unit-bits", 8);
5025 ficlSetEnv(pSys, "core", FICL_TRUE);
5026 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
5027 ficlSetEnv(pSys, "floored", FICL_FALSE);
5028 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
5029 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
5030 ficlSetEnv(pSys, "max-n", 0x7fffffff);
5031 ficlSetEnv(pSys, "max-u", 0xffffffff);
5032 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
5033 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
5034 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
5037 ** DOUBLE word set (partial)
5039 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
5040 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
5041 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
5042 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
5046 ** EXCEPTION word set
5048 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
5049 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
5051 ficlSetEnv(pSys, "exception", FICL_TRUE);
5052 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
5055 ** LOCAL and LOCAL EXT
5056 ** see softcore.c for implementation of locals|
5058 #if FICL_WANT_LOCALS
5060 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
5061 pSys->pUnLinkParen =
5062 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
5063 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
5064 pSys->pGetLocalParen =
5065 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
5066 pSys->pToLocalParen =
5067 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
5069 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
5071 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
5073 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
5075 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
5076 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
5078 pSys->pGet2LocalParen =
5079 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
5080 pSys->pTo2LocalParen =
5081 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
5082 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
5084 ficlSetEnv(pSys, "locals", FICL_TRUE);
5085 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
5086 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
5090 ** Optional MEMORY-ALLOC word set
5093 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
5094 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
5095 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
5097 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
5100 ** optional SEARCH-ORDER word set
5102 ficlCompileSearch(pSys);
5105 ** TOOLS and TOOLS EXT
5107 ficlCompileTools(pSys);
5110 ** FILE and FILE EXT
5113 ficlCompileFile(pSys);
5120 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
5122 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
5123 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
5124 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
5125 dictAppendWord(dp, "add-parse-step",
5126 addParseStep, FW_DEFAULT);
5127 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
5128 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
5129 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
5130 dictAppendWord(dp, "compile-only",
5131 compileOnly, FW_DEFAULT);
5132 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
5133 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
5134 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
5135 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
5136 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
5137 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
5138 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
5139 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
5140 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
5141 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
5142 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
5143 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
5144 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
5145 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
5146 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
5148 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
5149 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
5152 dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT);
5153 dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT);
5157 ** internal support words
5159 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
5161 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
5163 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
5165 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
5166 pSys->pTwoLitParen =
5167 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
5169 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
5171 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
5173 dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE);
5174 pSys->pBranchParen =
5175 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
5177 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
5179 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
5181 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
5183 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
5185 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
5187 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
5188 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
5190 dictAppendWord(dp, "(of)", ofParen, FW_DEFAULT);
5191 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
5192 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
5193 dictAppendWord(dp, "(parse-step)",
5194 parseStepParen, FW_DEFAULT);
5196 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
5199 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
5201 pSys->pInterp[0] = pSys->pInterpret;
5202 pSys->pInterp[1] = pSys->pBranchParen;
5203 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
5205 assert(dictCellsAvail(dp) > 0);