Deleted Added
sdiff udiff text old ( 43135 ) new ( 43139 )
full compact
words.c (43135) words.c (43139)
1/*******************************************************************
2** w o r d s . c
3** Forth Inspired Command Language
4** ANS Forth CORE word-set written in C
5** Author: John Sadler (john_sadler@alum.mit.edu)
6** Created: 19 July 1997
7**
8*******************************************************************/

--- 1054 unchanged lines hidden (view full) ---

1063
1064/**************************************************************************
1065 i f P a r e n
1066** Runtime code to do "if" or "until": pop a flag from the stack,
1067** fall through if true, branch if false. Probably ought to be
1068** called (not?branch) since it does "branch if false".
1069**************************************************************************/
1070
1/*******************************************************************
2** w o r d s . c
3** Forth Inspired Command Language
4** ANS Forth CORE word-set written in C
5** Author: John Sadler (john_sadler@alum.mit.edu)
6** Created: 19 July 1997
7**
8*******************************************************************/

--- 1054 unchanged lines hidden (view full) ---

1063
1064/**************************************************************************
1065 i f P a r e n
1066** Runtime code to do "if" or "until": pop a flag from the stack,
1067** fall through if true, branch if false. Probably ought to be
1068** called (not?branch) since it does "branch if false".
1069**************************************************************************/
1070
1071#ifdef FICL_TRACE
1072void ifParen(FICL_VM *pVM)
1073#else
1071static void ifParen(FICL_VM *pVM)
1074static void ifParen(FICL_VM *pVM)
1075#endif
1072{
1073 UNS32 flag;
1074
1075#if FICL_ROBUST > 1
1076 vmCheckStack(pVM, 1, 0);
1077#endif
1078 flag = stackPopUNS32(pVM->pStack);
1079

--- 45 unchanged lines hidden (view full) ---

1125
1126/**************************************************************************
1127 b r a n c h P a r e n
1128**
1129** Runtime for "(branch)" -- expects a literal offset in the next
1130** compilation address, and branches to that location.
1131**************************************************************************/
1132
1076{
1077 UNS32 flag;
1078
1079#if FICL_ROBUST > 1
1080 vmCheckStack(pVM, 1, 0);
1081#endif
1082 flag = stackPopUNS32(pVM->pStack);
1083

--- 45 unchanged lines hidden (view full) ---

1129
1130/**************************************************************************
1131 b r a n c h P a r e n
1132**
1133** Runtime for "(branch)" -- expects a literal offset in the next
1134** compilation address, and branches to that location.
1135**************************************************************************/
1136
1137#ifdef FICL_TRACE
1138void branchParen(FICL_VM *pVM)
1139#else
1133static void branchParen(FICL_VM *pVM)
1140static void branchParen(FICL_VM *pVM)
1141#endif
1134{
1135 vmBranchRelative(pVM, *(int *)(pVM->ip));
1136 return;
1137}
1138
1139
1140/**************************************************************************
1141 e n d i f C o I m

--- 130 unchanged lines hidden (view full) ---

1272/**************************************************************************
1273 l i t e r a l P a r e n
1274**
1275** This is the runtime for (literal). It assumes that it is part of a colon
1276** definition, and that the next CELL contains a value to be pushed on the
1277** parameter stack at runtime. This code is compiled by "literal".
1278**
1279**************************************************************************/
1142{
1143 vmBranchRelative(pVM, *(int *)(pVM->ip));
1144 return;
1145}
1146
1147
1148/**************************************************************************
1149 e n d i f C o I m

--- 130 unchanged lines hidden (view full) ---

1280/**************************************************************************
1281 l i t e r a l P a r e n
1282**
1283** This is the runtime for (literal). It assumes that it is part of a colon
1284** definition, and that the next CELL contains a value to be pushed on the
1285** parameter stack at runtime. This code is compiled by "literal".
1286**
1287**************************************************************************/
1280
1288#ifdef FICL_TRACE
1289void literalParen(FICL_VM *pVM)
1290#else
1281static void literalParen(FICL_VM *pVM)
1291static void literalParen(FICL_VM *pVM)
1292#endif
1282{
1283#if FICL_ROBUST > 1
1284 vmCheckStack(pVM, 0, 1);
1285#endif
1286 stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip));
1287 vmBranchRelative(pVM, 1);
1288 return;
1289}

