140843Smsmith/******************************************************************* 240843Smsmith** w o r d s . c 340843Smsmith** Forth Inspired Command Language 440843Smsmith** ANS Forth CORE word-set written in C 540843Smsmith** Author: John Sadler (john_sadler@alum.mit.edu) 640843Smsmith** Created: 19 July 1997 794290Sdcs** $Id: words.c,v 1.17 2001/12/05 07:21:34 jsadler Exp $ 876116Sdcs*******************************************************************/ 976116Sdcs/* 1076116Sdcs** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 1176116Sdcs** All rights reserved. 1276116Sdcs** 1376116Sdcs** Get the latest Ficl release at http://ficl.sourceforge.net 1476116Sdcs** 1594290Sdcs** I am interested in hearing from anyone who uses ficl. If you have 1694290Sdcs** a problem, a success story, a defect, an enhancement request, or 1794290Sdcs** if you would like to contribute to the ficl release, please 1894290Sdcs** contact me by email at the address above. 1994290Sdcs** 2076116Sdcs** L I C E N S E and D I S C L A I M E R 2140843Smsmith** 2276116Sdcs** Redistribution and use in source and binary forms, with or without 2376116Sdcs** modification, are permitted provided that the following conditions 2476116Sdcs** are met: 2576116Sdcs** 1. Redistributions of source code must retain the above copyright 2676116Sdcs** notice, this list of conditions and the following disclaimer. 2776116Sdcs** 2. Redistributions in binary form must reproduce the above copyright 2876116Sdcs** notice, this list of conditions and the following disclaimer in the 2976116Sdcs** documentation and/or other materials provided with the distribution. 3076116Sdcs** 3176116Sdcs** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 3276116Sdcs** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 3376116Sdcs** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 3476116Sdcs** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 3576116Sdcs** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 3676116Sdcs** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 3776116Sdcs** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 3876116Sdcs** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 3976116Sdcs** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 4076116Sdcs** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 4176116Sdcs** SUCH DAMAGE. 4276116Sdcs*/ 4340843Smsmith 4451786Sdcs/* $FreeBSD$ */ 4551786Sdcs 4640883Smsmith#ifdef TESTMAIN 4740883Smsmith#include <stdlib.h> 4840883Smsmith#include <stdio.h> 4940883Smsmith#include <ctype.h> 5040927Sjkh#include <fcntl.h> 5140883Smsmith#else 5240876Smsmith#include <stand.h> 5340883Smsmith#endif 5440843Smsmith#include <string.h> 5540843Smsmith#include "ficl.h" 5640843Smsmith#include "math64.h" 5740843Smsmith 5840843Smsmithstatic void colonParen(FICL_VM *pVM); 5940843Smsmithstatic void literalIm(FICL_VM *pVM); 6076116Sdcsstatic int ficlParseWord(FICL_VM *pVM, STRINGINFO si); 6140843Smsmith 6240843Smsmith/* 6340843Smsmith** Control structure building words use these 6440843Smsmith** strings' addresses as markers on the stack to 6540843Smsmith** check for structure completion. 6640843Smsmith*/ 6740843Smsmithstatic char doTag[] = "do"; 6840843Smsmithstatic char colonTag[] = "colon"; 6940843Smsmithstatic char leaveTag[] = "leave"; 7040843Smsmith 7151786Sdcsstatic char destTag[] = "target"; 7251786Sdcsstatic char origTag[] = "origin"; 7351786Sdcs 74167850Sjkimstatic char caseTag[] = "case"; 75167850Sjkimstatic char ofTag[] = "of"; 76167850Sjkimstatic char fallthroughTag[] = "fallthrough"; 77167850Sjkim 7840843Smsmith#if FICL_WANT_LOCALS 7960959Sdcsstatic void doLocalIm(FICL_VM *pVM); 8060959Sdcsstatic void do2LocalIm(FICL_VM *pVM); 8140843Smsmith#endif 8240843Smsmith 8360959Sdcs 8440843Smsmith/* 8540843Smsmith** C O N T R O L S T R U C T U R E B U I L D E R S 8640843Smsmith** 8740843Smsmith** Push current dict location for later branch resolution. 8840843Smsmith** The location may be either a branch target or a patch address... 8940843Smsmith*/ 9040843Smsmithstatic void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 9140843Smsmith{ 9276116Sdcs PUSHPTR(dp->here); 9376116Sdcs PUSHPTR(tag); 9440843Smsmith return; 9540843Smsmith} 9640843Smsmith 9740843Smsmithstatic void markControlTag(FICL_VM *pVM, char *tag) 9840843Smsmith{ 9976116Sdcs PUSHPTR(tag); 10040843Smsmith return; 10140843Smsmith} 10240843Smsmith 10340843Smsmithstatic void matchControlTag(FICL_VM *pVM, char *tag) 10440843Smsmith{ 10576116Sdcs char *cp; 10676116Sdcs#if FICL_ROBUST > 1 10776116Sdcs vmCheckStack(pVM, 1, 0); 10876116Sdcs#endif 10976116Sdcs cp = (char *)stackPopPtr(pVM->pStack); 11076116Sdcs /* 11176116Sdcs ** Changed the code below to compare the pointers first (by popular demand) 11276116Sdcs */ 11376116Sdcs if ( (cp != tag) && strcmp(cp, tag) ) 11440843Smsmith { 11551786Sdcs vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag); 11640843Smsmith } 11740843Smsmith 11840843Smsmith return; 11940843Smsmith} 12040843Smsmith 12140843Smsmith/* 12240843Smsmith** Expect a branch target address on the param stack, 12340843Smsmith** compile a literal offset from the current dict location 12440843Smsmith** to the target address 12540843Smsmith*/ 12640843Smsmithstatic void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 12740843Smsmith{ 12894290Sdcs FICL_INT offset; 12940843Smsmith CELL *patchAddr; 13040843Smsmith 13140843Smsmith matchControlTag(pVM, tag); 13240843Smsmith 13376116Sdcs#if FICL_ROBUST > 1 13476116Sdcs vmCheckStack(pVM, 1, 0); 13576116Sdcs#endif 13640843Smsmith patchAddr = (CELL *)stackPopPtr(pVM->pStack); 13740843Smsmith offset = patchAddr - dp->here; 13840843Smsmith dictAppendCell(dp, LVALUEtoCELL(offset)); 13940843Smsmith 14040843Smsmith return; 14140843Smsmith} 14240843Smsmith 14340843Smsmith 14440843Smsmith/* 14540843Smsmith** Expect a branch patch address on the param stack, 14640843Smsmith** compile a literal offset from the patch location 14740843Smsmith** to the current dict location 14840843Smsmith*/ 14940843Smsmithstatic void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 15040843Smsmith{ 15194290Sdcs FICL_INT offset; 15240843Smsmith CELL *patchAddr; 15340843Smsmith 15440843Smsmith matchControlTag(pVM, tag); 15540843Smsmith 15676116Sdcs#if FICL_ROBUST > 1 15776116Sdcs vmCheckStack(pVM, 1, 0); 15876116Sdcs#endif 15940843Smsmith patchAddr = (CELL *)stackPopPtr(pVM->pStack); 16040843Smsmith offset = dp->here - patchAddr; 16140843Smsmith *patchAddr = LVALUEtoCELL(offset); 16240843Smsmith 16340843Smsmith return; 16440843Smsmith} 16540843Smsmith 16640843Smsmith/* 16740843Smsmith** Match the tag to the top of the stack. If success, 16840843Smsmith** sopy "here" address into the cell whose address is next 16940843Smsmith** on the stack. Used by do..leave..loop. 17040843Smsmith*/ 17140843Smsmithstatic void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 17240843Smsmith{ 17340843Smsmith CELL *patchAddr; 17440843Smsmith char *cp; 17540843Smsmith 17676116Sdcs#if FICL_ROBUST > 1 17776116Sdcs vmCheckStack(pVM, 2, 0); 17876116Sdcs#endif 17940843Smsmith cp = stackPopPtr(pVM->pStack); 18076116Sdcs /* 18176116Sdcs ** Changed the comparison below to compare the pointers first (by popular demand) 18276116Sdcs */ 18376116Sdcs if ((cp != tag) && strcmp(cp, tag)) 18440843Smsmith { 18540843Smsmith vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); 18640843Smsmith vmTextOut(pVM, tag, 1); 18740843Smsmith } 18840843Smsmith 18940843Smsmith patchAddr = (CELL *)stackPopPtr(pVM->pStack); 19040843Smsmith *patchAddr = LVALUEtoCELL(dp->here); 19140843Smsmith 19240843Smsmith return; 19340843Smsmith} 19440843Smsmith 19540843Smsmith 19640843Smsmith/************************************************************************** 19776116Sdcs f i c l P a r s e N u m b e r 19840843Smsmith** Attempts to convert the NULL terminated string in the VM's pad to 19940843Smsmith** a number using the VM's current base. If successful, pushes the number 20040843Smsmith** onto the param stack and returns TRUE. Otherwise, returns FALSE. 20194290Sdcs** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See 20294290Sdcs** the standard for DOUBLE wordset. 20340843Smsmith**************************************************************************/ 20440843Smsmith 20576116Sdcsint ficlParseNumber(FICL_VM *pVM, STRINGINFO si) 20640843Smsmith{ 20776116Sdcs FICL_INT accum = 0; 20840843Smsmith char isNeg = FALSE; 20994290Sdcs char hasDP = FALSE; 21040843Smsmith unsigned base = pVM->base; 21140843Smsmith char *cp = SI_PTR(si); 21240843Smsmith FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); 21340843Smsmith unsigned ch; 21440843Smsmith unsigned digit; 21540843Smsmith 21676116Sdcs if (count > 1) 21740843Smsmith { 21876116Sdcs switch (*cp) 21976116Sdcs { 22076116Sdcs case '-': 22176116Sdcs cp++; 22276116Sdcs count--; 22376116Sdcs isNeg = TRUE; 22476116Sdcs break; 22576116Sdcs case '+': 22676116Sdcs cp++; 22776116Sdcs count--; 22876116Sdcs isNeg = FALSE; 22976116Sdcs break; 23076116Sdcs default: 23176116Sdcs break; 23276116Sdcs } 23340843Smsmith } 23440843Smsmith 23594290Sdcs if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */ 23694290Sdcs { 23794290Sdcs hasDP = TRUE; 23894290Sdcs count--; 23994290Sdcs } 24094290Sdcs 24194290Sdcs if (count == 0) /* detect "+", "-", ".", "+." etc */ 24240843Smsmith return FALSE; 24340843Smsmith 24476116Sdcs while ((count--) && ((ch = *cp++) != '\0')) 24540843Smsmith { 24676116Sdcs if (!isalnum(ch)) 24740843Smsmith return FALSE; 24840843Smsmith 24940843Smsmith digit = ch - '0'; 25040843Smsmith 25140843Smsmith if (digit > 9) 25240843Smsmith digit = tolower(ch) - 'a' + 10; 25351786Sdcs 25440843Smsmith if (digit >= base) 25540843Smsmith return FALSE; 25640843Smsmith 25740843Smsmith accum = accum * base + digit; 25840843Smsmith } 25940843Smsmith 26094290Sdcs if (hasDP) /* simple (required) DOUBLE support */ 26194290Sdcs PUSHINT(0); 26294290Sdcs 26340843Smsmith if (isNeg) 26451786Sdcs accum = -accum; 26540843Smsmith 26676116Sdcs PUSHINT(accum); 26776116Sdcs if (pVM->state == COMPILE) 26876116Sdcs literalIm(pVM); 26940843Smsmith 27040843Smsmith return TRUE; 27140843Smsmith} 27240843Smsmith 27340843Smsmith 27440843Smsmith/************************************************************************** 27540843Smsmith a d d & f r i e n d s 27640843Smsmith** 27740843Smsmith**************************************************************************/ 27840843Smsmith 27940843Smsmithstatic void add(FICL_VM *pVM) 28040843Smsmith{ 28151786Sdcs FICL_INT i; 28240843Smsmith#if FICL_ROBUST > 1 28340843Smsmith vmCheckStack(pVM, 2, 1); 28440843Smsmith#endif 28551786Sdcs i = stackPopINT(pVM->pStack); 28640843Smsmith i += stackGetTop(pVM->pStack).i; 28740843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 28840843Smsmith return; 28940843Smsmith} 29040843Smsmith 29140843Smsmithstatic void sub(FICL_VM *pVM) 29240843Smsmith{ 29351786Sdcs FICL_INT i; 29440843Smsmith#if FICL_ROBUST > 1 29540843Smsmith vmCheckStack(pVM, 2, 1); 29640843Smsmith#endif 29751786Sdcs i = stackPopINT(pVM->pStack); 29840843Smsmith i = stackGetTop(pVM->pStack).i - i; 29940843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 30040843Smsmith return; 30140843Smsmith} 30240843Smsmith 30340843Smsmithstatic void mul(FICL_VM *pVM) 30440843Smsmith{ 30551786Sdcs FICL_INT i; 30640843Smsmith#if FICL_ROBUST > 1 30740843Smsmith vmCheckStack(pVM, 2, 1); 30840843Smsmith#endif 30951786Sdcs i = stackPopINT(pVM->pStack); 31040843Smsmith i *= stackGetTop(pVM->pStack).i; 31140843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 31240843Smsmith return; 31340843Smsmith} 31440843Smsmith 31540843Smsmithstatic void negate(FICL_VM *pVM) 31640843Smsmith{ 31751786Sdcs FICL_INT i; 31840843Smsmith#if FICL_ROBUST > 1 31940843Smsmith vmCheckStack(pVM, 1, 1); 32040843Smsmith#endif 32151786Sdcs i = -stackPopINT(pVM->pStack); 32276116Sdcs PUSHINT(i); 32340843Smsmith return; 32440843Smsmith} 32540843Smsmith 32640843Smsmithstatic void ficlDiv(FICL_VM *pVM) 32740843Smsmith{ 32851786Sdcs FICL_INT i; 32940843Smsmith#if FICL_ROBUST > 1 33040843Smsmith vmCheckStack(pVM, 2, 1); 33140843Smsmith#endif 33251786Sdcs i = stackPopINT(pVM->pStack); 33340843Smsmith i = stackGetTop(pVM->pStack).i / i; 33440843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 33540843Smsmith return; 33640843Smsmith} 33740843Smsmith 33840843Smsmith/* 33940843Smsmith** slash-mod CORE ( n1 n2 -- n3 n4 ) 34040843Smsmith** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell 34140843Smsmith** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 34240843Smsmith** differ in sign, the implementation-defined result returned will be the 34340843Smsmith** same as that returned by either the phrase 34440843Smsmith** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . 34540843Smsmith** NOTE: Ficl complies with the second phrase (symmetric division) 34640843Smsmith*/ 34740843Smsmithstatic void slashMod(FICL_VM *pVM) 34840843Smsmith{ 34951786Sdcs DPINT n1; 35051786Sdcs FICL_INT n2; 35140843Smsmith INTQR qr; 35240843Smsmith 35340843Smsmith#if FICL_ROBUST > 1 35440843Smsmith vmCheckStack(pVM, 2, 2); 35540843Smsmith#endif 35651786Sdcs n2 = stackPopINT(pVM->pStack); 35751786Sdcs n1.lo = stackPopINT(pVM->pStack); 35840843Smsmith i64Extend(n1); 35940843Smsmith 36040843Smsmith qr = m64SymmetricDivI(n1, n2); 36176116Sdcs PUSHINT(qr.rem); 36276116Sdcs PUSHINT(qr.quot); 36340843Smsmith return; 36440843Smsmith} 36540843Smsmith 36640843Smsmithstatic void onePlus(FICL_VM *pVM) 36740843Smsmith{ 36851786Sdcs FICL_INT i; 36940843Smsmith#if FICL_ROBUST > 1 37040843Smsmith vmCheckStack(pVM, 1, 1); 37140843Smsmith#endif 37240843Smsmith i = stackGetTop(pVM->pStack).i; 37340843Smsmith i += 1; 37440843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 37540843Smsmith return; 37640843Smsmith} 37740843Smsmith 37840843Smsmithstatic void oneMinus(FICL_VM *pVM) 37940843Smsmith{ 38051786Sdcs FICL_INT i; 38140843Smsmith#if FICL_ROBUST > 1 38240843Smsmith vmCheckStack(pVM, 1, 1); 38340843Smsmith#endif 38440843Smsmith i = stackGetTop(pVM->pStack).i; 38540843Smsmith i -= 1; 38640843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 38740843Smsmith return; 38840843Smsmith} 38940843Smsmith 39040843Smsmithstatic void twoMul(FICL_VM *pVM) 39140843Smsmith{ 39251786Sdcs FICL_INT i; 39340843Smsmith#if FICL_ROBUST > 1 39440843Smsmith vmCheckStack(pVM, 1, 1); 39540843Smsmith#endif 39640843Smsmith i = stackGetTop(pVM->pStack).i; 39740843Smsmith i *= 2; 39840843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 39940843Smsmith return; 40040843Smsmith} 40140843Smsmith 40240843Smsmithstatic void twoDiv(FICL_VM *pVM) 40340843Smsmith{ 40451786Sdcs FICL_INT i; 40540843Smsmith#if FICL_ROBUST > 1 40640843Smsmith vmCheckStack(pVM, 1, 1); 40740843Smsmith#endif 40840843Smsmith i = stackGetTop(pVM->pStack).i; 40940843Smsmith i >>= 1; 41040843Smsmith stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 41140843Smsmith return; 41240843Smsmith} 41340843Smsmith 41440843Smsmithstatic void mulDiv(FICL_VM *pVM) 41540843Smsmith{ 41651786Sdcs FICL_INT x, y, z; 41751786Sdcs DPINT prod; 41840843Smsmith#if FICL_ROBUST > 1 41940843Smsmith vmCheckStack(pVM, 3, 1); 42040843Smsmith#endif 42151786Sdcs z = stackPopINT(pVM->pStack); 42251786Sdcs y = stackPopINT(pVM->pStack); 42351786Sdcs x = stackPopINT(pVM->pStack); 42440843Smsmith 42540843Smsmith prod = m64MulI(x,y); 42640843Smsmith x = m64SymmetricDivI(prod, z).quot; 42740843Smsmith 42876116Sdcs PUSHINT(x); 42940843Smsmith return; 43040843Smsmith} 43140843Smsmith 43240843Smsmith 43340843Smsmithstatic void mulDivRem(FICL_VM *pVM) 43440843Smsmith{ 43551786Sdcs FICL_INT x, y, z; 43651786Sdcs DPINT prod; 43740843Smsmith INTQR qr; 43840843Smsmith#if FICL_ROBUST > 1 43940843Smsmith vmCheckStack(pVM, 3, 2); 44040843Smsmith#endif 44151786Sdcs z = stackPopINT(pVM->pStack); 44251786Sdcs y = stackPopINT(pVM->pStack); 44351786Sdcs x = stackPopINT(pVM->pStack); 44440843Smsmith 44540843Smsmith prod = m64MulI(x,y); 44640843Smsmith qr = m64SymmetricDivI(prod, z); 44740843Smsmith 44876116Sdcs PUSHINT(qr.rem); 44976116Sdcs PUSHINT(qr.quot); 45040843Smsmith return; 45140843Smsmith} 45240843Smsmith 45340843Smsmith 45440843Smsmith/************************************************************************** 45540843Smsmith c o l o n d e f i n i t i o n s 45640843Smsmith** Code to begin compiling a colon definition 45740843Smsmith** This function sets the state to COMPILE, then creates a 45840843Smsmith** new word whose name is the next word in the input stream 45940843Smsmith** and whose code is colonParen. 46040843Smsmith**************************************************************************/ 46140843Smsmith 46240843Smsmithstatic void colon(FICL_VM *pVM) 46340843Smsmith{ 46494290Sdcs FICL_DICT *dp = vmGetDict(pVM); 46540843Smsmith STRINGINFO si = vmGetWord(pVM); 46640843Smsmith 46760014Sdcs dictCheckThreshold(dp); 46860014Sdcs 46940843Smsmith pVM->state = COMPILE; 47040843Smsmith markControlTag(pVM, colonTag); 47140843Smsmith dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 47240843Smsmith#if FICL_WANT_LOCALS 47394290Sdcs pVM->pSys->nLocals = 0; 47440843Smsmith#endif 47540843Smsmith return; 47640843Smsmith} 47740843Smsmith 47840843Smsmith 47940843Smsmith/************************************************************************** 48040843Smsmith c o l o n P a r e n 48140843Smsmith** This is the code that executes a colon definition. It assumes that the 48240843Smsmith** virtual machine is running a "next" loop (See the vm.c 48340843Smsmith** for its implementation of member function vmExecute()). The colon 48440843Smsmith** code simply copies the address of the first word in the list of words 48540843Smsmith** to interpret into IP after saving its old value. When we return to the 48640843Smsmith** "next" loop, the virtual machine will call the code for each word in 48740843Smsmith** turn. 48840843Smsmith** 48940843Smsmith**************************************************************************/ 49040843Smsmith 49140843Smsmithstatic void colonParen(FICL_VM *pVM) 49240843Smsmith{ 49340843Smsmith IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param); 49440843Smsmith vmPushIP(pVM, tempIP); 49540843Smsmith 49640843Smsmith return; 49740843Smsmith} 49840843Smsmith 49940843Smsmith 50040843Smsmith/************************************************************************** 50140843Smsmith s e m i c o l o n C o I m 50240843Smsmith** 50340843Smsmith** IMMEDIATE code for ";". This function sets the state to INTERPRET and 50440843Smsmith** terminates a word under compilation by appending code for "(;)" to 50540843Smsmith** the definition. TO DO: checks for leftover branch target tags on the 50640843Smsmith** return stack and complains if any are found. 50740843Smsmith**************************************************************************/ 50840843Smsmithstatic void semiParen(FICL_VM *pVM) 50940843Smsmith{ 51040843Smsmith vmPopIP(pVM); 51140843Smsmith return; 51240843Smsmith} 51340843Smsmith 51440843Smsmith 51540843Smsmithstatic void semicolonCoIm(FICL_VM *pVM) 51640843Smsmith{ 51794290Sdcs FICL_DICT *dp = vmGetDict(pVM); 51840843Smsmith 51994290Sdcs assert(pVM->pSys->pSemiParen); 52040843Smsmith matchControlTag(pVM, colonTag); 52140843Smsmith 52240843Smsmith#if FICL_WANT_LOCALS 52394290Sdcs assert(pVM->pSys->pUnLinkParen); 52494290Sdcs if (pVM->pSys->nLocals > 0) 52540843Smsmith { 52694290Sdcs FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 52740843Smsmith dictEmpty(pLoc, pLoc->pForthWords->size); 52894290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); 52940843Smsmith } 53094290Sdcs pVM->pSys->nLocals = 0; 53140843Smsmith#endif 53240843Smsmith 53394290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen)); 53440843Smsmith pVM->state = INTERPRET; 53540843Smsmith dictUnsmudge(dp); 53640843Smsmith return; 53740843Smsmith} 53840843Smsmith 53940843Smsmith 54040843Smsmith/************************************************************************** 54140843Smsmith e x i t 54240843Smsmith** CORE 54340843Smsmith** This function simply pops the previous instruction 54440843Smsmith** pointer and returns to the "next" loop. Used for exiting from within 54540843Smsmith** a definition. Note that exitParen is identical to semiParen - they 54640843Smsmith** are in two different functions so that "see" can correctly identify 54740843Smsmith** the end of a colon definition, even if it uses "exit". 54840843Smsmith**************************************************************************/ 54940843Smsmithstatic void exitParen(FICL_VM *pVM) 55040843Smsmith{ 55140843Smsmith vmPopIP(pVM); 55240843Smsmith return; 55340843Smsmith} 55440843Smsmith 55540843Smsmithstatic void exitCoIm(FICL_VM *pVM) 55640843Smsmith{ 55794290Sdcs FICL_DICT *dp = vmGetDict(pVM); 55894290Sdcs assert(pVM->pSys->pExitParen); 55940843Smsmith IGNORE(pVM); 56040843Smsmith 56140843Smsmith#if FICL_WANT_LOCALS 56294290Sdcs if (pVM->pSys->nLocals > 0) 56340843Smsmith { 56494290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); 56540843Smsmith } 56640843Smsmith#endif 56794290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen)); 56840843Smsmith return; 56940843Smsmith} 57040843Smsmith 57140843Smsmith 57240843Smsmith/************************************************************************** 57340843Smsmith c o n s t a n t P a r e n 57440843Smsmith** This is the run-time code for "constant". It simply returns the 57540843Smsmith** contents of its word's first data cell. 57640843Smsmith** 57740843Smsmith**************************************************************************/ 57840843Smsmith 57940843Smsmithvoid constantParen(FICL_VM *pVM) 58040843Smsmith{ 58140843Smsmith FICL_WORD *pFW = pVM->runningWord; 58240843Smsmith#if FICL_ROBUST > 1 58340843Smsmith vmCheckStack(pVM, 0, 1); 58440843Smsmith#endif 58540843Smsmith stackPush(pVM->pStack, pFW->param[0]); 58640843Smsmith return; 58740843Smsmith} 58840843Smsmith 58940843Smsmithvoid twoConstParen(FICL_VM *pVM) 59040843Smsmith{ 59140843Smsmith FICL_WORD *pFW = pVM->runningWord; 59240843Smsmith#if FICL_ROBUST > 1 59340843Smsmith vmCheckStack(pVM, 0, 2); 59440843Smsmith#endif 59540843Smsmith stackPush(pVM->pStack, pFW->param[0]); /* lo */ 59640843Smsmith stackPush(pVM->pStack, pFW->param[1]); /* hi */ 59740843Smsmith return; 59840843Smsmith} 59940843Smsmith 60040843Smsmith 60140843Smsmith/************************************************************************** 60240843Smsmith c o n s t a n t 60340843Smsmith** IMMEDIATE 60440843Smsmith** Compiles a constant into the dictionary. Constants return their 60540843Smsmith** value when invoked. Expects a value on top of the parm stack. 60640843Smsmith**************************************************************************/ 60740843Smsmith 60840843Smsmithstatic void constant(FICL_VM *pVM) 60940843Smsmith{ 61094290Sdcs FICL_DICT *dp = vmGetDict(pVM); 61140843Smsmith STRINGINFO si = vmGetWord(pVM); 61240843Smsmith 61340843Smsmith#if FICL_ROBUST > 1 61440843Smsmith vmCheckStack(pVM, 1, 0); 61540843Smsmith#endif 61640843Smsmith dictAppendWord2(dp, si, constantParen, FW_DEFAULT); 61740843Smsmith dictAppendCell(dp, stackPop(pVM->pStack)); 61840843Smsmith return; 61940843Smsmith} 62040843Smsmith 62140843Smsmith 62240843Smsmithstatic void twoConstant(FICL_VM *pVM) 62340843Smsmith{ 62494290Sdcs FICL_DICT *dp = vmGetDict(pVM); 62540843Smsmith STRINGINFO si = vmGetWord(pVM); 62640843Smsmith CELL c; 62740843Smsmith 62840843Smsmith#if FICL_ROBUST > 1 62940843Smsmith vmCheckStack(pVM, 2, 0); 63040843Smsmith#endif 63140843Smsmith c = stackPop(pVM->pStack); 63240843Smsmith dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT); 63340843Smsmith dictAppendCell(dp, stackPop(pVM->pStack)); 63440843Smsmith dictAppendCell(dp, c); 63540843Smsmith return; 63640843Smsmith} 63740843Smsmith 63840843Smsmith 63940843Smsmith/************************************************************************** 64040843Smsmith d i s p l a y C e l l 64140843Smsmith** Drop and print the contents of the cell at the top of the param 64240843Smsmith** stack 64340843Smsmith**************************************************************************/ 64440843Smsmith 64540843Smsmithstatic void displayCell(FICL_VM *pVM) 64640843Smsmith{ 64740843Smsmith CELL c; 64840843Smsmith#if FICL_ROBUST > 1 64940843Smsmith vmCheckStack(pVM, 1, 0); 65040843Smsmith#endif 65140843Smsmith c = stackPop(pVM->pStack); 65240843Smsmith ltoa((c).i, pVM->pad, pVM->base); 65340843Smsmith strcat(pVM->pad, " "); 65440843Smsmith vmTextOut(pVM, pVM->pad, 0); 65540843Smsmith return; 65640843Smsmith} 65740843Smsmith 65840843Smsmithstatic void uDot(FICL_VM *pVM) 65940843Smsmith{ 66051786Sdcs FICL_UNS u; 66140843Smsmith#if FICL_ROBUST > 1 66240843Smsmith vmCheckStack(pVM, 1, 0); 66340843Smsmith#endif 66451786Sdcs u = stackPopUNS(pVM->pStack); 66540843Smsmith ultoa(u, pVM->pad, pVM->base); 66640843Smsmith strcat(pVM->pad, " "); 66740843Smsmith vmTextOut(pVM, pVM->pad, 0); 66840843Smsmith return; 66940843Smsmith} 67040843Smsmith 67140843Smsmith 67240843Smsmithstatic void hexDot(FICL_VM *pVM) 67340843Smsmith{ 67451786Sdcs FICL_UNS u; 67540843Smsmith#if FICL_ROBUST > 1 67640843Smsmith vmCheckStack(pVM, 1, 0); 67740843Smsmith#endif 67851786Sdcs u = stackPopUNS(pVM->pStack); 67940843Smsmith ultoa(u, pVM->pad, 16); 68040843Smsmith strcat(pVM->pad, " "); 68140843Smsmith vmTextOut(pVM, pVM->pad, 0); 68240843Smsmith return; 68340843Smsmith} 68440843Smsmith 68540843Smsmith 68640843Smsmith/************************************************************************** 68794290Sdcs s t r l e n 68894290Sdcs** FICL ( c-string -- length ) 68994290Sdcs** 69094290Sdcs** Returns the length of a C-style (zero-terminated) string. 69194290Sdcs** 69294290Sdcs** --lch 69394290Sdcs**/ 69494290Sdcsstatic void ficlStrlen(FICL_VM *ficlVM) 69594290Sdcs { 69694290Sdcs char *address = (char *)stackPopPtr(ficlVM->pStack); 69794290Sdcs stackPushINT(ficlVM->pStack, strlen(address)); 69894290Sdcs } 69994290Sdcs 70094290Sdcs 70194290Sdcs/************************************************************************** 70294290Sdcs s p r i n t f 70394290Sdcs** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag ) 70494290Sdcs** Similar to the C sprintf() function. It formats into a buffer based on 70594290Sdcs** a "format" string. Each character in the format string is copied verbatim 70694290Sdcs** to the output buffer, until SPRINTF encounters a percent sign ("%"). 70794290Sdcs** SPRINTF then skips the percent sign, and examines the next character 70894290Sdcs** (the "format character"). Here are the valid format characters: 70994290Sdcs** s - read a C-ADDR U-LENGTH string from the stack and copy it to 71094290Sdcs** the buffer 71194290Sdcs** d - read a cell from the stack, format it as a string (base-10, 71294290Sdcs** signed), and copy it to the buffer 71394290Sdcs** x - same as d, except in base-16 71494290Sdcs** u - same as d, but unsigned 71594290Sdcs** % - output a literal percent-sign to the buffer 71694290Sdcs** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes 71794290Sdcs** written, and a flag indicating whether or not it ran out of space while 71894290Sdcs** writing to the output buffer (TRUE if it ran out of space). 71994290Sdcs** 72094290Sdcs** If SPRINTF runs out of space in the buffer to store the formatted string, 72194290Sdcs** it still continues parsing, in an effort to preserve your stack (otherwise 72294290Sdcs** it might leave uneaten arguments behind). 72394290Sdcs** 72494290Sdcs** --lch 72594290Sdcs**************************************************************************/ 72694290Sdcsstatic void ficlSprintf(FICL_VM *pVM) /* */ 72794290Sdcs{ 72894290Sdcs int bufferLength = stackPopINT(pVM->pStack); 72994290Sdcs char *buffer = (char *)stackPopPtr(pVM->pStack); 73094290Sdcs char *bufferStart = buffer; 73194290Sdcs 73294290Sdcs int formatLength = stackPopINT(pVM->pStack); 73394290Sdcs char *format = (char *)stackPopPtr(pVM->pStack); 73494290Sdcs char *formatStop = format + formatLength; 73594290Sdcs 73694290Sdcs int base = 10; 73794290Sdcs int unsignedInteger = FALSE; 73894290Sdcs 739102657Sscottl FICL_INT append = FICL_TRUE; 74094290Sdcs 74194290Sdcs while (format < formatStop) 74294290Sdcs { 74394290Sdcs char scratch[64]; 74494290Sdcs char *source; 74594290Sdcs int actualLength; 74694290Sdcs int desiredLength; 74794290Sdcs int leadingZeroes; 74894290Sdcs 74994290Sdcs 75094290Sdcs if (*format != '%') 75194290Sdcs { 75294290Sdcs source = format; 75394290Sdcs actualLength = desiredLength = 1; 75494290Sdcs leadingZeroes = 0; 75594290Sdcs } 75694290Sdcs else 75794290Sdcs { 75894290Sdcs format++; 75994290Sdcs if (format == formatStop) 76094290Sdcs break; 76194290Sdcs 76294290Sdcs leadingZeroes = (*format == '0'); 76394290Sdcs if (leadingZeroes) 76494290Sdcs { 76594290Sdcs format++; 76694290Sdcs if (format == formatStop) 76794290Sdcs break; 76894290Sdcs } 76994290Sdcs 77094290Sdcs desiredLength = isdigit(*format); 77194290Sdcs if (desiredLength) 77294290Sdcs { 77394290Sdcs desiredLength = strtol(format, &format, 10); 77494290Sdcs if (format == formatStop) 77594290Sdcs break; 77694290Sdcs } 77794290Sdcs else if (*format == '*') 77894290Sdcs { 77994290Sdcs desiredLength = stackPopINT(pVM->pStack); 78094290Sdcs format++; 78194290Sdcs if (format == formatStop) 78294290Sdcs break; 78394290Sdcs } 78494290Sdcs 78594290Sdcs 78694290Sdcs switch (*format) 78794290Sdcs { 78894290Sdcs case 's': 78994290Sdcs case 'S': 79094290Sdcs { 79194290Sdcs actualLength = stackPopINT(pVM->pStack); 79294290Sdcs source = (char *)stackPopPtr(pVM->pStack); 79394290Sdcs break; 79494290Sdcs } 79594290Sdcs case 'x': 79694290Sdcs case 'X': 79794290Sdcs base = 16; 79894290Sdcs case 'u': 79994290Sdcs case 'U': 80094290Sdcs unsignedInteger = TRUE; 80194290Sdcs case 'd': 80294290Sdcs case 'D': 80394290Sdcs { 80494290Sdcs int integer = stackPopINT(pVM->pStack); 80594290Sdcs if (unsignedInteger) 80694290Sdcs ultoa(integer, scratch, base); 80794290Sdcs else 80894290Sdcs ltoa(integer, scratch, base); 80994290Sdcs base = 10; 81094290Sdcs unsignedInteger = FALSE; 81194290Sdcs source = scratch; 81294290Sdcs actualLength = strlen(scratch); 81394290Sdcs break; 81494290Sdcs } 81594290Sdcs case '%': 81694290Sdcs source = format; 81794290Sdcs actualLength = 1; 81894290Sdcs default: 81994290Sdcs continue; 82094290Sdcs } 82194290Sdcs } 82294290Sdcs 823102657Sscottl if (append != FICL_FALSE) 82494290Sdcs { 82594290Sdcs if (!desiredLength) 82694290Sdcs desiredLength = actualLength; 82794290Sdcs if (desiredLength > bufferLength) 82894290Sdcs { 82994290Sdcs append = FICL_FALSE; 83094290Sdcs desiredLength = bufferLength; 83194290Sdcs } 83294290Sdcs while (desiredLength > actualLength) 83394290Sdcs { 83494290Sdcs *buffer++ = (char)((leadingZeroes) ? '0' : ' '); 83594290Sdcs bufferLength--; 83694290Sdcs desiredLength--; 83794290Sdcs } 83894290Sdcs memcpy(buffer, source, actualLength); 83994290Sdcs buffer += actualLength; 84094290Sdcs bufferLength -= actualLength; 84194290Sdcs } 84294290Sdcs 84394290Sdcs format++; 84494290Sdcs } 84594290Sdcs 84694290Sdcs stackPushPtr(pVM->pStack, bufferStart); 84794290Sdcs stackPushINT(pVM->pStack, buffer - bufferStart); 84894290Sdcs stackPushINT(pVM->pStack, append); 84994290Sdcs} 85094290Sdcs 85194290Sdcs 85294290Sdcs/************************************************************************** 85340843Smsmith d u p & f r i e n d s 85440843Smsmith** 85540843Smsmith**************************************************************************/ 85640843Smsmith 85740843Smsmithstatic void depth(FICL_VM *pVM) 85840843Smsmith{ 85940843Smsmith int i; 86040843Smsmith#if FICL_ROBUST > 1 86140843Smsmith vmCheckStack(pVM, 0, 1); 86240843Smsmith#endif 86340843Smsmith i = stackDepth(pVM->pStack); 86476116Sdcs PUSHINT(i); 86540843Smsmith return; 86640843Smsmith} 86740843Smsmith 86840843Smsmith 86940843Smsmithstatic void drop(FICL_VM *pVM) 87040843Smsmith{ 87140843Smsmith#if FICL_ROBUST > 1 87240843Smsmith vmCheckStack(pVM, 1, 0); 87340843Smsmith#endif 87440843Smsmith stackDrop(pVM->pStack, 1); 87540843Smsmith return; 87640843Smsmith} 87740843Smsmith 87840843Smsmith 87940843Smsmithstatic void twoDrop(FICL_VM *pVM) 88040843Smsmith{ 88140843Smsmith#if FICL_ROBUST > 1 88240843Smsmith vmCheckStack(pVM, 2, 0); 88340843Smsmith#endif 88440843Smsmith stackDrop(pVM->pStack, 2); 88540843Smsmith return; 88640843Smsmith} 88740843Smsmith 88840843Smsmith 88940843Smsmithstatic void dup(FICL_VM *pVM) 89040843Smsmith{ 89140843Smsmith#if FICL_ROBUST > 1 89240843Smsmith vmCheckStack(pVM, 1, 2); 89340843Smsmith#endif 89440843Smsmith stackPick(pVM->pStack, 0); 89540843Smsmith return; 89640843Smsmith} 89740843Smsmith 89840843Smsmith 89940843Smsmithstatic void twoDup(FICL_VM *pVM) 90040843Smsmith{ 90140843Smsmith#if FICL_ROBUST > 1 90240843Smsmith vmCheckStack(pVM, 2, 4); 90340843Smsmith#endif 90440843Smsmith stackPick(pVM->pStack, 1); 90540843Smsmith stackPick(pVM->pStack, 1); 90640843Smsmith return; 90740843Smsmith} 90840843Smsmith 90940843Smsmith 91040843Smsmithstatic void over(FICL_VM *pVM) 91140843Smsmith{ 91240843Smsmith#if FICL_ROBUST > 1 91340843Smsmith vmCheckStack(pVM, 2, 3); 91440843Smsmith#endif 91540843Smsmith stackPick(pVM->pStack, 1); 91640843Smsmith return; 91740843Smsmith} 91840843Smsmith 91940843Smsmithstatic void twoOver(FICL_VM *pVM) 92040843Smsmith{ 92140843Smsmith#if FICL_ROBUST > 1 92240843Smsmith vmCheckStack(pVM, 4, 6); 92340843Smsmith#endif 92440843Smsmith stackPick(pVM->pStack, 3); 92540843Smsmith stackPick(pVM->pStack, 3); 92640843Smsmith return; 92740843Smsmith} 92840843Smsmith 92940843Smsmith 93040843Smsmithstatic void pick(FICL_VM *pVM) 93140843Smsmith{ 93240843Smsmith CELL c = stackPop(pVM->pStack); 93340843Smsmith#if FICL_ROBUST > 1 93440843Smsmith vmCheckStack(pVM, c.i+1, c.i+2); 93540843Smsmith#endif 93640843Smsmith stackPick(pVM->pStack, c.i); 93740843Smsmith return; 93840843Smsmith} 93940843Smsmith 94040843Smsmith 94140843Smsmithstatic void questionDup(FICL_VM *pVM) 94240843Smsmith{ 94340843Smsmith CELL c; 94440843Smsmith#if FICL_ROBUST > 1 94540843Smsmith vmCheckStack(pVM, 1, 2); 94640843Smsmith#endif 94740843Smsmith c = stackGetTop(pVM->pStack); 94840843Smsmith 94940843Smsmith if (c.i != 0) 95040843Smsmith stackPick(pVM->pStack, 0); 95140843Smsmith 95240843Smsmith return; 95340843Smsmith} 95440843Smsmith 95540843Smsmith 95640843Smsmithstatic void roll(FICL_VM *pVM) 95740843Smsmith{ 95840843Smsmith int i = stackPop(pVM->pStack).i; 95940843Smsmith i = (i > 0) ? i : 0; 96040843Smsmith#if FICL_ROBUST > 1 96140843Smsmith vmCheckStack(pVM, i+1, i+1); 96240843Smsmith#endif 96340843Smsmith stackRoll(pVM->pStack, i); 96440843Smsmith return; 96540843Smsmith} 96640843Smsmith 96740843Smsmith 96840843Smsmithstatic void minusRoll(FICL_VM *pVM) 96940843Smsmith{ 97040843Smsmith int i = stackPop(pVM->pStack).i; 97140843Smsmith i = (i > 0) ? i : 0; 97240843Smsmith#if FICL_ROBUST > 1 97340843Smsmith vmCheckStack(pVM, i+1, i+1); 97440843Smsmith#endif 97540843Smsmith stackRoll(pVM->pStack, -i); 97640843Smsmith return; 97740843Smsmith} 97840843Smsmith 97940843Smsmith 98040843Smsmithstatic void rot(FICL_VM *pVM) 98140843Smsmith{ 98240843Smsmith#if FICL_ROBUST > 1 98340843Smsmith vmCheckStack(pVM, 3, 3); 98440843Smsmith#endif 98540843Smsmith stackRoll(pVM->pStack, 2); 98640843Smsmith return; 98740843Smsmith} 98840843Smsmith 98940843Smsmith 99040843Smsmithstatic void swap(FICL_VM *pVM) 99140843Smsmith{ 99240843Smsmith#if FICL_ROBUST > 1 99340843Smsmith vmCheckStack(pVM, 2, 2); 99440843Smsmith#endif 99540843Smsmith stackRoll(pVM->pStack, 1); 99640843Smsmith return; 99740843Smsmith} 99840843Smsmith 99940843Smsmith 100040843Smsmithstatic void twoSwap(FICL_VM *pVM) 100140843Smsmith{ 100240843Smsmith#if FICL_ROBUST > 1 100340843Smsmith vmCheckStack(pVM, 4, 4); 100440843Smsmith#endif 100540843Smsmith stackRoll(pVM->pStack, 3); 100640843Smsmith stackRoll(pVM->pStack, 3); 100740843Smsmith return; 100840843Smsmith} 100940843Smsmith 101040843Smsmith 101140843Smsmith/************************************************************************** 101240843Smsmith e m i t & f r i e n d s 101340843Smsmith** 101440843Smsmith**************************************************************************/ 101540843Smsmith 101640843Smsmithstatic void emit(FICL_VM *pVM) 101740843Smsmith{ 101840843Smsmith char *cp = pVM->pad; 101940843Smsmith int i; 102040843Smsmith 102140843Smsmith#if FICL_ROBUST > 1 102240843Smsmith vmCheckStack(pVM, 1, 0); 102340843Smsmith#endif 102451786Sdcs i = stackPopINT(pVM->pStack); 102540843Smsmith cp[0] = (char)i; 102640843Smsmith cp[1] = '\0'; 102740843Smsmith vmTextOut(pVM, cp, 0); 102840843Smsmith return; 102940843Smsmith} 103040843Smsmith 103140843Smsmith 103240843Smsmithstatic void cr(FICL_VM *pVM) 103340843Smsmith{ 103440843Smsmith vmTextOut(pVM, "", 1); 103540843Smsmith return; 103640843Smsmith} 103740843Smsmith 103840843Smsmith 103940843Smsmithstatic void commentLine(FICL_VM *pVM) 104040843Smsmith{ 104151786Sdcs char *cp = vmGetInBuf(pVM); 104251786Sdcs char *pEnd = vmGetInBufEnd(pVM); 104340843Smsmith char ch = *cp; 104440843Smsmith 104551786Sdcs while ((cp != pEnd) && (ch != '\r') && (ch != '\n')) 104640843Smsmith { 104740843Smsmith ch = *++cp; 104840843Smsmith } 104940843Smsmith 105040843Smsmith /* 105140843Smsmith ** Cope with DOS or UNIX-style EOLs - 105240843Smsmith ** Check for /r, /n, /r/n, or /n/r end-of-line sequences, 105340843Smsmith ** and point cp to next char. If EOL is \0, we're done. 105440843Smsmith */ 105551786Sdcs if (cp != pEnd) 105640843Smsmith { 105740843Smsmith cp++; 105840843Smsmith 105951786Sdcs if ( (cp != pEnd) && (ch != *cp) 106040843Smsmith && ((*cp == '\r') || (*cp == '\n')) ) 106140843Smsmith cp++; 106240843Smsmith } 106340843Smsmith 106440843Smsmith vmUpdateTib(pVM, cp); 106540843Smsmith return; 106640843Smsmith} 106740843Smsmith 106840843Smsmith 106940843Smsmith/* 107040843Smsmith** paren CORE 107140843Smsmith** Compilation: Perform the execution semantics given below. 107240843Smsmith** Execution: ( "ccc<paren>" -- ) 107340843Smsmith** Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 107440843Smsmith** The number of characters in ccc may be zero to the number of characters 107540843Smsmith** in the parse area. 107640843Smsmith** 107740843Smsmith*/ 107840843Smsmithstatic void commentHang(FICL_VM *pVM) 107940843Smsmith{ 108060959Sdcs vmParseStringEx(pVM, ')', 0); 108140843Smsmith return; 108240843Smsmith} 108340843Smsmith 108440843Smsmith 108540843Smsmith/************************************************************************** 108640843Smsmith F E T C H & S T O R E 108740843Smsmith** 108840843Smsmith**************************************************************************/ 108940843Smsmith 109040843Smsmithstatic void fetch(FICL_VM *pVM) 109140843Smsmith{ 109240843Smsmith CELL *pCell; 109340843Smsmith#if FICL_ROBUST > 1 109440843Smsmith vmCheckStack(pVM, 1, 1); 109540843Smsmith#endif 109640843Smsmith pCell = (CELL *)stackPopPtr(pVM->pStack); 109740843Smsmith stackPush(pVM->pStack, *pCell); 109840843Smsmith return; 109940843Smsmith} 110040843Smsmith 110140843Smsmith/* 110240843Smsmith** two-fetch CORE ( a-addr -- x1 x2 ) 110340843Smsmith** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and 110440843Smsmith** x1 at the next consecutive cell. It is equivalent to the sequence 110540843Smsmith** DUP CELL+ @ SWAP @ . 110640843Smsmith*/ 110740843Smsmithstatic void twoFetch(FICL_VM *pVM) 110840843Smsmith{ 110940843Smsmith CELL *pCell; 111040843Smsmith#if FICL_ROBUST > 1 111140843Smsmith vmCheckStack(pVM, 1, 2); 111240843Smsmith#endif 111340843Smsmith pCell = (CELL *)stackPopPtr(pVM->pStack); 111440843Smsmith stackPush(pVM->pStack, *pCell++); 111540843Smsmith stackPush(pVM->pStack, *pCell); 111640843Smsmith swap(pVM); 111740843Smsmith return; 111840843Smsmith} 111940843Smsmith 112040843Smsmith/* 112140843Smsmith** store CORE ( x a-addr -- ) 112240843Smsmith** Store x at a-addr. 112340843Smsmith*/ 112440843Smsmithstatic void store(FICL_VM *pVM) 112540843Smsmith{ 112640843Smsmith CELL *pCell; 112740843Smsmith#if FICL_ROBUST > 1 112840843Smsmith vmCheckStack(pVM, 2, 0); 112940843Smsmith#endif 113040843Smsmith pCell = (CELL *)stackPopPtr(pVM->pStack); 113140843Smsmith *pCell = stackPop(pVM->pStack); 113240843Smsmith} 113340843Smsmith 113440843Smsmith/* 113540843Smsmith** two-store CORE ( x1 x2 a-addr -- ) 113640843Smsmith** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the 113740843Smsmith** next consecutive cell. It is equivalent to the sequence 113840843Smsmith** SWAP OVER ! CELL+ ! . 113940843Smsmith*/ 114040843Smsmithstatic void twoStore(FICL_VM *pVM) 114140843Smsmith{ 114240843Smsmith CELL *pCell; 114340843Smsmith#if FICL_ROBUST > 1 114440843Smsmith vmCheckStack(pVM, 3, 0); 114540843Smsmith#endif 114640843Smsmith pCell = (CELL *)stackPopPtr(pVM->pStack); 114740843Smsmith *pCell++ = stackPop(pVM->pStack); 114840843Smsmith *pCell = stackPop(pVM->pStack); 114940843Smsmith} 115040843Smsmith 115140843Smsmithstatic void plusStore(FICL_VM *pVM) 115240843Smsmith{ 115340843Smsmith CELL *pCell; 115440843Smsmith#if FICL_ROBUST > 1 115540843Smsmith vmCheckStack(pVM, 2, 0); 115640843Smsmith#endif 115740843Smsmith pCell = (CELL *)stackPopPtr(pVM->pStack); 115840843Smsmith pCell->i += stackPop(pVM->pStack).i; 115940843Smsmith} 116040843Smsmith 116140843Smsmith 116276116Sdcsstatic void quadFetch(FICL_VM *pVM) 116361149Sdcs{ 116461149Sdcs UNS32 *pw; 116561149Sdcs#if FICL_ROBUST > 1 116661149Sdcs vmCheckStack(pVM, 1, 1); 116761149Sdcs#endif 116861182Sdcs pw = (UNS32 *)stackPopPtr(pVM->pStack); 116976116Sdcs PUSHUNS((FICL_UNS)*pw); 117061149Sdcs return; 117161149Sdcs} 117261149Sdcs 117376116Sdcsstatic void quadStore(FICL_VM *pVM) 117461149Sdcs{ 117561149Sdcs UNS32 *pw; 117661149Sdcs#if FICL_ROBUST > 1 117761149Sdcs vmCheckStack(pVM, 2, 0); 117861149Sdcs#endif 117961149Sdcs pw = (UNS32 *)stackPopPtr(pVM->pStack); 118061149Sdcs *pw = (UNS32)(stackPop(pVM->pStack).u); 118161149Sdcs} 118261149Sdcs 118340843Smsmithstatic void wFetch(FICL_VM *pVM) 118440843Smsmith{ 118540843Smsmith UNS16 *pw; 118640843Smsmith#if FICL_ROBUST > 1 118740843Smsmith vmCheckStack(pVM, 1, 1); 118840843Smsmith#endif 118940843Smsmith pw = (UNS16 *)stackPopPtr(pVM->pStack); 119076116Sdcs PUSHUNS((FICL_UNS)*pw); 119140843Smsmith return; 119240843Smsmith} 119340843Smsmith 119440843Smsmithstatic void wStore(FICL_VM *pVM) 119540843Smsmith{ 119640843Smsmith UNS16 *pw; 119740843Smsmith#if FICL_ROBUST > 1 119840843Smsmith vmCheckStack(pVM, 2, 0); 119940843Smsmith#endif 120040843Smsmith pw = (UNS16 *)stackPopPtr(pVM->pStack); 120140843Smsmith *pw = (UNS16)(stackPop(pVM->pStack).u); 120240843Smsmith} 120340843Smsmith 120440843Smsmithstatic void cFetch(FICL_VM *pVM) 120540843Smsmith{ 120640843Smsmith UNS8 *pc; 120740843Smsmith#if FICL_ROBUST > 1 120840843Smsmith vmCheckStack(pVM, 1, 1); 120940843Smsmith#endif 121040843Smsmith pc = (UNS8 *)stackPopPtr(pVM->pStack); 121176116Sdcs PUSHUNS((FICL_UNS)*pc); 121240843Smsmith return; 121340843Smsmith} 121440843Smsmith 121540843Smsmithstatic void cStore(FICL_VM *pVM) 121640843Smsmith{ 121740843Smsmith UNS8 *pc; 121840843Smsmith#if FICL_ROBUST > 1 121940843Smsmith vmCheckStack(pVM, 2, 0); 122040843Smsmith#endif 122140843Smsmith pc = (UNS8 *)stackPopPtr(pVM->pStack); 122240843Smsmith *pc = (UNS8)(stackPop(pVM->pStack).u); 122340843Smsmith} 122440843Smsmith 122540843Smsmith 122640843Smsmith/************************************************************************** 1227167850Sjkim b r a n c h P a r e n 1228167850Sjkim** 1229167850Sjkim** Runtime for "(branch)" -- expects a literal offset in the next 1230167850Sjkim** compilation address, and branches to that location. 123140843Smsmith**************************************************************************/ 123240843Smsmith 1233167850Sjkimstatic void branchParen(FICL_VM *pVM) 123440843Smsmith{ 1235167850Sjkim vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); 123640843Smsmith return; 123740843Smsmith} 123840843Smsmith 123940843Smsmith 124040843Smsmith/************************************************************************** 1241167850Sjkim b r a n c h 0 1242167850Sjkim** Runtime code for "(branch0)"; pop a flag from the stack, 1243167850Sjkim** branch if 0. fall through otherwise. The heart of "if" and "until". 124440843Smsmith**************************************************************************/ 124540843Smsmith 1246167850Sjkimstatic void branch0(FICL_VM *pVM) 124740843Smsmith{ 124851786Sdcs FICL_UNS flag; 124940843Smsmith 125040843Smsmith#if FICL_ROBUST > 1 125140843Smsmith vmCheckStack(pVM, 1, 0); 125240843Smsmith#endif 125351786Sdcs flag = stackPopUNS(pVM->pStack); 125440843Smsmith 125540843Smsmith if (flag) 125640843Smsmith { /* fall through */ 125740843Smsmith vmBranchRelative(pVM, 1); 125840843Smsmith } 125940843Smsmith else 126040843Smsmith { /* take branch (to else/endif/begin) */ 1261102657Sscottl vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); 126240843Smsmith } 126340843Smsmith 126440843Smsmith return; 126540843Smsmith} 126640843Smsmith 126740843Smsmith 126840843Smsmith/************************************************************************** 1269167850Sjkim i f C o I m 1270167850Sjkim** IMMEDIATE COMPILE-ONLY 1271167850Sjkim** Compiles code for a conditional branch into the dictionary 1272167850Sjkim** and pushes the branch patch address on the stack for later 1273167850Sjkim** patching by ELSE or THEN/ENDIF. 1274167850Sjkim**************************************************************************/ 1275167850Sjkim 1276167850Sjkimstatic void ifCoIm(FICL_VM *pVM) 1277167850Sjkim{ 1278167850Sjkim FICL_DICT *dp = vmGetDict(pVM); 1279167850Sjkim 1280167850Sjkim assert(pVM->pSys->pBranch0); 1281167850Sjkim 1282167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); 1283167850Sjkim markBranch(dp, pVM, origTag); 1284167850Sjkim dictAppendUNS(dp, 1); 1285167850Sjkim return; 1286167850Sjkim} 1287167850Sjkim 1288167850Sjkim 1289167850Sjkim/************************************************************************** 129040843Smsmith e l s e C o I m 129140843Smsmith** 1292167850Sjkim** IMMEDIATE COMPILE-ONLY 1293167850Sjkim** compiles an "else"... 129440843Smsmith** 1) Compile a branch and a patch address; the address gets patched 129540843Smsmith** by "endif" to point past the "else" code. 1296218909Sbrucec** 2) Pop the "if" patch address 129740843Smsmith** 3) Patch the "if" branch to point to the current compile address. 129840843Smsmith** 4) Push the "else" patch address. ("endif" patches this to jump past 129940843Smsmith** the "else" code. 130040843Smsmith**************************************************************************/ 130140843Smsmith 130240843Smsmithstatic void elseCoIm(FICL_VM *pVM) 130340843Smsmith{ 130440843Smsmith CELL *patchAddr; 130582960Sdfr FICL_INT offset; 130694290Sdcs FICL_DICT *dp = vmGetDict(pVM); 130740843Smsmith 130894290Sdcs assert(pVM->pSys->pBranchParen); 130940843Smsmith /* (1) compile branch runtime */ 131094290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 131151786Sdcs matchControlTag(pVM, origTag); 131240843Smsmith patchAddr = 131340843Smsmith (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ 131451786Sdcs markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */ 131551786Sdcs dictAppendUNS(dp, 1); /* (1) compile patch placeholder */ 131640843Smsmith offset = dp->here - patchAddr; 131740843Smsmith *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */ 131840843Smsmith 131940843Smsmith return; 132040843Smsmith} 132140843Smsmith 132240843Smsmith 132340843Smsmith/************************************************************************** 1324167850Sjkim e n d i f C o I m 1325167850Sjkim** IMMEDIATE COMPILE-ONLY 132640843Smsmith**************************************************************************/ 132740843Smsmith 1328167850Sjkimstatic void endifCoIm(FICL_VM *pVM) 132940843Smsmith{ 1330167850Sjkim FICL_DICT *dp = vmGetDict(pVM); 1331167850Sjkim resolveForwardBranch(dp, pVM, origTag); 133240843Smsmith return; 133340843Smsmith} 133440843Smsmith 133540843Smsmith 133640843Smsmith/************************************************************************** 1337167850Sjkim c a s e C o I m 1338167850Sjkim** IMMEDIATE COMPILE-ONLY 1339167850Sjkim** 1340167850Sjkim** 1341167850Sjkim** At compile-time, a CASE-SYS (see DPANS94 6.2.0873) looks like this: 1342167850Sjkim** i*addr i caseTag 1343167850Sjkim** and an OF-SYS (see DPANS94 6.2.1950) looks like this: 1344167850Sjkim** i*addr i caseTag addr ofTag 1345167850Sjkim** The integer under caseTag is the count of fixup addresses that branch 1346167850Sjkim** to ENDCASE. 134740843Smsmith**************************************************************************/ 134840843Smsmith 1349167850Sjkimstatic void caseCoIm(FICL_VM *pVM) 135040843Smsmith{ 1351167850Sjkim#if FICL_ROBUST > 1 1352167850Sjkim vmCheckStack(pVM, 0, 2); 1353167850Sjkim#endif 1354167850Sjkim 1355167850Sjkim PUSHUNS(0); 1356167850Sjkim markControlTag(pVM, caseTag); 1357167850Sjkim return; 1358167850Sjkim} 1359167850Sjkim 1360167850Sjkim 1361167850Sjkim/************************************************************************** 1362167850Sjkim e n d c a s eC o I m 1363167850Sjkim** IMMEDIATE COMPILE-ONLY 1364167850Sjkim**************************************************************************/ 1365167850Sjkim 1366167850Sjkimstatic void endcaseCoIm(FICL_VM *pVM) 1367167850Sjkim{ 1368167850Sjkim FICL_UNS fixupCount; 1369167850Sjkim FICL_DICT *dp; 1370167850Sjkim CELL *patchAddr; 1371167850Sjkim FICL_INT offset; 1372167850Sjkim 1373167850Sjkim assert(pVM->pSys->pDrop); 1374167850Sjkim 1375167850Sjkim /* 1376167850Sjkim ** if the last OF ended with FALLTHROUGH, 1377167850Sjkim ** just add the FALLTHROUGH fixup to the 1378167850Sjkim ** ENDOF fixups 1379167850Sjkim */ 1380167850Sjkim if (stackGetTop(pVM->pStack).p == fallthroughTag) 1381167850Sjkim { 1382167850Sjkim matchControlTag(pVM, fallthroughTag); 1383167850Sjkim patchAddr = POPPTR(); 1384167850Sjkim matchControlTag(pVM, caseTag); 1385167850Sjkim fixupCount = POPUNS(); 1386167850Sjkim PUSHPTR(patchAddr); 1387167850Sjkim PUSHUNS(fixupCount + 1); 1388167850Sjkim markControlTag(pVM, caseTag); 1389167850Sjkim } 1390167850Sjkim 1391167850Sjkim matchControlTag(pVM, caseTag); 1392167850Sjkim 1393167850Sjkim#if FICL_ROBUST > 1 1394167850Sjkim vmCheckStack(pVM, 1, 0); 1395167850Sjkim#endif 1396167850Sjkim fixupCount = POPUNS(); 1397167850Sjkim#if FICL_ROBUST > 1 1398167850Sjkim vmCheckStack(pVM, fixupCount, 0); 1399167850Sjkim#endif 1400167850Sjkim 1401167850Sjkim dp = vmGetDict(pVM); 1402167850Sjkim 1403167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop)); 1404167850Sjkim 1405167850Sjkim while (fixupCount--) 1406167850Sjkim { 1407167850Sjkim patchAddr = (CELL *)stackPopPtr(pVM->pStack); 1408167850Sjkim offset = dp->here - patchAddr; 1409167850Sjkim *patchAddr = LVALUEtoCELL(offset); 1410167850Sjkim } 1411167850Sjkim return; 1412167850Sjkim} 1413167850Sjkim 1414167850Sjkim 1415167850Sjkimstatic void ofParen(FICL_VM *pVM) 1416167850Sjkim{ 1417167850Sjkim FICL_UNS a, b; 1418167850Sjkim 1419167850Sjkim#if FICL_ROBUST > 1 1420167850Sjkim vmCheckStack(pVM, 2, 1); 1421167850Sjkim#endif 1422167850Sjkim 1423167850Sjkim a = POPUNS(); 1424167850Sjkim b = stackGetTop(pVM->pStack).u; 1425167850Sjkim 1426167850Sjkim if (a == b) 1427167850Sjkim { /* fall through */ 1428167850Sjkim stackDrop(pVM->pStack, 1); 1429167850Sjkim vmBranchRelative(pVM, 1); 1430167850Sjkim } 1431167850Sjkim else 1432167850Sjkim { /* take branch to next of or endswitch */ 1433167850Sjkim vmBranchRelative(pVM, *(int *)(pVM->ip)); 1434167850Sjkim } 1435167850Sjkim 1436167850Sjkim return; 1437167850Sjkim} 1438167850Sjkim 1439167850Sjkim 1440167850Sjkim/************************************************************************** 1441167850Sjkim o f C o I m 1442167850Sjkim** IMMEDIATE COMPILE-ONLY 1443167850Sjkim**************************************************************************/ 1444167850Sjkim 1445167850Sjkimstatic void ofCoIm(FICL_VM *pVM) 1446167850Sjkim{ 144794290Sdcs FICL_DICT *dp = vmGetDict(pVM); 1448167850Sjkim CELL *fallthroughFixup = NULL; 1449167850Sjkim 1450167850Sjkim assert(pVM->pSys->pBranch0); 1451167850Sjkim 1452167850Sjkim#if FICL_ROBUST > 1 1453167850Sjkim vmCheckStack(pVM, 1, 3); 1454167850Sjkim#endif 1455167850Sjkim 1456167850Sjkim if (stackGetTop(pVM->pStack).p == fallthroughTag) 1457167850Sjkim { 1458167850Sjkim matchControlTag(pVM, fallthroughTag); 1459167850Sjkim fallthroughFixup = POPPTR(); 1460167850Sjkim } 1461167850Sjkim 1462167850Sjkim matchControlTag(pVM, caseTag); 1463167850Sjkim 1464167850Sjkim markControlTag(pVM, caseTag); 1465167850Sjkim 1466167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen)); 1467167850Sjkim markBranch(dp, pVM, ofTag); 1468167850Sjkim dictAppendUNS(dp, 2); 1469167850Sjkim 1470167850Sjkim if (fallthroughFixup != NULL) 1471167850Sjkim { 1472167850Sjkim FICL_INT offset = dp->here - fallthroughFixup; 1473167850Sjkim *fallthroughFixup = LVALUEtoCELL(offset); 1474167850Sjkim } 1475167850Sjkim 147640843Smsmith return; 147740843Smsmith} 147840843Smsmith 147940843Smsmith 148040843Smsmith/************************************************************************** 1481167850Sjkim e n d o f C o I m 1482167850Sjkim** IMMEDIATE COMPILE-ONLY 1483167850Sjkim**************************************************************************/ 1484167850Sjkim 1485167850Sjkimstatic void endofCoIm(FICL_VM *pVM) 1486167850Sjkim{ 1487167850Sjkim CELL *patchAddr; 1488167850Sjkim FICL_UNS fixupCount; 1489167850Sjkim FICL_INT offset; 1490167850Sjkim FICL_DICT *dp = vmGetDict(pVM); 1491167850Sjkim 1492167850Sjkim#if FICL_ROBUST > 1 1493167850Sjkim vmCheckStack(pVM, 4, 3); 1494167850Sjkim#endif 1495167850Sjkim 1496167850Sjkim assert(pVM->pSys->pBranchParen); 1497167850Sjkim 1498167850Sjkim /* ensure we're in an OF, */ 1499167850Sjkim matchControlTag(pVM, ofTag); 1500167850Sjkim /* grab the address of the branch location after the OF */ 1501167850Sjkim patchAddr = (CELL *)stackPopPtr(pVM->pStack); 1502167850Sjkim /* ensure we're also in a "case" */ 1503167850Sjkim matchControlTag(pVM, caseTag); 1504167850Sjkim /* grab the current number of ENDOF fixups */ 1505167850Sjkim fixupCount = POPUNS(); 1506167850Sjkim 1507167850Sjkim /* compile branch runtime */ 1508167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 1509167850Sjkim 1510167850Sjkim /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */ 1511167850Sjkim PUSHPTR(dp->here); 1512167850Sjkim PUSHUNS(fixupCount + 1); 1513167850Sjkim markControlTag(pVM, caseTag); 1514167850Sjkim 1515167850Sjkim /* reserve space for the ENDOF fixup */ 1516167850Sjkim dictAppendUNS(dp, 2); 1517167850Sjkim 1518167850Sjkim /* and patch the original OF */ 1519167850Sjkim offset = dp->here - patchAddr; 1520167850Sjkim *patchAddr = LVALUEtoCELL(offset); 1521167850Sjkim} 1522167850Sjkim 1523167850Sjkim 1524167850Sjkim/************************************************************************** 1525167850Sjkim f a l l t h r o u g h C o I m 1526167850Sjkim** IMMEDIATE COMPILE-ONLY 1527167850Sjkim**************************************************************************/ 1528167850Sjkim 1529167850Sjkimstatic void fallthroughCoIm(FICL_VM *pVM) 1530167850Sjkim{ 1531167850Sjkim CELL *patchAddr; 1532167850Sjkim FICL_INT offset; 1533167850Sjkim FICL_DICT *dp = vmGetDict(pVM); 1534167850Sjkim 1535167850Sjkim#if FICL_ROBUST > 1 1536167850Sjkim vmCheckStack(pVM, 4, 3); 1537167850Sjkim#endif 1538167850Sjkim 1539167850Sjkim /* ensure we're in an OF, */ 1540167850Sjkim matchControlTag(pVM, ofTag); 1541167850Sjkim /* grab the address of the branch location after the OF */ 1542167850Sjkim patchAddr = (CELL *)stackPopPtr(pVM->pStack); 1543167850Sjkim /* ensure we're also in a "case" */ 1544167850Sjkim matchControlTag(pVM, caseTag); 1545167850Sjkim 1546167850Sjkim /* okay, here we go. put the case tag back. */ 1547167850Sjkim markControlTag(pVM, caseTag); 1548167850Sjkim 1549167850Sjkim /* compile branch runtime */ 1550167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 1551167850Sjkim 1552167850Sjkim /* push a new FALLTHROUGH fixup and the fallthroughTag */ 1553167850Sjkim PUSHPTR(dp->here); 1554167850Sjkim markControlTag(pVM, fallthroughTag); 1555167850Sjkim 1556167850Sjkim /* reserve space for the FALLTHROUGH fixup */ 1557167850Sjkim dictAppendUNS(dp, 2); 1558167850Sjkim 1559167850Sjkim /* and patch the original OF */ 1560167850Sjkim offset = dp->here - patchAddr; 1561167850Sjkim *patchAddr = LVALUEtoCELL(offset); 1562167850Sjkim} 1563167850Sjkim 1564167850Sjkim/************************************************************************** 156560959Sdcs h a s h 156660959Sdcs** hash ( c-addr u -- code) 156760959Sdcs** calculates hashcode of specified string and leaves it on the stack 156860959Sdcs**************************************************************************/ 156960959Sdcs 157060959Sdcsstatic void hash(FICL_VM *pVM) 157160959Sdcs{ 157276116Sdcs STRINGINFO si; 157376116Sdcs SI_SETLEN(si, stackPopUNS(pVM->pStack)); 157476116Sdcs SI_SETPTR(si, stackPopPtr(pVM->pStack)); 157576116Sdcs PUSHUNS(hashHashCode(si)); 157660959Sdcs return; 157760959Sdcs} 157860959Sdcs 157960959Sdcs 158060959Sdcs/************************************************************************** 158140843Smsmith i n t e r p r e t 158240843Smsmith** This is the "user interface" of a Forth. It does the following: 158340843Smsmith** while there are words in the VM's Text Input Buffer 158440843Smsmith** Copy next word into the pad (vmGetWord) 158540843Smsmith** Attempt to find the word in the dictionary (dictLookup) 158640843Smsmith** If successful, execute the word. 158740843Smsmith** Otherwise, attempt to convert the word to a number (isNumber) 158840843Smsmith** If successful, push the number onto the parameter stack. 158940843Smsmith** Otherwise, print an error message and exit loop... 159040843Smsmith** End Loop 159140843Smsmith** 159240843Smsmith** From the standard, section 3.4 159340843Smsmith** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall 159440843Smsmith** repeat the following steps until either the parse area is empty or an 159540843Smsmith** ambiguous condition exists: 159640843Smsmith** a) Skip leading spaces and parse a name (see 3.4.1); 159740843Smsmith**************************************************************************/ 159840843Smsmith 159940843Smsmithstatic void interpret(FICL_VM *pVM) 160040843Smsmith{ 160176116Sdcs STRINGINFO si; 160276116Sdcs int i; 160376116Sdcs FICL_SYSTEM *pSys; 160476116Sdcs 160540843Smsmith assert(pVM); 160694290Sdcs 160776116Sdcs pSys = pVM->pSys; 160876116Sdcs si = vmGetWord0(pVM); 160940843Smsmith 161040843Smsmith /* 161151786Sdcs ** Get next word...if out of text, we're done. 161240843Smsmith */ 161340843Smsmith if (si.count == 0) 161460959Sdcs { 161540843Smsmith vmThrow(pVM, VM_OUTOFTEXT); 161660959Sdcs } 161740843Smsmith 161876116Sdcs /* 161976116Sdcs ** Attempt to find the incoming token in the dictionary. If that fails... 162076116Sdcs ** run the parse chain against the incoming token until somebody eats it. 162176116Sdcs ** Otherwise emit an error message and give up. 162276116Sdcs ** Although ficlParseWord could be part of the parse list, I've hard coded it 162376116Sdcs ** in for robustness. ficlInitSystem adds the other default steps to the list. 162476116Sdcs */ 162576116Sdcs if (ficlParseWord(pVM, si)) 162676116Sdcs return; 162740843Smsmith 162876116Sdcs for (i=0; i < FICL_MAX_PARSE_STEPS; i++) 162976116Sdcs { 163076116Sdcs FICL_WORD *pFW = pSys->parseList[i]; 163176116Sdcs 163276116Sdcs if (pFW == NULL) 163376116Sdcs break; 163460959Sdcs 163594290Sdcs if (pFW->code == parseStepParen) 163694290Sdcs { 163794290Sdcs FICL_PARSE_STEP pStep; 163894290Sdcs pStep = (FICL_PARSE_STEP)(pFW->param->fn); 163994290Sdcs if ((*pStep)(pVM, si)) 164094290Sdcs return; 164194290Sdcs } 164294290Sdcs else 164394290Sdcs { 164494290Sdcs stackPushPtr(pVM->pStack, SI_PTR(si)); 164594290Sdcs stackPushUNS(pVM->pStack, SI_COUNT(si)); 164694290Sdcs ficlExecXT(pVM, pFW); 164794290Sdcs if (stackPopINT(pVM->pStack)) 164894290Sdcs return; 164994290Sdcs } 165076116Sdcs } 165176116Sdcs 165276116Sdcs i = SI_COUNT(si); 165376116Sdcs vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 165476116Sdcs 165540843Smsmith return; /* back to inner interpreter */ 165640843Smsmith} 165740843Smsmith 165876116Sdcs 165940843Smsmith/************************************************************************** 166076116Sdcs f i c l P a r s e W o r d 166140843Smsmith** From the standard, section 3.4 166240843Smsmith** b) Search the dictionary name space (see 3.4.2). If a definition name 166340843Smsmith** matching the string is found: 166440843Smsmith** 1.if interpreting, perform the interpretation semantics of the definition 166540843Smsmith** (see 3.4.3.2), and continue at a); 166640843Smsmith** 2.if compiling, perform the compilation semantics of the definition 166740843Smsmith** (see 3.4.3.3), and continue at a). 166840843Smsmith** 166940843Smsmith** c) If a definition name matching the string is not found, attempt to 167040843Smsmith** convert the string to a number (see 3.4.1.3). If successful: 167140843Smsmith** 1.if interpreting, place the number on the data stack, and continue at a); 167240843Smsmith** 2.if compiling, compile code that when executed will place the number on 167340843Smsmith** the stack (see 6.1.1780 LITERAL), and continue at a); 167440843Smsmith** 167540843Smsmith** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 167676116Sdcs** 167776116Sdcs** (jws 4/01) Modified to be a FICL_PARSE_STEP 167840843Smsmith**************************************************************************/ 167976116Sdcsstatic int ficlParseWord(FICL_VM *pVM, STRINGINFO si) 168040843Smsmith{ 168194290Sdcs FICL_DICT *dp = vmGetDict(pVM); 168240843Smsmith FICL_WORD *tempFW; 168340843Smsmith 168440843Smsmith#if FICL_ROBUST 168540843Smsmith dictCheck(dp, pVM, 0); 168640843Smsmith vmCheckStack(pVM, 0, 0); 168740843Smsmith#endif 168840843Smsmith 168940843Smsmith#if FICL_WANT_LOCALS 169094290Sdcs if (pVM->pSys->nLocals > 0) 169140843Smsmith { 169294290Sdcs tempFW = ficlLookupLoc(pVM->pSys, si); 169340843Smsmith } 169440843Smsmith else 169540843Smsmith#endif 169640843Smsmith tempFW = dictLookup(dp, si); 169740843Smsmith 169840843Smsmith if (pVM->state == INTERPRET) 169940843Smsmith { 170040843Smsmith if (tempFW != NULL) 170140843Smsmith { 170240843Smsmith if (wordIsCompileOnly(tempFW)) 170340843Smsmith { 170440843Smsmith vmThrowErr(pVM, "Error: Compile only!"); 170540843Smsmith } 170660959Sdcs 170740843Smsmith vmExecute(pVM, tempFW); 1708102657Sscottl return (int)FICL_TRUE; 170940843Smsmith } 171040843Smsmith } 171140843Smsmith 171240843Smsmith else /* (pVM->state == COMPILE) */ 171340843Smsmith { 171440843Smsmith if (tempFW != NULL) 171540843Smsmith { 171640843Smsmith if (wordIsImmediate(tempFW)) 171740843Smsmith { 171840843Smsmith vmExecute(pVM, tempFW); 171940843Smsmith } 172040843Smsmith else 172140843Smsmith { 172240843Smsmith dictAppendCell(dp, LVALUEtoCELL(tempFW)); 172340843Smsmith } 1724102657Sscottl return (int)FICL_TRUE; 172540843Smsmith } 172640843Smsmith } 172740843Smsmith 172876116Sdcs return FICL_FALSE; 172976116Sdcs} 173076116Sdcs 173176116Sdcs 173294290Sdcs/* 173394290Sdcs** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in 173494290Sdcs** INTERPRET) 173594290Sdcs*/ 173694290Sdcsstatic void lookup(FICL_VM *pVM) 173794290Sdcs{ 173894290Sdcs STRINGINFO si; 173994290Sdcs SI_SETLEN(si, stackPopUNS(pVM->pStack)); 174094290Sdcs SI_SETPTR(si, stackPopPtr(pVM->pStack)); 174194290Sdcs stackPushINT(pVM->pStack, ficlParseWord(pVM, si)); 174294290Sdcs return; 174394290Sdcs} 174494290Sdcs 174594290Sdcs 174676116Sdcs/************************************************************************** 174776116Sdcs p a r e n P a r s e S t e p 174876116Sdcs** (parse-step) ( c-addr u -- flag ) 174976116Sdcs** runtime for a precompiled parse step - pop a counted string off the 175076116Sdcs** stack, run the parse step against it, and push the result flag (FICL_TRUE 175176116Sdcs** if success, FICL_FALSE otherwise). 175276116Sdcs**************************************************************************/ 175376116Sdcs 175476116Sdcsvoid parseStepParen(FICL_VM *pVM) 175576116Sdcs{ 175676116Sdcs STRINGINFO si; 175776116Sdcs FICL_WORD *pFW = pVM->runningWord; 175876116Sdcs FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn); 175976116Sdcs 176076116Sdcs SI_SETLEN(si, stackPopINT(pVM->pStack)); 176176116Sdcs SI_SETPTR(si, stackPopPtr(pVM->pStack)); 176276116Sdcs 176376116Sdcs PUSHINT((*pStep)(pVM, si)); 176476116Sdcs 176540843Smsmith return; 176640843Smsmith} 176740843Smsmith 176840843Smsmith 176976116Sdcsstatic void addParseStep(FICL_VM *pVM) 177076116Sdcs{ 177176116Sdcs FICL_WORD *pStep; 177294290Sdcs FICL_DICT *pd = vmGetDict(pVM); 177376116Sdcs#if FICL_ROBUST > 1 177476116Sdcs vmCheckStack(pVM, 1, 0); 177576116Sdcs#endif 177676116Sdcs pStep = (FICL_WORD *)(stackPop(pVM->pStack).p); 177794290Sdcs if ((pStep != NULL) && isAFiclWord(pd, pStep)) 177876116Sdcs ficlAddParseStep(pVM->pSys, pStep); 177976116Sdcs return; 178076116Sdcs} 178176116Sdcs 178276116Sdcs 178340843Smsmith/************************************************************************** 178440843Smsmith l i t e r a l P a r e n 178540843Smsmith** 178640843Smsmith** This is the runtime for (literal). It assumes that it is part of a colon 178740843Smsmith** definition, and that the next CELL contains a value to be pushed on the 178840843Smsmith** parameter stack at runtime. This code is compiled by "literal". 178940843Smsmith** 179040843Smsmith**************************************************************************/ 179160959Sdcs 179240843Smsmithstatic void literalParen(FICL_VM *pVM) 179340843Smsmith{ 179440843Smsmith#if FICL_ROBUST > 1 179540843Smsmith vmCheckStack(pVM, 0, 1); 179640843Smsmith#endif 179776116Sdcs PUSHINT(*(FICL_INT *)(pVM->ip)); 179840843Smsmith vmBranchRelative(pVM, 1); 179940843Smsmith return; 180040843Smsmith} 180140843Smsmith 180260959Sdcsstatic void twoLitParen(FICL_VM *pVM) 180360959Sdcs{ 180460959Sdcs#if FICL_ROBUST > 1 180560959Sdcs vmCheckStack(pVM, 0, 2); 180660959Sdcs#endif 180776116Sdcs PUSHINT(*((FICL_INT *)(pVM->ip)+1)); 180876116Sdcs PUSHINT(*(FICL_INT *)(pVM->ip)); 180960959Sdcs vmBranchRelative(pVM, 2); 181060959Sdcs return; 181160959Sdcs} 181240843Smsmith 181360959Sdcs 181440843Smsmith/************************************************************************** 181540843Smsmith l i t e r a l I m 181640843Smsmith** 181740843Smsmith** IMMEDIATE code for "literal". This function gets a value from the stack 181840843Smsmith** and compiles it into the dictionary preceded by the code for "(literal)". 181940843Smsmith** IMMEDIATE 182040843Smsmith**************************************************************************/ 182140843Smsmith 182240843Smsmithstatic void literalIm(FICL_VM *pVM) 182340843Smsmith{ 182494290Sdcs FICL_DICT *dp = vmGetDict(pVM); 182594290Sdcs assert(pVM->pSys->pLitParen); 182640843Smsmith 182794290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen)); 182840843Smsmith dictAppendCell(dp, stackPop(pVM->pStack)); 182940843Smsmith 183040843Smsmith return; 183140843Smsmith} 183240843Smsmith 183340843Smsmith 183460959Sdcsstatic void twoLiteralIm(FICL_VM *pVM) 183560959Sdcs{ 183694290Sdcs FICL_DICT *dp = vmGetDict(pVM); 183794290Sdcs assert(pVM->pSys->pTwoLitParen); 183860959Sdcs 183994290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen)); 184060959Sdcs dictAppendCell(dp, stackPop(pVM->pStack)); 184160959Sdcs dictAppendCell(dp, stackPop(pVM->pStack)); 184260959Sdcs 184360959Sdcs return; 184460959Sdcs} 184560959Sdcs 184640843Smsmith/************************************************************************** 184740843Smsmith l o g i c a n d c o m p a r i s o n s 184840843Smsmith** 184940843Smsmith**************************************************************************/ 185040843Smsmith 185140843Smsmithstatic void zeroEquals(FICL_VM *pVM) 185240843Smsmith{ 185340843Smsmith CELL c; 185440843Smsmith#if FICL_ROBUST > 1 185540843Smsmith vmCheckStack(pVM, 1, 1); 185640843Smsmith#endif 185751786Sdcs c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0); 185840843Smsmith stackPush(pVM->pStack, c); 185940843Smsmith return; 186040843Smsmith} 186140843Smsmith 186240843Smsmithstatic void zeroLess(FICL_VM *pVM) 186340843Smsmith{ 186440843Smsmith CELL c; 186540843Smsmith#if FICL_ROBUST > 1 186640843Smsmith vmCheckStack(pVM, 1, 1); 186740843Smsmith#endif 186851786Sdcs c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0); 186940843Smsmith stackPush(pVM->pStack, c); 187040843Smsmith return; 187140843Smsmith} 187240843Smsmith 187340843Smsmithstatic void zeroGreater(FICL_VM *pVM) 187440843Smsmith{ 187540843Smsmith CELL c; 187640843Smsmith#if FICL_ROBUST > 1 187740843Smsmith vmCheckStack(pVM, 1, 1); 187840843Smsmith#endif 187951786Sdcs c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0); 188040843Smsmith stackPush(pVM->pStack, c); 188140843Smsmith return; 188240843Smsmith} 188340843Smsmith 188440843Smsmithstatic void isEqual(FICL_VM *pVM) 188540843Smsmith{ 188640843Smsmith CELL x, y; 188740843Smsmith 188840843Smsmith#if FICL_ROBUST > 1 188940843Smsmith vmCheckStack(pVM, 2, 1); 189040843Smsmith#endif 189140843Smsmith x = stackPop(pVM->pStack); 189240843Smsmith y = stackPop(pVM->pStack); 189376116Sdcs PUSHINT(FICL_BOOL(x.i == y.i)); 189440843Smsmith return; 189540843Smsmith} 189640843Smsmith 189740843Smsmithstatic void isLess(FICL_VM *pVM) 189840843Smsmith{ 189940843Smsmith CELL x, y; 190040843Smsmith#if FICL_ROBUST > 1 190140843Smsmith vmCheckStack(pVM, 2, 1); 190240843Smsmith#endif 190340843Smsmith y = stackPop(pVM->pStack); 190440843Smsmith x = stackPop(pVM->pStack); 190576116Sdcs PUSHINT(FICL_BOOL(x.i < y.i)); 190640843Smsmith return; 190740843Smsmith} 190840843Smsmith 190940843Smsmithstatic void uIsLess(FICL_VM *pVM) 191040843Smsmith{ 191151786Sdcs FICL_UNS u1, u2; 191240843Smsmith#if FICL_ROBUST > 1 191340843Smsmith vmCheckStack(pVM, 2, 1); 191440843Smsmith#endif 191551786Sdcs u2 = stackPopUNS(pVM->pStack); 191651786Sdcs u1 = stackPopUNS(pVM->pStack); 191776116Sdcs PUSHINT(FICL_BOOL(u1 < u2)); 191840843Smsmith return; 191940843Smsmith} 192040843Smsmith 192140843Smsmithstatic void isGreater(FICL_VM *pVM) 192240843Smsmith{ 192340843Smsmith CELL x, y; 192440843Smsmith#if FICL_ROBUST > 1 192540843Smsmith vmCheckStack(pVM, 2, 1); 192640843Smsmith#endif 192740843Smsmith y = stackPop(pVM->pStack); 192840843Smsmith x = stackPop(pVM->pStack); 192976116Sdcs PUSHINT(FICL_BOOL(x.i > y.i)); 193040843Smsmith return; 193140843Smsmith} 193240843Smsmith 193340843Smsmithstatic void bitwiseAnd(FICL_VM *pVM) 193440843Smsmith{ 193540843Smsmith CELL x, y; 193640843Smsmith#if FICL_ROBUST > 1 193740843Smsmith vmCheckStack(pVM, 2, 1); 193840843Smsmith#endif 193940843Smsmith x = stackPop(pVM->pStack); 194040843Smsmith y = stackPop(pVM->pStack); 194176116Sdcs PUSHINT(x.i & y.i); 194240843Smsmith return; 194340843Smsmith} 194440843Smsmith 194540843Smsmithstatic void bitwiseOr(FICL_VM *pVM) 194640843Smsmith{ 194740843Smsmith CELL x, y; 194840843Smsmith#if FICL_ROBUST > 1 194940843Smsmith vmCheckStack(pVM, 2, 1); 195040843Smsmith#endif 195140843Smsmith x = stackPop(pVM->pStack); 195240843Smsmith y = stackPop(pVM->pStack); 195376116Sdcs PUSHINT(x.i | y.i); 195440843Smsmith return; 195540843Smsmith} 195640843Smsmith 195740843Smsmithstatic void bitwiseXor(FICL_VM *pVM) 195840843Smsmith{ 195940843Smsmith CELL x, y; 196040843Smsmith#if FICL_ROBUST > 1 196140843Smsmith vmCheckStack(pVM, 2, 1); 196240843Smsmith#endif 196340843Smsmith x = stackPop(pVM->pStack); 196440843Smsmith y = stackPop(pVM->pStack); 196576116Sdcs PUSHINT(x.i ^ y.i); 196640843Smsmith return; 196740843Smsmith} 196840843Smsmith 196940843Smsmithstatic void bitwiseNot(FICL_VM *pVM) 197040843Smsmith{ 197140843Smsmith CELL x; 197240843Smsmith#if FICL_ROBUST > 1 197340843Smsmith vmCheckStack(pVM, 1, 1); 197440843Smsmith#endif 197540843Smsmith x = stackPop(pVM->pStack); 197676116Sdcs PUSHINT(~x.i); 197740843Smsmith return; 197840843Smsmith} 197940843Smsmith 198040843Smsmith 198140843Smsmith/************************************************************************** 198240843Smsmith D o / L o o p 198340843Smsmith** do -- IMMEDIATE COMPILE ONLY 198440843Smsmith** Compiles code to initialize a loop: compile (do), 198540843Smsmith** allot space to hold the "leave" address, push a branch 198640843Smsmith** target address for the loop. 198740843Smsmith** (do) -- runtime for "do" 198840843Smsmith** pops index and limit from the p stack and moves them 198940843Smsmith** to the r stack, then skips to the loop body. 199040843Smsmith** loop -- IMMEDIATE COMPILE ONLY 199140843Smsmith** +loop 199240843Smsmith** Compiles code for the test part of a loop: 199340843Smsmith** compile (loop), resolve forward branch from "do", and 199440843Smsmith** copy "here" address to the "leave" address allotted by "do" 199540843Smsmith** i,j,k -- COMPILE ONLY 199640843Smsmith** Runtime: Push loop indices on param stack (i is innermost loop...) 199740843Smsmith** Note: each loop has three values on the return stack: 199840843Smsmith** ( R: leave limit index ) 199940843Smsmith** "leave" is the absolute address of the next cell after the loop 200040843Smsmith** limit and index are the loop control variables. 200140843Smsmith** leave -- COMPILE ONLY 200240843Smsmith** Runtime: pop the loop control variables, then pop the 200340843Smsmith** "leave" address and jump (absolute) there. 200440843Smsmith**************************************************************************/ 200540843Smsmith 200640843Smsmithstatic void doCoIm(FICL_VM *pVM) 200740843Smsmith{ 200894290Sdcs FICL_DICT *dp = vmGetDict(pVM); 200940843Smsmith 201094290Sdcs assert(pVM->pSys->pDoParen); 201140843Smsmith 201294290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen)); 201340843Smsmith /* 201440843Smsmith ** Allot space for a pointer to the end 201540843Smsmith ** of the loop - "leave" uses this... 201640843Smsmith */ 201740843Smsmith markBranch(dp, pVM, leaveTag); 201851786Sdcs dictAppendUNS(dp, 0); 201940843Smsmith /* 202040843Smsmith ** Mark location of head of loop... 202140843Smsmith */ 202240843Smsmith markBranch(dp, pVM, doTag); 202340843Smsmith 202440843Smsmith return; 202540843Smsmith} 202640843Smsmith 202760959Sdcs 202840843Smsmithstatic void doParen(FICL_VM *pVM) 202940843Smsmith{ 203040843Smsmith CELL index, limit; 203140843Smsmith#if FICL_ROBUST > 1 203240843Smsmith vmCheckStack(pVM, 2, 0); 203340843Smsmith#endif 203440843Smsmith index = stackPop(pVM->pStack); 203540843Smsmith limit = stackPop(pVM->pStack); 203640843Smsmith 203740843Smsmith /* copy "leave" target addr to stack */ 203840843Smsmith stackPushPtr(pVM->rStack, *(pVM->ip++)); 203940843Smsmith stackPush(pVM->rStack, limit); 204040843Smsmith stackPush(pVM->rStack, index); 204140843Smsmith 204240843Smsmith return; 204340843Smsmith} 204440843Smsmith 204540843Smsmith 204640843Smsmithstatic void qDoCoIm(FICL_VM *pVM) 204740843Smsmith{ 204894290Sdcs FICL_DICT *dp = vmGetDict(pVM); 204940843Smsmith 205094290Sdcs assert(pVM->pSys->pQDoParen); 205140843Smsmith 205294290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen)); 205340843Smsmith /* 205440843Smsmith ** Allot space for a pointer to the end 205540843Smsmith ** of the loop - "leave" uses this... 205640843Smsmith */ 205740843Smsmith markBranch(dp, pVM, leaveTag); 205851786Sdcs dictAppendUNS(dp, 0); 205940843Smsmith /* 206040843Smsmith ** Mark location of head of loop... 206140843Smsmith */ 206240843Smsmith markBranch(dp, pVM, doTag); 206340843Smsmith 206440843Smsmith return; 206540843Smsmith} 206640843Smsmith 206760959Sdcs 206840843Smsmithstatic void qDoParen(FICL_VM *pVM) 206940843Smsmith{ 207040843Smsmith CELL index, limit; 207140843Smsmith#if FICL_ROBUST > 1 207240843Smsmith vmCheckStack(pVM, 2, 0); 207340843Smsmith#endif 207440843Smsmith index = stackPop(pVM->pStack); 207540843Smsmith limit = stackPop(pVM->pStack); 207640843Smsmith 207740843Smsmith /* copy "leave" target addr to stack */ 207840843Smsmith stackPushPtr(pVM->rStack, *(pVM->ip++)); 207940843Smsmith 208040843Smsmith if (limit.u == index.u) 208140843Smsmith { 208240843Smsmith vmPopIP(pVM); 208340843Smsmith } 208440843Smsmith else 208540843Smsmith { 208640843Smsmith stackPush(pVM->rStack, limit); 208740843Smsmith stackPush(pVM->rStack, index); 208840843Smsmith } 208940843Smsmith 209040843Smsmith return; 209140843Smsmith} 209240843Smsmith 209340843Smsmith 209440843Smsmith/* 209540843Smsmith** Runtime code to break out of a do..loop construct 209640843Smsmith** Drop the loop control variables; the branch address 209740843Smsmith** past "loop" is next on the return stack. 209840843Smsmith*/ 209940843Smsmithstatic void leaveCo(FICL_VM *pVM) 210040843Smsmith{ 210140843Smsmith /* almost unloop */ 210240843Smsmith stackDrop(pVM->rStack, 2); 210340843Smsmith /* exit */ 210440843Smsmith vmPopIP(pVM); 210540843Smsmith return; 210640843Smsmith} 210740843Smsmith 210840843Smsmith 210940843Smsmithstatic void unloopCo(FICL_VM *pVM) 211040843Smsmith{ 211140843Smsmith stackDrop(pVM->rStack, 3); 211240843Smsmith return; 211340843Smsmith} 211440843Smsmith 211540843Smsmith 211640843Smsmithstatic void loopCoIm(FICL_VM *pVM) 211740843Smsmith{ 211894290Sdcs FICL_DICT *dp = vmGetDict(pVM); 211940843Smsmith 212094290Sdcs assert(pVM->pSys->pLoopParen); 212140843Smsmith 212294290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen)); 212340843Smsmith resolveBackBranch(dp, pVM, doTag); 212440843Smsmith resolveAbsBranch(dp, pVM, leaveTag); 212540843Smsmith return; 212640843Smsmith} 212740843Smsmith 212840843Smsmith 212940843Smsmithstatic void plusLoopCoIm(FICL_VM *pVM) 213040843Smsmith{ 213194290Sdcs FICL_DICT *dp = vmGetDict(pVM); 213240843Smsmith 213394290Sdcs assert(pVM->pSys->pPLoopParen); 213440843Smsmith 213594290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen)); 213640843Smsmith resolveBackBranch(dp, pVM, doTag); 213740843Smsmith resolveAbsBranch(dp, pVM, leaveTag); 213840843Smsmith return; 213940843Smsmith} 214040843Smsmith 214160959Sdcs 214240843Smsmithstatic void loopParen(FICL_VM *pVM) 214340843Smsmith{ 214451786Sdcs FICL_INT index = stackGetTop(pVM->rStack).i; 214551786Sdcs FICL_INT limit = stackFetch(pVM->rStack, 1).i; 214640843Smsmith 214740843Smsmith index++; 214840843Smsmith 214940843Smsmith if (index >= limit) 215040843Smsmith { 215140843Smsmith stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 215240843Smsmith vmBranchRelative(pVM, 1); /* fall through the loop */ 215340843Smsmith } 215440843Smsmith else 215540843Smsmith { /* update index, branch to loop head */ 215640843Smsmith stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 2157102657Sscottl vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); 215840843Smsmith } 215940843Smsmith 216040843Smsmith return; 216140843Smsmith} 216240843Smsmith 216360959Sdcs 216440843Smsmithstatic void plusLoopParen(FICL_VM *pVM) 216540843Smsmith{ 216694290Sdcs FICL_INT index,limit,increment; 216794290Sdcs int flag; 216840843Smsmith 216976116Sdcs#if FICL_ROBUST > 1 217094290Sdcs vmCheckStack(pVM, 1, 0); 217176116Sdcs#endif 217240843Smsmith 217394290Sdcs index = stackGetTop(pVM->rStack).i; 217494290Sdcs limit = stackFetch(pVM->rStack, 1).i; 217594290Sdcs increment = POP().i; 217694290Sdcs 217794290Sdcs index += increment; 217876116Sdcs 217940843Smsmith if (increment < 0) 218040843Smsmith flag = (index < limit); 218140843Smsmith else 218240843Smsmith flag = (index >= limit); 218340843Smsmith 218440843Smsmith if (flag) 218540843Smsmith { 218640843Smsmith stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 218740843Smsmith vmBranchRelative(pVM, 1); /* fall through the loop */ 218840843Smsmith } 218940843Smsmith else 219040843Smsmith { /* update index, branch to loop head */ 219140843Smsmith stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 2192102657Sscottl vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); 219340843Smsmith } 219440843Smsmith 219540843Smsmith return; 219640843Smsmith} 219740843Smsmith 219840843Smsmith 219940843Smsmithstatic void loopICo(FICL_VM *pVM) 220040843Smsmith{ 220140843Smsmith CELL index = stackGetTop(pVM->rStack); 220240843Smsmith stackPush(pVM->pStack, index); 220340843Smsmith 220440843Smsmith return; 220540843Smsmith} 220640843Smsmith 220740843Smsmith 220840843Smsmithstatic void loopJCo(FICL_VM *pVM) 220940843Smsmith{ 221040843Smsmith CELL index = stackFetch(pVM->rStack, 3); 221140843Smsmith stackPush(pVM->pStack, index); 221240843Smsmith 221340843Smsmith return; 221440843Smsmith} 221540843Smsmith 221640843Smsmith 221740843Smsmithstatic void loopKCo(FICL_VM *pVM) 221840843Smsmith{ 221940843Smsmith CELL index = stackFetch(pVM->rStack, 6); 222040843Smsmith stackPush(pVM->pStack, index); 222140843Smsmith 222240843Smsmith return; 222340843Smsmith} 222440843Smsmith 222540843Smsmith 222640843Smsmith/************************************************************************** 222740843Smsmith r e t u r n s t a c k 222840843Smsmith** 222940843Smsmith**************************************************************************/ 223040843Smsmithstatic void toRStack(FICL_VM *pVM) 223140843Smsmith{ 223276116Sdcs#if FICL_ROBUST > 1 223394290Sdcs vmCheckStack(pVM, 1, 0); 223476116Sdcs#endif 223576116Sdcs 223694290Sdcs stackPush(pVM->rStack, POP()); 223776116Sdcs} 223876116Sdcs 223976116Sdcsstatic void fromRStack(FICL_VM *pVM) 224076116Sdcs{ 224176116Sdcs#if FICL_ROBUST > 1 224294290Sdcs vmCheckStack(pVM, 0, 1); 224376116Sdcs#endif 224476116Sdcs 224594290Sdcs PUSH(stackPop(pVM->rStack)); 224676116Sdcs} 224776116Sdcs 224876116Sdcsstatic void fetchRStack(FICL_VM *pVM) 224976116Sdcs{ 225076116Sdcs#if FICL_ROBUST > 1 225194290Sdcs vmCheckStack(pVM, 0, 1); 225276116Sdcs#endif 225376116Sdcs 225494290Sdcs PUSH(stackGetTop(pVM->rStack)); 225576116Sdcs} 225676116Sdcs 225776116Sdcsstatic void twoToR(FICL_VM *pVM) 225876116Sdcs{ 225976116Sdcs#if FICL_ROBUST > 1 226076116Sdcs vmCheckStack(pVM, 2, 0); 226176116Sdcs#endif 226276116Sdcs stackRoll(pVM->pStack, 1); 226340843Smsmith stackPush(pVM->rStack, stackPop(pVM->pStack)); 226476116Sdcs stackPush(pVM->rStack, stackPop(pVM->pStack)); 226540843Smsmith return; 226640843Smsmith} 226740843Smsmith 226876116Sdcsstatic void twoRFrom(FICL_VM *pVM) 226940843Smsmith{ 227076116Sdcs#if FICL_ROBUST > 1 227176116Sdcs vmCheckStack(pVM, 0, 2); 227276116Sdcs#endif 227340843Smsmith stackPush(pVM->pStack, stackPop(pVM->rStack)); 227476116Sdcs stackPush(pVM->pStack, stackPop(pVM->rStack)); 227576116Sdcs stackRoll(pVM->pStack, 1); 227640843Smsmith return; 227740843Smsmith} 227840843Smsmith 227976116Sdcsstatic void twoRFetch(FICL_VM *pVM) 228040843Smsmith{ 228176116Sdcs#if FICL_ROBUST > 1 228276116Sdcs vmCheckStack(pVM, 0, 2); 228376116Sdcs#endif 228476116Sdcs stackPush(pVM->pStack, stackFetch(pVM->rStack, 1)); 228576116Sdcs stackPush(pVM->pStack, stackFetch(pVM->rStack, 0)); 228640843Smsmith return; 228740843Smsmith} 228840843Smsmith 228940843Smsmith 229040843Smsmith/************************************************************************** 229140843Smsmith v a r i a b l e 229240843Smsmith** 229340843Smsmith**************************************************************************/ 229440843Smsmith 229540843Smsmithstatic void variableParen(FICL_VM *pVM) 229640843Smsmith{ 229794290Sdcs FICL_WORD *fw; 229876116Sdcs#if FICL_ROBUST > 1 229994290Sdcs vmCheckStack(pVM, 0, 1); 230076116Sdcs#endif 230176116Sdcs 230294290Sdcs fw = pVM->runningWord; 230394290Sdcs PUSHPTR(fw->param); 230440843Smsmith} 230540843Smsmith 230640843Smsmith 230740843Smsmithstatic void variable(FICL_VM *pVM) 230840843Smsmith{ 230994290Sdcs FICL_DICT *dp = vmGetDict(pVM); 231040843Smsmith STRINGINFO si = vmGetWord(pVM); 231140843Smsmith 231240843Smsmith dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 231340843Smsmith dictAllotCells(dp, 1); 231440843Smsmith return; 231540843Smsmith} 231640843Smsmith 231740843Smsmith 231876116Sdcsstatic void twoVariable(FICL_VM *pVM) 231976116Sdcs{ 232094290Sdcs FICL_DICT *dp = vmGetDict(pVM); 232176116Sdcs STRINGINFO si = vmGetWord(pVM); 232240843Smsmith 232376116Sdcs dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 232476116Sdcs dictAllotCells(dp, 2); 232576116Sdcs return; 232676116Sdcs} 232776116Sdcs 232876116Sdcs 232940843Smsmith/************************************************************************** 233040843Smsmith b a s e & f r i e n d s 233140843Smsmith** 233240843Smsmith**************************************************************************/ 233340843Smsmith 233440843Smsmithstatic void base(FICL_VM *pVM) 233540843Smsmith{ 233694290Sdcs CELL *pBase; 233776116Sdcs#if FICL_ROBUST > 1 233894290Sdcs vmCheckStack(pVM, 0, 1); 233976116Sdcs#endif 234076116Sdcs 234194290Sdcs pBase = (CELL *)(&pVM->base); 234294290Sdcs stackPush(pVM->pStack, LVALUEtoCELL(pBase)); 234394290Sdcs return; 234440843Smsmith} 234540843Smsmith 234640843Smsmith 234740843Smsmithstatic void decimal(FICL_VM *pVM) 234840843Smsmith{ 234940843Smsmith pVM->base = 10; 235040843Smsmith return; 235140843Smsmith} 235240843Smsmith 235340843Smsmith 235440843Smsmithstatic void hex(FICL_VM *pVM) 235540843Smsmith{ 235640843Smsmith pVM->base = 16; 235740843Smsmith return; 235840843Smsmith} 235940843Smsmith 236040843Smsmith 236140843Smsmith/************************************************************************** 236240843Smsmith a l l o t & f r i e n d s 236340843Smsmith** 236440843Smsmith**************************************************************************/ 236540843Smsmith 236640843Smsmithstatic void allot(FICL_VM *pVM) 236740843Smsmith{ 236894290Sdcs FICL_DICT *dp; 236994290Sdcs FICL_INT i; 237076116Sdcs#if FICL_ROBUST > 1 237194290Sdcs vmCheckStack(pVM, 1, 0); 237276116Sdcs#endif 237376116Sdcs 237494290Sdcs dp = vmGetDict(pVM); 237594290Sdcs i = POPINT(); 237676116Sdcs 237740843Smsmith#if FICL_ROBUST 237894290Sdcs dictCheck(dp, pVM, i); 237940843Smsmith#endif 238076116Sdcs 238194290Sdcs dictAllot(dp, i); 238240843Smsmith return; 238340843Smsmith} 238440843Smsmith 238540843Smsmith 238640843Smsmithstatic void here(FICL_VM *pVM) 238740843Smsmith{ 238894290Sdcs FICL_DICT *dp; 238976116Sdcs#if FICL_ROBUST > 1 239094290Sdcs vmCheckStack(pVM, 0, 1); 239176116Sdcs#endif 239276116Sdcs 239394290Sdcs dp = vmGetDict(pVM); 239494290Sdcs PUSHPTR(dp->here); 239540843Smsmith return; 239640843Smsmith} 239740843Smsmith 239840843Smsmithstatic void comma(FICL_VM *pVM) 239940843Smsmith{ 240094290Sdcs FICL_DICT *dp; 240194290Sdcs CELL c; 240276116Sdcs#if FICL_ROBUST > 1 240394290Sdcs vmCheckStack(pVM, 1, 0); 240476116Sdcs#endif 240576116Sdcs 240694290Sdcs dp = vmGetDict(pVM); 240794290Sdcs c = POP(); 240894290Sdcs dictAppendCell(dp, c); 240940843Smsmith return; 241040843Smsmith} 241140843Smsmith 241240843Smsmithstatic void cComma(FICL_VM *pVM) 241340843Smsmith{ 241494290Sdcs FICL_DICT *dp; 241594290Sdcs char c; 241676116Sdcs#if FICL_ROBUST > 1 241794290Sdcs vmCheckStack(pVM, 1, 0); 241876116Sdcs#endif 241976116Sdcs 242094290Sdcs dp = vmGetDict(pVM); 242194290Sdcs c = (char)POPINT(); 242294290Sdcs dictAppendChar(dp, c); 242340843Smsmith return; 242440843Smsmith} 242540843Smsmith 242640843Smsmithstatic void cells(FICL_VM *pVM) 242740843Smsmith{ 242894290Sdcs FICL_INT i; 242976116Sdcs#if FICL_ROBUST > 1 243094290Sdcs vmCheckStack(pVM, 1, 1); 243176116Sdcs#endif 243276116Sdcs 243394290Sdcs i = POPINT(); 243494290Sdcs PUSHINT(i * (FICL_INT)sizeof (CELL)); 243540843Smsmith return; 243640843Smsmith} 243740843Smsmith 243840843Smsmithstatic void cellPlus(FICL_VM *pVM) 243940843Smsmith{ 244094290Sdcs char *cp; 244176116Sdcs#if FICL_ROBUST > 1 244294290Sdcs vmCheckStack(pVM, 1, 1); 244376116Sdcs#endif 244476116Sdcs 244594290Sdcs cp = POPPTR(); 244694290Sdcs PUSHPTR(cp + sizeof (CELL)); 244740843Smsmith return; 244840843Smsmith} 244940843Smsmith 245040843Smsmith 245176116Sdcs 245240843Smsmith/************************************************************************** 245340843Smsmith t i c k 245440843Smsmith** tick CORE ( "<spaces>name" -- xt ) 245540843Smsmith** Skip leading space delimiters. Parse name delimited by a space. Find 245640843Smsmith** name and return xt, the execution token for name. An ambiguous condition 245740843Smsmith** exists if name is not found. 245840843Smsmith**************************************************************************/ 245976116Sdcsvoid ficlTick(FICL_VM *pVM) 246040843Smsmith{ 246194290Sdcs FICL_WORD *pFW = NULL; 246294290Sdcs STRINGINFO si = vmGetWord(pVM); 246376116Sdcs#if FICL_ROBUST > 1 246494290Sdcs vmCheckStack(pVM, 0, 1); 246576116Sdcs#endif 246676116Sdcs 246794290Sdcs pFW = dictLookup(vmGetDict(pVM), si); 246894290Sdcs if (!pFW) 246994290Sdcs { 247094290Sdcs int i = SI_COUNT(si); 247194290Sdcs vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 247294290Sdcs } 247394290Sdcs PUSHPTR(pFW); 247440843Smsmith return; 247540843Smsmith} 247640843Smsmith 247740843Smsmith 247840843Smsmithstatic void bracketTickCoIm(FICL_VM *pVM) 247940843Smsmith{ 248076116Sdcs ficlTick(pVM); 248140843Smsmith literalIm(pVM); 248240843Smsmith 248340843Smsmith return; 248440843Smsmith} 248540843Smsmith 248640843Smsmith 248740843Smsmith/************************************************************************** 248840843Smsmith p o s t p o n e 248940843Smsmith** Lookup the next word in the input stream and compile code to 249040843Smsmith** insert it into definitions created by the resulting word 249140843Smsmith** (defers compilation, even of immediate words) 249240843Smsmith**************************************************************************/ 249340843Smsmith 249440843Smsmithstatic void postponeCoIm(FICL_VM *pVM) 249540843Smsmith{ 249694290Sdcs FICL_DICT *dp = vmGetDict(pVM); 249740843Smsmith FICL_WORD *pFW; 249894290Sdcs FICL_WORD *pComma = ficlLookup(pVM->pSys, ","); 249940843Smsmith assert(pComma); 250040843Smsmith 250176116Sdcs ficlTick(pVM); 250240843Smsmith pFW = stackGetTop(pVM->pStack).p; 250340843Smsmith if (wordIsImmediate(pFW)) 250440843Smsmith { 250540843Smsmith dictAppendCell(dp, stackPop(pVM->pStack)); 250640843Smsmith } 250740843Smsmith else 250840843Smsmith { 250940843Smsmith literalIm(pVM); 251040843Smsmith dictAppendCell(dp, LVALUEtoCELL(pComma)); 251140843Smsmith } 251240843Smsmith 251340843Smsmith return; 251440843Smsmith} 251540843Smsmith 251640843Smsmith 251740843Smsmith 251840843Smsmith/************************************************************************** 251940843Smsmith e x e c u t e 252040843Smsmith** Pop an execution token (pointer to a word) off the stack and 252140843Smsmith** run it 252240843Smsmith**************************************************************************/ 252340843Smsmith 252440843Smsmithstatic void execute(FICL_VM *pVM) 252540843Smsmith{ 252640843Smsmith FICL_WORD *pFW; 252740843Smsmith#if FICL_ROBUST > 1 252840843Smsmith vmCheckStack(pVM, 1, 0); 252940843Smsmith#endif 253040843Smsmith 253140843Smsmith pFW = stackPopPtr(pVM->pStack); 253240843Smsmith vmExecute(pVM, pFW); 253340843Smsmith 253440843Smsmith return; 253540843Smsmith} 253640843Smsmith 253740843Smsmith 253840843Smsmith/************************************************************************** 253940843Smsmith i m m e d i a t e 254040843Smsmith** Make the most recently compiled word IMMEDIATE -- it executes even 254140843Smsmith** in compile state (most often used for control compiling words 254240843Smsmith** such as IF, THEN, etc) 254340843Smsmith**************************************************************************/ 254440843Smsmith 254540843Smsmithstatic void immediate(FICL_VM *pVM) 254640843Smsmith{ 254740843Smsmith IGNORE(pVM); 254894290Sdcs dictSetImmediate(vmGetDict(pVM)); 254940843Smsmith return; 255040843Smsmith} 255140843Smsmith 255240843Smsmith 255340843Smsmithstatic void compileOnly(FICL_VM *pVM) 255440843Smsmith{ 255540843Smsmith IGNORE(pVM); 255694290Sdcs dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0); 255740843Smsmith return; 255840843Smsmith} 255940843Smsmith 256040843Smsmith 256194290Sdcsstatic void setObjectFlag(FICL_VM *pVM) 256294290Sdcs{ 256394290Sdcs IGNORE(pVM); 256494290Sdcs dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0); 256594290Sdcs return; 256694290Sdcs} 256794290Sdcs 256894290Sdcsstatic void isObject(FICL_VM *pVM) 256994290Sdcs{ 2570271135Semaste FICL_INT flag; 257194290Sdcs FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); 257294290Sdcs 257394290Sdcs flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE; 257494290Sdcs stackPushINT(pVM->pStack, flag); 257594290Sdcs return; 257694290Sdcs} 257794290Sdcs 257894290Sdcsstatic void cstringLit(FICL_VM *pVM) 257994290Sdcs{ 258094290Sdcs FICL_STRING *sp = (FICL_STRING *)(pVM->ip); 258194290Sdcs 258294290Sdcs char *cp = sp->text; 258394290Sdcs cp += sp->count + 1; 258494290Sdcs cp = alignPtr(cp); 258594290Sdcs pVM->ip = (IPTYPE)(void *)cp; 258694290Sdcs 258794290Sdcs stackPushPtr(pVM->pStack, sp); 258894290Sdcs return; 258994290Sdcs} 259094290Sdcs 259194290Sdcs 259294290Sdcsstatic void cstringQuoteIm(FICL_VM *pVM) 259394290Sdcs{ 259494290Sdcs FICL_DICT *dp = vmGetDict(pVM); 259594290Sdcs 259694290Sdcs if (pVM->state == INTERPRET) 259794290Sdcs { 259894290Sdcs FICL_STRING *sp = (FICL_STRING *) dp->here; 259994290Sdcs vmGetString(pVM, sp, '\"'); 260094290Sdcs stackPushPtr(pVM->pStack, sp); 260194290Sdcs /* move HERE past string so it doesn't get overwritten. --lch */ 260294290Sdcs dictAllot(dp, sp->count + sizeof(FICL_COUNT)); 260394290Sdcs } 260494290Sdcs else /* COMPILE state */ 260594290Sdcs { 260694290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit)); 260794290Sdcs dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 260894290Sdcs dictAlign(dp); 260994290Sdcs } 261094290Sdcs 261194290Sdcs return; 261294290Sdcs} 261394290Sdcs 261440843Smsmith/************************************************************************** 261540843Smsmith d o t Q u o t e 261640843Smsmith** IMMEDIATE word that compiles a string literal for later display 261740843Smsmith** Compile stringLit, then copy the bytes of the string from the TIB 261840843Smsmith** to the dictionary. Backpatch the count byte and align the dictionary. 261940843Smsmith** 262040843Smsmith** stringlit: Fetch the count from the dictionary, then push the address 262140843Smsmith** and count on the stack. Finally, update ip to point to the first 262240843Smsmith** aligned address after the string text. 262340843Smsmith**************************************************************************/ 262460959Sdcs 262540843Smsmithstatic void stringLit(FICL_VM *pVM) 262640843Smsmith{ 262794290Sdcs FICL_STRING *sp; 262894290Sdcs FICL_COUNT count; 262994290Sdcs char *cp; 263076116Sdcs#if FICL_ROBUST > 1 263194290Sdcs vmCheckStack(pVM, 0, 2); 263276116Sdcs#endif 263376116Sdcs 263494290Sdcs sp = (FICL_STRING *)(pVM->ip); 263594290Sdcs count = sp->count; 263694290Sdcs cp = sp->text; 263794290Sdcs PUSHPTR(cp); 263894290Sdcs PUSHUNS(count); 263994290Sdcs cp += count + 1; 264094290Sdcs cp = alignPtr(cp); 264194290Sdcs pVM->ip = (IPTYPE)(void *)cp; 264240843Smsmith} 264340843Smsmith 264440843Smsmithstatic void dotQuoteCoIm(FICL_VM *pVM) 264540843Smsmith{ 264694290Sdcs FICL_DICT *dp = vmGetDict(pVM); 264794290Sdcs FICL_WORD *pType = ficlLookup(pVM->pSys, "type"); 264894290Sdcs assert(pType); 264994290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); 265040843Smsmith dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 265140843Smsmith dictAlign(dp); 265240843Smsmith dictAppendCell(dp, LVALUEtoCELL(pType)); 265340843Smsmith return; 265440843Smsmith} 265540843Smsmith 265640843Smsmith 265740843Smsmithstatic void dotParen(FICL_VM *pVM) 265840843Smsmith{ 265951786Sdcs char *pSrc = vmGetInBuf(pVM); 266051786Sdcs char *pEnd = vmGetInBufEnd(pVM); 266151786Sdcs char *pDest = pVM->pad; 266240843Smsmith char ch; 266340843Smsmith 266476116Sdcs /* 266576116Sdcs ** Note: the standard does not want leading spaces skipped (apparently) 266676116Sdcs */ 266751786Sdcs for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc) 266840843Smsmith *pDest++ = ch; 266940843Smsmith 267040843Smsmith *pDest = '\0'; 267151786Sdcs if ((pEnd != pSrc) && (ch == ')')) 267240843Smsmith pSrc++; 267340843Smsmith 267440843Smsmith vmTextOut(pVM, pVM->pad, 0); 267540843Smsmith vmUpdateTib(pVM, pSrc); 267640843Smsmith 267740843Smsmith return; 267840843Smsmith} 267940843Smsmith 268040843Smsmith 268140843Smsmith/************************************************************************** 268240843Smsmith s l i t e r a l 268340843Smsmith** STRING 268440843Smsmith** Interpretation: Interpretation semantics for this word are undefined. 268540843Smsmith** Compilation: ( c-addr1 u -- ) 268640843Smsmith** Append the run-time semantics given below to the current definition. 268740843Smsmith** Run-time: ( -- c-addr2 u ) 268840843Smsmith** Return c-addr2 u describing a string consisting of the characters 268940843Smsmith** specified by c-addr1 u during compilation. A program shall not alter 269040843Smsmith** the returned string. 269140843Smsmith**************************************************************************/ 269240843Smsmithstatic void sLiteralCoIm(FICL_VM *pVM) 269340843Smsmith{ 269494290Sdcs FICL_DICT *dp; 269594290Sdcs char *cp, *cpDest; 269694290Sdcs FICL_UNS u; 269740843Smsmith 269876116Sdcs#if FICL_ROBUST > 1 269994290Sdcs vmCheckStack(pVM, 2, 0); 270076116Sdcs#endif 270176116Sdcs 270294290Sdcs dp = vmGetDict(pVM); 270394290Sdcs u = POPUNS(); 270494290Sdcs cp = POPPTR(); 270576116Sdcs 270694290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); 270740843Smsmith cpDest = (char *) dp->here; 270840843Smsmith *cpDest++ = (char) u; 270940843Smsmith 271040843Smsmith for (; u > 0; --u) 271140843Smsmith { 271240843Smsmith *cpDest++ = *cp++; 271340843Smsmith } 271440843Smsmith 271540843Smsmith *cpDest++ = 0; 271640843Smsmith dp->here = PTRtoCELL alignPtr(cpDest); 271740843Smsmith return; 271840843Smsmith} 271940843Smsmith 272040843Smsmith 272140843Smsmith/************************************************************************** 272240843Smsmith s t a t e 272340843Smsmith** Return the address of the VM's state member (must be sized the 272440843Smsmith** same as a CELL for this reason) 272540843Smsmith**************************************************************************/ 272640843Smsmithstatic void state(FICL_VM *pVM) 272740843Smsmith{ 272876116Sdcs#if FICL_ROBUST > 1 272994290Sdcs vmCheckStack(pVM, 0, 1); 273076116Sdcs#endif 273176116Sdcs PUSHPTR(&pVM->state); 273240843Smsmith return; 273340843Smsmith} 273440843Smsmith 273540843Smsmith 273640843Smsmith/************************************************************************** 273740843Smsmith c r e a t e . . . d o e s > 273840843Smsmith** Make a new word in the dictionary with the run-time effect of 273940843Smsmith** a variable (push my address), but with extra space allotted 274040843Smsmith** for use by does> . 274140843Smsmith**************************************************************************/ 274240843Smsmith 274340843Smsmithstatic void createParen(FICL_VM *pVM) 274440843Smsmith{ 274594290Sdcs CELL *pCell; 274676116Sdcs 274776116Sdcs#if FICL_ROBUST > 1 274894290Sdcs vmCheckStack(pVM, 0, 1); 274976116Sdcs#endif 275076116Sdcs 275194290Sdcs pCell = pVM->runningWord->param; 275294290Sdcs PUSHPTR(pCell+1); 275340843Smsmith return; 275440843Smsmith} 275540843Smsmith 275640843Smsmith 275740843Smsmithstatic void create(FICL_VM *pVM) 275840843Smsmith{ 275994290Sdcs FICL_DICT *dp = vmGetDict(pVM); 276040843Smsmith STRINGINFO si = vmGetWord(pVM); 276140843Smsmith 276277268Sdcs dictCheckThreshold(dp); 276377268Sdcs 276440843Smsmith dictAppendWord2(dp, si, createParen, FW_DEFAULT); 276540843Smsmith dictAllotCells(dp, 1); 276640843Smsmith return; 276740843Smsmith} 276840843Smsmith 276940843Smsmith 277040843Smsmithstatic void doDoes(FICL_VM *pVM) 277140843Smsmith{ 277294290Sdcs CELL *pCell; 277394290Sdcs IPTYPE tempIP; 277476116Sdcs#if FICL_ROBUST > 1 277594290Sdcs vmCheckStack(pVM, 0, 1); 277676116Sdcs#endif 277776116Sdcs 277894290Sdcs pCell = pVM->runningWord->param; 277994290Sdcs tempIP = (IPTYPE)((*pCell).p); 278094290Sdcs PUSHPTR(pCell+1); 278194290Sdcs vmPushIP(pVM, tempIP); 278240843Smsmith return; 278340843Smsmith} 278440843Smsmith 278540843Smsmith 278640843Smsmithstatic void doesParen(FICL_VM *pVM) 278740843Smsmith{ 278894290Sdcs FICL_DICT *dp = vmGetDict(pVM); 278940843Smsmith dp->smudge->code = doDoes; 279040843Smsmith dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); 279140843Smsmith vmPopIP(pVM); 279240843Smsmith return; 279340843Smsmith} 279440843Smsmith 279540843Smsmith 279640843Smsmithstatic void doesCoIm(FICL_VM *pVM) 279740843Smsmith{ 279894290Sdcs FICL_DICT *dp = vmGetDict(pVM); 279940843Smsmith#if FICL_WANT_LOCALS 280094290Sdcs assert(pVM->pSys->pUnLinkParen); 280194290Sdcs if (pVM->pSys->nLocals > 0) 280240843Smsmith { 280394290Sdcs FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 280440843Smsmith dictEmpty(pLoc, pLoc->pForthWords->size); 280594290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); 280640843Smsmith } 280740843Smsmith 280894290Sdcs pVM->pSys->nLocals = 0; 280940843Smsmith#endif 281040843Smsmith IGNORE(pVM); 281140843Smsmith 281294290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen)); 281340843Smsmith return; 281440843Smsmith} 281540843Smsmith 281640843Smsmith 281740843Smsmith/************************************************************************** 281840843Smsmith t o b o d y 281940843Smsmith** to-body CORE ( xt -- a-addr ) 282040843Smsmith** a-addr is the data-field address corresponding to xt. An ambiguous 282140843Smsmith** condition exists if xt is not for a word defined via CREATE. 282240843Smsmith**************************************************************************/ 282340843Smsmithstatic void toBody(FICL_VM *pVM) 282440843Smsmith{ 282594290Sdcs FICL_WORD *pFW; 282676116Sdcs/*#$-GUY CHANGE: Added robustness.-$#*/ 282776116Sdcs#if FICL_ROBUST > 1 282894290Sdcs vmCheckStack(pVM, 1, 1); 282976116Sdcs#endif 283076116Sdcs 283194290Sdcs pFW = POPPTR(); 283294290Sdcs PUSHPTR(pFW->param + 1); 283340843Smsmith return; 283440843Smsmith} 283540843Smsmith 283640843Smsmith 283740843Smsmith/* 283840843Smsmith** from-body ficl ( a-addr -- xt ) 283940843Smsmith** Reverse effect of >body 284040843Smsmith*/ 284140843Smsmithstatic void fromBody(FICL_VM *pVM) 284240843Smsmith{ 284394290Sdcs char *ptr; 284476116Sdcs#if FICL_ROBUST > 1 284594290Sdcs vmCheckStack(pVM, 1, 1); 284676116Sdcs#endif 284776116Sdcs 284894290Sdcs ptr = (char *)POPPTR() - sizeof (FICL_WORD); 284994290Sdcs PUSHPTR(ptr); 285040843Smsmith return; 285140843Smsmith} 285240843Smsmith 285340843Smsmith 285440843Smsmith/* 285540843Smsmith** >name ficl ( xt -- c-addr u ) 285640843Smsmith** Push the address and length of a word's name given its address 285740843Smsmith** xt. 285840843Smsmith*/ 285940843Smsmithstatic void toName(FICL_VM *pVM) 286040843Smsmith{ 286194290Sdcs FICL_WORD *pFW; 286276116Sdcs#if FICL_ROBUST > 1 286394290Sdcs vmCheckStack(pVM, 1, 2); 286476116Sdcs#endif 286576116Sdcs 286694290Sdcs pFW = POPPTR(); 286794290Sdcs PUSHPTR(pFW->name); 286894290Sdcs PUSHUNS(pFW->nName); 286940843Smsmith return; 287040843Smsmith} 287140843Smsmith 287240843Smsmith 287376116Sdcsstatic void getLastWord(FICL_VM *pVM) 287476116Sdcs{ 287594290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 287676116Sdcs FICL_WORD *wp = pDict->smudge; 287776116Sdcs assert(wp); 287876116Sdcs vmPush(pVM, LVALUEtoCELL(wp)); 287976116Sdcs return; 288076116Sdcs} 288176116Sdcs 288276116Sdcs 288340843Smsmith/************************************************************************** 288440843Smsmith l b r a c k e t e t c 288540843Smsmith** 288640843Smsmith**************************************************************************/ 288740843Smsmith 288840843Smsmithstatic void lbracketCoIm(FICL_VM *pVM) 288940843Smsmith{ 289040843Smsmith pVM->state = INTERPRET; 289140843Smsmith return; 289240843Smsmith} 289340843Smsmith 289440843Smsmith 289540843Smsmithstatic void rbracket(FICL_VM *pVM) 289640843Smsmith{ 289740843Smsmith pVM->state = COMPILE; 289840843Smsmith return; 289940843Smsmith} 290040843Smsmith 290140843Smsmith 290240843Smsmith/************************************************************************** 290340843Smsmith p i c t u r e d n u m e r i c w o r d s 290440843Smsmith** 290540843Smsmith** less-number-sign CORE ( -- ) 290640843Smsmith** Initialize the pictured numeric output conversion process. 290740843Smsmith** (clear the pad) 290840843Smsmith**************************************************************************/ 290940843Smsmithstatic void lessNumberSign(FICL_VM *pVM) 291040843Smsmith{ 291140843Smsmith FICL_STRING *sp = PTRtoSTRING pVM->pad; 291240843Smsmith sp->count = 0; 291340843Smsmith return; 291440843Smsmith} 291540843Smsmith 291640843Smsmith/* 291740843Smsmith** number-sign CORE ( ud1 -- ud2 ) 291840843Smsmith** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder 291940843Smsmith** n. (n is the least-significant digit of ud1.) Convert n to external form 292040843Smsmith** and add the resulting character to the beginning of the pictured numeric 292140843Smsmith** output string. An ambiguous condition exists if # executes outside of a 292240843Smsmith** <# #> delimited number conversion. 292340843Smsmith*/ 292440843Smsmithstatic void numberSign(FICL_VM *pVM) 292540843Smsmith{ 292694290Sdcs FICL_STRING *sp; 292794290Sdcs DPUNS u; 292894290Sdcs UNS16 rem; 292976116Sdcs#if FICL_ROBUST > 1 293094290Sdcs vmCheckStack(pVM, 2, 2); 293176116Sdcs#endif 293276116Sdcs 293394290Sdcs sp = PTRtoSTRING pVM->pad; 293494290Sdcs u = u64Pop(pVM->pStack); 293594290Sdcs rem = m64UMod(&u, (UNS16)(pVM->base)); 293694290Sdcs sp->text[sp->count++] = digit_to_char(rem); 293794290Sdcs u64Push(pVM->pStack, u); 293840843Smsmith return; 293940843Smsmith} 294040843Smsmith 294140843Smsmith/* 294240843Smsmith** number-sign-greater CORE ( xd -- c-addr u ) 294340843Smsmith** Drop xd. Make the pictured numeric output string available as a character 294440843Smsmith** string. c-addr and u specify the resulting character string. A program 294540843Smsmith** may replace characters within the string. 294640843Smsmith*/ 294740843Smsmithstatic void numberSignGreater(FICL_VM *pVM) 294840843Smsmith{ 294994290Sdcs FICL_STRING *sp; 295076116Sdcs#if FICL_ROBUST > 1 295194290Sdcs vmCheckStack(pVM, 2, 2); 295276116Sdcs#endif 295376116Sdcs 295494290Sdcs sp = PTRtoSTRING pVM->pad; 295594290Sdcs sp->text[sp->count] = 0; 295694290Sdcs strrev(sp->text); 295794290Sdcs DROP(2); 295894290Sdcs PUSHPTR(sp->text); 295994290Sdcs PUSHUNS(sp->count); 296040843Smsmith return; 296140843Smsmith} 296240843Smsmith 296340843Smsmith/* 296440843Smsmith** number-sign-s CORE ( ud1 -- ud2 ) 296540843Smsmith** Convert one digit of ud1 according to the rule for #. Continue conversion 296640843Smsmith** until the quotient is zero. ud2 is zero. An ambiguous condition exists if 296740843Smsmith** #S executes outside of a <# #> delimited number conversion. 296840843Smsmith** TO DO: presently does not use ud1 hi cell - use it! 296940843Smsmith*/ 297040843Smsmithstatic void numberSignS(FICL_VM *pVM) 297140843Smsmith{ 297294290Sdcs FICL_STRING *sp; 297394290Sdcs DPUNS u; 297494290Sdcs UNS16 rem; 297576116Sdcs#if FICL_ROBUST > 1 297694290Sdcs vmCheckStack(pVM, 2, 2); 297776116Sdcs#endif 297840843Smsmith 297994290Sdcs sp = PTRtoSTRING pVM->pad; 298094290Sdcs u = u64Pop(pVM->pStack); 298140843Smsmith 298294290Sdcs do 298394290Sdcs { 298494290Sdcs rem = m64UMod(&u, (UNS16)(pVM->base)); 298594290Sdcs sp->text[sp->count++] = digit_to_char(rem); 298694290Sdcs } 298794290Sdcs while (u.hi || u.lo); 298840843Smsmith 298994290Sdcs u64Push(pVM->pStack, u); 299040843Smsmith return; 299140843Smsmith} 299240843Smsmith 299340843Smsmith/* 299440843Smsmith** HOLD CORE ( char -- ) 299540843Smsmith** Add char to the beginning of the pictured numeric output string. An ambiguous 299640843Smsmith** condition exists if HOLD executes outside of a <# #> delimited number conversion. 299740843Smsmith*/ 299840843Smsmithstatic void hold(FICL_VM *pVM) 299940843Smsmith{ 300094290Sdcs FICL_STRING *sp; 300194290Sdcs int i; 300276116Sdcs#if FICL_ROBUST > 1 300394290Sdcs vmCheckStack(pVM, 1, 0); 300476116Sdcs#endif 300576116Sdcs 300694290Sdcs sp = PTRtoSTRING pVM->pad; 300794290Sdcs i = POPINT(); 300894290Sdcs sp->text[sp->count++] = (char) i; 300940843Smsmith return; 301040843Smsmith} 301140843Smsmith 301240843Smsmith/* 301340843Smsmith** SIGN CORE ( n -- ) 301440843Smsmith** If n is negative, add a minus sign to the beginning of the pictured 301540843Smsmith** numeric output string. An ambiguous condition exists if SIGN 301640843Smsmith** executes outside of a <# #> delimited number conversion. 301740843Smsmith*/ 301840843Smsmithstatic void sign(FICL_VM *pVM) 301940843Smsmith{ 302094290Sdcs FICL_STRING *sp; 302194290Sdcs int i; 302276116Sdcs#if FICL_ROBUST > 1 302394290Sdcs vmCheckStack(pVM, 1, 0); 302476116Sdcs#endif 302576116Sdcs 302694290Sdcs sp = PTRtoSTRING pVM->pad; 302794290Sdcs i = POPINT(); 302894290Sdcs if (i < 0) 302994290Sdcs sp->text[sp->count++] = '-'; 303040843Smsmith return; 303140843Smsmith} 303240843Smsmith 303340843Smsmith 303440843Smsmith/************************************************************************** 303540843Smsmith t o N u m b e r 303640843Smsmith** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 303740843Smsmith** ud2 is the unsigned result of converting the characters within the 303840843Smsmith** string specified by c-addr1 u1 into digits, using the number in BASE, 303940843Smsmith** and adding each into ud1 after multiplying ud1 by the number in BASE. 304040843Smsmith** Conversion continues left-to-right until a character that is not 304140843Smsmith** convertible, including any + or -, is encountered or the string is 304240843Smsmith** entirely converted. c-addr2 is the location of the first unconverted 304340843Smsmith** character or the first character past the end of the string if the string 304440843Smsmith** was entirely converted. u2 is the number of unconverted characters in the 304540843Smsmith** string. An ambiguous condition exists if ud2 overflows during the 304640843Smsmith** conversion. 304740843Smsmith**************************************************************************/ 304840843Smsmithstatic void toNumber(FICL_VM *pVM) 304940843Smsmith{ 305094290Sdcs FICL_UNS count; 305194290Sdcs char *cp; 305294290Sdcs DPUNS accum; 305394290Sdcs FICL_UNS base = pVM->base; 305494290Sdcs FICL_UNS ch; 305594290Sdcs FICL_UNS digit; 305640843Smsmith 305776116Sdcs#if FICL_ROBUST > 1 305894290Sdcs vmCheckStack(pVM,4,4); 305976116Sdcs#endif 306076116Sdcs 306194290Sdcs count = POPUNS(); 306294290Sdcs cp = (char *)POPPTR(); 306340843Smsmith accum = u64Pop(pVM->pStack); 306440843Smsmith 306540843Smsmith for (ch = *cp; count > 0; ch = *++cp, count--) 306640843Smsmith { 306740843Smsmith if (ch < '0') 306840843Smsmith break; 306940843Smsmith 307040843Smsmith digit = ch - '0'; 307140843Smsmith 307240843Smsmith if (digit > 9) 307340843Smsmith digit = tolower(ch) - 'a' + 10; 307440843Smsmith /* 307540843Smsmith ** Note: following test also catches chars between 9 and a 307640843Smsmith ** because 'digit' is unsigned! 307740843Smsmith */ 307840843Smsmith if (digit >= base) 307940843Smsmith break; 308040843Smsmith 308140843Smsmith accum = m64Mac(accum, base, digit); 308240843Smsmith } 308340843Smsmith 308440843Smsmith u64Push(pVM->pStack, accum); 308576116Sdcs PUSHPTR(cp); 308676116Sdcs PUSHUNS(count); 308740843Smsmith 308840843Smsmith return; 308940843Smsmith} 309040843Smsmith 309140843Smsmith 309240843Smsmith 309340843Smsmith/************************************************************************** 309440843Smsmith q u i t & a b o r t 309540843Smsmith** quit CORE ( -- ) ( R: i*x -- ) 309640843Smsmith** Empty the return stack, store zero in SOURCE-ID if it is present, make 309740843Smsmith** the user input device the input source, and enter interpretation state. 309840843Smsmith** Do not display a message. Repeat the following: 309940843Smsmith** 310040843Smsmith** Accept a line from the input source into the input buffer, set >IN to 310140843Smsmith** zero, and interpret. 310240843Smsmith** Display the implementation-defined system prompt if in 310340843Smsmith** interpretation state, all processing has been completed, and no 310440843Smsmith** ambiguous condition exists. 310540843Smsmith**************************************************************************/ 310640843Smsmith 310740843Smsmithstatic void quit(FICL_VM *pVM) 310840843Smsmith{ 310940843Smsmith vmThrow(pVM, VM_QUIT); 311040843Smsmith return; 311140843Smsmith} 311240843Smsmith 311340843Smsmith 311440843Smsmithstatic void ficlAbort(FICL_VM *pVM) 311540843Smsmith{ 311643078Smsmith vmThrow(pVM, VM_ABORT); 311740843Smsmith return; 311840843Smsmith} 311940843Smsmith 312040843Smsmith 312140843Smsmith/************************************************************************** 312240843Smsmith a c c e p t 312340843Smsmith** accept CORE ( c-addr +n1 -- +n2 ) 312440843Smsmith** Receive a string of at most +n1 characters. An ambiguous condition 312540843Smsmith** exists if +n1 is zero or greater than 32,767. Display graphic characters 312640843Smsmith** as they are received. A program that depends on the presence or absence 312740843Smsmith** of non-graphic characters in the string has an environmental dependency. 312840843Smsmith** The editing functions, if any, that the system performs in order to 312940843Smsmith** construct the string are implementation-defined. 313040843Smsmith** 313140843Smsmith** (Although the standard text doesn't say so, I assume that the intent 313240843Smsmith** of 'accept' is to store the string at the address specified on 313340843Smsmith** the stack.) 313440843Smsmith** Implementation: if there's more text in the TIB, use it. Otherwise 313540843Smsmith** throw out for more text. Copy characters up to the max count into the 313640843Smsmith** address given, and return the number of actual characters copied. 313751786Sdcs** 313851786Sdcs** Note (sobral) this may not be the behavior you'd expect if you're 313951786Sdcs** trying to get user input at load time! 314040843Smsmith**************************************************************************/ 314140843Smsmithstatic void accept(FICL_VM *pVM) 314240843Smsmith{ 314394290Sdcs FICL_UNS count, len; 314494290Sdcs char *cp; 314594290Sdcs char *pBuf, *pEnd; 314640843Smsmith 314776116Sdcs#if FICL_ROBUST > 1 314894290Sdcs vmCheckStack(pVM,2,1); 314976116Sdcs#endif 315076116Sdcs 315194290Sdcs pBuf = vmGetInBuf(pVM); 315276116Sdcs pEnd = vmGetInBufEnd(pVM); 315394290Sdcs len = pEnd - pBuf; 315440843Smsmith if (len == 0) 315540843Smsmith vmThrow(pVM, VM_RESTART); 315651786Sdcs 315751786Sdcs /* 315851786Sdcs ** Now we have something in the text buffer - use it 315951786Sdcs */ 316051786Sdcs count = stackPopINT(pVM->pStack); 316140843Smsmith cp = stackPopPtr(pVM->pStack); 316240843Smsmith 316340843Smsmith len = (count < len) ? count : len; 316451786Sdcs strncpy(cp, vmGetInBuf(pVM), len); 316540843Smsmith pBuf += len; 316640843Smsmith vmUpdateTib(pVM, pBuf); 316776116Sdcs PUSHINT(len); 316840843Smsmith 316940843Smsmith return; 317040843Smsmith} 317140843Smsmith 317240843Smsmith 317340843Smsmith/************************************************************************** 317440843Smsmith a l i g n 317540843Smsmith** 6.1.0705 ALIGN CORE ( -- ) 317640843Smsmith** If the data-space pointer is not aligned, reserve enough space to 317740843Smsmith** align it. 317840843Smsmith**************************************************************************/ 317940843Smsmithstatic void align(FICL_VM *pVM) 318040843Smsmith{ 318194290Sdcs FICL_DICT *dp = vmGetDict(pVM); 318240843Smsmith IGNORE(pVM); 318340843Smsmith dictAlign(dp); 318440843Smsmith return; 318540843Smsmith} 318640843Smsmith 318740843Smsmith 318840843Smsmith/************************************************************************** 318940843Smsmith a l i g n e d 319040843Smsmith** 319140843Smsmith**************************************************************************/ 319240843Smsmithstatic void aligned(FICL_VM *pVM) 319340843Smsmith{ 319494290Sdcs void *addr; 319576116Sdcs#if FICL_ROBUST > 1 319694290Sdcs vmCheckStack(pVM,1,1); 319776116Sdcs#endif 319876116Sdcs 319994290Sdcs addr = POPPTR(); 320094290Sdcs PUSHPTR(alignPtr(addr)); 320140843Smsmith return; 320240843Smsmith} 320340843Smsmith 320440843Smsmith 320540843Smsmith/************************************************************************** 320640843Smsmith b e g i n & f r i e n d s 320740843Smsmith** Indefinite loop control structures 320840843Smsmith** A.6.1.0760 BEGIN 320940843Smsmith** Typical use: 321040843Smsmith** : X ... BEGIN ... test UNTIL ; 321140843Smsmith** or 321240843Smsmith** : X ... BEGIN ... test WHILE ... REPEAT ; 321340843Smsmith**************************************************************************/ 321440843Smsmithstatic void beginCoIm(FICL_VM *pVM) 321540843Smsmith{ 321694290Sdcs FICL_DICT *dp = vmGetDict(pVM); 321751786Sdcs markBranch(dp, pVM, destTag); 321840843Smsmith return; 321940843Smsmith} 322040843Smsmith 322140843Smsmithstatic void untilCoIm(FICL_VM *pVM) 322240843Smsmith{ 322394290Sdcs FICL_DICT *dp = vmGetDict(pVM); 322440843Smsmith 3225167850Sjkim assert(pVM->pSys->pBranch0); 322640843Smsmith 3227167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); 322851786Sdcs resolveBackBranch(dp, pVM, destTag); 322940843Smsmith return; 323040843Smsmith} 323140843Smsmith 323240843Smsmithstatic void whileCoIm(FICL_VM *pVM) 323340843Smsmith{ 323494290Sdcs FICL_DICT *dp = vmGetDict(pVM); 323540843Smsmith 3236167850Sjkim assert(pVM->pSys->pBranch0); 323740843Smsmith 3238167850Sjkim dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); 323951786Sdcs markBranch(dp, pVM, origTag); 324040843Smsmith twoSwap(pVM); 324151786Sdcs dictAppendUNS(dp, 1); 324240843Smsmith return; 324340843Smsmith} 324440843Smsmith 324540843Smsmithstatic void repeatCoIm(FICL_VM *pVM) 324640843Smsmith{ 324794290Sdcs FICL_DICT *dp = vmGetDict(pVM); 324840843Smsmith 324994290Sdcs assert(pVM->pSys->pBranchParen); 325094290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 325140843Smsmith 325240843Smsmith /* expect "begin" branch marker */ 325351786Sdcs resolveBackBranch(dp, pVM, destTag); 325440843Smsmith /* expect "while" branch marker */ 325551786Sdcs resolveForwardBranch(dp, pVM, origTag); 325640843Smsmith return; 325740843Smsmith} 325840843Smsmith 325940843Smsmith 326060959Sdcsstatic void againCoIm(FICL_VM *pVM) 326160959Sdcs{ 326294290Sdcs FICL_DICT *dp = vmGetDict(pVM); 326360959Sdcs 326494290Sdcs assert(pVM->pSys->pBranchParen); 326594290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 326660959Sdcs 326760959Sdcs /* expect "begin" branch marker */ 326860959Sdcs resolveBackBranch(dp, pVM, destTag); 326960959Sdcs return; 327060959Sdcs} 327160959Sdcs 327260959Sdcs 327340843Smsmith/************************************************************************** 327440843Smsmith c h a r & f r i e n d s 327540843Smsmith** 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) 327640843Smsmith** Skip leading space delimiters. Parse name delimited by a space. 327740843Smsmith** Put the value of its first character onto the stack. 327840843Smsmith** 327940843Smsmith** bracket-char CORE 328040843Smsmith** Interpretation: Interpretation semantics for this word are undefined. 328140843Smsmith** Compilation: ( "<spaces>name" -- ) 328240843Smsmith** Skip leading space delimiters. Parse name delimited by a space. 328340843Smsmith** Append the run-time semantics given below to the current definition. 328440843Smsmith** Run-time: ( -- char ) 328540843Smsmith** Place char, the value of the first character of name, on the stack. 328640843Smsmith**************************************************************************/ 328740843Smsmithstatic void ficlChar(FICL_VM *pVM) 328840843Smsmith{ 328994290Sdcs STRINGINFO si; 329076116Sdcs#if FICL_ROBUST > 1 329194290Sdcs vmCheckStack(pVM,0,1); 329276116Sdcs#endif 329340843Smsmith 329494290Sdcs si = vmGetWord(pVM); 329594290Sdcs PUSHUNS((FICL_UNS)(si.cp[0])); 329640843Smsmith return; 329740843Smsmith} 329840843Smsmith 329940843Smsmithstatic void charCoIm(FICL_VM *pVM) 330040843Smsmith{ 330140843Smsmith ficlChar(pVM); 330240843Smsmith literalIm(pVM); 330340843Smsmith return; 330440843Smsmith} 330540843Smsmith 330640843Smsmith/************************************************************************** 330740843Smsmith c h a r P l u s 330840843Smsmith** char-plus CORE ( c-addr1 -- c-addr2 ) 330940843Smsmith** Add the size in address units of a character to c-addr1, giving c-addr2. 331040843Smsmith**************************************************************************/ 331140843Smsmithstatic void charPlus(FICL_VM *pVM) 331240843Smsmith{ 331394290Sdcs char *cp; 331476116Sdcs#if FICL_ROBUST > 1 331594290Sdcs vmCheckStack(pVM,1,1); 331676116Sdcs#endif 331776116Sdcs 331894290Sdcs cp = POPPTR(); 331994290Sdcs PUSHPTR(cp + 1); 332040843Smsmith return; 332140843Smsmith} 332240843Smsmith 332340843Smsmith/************************************************************************** 332440843Smsmith c h a r s 332540843Smsmith** chars CORE ( n1 -- n2 ) 332640843Smsmith** n2 is the size in address units of n1 characters. 332740843Smsmith** For most processors, this function can be a no-op. To guarantee 332840843Smsmith** portability, we'll multiply by sizeof (char). 332940843Smsmith**************************************************************************/ 333040843Smsmith#if defined (_M_IX86) 333140843Smsmith#pragma warning(disable: 4127) 333240843Smsmith#endif 333340843Smsmithstatic void ficlChars(FICL_VM *pVM) 333440843Smsmith{ 333594290Sdcs if (sizeof (char) > 1) 333694290Sdcs { 333794290Sdcs FICL_INT i; 333876116Sdcs#if FICL_ROBUST > 1 333994290Sdcs vmCheckStack(pVM,1,1); 334076116Sdcs#endif 334194290Sdcs i = POPINT(); 334294290Sdcs PUSHINT(i * sizeof (char)); 334394290Sdcs } 334494290Sdcs /* otherwise no-op! */ 334540843Smsmith return; 334640843Smsmith} 334740843Smsmith#if defined (_M_IX86) 334840843Smsmith#pragma warning(default: 4127) 334940843Smsmith#endif 335040843Smsmith 335140843Smsmith 335240843Smsmith/************************************************************************** 335340843Smsmith c o u n t 335440843Smsmith** COUNT CORE ( c-addr1 -- c-addr2 u ) 335540843Smsmith** Return the character string specification for the counted string stored 335640843Smsmith** at c-addr1. c-addr2 is the address of the first character after c-addr1. 335740843Smsmith** u is the contents of the character at c-addr1, which is the length in 335840843Smsmith** characters of the string at c-addr2. 335940843Smsmith**************************************************************************/ 336040843Smsmithstatic void count(FICL_VM *pVM) 336140843Smsmith{ 336294290Sdcs FICL_STRING *sp; 336376116Sdcs#if FICL_ROBUST > 1 336494290Sdcs vmCheckStack(pVM,1,2); 336576116Sdcs#endif 336676116Sdcs 336794290Sdcs sp = POPPTR(); 336894290Sdcs PUSHPTR(sp->text); 336994290Sdcs PUSHUNS(sp->count); 337040843Smsmith return; 337140843Smsmith} 337240843Smsmith 337340843Smsmith/************************************************************************** 337440843Smsmith e n v i r o n m e n t ? 337540843Smsmith** environment-query CORE ( c-addr u -- false | i*x true ) 337640843Smsmith** c-addr is the address of a character string and u is the string's 337740843Smsmith** character count. u may have a value in the range from zero to an 337840843Smsmith** implementation-defined maximum which shall not be less than 31. The 337940843Smsmith** character string should contain a keyword from 3.2.6 Environmental 338040843Smsmith** queries or the optional word sets to be checked for correspondence 338140843Smsmith** with an attribute of the present environment. If the system treats the 338240843Smsmith** attribute as unknown, the returned flag is false; otherwise, the flag 338340843Smsmith** is true and the i*x returned is of the type specified in the table for 338440843Smsmith** the attribute queried. 338540843Smsmith**************************************************************************/ 338640843Smsmithstatic void environmentQ(FICL_VM *pVM) 338740843Smsmith{ 338894290Sdcs FICL_DICT *envp; 338994290Sdcs FICL_WORD *pFW; 339094290Sdcs STRINGINFO si; 339176116Sdcs#if FICL_ROBUST > 1 339294290Sdcs vmCheckStack(pVM,2,1); 339376116Sdcs#endif 339440843Smsmith 339594290Sdcs envp = pVM->pSys->envp; 339694290Sdcs si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); 339794290Sdcs si.cp = stackPopPtr(pVM->pStack); 339851786Sdcs 339994290Sdcs pFW = dictLookup(envp, si); 340040843Smsmith 340194290Sdcs if (pFW != NULL) 340294290Sdcs { 340394290Sdcs vmExecute(pVM, pFW); 340494290Sdcs PUSHINT(FICL_TRUE); 340594290Sdcs } 340694290Sdcs else 340794290Sdcs { 340894290Sdcs PUSHINT(FICL_FALSE); 340994290Sdcs } 341040843Smsmith return; 341140843Smsmith} 341240843Smsmith 341340843Smsmith/************************************************************************** 341440843Smsmith e v a l u a t e 341540843Smsmith** EVALUATE CORE ( i*x c-addr u -- j*x ) 341640843Smsmith** Save the current input source specification. Store minus-one (-1) in 341740843Smsmith** SOURCE-ID if it is present. Make the string described by c-addr and u 341860959Sdcs** both the input source and input buffer, set >IN to zero, and interpret. 341940843Smsmith** When the parse area is empty, restore the prior input source 342040843Smsmith** specification. Other stack effects are due to the words EVALUATEd. 342140843Smsmith** 342240843Smsmith**************************************************************************/ 342340843Smsmithstatic void evaluate(FICL_VM *pVM) 342440843Smsmith{ 342594290Sdcs FICL_UNS count; 342694290Sdcs char *cp; 342794290Sdcs CELL id; 342843078Smsmith int result; 342976116Sdcs#if FICL_ROBUST > 1 343094290Sdcs vmCheckStack(pVM,2,0); 343176116Sdcs#endif 343240843Smsmith 343394290Sdcs count = POPUNS(); 343494290Sdcs cp = POPPTR(); 343551786Sdcs 343694290Sdcs IGNORE(count); 343794290Sdcs id = pVM->sourceID; 343894290Sdcs pVM->sourceID.i = -1; 343994290Sdcs result = ficlExecC(pVM, cp, count); 344094290Sdcs pVM->sourceID = id; 344194290Sdcs if (result != VM_OUTOFTEXT) 344294290Sdcs vmThrow(pVM, result); 344376116Sdcs 344440843Smsmith return; 344540843Smsmith} 344640843Smsmith 344740843Smsmith 344840843Smsmith/************************************************************************** 344940843Smsmith s t r i n g q u o t e 345076116Sdcs** Interpreting: get string delimited by a quote from the input stream, 345140843Smsmith** copy to a scratch area, and put its count and address on the stack. 345240843Smsmith** Compiling: compile code to push the address and count of a string 345340843Smsmith** literal, compile the string from the input stream, and align the dict 345440843Smsmith** pointer. 345540843Smsmith**************************************************************************/ 345640843Smsmithstatic void stringQuoteIm(FICL_VM *pVM) 345740843Smsmith{ 345894290Sdcs FICL_DICT *dp = vmGetDict(pVM); 345940843Smsmith 346040843Smsmith if (pVM->state == INTERPRET) 346140843Smsmith { 346240843Smsmith FICL_STRING *sp = (FICL_STRING *) dp->here; 346340843Smsmith vmGetString(pVM, sp, '\"'); 346476116Sdcs PUSHPTR(sp->text); 346576116Sdcs PUSHUNS(sp->count); 346640843Smsmith } 346740843Smsmith else /* COMPILE state */ 346840843Smsmith { 346994290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); 347040843Smsmith dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 347140843Smsmith dictAlign(dp); 347240843Smsmith } 347340843Smsmith 347440843Smsmith return; 347540843Smsmith} 347640843Smsmith 347760959Sdcs 347840843Smsmith/************************************************************************** 347940843Smsmith t y p e 348040843Smsmith** Pop count and char address from stack and print the designated string. 348140843Smsmith**************************************************************************/ 348240843Smsmithstatic void type(FICL_VM *pVM) 348340843Smsmith{ 348451786Sdcs FICL_UNS count = stackPopUNS(pVM->pStack); 348540843Smsmith char *cp = stackPopPtr(pVM->pStack); 348643599Sdcs char *pDest = (char *)ficlMalloc(count + 1); 348740843Smsmith 348840843Smsmith /* 348940843Smsmith ** Since we don't have an output primitive for a counted string 349040843Smsmith ** (oops), make sure the string is null terminated. If not, copy 349140843Smsmith ** and terminate it. 349240843Smsmith */ 349343135Smsmith if (!pDest) 349443135Smsmith vmThrowErr(pVM, "Error: out of memory"); 349594290Sdcs 349643135Smsmith strncpy(pDest, cp, count); 349743135Smsmith pDest[count] = '\0'; 349894290Sdcs 349943599Sdcs vmTextOut(pVM, pDest, 0); 350094290Sdcs 350143135Smsmith ficlFree(pDest); 350240843Smsmith return; 350340843Smsmith} 350440843Smsmith 350540843Smsmith/************************************************************************** 350640843Smsmith w o r d 350740843Smsmith** word CORE ( char "<chars>ccc<char>" -- c-addr ) 350840843Smsmith** Skip leading delimiters. Parse characters ccc delimited by char. An 350940843Smsmith** ambiguous condition exists if the length of the parsed string is greater 351040843Smsmith** than the implementation-defined length of a counted string. 351140843Smsmith** 351240843Smsmith** c-addr is the address of a transient region containing the parsed word 351340843Smsmith** as a counted string. If the parse area was empty or contained no 351440843Smsmith** characters other than the delimiter, the resulting string has a zero 351540843Smsmith** length. A space, not included in the length, follows the string. A 351640843Smsmith** program may replace characters within the string. 351740843Smsmith** NOTE! Ficl also NULL-terminates the dest string. 351840843Smsmith**************************************************************************/ 351940843Smsmithstatic void ficlWord(FICL_VM *pVM) 352040843Smsmith{ 352194290Sdcs FICL_STRING *sp; 352294290Sdcs char delim; 352394290Sdcs STRINGINFO si; 352476116Sdcs#if FICL_ROBUST > 1 352594290Sdcs vmCheckStack(pVM,1,1); 352676116Sdcs#endif 352776116Sdcs 352894290Sdcs sp = (FICL_STRING *)pVM->pad; 352994290Sdcs delim = (char)POPINT(); 353060959Sdcs si = vmParseStringEx(pVM, delim, 1); 353140843Smsmith 353294290Sdcs if (SI_COUNT(si) > nPAD-1) 353394290Sdcs SI_SETLEN(si, nPAD-1); 353440843Smsmith 353594290Sdcs sp->count = (FICL_COUNT)SI_COUNT(si); 353694290Sdcs strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); 353794290Sdcs /*#$-GUY CHANGE: I added this.-$#*/ 353894290Sdcs sp->text[sp->count] = 0; 353994290Sdcs strcat(sp->text, " "); 354040843Smsmith 354194290Sdcs PUSHPTR(sp); 354240843Smsmith return; 354340843Smsmith} 354440843Smsmith 354540843Smsmith 354640843Smsmith/************************************************************************** 354740843Smsmith p a r s e - w o r d 354840843Smsmith** ficl PARSE-WORD ( <spaces>name -- c-addr u ) 354940843Smsmith** Skip leading spaces and parse name delimited by a space. c-addr is the 355040843Smsmith** address within the input buffer and u is the length of the selected 355140843Smsmith** string. If the parse area is empty, the resulting string has a zero length. 355240843Smsmith**************************************************************************/ 355340843Smsmithstatic void parseNoCopy(FICL_VM *pVM) 355440843Smsmith{ 355594290Sdcs STRINGINFO si; 355676116Sdcs#if FICL_ROBUST > 1 355794290Sdcs vmCheckStack(pVM,0,2); 355876116Sdcs#endif 355976116Sdcs 356094290Sdcs si = vmGetWord0(pVM); 356194290Sdcs PUSHPTR(SI_PTR(si)); 356294290Sdcs PUSHUNS(SI_COUNT(si)); 356340843Smsmith return; 356440843Smsmith} 356540843Smsmith 356640843Smsmith 356740843Smsmith/************************************************************************** 356840843Smsmith p a r s e 356940843Smsmith** CORE EXT ( char "ccc<char>" -- c-addr u ) 357040843Smsmith** Parse ccc delimited by the delimiter char. 357140843Smsmith** c-addr is the address (within the input buffer) and u is the length of 357240843Smsmith** the parsed string. If the parse area was empty, the resulting string has 357340843Smsmith** a zero length. 357440843Smsmith** NOTE! PARSE differs from WORD: it does not skip leading delimiters. 357540843Smsmith**************************************************************************/ 357640843Smsmithstatic void parse(FICL_VM *pVM) 357740843Smsmith{ 357894290Sdcs STRINGINFO si; 357994290Sdcs char delim; 358040843Smsmith 358176116Sdcs#if FICL_ROBUST > 1 358294290Sdcs vmCheckStack(pVM,1,2); 358376116Sdcs#endif 358476116Sdcs 358594290Sdcs delim = (char)POPINT(); 358676116Sdcs 358794290Sdcs si = vmParseStringEx(pVM, delim, 0); 358894290Sdcs PUSHPTR(SI_PTR(si)); 358994290Sdcs PUSHUNS(SI_COUNT(si)); 359040843Smsmith return; 359140843Smsmith} 359240843Smsmith 359340843Smsmith 359440843Smsmith/************************************************************************** 359540843Smsmith f i l l 359640843Smsmith** CORE ( c-addr u char -- ) 359740843Smsmith** If u is greater than zero, store char in each of u consecutive 359840843Smsmith** characters of memory beginning at c-addr. 359940843Smsmith**************************************************************************/ 360040843Smsmithstatic void fill(FICL_VM *pVM) 360140843Smsmith{ 360294290Sdcs char ch; 360394290Sdcs FICL_UNS u; 360494290Sdcs char *cp; 360576116Sdcs#if FICL_ROBUST > 1 360694290Sdcs vmCheckStack(pVM,3,0); 360776116Sdcs#endif 360894290Sdcs ch = (char)POPINT(); 360994290Sdcs u = POPUNS(); 361094290Sdcs cp = (char *)POPPTR(); 361140843Smsmith 361294290Sdcs while (u > 0) 361394290Sdcs { 361494290Sdcs *cp++ = ch; 361594290Sdcs u--; 361694290Sdcs } 361740843Smsmith return; 361840843Smsmith} 361940843Smsmith 362040843Smsmith 362140843Smsmith/************************************************************************** 362240843Smsmith f i n d 362340843Smsmith** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 362440843Smsmith** Find the definition named in the counted string at c-addr. If the 362540843Smsmith** definition is not found, return c-addr and zero. If the definition is 362640843Smsmith** found, return its execution token xt. If the definition is immediate, 362740843Smsmith** also return one (1), otherwise also return minus-one (-1). For a given 362840843Smsmith** string, the values returned by FIND while compiling may differ from 362940843Smsmith** those returned while not compiling. 363040843Smsmith**************************************************************************/ 363194290Sdcsstatic void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure) 363240843Smsmith{ 363394290Sdcs FICL_WORD *pFW; 363494290Sdcs 363594290Sdcs pFW = dictLookup(vmGetDict(pVM), si); 363694290Sdcs if (pFW) 363794290Sdcs { 363894290Sdcs PUSHPTR(pFW); 363994290Sdcs PUSHINT((wordIsImmediate(pFW) ? 1 : -1)); 364094290Sdcs } 364194290Sdcs else 364294290Sdcs { 364394290Sdcs PUSHPTR(returnForFailure); 364494290Sdcs PUSHUNS(0); 364594290Sdcs } 364694290Sdcs return; 364794290Sdcs} 364894290Sdcs 364994290Sdcs 365094290Sdcs 365194290Sdcs/************************************************************************** 365294290Sdcs f i n d 365394290Sdcs** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 365494290Sdcs** Find the definition named in the counted string at c-addr. If the 365594290Sdcs** definition is not found, return c-addr and zero. If the definition is 365694290Sdcs** found, return its execution token xt. If the definition is immediate, 365794290Sdcs** also return one (1), otherwise also return minus-one (-1). For a given 365894290Sdcs** string, the values returned by FIND while compiling may differ from 365994290Sdcs** those returned while not compiling. 366094290Sdcs**************************************************************************/ 366194290Sdcsstatic void cFind(FICL_VM *pVM) 366294290Sdcs{ 366394290Sdcs FICL_STRING *sp; 366494290Sdcs STRINGINFO si; 366594290Sdcs 366676116Sdcs#if FICL_ROBUST > 1 366794290Sdcs vmCheckStack(pVM,1,2); 366876116Sdcs#endif 366994290Sdcs sp = POPPTR(); 367094290Sdcs SI_PFS(si, sp); 367194290Sdcs do_find(pVM, si, sp); 367294290Sdcs} 367340843Smsmith 367494290Sdcs 367594290Sdcs 367694290Sdcs/************************************************************************** 367794290Sdcs s f i n d 367894290Sdcs** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 ) 367994290Sdcs** Like FIND, but takes "c-addr u" for the string. 368094290Sdcs**************************************************************************/ 368194290Sdcsstatic void sFind(FICL_VM *pVM) 368294290Sdcs{ 368394290Sdcs STRINGINFO si; 368494290Sdcs 368594290Sdcs#if FICL_ROBUST > 1 368694290Sdcs vmCheckStack(pVM,2,2); 368794290Sdcs#endif 368894290Sdcs 368994290Sdcs si.count = stackPopINT(pVM->pStack); 369094290Sdcs si.cp = stackPopPtr(pVM->pStack); 369194290Sdcs 369294290Sdcs do_find(pVM, si, NULL); 369340843Smsmith} 369440843Smsmith 369540843Smsmith 369660959Sdcs 369740843Smsmith/************************************************************************** 369840843Smsmith f m S l a s h M o d 369940843Smsmith** f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) 370040843Smsmith** Divide d1 by n1, giving the floored quotient n3 and the remainder n2. 370140843Smsmith** Input and output stack arguments are signed. An ambiguous condition 370240843Smsmith** exists if n1 is zero or if the quotient lies outside the range of a 370340843Smsmith** single-cell signed integer. 370440843Smsmith**************************************************************************/ 370540843Smsmithstatic void fmSlashMod(FICL_VM *pVM) 370640843Smsmith{ 370794290Sdcs DPINT d1; 370894290Sdcs FICL_INT n1; 370994290Sdcs INTQR qr; 371076116Sdcs#if FICL_ROBUST > 1 371194290Sdcs vmCheckStack(pVM,3,2); 371276116Sdcs#endif 371340843Smsmith 371494290Sdcs n1 = POPINT(); 371594290Sdcs d1 = i64Pop(pVM->pStack); 371694290Sdcs qr = m64FlooredDivI(d1, n1); 371794290Sdcs PUSHINT(qr.rem); 371894290Sdcs PUSHINT(qr.quot); 371940843Smsmith return; 372040843Smsmith} 372140843Smsmith 372240843Smsmith 372340843Smsmith/************************************************************************** 372440843Smsmith s m S l a s h R e m 372540843Smsmith** s-m-slash-rem CORE ( d1 n1 -- n2 n3 ) 372640843Smsmith** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 372740843Smsmith** Input and output stack arguments are signed. An ambiguous condition 372840843Smsmith** exists if n1 is zero or if the quotient lies outside the range of a 372940843Smsmith** single-cell signed integer. 373040843Smsmith**************************************************************************/ 373140843Smsmithstatic void smSlashRem(FICL_VM *pVM) 373240843Smsmith{ 373394290Sdcs DPINT d1; 373494290Sdcs FICL_INT n1; 373594290Sdcs INTQR qr; 373676116Sdcs#if FICL_ROBUST > 1 373794290Sdcs vmCheckStack(pVM,3,2); 373876116Sdcs#endif 373940843Smsmith 374094290Sdcs n1 = POPINT(); 374194290Sdcs d1 = i64Pop(pVM->pStack); 374294290Sdcs qr = m64SymmetricDivI(d1, n1); 374394290Sdcs PUSHINT(qr.rem); 374494290Sdcs PUSHINT(qr.quot); 374540843Smsmith return; 374640843Smsmith} 374740843Smsmith 374840843Smsmith 374940843Smsmithstatic void ficlMod(FICL_VM *pVM) 375040843Smsmith{ 375194290Sdcs DPINT d1; 375294290Sdcs FICL_INT n1; 375394290Sdcs INTQR qr; 375476116Sdcs#if FICL_ROBUST > 1 375594290Sdcs vmCheckStack(pVM,2,1); 375676116Sdcs#endif 375740843Smsmith 375894290Sdcs n1 = POPINT(); 375994290Sdcs d1.lo = POPINT(); 376094290Sdcs i64Extend(d1); 376194290Sdcs qr = m64SymmetricDivI(d1, n1); 376294290Sdcs PUSHINT(qr.rem); 376340843Smsmith return; 376440843Smsmith} 376540843Smsmith 376640843Smsmith 376740843Smsmith/************************************************************************** 376840843Smsmith u m S l a s h M o d 376940843Smsmith** u-m-slash-mod CORE ( ud u1 -- u2 u3 ) 377040843Smsmith** Divide ud by u1, giving the quotient u3 and the remainder u2. 377140843Smsmith** All values and arithmetic are unsigned. An ambiguous condition 377240843Smsmith** exists if u1 is zero or if the quotient lies outside the range of a 377340843Smsmith** single-cell unsigned integer. 377440843Smsmith*************************************************************************/ 377540843Smsmithstatic void umSlashMod(FICL_VM *pVM) 377640843Smsmith{ 377751786Sdcs DPUNS ud; 377851786Sdcs FICL_UNS u1; 377940843Smsmith UNSQR qr; 378040843Smsmith 378151786Sdcs u1 = stackPopUNS(pVM->pStack); 378240843Smsmith ud = u64Pop(pVM->pStack); 378340843Smsmith qr = ficlLongDiv(ud, u1); 378476116Sdcs PUSHUNS(qr.rem); 378576116Sdcs PUSHUNS(qr.quot); 378640843Smsmith return; 378740843Smsmith} 378840843Smsmith 378940843Smsmith 379040843Smsmith/************************************************************************** 379140843Smsmith l s h i f t 379240843Smsmith** l-shift CORE ( x1 u -- x2 ) 379340843Smsmith** Perform a logical left shift of u bit-places on x1, giving x2. 379440843Smsmith** Put zeroes into the least significant bits vacated by the shift. 379540843Smsmith** An ambiguous condition exists if u is greater than or equal to the 379640843Smsmith** number of bits in a cell. 379740843Smsmith** 379840843Smsmith** r-shift CORE ( x1 u -- x2 ) 379940843Smsmith** Perform a logical right shift of u bit-places on x1, giving x2. 380040843Smsmith** Put zeroes into the most significant bits vacated by the shift. An 380140843Smsmith** ambiguous condition exists if u is greater than or equal to the 380240843Smsmith** number of bits in a cell. 380340843Smsmith**************************************************************************/ 380440843Smsmithstatic void lshift(FICL_VM *pVM) 380540843Smsmith{ 380694290Sdcs FICL_UNS nBits; 380794290Sdcs FICL_UNS x1; 380876116Sdcs#if FICL_ROBUST > 1 380994290Sdcs vmCheckStack(pVM,2,1); 381076116Sdcs#endif 381140843Smsmith 381294290Sdcs nBits = POPUNS(); 381394290Sdcs x1 = POPUNS(); 381494290Sdcs PUSHUNS(x1 << nBits); 381540843Smsmith return; 381640843Smsmith} 381740843Smsmith 381840843Smsmith 381940843Smsmithstatic void rshift(FICL_VM *pVM) 382040843Smsmith{ 382194290Sdcs FICL_UNS nBits; 382294290Sdcs FICL_UNS x1; 382376116Sdcs#if FICL_ROBUST > 1 382494290Sdcs vmCheckStack(pVM,2,1); 382576116Sdcs#endif 382640843Smsmith 382794290Sdcs nBits = POPUNS(); 382894290Sdcs x1 = POPUNS(); 382976116Sdcs 383094290Sdcs PUSHUNS(x1 >> nBits); 383140843Smsmith return; 383240843Smsmith} 383340843Smsmith 383440843Smsmith 383540843Smsmith/************************************************************************** 383640843Smsmith m S t a r 383740843Smsmith** m-star CORE ( n1 n2 -- d ) 383840843Smsmith** d is the signed product of n1 times n2. 383940843Smsmith**************************************************************************/ 384040843Smsmithstatic void mStar(FICL_VM *pVM) 384140843Smsmith{ 384294290Sdcs FICL_INT n2; 384394290Sdcs FICL_INT n1; 384494290Sdcs DPINT d; 384576116Sdcs#if FICL_ROBUST > 1 384694290Sdcs vmCheckStack(pVM,2,2); 384776116Sdcs#endif 384876116Sdcs 384994290Sdcs n2 = POPINT(); 385094290Sdcs n1 = POPINT(); 385176116Sdcs 385294290Sdcs d = m64MulI(n1, n2); 385394290Sdcs i64Push(pVM->pStack, d); 385440843Smsmith return; 385540843Smsmith} 385640843Smsmith 385740843Smsmith 385840843Smsmithstatic void umStar(FICL_VM *pVM) 385940843Smsmith{ 386094290Sdcs FICL_UNS u2; 386194290Sdcs FICL_UNS u1; 386294290Sdcs DPUNS ud; 386376116Sdcs#if FICL_ROBUST > 1 386494290Sdcs vmCheckStack(pVM,2,2); 386576116Sdcs#endif 386676116Sdcs 386794290Sdcs u2 = POPUNS(); 386894290Sdcs u1 = POPUNS(); 386976116Sdcs 387094290Sdcs ud = ficlLongMul(u1, u2); 387194290Sdcs u64Push(pVM->pStack, ud); 387240843Smsmith return; 387340843Smsmith} 387440843Smsmith 387540843Smsmith 387640843Smsmith/************************************************************************** 387740843Smsmith m a x & m i n 387840843Smsmith** 387940843Smsmith**************************************************************************/ 388040843Smsmithstatic void ficlMax(FICL_VM *pVM) 388140843Smsmith{ 388294290Sdcs FICL_INT n2; 388394290Sdcs FICL_INT n1; 388476116Sdcs#if FICL_ROBUST > 1 388594290Sdcs vmCheckStack(pVM,2,1); 388676116Sdcs#endif 388740843Smsmith 388894290Sdcs n2 = POPINT(); 388994290Sdcs n1 = POPINT(); 389076116Sdcs 389194290Sdcs PUSHINT((n1 > n2) ? n1 : n2); 389240843Smsmith return; 389340843Smsmith} 389440843Smsmith 389540843Smsmithstatic void ficlMin(FICL_VM *pVM) 389640843Smsmith{ 389794290Sdcs FICL_INT n2; 389894290Sdcs FICL_INT n1; 389976116Sdcs#if FICL_ROBUST > 1 390094290Sdcs vmCheckStack(pVM,2,1); 390176116Sdcs#endif 390240843Smsmith 390394290Sdcs n2 = POPINT(); 390494290Sdcs n1 = POPINT(); 390576116Sdcs 390694290Sdcs PUSHINT((n1 < n2) ? n1 : n2); 390740843Smsmith return; 390840843Smsmith} 390940843Smsmith 391040843Smsmith 391140843Smsmith/************************************************************************** 391240843Smsmith m o v e 391340843Smsmith** CORE ( addr1 addr2 u -- ) 391440843Smsmith** If u is greater than zero, copy the contents of u consecutive address 391540843Smsmith** units at addr1 to the u consecutive address units at addr2. After MOVE 391640843Smsmith** completes, the u consecutive address units at addr2 contain exactly 391740843Smsmith** what the u consecutive address units at addr1 contained before the move. 391840843Smsmith** NOTE! This implementation assumes that a char is the same size as 391940843Smsmith** an address unit. 392040843Smsmith**************************************************************************/ 392140843Smsmithstatic void move(FICL_VM *pVM) 392240843Smsmith{ 392394290Sdcs FICL_UNS u; 392494290Sdcs char *addr2; 392594290Sdcs char *addr1; 392676116Sdcs#if FICL_ROBUST > 1 392794290Sdcs vmCheckStack(pVM,3,0); 392876116Sdcs#endif 392940843Smsmith 393094290Sdcs u = POPUNS(); 393194290Sdcs addr2 = POPPTR(); 393294290Sdcs addr1 = POPPTR(); 393376116Sdcs 393440843Smsmith if (u == 0) 393540843Smsmith return; 393640843Smsmith /* 393740843Smsmith ** Do the copy carefully, so as to be 393840843Smsmith ** correct even if the two ranges overlap 393940843Smsmith */ 394040843Smsmith if (addr1 >= addr2) 394140843Smsmith { 394240843Smsmith for (; u > 0; u--) 394340843Smsmith *addr2++ = *addr1++; 394440843Smsmith } 394540843Smsmith else 394640843Smsmith { 394740843Smsmith addr2 += u-1; 394840843Smsmith addr1 += u-1; 394940843Smsmith for (; u > 0; u--) 395040843Smsmith *addr2-- = *addr1--; 395140843Smsmith } 395240843Smsmith 395340843Smsmith return; 395440843Smsmith} 395540843Smsmith 395640843Smsmith 395740843Smsmith/************************************************************************** 395840843Smsmith r e c u r s e 395940843Smsmith** 396040843Smsmith**************************************************************************/ 396140843Smsmithstatic void recurseCoIm(FICL_VM *pVM) 396240843Smsmith{ 396394290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 396440843Smsmith 396540843Smsmith IGNORE(pVM); 396640843Smsmith dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); 396740843Smsmith return; 396840843Smsmith} 396940843Smsmith 397040843Smsmith 397140843Smsmith/************************************************************************** 397240843Smsmith s t o d 397340843Smsmith** s-to-d CORE ( n -- d ) 397440843Smsmith** Convert the number n to the double-cell number d with the same 397540843Smsmith** numerical value. 397640843Smsmith**************************************************************************/ 397740843Smsmithstatic void sToD(FICL_VM *pVM) 397840843Smsmith{ 397994290Sdcs FICL_INT s; 398076116Sdcs#if FICL_ROBUST > 1 398194290Sdcs vmCheckStack(pVM,1,2); 398276116Sdcs#endif 398340843Smsmith 398494290Sdcs s = POPINT(); 398576116Sdcs 398694290Sdcs /* sign extend to 64 bits.. */ 398794290Sdcs PUSHINT(s); 398894290Sdcs PUSHINT((s < 0) ? -1 : 0); 398940843Smsmith return; 399040843Smsmith} 399140843Smsmith 399240843Smsmith 399340843Smsmith/************************************************************************** 399440843Smsmith s o u r c e 399540843Smsmith** CORE ( -- c-addr u ) 399640843Smsmith** c-addr is the address of, and u is the number of characters in, the 399740843Smsmith** input buffer. 399840843Smsmith**************************************************************************/ 399940843Smsmithstatic void source(FICL_VM *pVM) 400060959Sdcs{ 400176116Sdcs#if FICL_ROBUST > 1 400294290Sdcs vmCheckStack(pVM,0,2); 400376116Sdcs#endif 400494290Sdcs PUSHPTR(pVM->tib.cp); 400576116Sdcs PUSHINT(vmGetInBufLen(pVM)); 400640843Smsmith return; 400740843Smsmith} 400840843Smsmith 400940843Smsmith 401040843Smsmith/************************************************************************** 401140843Smsmith v e r s i o n 401240843Smsmith** non-standard... 401340843Smsmith**************************************************************************/ 401440843Smsmithstatic void ficlVersion(FICL_VM *pVM) 401540843Smsmith{ 401640843Smsmith vmTextOut(pVM, "ficl Version " FICL_VER, 1); 401740843Smsmith return; 401840843Smsmith} 401940843Smsmith 402040843Smsmith 402140843Smsmith/************************************************************************** 402240843Smsmith t o I n 402340843Smsmith** to-in CORE 402440843Smsmith**************************************************************************/ 402540843Smsmithstatic void toIn(FICL_VM *pVM) 402640843Smsmith{ 402740843Smsmith#if FICL_ROBUST > 1 402894290Sdcs vmCheckStack(pVM,0,1); 402940843Smsmith#endif 403094290Sdcs PUSHPTR(&pVM->tib.index); 403140843Smsmith return; 403240843Smsmith} 403340843Smsmith 403440843Smsmith 403540843Smsmith/************************************************************************** 403640843Smsmith c o l o n N o N a m e 403740843Smsmith** CORE EXT ( C: -- colon-sys ) ( S: -- xt ) 403840843Smsmith** Create an unnamed colon definition and push its address. 403940843Smsmith** Change state to compile. 404040843Smsmith**************************************************************************/ 404140843Smsmithstatic void colonNoName(FICL_VM *pVM) 404240843Smsmith{ 404394290Sdcs FICL_DICT *dp = vmGetDict(pVM); 404440843Smsmith FICL_WORD *pFW; 404540843Smsmith STRINGINFO si; 404640843Smsmith 404740843Smsmith SI_SETLEN(si, 0); 404840843Smsmith SI_SETPTR(si, NULL); 404940843Smsmith 405040843Smsmith pVM->state = COMPILE; 405140843Smsmith pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 405276116Sdcs PUSHPTR(pFW); 405340843Smsmith markControlTag(pVM, colonTag); 405440843Smsmith return; 405540843Smsmith} 405640843Smsmith 405740843Smsmith 405840843Smsmith/************************************************************************** 405940843Smsmith u s e r V a r i a b l e 406040843Smsmith** user ( u -- ) "<spaces>name" 406140843Smsmith** Get a name from the input stream and create a user variable 406240843Smsmith** with the name and the index supplied. The run-time effect 406340843Smsmith** of a user variable is to push the address of the indexed cell 406440843Smsmith** in the running vm's user array. 406540843Smsmith** 406640843Smsmith** User variables are vm local cells. Each vm has an array of 406740843Smsmith** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. 406840843Smsmith** Ficl's user facility is implemented with two primitives, 406940843Smsmith** "user" and "(user)", a variable ("nUser") (in softcore.c) that 407040843Smsmith** holds the index of the next free user cell, and a redefinition 407140843Smsmith** (also in softcore) of "user" that defines a user word and increments 407240843Smsmith** nUser. 407340843Smsmith**************************************************************************/ 407440843Smsmith#if FICL_WANT_USER 407540843Smsmithstatic void userParen(FICL_VM *pVM) 407640843Smsmith{ 407751786Sdcs FICL_INT i = pVM->runningWord->param[0].i; 407876116Sdcs PUSHPTR(&pVM->user[i]); 407940843Smsmith return; 408040843Smsmith} 408140843Smsmith 408240843Smsmith 408340843Smsmithstatic void userVariable(FICL_VM *pVM) 408440843Smsmith{ 408594290Sdcs FICL_DICT *dp = vmGetDict(pVM); 408640843Smsmith STRINGINFO si = vmGetWord(pVM); 408740843Smsmith CELL c; 408840843Smsmith 408940843Smsmith c = stackPop(pVM->pStack); 409040843Smsmith if (c.i >= FICL_USER_CELLS) 409140843Smsmith { 409240843Smsmith vmThrowErr(pVM, "Error - out of user space"); 409340843Smsmith } 409440843Smsmith 409540843Smsmith dictAppendWord2(dp, si, userParen, FW_DEFAULT); 409640843Smsmith dictAppendCell(dp, c); 409740843Smsmith return; 409840843Smsmith} 409940843Smsmith#endif 410040843Smsmith 410140843Smsmith 410240843Smsmith/************************************************************************** 410340843Smsmith t o V a l u e 410440843Smsmith** CORE EXT 410540843Smsmith** Interpretation: ( x "<spaces>name" -- ) 410640843Smsmith** Skip leading spaces and parse name delimited by a space. Store x in 410740843Smsmith** name. An ambiguous condition exists if name was not defined by VALUE. 410840843Smsmith** NOTE: In ficl, VALUE is an alias of CONSTANT 410940843Smsmith**************************************************************************/ 411040843Smsmithstatic void toValue(FICL_VM *pVM) 411140843Smsmith{ 411240843Smsmith STRINGINFO si = vmGetWord(pVM); 411394290Sdcs FICL_DICT *dp = vmGetDict(pVM); 411440843Smsmith FICL_WORD *pFW; 411540843Smsmith 411640843Smsmith#if FICL_WANT_LOCALS 411794290Sdcs if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE)) 411840843Smsmith { 411994290Sdcs FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 412040843Smsmith pFW = dictLookup(pLoc, si); 412160959Sdcs if (pFW && (pFW->code == doLocalIm)) 412240843Smsmith { 412394290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen)); 412440843Smsmith dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 412540843Smsmith return; 412640843Smsmith } 412776116Sdcs else if (pFW && pFW->code == do2LocalIm) 412876116Sdcs { 412994290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); 413060959Sdcs dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 413160959Sdcs return; 413276116Sdcs } 413340843Smsmith } 413440843Smsmith#endif 413540843Smsmith 413694290Sdcs assert(pVM->pSys->pStore); 413740843Smsmith 413840843Smsmith pFW = dictLookup(dp, si); 413940843Smsmith if (!pFW) 414040843Smsmith { 414140843Smsmith int i = SI_COUNT(si); 414240843Smsmith vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 414340843Smsmith } 414440843Smsmith 414540843Smsmith if (pVM->state == INTERPRET) 414640843Smsmith pFW->param[0] = stackPop(pVM->pStack); 414740843Smsmith else /* compile code to store to word's param */ 414840843Smsmith { 414976116Sdcs PUSHPTR(&pFW->param[0]); 415040843Smsmith literalIm(pVM); 415194290Sdcs dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore)); 415240843Smsmith } 415340843Smsmith return; 415440843Smsmith} 415540843Smsmith 415640843Smsmith 415740843Smsmith#if FICL_WANT_LOCALS 415840843Smsmith/************************************************************************** 415940843Smsmith l i n k P a r e n 416040843Smsmith** ( -- ) 416140843Smsmith** Link a frame on the return stack, reserving nCells of space for 416240843Smsmith** locals - the value of nCells is the next cell in the instruction 416340843Smsmith** stream. 416440843Smsmith**************************************************************************/ 416540843Smsmithstatic void linkParen(FICL_VM *pVM) 416640843Smsmith{ 416751786Sdcs FICL_INT nLink = *(FICL_INT *)(pVM->ip); 416840843Smsmith vmBranchRelative(pVM, 1); 416940843Smsmith stackLink(pVM->rStack, nLink); 417040843Smsmith return; 417140843Smsmith} 417240843Smsmith 417340843Smsmith 417440843Smsmithstatic void unlinkParen(FICL_VM *pVM) 417540843Smsmith{ 417640843Smsmith stackUnlink(pVM->rStack); 417740843Smsmith return; 417840843Smsmith} 417940843Smsmith 418040843Smsmith 418140843Smsmith/************************************************************************** 418240843Smsmith d o L o c a l I m 418340843Smsmith** Immediate - cfa of a local while compiling - when executed, compiles 418440843Smsmith** code to fetch the value of a local given the local's index in the 418540843Smsmith** word's pfa 418640843Smsmith**************************************************************************/ 418740843Smsmithstatic void getLocalParen(FICL_VM *pVM) 418840843Smsmith{ 418951786Sdcs FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 419040843Smsmith stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 419140843Smsmith return; 419240843Smsmith} 419340843Smsmith 419440843Smsmith 419540843Smsmithstatic void toLocalParen(FICL_VM *pVM) 419640843Smsmith{ 419751786Sdcs FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 419840843Smsmith pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 419940843Smsmith return; 420040843Smsmith} 420140843Smsmith 420240843Smsmith 420340843Smsmithstatic void getLocal0(FICL_VM *pVM) 420440843Smsmith{ 420540843Smsmith stackPush(pVM->pStack, pVM->rStack->pFrame[0]); 420640843Smsmith return; 420740843Smsmith} 420840843Smsmith 420940843Smsmith 421040843Smsmithstatic void toLocal0(FICL_VM *pVM) 421140843Smsmith{ 421240843Smsmith pVM->rStack->pFrame[0] = stackPop(pVM->pStack); 421340843Smsmith return; 421440843Smsmith} 421540843Smsmith 421640843Smsmith 421740843Smsmithstatic void getLocal1(FICL_VM *pVM) 421840843Smsmith{ 421940843Smsmith stackPush(pVM->pStack, pVM->rStack->pFrame[1]); 422040843Smsmith return; 422140843Smsmith} 422240843Smsmith 422340843Smsmith 422440843Smsmithstatic void toLocal1(FICL_VM *pVM) 422540843Smsmith{ 422640843Smsmith pVM->rStack->pFrame[1] = stackPop(pVM->pStack); 422740843Smsmith return; 422840843Smsmith} 422940843Smsmith 423040843Smsmith 423140843Smsmith/* 423240843Smsmith** Each local is recorded in a private locals dictionary as a 423340843Smsmith** word that does doLocalIm at runtime. DoLocalIm compiles code 423440843Smsmith** into the client definition to fetch the value of the 423540843Smsmith** corresponding local variable from the return stack. 423640843Smsmith** The private dictionary gets initialized at the end of each block 423740843Smsmith** that uses locals (in ; and does> for example). 423840843Smsmith*/ 423940843Smsmithstatic void doLocalIm(FICL_VM *pVM) 424040843Smsmith{ 424194290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 424294290Sdcs FICL_INT nLocal = pVM->runningWord->param[0].i; 424340843Smsmith 424440843Smsmith if (pVM->state == INTERPRET) 424540843Smsmith { 424640843Smsmith stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 424740843Smsmith } 424840843Smsmith else 424940843Smsmith { 425040843Smsmith 425140843Smsmith if (nLocal == 0) 425240843Smsmith { 425394290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0)); 425440843Smsmith } 425540843Smsmith else if (nLocal == 1) 425640843Smsmith { 425794290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1)); 425840843Smsmith } 425940843Smsmith else 426040843Smsmith { 426194290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen)); 426240843Smsmith dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 426340843Smsmith } 426440843Smsmith } 426540843Smsmith return; 426640843Smsmith} 426740843Smsmith 426840843Smsmith 426940843Smsmith/************************************************************************** 427040843Smsmith l o c a l P a r e n 427140843Smsmith** paren-local-paren LOCAL 427240843Smsmith** Interpretation: Interpretation semantics for this word are undefined. 427340843Smsmith** Execution: ( c-addr u -- ) 427440843Smsmith** When executed during compilation, (LOCAL) passes a message to the 427540843Smsmith** system that has one of two meanings. If u is non-zero, 427640843Smsmith** the message identifies a new local whose definition name is given by 427740843Smsmith** the string of characters identified by c-addr u. If u is zero, 427840843Smsmith** the message is last local and c-addr has no significance. 427940843Smsmith** 428040843Smsmith** The result of executing (LOCAL) during compilation of a definition is 428140843Smsmith** to create a set of named local identifiers, each of which is 428240843Smsmith** a definition name, that only have execution semantics within the scope 428340843Smsmith** of that definition's source. 428440843Smsmith** 428540843Smsmith** local Execution: ( -- x ) 428640843Smsmith** 428740843Smsmith** Push the local's value, x, onto the stack. The local's value is 428840843Smsmith** initialized as described in 13.3.3 Processing locals and may be 428940843Smsmith** changed by preceding the local's name with TO. An ambiguous condition 429040843Smsmith** exists when local is executed while in interpretation state. 429140843Smsmith**************************************************************************/ 429240843Smsmithstatic void localParen(FICL_VM *pVM) 429340843Smsmith{ 429494290Sdcs FICL_DICT *pDict; 429594290Sdcs STRINGINFO si; 429676116Sdcs#if FICL_ROBUST > 1 429794290Sdcs vmCheckStack(pVM,2,0); 429876116Sdcs#endif 429940843Smsmith 430094290Sdcs pDict = vmGetDict(pVM); 430194290Sdcs SI_SETLEN(si, POPUNS()); 430294290Sdcs SI_SETPTR(si, (char *)POPPTR()); 430376116Sdcs 430440843Smsmith if (SI_COUNT(si) > 0) 430560959Sdcs { /* add a local to the **locals** dict and update nLocals */ 430694290Sdcs FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 430794290Sdcs if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) 430840843Smsmith { 430940843Smsmith vmThrowErr(pVM, "Error: out of local space"); 431040843Smsmith } 431140843Smsmith 431240843Smsmith dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); 431394290Sdcs dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); 431440843Smsmith 431594290Sdcs if (pVM->pSys->nLocals == 0) 431640843Smsmith { /* compile code to create a local stack frame */ 431794290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); 431840843Smsmith /* save location in dictionary for #locals */ 431994290Sdcs pVM->pSys->pMarkLocals = pDict->here; 432094290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 432140843Smsmith /* compile code to initialize first local */ 432294290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0)); 432340843Smsmith } 432494290Sdcs else if (pVM->pSys->nLocals == 1) 432540843Smsmith { 432694290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1)); 432740843Smsmith } 432840843Smsmith else 432940843Smsmith { 433094290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen)); 433194290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 433240843Smsmith } 433340843Smsmith 433494290Sdcs (pVM->pSys->nLocals)++; 433540843Smsmith } 433694290Sdcs else if (pVM->pSys->nLocals > 0) 433740843Smsmith { /* write nLocals to (link) param area in dictionary */ 433894290Sdcs *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; 433940843Smsmith } 434040843Smsmith 434140843Smsmith return; 434240843Smsmith} 434340843Smsmith 434440843Smsmith 434560959Sdcsstatic void get2LocalParen(FICL_VM *pVM) 434660959Sdcs{ 434760959Sdcs FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 434860959Sdcs stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 434960959Sdcs stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); 435060959Sdcs return; 435160959Sdcs} 435260959Sdcs 435360959Sdcs 435460959Sdcsstatic void do2LocalIm(FICL_VM *pVM) 435560959Sdcs{ 435694290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 435794290Sdcs FICL_INT nLocal = pVM->runningWord->param[0].i; 435860959Sdcs 435960959Sdcs if (pVM->state == INTERPRET) 436060959Sdcs { 436160959Sdcs stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 436260959Sdcs stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); 436360959Sdcs } 436460959Sdcs else 436560959Sdcs { 436694290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen)); 436760959Sdcs dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 436860959Sdcs } 436960959Sdcs return; 437060959Sdcs} 437160959Sdcs 437260959Sdcs 437360959Sdcsstatic void to2LocalParen(FICL_VM *pVM) 437460959Sdcs{ 437560959Sdcs FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 437660959Sdcs pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack); 437760959Sdcs pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 437860959Sdcs return; 437960959Sdcs} 438060959Sdcs 438160959Sdcs 438260959Sdcsstatic void twoLocalParen(FICL_VM *pVM) 438360959Sdcs{ 438494290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 438560959Sdcs STRINGINFO si; 438660959Sdcs SI_SETLEN(si, stackPopUNS(pVM->pStack)); 438760959Sdcs SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); 438860959Sdcs 438960959Sdcs if (SI_COUNT(si) > 0) 439060959Sdcs { /* add a local to the **locals** dict and update nLocals */ 439194290Sdcs FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 439294290Sdcs if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) 439360959Sdcs { 439460959Sdcs vmThrowErr(pVM, "Error: out of local space"); 439560959Sdcs } 439660959Sdcs 439760959Sdcs dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED); 439894290Sdcs dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); 439960959Sdcs 440094290Sdcs if (pVM->pSys->nLocals == 0) 440160959Sdcs { /* compile code to create a local stack frame */ 440294290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); 440360959Sdcs /* save location in dictionary for #locals */ 440494290Sdcs pVM->pSys->pMarkLocals = pDict->here; 440594290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 440660959Sdcs } 440760959Sdcs 440894290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); 440994290Sdcs dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 441060959Sdcs 441194290Sdcs pVM->pSys->nLocals += 2; 441260959Sdcs } 441394290Sdcs else if (pVM->pSys->nLocals > 0) 441460959Sdcs { /* write nLocals to (link) param area in dictionary */ 441594290Sdcs *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; 441660959Sdcs } 441760959Sdcs 441860959Sdcs return; 441960959Sdcs} 442060959Sdcs 442160959Sdcs 442240843Smsmith#endif 442340843Smsmith/************************************************************************** 442440843Smsmith c o m p a r e 442540843Smsmith** STRING ( c-addr1 u1 c-addr2 u2 -- n ) 442640843Smsmith** Compare the string specified by c-addr1 u1 to the string specified by 442740843Smsmith** c-addr2 u2. The strings are compared, beginning at the given addresses, 442840843Smsmith** character by character, up to the length of the shorter string or until a 442940843Smsmith** difference is found. If the two strings are identical, n is zero. If the two 443040843Smsmith** strings are identical up to the length of the shorter string, n is minus-one 443140843Smsmith** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not 443240843Smsmith** identical up to the length of the shorter string, n is minus-one (-1) if the 443340843Smsmith** first non-matching character in the string specified by c-addr1 u1 has a 443440843Smsmith** lesser numeric value than the corresponding character in the string specified 443540843Smsmith** by c-addr2 u2 and one (1) otherwise. 443640843Smsmith**************************************************************************/ 443794290Sdcsstatic void compareInternal(FICL_VM *pVM, int caseInsensitive) 443840843Smsmith{ 443940843Smsmith char *cp1, *cp2; 444051786Sdcs FICL_UNS u1, u2, uMin; 444140843Smsmith int n = 0; 444240843Smsmith 444340843Smsmith vmCheckStack(pVM, 4, 1); 444451786Sdcs u2 = stackPopUNS(pVM->pStack); 444540843Smsmith cp2 = (char *)stackPopPtr(pVM->pStack); 444651786Sdcs u1 = stackPopUNS(pVM->pStack); 444740843Smsmith cp1 = (char *)stackPopPtr(pVM->pStack); 444840843Smsmith 444940843Smsmith uMin = (u1 < u2)? u1 : u2; 445040843Smsmith for ( ; (uMin > 0) && (n == 0); uMin--) 445140843Smsmith { 445294290Sdcs char c1 = *cp1++; 445394290Sdcs char c2 = *cp2++; 445494290Sdcs if (caseInsensitive) 445594290Sdcs { 445694290Sdcs c1 = (char)tolower(c1); 445794290Sdcs c2 = (char)tolower(c2); 445894290Sdcs } 445994290Sdcs n = (int)(c1 - c2); 446040843Smsmith } 446140843Smsmith 446240843Smsmith if (n == 0) 446340843Smsmith n = (int)(u1 - u2); 446440843Smsmith 446540843Smsmith if (n < 0) 446640843Smsmith n = -1; 446740843Smsmith else if (n > 0) 446840843Smsmith n = 1; 446940843Smsmith 447076116Sdcs PUSHINT(n); 447140843Smsmith return; 447240843Smsmith} 447340843Smsmith 447440843Smsmith 447594290Sdcsstatic void compareString(FICL_VM *pVM) 447694290Sdcs{ 447794290Sdcs compareInternal(pVM, FALSE); 447894290Sdcs} 447994290Sdcs 448094290Sdcs 448194290Sdcsstatic void compareStringInsensitive(FICL_VM *pVM) 448294290Sdcs{ 448394290Sdcs compareInternal(pVM, TRUE); 448494290Sdcs} 448594290Sdcs 448694290Sdcs 448740843Smsmith/************************************************************************** 448894290Sdcs p a d 448994290Sdcs** CORE EXT ( -- c-addr ) 449094290Sdcs** c-addr is the address of a transient region that can be used to hold 449194290Sdcs** data for intermediate processing. 449294290Sdcs**************************************************************************/ 449394290Sdcsstatic void pad(FICL_VM *pVM) 449494290Sdcs{ 449594290Sdcs stackPushPtr(pVM->pStack, pVM->pad); 449694290Sdcs} 449794290Sdcs 449894290Sdcs 449994290Sdcs/************************************************************************** 450061586Sdcs s o u r c e - i d 450161586Sdcs** CORE EXT, FILE ( -- 0 | -1 | fileid ) 450261586Sdcs** Identifies the input source as follows: 450361586Sdcs** 450461586Sdcs** SOURCE-ID Input source 450561586Sdcs** --------- ------------ 450661586Sdcs** fileid Text file fileid 450761586Sdcs** -1 String (via EVALUATE) 450861586Sdcs** 0 User input device 450961586Sdcs**************************************************************************/ 451061586Sdcsstatic void sourceid(FICL_VM *pVM) 451161586Sdcs{ 451276116Sdcs PUSHINT(pVM->sourceID.i); 451361586Sdcs return; 451461586Sdcs} 451561586Sdcs 451661586Sdcs 451761586Sdcs/************************************************************************** 451840843Smsmith r e f i l l 451940843Smsmith** CORE EXT ( -- flag ) 452040843Smsmith** Attempt to fill the input buffer from the input source, returning a true 452140843Smsmith** flag if successful. 452240843Smsmith** When the input source is the user input device, attempt to receive input 452340843Smsmith** into the terminal input buffer. If successful, make the result the input 452440843Smsmith** buffer, set >IN to zero, and return true. Receipt of a line containing no 452540843Smsmith** characters is considered successful. If there is no input available from 452640843Smsmith** the current input source, return false. 452740843Smsmith** When the input source is a string from EVALUATE, return false and 452840843Smsmith** perform no other action. 452940843Smsmith**************************************************************************/ 453040843Smsmithstatic void refill(FICL_VM *pVM) 453140843Smsmith{ 453251786Sdcs FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; 453376116Sdcs if (ret && (pVM->fRestart == 0)) 453461586Sdcs vmThrow(pVM, VM_RESTART); 453540843Smsmith 453676116Sdcs PUSHINT(ret); 453740843Smsmith return; 453840843Smsmith} 453940843Smsmith 454040843Smsmith 454151786Sdcs/************************************************************************** 454251786Sdcs freebsd exception handling words 454351786Sdcs** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE 454451786Sdcs** the word in ToS. If an exception happens, restore the state to what 454551786Sdcs** it was before, and pushes the exception value on the stack. If not, 454651786Sdcs** push zero. 454751786Sdcs** 454851786Sdcs** Notice that Catch implements an inner interpreter. This is ugly, 454951786Sdcs** but given how ficl works, it cannot be helped. The problem is that 455051786Sdcs** colon definitions will be executed *after* the function returns, 455151786Sdcs** while "code" definitions will be executed immediately. I considered 455251786Sdcs** other solutions to this problem, but all of them shared the same 455351786Sdcs** basic problem (with added disadvantages): if ficl ever changes it's 455451786Sdcs** inner thread modus operandi, one would have to fix this word. 455551786Sdcs** 455651786Sdcs** More comments can be found throughout catch's code. 455751786Sdcs** 455851786Sdcs** Daniel C. Sobral Jan 09/1999 455960959Sdcs** sadler may 2000 -- revised to follow ficl.c:ficlExecXT. 456051786Sdcs**************************************************************************/ 456151786Sdcs 456251786Sdcsstatic void ficlCatch(FICL_VM *pVM) 456351786Sdcs{ 456460959Sdcs int except; 456551786Sdcs jmp_buf vmState; 456651786Sdcs FICL_VM VM; 456751786Sdcs FICL_STACK pStack; 456851786Sdcs FICL_STACK rStack; 456951786Sdcs FICL_WORD *pFW; 457051786Sdcs 457160959Sdcs assert(pVM); 457294290Sdcs assert(pVM->pSys->pExitInner); 457360959Sdcs 457460959Sdcs 457551786Sdcs /* 457651786Sdcs ** Get xt. 457751786Sdcs ** We need this *before* we save the stack pointer, or 457851786Sdcs ** we'll have to pop one element out of the stack after 457951786Sdcs ** an exception. I prefer to get done with it up front. :-) 458051786Sdcs */ 458151786Sdcs#if FICL_ROBUST > 1 458251786Sdcs vmCheckStack(pVM, 1, 0); 458351786Sdcs#endif 458451786Sdcs pFW = stackPopPtr(pVM->pStack); 458551786Sdcs 458651786Sdcs /* 458751786Sdcs ** Save vm's state -- a catch will not back out environmental 458851786Sdcs ** changes. 458951786Sdcs ** 459051786Sdcs ** We are *not* saving dictionary state, since it is 459151786Sdcs ** global instead of per vm, and we are not saving 459251786Sdcs ** stack contents, since we are not required to (and, 459351786Sdcs ** thus, it would be useless). We save pVM, and pVM 459451786Sdcs ** "stacks" (a structure containing general information 459551786Sdcs ** about it, including the current stack pointer). 459651786Sdcs */ 459751786Sdcs memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); 459851786Sdcs memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK)); 459951786Sdcs memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); 460051786Sdcs 460151786Sdcs /* 460251786Sdcs ** Give pVM a jmp_buf 460351786Sdcs */ 460451786Sdcs pVM->pState = &vmState; 460551786Sdcs 460651786Sdcs /* 460751786Sdcs ** Safety net 460851786Sdcs */ 460951786Sdcs except = setjmp(vmState); 461051786Sdcs 461160959Sdcs switch (except) 461276116Sdcs { 461376116Sdcs /* 461476116Sdcs ** Setup condition - push poison pill so that the VM throws 461576116Sdcs ** VM_INNEREXIT if the XT terminates normally, then execute 461676116Sdcs ** the XT 461776116Sdcs */ 461876116Sdcs case 0: 461994290Sdcs vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */ 462060959Sdcs vmExecute(pVM, pFW); 462160959Sdcs vmInnerLoop(pVM); 462276116Sdcs break; 462351786Sdcs 462476116Sdcs /* 462576116Sdcs ** Normal exit from XT - lose the poison pill, 462676116Sdcs ** restore old setjmp vector and push a zero. 462776116Sdcs */ 462876116Sdcs case VM_INNEREXIT: 462960959Sdcs vmPopIP(pVM); /* Gack - hurl poison pill */ 463060959Sdcs pVM->pState = VM.pState; /* Restore just the setjmp vector */ 463176116Sdcs PUSHINT(0); /* Push 0 -- everything is ok */ 463276116Sdcs break; 463360959Sdcs 463476116Sdcs /* 463576116Sdcs ** Some other exception got thrown - restore pre-existing VM state 463676116Sdcs ** and push the exception code 463776116Sdcs */ 463876116Sdcs default: 463951786Sdcs /* Restore vm's state */ 464051786Sdcs memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); 464151786Sdcs memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); 464251786Sdcs memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); 464351786Sdcs 464476116Sdcs PUSHINT(except);/* Push error */ 464576116Sdcs break; 464676116Sdcs } 464751786Sdcs} 464851786Sdcs 464976116Sdcs/************************************************************************** 465076116Sdcs** t h r o w 465176116Sdcs** EXCEPTION 465276116Sdcs** Throw -- From ANS Forth standard. 465376116Sdcs** 465476116Sdcs** Throw takes the ToS and, if that's different from zero, 465576116Sdcs** returns to the last executed catch context. Further throws will 465676116Sdcs** unstack previously executed "catches", in LIFO mode. 465776116Sdcs** 465876116Sdcs** Daniel C. Sobral Jan 09/1999 465976116Sdcs**************************************************************************/ 466051786Sdcsstatic void ficlThrow(FICL_VM *pVM) 466151786Sdcs{ 466251786Sdcs int except; 466351786Sdcs 466451786Sdcs except = stackPopINT(pVM->pStack); 466551786Sdcs 466651786Sdcs if (except) 466751786Sdcs vmThrow(pVM, except); 466851786Sdcs} 466951786Sdcs 467051786Sdcs 467176116Sdcs/************************************************************************** 467276116Sdcs** a l l o c a t e 467376116Sdcs** MEMORY 467476116Sdcs**************************************************************************/ 467551786Sdcsstatic void ansAllocate(FICL_VM *pVM) 467651786Sdcs{ 467751786Sdcs size_t size; 467851786Sdcs void *p; 467951786Sdcs 468051786Sdcs size = stackPopINT(pVM->pStack); 468151786Sdcs p = ficlMalloc(size); 468276116Sdcs PUSHPTR(p); 468351786Sdcs if (p) 468476116Sdcs PUSHINT(0); 468551786Sdcs else 468676116Sdcs PUSHINT(1); 468751786Sdcs} 468851786Sdcs 468951786Sdcs 469076116Sdcs/************************************************************************** 469176116Sdcs** f r e e 469276116Sdcs** MEMORY 469376116Sdcs**************************************************************************/ 469451786Sdcsstatic void ansFree(FICL_VM *pVM) 469551786Sdcs{ 469651786Sdcs void *p; 469751786Sdcs 469851786Sdcs p = stackPopPtr(pVM->pStack); 469951786Sdcs ficlFree(p); 470076116Sdcs PUSHINT(0); 470151786Sdcs} 470251786Sdcs 470351786Sdcs 470476116Sdcs/************************************************************************** 470576116Sdcs** r e s i z e 470676116Sdcs** MEMORY 470776116Sdcs**************************************************************************/ 470851786Sdcsstatic void ansResize(FICL_VM *pVM) 470951786Sdcs{ 471051786Sdcs size_t size; 471151786Sdcs void *new, *old; 471251786Sdcs 471351786Sdcs size = stackPopINT(pVM->pStack); 471451786Sdcs old = stackPopPtr(pVM->pStack); 471551786Sdcs new = ficlRealloc(old, size); 471651786Sdcs if (new) 471751786Sdcs { 471876116Sdcs PUSHPTR(new); 471976116Sdcs PUSHINT(0); 472051786Sdcs } 472151786Sdcs else 472251786Sdcs { 472376116Sdcs PUSHPTR(old); 472476116Sdcs PUSHINT(1); 472551786Sdcs } 472651786Sdcs} 472751786Sdcs 472851786Sdcs 472976116Sdcs/************************************************************************** 473076116Sdcs** e x i t - i n n e r 473151786Sdcs** Signals execXT that an inner loop has completed 473276116Sdcs**************************************************************************/ 473351786Sdcsstatic void ficlExitInner(FICL_VM *pVM) 473451786Sdcs{ 473551786Sdcs vmThrow(pVM, VM_INNEREXIT); 473651786Sdcs} 473751786Sdcs 473851786Sdcs 473951786Sdcs/************************************************************************** 474051786Sdcs d n e g a t e 474151786Sdcs** DOUBLE ( d1 -- d2 ) 474251786Sdcs** d2 is the negation of d1. 474351786Sdcs**************************************************************************/ 474451786Sdcsstatic void dnegate(FICL_VM *pVM) 474551786Sdcs{ 474651786Sdcs DPINT i = i64Pop(pVM->pStack); 474751786Sdcs i = m64Negate(i); 474851786Sdcs i64Push(pVM->pStack, i); 474951786Sdcs 475051786Sdcs return; 475151786Sdcs} 475251786Sdcs 475360014Sdcs 475476116Sdcs#if 0 475576116Sdcs/************************************************************************** 475676116Sdcs 475776116Sdcs** 475876116Sdcs**************************************************************************/ 475976116Sdcsstatic void funcname(FICL_VM *pVM) 476060014Sdcs{ 476176116Sdcs IGNORE(pVM); 476276116Sdcs return; 476360014Sdcs} 476460014Sdcs 476576116Sdcs 476676116Sdcs#endif 476776116Sdcs/************************************************************************** 476876116Sdcs f i c l W o r d C l a s s i f y 476976116Sdcs** This public function helps to classify word types for SEE 4770108470Sschweikh** and the deugger in tools.c. Given a pointer to a word, it returns 477176116Sdcs** a member of WOR 477276116Sdcs**************************************************************************/ 477376116SdcsWORDKIND ficlWordClassify(FICL_WORD *pFW) 477460014Sdcs{ 477576116Sdcs typedef struct 477676116Sdcs { 477776116Sdcs WORDKIND kind; 477876116Sdcs FICL_CODE code; 477976116Sdcs } CODEtoKIND; 478060014Sdcs 478176116Sdcs static CODEtoKIND codeMap[] = 478276116Sdcs { 478394290Sdcs {BRANCH, branchParen}, 478494290Sdcs {COLON, colonParen}, 478576116Sdcs {CONSTANT, constantParen}, 478694290Sdcs {CREATE, createParen}, 478794290Sdcs {DO, doParen}, 478894290Sdcs {DOES, doDoes}, 4789167850Sjkim {IF, branch0}, 479094290Sdcs {LITERAL, literalParen}, 479194290Sdcs {LOOP, loopParen}, 4792167850Sjkim {OF, ofParen}, 479394290Sdcs {PLOOP, plusLoopParen}, 479494290Sdcs {QDO, qDoParen}, 479594290Sdcs {CSTRINGLIT, cstringLit}, 479694290Sdcs {STRINGLIT, stringLit}, 479794290Sdcs#if FICL_WANT_USER 479894290Sdcs {USER, userParen}, 479994290Sdcs#endif 480076116Sdcs {VARIABLE, variableParen}, 480176116Sdcs }; 480240843Smsmith 480376116Sdcs#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND)) 480443139Smsmith 480576116Sdcs FICL_CODE code = pFW->code; 480676116Sdcs int i; 480776116Sdcs 480876116Sdcs for (i=0; i < nMAP; i++) 480976116Sdcs { 481076116Sdcs if (codeMap[i].code == code) 481176116Sdcs return codeMap[i].kind; 481276116Sdcs } 481376116Sdcs 481476116Sdcs return PRIMITIVE; 481543139Smsmith} 481643139Smsmith 481776116Sdcs 4818167850Sjkim#ifdef TESTMAIN 481940843Smsmith/************************************************************************** 4820167850Sjkim** r a n d o m 4821167850Sjkim** FICL-specific 4822167850Sjkim**************************************************************************/ 4823167850Sjkimstatic void ficlRandom(FICL_VM *pVM) 4824167850Sjkim{ 4825167850Sjkim PUSHINT(rand()); 4826167850Sjkim} 4827167850Sjkim 4828167850Sjkim 4829167850Sjkim/************************************************************************** 4830167850Sjkim** s e e d - r a n d o m 4831167850Sjkim** FICL-specific 4832167850Sjkim**************************************************************************/ 4833167850Sjkimstatic void ficlSeedRandom(FICL_VM *pVM) 4834167850Sjkim{ 4835167850Sjkim srand(POPINT()); 4836167850Sjkim} 4837167850Sjkim#endif 4838167850Sjkim 4839167850Sjkim 4840167850Sjkim/************************************************************************** 484140843Smsmith f i c l C o m p i l e C o r e 484240843Smsmith** Builds the primitive wordset and the environment-query namespace. 484340843Smsmith**************************************************************************/ 484440843Smsmith 484576116Sdcsvoid ficlCompileCore(FICL_SYSTEM *pSys) 484640843Smsmith{ 484776116Sdcs FICL_DICT *dp = pSys->dp; 484840843Smsmith assert (dp); 484940843Smsmith 485094290Sdcs 485140843Smsmith /* 485240843Smsmith ** CORE word set 485340843Smsmith ** see softcore.c for definitions of: abs bl space spaces abort" 485440843Smsmith */ 485594290Sdcs pSys->pStore = 485640843Smsmith dictAppendWord(dp, "!", store, FW_DEFAULT); 485740843Smsmith dictAppendWord(dp, "#", numberSign, FW_DEFAULT); 485840843Smsmith dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); 485940843Smsmith dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); 486076116Sdcs dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT); 486140843Smsmith dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); 486240843Smsmith dictAppendWord(dp, "*", mul, FW_DEFAULT); 486340843Smsmith dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); 486440843Smsmith dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT); 486540843Smsmith dictAppendWord(dp, "+", add, FW_DEFAULT); 486640843Smsmith dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); 486740843Smsmith dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); 486840843Smsmith dictAppendWord(dp, ",", comma, FW_DEFAULT); 486940843Smsmith dictAppendWord(dp, "-", sub, FW_DEFAULT); 487040843Smsmith dictAppendWord(dp, ".", displayCell, FW_DEFAULT); 487140843Smsmith dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED); 487240843Smsmith dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT); 487340843Smsmith dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); 487440843Smsmith dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); 487540843Smsmith dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); 487640843Smsmith dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); 487740843Smsmith dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); 487840843Smsmith dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); 487940843Smsmith dictAppendWord(dp, "2*", twoMul, FW_DEFAULT); 488040843Smsmith dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT); 488140843Smsmith dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT); 488240843Smsmith dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT); 488340843Smsmith dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT); 488440843Smsmith dictAppendWord(dp, "2over", twoOver, FW_DEFAULT); 488540843Smsmith dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT); 488640843Smsmith dictAppendWord(dp, ":", colon, FW_DEFAULT); 488740843Smsmith dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED); 488840843Smsmith dictAppendWord(dp, "<", isLess, FW_DEFAULT); 488940843Smsmith dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT); 489040843Smsmith dictAppendWord(dp, "=", isEqual, FW_DEFAULT); 489140843Smsmith dictAppendWord(dp, ">", isGreater, FW_DEFAULT); 489240843Smsmith dictAppendWord(dp, ">body", toBody, FW_DEFAULT); 489340843Smsmith dictAppendWord(dp, ">in", toIn, FW_DEFAULT); 489440843Smsmith dictAppendWord(dp, ">number", toNumber, FW_DEFAULT); 489576116Sdcs dictAppendWord(dp, ">r", toRStack, FW_COMPILE); 489640843Smsmith dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); 489740843Smsmith dictAppendWord(dp, "@", fetch, FW_DEFAULT); 489840843Smsmith dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); 489940843Smsmith dictAppendWord(dp, "accept", accept, FW_DEFAULT); 490040843Smsmith dictAppendWord(dp, "align", align, FW_DEFAULT); 490140843Smsmith dictAppendWord(dp, "aligned", aligned, FW_DEFAULT); 490240843Smsmith dictAppendWord(dp, "allot", allot, FW_DEFAULT); 490340843Smsmith dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT); 490440843Smsmith dictAppendWord(dp, "base", base, FW_DEFAULT); 490540843Smsmith dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED); 490640843Smsmith dictAppendWord(dp, "c!", cStore, FW_DEFAULT); 490740843Smsmith dictAppendWord(dp, "c,", cComma, FW_DEFAULT); 490840843Smsmith dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); 4909167850Sjkim dictAppendWord(dp, "case", caseCoIm, FW_COMPIMMED); 491040843Smsmith dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); 491140843Smsmith dictAppendWord(dp, "cells", cells, FW_DEFAULT); 491240843Smsmith dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); 491340843Smsmith dictAppendWord(dp, "char+", charPlus, FW_DEFAULT); 491440843Smsmith dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT); 491540843Smsmith dictAppendWord(dp, "constant", constant, FW_DEFAULT); 491640843Smsmith dictAppendWord(dp, "count", count, FW_DEFAULT); 491740843Smsmith dictAppendWord(dp, "cr", cr, FW_DEFAULT); 491840843Smsmith dictAppendWord(dp, "create", create, FW_DEFAULT); 491940843Smsmith dictAppendWord(dp, "decimal", decimal, FW_DEFAULT); 492040843Smsmith dictAppendWord(dp, "depth", depth, FW_DEFAULT); 492140843Smsmith dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); 492240843Smsmith dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); 4923167850Sjkim pSys->pDrop = 492440843Smsmith dictAppendWord(dp, "drop", drop, FW_DEFAULT); 492540843Smsmith dictAppendWord(dp, "dup", dup, FW_DEFAULT); 492640843Smsmith dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); 492740843Smsmith dictAppendWord(dp, "emit", emit, FW_DEFAULT); 4928167850Sjkim dictAppendWord(dp, "endcase", endcaseCoIm, FW_COMPIMMED); 4929167850Sjkim dictAppendWord(dp, "endof", endofCoIm, FW_COMPIMMED); 493040843Smsmith dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); 493140843Smsmith dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); 493240843Smsmith dictAppendWord(dp, "execute", execute, FW_DEFAULT); 493340843Smsmith dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); 4934167850Sjkim dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED); 493540843Smsmith dictAppendWord(dp, "fill", fill, FW_DEFAULT); 493694290Sdcs dictAppendWord(dp, "find", cFind, FW_DEFAULT); 493740843Smsmith dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); 493840843Smsmith dictAppendWord(dp, "here", here, FW_DEFAULT); 493940843Smsmith dictAppendWord(dp, "hold", hold, FW_DEFAULT); 494040843Smsmith dictAppendWord(dp, "i", loopICo, FW_COMPILE); 494140843Smsmith dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); 494240843Smsmith dictAppendWord(dp, "immediate", immediate, FW_DEFAULT); 494340843Smsmith dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT); 494440843Smsmith dictAppendWord(dp, "j", loopJCo, FW_COMPILE); 494540843Smsmith dictAppendWord(dp, "k", loopKCo, FW_COMPILE); 494640843Smsmith dictAppendWord(dp, "leave", leaveCo, FW_COMPILE); 494740843Smsmith dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE); 494840843Smsmith dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED); 494940843Smsmith dictAppendWord(dp, "lshift", lshift, FW_DEFAULT); 495040843Smsmith dictAppendWord(dp, "m*", mStar, FW_DEFAULT); 495140843Smsmith dictAppendWord(dp, "max", ficlMax, FW_DEFAULT); 495240843Smsmith dictAppendWord(dp, "min", ficlMin, FW_DEFAULT); 495340843Smsmith dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); 495440843Smsmith dictAppendWord(dp, "move", move, FW_DEFAULT); 495540843Smsmith dictAppendWord(dp, "negate", negate, FW_DEFAULT); 4956167850Sjkim dictAppendWord(dp, "of", ofCoIm, FW_COMPIMMED); 495740843Smsmith dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); 495840843Smsmith dictAppendWord(dp, "over", over, FW_DEFAULT); 495940843Smsmith dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); 496040843Smsmith dictAppendWord(dp, "quit", quit, FW_DEFAULT); 496176116Sdcs dictAppendWord(dp, "r>", fromRStack, FW_COMPILE); 496276116Sdcs dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE); 496340843Smsmith dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); 496440843Smsmith dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); 496540843Smsmith dictAppendWord(dp, "rot", rot, FW_DEFAULT); 496640843Smsmith dictAppendWord(dp, "rshift", rshift, FW_DEFAULT); 496740843Smsmith dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE); 496840843Smsmith dictAppendWord(dp, "s>d", sToD, FW_DEFAULT); 496940843Smsmith dictAppendWord(dp, "sign", sign, FW_DEFAULT); 497040843Smsmith dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT); 497140843Smsmith dictAppendWord(dp, "source", source, FW_DEFAULT); 497240843Smsmith dictAppendWord(dp, "state", state, FW_DEFAULT); 497340843Smsmith dictAppendWord(dp, "swap", swap, FW_DEFAULT); 497440843Smsmith dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); 497540843Smsmith dictAppendWord(dp, "type", type, FW_DEFAULT); 497640843Smsmith dictAppendWord(dp, "u.", uDot, FW_DEFAULT); 497740843Smsmith dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); 497840843Smsmith dictAppendWord(dp, "um*", umStar, FW_DEFAULT); 497940843Smsmith dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT); 498040843Smsmith dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE); 498140843Smsmith dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED); 498240843Smsmith dictAppendWord(dp, "variable", variable, FW_DEFAULT); 498340843Smsmith dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED); 498440843Smsmith dictAppendWord(dp, "word", ficlWord, FW_DEFAULT); 498540843Smsmith dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT); 498640843Smsmith dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED); 498740843Smsmith dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED); 498840843Smsmith dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED); 498940843Smsmith dictAppendWord(dp, "]", rbracket, FW_DEFAULT); 499040843Smsmith /* 499140843Smsmith ** CORE EXT word set... 499294290Sdcs ** see softcore.fr for other definitions 499340843Smsmith */ 499494290Sdcs /* "#tib" */ 499594290Sdcs dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE); 499694290Sdcs /* ".r" */ 499794290Sdcs dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); 499876116Sdcs dictAppendWord(dp, "2>r", twoToR, FW_COMPILE); 499976116Sdcs dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE); 500076116Sdcs dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE); 500194290Sdcs dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); 500240843Smsmith dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); 500360959Sdcs dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); 500494290Sdcs dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE); 500594290Sdcs dictAppendWord(dp, "hex", hex, FW_DEFAULT); 500694290Sdcs dictAppendWord(dp, "pad", pad, FW_DEFAULT); 500740843Smsmith dictAppendWord(dp, "parse", parse, FW_DEFAULT); 500840843Smsmith dictAppendWord(dp, "pick", pick, FW_DEFAULT); 500994290Sdcs /* query restore-input save-input tib u.r u> unused [compile] */ 501040843Smsmith dictAppendWord(dp, "roll", roll, FW_DEFAULT); 501140843Smsmith dictAppendWord(dp, "refill", refill, FW_DEFAULT); 501276116Sdcs dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT); 501340843Smsmith dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); 501440843Smsmith dictAppendWord(dp, "value", constant, FW_DEFAULT); 501540843Smsmith dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); 501640843Smsmith 501743078Smsmith 501840843Smsmith /* 501940843Smsmith ** Set CORE environment query values 502040843Smsmith */ 502194290Sdcs ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX); 502294290Sdcs ficlSetEnv(pSys, "/hold", nPAD); 502394290Sdcs ficlSetEnv(pSys, "/pad", nPAD); 502494290Sdcs ficlSetEnv(pSys, "address-unit-bits", 8); 502594290Sdcs ficlSetEnv(pSys, "core", FICL_TRUE); 502694290Sdcs ficlSetEnv(pSys, "core-ext", FICL_FALSE); 502794290Sdcs ficlSetEnv(pSys, "floored", FICL_FALSE); 502894290Sdcs ficlSetEnv(pSys, "max-char", UCHAR_MAX); 502994290Sdcs ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff); 503094290Sdcs ficlSetEnv(pSys, "max-n", 0x7fffffff); 503194290Sdcs ficlSetEnv(pSys, "max-u", 0xffffffff); 503294290Sdcs ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff); 503394290Sdcs ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK); 503494290Sdcs ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK); 503540843Smsmith 503640843Smsmith /* 503760959Sdcs ** DOUBLE word set (partial) 503860959Sdcs */ 503960959Sdcs dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); 504060959Sdcs dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE); 504176116Sdcs dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE); 504260959Sdcs dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); 504360959Sdcs 504460959Sdcs 504560959Sdcs /* 504651786Sdcs ** EXCEPTION word set 504751786Sdcs */ 504851786Sdcs dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); 504951786Sdcs dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); 505051786Sdcs 505194290Sdcs ficlSetEnv(pSys, "exception", FICL_TRUE); 505294290Sdcs ficlSetEnv(pSys, "exception-ext", FICL_TRUE); 505351786Sdcs 505451786Sdcs /* 505540843Smsmith ** LOCAL and LOCAL EXT 505640843Smsmith ** see softcore.c for implementation of locals| 505740843Smsmith */ 505840843Smsmith#if FICL_WANT_LOCALS 505994290Sdcs pSys->pLinkParen = 506040843Smsmith dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); 506194290Sdcs pSys->pUnLinkParen = 506240843Smsmith dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); 506340843Smsmith dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); 506494290Sdcs pSys->pGetLocalParen = 506540843Smsmith dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); 506694290Sdcs pSys->pToLocalParen = 506740843Smsmith dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); 506894290Sdcs pSys->pGetLocal0 = 506940843Smsmith dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); 507094290Sdcs pSys->pToLocal0 = 507140843Smsmith dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); 507294290Sdcs pSys->pGetLocal1 = 507340843Smsmith dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); 507494290Sdcs pSys->pToLocal1 = 507540843Smsmith dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); 507640843Smsmith dictAppendWord(dp, "(local)", localParen, FW_COMPILE); 507740843Smsmith 507894290Sdcs pSys->pGet2LocalParen = 507960959Sdcs dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE); 508094290Sdcs pSys->pTo2LocalParen = 508160959Sdcs dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE); 508260959Sdcs dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE); 508360959Sdcs 508494290Sdcs ficlSetEnv(pSys, "locals", FICL_TRUE); 508594290Sdcs ficlSetEnv(pSys, "locals-ext", FICL_TRUE); 508694290Sdcs ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS); 508740843Smsmith#endif 508840843Smsmith 508940843Smsmith /* 509051786Sdcs ** Optional MEMORY-ALLOC word set 509151786Sdcs */ 509251786Sdcs 509351786Sdcs dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT); 509451786Sdcs dictAppendWord(dp, "free", ansFree, FW_DEFAULT); 509551786Sdcs dictAppendWord(dp, "resize", ansResize, FW_DEFAULT); 509651786Sdcs 509794290Sdcs ficlSetEnv(pSys, "memory-alloc", FICL_TRUE); 509851786Sdcs 509951786Sdcs /* 510040843Smsmith ** optional SEARCH-ORDER word set 510140843Smsmith */ 510276116Sdcs ficlCompileSearch(pSys); 510340843Smsmith 510440843Smsmith /* 510540843Smsmith ** TOOLS and TOOLS EXT 510640843Smsmith */ 510776116Sdcs ficlCompileTools(pSys); 510840843Smsmith 510940843Smsmith /* 511094290Sdcs ** FILE and FILE EXT 511194290Sdcs */ 511294290Sdcs#if FICL_WANT_FILE 511394290Sdcs ficlCompileFile(pSys); 511494290Sdcs#endif 511594290Sdcs 511694290Sdcs /* 511740843Smsmith ** Ficl extras 511840843Smsmith */ 511994290Sdcs#if FICL_WANT_FLOAT 512094290Sdcs dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT); 512194290Sdcs#endif 512240843Smsmith dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); 512340843Smsmith dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); 512440843Smsmith dictAppendWord(dp, ">name", toName, FW_DEFAULT); 512576116Sdcs dictAppendWord(dp, "add-parse-step", 512676116Sdcs addParseStep, FW_DEFAULT); 512740843Smsmith dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); 512840843Smsmith dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ 512994290Sdcs dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */ 513040843Smsmith dictAppendWord(dp, "compile-only", 513140843Smsmith compileOnly, FW_DEFAULT); 513240843Smsmith dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); 513376116Sdcs dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT); 513476116Sdcs dictAppendWord(dp, "hash", hash, FW_DEFAULT); 513594290Sdcs dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT); 513694290Sdcs dictAppendWord(dp, "?object", isObject, FW_DEFAULT); 513740843Smsmith dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); 513894290Sdcs dictAppendWord(dp, "sfind", sFind, FW_DEFAULT); 513940843Smsmith dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ 514094290Sdcs dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT); 514194290Sdcs dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT); 514276116Sdcs dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT); 514376116Sdcs dictAppendWord(dp, "q!", quadStore, FW_DEFAULT); 514440843Smsmith dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); 514540843Smsmith dictAppendWord(dp, "w!", wStore, FW_DEFAULT); 514640843Smsmith dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); 514740843Smsmith#if FICL_WANT_USER 514840843Smsmith dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); 514940843Smsmith dictAppendWord(dp, "user", userVariable, FW_DEFAULT); 515040843Smsmith#endif 5151167850Sjkim#ifdef TESTMAIN 5152167850Sjkim dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT); 5153167850Sjkim dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT); 5154167850Sjkim#endif 515594290Sdcs 515640843Smsmith /* 515740843Smsmith ** internal support words 515840843Smsmith */ 515976116Sdcs dictAppendWord(dp, "(create)", createParen, FW_COMPILE); 516094290Sdcs pSys->pExitParen = 516140843Smsmith dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); 516294290Sdcs pSys->pSemiParen = 516340843Smsmith dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); 516494290Sdcs pSys->pLitParen = 516540843Smsmith dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); 516694290Sdcs pSys->pTwoLitParen = 516760959Sdcs dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE); 516894290Sdcs pSys->pStringLit = 516940843Smsmith dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); 517094290Sdcs pSys->pCStringLit = 517194290Sdcs dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE); 5172167850Sjkim pSys->pBranch0 = 5173167850Sjkim dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE); 517494290Sdcs pSys->pBranchParen = 517540843Smsmith dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); 517694290Sdcs pSys->pDoParen = 517740843Smsmith dictAppendWord(dp, "(do)", doParen, FW_COMPILE); 517894290Sdcs pSys->pDoesParen = 517940843Smsmith dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); 518094290Sdcs pSys->pQDoParen = 518140843Smsmith dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); 518294290Sdcs pSys->pLoopParen = 518340843Smsmith dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); 518494290Sdcs pSys->pPLoopParen = 518540843Smsmith dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); 518694290Sdcs pSys->pInterpret = 518740843Smsmith dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); 518894290Sdcs dictAppendWord(dp, "lookup", lookup, FW_DEFAULT); 5189167850Sjkim pSys->pOfParen = 5190167850Sjkim dictAppendWord(dp, "(of)", ofParen, FW_DEFAULT); 519140843Smsmith dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); 519240843Smsmith dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); 519376116Sdcs dictAppendWord(dp, "(parse-step)", 519476116Sdcs parseStepParen, FW_DEFAULT); 519594290Sdcs pSys->pExitInner = 519651786Sdcs dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); 519740843Smsmith 519894290Sdcs /* 519994290Sdcs ** Set up system's outer interpreter loop - maybe this should be in initSystem? 520094290Sdcs */ 520194290Sdcs pSys->pInterp[0] = pSys->pInterpret; 520294290Sdcs pSys->pInterp[1] = pSys->pBranchParen; 520394290Sdcs pSys->pInterp[2] = (FICL_WORD *)(void *)(-2); 520494290Sdcs 520551786Sdcs assert(dictCellsAvail(dp) > 0); 520676116Sdcs 520740843Smsmith return; 520840843Smsmith} 520940843Smsmith 5210