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";
75 static void doLocalIm(FICL_VM *pVM);
76 static void do2LocalIm(FICL_VM *pVM);
81 ** C O N T R O L S T R U C T U R E B U I L D E R S
83 ** Push current dict location for later branch resolution.
84 ** The location may be either a branch target or a patch address...
86 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
93 static void markControlTag(FICL_VM *pVM, char *tag)
99 static void matchControlTag(FICL_VM *pVM, char *tag)
103 vmCheckStack(pVM, 1, 0);
105 cp = (char *)stackPopPtr(pVM->pStack);
107 ** Changed the code below to compare the pointers first (by popular demand)
109 if ( (cp != tag) && strcmp(cp, tag) )
111 vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
118 ** Expect a branch target address on the param stack,
119 ** compile a literal offset from the current dict location
120 ** to the target address
122 static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
127 matchControlTag(pVM, tag);
130 vmCheckStack(pVM, 1, 0);
132 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
133 offset = patchAddr - dp->here;
134 dictAppendCell(dp, LVALUEtoCELL(offset));
141 ** Expect a branch patch address on the param stack,
142 ** compile a literal offset from the patch location
143 ** to the current dict location
145 static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
150 matchControlTag(pVM, tag);
153 vmCheckStack(pVM, 1, 0);
155 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
156 offset = dp->here - patchAddr;
157 *patchAddr = LVALUEtoCELL(offset);
163 ** Match the tag to the top of the stack. If success,
164 ** sopy "here" address into the cell whose address is next
165 ** on the stack. Used by do..leave..loop.
167 static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
173 vmCheckStack(pVM, 2, 0);
175 cp = stackPopPtr(pVM->pStack);
177 ** Changed the comparison below to compare the pointers first (by popular demand)
179 if ((cp != tag) && strcmp(cp, tag))
181 vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
182 vmTextOut(pVM, tag, 1);
185 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
186 *patchAddr = LVALUEtoCELL(dp->here);
192 /**************************************************************************
193 f i c l P a r s e N u m b e r
194 ** Attempts to convert the NULL terminated string in the VM's pad to
195 ** a number using the VM's current base. If successful, pushes the number
196 ** onto the param stack and returns TRUE. Otherwise, returns FALSE.
197 ** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
198 ** the standard for DOUBLE wordset.
199 **************************************************************************/
201 int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
206 unsigned base = pVM->base;
207 char *cp = SI_PTR(si);
208 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
231 if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
237 if (count == 0) /* detect "+", "-", ".", "+." etc */
240 while ((count--) && ((ch = *cp++) != '\0'))
248 digit = tolower(ch) - 'a' + 10;
253 accum = accum * base + digit;
256 if (hasDP) /* simple (required) DOUBLE support */
263 if (pVM->state == COMPILE)
270 /**************************************************************************
271 a d d & f r i e n d s
273 **************************************************************************/
275 static void add(FICL_VM *pVM)
279 vmCheckStack(pVM, 2, 1);
281 i = stackPopINT(pVM->pStack);
282 i += stackGetTop(pVM->pStack).i;
283 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
287 static void sub(FICL_VM *pVM)
291 vmCheckStack(pVM, 2, 1);
293 i = stackPopINT(pVM->pStack);
294 i = stackGetTop(pVM->pStack).i - i;
295 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
299 static void mul(FICL_VM *pVM)
303 vmCheckStack(pVM, 2, 1);
305 i = stackPopINT(pVM->pStack);
306 i *= stackGetTop(pVM->pStack).i;
307 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
311 static void negate(FICL_VM *pVM)
315 vmCheckStack(pVM, 1, 1);
317 i = -stackPopINT(pVM->pStack);
322 static void ficlDiv(FICL_VM *pVM)
326 vmCheckStack(pVM, 2, 1);
328 i = stackPopINT(pVM->pStack);
329 i = stackGetTop(pVM->pStack).i / i;
330 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
335 ** slash-mod CORE ( n1 n2 -- n3 n4 )
336 ** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
337 ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
338 ** differ in sign, the implementation-defined result returned will be the
339 ** same as that returned by either the phrase
340 ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
341 ** NOTE: Ficl complies with the second phrase (symmetric division)
343 static void slashMod(FICL_VM *pVM)
350 vmCheckStack(pVM, 2, 2);
352 n2 = stackPopINT(pVM->pStack);
353 n1.lo = stackPopINT(pVM->pStack);
356 qr = m64SymmetricDivI(n1, n2);
362 static void onePlus(FICL_VM *pVM)
366 vmCheckStack(pVM, 1, 1);
368 i = stackGetTop(pVM->pStack).i;
370 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
374 static void oneMinus(FICL_VM *pVM)
378 vmCheckStack(pVM, 1, 1);
380 i = stackGetTop(pVM->pStack).i;
382 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
386 static void twoMul(FICL_VM *pVM)
390 vmCheckStack(pVM, 1, 1);
392 i = stackGetTop(pVM->pStack).i;
394 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
398 static void twoDiv(FICL_VM *pVM)
402 vmCheckStack(pVM, 1, 1);
404 i = stackGetTop(pVM->pStack).i;
406 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
410 static void mulDiv(FICL_VM *pVM)
415 vmCheckStack(pVM, 3, 1);
417 z = stackPopINT(pVM->pStack);
418 y = stackPopINT(pVM->pStack);
419 x = stackPopINT(pVM->pStack);
422 x = m64SymmetricDivI(prod, z).quot;
429 static void mulDivRem(FICL_VM *pVM)
435 vmCheckStack(pVM, 3, 2);
437 z = stackPopINT(pVM->pStack);
438 y = stackPopINT(pVM->pStack);
439 x = stackPopINT(pVM->pStack);
442 qr = m64SymmetricDivI(prod, z);
450 /**************************************************************************
451 c o l o n d e f i n i t i o n s
452 ** Code to begin compiling a colon definition
453 ** This function sets the state to COMPILE, then creates a
454 ** new word whose name is the next word in the input stream
455 ** and whose code is colonParen.
456 **************************************************************************/
458 static void colon(FICL_VM *pVM)
460 FICL_DICT *dp = vmGetDict(pVM);
461 STRINGINFO si = vmGetWord(pVM);
463 dictCheckThreshold(dp);
465 pVM->state = COMPILE;
466 markControlTag(pVM, colonTag);
467 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
469 pVM->pSys->nLocals = 0;
475 /**************************************************************************
477 ** This is the code that executes a colon definition. It assumes that the
478 ** virtual machine is running a "next" loop (See the vm.c
479 ** for its implementation of member function vmExecute()). The colon
480 ** code simply copies the address of the first word in the list of words
481 ** to interpret into IP after saving its old value. When we return to the
482 ** "next" loop, the virtual machine will call the code for each word in
485 **************************************************************************/
487 static void colonParen(FICL_VM *pVM)
489 IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
490 vmPushIP(pVM, tempIP);
496 /**************************************************************************
497 s e m i c o l o n C o I m
499 ** IMMEDIATE code for ";". This function sets the state to INTERPRET and
500 ** terminates a word under compilation by appending code for "(;)" to
501 ** the definition. TO DO: checks for leftover branch target tags on the
502 ** return stack and complains if any are found.
503 **************************************************************************/
504 static void semiParen(FICL_VM *pVM)
511 static void semicolonCoIm(FICL_VM *pVM)
513 FICL_DICT *dp = vmGetDict(pVM);
515 assert(pVM->pSys->pSemiParen);
516 matchControlTag(pVM, colonTag);
519 assert(pVM->pSys->pUnLinkParen);
520 if (pVM->pSys->nLocals > 0)
522 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
523 dictEmpty(pLoc, pLoc->pForthWords->size);
524 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
526 pVM->pSys->nLocals = 0;
529 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
530 pVM->state = INTERPRET;
536 /**************************************************************************
539 ** This function simply pops the previous instruction
540 ** pointer and returns to the "next" loop. Used for exiting from within
541 ** a definition. Note that exitParen is identical to semiParen - they
542 ** are in two different functions so that "see" can correctly identify
543 ** the end of a colon definition, even if it uses "exit".
544 **************************************************************************/
545 static void exitParen(FICL_VM *pVM)
551 static void exitCoIm(FICL_VM *pVM)
553 FICL_DICT *dp = vmGetDict(pVM);
554 assert(pVM->pSys->pExitParen);
558 if (pVM->pSys->nLocals > 0)
560 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
563 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
568 /**************************************************************************
569 c o n s t a n t P a r e n
570 ** This is the run-time code for "constant". It simply returns the
571 ** contents of its word's first data cell.
573 **************************************************************************/
575 void constantParen(FICL_VM *pVM)
577 FICL_WORD *pFW = pVM->runningWord;
579 vmCheckStack(pVM, 0, 1);
581 stackPush(pVM->pStack, pFW->param[0]);
585 void twoConstParen(FICL_VM *pVM)
587 FICL_WORD *pFW = pVM->runningWord;
589 vmCheckStack(pVM, 0, 2);
591 stackPush(pVM->pStack, pFW->param[0]); /* lo */
592 stackPush(pVM->pStack, pFW->param[1]); /* hi */
597 /**************************************************************************
600 ** Compiles a constant into the dictionary. Constants return their
601 ** value when invoked. Expects a value on top of the parm stack.
602 **************************************************************************/
604 static void constant(FICL_VM *pVM)
606 FICL_DICT *dp = vmGetDict(pVM);
607 STRINGINFO si = vmGetWord(pVM);
610 vmCheckStack(pVM, 1, 0);
612 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
613 dictAppendCell(dp, stackPop(pVM->pStack));
618 static void twoConstant(FICL_VM *pVM)
620 FICL_DICT *dp = vmGetDict(pVM);
621 STRINGINFO si = vmGetWord(pVM);
625 vmCheckStack(pVM, 2, 0);
627 c = stackPop(pVM->pStack);
628 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
629 dictAppendCell(dp, stackPop(pVM->pStack));
630 dictAppendCell(dp, c);
635 /**************************************************************************
636 d i s p l a y C e l l
637 ** Drop and print the contents of the cell at the top of the param
639 **************************************************************************/
641 static void displayCell(FICL_VM *pVM)
645 vmCheckStack(pVM, 1, 0);
647 c = stackPop(pVM->pStack);
648 ltoa((c).i, pVM->pad, pVM->base);
649 strcat(pVM->pad, " ");
650 vmTextOut(pVM, pVM->pad, 0);
654 static void uDot(FICL_VM *pVM)
658 vmCheckStack(pVM, 1, 0);
660 u = stackPopUNS(pVM->pStack);
661 ultoa(u, pVM->pad, pVM->base);
662 strcat(pVM->pad, " ");
663 vmTextOut(pVM, pVM->pad, 0);
668 static void hexDot(FICL_VM *pVM)
672 vmCheckStack(pVM, 1, 0);
674 u = stackPopUNS(pVM->pStack);
675 ultoa(u, pVM->pad, 16);
676 strcat(pVM->pad, " ");
677 vmTextOut(pVM, pVM->pad, 0);
682 /**************************************************************************
684 ** FICL ( c-string -- length )
686 ** Returns the length of a C-style (zero-terminated) string.
690 static void ficlStrlen(FICL_VM *ficlVM)
692 char *address = (char *)stackPopPtr(ficlVM->pStack);
693 stackPushINT(ficlVM->pStack, strlen(address));
697 /**************************************************************************
699 ** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
700 ** Similar to the C sprintf() function. It formats into a buffer based on
701 ** a "format" string. Each character in the format string is copied verbatim
702 ** to the output buffer, until SPRINTF encounters a percent sign ("%").
703 ** SPRINTF then skips the percent sign, and examines the next character
704 ** (the "format character"). Here are the valid format characters:
705 ** s - read a C-ADDR U-LENGTH string from the stack and copy it to
707 ** d - read a cell from the stack, format it as a string (base-10,
708 ** signed), and copy it to the buffer
709 ** x - same as d, except in base-16
710 ** u - same as d, but unsigned
711 ** % - output a literal percent-sign to the buffer
712 ** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
713 ** written, and a flag indicating whether or not it ran out of space while
714 ** writing to the output buffer (TRUE if it ran out of space).
716 ** If SPRINTF runs out of space in the buffer to store the formatted string,
717 ** it still continues parsing, in an effort to preserve your stack (otherwise
718 ** it might leave uneaten arguments behind).
721 **************************************************************************/
722 static void ficlSprintf(FICL_VM *pVM) /* */
724 int bufferLength = stackPopINT(pVM->pStack);
725 char *buffer = (char *)stackPopPtr(pVM->pStack);
726 char *bufferStart = buffer;
728 int formatLength = stackPopINT(pVM->pStack);
729 char *format = (char *)stackPopPtr(pVM->pStack);
730 char *formatStop = format + formatLength;
733 int unsignedInteger = FALSE;
735 int append = FICL_TRUE;
737 while (format < formatStop)
749 actualLength = desiredLength = 1;
755 if (format == formatStop)
758 leadingZeroes = (*format == '0');
762 if (format == formatStop)
766 desiredLength = isdigit(*format);
769 desiredLength = strtol(format, &format, 10);
770 if (format == formatStop)
773 else if (*format == '*')
775 desiredLength = stackPopINT(pVM->pStack);
777 if (format == formatStop)
787 actualLength = stackPopINT(pVM->pStack);
788 source = (char *)stackPopPtr(pVM->pStack);
796 unsignedInteger = TRUE;
800 int integer = stackPopINT(pVM->pStack);
802 ultoa(integer, scratch, base);
804 ltoa(integer, scratch, base);
806 unsignedInteger = FALSE;
808 actualLength = strlen(scratch);
819 if (append == FICL_TRUE)
822 desiredLength = actualLength;
823 if (desiredLength > bufferLength)
826 desiredLength = bufferLength;
828 while (desiredLength > actualLength)
830 *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
834 memcpy(buffer, source, actualLength);
835 buffer += actualLength;
836 bufferLength -= actualLength;
842 stackPushPtr(pVM->pStack, bufferStart);
843 stackPushINT(pVM->pStack, buffer - bufferStart);
844 stackPushINT(pVM->pStack, append);
848 /**************************************************************************
849 d u p & f r i e n d s
851 **************************************************************************/
853 static void depth(FICL_VM *pVM)
857 vmCheckStack(pVM, 0, 1);
859 i = stackDepth(pVM->pStack);
865 static void drop(FICL_VM *pVM)
868 vmCheckStack(pVM, 1, 0);
870 stackDrop(pVM->pStack, 1);
875 static void twoDrop(FICL_VM *pVM)
878 vmCheckStack(pVM, 2, 0);
880 stackDrop(pVM->pStack, 2);
885 static void dup(FICL_VM *pVM)
888 vmCheckStack(pVM, 1, 2);
890 stackPick(pVM->pStack, 0);
895 static void twoDup(FICL_VM *pVM)
898 vmCheckStack(pVM, 2, 4);
900 stackPick(pVM->pStack, 1);
901 stackPick(pVM->pStack, 1);
906 static void over(FICL_VM *pVM)
909 vmCheckStack(pVM, 2, 3);
911 stackPick(pVM->pStack, 1);
915 static void twoOver(FICL_VM *pVM)
918 vmCheckStack(pVM, 4, 6);
920 stackPick(pVM->pStack, 3);
921 stackPick(pVM->pStack, 3);
926 static void pick(FICL_VM *pVM)
928 CELL c = stackPop(pVM->pStack);
930 vmCheckStack(pVM, c.i+1, c.i+2);
932 stackPick(pVM->pStack, c.i);
937 static void questionDup(FICL_VM *pVM)
941 vmCheckStack(pVM, 1, 2);
943 c = stackGetTop(pVM->pStack);
946 stackPick(pVM->pStack, 0);
952 static void roll(FICL_VM *pVM)
954 int i = stackPop(pVM->pStack).i;
957 vmCheckStack(pVM, i+1, i+1);
959 stackRoll(pVM->pStack, i);
964 static void minusRoll(FICL_VM *pVM)
966 int i = stackPop(pVM->pStack).i;
969 vmCheckStack(pVM, i+1, i+1);
971 stackRoll(pVM->pStack, -i);
976 static void rot(FICL_VM *pVM)
979 vmCheckStack(pVM, 3, 3);
981 stackRoll(pVM->pStack, 2);
986 static void swap(FICL_VM *pVM)
989 vmCheckStack(pVM, 2, 2);
991 stackRoll(pVM->pStack, 1);
996 static void twoSwap(FICL_VM *pVM)
999 vmCheckStack(pVM, 4, 4);
1001 stackRoll(pVM->pStack, 3);
1002 stackRoll(pVM->pStack, 3);
1007 /**************************************************************************
1008 e m i t & f r i e n d s
1010 **************************************************************************/
1012 static void emit(FICL_VM *pVM)
1014 char *cp = pVM->pad;
1018 vmCheckStack(pVM, 1, 0);
1020 i = stackPopINT(pVM->pStack);
1023 vmTextOut(pVM, cp, 0);
1028 static void cr(FICL_VM *pVM)
1030 vmTextOut(pVM, "", 1);
1035 static void commentLine(FICL_VM *pVM)
1037 char *cp = vmGetInBuf(pVM);
1038 char *pEnd = vmGetInBufEnd(pVM);
1041 while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
1047 ** Cope with DOS or UNIX-style EOLs -
1048 ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
1049 ** and point cp to next char. If EOL is \0, we're done.
1055 if ( (cp != pEnd) && (ch != *cp)
1056 && ((*cp == '\r') || (*cp == '\n')) )
1060 vmUpdateTib(pVM, cp);
1067 ** Compilation: Perform the execution semantics given below.
1068 ** Execution: ( "ccc<paren>" -- )
1069 ** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
1070 ** The number of characters in ccc may be zero to the number of characters
1071 ** in the parse area.
1074 static void commentHang(FICL_VM *pVM)
1076 vmParseStringEx(pVM, ')', 0);
1081 /**************************************************************************
1082 F E T C H & S T O R E
1084 **************************************************************************/
1086 static void fetch(FICL_VM *pVM)
1090 vmCheckStack(pVM, 1, 1);
1092 pCell = (CELL *)stackPopPtr(pVM->pStack);
1093 stackPush(pVM->pStack, *pCell);
1098 ** two-fetch CORE ( a-addr -- x1 x2 )
1099 ** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
1100 ** x1 at the next consecutive cell. It is equivalent to the sequence
1101 ** DUP CELL+ @ SWAP @ .
1103 static void twoFetch(FICL_VM *pVM)
1107 vmCheckStack(pVM, 1, 2);
1109 pCell = (CELL *)stackPopPtr(pVM->pStack);
1110 stackPush(pVM->pStack, *pCell++);
1111 stackPush(pVM->pStack, *pCell);
1117 ** store CORE ( x a-addr -- )
1118 ** Store x at a-addr.
1120 static void store(FICL_VM *pVM)
1124 vmCheckStack(pVM, 2, 0);
1126 pCell = (CELL *)stackPopPtr(pVM->pStack);
1127 *pCell = stackPop(pVM->pStack);
1131 ** two-store CORE ( x1 x2 a-addr -- )
1132 ** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
1133 ** next consecutive cell. It is equivalent to the sequence
1134 ** SWAP OVER ! CELL+ ! .
1136 static void twoStore(FICL_VM *pVM)
1140 vmCheckStack(pVM, 3, 0);
1142 pCell = (CELL *)stackPopPtr(pVM->pStack);
1143 *pCell++ = stackPop(pVM->pStack);
1144 *pCell = stackPop(pVM->pStack);
1147 static void plusStore(FICL_VM *pVM)
1151 vmCheckStack(pVM, 2, 0);
1153 pCell = (CELL *)stackPopPtr(pVM->pStack);
1154 pCell->i += stackPop(pVM->pStack).i;
1158 static void quadFetch(FICL_VM *pVM)
1162 vmCheckStack(pVM, 1, 1);
1164 pw = (UNS32 *)stackPopPtr(pVM->pStack);
1165 PUSHUNS((FICL_UNS)*pw);
1169 static void quadStore(FICL_VM *pVM)
1173 vmCheckStack(pVM, 2, 0);
1175 pw = (UNS32 *)stackPopPtr(pVM->pStack);
1176 *pw = (UNS32)(stackPop(pVM->pStack).u);
1179 static void wFetch(FICL_VM *pVM)
1183 vmCheckStack(pVM, 1, 1);
1185 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1186 PUSHUNS((FICL_UNS)*pw);
1190 static void wStore(FICL_VM *pVM)
1194 vmCheckStack(pVM, 2, 0);
1196 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1197 *pw = (UNS16)(stackPop(pVM->pStack).u);
1200 static void cFetch(FICL_VM *pVM)
1204 vmCheckStack(pVM, 1, 1);
1206 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1207 PUSHUNS((FICL_UNS)*pc);
1211 static void cStore(FICL_VM *pVM)
1215 vmCheckStack(pVM, 2, 0);
1217 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1218 *pc = (UNS8)(stackPop(pVM->pStack).u);
1222 /**************************************************************************
1225 ** Compiles code for a conditional branch into the dictionary
1226 ** and pushes the branch patch address on the stack for later
1227 ** patching by ELSE or THEN/ENDIF.
1228 **************************************************************************/
1230 static void ifCoIm(FICL_VM *pVM)
1232 FICL_DICT *dp = vmGetDict(pVM);
1234 assert(pVM->pSys->pIfParen);
1236 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
1237 markBranch(dp, pVM, origTag);
1238 dictAppendUNS(dp, 1);
1243 /**************************************************************************
1245 ** Runtime code to do "if" or "until": pop a flag from the stack,
1246 ** fall through if true, branch if false. Probably ought to be
1247 ** called (not?branch) since it does "branch if false".
1248 **************************************************************************/
1250 static void ifParen(FICL_VM *pVM)
1255 vmCheckStack(pVM, 1, 0);
1257 flag = stackPopUNS(pVM->pStack);
1260 { /* fall through */
1261 vmBranchRelative(pVM, 1);
1264 { /* take branch (to else/endif/begin) */
1265 vmBranchRelative(pVM, *(int *)(pVM->ip));
1272 /**************************************************************************
1275 ** IMMEDIATE -- compiles an "else"...
1276 ** 1) Compile a branch and a patch address; the address gets patched
1277 ** by "endif" to point past the "else" code.
1278 ** 2) Pop the the "if" patch address
1279 ** 3) Patch the "if" branch to point to the current compile address.
1280 ** 4) Push the "else" patch address. ("endif" patches this to jump past
1282 **************************************************************************/
1284 static void elseCoIm(FICL_VM *pVM)
1288 FICL_DICT *dp = vmGetDict(pVM);
1290 assert(pVM->pSys->pBranchParen);
1291 /* (1) compile branch runtime */
1292 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1293 matchControlTag(pVM, origTag);
1295 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1296 markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
1297 dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
1298 offset = dp->here - patchAddr;
1299 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1305 /**************************************************************************
1306 b r a n c h P a r e n
1308 ** Runtime for "(branch)" -- expects a literal offset in the next
1309 ** compilation address, and branches to that location.
1310 **************************************************************************/
1312 static void branchParen(FICL_VM *pVM)
1314 vmBranchRelative(pVM, *(int *)(pVM->ip));
1319 /**************************************************************************
1322 **************************************************************************/
1324 static void endifCoIm(FICL_VM *pVM)
1326 FICL_DICT *dp = vmGetDict(pVM);
1327 resolveForwardBranch(dp, pVM, origTag);
1332 /**************************************************************************
1334 ** hash ( c-addr u -- code)
1335 ** calculates hashcode of specified string and leaves it on the stack
1336 **************************************************************************/
1338 static void hash(FICL_VM *pVM)
1341 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1342 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1343 PUSHUNS(hashHashCode(si));
1348 /**************************************************************************
1350 ** This is the "user interface" of a Forth. It does the following:
1351 ** while there are words in the VM's Text Input Buffer
1352 ** Copy next word into the pad (vmGetWord)
1353 ** Attempt to find the word in the dictionary (dictLookup)
1354 ** If successful, execute the word.
1355 ** Otherwise, attempt to convert the word to a number (isNumber)
1356 ** If successful, push the number onto the parameter stack.
1357 ** Otherwise, print an error message and exit loop...
1360 ** From the standard, section 3.4
1361 ** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1362 ** repeat the following steps until either the parse area is empty or an
1363 ** ambiguous condition exists:
1364 ** a) Skip leading spaces and parse a name (see 3.4.1);
1365 **************************************************************************/
1367 static void interpret(FICL_VM *pVM)
1376 si = vmGetWord0(pVM);
1379 ** Get next word...if out of text, we're done.
1383 vmThrow(pVM, VM_OUTOFTEXT);
1387 ** Attempt to find the incoming token in the dictionary. If that fails...
1388 ** run the parse chain against the incoming token until somebody eats it.
1389 ** Otherwise emit an error message and give up.
1390 ** Although ficlParseWord could be part of the parse list, I've hard coded it
1391 ** in for robustness. ficlInitSystem adds the other default steps to the list.
1393 if (ficlParseWord(pVM, si))
1396 for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1398 FICL_WORD *pFW = pSys->parseList[i];
1403 if (pFW->code == parseStepParen)
1405 FICL_PARSE_STEP pStep;
1406 pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1407 if ((*pStep)(pVM, si))
1412 stackPushPtr(pVM->pStack, SI_PTR(si));
1413 stackPushUNS(pVM->pStack, SI_COUNT(si));
1414 ficlExecXT(pVM, pFW);
1415 if (stackPopINT(pVM->pStack))
1421 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1423 return; /* back to inner interpreter */
1427 /**************************************************************************
1428 f i c l P a r s e W o r d
1429 ** From the standard, section 3.4
1430 ** b) Search the dictionary name space (see 3.4.2). If a definition name
1431 ** matching the string is found:
1432 ** 1.if interpreting, perform the interpretation semantics of the definition
1433 ** (see 3.4.3.2), and continue at a);
1434 ** 2.if compiling, perform the compilation semantics of the definition
1435 ** (see 3.4.3.3), and continue at a).
1437 ** c) If a definition name matching the string is not found, attempt to
1438 ** convert the string to a number (see 3.4.1.3). If successful:
1439 ** 1.if interpreting, place the number on the data stack, and continue at a);
1440 ** 2.if compiling, compile code that when executed will place the number on
1441 ** the stack (see 6.1.1780 LITERAL), and continue at a);
1443 ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1445 ** (jws 4/01) Modified to be a FICL_PARSE_STEP
1446 **************************************************************************/
1447 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1449 FICL_DICT *dp = vmGetDict(pVM);
1453 dictCheck(dp, pVM, 0);
1454 vmCheckStack(pVM, 0, 0);
1457 #if FICL_WANT_LOCALS
1458 if (pVM->pSys->nLocals > 0)
1460 tempFW = ficlLookupLoc(pVM->pSys, si);
1464 tempFW = dictLookup(dp, si);
1466 if (pVM->state == INTERPRET)
1470 if (wordIsCompileOnly(tempFW))
1472 vmThrowErr(pVM, "Error: Compile only!");
1475 vmExecute(pVM, tempFW);
1480 else /* (pVM->state == COMPILE) */
1484 if (wordIsImmediate(tempFW))
1486 vmExecute(pVM, tempFW);
1490 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1501 ** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
1504 static void lookup(FICL_VM *pVM)
1507 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1508 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1509 stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
1514 /**************************************************************************
1515 p a r e n P a r s e S t e p
1516 ** (parse-step) ( c-addr u -- flag )
1517 ** runtime for a precompiled parse step - pop a counted string off the
1518 ** stack, run the parse step against it, and push the result flag (FICL_TRUE
1519 ** if success, FICL_FALSE otherwise).
1520 **************************************************************************/
1522 void parseStepParen(FICL_VM *pVM)
1525 FICL_WORD *pFW = pVM->runningWord;
1526 FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1528 SI_SETLEN(si, stackPopINT(pVM->pStack));
1529 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1531 PUSHINT((*pStep)(pVM, si));
1537 static void addParseStep(FICL_VM *pVM)
1540 FICL_DICT *pd = vmGetDict(pVM);
1542 vmCheckStack(pVM, 1, 0);
1544 pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1545 if ((pStep != NULL) && isAFiclWord(pd, pStep))
1546 ficlAddParseStep(pVM->pSys, pStep);
1551 /**************************************************************************
1552 l i t e r a l P a r e n
1554 ** This is the runtime for (literal). It assumes that it is part of a colon
1555 ** definition, and that the next CELL contains a value to be pushed on the
1556 ** parameter stack at runtime. This code is compiled by "literal".
1558 **************************************************************************/
1560 static void literalParen(FICL_VM *pVM)
1563 vmCheckStack(pVM, 0, 1);
1565 PUSHINT(*(FICL_INT *)(pVM->ip));
1566 vmBranchRelative(pVM, 1);
1570 static void twoLitParen(FICL_VM *pVM)
1573 vmCheckStack(pVM, 0, 2);
1575 PUSHINT(*((FICL_INT *)(pVM->ip)+1));
1576 PUSHINT(*(FICL_INT *)(pVM->ip));
1577 vmBranchRelative(pVM, 2);
1582 /**************************************************************************
1585 ** IMMEDIATE code for "literal". This function gets a value from the stack
1586 ** and compiles it into the dictionary preceded by the code for "(literal)".
1588 **************************************************************************/
1590 static void literalIm(FICL_VM *pVM)
1592 FICL_DICT *dp = vmGetDict(pVM);
1593 assert(pVM->pSys->pLitParen);
1595 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
1596 dictAppendCell(dp, stackPop(pVM->pStack));
1602 static void twoLiteralIm(FICL_VM *pVM)
1604 FICL_DICT *dp = vmGetDict(pVM);
1605 assert(pVM->pSys->pTwoLitParen);
1607 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
1608 dictAppendCell(dp, stackPop(pVM->pStack));
1609 dictAppendCell(dp, stackPop(pVM->pStack));
1614 /**************************************************************************
1615 l o g i c a n d c o m p a r i s o n s
1617 **************************************************************************/
1619 static void zeroEquals(FICL_VM *pVM)
1623 vmCheckStack(pVM, 1, 1);
1625 c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
1626 stackPush(pVM->pStack, c);
1630 static void zeroLess(FICL_VM *pVM)
1634 vmCheckStack(pVM, 1, 1);
1636 c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
1637 stackPush(pVM->pStack, c);
1641 static void zeroGreater(FICL_VM *pVM)
1645 vmCheckStack(pVM, 1, 1);
1647 c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
1648 stackPush(pVM->pStack, c);
1652 static void isEqual(FICL_VM *pVM)
1657 vmCheckStack(pVM, 2, 1);
1659 x = stackPop(pVM->pStack);
1660 y = stackPop(pVM->pStack);
1661 PUSHINT(FICL_BOOL(x.i == y.i));
1665 static void isLess(FICL_VM *pVM)
1669 vmCheckStack(pVM, 2, 1);
1671 y = stackPop(pVM->pStack);
1672 x = stackPop(pVM->pStack);
1673 PUSHINT(FICL_BOOL(x.i < y.i));
1677 static void uIsLess(FICL_VM *pVM)
1681 vmCheckStack(pVM, 2, 1);
1683 u2 = stackPopUNS(pVM->pStack);
1684 u1 = stackPopUNS(pVM->pStack);
1685 PUSHINT(FICL_BOOL(u1 < u2));
1689 static void isGreater(FICL_VM *pVM)
1693 vmCheckStack(pVM, 2, 1);
1695 y = stackPop(pVM->pStack);
1696 x = stackPop(pVM->pStack);
1697 PUSHINT(FICL_BOOL(x.i > y.i));
1701 static void bitwiseAnd(FICL_VM *pVM)
1705 vmCheckStack(pVM, 2, 1);
1707 x = stackPop(pVM->pStack);
1708 y = stackPop(pVM->pStack);
1713 static void bitwiseOr(FICL_VM *pVM)
1717 vmCheckStack(pVM, 2, 1);
1719 x = stackPop(pVM->pStack);
1720 y = stackPop(pVM->pStack);
1725 static void bitwiseXor(FICL_VM *pVM)
1729 vmCheckStack(pVM, 2, 1);
1731 x = stackPop(pVM->pStack);
1732 y = stackPop(pVM->pStack);
1737 static void bitwiseNot(FICL_VM *pVM)
1741 vmCheckStack(pVM, 1, 1);
1743 x = stackPop(pVM->pStack);
1749 /**************************************************************************
1751 ** do -- IMMEDIATE COMPILE ONLY
1752 ** Compiles code to initialize a loop: compile (do),
1753 ** allot space to hold the "leave" address, push a branch
1754 ** target address for the loop.
1755 ** (do) -- runtime for "do"
1756 ** pops index and limit from the p stack and moves them
1757 ** to the r stack, then skips to the loop body.
1758 ** loop -- IMMEDIATE COMPILE ONLY
1760 ** Compiles code for the test part of a loop:
1761 ** compile (loop), resolve forward branch from "do", and
1762 ** copy "here" address to the "leave" address allotted by "do"
1763 ** i,j,k -- COMPILE ONLY
1764 ** Runtime: Push loop indices on param stack (i is innermost loop...)
1765 ** Note: each loop has three values on the return stack:
1766 ** ( R: leave limit index )
1767 ** "leave" is the absolute address of the next cell after the loop
1768 ** limit and index are the loop control variables.
1769 ** leave -- COMPILE ONLY
1770 ** Runtime: pop the loop control variables, then pop the
1771 ** "leave" address and jump (absolute) there.
1772 **************************************************************************/
1774 static void doCoIm(FICL_VM *pVM)
1776 FICL_DICT *dp = vmGetDict(pVM);
1778 assert(pVM->pSys->pDoParen);
1780 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
1782 ** Allot space for a pointer to the end
1783 ** of the loop - "leave" uses this...
1785 markBranch(dp, pVM, leaveTag);
1786 dictAppendUNS(dp, 0);
1788 ** Mark location of head of loop...
1790 markBranch(dp, pVM, doTag);
1796 static void doParen(FICL_VM *pVM)
1800 vmCheckStack(pVM, 2, 0);
1802 index = stackPop(pVM->pStack);
1803 limit = stackPop(pVM->pStack);
1805 /* copy "leave" target addr to stack */
1806 stackPushPtr(pVM->rStack, *(pVM->ip++));
1807 stackPush(pVM->rStack, limit);
1808 stackPush(pVM->rStack, index);
1814 static void qDoCoIm(FICL_VM *pVM)
1816 FICL_DICT *dp = vmGetDict(pVM);
1818 assert(pVM->pSys->pQDoParen);
1820 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
1822 ** Allot space for a pointer to the end
1823 ** of the loop - "leave" uses this...
1825 markBranch(dp, pVM, leaveTag);
1826 dictAppendUNS(dp, 0);
1828 ** Mark location of head of loop...
1830 markBranch(dp, pVM, doTag);
1836 static void qDoParen(FICL_VM *pVM)
1840 vmCheckStack(pVM, 2, 0);
1842 index = stackPop(pVM->pStack);
1843 limit = stackPop(pVM->pStack);
1845 /* copy "leave" target addr to stack */
1846 stackPushPtr(pVM->rStack, *(pVM->ip++));
1848 if (limit.u == index.u)
1854 stackPush(pVM->rStack, limit);
1855 stackPush(pVM->rStack, index);
1863 ** Runtime code to break out of a do..loop construct
1864 ** Drop the loop control variables; the branch address
1865 ** past "loop" is next on the return stack.
1867 static void leaveCo(FICL_VM *pVM)
1870 stackDrop(pVM->rStack, 2);
1877 static void unloopCo(FICL_VM *pVM)
1879 stackDrop(pVM->rStack, 3);
1884 static void loopCoIm(FICL_VM *pVM)
1886 FICL_DICT *dp = vmGetDict(pVM);
1888 assert(pVM->pSys->pLoopParen);
1890 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
1891 resolveBackBranch(dp, pVM, doTag);
1892 resolveAbsBranch(dp, pVM, leaveTag);
1897 static void plusLoopCoIm(FICL_VM *pVM)
1899 FICL_DICT *dp = vmGetDict(pVM);
1901 assert(pVM->pSys->pPLoopParen);
1903 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
1904 resolveBackBranch(dp, pVM, doTag);
1905 resolveAbsBranch(dp, pVM, leaveTag);
1910 static void loopParen(FICL_VM *pVM)
1912 FICL_INT index = stackGetTop(pVM->rStack).i;
1913 FICL_INT limit = stackFetch(pVM->rStack, 1).i;
1919 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1920 vmBranchRelative(pVM, 1); /* fall through the loop */
1923 { /* update index, branch to loop head */
1924 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1925 vmBranchRelative(pVM, *(int *)(pVM->ip));
1932 static void plusLoopParen(FICL_VM *pVM)
1934 FICL_INT index,limit,increment;
1938 vmCheckStack(pVM, 1, 0);
1941 index = stackGetTop(pVM->rStack).i;
1942 limit = stackFetch(pVM->rStack, 1).i;
1943 increment = POP().i;
1948 flag = (index < limit);
1950 flag = (index >= limit);
1954 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1955 vmBranchRelative(pVM, 1); /* fall through the loop */
1958 { /* update index, branch to loop head */
1959 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1960 vmBranchRelative(pVM, *(int *)(pVM->ip));
1967 static void loopICo(FICL_VM *pVM)
1969 CELL index = stackGetTop(pVM->rStack);
1970 stackPush(pVM->pStack, index);
1976 static void loopJCo(FICL_VM *pVM)
1978 CELL index = stackFetch(pVM->rStack, 3);
1979 stackPush(pVM->pStack, index);
1985 static void loopKCo(FICL_VM *pVM)
1987 CELL index = stackFetch(pVM->rStack, 6);
1988 stackPush(pVM->pStack, index);
1994 /**************************************************************************
1995 r e t u r n s t a c k
1997 **************************************************************************/
1998 static void toRStack(FICL_VM *pVM)
2001 vmCheckStack(pVM, 1, 0);
2004 stackPush(pVM->rStack, POP());
2007 static void fromRStack(FICL_VM *pVM)
2010 vmCheckStack(pVM, 0, 1);
2013 PUSH(stackPop(pVM->rStack));
2016 static void fetchRStack(FICL_VM *pVM)
2019 vmCheckStack(pVM, 0, 1);
2022 PUSH(stackGetTop(pVM->rStack));
2025 static void twoToR(FICL_VM *pVM)
2028 vmCheckStack(pVM, 2, 0);
2030 stackRoll(pVM->pStack, 1);
2031 stackPush(pVM->rStack, stackPop(pVM->pStack));
2032 stackPush(pVM->rStack, stackPop(pVM->pStack));
2036 static void twoRFrom(FICL_VM *pVM)
2039 vmCheckStack(pVM, 0, 2);
2041 stackPush(pVM->pStack, stackPop(pVM->rStack));
2042 stackPush(pVM->pStack, stackPop(pVM->rStack));
2043 stackRoll(pVM->pStack, 1);
2047 static void twoRFetch(FICL_VM *pVM)
2050 vmCheckStack(pVM, 0, 2);
2052 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2053 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2058 /**************************************************************************
2061 **************************************************************************/
2063 static void variableParen(FICL_VM *pVM)
2067 vmCheckStack(pVM, 0, 1);
2070 fw = pVM->runningWord;
2075 static void variable(FICL_VM *pVM)
2077 FICL_DICT *dp = vmGetDict(pVM);
2078 STRINGINFO si = vmGetWord(pVM);
2080 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2081 dictAllotCells(dp, 1);
2086 static void twoVariable(FICL_VM *pVM)
2088 FICL_DICT *dp = vmGetDict(pVM);
2089 STRINGINFO si = vmGetWord(pVM);
2091 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2092 dictAllotCells(dp, 2);
2097 /**************************************************************************
2098 b a s e & f r i e n d s
2100 **************************************************************************/
2102 static void base(FICL_VM *pVM)
2106 vmCheckStack(pVM, 0, 1);
2109 pBase = (CELL *)(&pVM->base);
2110 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2115 static void decimal(FICL_VM *pVM)
2122 static void hex(FICL_VM *pVM)
2129 /**************************************************************************
2130 a l l o t & f r i e n d s
2132 **************************************************************************/
2134 static void allot(FICL_VM *pVM)
2139 vmCheckStack(pVM, 1, 0);
2142 dp = vmGetDict(pVM);
2146 dictCheck(dp, pVM, i);
2154 static void here(FICL_VM *pVM)
2158 vmCheckStack(pVM, 0, 1);
2161 dp = vmGetDict(pVM);
2166 static void comma(FICL_VM *pVM)
2171 vmCheckStack(pVM, 1, 0);
2174 dp = vmGetDict(pVM);
2176 dictAppendCell(dp, c);
2180 static void cComma(FICL_VM *pVM)
2185 vmCheckStack(pVM, 1, 0);
2188 dp = vmGetDict(pVM);
2190 dictAppendChar(dp, c);
2194 static void cells(FICL_VM *pVM)
2198 vmCheckStack(pVM, 1, 1);
2202 PUSHINT(i * (FICL_INT)sizeof (CELL));
2206 static void cellPlus(FICL_VM *pVM)
2210 vmCheckStack(pVM, 1, 1);
2214 PUSHPTR(cp + sizeof (CELL));
2220 /**************************************************************************
2222 ** tick CORE ( "<spaces>name" -- xt )
2223 ** Skip leading space delimiters. Parse name delimited by a space. Find
2224 ** name and return xt, the execution token for name. An ambiguous condition
2225 ** exists if name is not found.
2226 **************************************************************************/
2227 void ficlTick(FICL_VM *pVM)
2229 FICL_WORD *pFW = NULL;
2230 STRINGINFO si = vmGetWord(pVM);
2232 vmCheckStack(pVM, 0, 1);
2235 pFW = dictLookup(vmGetDict(pVM), si);
2238 int i = SI_COUNT(si);
2239 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2246 static void bracketTickCoIm(FICL_VM *pVM)
2255 /**************************************************************************
2257 ** Lookup the next word in the input stream and compile code to
2258 ** insert it into definitions created by the resulting word
2259 ** (defers compilation, even of immediate words)
2260 **************************************************************************/
2262 static void postponeCoIm(FICL_VM *pVM)
2264 FICL_DICT *dp = vmGetDict(pVM);
2266 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2270 pFW = stackGetTop(pVM->pStack).p;
2271 if (wordIsImmediate(pFW))
2273 dictAppendCell(dp, stackPop(pVM->pStack));
2278 dictAppendCell(dp, LVALUEtoCELL(pComma));
2286 /**************************************************************************
2288 ** Pop an execution token (pointer to a word) off the stack and
2290 **************************************************************************/
2292 static void execute(FICL_VM *pVM)
2296 vmCheckStack(pVM, 1, 0);
2299 pFW = stackPopPtr(pVM->pStack);
2300 vmExecute(pVM, pFW);
2306 /**************************************************************************
2308 ** Make the most recently compiled word IMMEDIATE -- it executes even
2309 ** in compile state (most often used for control compiling words
2310 ** such as IF, THEN, etc)
2311 **************************************************************************/
2313 static void immediate(FICL_VM *pVM)
2316 dictSetImmediate(vmGetDict(pVM));
2321 static void compileOnly(FICL_VM *pVM)
2324 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2329 static void setObjectFlag(FICL_VM *pVM)
2332 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2336 static void isObject(FICL_VM *pVM)
2339 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2341 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2342 stackPushINT(pVM->pStack, flag);
2346 static void cstringLit(FICL_VM *pVM)
2348 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2350 char *cp = sp->text;
2351 cp += sp->count + 1;
2353 pVM->ip = (IPTYPE)(void *)cp;
2355 stackPushPtr(pVM->pStack, sp);
2360 static void cstringQuoteIm(FICL_VM *pVM)
2362 FICL_DICT *dp = vmGetDict(pVM);
2364 if (pVM->state == INTERPRET)
2366 FICL_STRING *sp = (FICL_STRING *) dp->here;
2367 vmGetString(pVM, sp, '\"');
2368 stackPushPtr(pVM->pStack, sp);
2369 /* move HERE past string so it doesn't get overwritten. --lch */
2370 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2372 else /* COMPILE state */
2374 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2375 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2382 /**************************************************************************
2384 ** IMMEDIATE word that compiles a string literal for later display
2385 ** Compile stringLit, then copy the bytes of the string from the TIB
2386 ** to the dictionary. Backpatch the count byte and align the dictionary.
2388 ** stringlit: Fetch the count from the dictionary, then push the address
2389 ** and count on the stack. Finally, update ip to point to the first
2390 ** aligned address after the string text.
2391 **************************************************************************/
2393 static void stringLit(FICL_VM *pVM)
2399 vmCheckStack(pVM, 0, 2);
2402 sp = (FICL_STRING *)(pVM->ip);
2409 pVM->ip = (IPTYPE)(void *)cp;
2412 static void dotQuoteCoIm(FICL_VM *pVM)
2414 FICL_DICT *dp = vmGetDict(pVM);
2415 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2417 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2418 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2420 dictAppendCell(dp, LVALUEtoCELL(pType));
2425 static void dotParen(FICL_VM *pVM)
2427 char *pSrc = vmGetInBuf(pVM);
2428 char *pEnd = vmGetInBufEnd(pVM);
2429 char *pDest = pVM->pad;
2433 ** Note: the standard does not want leading spaces skipped (apparently)
2435 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2439 if ((pEnd != pSrc) && (ch == ')'))
2442 vmTextOut(pVM, pVM->pad, 0);
2443 vmUpdateTib(pVM, pSrc);
2449 /**************************************************************************
2452 ** Interpretation: Interpretation semantics for this word are undefined.
2453 ** Compilation: ( c-addr1 u -- )
2454 ** Append the run-time semantics given below to the current definition.
2455 ** Run-time: ( -- c-addr2 u )
2456 ** Return c-addr2 u describing a string consisting of the characters
2457 ** specified by c-addr1 u during compilation. A program shall not alter
2458 ** the returned string.
2459 **************************************************************************/
2460 static void sLiteralCoIm(FICL_VM *pVM)
2467 vmCheckStack(pVM, 2, 0);
2470 dp = vmGetDict(pVM);
2474 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2475 cpDest = (char *) dp->here;
2476 *cpDest++ = (char) u;
2484 dp->here = PTRtoCELL alignPtr(cpDest);
2489 /**************************************************************************
2491 ** Return the address of the VM's state member (must be sized the
2492 ** same as a CELL for this reason)
2493 **************************************************************************/
2494 static void state(FICL_VM *pVM)
2497 vmCheckStack(pVM, 0, 1);
2499 PUSHPTR(&pVM->state);
2504 /**************************************************************************
2505 c r e a t e . . . d o e s >
2506 ** Make a new word in the dictionary with the run-time effect of
2507 ** a variable (push my address), but with extra space allotted
2508 ** for use by does> .
2509 **************************************************************************/
2511 static void createParen(FICL_VM *pVM)
2516 vmCheckStack(pVM, 0, 1);
2519 pCell = pVM->runningWord->param;
2525 static void create(FICL_VM *pVM)
2527 FICL_DICT *dp = vmGetDict(pVM);
2528 STRINGINFO si = vmGetWord(pVM);
2530 dictCheckThreshold(dp);
2532 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2533 dictAllotCells(dp, 1);
2538 static void doDoes(FICL_VM *pVM)
2543 vmCheckStack(pVM, 0, 1);
2546 pCell = pVM->runningWord->param;
2547 tempIP = (IPTYPE)((*pCell).p);
2549 vmPushIP(pVM, tempIP);
2554 static void doesParen(FICL_VM *pVM)
2556 FICL_DICT *dp = vmGetDict(pVM);
2557 dp->smudge->code = doDoes;
2558 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2564 static void doesCoIm(FICL_VM *pVM)
2566 FICL_DICT *dp = vmGetDict(pVM);
2567 #if FICL_WANT_LOCALS
2568 assert(pVM->pSys->pUnLinkParen);
2569 if (pVM->pSys->nLocals > 0)
2571 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2572 dictEmpty(pLoc, pLoc->pForthWords->size);
2573 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2576 pVM->pSys->nLocals = 0;
2580 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2585 /**************************************************************************
2587 ** to-body CORE ( xt -- a-addr )
2588 ** a-addr is the data-field address corresponding to xt. An ambiguous
2589 ** condition exists if xt is not for a word defined via CREATE.
2590 **************************************************************************/
2591 static void toBody(FICL_VM *pVM)
2594 /*#$-GUY CHANGE: Added robustness.-$#*/
2596 vmCheckStack(pVM, 1, 1);
2600 PUSHPTR(pFW->param + 1);
2606 ** from-body ficl ( a-addr -- xt )
2607 ** Reverse effect of >body
2609 static void fromBody(FICL_VM *pVM)
2613 vmCheckStack(pVM, 1, 1);
2616 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2623 ** >name ficl ( xt -- c-addr u )
2624 ** Push the address and length of a word's name given its address
2627 static void toName(FICL_VM *pVM)
2631 vmCheckStack(pVM, 1, 2);
2636 PUSHUNS(pFW->nName);
2641 static void getLastWord(FICL_VM *pVM)
2643 FICL_DICT *pDict = vmGetDict(pVM);
2644 FICL_WORD *wp = pDict->smudge;
2646 vmPush(pVM, LVALUEtoCELL(wp));
2651 /**************************************************************************
2652 l b r a c k e t e t c
2654 **************************************************************************/
2656 static void lbracketCoIm(FICL_VM *pVM)
2658 pVM->state = INTERPRET;
2663 static void rbracket(FICL_VM *pVM)
2665 pVM->state = COMPILE;
2670 /**************************************************************************
2671 p i c t u r e d n u m e r i c w o r d s
2673 ** less-number-sign CORE ( -- )
2674 ** Initialize the pictured numeric output conversion process.
2676 **************************************************************************/
2677 static void lessNumberSign(FICL_VM *pVM)
2679 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2685 ** number-sign CORE ( ud1 -- ud2 )
2686 ** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2687 ** n. (n is the least-significant digit of ud1.) Convert n to external form
2688 ** and add the resulting character to the beginning of the pictured numeric
2689 ** output string. An ambiguous condition exists if # executes outside of a
2690 ** <# #> delimited number conversion.
2692 static void numberSign(FICL_VM *pVM)
2698 vmCheckStack(pVM, 2, 2);
2701 sp = PTRtoSTRING pVM->pad;
2702 u = u64Pop(pVM->pStack);
2703 rem = m64UMod(&u, (UNS16)(pVM->base));
2704 sp->text[sp->count++] = digit_to_char(rem);
2705 u64Push(pVM->pStack, u);
2710 ** number-sign-greater CORE ( xd -- c-addr u )
2711 ** Drop xd. Make the pictured numeric output string available as a character
2712 ** string. c-addr and u specify the resulting character string. A program
2713 ** may replace characters within the string.
2715 static void numberSignGreater(FICL_VM *pVM)
2719 vmCheckStack(pVM, 2, 2);
2722 sp = PTRtoSTRING pVM->pad;
2723 sp->text[sp->count] = 0;
2732 ** number-sign-s CORE ( ud1 -- ud2 )
2733 ** Convert one digit of ud1 according to the rule for #. Continue conversion
2734 ** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2735 ** #S executes outside of a <# #> delimited number conversion.
2736 ** TO DO: presently does not use ud1 hi cell - use it!
2738 static void numberSignS(FICL_VM *pVM)
2744 vmCheckStack(pVM, 2, 2);
2747 sp = PTRtoSTRING pVM->pad;
2748 u = u64Pop(pVM->pStack);
2752 rem = m64UMod(&u, (UNS16)(pVM->base));
2753 sp->text[sp->count++] = digit_to_char(rem);
2755 while (u.hi || u.lo);
2757 u64Push(pVM->pStack, u);
2762 ** HOLD CORE ( char -- )
2763 ** Add char to the beginning of the pictured numeric output string. An ambiguous
2764 ** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2766 static void hold(FICL_VM *pVM)
2771 vmCheckStack(pVM, 1, 0);
2774 sp = PTRtoSTRING pVM->pad;
2776 sp->text[sp->count++] = (char) i;
2781 ** SIGN CORE ( n -- )
2782 ** If n is negative, add a minus sign to the beginning of the pictured
2783 ** numeric output string. An ambiguous condition exists if SIGN
2784 ** executes outside of a <# #> delimited number conversion.
2786 static void sign(FICL_VM *pVM)
2791 vmCheckStack(pVM, 1, 0);
2794 sp = PTRtoSTRING pVM->pad;
2797 sp->text[sp->count++] = '-';
2802 /**************************************************************************
2804 ** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2805 ** ud2 is the unsigned result of converting the characters within the
2806 ** string specified by c-addr1 u1 into digits, using the number in BASE,
2807 ** and adding each into ud1 after multiplying ud1 by the number in BASE.
2808 ** Conversion continues left-to-right until a character that is not
2809 ** convertible, including any + or -, is encountered or the string is
2810 ** entirely converted. c-addr2 is the location of the first unconverted
2811 ** character or the first character past the end of the string if the string
2812 ** was entirely converted. u2 is the number of unconverted characters in the
2813 ** string. An ambiguous condition exists if ud2 overflows during the
2815 **************************************************************************/
2816 static void toNumber(FICL_VM *pVM)
2821 FICL_UNS base = pVM->base;
2826 vmCheckStack(pVM,4,4);
2830 cp = (char *)POPPTR();
2831 accum = u64Pop(pVM->pStack);
2833 for (ch = *cp; count > 0; ch = *++cp, count--)
2841 digit = tolower(ch) - 'a' + 10;
2843 ** Note: following test also catches chars between 9 and a
2844 ** because 'digit' is unsigned!
2849 accum = m64Mac(accum, base, digit);
2852 u64Push(pVM->pStack, accum);
2861 /**************************************************************************
2863 ** quit CORE ( -- ) ( R: i*x -- )
2864 ** Empty the return stack, store zero in SOURCE-ID if it is present, make
2865 ** the user input device the input source, and enter interpretation state.
2866 ** Do not display a message. Repeat the following:
2868 ** Accept a line from the input source into the input buffer, set >IN to
2869 ** zero, and interpret.
2870 ** Display the implementation-defined system prompt if in
2871 ** interpretation state, all processing has been completed, and no
2872 ** ambiguous condition exists.
2873 **************************************************************************/
2875 static void quit(FICL_VM *pVM)
2877 vmThrow(pVM, VM_QUIT);
2882 static void ficlAbort(FICL_VM *pVM)
2884 vmThrow(pVM, VM_ABORT);
2889 /**************************************************************************
2891 ** accept CORE ( c-addr +n1 -- +n2 )
2892 ** Receive a string of at most +n1 characters. An ambiguous condition
2893 ** exists if +n1 is zero or greater than 32,767. Display graphic characters
2894 ** as they are received. A program that depends on the presence or absence
2895 ** of non-graphic characters in the string has an environmental dependency.
2896 ** The editing functions, if any, that the system performs in order to
2897 ** construct the string are implementation-defined.
2899 ** (Although the standard text doesn't say so, I assume that the intent
2900 ** of 'accept' is to store the string at the address specified on
2902 ** Implementation: if there's more text in the TIB, use it. Otherwise
2903 ** throw out for more text. Copy characters up to the max count into the
2904 ** address given, and return the number of actual characters copied.
2906 ** Note (sobral) this may not be the behavior you'd expect if you're
2907 ** trying to get user input at load time!
2908 **************************************************************************/
2909 static void accept(FICL_VM *pVM)
2911 FICL_UNS count, len;
2916 vmCheckStack(pVM,2,1);
2919 pBuf = vmGetInBuf(pVM);
2920 pEnd = vmGetInBufEnd(pVM);
2923 vmThrow(pVM, VM_RESTART);
2926 ** Now we have something in the text buffer - use it
2928 count = stackPopINT(pVM->pStack);
2929 cp = stackPopPtr(pVM->pStack);
2931 len = (count < len) ? count : len;
2932 strncpy(cp, vmGetInBuf(pVM), len);
2934 vmUpdateTib(pVM, pBuf);
2941 /**************************************************************************
2943 ** 6.1.0705 ALIGN CORE ( -- )
2944 ** If the data-space pointer is not aligned, reserve enough space to
2946 **************************************************************************/
2947 static void align(FICL_VM *pVM)
2949 FICL_DICT *dp = vmGetDict(pVM);
2956 /**************************************************************************
2959 **************************************************************************/
2960 static void aligned(FICL_VM *pVM)
2964 vmCheckStack(pVM,1,1);
2968 PUSHPTR(alignPtr(addr));
2973 /**************************************************************************
2974 b e g i n & f r i e n d s
2975 ** Indefinite loop control structures
2978 ** : X ... BEGIN ... test UNTIL ;
2980 ** : X ... BEGIN ... test WHILE ... REPEAT ;
2981 **************************************************************************/
2982 static void beginCoIm(FICL_VM *pVM)
2984 FICL_DICT *dp = vmGetDict(pVM);
2985 markBranch(dp, pVM, destTag);
2989 static void untilCoIm(FICL_VM *pVM)
2991 FICL_DICT *dp = vmGetDict(pVM);
2993 assert(pVM->pSys->pIfParen);
2995 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
2996 resolveBackBranch(dp, pVM, destTag);
3000 static void whileCoIm(FICL_VM *pVM)
3002 FICL_DICT *dp = vmGetDict(pVM);
3004 assert(pVM->pSys->pIfParen);
3006 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
3007 markBranch(dp, pVM, origTag);
3009 dictAppendUNS(dp, 1);
3013 static void repeatCoIm(FICL_VM *pVM)
3015 FICL_DICT *dp = vmGetDict(pVM);
3017 assert(pVM->pSys->pBranchParen);
3018 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3020 /* expect "begin" branch marker */
3021 resolveBackBranch(dp, pVM, destTag);
3022 /* expect "while" branch marker */
3023 resolveForwardBranch(dp, pVM, origTag);
3028 static void againCoIm(FICL_VM *pVM)
3030 FICL_DICT *dp = vmGetDict(pVM);
3032 assert(pVM->pSys->pBranchParen);
3033 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3035 /* expect "begin" branch marker */
3036 resolveBackBranch(dp, pVM, destTag);
3041 /**************************************************************************
3042 c h a r & f r i e n d s
3043 ** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
3044 ** Skip leading space delimiters. Parse name delimited by a space.
3045 ** Put the value of its first character onto the stack.
3047 ** bracket-char CORE
3048 ** Interpretation: Interpretation semantics for this word are undefined.
3049 ** Compilation: ( "<spaces>name" -- )
3050 ** Skip leading space delimiters. Parse name delimited by a space.
3051 ** Append the run-time semantics given below to the current definition.
3052 ** Run-time: ( -- char )
3053 ** Place char, the value of the first character of name, on the stack.
3054 **************************************************************************/
3055 static void ficlChar(FICL_VM *pVM)
3059 vmCheckStack(pVM,0,1);
3062 si = vmGetWord(pVM);
3063 PUSHUNS((FICL_UNS)(si.cp[0]));
3067 static void charCoIm(FICL_VM *pVM)
3074 /**************************************************************************
3076 ** char-plus CORE ( c-addr1 -- c-addr2 )
3077 ** Add the size in address units of a character to c-addr1, giving c-addr2.
3078 **************************************************************************/
3079 static void charPlus(FICL_VM *pVM)
3083 vmCheckStack(pVM,1,1);
3091 /**************************************************************************
3093 ** chars CORE ( n1 -- n2 )
3094 ** n2 is the size in address units of n1 characters.
3095 ** For most processors, this function can be a no-op. To guarantee
3096 ** portability, we'll multiply by sizeof (char).
3097 **************************************************************************/
3098 #if defined (_M_IX86)
3099 #pragma warning(disable: 4127)
3101 static void ficlChars(FICL_VM *pVM)
3103 if (sizeof (char) > 1)
3107 vmCheckStack(pVM,1,1);
3110 PUSHINT(i * sizeof (char));
3112 /* otherwise no-op! */
3115 #if defined (_M_IX86)
3116 #pragma warning(default: 4127)
3120 /**************************************************************************
3122 ** COUNT CORE ( c-addr1 -- c-addr2 u )
3123 ** Return the character string specification for the counted string stored
3124 ** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3125 ** u is the contents of the character at c-addr1, which is the length in
3126 ** characters of the string at c-addr2.
3127 **************************************************************************/
3128 static void count(FICL_VM *pVM)
3132 vmCheckStack(pVM,1,2);
3141 /**************************************************************************
3142 e n v i r o n m e n t ?
3143 ** environment-query CORE ( c-addr u -- false | i*x true )
3144 ** c-addr is the address of a character string and u is the string's
3145 ** character count. u may have a value in the range from zero to an
3146 ** implementation-defined maximum which shall not be less than 31. The
3147 ** character string should contain a keyword from 3.2.6 Environmental
3148 ** queries or the optional word sets to be checked for correspondence
3149 ** with an attribute of the present environment. If the system treats the
3150 ** attribute as unknown, the returned flag is false; otherwise, the flag
3151 ** is true and the i*x returned is of the type specified in the table for
3152 ** the attribute queried.
3153 **************************************************************************/
3154 static void environmentQ(FICL_VM *pVM)
3160 vmCheckStack(pVM,2,1);
3163 envp = pVM->pSys->envp;
3164 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3165 si.cp = stackPopPtr(pVM->pStack);
3167 pFW = dictLookup(envp, si);
3171 vmExecute(pVM, pFW);
3176 PUSHINT(FICL_FALSE);
3181 /**************************************************************************
3183 ** EVALUATE CORE ( i*x c-addr u -- j*x )
3184 ** Save the current input source specification. Store minus-one (-1) in
3185 ** SOURCE-ID if it is present. Make the string described by c-addr and u
3186 ** both the input source and input buffer, set >IN to zero, and interpret.
3187 ** When the parse area is empty, restore the prior input source
3188 ** specification. Other stack effects are due to the words EVALUATEd.
3190 **************************************************************************/
3191 static void evaluate(FICL_VM *pVM)
3198 vmCheckStack(pVM,2,0);
3206 pVM->sourceID.i = -1;
3207 result = ficlExecC(pVM, cp, count);
3209 if (result != VM_OUTOFTEXT)
3210 vmThrow(pVM, result);
3216 /**************************************************************************
3217 s t r i n g q u o t e
3218 ** Interpreting: get string delimited by a quote from the input stream,
3219 ** copy to a scratch area, and put its count and address on the stack.
3220 ** Compiling: compile code to push the address and count of a string
3221 ** literal, compile the string from the input stream, and align the dict
3223 **************************************************************************/
3224 static void stringQuoteIm(FICL_VM *pVM)
3226 FICL_DICT *dp = vmGetDict(pVM);
3228 if (pVM->state == INTERPRET)
3230 FICL_STRING *sp = (FICL_STRING *) dp->here;
3231 vmGetString(pVM, sp, '\"');
3235 else /* COMPILE state */
3237 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3238 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3246 /**************************************************************************
3248 ** Pop count and char address from stack and print the designated string.
3249 **************************************************************************/
3250 static void type(FICL_VM *pVM)
3252 FICL_UNS count = stackPopUNS(pVM->pStack);
3253 char *cp = stackPopPtr(pVM->pStack);
3254 char *pDest = (char *)ficlMalloc(count + 1);
3257 ** Since we don't have an output primitive for a counted string
3258 ** (oops), make sure the string is null terminated. If not, copy
3259 ** and terminate it.
3262 vmThrowErr(pVM, "Error: out of memory");
3264 strncpy(pDest, cp, count);
3265 pDest[count] = '\0';
3267 vmTextOut(pVM, pDest, 0);
3273 /**************************************************************************
3275 ** word CORE ( char "<chars>ccc<char>" -- c-addr )
3276 ** Skip leading delimiters. Parse characters ccc delimited by char. An
3277 ** ambiguous condition exists if the length of the parsed string is greater
3278 ** than the implementation-defined length of a counted string.
3280 ** c-addr is the address of a transient region containing the parsed word
3281 ** as a counted string. If the parse area was empty or contained no
3282 ** characters other than the delimiter, the resulting string has a zero
3283 ** length. A space, not included in the length, follows the string. A
3284 ** program may replace characters within the string.
3285 ** NOTE! Ficl also NULL-terminates the dest string.
3286 **************************************************************************/
3287 static void ficlWord(FICL_VM *pVM)
3293 vmCheckStack(pVM,1,1);
3296 sp = (FICL_STRING *)pVM->pad;
3297 delim = (char)POPINT();
3298 si = vmParseStringEx(pVM, delim, 1);
3300 if (SI_COUNT(si) > nPAD-1)
3301 SI_SETLEN(si, nPAD-1);
3303 sp->count = (FICL_COUNT)SI_COUNT(si);
3304 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3305 /*#$-GUY CHANGE: I added this.-$#*/
3306 sp->text[sp->count] = 0;
3307 strcat(sp->text, " ");
3314 /**************************************************************************
3316 ** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3317 ** Skip leading spaces and parse name delimited by a space. c-addr is the
3318 ** address within the input buffer and u is the length of the selected
3319 ** string. If the parse area is empty, the resulting string has a zero length.
3320 **************************************************************************/
3321 static void parseNoCopy(FICL_VM *pVM)
3325 vmCheckStack(pVM,0,2);
3328 si = vmGetWord0(pVM);
3329 PUSHPTR(SI_PTR(si));
3330 PUSHUNS(SI_COUNT(si));
3335 /**************************************************************************
3337 ** CORE EXT ( char "ccc<char>" -- c-addr u )
3338 ** Parse ccc delimited by the delimiter char.
3339 ** c-addr is the address (within the input buffer) and u is the length of
3340 ** the parsed string. If the parse area was empty, the resulting string has
3342 ** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3343 **************************************************************************/
3344 static void parse(FICL_VM *pVM)
3350 vmCheckStack(pVM,1,2);
3353 delim = (char)POPINT();
3355 si = vmParseStringEx(pVM, delim, 0);
3356 PUSHPTR(SI_PTR(si));
3357 PUSHUNS(SI_COUNT(si));
3362 /**************************************************************************
3364 ** CORE ( c-addr u char -- )
3365 ** If u is greater than zero, store char in each of u consecutive
3366 ** characters of memory beginning at c-addr.
3367 **************************************************************************/
3368 static void fill(FICL_VM *pVM)
3374 vmCheckStack(pVM,3,0);
3376 ch = (char)POPINT();
3378 cp = (char *)POPPTR();
3389 /**************************************************************************
3391 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3392 ** Find the definition named in the counted string at c-addr. If the
3393 ** definition is not found, return c-addr and zero. If the definition is
3394 ** found, return its execution token xt. If the definition is immediate,
3395 ** also return one (1), otherwise also return minus-one (-1). For a given
3396 ** string, the values returned by FIND while compiling may differ from
3397 ** those returned while not compiling.
3398 **************************************************************************/
3399 static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3403 pFW = dictLookup(vmGetDict(pVM), si);
3407 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3411 PUSHPTR(returnForFailure);
3419 /**************************************************************************
3421 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3422 ** Find the definition named in the counted string at c-addr. If the
3423 ** definition is not found, return c-addr and zero. If the definition is
3424 ** found, return its execution token xt. If the definition is immediate,
3425 ** also return one (1), otherwise also return minus-one (-1). For a given
3426 ** string, the values returned by FIND while compiling may differ from
3427 ** those returned while not compiling.
3428 **************************************************************************/
3429 static void cFind(FICL_VM *pVM)
3435 vmCheckStack(pVM,1,2);
3439 do_find(pVM, si, sp);
3444 /**************************************************************************
3446 ** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3447 ** Like FIND, but takes "c-addr u" for the string.
3448 **************************************************************************/
3449 static void sFind(FICL_VM *pVM)
3454 vmCheckStack(pVM,2,2);
3457 si.count = stackPopINT(pVM->pStack);
3458 si.cp = stackPopPtr(pVM->pStack);
3460 do_find(pVM, si, NULL);
3465 /**************************************************************************
3467 ** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3468 ** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3469 ** Input and output stack arguments are signed. An ambiguous condition
3470 ** exists if n1 is zero or if the quotient lies outside the range of a
3471 ** single-cell signed integer.
3472 **************************************************************************/
3473 static void fmSlashMod(FICL_VM *pVM)
3479 vmCheckStack(pVM,3,2);
3483 d1 = i64Pop(pVM->pStack);
3484 qr = m64FlooredDivI(d1, n1);
3491 /**************************************************************************
3493 ** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3494 ** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3495 ** Input and output stack arguments are signed. An ambiguous condition
3496 ** exists if n1 is zero or if the quotient lies outside the range of a
3497 ** single-cell signed integer.
3498 **************************************************************************/
3499 static void smSlashRem(FICL_VM *pVM)
3505 vmCheckStack(pVM,3,2);
3509 d1 = i64Pop(pVM->pStack);
3510 qr = m64SymmetricDivI(d1, n1);
3517 static void ficlMod(FICL_VM *pVM)
3523 vmCheckStack(pVM,2,1);
3529 qr = m64SymmetricDivI(d1, n1);
3535 /**************************************************************************
3537 ** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3538 ** Divide ud by u1, giving the quotient u3 and the remainder u2.
3539 ** All values and arithmetic are unsigned. An ambiguous condition
3540 ** exists if u1 is zero or if the quotient lies outside the range of a
3541 ** single-cell unsigned integer.
3542 *************************************************************************/
3543 static void umSlashMod(FICL_VM *pVM)
3549 u1 = stackPopUNS(pVM->pStack);
3550 ud = u64Pop(pVM->pStack);
3551 qr = ficlLongDiv(ud, u1);
3558 /**************************************************************************
3560 ** l-shift CORE ( x1 u -- x2 )
3561 ** Perform a logical left shift of u bit-places on x1, giving x2.
3562 ** Put zeroes into the least significant bits vacated by the shift.
3563 ** An ambiguous condition exists if u is greater than or equal to the
3564 ** number of bits in a cell.
3566 ** r-shift CORE ( x1 u -- x2 )
3567 ** Perform a logical right shift of u bit-places on x1, giving x2.
3568 ** Put zeroes into the most significant bits vacated by the shift. An
3569 ** ambiguous condition exists if u is greater than or equal to the
3570 ** number of bits in a cell.
3571 **************************************************************************/
3572 static void lshift(FICL_VM *pVM)
3577 vmCheckStack(pVM,2,1);
3582 PUSHUNS(x1 << nBits);
3587 static void rshift(FICL_VM *pVM)
3592 vmCheckStack(pVM,2,1);
3598 PUSHUNS(x1 >> nBits);
3603 /**************************************************************************
3605 ** m-star CORE ( n1 n2 -- d )
3606 ** d is the signed product of n1 times n2.
3607 **************************************************************************/
3608 static void mStar(FICL_VM *pVM)
3614 vmCheckStack(pVM,2,2);
3620 d = m64MulI(n1, n2);
3621 i64Push(pVM->pStack, d);
3626 static void umStar(FICL_VM *pVM)
3632 vmCheckStack(pVM,2,2);
3638 ud = ficlLongMul(u1, u2);
3639 u64Push(pVM->pStack, ud);
3644 /**************************************************************************
3647 **************************************************************************/
3648 static void ficlMax(FICL_VM *pVM)
3653 vmCheckStack(pVM,2,1);
3659 PUSHINT((n1 > n2) ? n1 : n2);
3663 static void ficlMin(FICL_VM *pVM)
3668 vmCheckStack(pVM,2,1);
3674 PUSHINT((n1 < n2) ? n1 : n2);
3679 /**************************************************************************
3681 ** CORE ( addr1 addr2 u -- )
3682 ** If u is greater than zero, copy the contents of u consecutive address
3683 ** units at addr1 to the u consecutive address units at addr2. After MOVE
3684 ** completes, the u consecutive address units at addr2 contain exactly
3685 ** what the u consecutive address units at addr1 contained before the move.
3686 ** NOTE! This implementation assumes that a char is the same size as
3688 **************************************************************************/
3689 static void move(FICL_VM *pVM)
3695 vmCheckStack(pVM,3,0);
3705 ** Do the copy carefully, so as to be
3706 ** correct even if the two ranges overlap
3711 *addr2++ = *addr1++;
3718 *addr2-- = *addr1--;
3725 /**************************************************************************
3728 **************************************************************************/
3729 static void recurseCoIm(FICL_VM *pVM)
3731 FICL_DICT *pDict = vmGetDict(pVM);
3734 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3739 /**************************************************************************
3741 ** s-to-d CORE ( n -- d )
3742 ** Convert the number n to the double-cell number d with the same
3744 **************************************************************************/
3745 static void sToD(FICL_VM *pVM)
3749 vmCheckStack(pVM,1,2);
3754 /* sign extend to 64 bits.. */
3756 PUSHINT((s < 0) ? -1 : 0);
3761 /**************************************************************************
3763 ** CORE ( -- c-addr u )
3764 ** c-addr is the address of, and u is the number of characters in, the
3766 **************************************************************************/
3767 static void source(FICL_VM *pVM)
3770 vmCheckStack(pVM,0,2);
3772 PUSHPTR(pVM->tib.cp);
3773 PUSHINT(vmGetInBufLen(pVM));
3778 /**************************************************************************
3781 **************************************************************************/
3782 static void ficlVersion(FICL_VM *pVM)
3784 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3789 /**************************************************************************
3792 **************************************************************************/
3793 static void toIn(FICL_VM *pVM)
3796 vmCheckStack(pVM,0,1);
3798 PUSHPTR(&pVM->tib.index);
3803 /**************************************************************************
3804 c o l o n N o N a m e
3805 ** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3806 ** Create an unnamed colon definition and push its address.
3807 ** Change state to compile.
3808 **************************************************************************/
3809 static void colonNoName(FICL_VM *pVM)
3811 FICL_DICT *dp = vmGetDict(pVM);
3816 SI_SETPTR(si, NULL);
3818 pVM->state = COMPILE;
3819 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3821 markControlTag(pVM, colonTag);
3826 /**************************************************************************
3827 u s e r V a r i a b l e
3828 ** user ( u -- ) "<spaces>name"
3829 ** Get a name from the input stream and create a user variable
3830 ** with the name and the index supplied. The run-time effect
3831 ** of a user variable is to push the address of the indexed cell
3832 ** in the running vm's user array.
3834 ** User variables are vm local cells. Each vm has an array of
3835 ** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3836 ** Ficl's user facility is implemented with two primitives,
3837 ** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3838 ** holds the index of the next free user cell, and a redefinition
3839 ** (also in softcore) of "user" that defines a user word and increments
3841 **************************************************************************/
3843 static void userParen(FICL_VM *pVM)
3845 FICL_INT i = pVM->runningWord->param[0].i;
3846 PUSHPTR(&pVM->user[i]);
3851 static void userVariable(FICL_VM *pVM)
3853 FICL_DICT *dp = vmGetDict(pVM);
3854 STRINGINFO si = vmGetWord(pVM);
3857 c = stackPop(pVM->pStack);
3858 if (c.i >= FICL_USER_CELLS)
3860 vmThrowErr(pVM, "Error - out of user space");
3863 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3864 dictAppendCell(dp, c);
3870 /**************************************************************************
3873 ** Interpretation: ( x "<spaces>name" -- )
3874 ** Skip leading spaces and parse name delimited by a space. Store x in
3875 ** name. An ambiguous condition exists if name was not defined by VALUE.
3876 ** NOTE: In ficl, VALUE is an alias of CONSTANT
3877 **************************************************************************/
3878 static void toValue(FICL_VM *pVM)
3880 STRINGINFO si = vmGetWord(pVM);
3881 FICL_DICT *dp = vmGetDict(pVM);
3884 #if FICL_WANT_LOCALS
3885 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
3887 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
3888 pFW = dictLookup(pLoc, si);
3889 if (pFW && (pFW->code == doLocalIm))
3891 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
3892 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3895 else if (pFW && pFW->code == do2LocalIm)
3897 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
3898 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3904 assert(pVM->pSys->pStore);
3906 pFW = dictLookup(dp, si);
3909 int i = SI_COUNT(si);
3910 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3913 if (pVM->state == INTERPRET)
3914 pFW->param[0] = stackPop(pVM->pStack);
3915 else /* compile code to store to word's param */
3917 PUSHPTR(&pFW->param[0]);
3919 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
3925 #if FICL_WANT_LOCALS
3926 /**************************************************************************
3929 ** Link a frame on the return stack, reserving nCells of space for
3930 ** locals - the value of nCells is the next cell in the instruction
3932 **************************************************************************/
3933 static void linkParen(FICL_VM *pVM)
3935 FICL_INT nLink = *(FICL_INT *)(pVM->ip);
3936 vmBranchRelative(pVM, 1);
3937 stackLink(pVM->rStack, nLink);
3942 static void unlinkParen(FICL_VM *pVM)
3944 stackUnlink(pVM->rStack);
3949 /**************************************************************************
3951 ** Immediate - cfa of a local while compiling - when executed, compiles
3952 ** code to fetch the value of a local given the local's index in the
3954 **************************************************************************/
3955 static void getLocalParen(FICL_VM *pVM)
3957 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3958 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3963 static void toLocalParen(FICL_VM *pVM)
3965 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3966 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3971 static void getLocal0(FICL_VM *pVM)
3973 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3978 static void toLocal0(FICL_VM *pVM)
3980 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3985 static void getLocal1(FICL_VM *pVM)
3987 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3992 static void toLocal1(FICL_VM *pVM)
3994 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
4000 ** Each local is recorded in a private locals dictionary as a
4001 ** word that does doLocalIm at runtime. DoLocalIm compiles code
4002 ** into the client definition to fetch the value of the
4003 ** corresponding local variable from the return stack.
4004 ** The private dictionary gets initialized at the end of each block
4005 ** that uses locals (in ; and does> for example).
4007 static void doLocalIm(FICL_VM *pVM)
4009 FICL_DICT *pDict = vmGetDict(pVM);
4010 FICL_INT nLocal = pVM->runningWord->param[0].i;
4012 if (pVM->state == INTERPRET)
4014 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4021 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
4023 else if (nLocal == 1)
4025 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
4029 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
4030 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4037 /**************************************************************************
4039 ** paren-local-paren LOCAL
4040 ** Interpretation: Interpretation semantics for this word are undefined.
4041 ** Execution: ( c-addr u -- )
4042 ** When executed during compilation, (LOCAL) passes a message to the
4043 ** system that has one of two meanings. If u is non-zero,
4044 ** the message identifies a new local whose definition name is given by
4045 ** the string of characters identified by c-addr u. If u is zero,
4046 ** the message is last local and c-addr has no significance.
4048 ** The result of executing (LOCAL) during compilation of a definition is
4049 ** to create a set of named local identifiers, each of which is
4050 ** a definition name, that only have execution semantics within the scope
4051 ** of that definition's source.
4053 ** local Execution: ( -- x )
4055 ** Push the local's value, x, onto the stack. The local's value is
4056 ** initialized as described in 13.3.3 Processing locals and may be
4057 ** changed by preceding the local's name with TO. An ambiguous condition
4058 ** exists when local is executed while in interpretation state.
4059 **************************************************************************/
4060 static void localParen(FICL_VM *pVM)
4065 vmCheckStack(pVM,2,0);
4068 pDict = vmGetDict(pVM);
4069 SI_SETLEN(si, POPUNS());
4070 SI_SETPTR(si, (char *)POPPTR());
4072 if (SI_COUNT(si) > 0)
4073 { /* add a local to the **locals** dict and update nLocals */
4074 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4075 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4077 vmThrowErr(pVM, "Error: out of local space");
4080 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4081 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4083 if (pVM->pSys->nLocals == 0)
4084 { /* compile code to create a local stack frame */
4085 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4086 /* save location in dictionary for #locals */
4087 pVM->pSys->pMarkLocals = pDict->here;
4088 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4089 /* compile code to initialize first local */
4090 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
4092 else if (pVM->pSys->nLocals == 1)
4094 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
4098 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4099 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4102 (pVM->pSys->nLocals)++;
4104 else if (pVM->pSys->nLocals > 0)
4105 { /* write nLocals to (link) param area in dictionary */
4106 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4113 static void get2LocalParen(FICL_VM *pVM)
4115 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4116 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4117 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4122 static void do2LocalIm(FICL_VM *pVM)
4124 FICL_DICT *pDict = vmGetDict(pVM);
4125 FICL_INT nLocal = pVM->runningWord->param[0].i;
4127 if (pVM->state == INTERPRET)
4129 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4130 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4134 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
4135 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4141 static void to2LocalParen(FICL_VM *pVM)
4143 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4144 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4145 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4150 static void twoLocalParen(FICL_VM *pVM)
4152 FICL_DICT *pDict = vmGetDict(pVM);
4154 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4155 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4157 if (SI_COUNT(si) > 0)
4158 { /* add a local to the **locals** dict and update nLocals */
4159 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4160 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4162 vmThrowErr(pVM, "Error: out of local space");
4165 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4166 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4168 if (pVM->pSys->nLocals == 0)
4169 { /* compile code to create a local stack frame */
4170 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4171 /* save location in dictionary for #locals */
4172 pVM->pSys->pMarkLocals = pDict->here;
4173 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4176 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4177 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4179 pVM->pSys->nLocals += 2;
4181 else if (pVM->pSys->nLocals > 0)
4182 { /* write nLocals to (link) param area in dictionary */
4183 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4191 /**************************************************************************
4193 ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4194 ** Compare the string specified by c-addr1 u1 to the string specified by
4195 ** c-addr2 u2. The strings are compared, beginning at the given addresses,
4196 ** character by character, up to the length of the shorter string or until a
4197 ** difference is found. If the two strings are identical, n is zero. If the two
4198 ** strings are identical up to the length of the shorter string, n is minus-one
4199 ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4200 ** identical up to the length of the shorter string, n is minus-one (-1) if the
4201 ** first non-matching character in the string specified by c-addr1 u1 has a
4202 ** lesser numeric value than the corresponding character in the string specified
4203 ** by c-addr2 u2 and one (1) otherwise.
4204 **************************************************************************/
4205 static void compareInternal(FICL_VM *pVM, int caseInsensitive)
4208 FICL_UNS u1, u2, uMin;
4211 vmCheckStack(pVM, 4, 1);
4212 u2 = stackPopUNS(pVM->pStack);
4213 cp2 = (char *)stackPopPtr(pVM->pStack);
4214 u1 = stackPopUNS(pVM->pStack);
4215 cp1 = (char *)stackPopPtr(pVM->pStack);
4217 uMin = (u1 < u2)? u1 : u2;
4218 for ( ; (uMin > 0) && (n == 0); uMin--)
4222 if (caseInsensitive)
4224 c1 = (char)tolower(c1);
4225 c2 = (char)tolower(c2);
4243 static void compareString(FICL_VM *pVM)
4245 compareInternal(pVM, FALSE);
4249 static void compareStringInsensitive(FICL_VM *pVM)
4251 compareInternal(pVM, TRUE);
4255 /**************************************************************************
4257 ** CORE EXT ( -- c-addr )
4258 ** c-addr is the address of a transient region that can be used to hold
4259 ** data for intermediate processing.
4260 **************************************************************************/
4261 static void pad(FICL_VM *pVM)
4263 stackPushPtr(pVM->pStack, pVM->pad);
4267 /**************************************************************************
4269 ** CORE EXT, FILE ( -- 0 | -1 | fileid )
4270 ** Identifies the input source as follows:
4272 ** SOURCE-ID Input source
4273 ** --------- ------------
4274 ** fileid Text file fileid
4275 ** -1 String (via EVALUATE)
4276 ** 0 User input device
4277 **************************************************************************/
4278 static void sourceid(FICL_VM *pVM)
4280 PUSHINT(pVM->sourceID.i);
4285 /**************************************************************************
4287 ** CORE EXT ( -- flag )
4288 ** Attempt to fill the input buffer from the input source, returning a true
4289 ** flag if successful.
4290 ** When the input source is the user input device, attempt to receive input
4291 ** into the terminal input buffer. If successful, make the result the input
4292 ** buffer, set >IN to zero, and return true. Receipt of a line containing no
4293 ** characters is considered successful. If there is no input available from
4294 ** the current input source, return false.
4295 ** When the input source is a string from EVALUATE, return false and
4296 ** perform no other action.
4297 **************************************************************************/
4298 static void refill(FICL_VM *pVM)
4300 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4301 if (ret && (pVM->fRestart == 0))
4302 vmThrow(pVM, VM_RESTART);
4309 /**************************************************************************
4310 freebsd exception handling words
4311 ** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4312 ** the word in ToS. If an exception happens, restore the state to what
4313 ** it was before, and pushes the exception value on the stack. If not,
4316 ** Notice that Catch implements an inner interpreter. This is ugly,
4317 ** but given how ficl works, it cannot be helped. The problem is that
4318 ** colon definitions will be executed *after* the function returns,
4319 ** while "code" definitions will be executed immediately. I considered
4320 ** other solutions to this problem, but all of them shared the same
4321 ** basic problem (with added disadvantages): if ficl ever changes it's
4322 ** inner thread modus operandi, one would have to fix this word.
4324 ** More comments can be found throughout catch's code.
4326 ** Daniel C. Sobral Jan 09/1999
4327 ** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4328 **************************************************************************/
4330 static void ficlCatch(FICL_VM *pVM)
4340 assert(pVM->pSys->pExitInner);
4345 ** We need this *before* we save the stack pointer, or
4346 ** we'll have to pop one element out of the stack after
4347 ** an exception. I prefer to get done with it up front. :-)
4350 vmCheckStack(pVM, 1, 0);
4352 pFW = stackPopPtr(pVM->pStack);
4355 ** Save vm's state -- a catch will not back out environmental
4358 ** We are *not* saving dictionary state, since it is
4359 ** global instead of per vm, and we are not saving
4360 ** stack contents, since we are not required to (and,
4361 ** thus, it would be useless). We save pVM, and pVM
4362 ** "stacks" (a structure containing general information
4363 ** about it, including the current stack pointer).
4365 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4366 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4367 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4370 ** Give pVM a jmp_buf
4372 pVM->pState = &vmState;
4377 except = setjmp(vmState);
4382 ** Setup condition - push poison pill so that the VM throws
4383 ** VM_INNEREXIT if the XT terminates normally, then execute
4387 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4388 vmExecute(pVM, pFW);
4393 ** Normal exit from XT - lose the poison pill,
4394 ** restore old setjmp vector and push a zero.
4397 vmPopIP(pVM); /* Gack - hurl poison pill */
4398 pVM->pState = VM.pState; /* Restore just the setjmp vector */
4399 PUSHINT(0); /* Push 0 -- everything is ok */
4403 ** Some other exception got thrown - restore pre-existing VM state
4404 ** and push the exception code
4407 /* Restore vm's state */
4408 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4409 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4410 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4412 PUSHINT(except);/* Push error */
4417 /**************************************************************************
4420 ** Throw -- From ANS Forth standard.
4422 ** Throw takes the ToS and, if that's different from zero,
4423 ** returns to the last executed catch context. Further throws will
4424 ** unstack previously executed "catches", in LIFO mode.
4426 ** Daniel C. Sobral Jan 09/1999
4427 **************************************************************************/
4428 static void ficlThrow(FICL_VM *pVM)
4432 except = stackPopINT(pVM->pStack);
4435 vmThrow(pVM, except);
4439 /**************************************************************************
4442 **************************************************************************/
4443 static void ansAllocate(FICL_VM *pVM)
4448 size = stackPopINT(pVM->pStack);
4449 p = ficlMalloc(size);
4458 /**************************************************************************
4461 **************************************************************************/
4462 static void ansFree(FICL_VM *pVM)
4466 p = stackPopPtr(pVM->pStack);
4472 /**************************************************************************
4475 **************************************************************************/
4476 static void ansResize(FICL_VM *pVM)
4481 size = stackPopINT(pVM->pStack);
4482 old = stackPopPtr(pVM->pStack);
4483 new = ficlRealloc(old, size);
4497 /**************************************************************************
4498 ** e x i t - i n n e r
4499 ** Signals execXT that an inner loop has completed
4500 **************************************************************************/
4501 static void ficlExitInner(FICL_VM *pVM)
4503 vmThrow(pVM, VM_INNEREXIT);
4507 /**************************************************************************
4509 ** DOUBLE ( d1 -- d2 )
4510 ** d2 is the negation of d1.
4511 **************************************************************************/
4512 static void dnegate(FICL_VM *pVM)
4514 DPINT i = i64Pop(pVM->pStack);
4516 i64Push(pVM->pStack, i);
4523 /**************************************************************************
4526 **************************************************************************/
4527 static void funcname(FICL_VM *pVM)
4535 /**************************************************************************
4536 f i c l W o r d C l a s s i f y
4537 ** This public function helps to classify word types for SEE
4538 ** and the deugger in tools.c. Given an pointer to a word, it returns
4540 **************************************************************************/
4541 WORDKIND ficlWordClassify(FICL_WORD *pFW)
4549 static CODEtoKIND codeMap[] =
4551 {BRANCH, branchParen},
4552 {COLON, colonParen},
4553 {CONSTANT, constantParen},
4554 {CREATE, createParen},
4558 {LITERAL, literalParen},
4560 {PLOOP, plusLoopParen},
4562 {CSTRINGLIT, cstringLit},
4563 {STRINGLIT, stringLit},
4567 {VARIABLE, variableParen},
4570 #define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4572 FICL_CODE code = pFW->code;
4575 for (i=0; i < nMAP; i++)
4577 if (codeMap[i].code == code)
4578 return codeMap[i].kind;
4585 /**************************************************************************
4586 f i c l C o m p i l e C o r e
4587 ** Builds the primitive wordset and the environment-query namespace.
4588 **************************************************************************/
4590 void ficlCompileCore(FICL_SYSTEM *pSys)
4592 FICL_DICT *dp = pSys->dp;
4598 ** see softcore.c for definitions of: abs bl space spaces abort"
4601 dictAppendWord(dp, "!", store, FW_DEFAULT);
4602 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4603 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4604 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4605 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4606 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4607 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4608 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4609 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4610 dictAppendWord(dp, "+", add, FW_DEFAULT);
4611 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4612 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4613 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4614 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4615 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4616 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4617 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4618 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4619 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4620 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4621 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4622 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4623 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4624 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4625 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4626 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4627 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4628 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4629 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4630 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4631 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4632 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4633 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4634 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4635 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4636 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4637 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4638 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4639 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4640 dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
4641 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4642 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4643 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4644 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4645 dictAppendWord(dp, "align", align, FW_DEFAULT);
4646 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4647 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4648 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4649 dictAppendWord(dp, "base", base, FW_DEFAULT);
4650 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4651 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4652 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4653 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4654 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4655 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4656 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4657 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4658 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4659 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4660 dictAppendWord(dp, "count", count, FW_DEFAULT);
4661 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4662 dictAppendWord(dp, "create", create, FW_DEFAULT);
4663 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4664 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4665 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4666 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4667 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4668 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4669 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4670 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4671 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4672 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4673 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4674 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4675 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4676 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4677 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4678 dictAppendWord(dp, "here", here, FW_DEFAULT);
4679 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4680 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4681 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4682 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4683 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4684 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4685 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4686 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4687 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4688 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4689 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4690 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4691 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4692 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4693 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4694 dictAppendWord(dp, "move", move, FW_DEFAULT);
4695 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4696 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4697 dictAppendWord(dp, "over", over, FW_DEFAULT);
4698 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4699 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4700 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
4701 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
4702 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4703 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4704 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4705 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4706 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4707 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4708 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4709 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4710 dictAppendWord(dp, "source", source, FW_DEFAULT);
4711 dictAppendWord(dp, "state", state, FW_DEFAULT);
4712 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4713 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4714 dictAppendWord(dp, "type", type, FW_DEFAULT);
4715 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4716 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4717 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4718 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4719 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4720 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4721 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4722 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4723 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4724 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4725 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4726 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4727 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4728 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4730 ** CORE EXT word set...
4731 ** see softcore.fr for other definitions
4734 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
4736 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4737 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4738 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
4739 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
4740 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4741 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4742 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
4743 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
4744 /* case of endof endcase */
4745 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4746 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
4747 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4748 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4749 /* query restore-input save-input tib u.r u> unused [compile] */
4750 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4751 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4752 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
4753 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4754 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4755 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4759 ** Set CORE environment query values
4761 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
4762 ficlSetEnv(pSys, "/hold", nPAD);
4763 ficlSetEnv(pSys, "/pad", nPAD);
4764 ficlSetEnv(pSys, "address-unit-bits", 8);
4765 ficlSetEnv(pSys, "core", FICL_TRUE);
4766 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
4767 ficlSetEnv(pSys, "floored", FICL_FALSE);
4768 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
4769 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
4770 ficlSetEnv(pSys, "max-n", 0x7fffffff);
4771 ficlSetEnv(pSys, "max-u", 0xffffffff);
4772 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
4773 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
4774 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
4777 ** DOUBLE word set (partial)
4779 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
4780 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
4781 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
4782 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
4786 ** EXCEPTION word set
4788 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
4789 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
4791 ficlSetEnv(pSys, "exception", FICL_TRUE);
4792 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
4795 ** LOCAL and LOCAL EXT
4796 ** see softcore.c for implementation of locals|
4798 #if FICL_WANT_LOCALS
4800 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4801 pSys->pUnLinkParen =
4802 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4803 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4804 pSys->pGetLocalParen =
4805 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4806 pSys->pToLocalParen =
4807 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4809 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4811 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4813 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4815 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4816 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4818 pSys->pGet2LocalParen =
4819 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4820 pSys->pTo2LocalParen =
4821 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
4822 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
4824 ficlSetEnv(pSys, "locals", FICL_TRUE);
4825 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
4826 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
4830 ** Optional MEMORY-ALLOC word set
4833 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
4834 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
4835 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
4837 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
4840 ** optional SEARCH-ORDER word set
4842 ficlCompileSearch(pSys);
4845 ** TOOLS and TOOLS EXT
4847 ficlCompileTools(pSys);
4850 ** FILE and FILE EXT
4853 ficlCompileFile(pSys);
4860 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4862 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4863 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4864 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4865 dictAppendWord(dp, "add-parse-step",
4866 addParseStep, FW_DEFAULT);
4867 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4868 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4869 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
4870 dictAppendWord(dp, "compile-only",
4871 compileOnly, FW_DEFAULT);
4872 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4873 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
4874 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
4875 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
4876 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
4877 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4878 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
4879 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4880 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
4881 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
4882 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
4883 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
4884 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4885 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4886 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4888 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4889 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4893 ** internal support words
4895 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
4897 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4899 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4901 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4902 pSys->pTwoLitParen =
4903 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
4905 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4907 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
4909 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4910 pSys->pBranchParen =
4911 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4913 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4915 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4917 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4919 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4921 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4923 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4924 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
4925 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4926 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4927 dictAppendWord(dp, "(parse-step)",
4928 parseStepParen, FW_DEFAULT);
4930 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
4933 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
4935 pSys->pInterp[0] = pSys->pInterpret;
4936 pSys->pInterp[1] = pSys->pBranchParen;
4937 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
4939 assert(dictCellsAvail(dp) > 0);