--- 296 unchanged lines hidden (view full) ---

1586 /*
1587 ** Mark location of head of loop...
1588 */
1589 markBranch(dp, pVM, doTag);
1590
1591 return;
1592}
1593
1293{
1294#if FICL_ROBUST > 1
1295 vmCheckStack(pVM, 0, 1);
1296#endif
1297 stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip));
1298 vmBranchRelative(pVM, 1);
1299 return;
1300}

--- 296 unchanged lines hidden (view full) ---

1597 /*
1598 ** Mark location of head of loop...
1599 */
1600 markBranch(dp, pVM, doTag);
1601
1602 return;
1603}
1604
1594
1605#ifdef FICL_TRACE
1606void doParen(FICL_VM *pVM)
1607#else
1595static void doParen(FICL_VM *pVM)
1608static void doParen(FICL_VM *pVM)
1609#endif
1596{
1597 CELL index, limit;
1598#if FICL_ROBUST > 1
1599 vmCheckStack(pVM, 2, 0);
1600#endif
1601 index = stackPop(pVM->pStack);
1602 limit = stackPop(pVM->pStack);
1603

--- 22 unchanged lines hidden (view full) ---

1626 /*
1627 ** Mark location of head of loop...
1628 */
1629 markBranch(dp, pVM, doTag);
1630
1631 return;
1632}
1633
1610{
1611 CELL index, limit;
1612#if FICL_ROBUST > 1
1613 vmCheckStack(pVM, 2, 0);
1614#endif
1615 index = stackPop(pVM->pStack);
1616 limit = stackPop(pVM->pStack);
1617

--- 22 unchanged lines hidden (view full) ---

1640 /*
1641 ** Mark location of head of loop...
1642 */
1643 markBranch(dp, pVM, doTag);
1644
1645 return;
1646}
1647
1634
1648#ifdef FICL_TRACE
1649void qDoParen(FICL_VM *pVM)
1650#else
1635static void qDoParen(FICL_VM *pVM)
1651static void qDoParen(FICL_VM *pVM)
1652#endif
1636{
1637 CELL index, limit;
1638#if FICL_ROBUST > 1
1639 vmCheckStack(pVM, 2, 0);
1640#endif
1641 index = stackPop(pVM->pStack);
1642 limit = stackPop(pVM->pStack);
1643

--- 56 unchanged lines hidden (view full) ---

1700 assert(pPLoopParen);
1701
1702 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
1703 resolveBackBranch(dp, pVM, doTag);
1704 resolveAbsBranch(dp, pVM, leaveTag);
1705 return;
1706}
1707
1653{
1654 CELL index, limit;
1655#if FICL_ROBUST > 1
1656 vmCheckStack(pVM, 2, 0);
1657#endif
1658 index = stackPop(pVM->pStack);
1659 limit = stackPop(pVM->pStack);
1660

--- 56 unchanged lines hidden (view full) ---

1717 assert(pPLoopParen);
1718
1719 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
1720 resolveBackBranch(dp, pVM, doTag);
1721 resolveAbsBranch(dp, pVM, leaveTag);
1722 return;
1723}
1724
1708
1725#ifdef FICL_TRACE
1726void loopParen(FICL_VM *pVM)
1727#else
1709static void loopParen(FICL_VM *pVM)
1728static void loopParen(FICL_VM *pVM)
1729#endif
1710{
1711 INT32 index = stackGetTop(pVM->rStack).i;
1712 INT32 limit = stackFetch(pVM->rStack, 1).i;
1713
1714 index++;
1715
1716 if (index >= limit)
1717 {

--- 4 unchanged lines hidden (view full) ---

1722 { /* update index, branch to loop head */
1723 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1724 vmBranchRelative(pVM, *(int *)(pVM->ip));
1725 }
1726
1727 return;
1728}
1729
1730{
1731 INT32 index = stackGetTop(pVM->rStack).i;
1732 INT32 limit = stackFetch(pVM->rStack, 1).i;
1733
1734 index++;
1735
1736 if (index >= limit)
1737 {

--- 4 unchanged lines hidden (view full) ---

1742 { /* update index, branch to loop head */
1743 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1744 vmBranchRelative(pVM, *(int *)(pVM->ip));
1745 }
1746
1747 return;
1748}
1749
1730
1750#ifdef FICL_TRACE
1751void plusLoopParen(FICL_VM *pVM)
1752#else
1731static void plusLoopParen(FICL_VM *pVM)
1753static void plusLoopParen(FICL_VM *pVM)
1754#endif
1732{
1733 INT32 index = stackGetTop(pVM->rStack).i;
1734 INT32 limit = stackFetch(pVM->rStack, 1).i;
1735 INT32 increment = stackPop(pVM->pStack).i;
1736 int flag;
1737
1738 index += increment;
1739

--- 289 unchanged lines hidden (view full) ---

2029** IMMEDIATE word that compiles a string literal for later display
2030** Compile stringLit, then copy the bytes of the string from the TIB
2031** to the dictionary. Backpatch the count byte and align the dictionary.
2032**
2033** stringlit: Fetch the count from the dictionary, then push the address
2034** and count on the stack. Finally, update ip to point to the first
2035** aligned address after the string text.
2036**************************************************************************/
1755{
1756 INT32 index = stackGetTop(pVM->rStack).i;
1757 INT32 limit = stackFetch(pVM->rStack, 1).i;
1758 INT32 increment = stackPop(pVM->pStack).i;
1759 int flag;
1760
1761 index += increment;
1762

--- 289 unchanged lines hidden (view full) ---

2052** IMMEDIATE word that compiles a string literal for later display
2053** Compile stringLit, then copy the bytes of the string from the TIB
2054** to the dictionary. Backpatch the count byte and align the dictionary.
2055**
2056** stringlit: Fetch the count from the dictionary, then push the address
2057** and count on the stack. Finally, update ip to point to the first
2058** aligned address after the string text.
2059**************************************************************************/
2037
2060#ifdef FICL_TRACE
2061void stringLit(FICL_VM *pVM)
2062#else
2038static void stringLit(FICL_VM *pVM)
2063static void stringLit(FICL_VM *pVM)
2064#endif
2039{
2040 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2041 FICL_COUNT count = sp->count;
2042 char *cp = sp->text;
2043 stackPushPtr(pVM->pStack, cp);
2044 stackPushUNS32(pVM->pStack, count);
2045 cp += count + 1;
2046 cp = alignPtr(cp);

--- 1731 unchanged lines hidden (view full) ---

3778/*
3779** isAFiclWord
3780** Vet a candidate pointer carefully to make sure
3781** it's not some chunk o' inline data...
3782** It has to have a name, and it has to look
3783** like it's in the dictionary address range.
3784** NOTE: this excludes :noname words!
3785*/
2065{
2066 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2067 FICL_COUNT count = sp->count;
2068 char *cp = sp->text;
2069 stackPushPtr(pVM->pStack, cp);
2070 stackPushUNS32(pVM->pStack, count);
2071 cp += count + 1;
2072 cp = alignPtr(cp);

--- 1731 unchanged lines hidden (view full) ---

3804/*
3805** isAFiclWord
3806** Vet a candidate pointer carefully to make sure
3807** it's not some chunk o' inline data...
3808** It has to have a name, and it has to look
3809** like it's in the dictionary address range.
3810** NOTE: this excludes :noname words!
3811*/
3812#ifdef FICL_TRACE
3813int isAFiclWord(FICL_WORD *pFW)
3814#else
3786static int isAFiclWord(FICL_WORD *pFW)
3815static int isAFiclWord(FICL_WORD *pFW)
3816#endif
3787{
3788 void *pv = (void *)pFW;
3789 FICL_DICT *pd = ficlGetDict();
3790
3791 if (!dictIncludes(pd, pFW))
3792 return 0;
3793
3794 if (!dictIncludes(pd, pFW->name))

--- 601 unchanged lines hidden (view full) ---

4396 vmCheckStack(pVM, 1, 1);
4397#endif
4398 fd = stackPopINT32(pVM->pStack);
4399 i = read(fd, &ch, 1);
4400 stackPushINT32(pVM->pStack, i > 0 ? ch : -1);
4401 return;
4402}
4403
3817{
3818 void *pv = (void *)pFW;
3819 FICL_DICT *pd = ficlGetDict();
3820
3821 if (!dictIncludes(pd, pFW))
3822 return 0;
3823
3824 if (!dictIncludes(pd, pFW->name))

--- 601 unchanged lines hidden (view full) ---

4426 vmCheckStack(pVM, 1, 1);
4427#endif
4428 fd = stackPopINT32(pVM->pStack);
4429 i = read(fd, &ch, 1);
4430 stackPushINT32(pVM->pStack, i > 0 ? ch : -1);
4431 return;
4432}
4433
4434/************************* freebsd added trace ***************************/
4404
4435
4436#ifdef FICL_TRACE
4437static void ficlTrace(FICL_VM *pVM)
4438{
4439#if FICL_ROBUST > 1
4440 vmCheckStack(pVM, 1, 1);
4441#endif
4442
4443 ficl_trace = stackPopINT32(pVM->pStack);
4444}
4445#endif
4446
4405/**************************************************************************
4406 f i c l C o m p i l e C o r e
4407** Builds the primitive wordset and the environment-query namespace.
4408**************************************************************************/
4409
4410void ficlCompileCore(FICL_DICT *dp)
4411{
4412 assert (dp);

--- 156 unchanged lines hidden (view full) ---

4569 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT);
4570 dictAppendWord(dp, "fread", pfread, FW_DEFAULT);
4571 dictAppendWord(dp, "fload", pfload, FW_DEFAULT);
4572 dictAppendWord(dp, "fkey", fkey, FW_DEFAULT);
4573 dictAppendWord(dp, "key", key, FW_DEFAULT);
4574 dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT);
4575 dictAppendWord(dp, "ms", ms, FW_DEFAULT);
4576 dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT);
4447/**************************************************************************
4448 f i c l C o m p i l e C o r e
4449** Builds the primitive wordset and the environment-query namespace.
4450**************************************************************************/
4451
4452void ficlCompileCore(FICL_DICT *dp)
4453{
4454 assert (dp);

--- 156 unchanged lines hidden (view full) ---

4611 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT);
4612 dictAppendWord(dp, "fread", pfread, FW_DEFAULT);
4613 dictAppendWord(dp, "fload", pfload, FW_DEFAULT);
4614 dictAppendWord(dp, "fkey", fkey, FW_DEFAULT);
4615 dictAppendWord(dp, "key", key, FW_DEFAULT);
4616 dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT);
4617 dictAppendWord(dp, "ms", ms, FW_DEFAULT);
4618 dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT);
4619#ifdef FICL_TRACE
4620 dictAppendWord(dp, "trace!", ficlTrace, FW_DEFAULT);
4621#endif
4577 /*
4578 ** EXCEPTION word set
4579 */
4580 dictAppendWord(dp, "catch", catch, FW_DEFAULT);
4581 dictAppendWord(dp, "throw", throw, FW_DEFAULT);
4582
4583 ficlSetEnv("exception", FICL_TRUE);
4584 ficlSetEnv("exception-ext", FICL_TRUE);

--- 172 unchanged lines hidden --- 		4622 /*
4623 ** EXCEPTION word set
4624 */
4625 dictAppendWord(dp, "catch", catch, FW_DEFAULT);
4626 dictAppendWord(dp, "throw", throw, FW_DEFAULT);
4627
4628 ficlSetEnv("exception", FICL_TRUE);
4629 ficlSetEnv("exception-ext", FICL_TRUE);

--- 172 unchanged lines hidden ---