1961 }
1962
1963 return;
1964}
1965
1966
1967static void loopICo(FICL_VM *pVM)
1968{
1969 CELL index = stackGetTop(pVM->rStack);
1970 stackPush(pVM->pStack, index);
1971
1972 return;
1973}
1974
1975
1976static void loopJCo(FICL_VM *pVM)
1977{
1978 CELL index = stackFetch(pVM->rStack, 3);
1979 stackPush(pVM->pStack, index);
1980
1981 return;
1982}
1983
1984
1985static void loopKCo(FICL_VM *pVM)
1986{
1987 CELL index = stackFetch(pVM->rStack, 6);
1988 stackPush(pVM->pStack, index);
1989
1990 return;
1991}
1992
1993
1994/**************************************************************************
1995 r e t u r n s t a c k
1996**
1997**************************************************************************/
1998static void toRStack(FICL_VM *pVM)
1999{
2000#if FICL_ROBUST > 1
2001 vmCheckStack(pVM, 1, 0);
2002#endif
2003
2004 stackPush(pVM->rStack, POP());
2005}
2006
2007static void fromRStack(FICL_VM *pVM)
2008{
2009#if FICL_ROBUST > 1
2010 vmCheckStack(pVM, 0, 1);
2011#endif
2012
2013 PUSH(stackPop(pVM->rStack));
2014}
2015
2016static void fetchRStack(FICL_VM *pVM)
2017{
2018#if FICL_ROBUST > 1
2019 vmCheckStack(pVM, 0, 1);
2020#endif
2021
2022 PUSH(stackGetTop(pVM->rStack));
2023}
2024
2025static void twoToR(FICL_VM *pVM)
2026{
2027#if FICL_ROBUST > 1
2028 vmCheckStack(pVM, 2, 0);
2029#endif
2030 stackRoll(pVM->pStack, 1);
2031 stackPush(pVM->rStack, stackPop(pVM->pStack));
2032 stackPush(pVM->rStack, stackPop(pVM->pStack));
2033 return;
2034}
2035
2036static void twoRFrom(FICL_VM *pVM)
2037{
2038#if FICL_ROBUST > 1
2039 vmCheckStack(pVM, 0, 2);
2040#endif
2041 stackPush(pVM->pStack, stackPop(pVM->rStack));
2042 stackPush(pVM->pStack, stackPop(pVM->rStack));
2043 stackRoll(pVM->pStack, 1);
2044 return;
2045}
2046
2047static void twoRFetch(FICL_VM *pVM)
2048{
2049#if FICL_ROBUST > 1
2050 vmCheckStack(pVM, 0, 2);
2051#endif
2052 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2053 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2054 return;
2055}
2056
2057
2058/**************************************************************************
2059 v a r i a b l e
2060**
2061**************************************************************************/
2062
2063static void variableParen(FICL_VM *pVM)
2064{
2065 FICL_WORD *fw;
2066#if FICL_ROBUST > 1
2067 vmCheckStack(pVM, 0, 1);
2068#endif
2069
2070 fw = pVM->runningWord;
2071 PUSHPTR(fw->param);
2072}
2073
2074
2075static void variable(FICL_VM *pVM)
2076{
2077 FICL_DICT *dp = vmGetDict(pVM);
2078 STRINGINFO si = vmGetWord(pVM);
2079
2080 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2081 dictAllotCells(dp, 1);
2082 return;
2083}
2084
2085
2086static void twoVariable(FICL_VM *pVM)
2087{
2088 FICL_DICT *dp = vmGetDict(pVM);
2089 STRINGINFO si = vmGetWord(pVM);
2090
2091 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2092 dictAllotCells(dp, 2);
2093 return;
2094}
2095
2096
2097/**************************************************************************
2098 b a s e & f r i e n d s
2099**
2100**************************************************************************/
2101
2102static void base(FICL_VM *pVM)
2103{
2104 CELL *pBase;
2105#if FICL_ROBUST > 1
2106 vmCheckStack(pVM, 0, 1);
2107#endif
2108
2109 pBase = (CELL *)(&pVM->base);
2110 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2111 return;
2112}
2113
2114
2115static void decimal(FICL_VM *pVM)
2116{
2117 pVM->base = 10;
2118 return;
2119}
2120
2121
2122static void hex(FICL_VM *pVM)
2123{
2124 pVM->base = 16;
2125 return;
2126}
2127
2128
2129/**************************************************************************
2130 a l l o t & f r i e n d s
2131**
2132**************************************************************************/
2133
2134static void allot(FICL_VM *pVM)
2135{
2136 FICL_DICT *dp;
2137 FICL_INT i;
2138#if FICL_ROBUST > 1
2139 vmCheckStack(pVM, 1, 0);
2140#endif
2141
2142 dp = vmGetDict(pVM);
2143 i = POPINT();
2144
2145#if FICL_ROBUST
2146 dictCheck(dp, pVM, i);
2147#endif
2148
2149 dictAllot(dp, i);
2150 return;
2151}
2152
2153
2154static void here(FICL_VM *pVM)
2155{
2156 FICL_DICT *dp;
2157#if FICL_ROBUST > 1
2158 vmCheckStack(pVM, 0, 1);
2159#endif
2160
2161 dp = vmGetDict(pVM);
2162 PUSHPTR(dp->here);
2163 return;
2164}
2165
2166static void comma(FICL_VM *pVM)
2167{
2168 FICL_DICT *dp;
2169 CELL c;
2170#if FICL_ROBUST > 1
2171 vmCheckStack(pVM, 1, 0);
2172#endif
2173
2174 dp = vmGetDict(pVM);
2175 c = POP();
2176 dictAppendCell(dp, c);
2177 return;
2178}
2179
2180static void cComma(FICL_VM *pVM)
2181{
2182 FICL_DICT *dp;
2183 char c;
2184#if FICL_ROBUST > 1
2185 vmCheckStack(pVM, 1, 0);
2186#endif
2187
2188 dp = vmGetDict(pVM);
2189 c = (char)POPINT();
2190 dictAppendChar(dp, c);
2191 return;
2192}
2193
2194static void cells(FICL_VM *pVM)
2195{
2196 FICL_INT i;
2197#if FICL_ROBUST > 1
2198 vmCheckStack(pVM, 1, 1);
2199#endif
2200
2201 i = POPINT();
2202 PUSHINT(i * (FICL_INT)sizeof (CELL));
2203 return;
2204}
2205
2206static void cellPlus(FICL_VM *pVM)
2207{
2208 char *cp;
2209#if FICL_ROBUST > 1
2210 vmCheckStack(pVM, 1, 1);
2211#endif
2212
2213 cp = POPPTR();
2214 PUSHPTR(cp + sizeof (CELL));
2215 return;
2216}
2217
2218
2219
2220/**************************************************************************
2221 t i c k
2222** tick CORE ( "<spaces>name" -- xt )
2223** Skip leading space delimiters. Parse name delimited by a space. Find
2224** name and return xt, the execution token for name. An ambiguous condition
2225** exists if name is not found.
2226**************************************************************************/
2227void ficlTick(FICL_VM *pVM)
2228{
2229 FICL_WORD *pFW = NULL;
2230 STRINGINFO si = vmGetWord(pVM);
2231#if FICL_ROBUST > 1
2232 vmCheckStack(pVM, 0, 1);
2233#endif
2234
2235 pFW = dictLookup(vmGetDict(pVM), si);
2236 if (!pFW)
2237 {
2238 int i = SI_COUNT(si);
2239 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2240 }
2241 PUSHPTR(pFW);
2242 return;
2243}
2244
2245
2246static void bracketTickCoIm(FICL_VM *pVM)
2247{
2248 ficlTick(pVM);
2249 literalIm(pVM);
2250
2251 return;
2252}
2253
2254
2255/**************************************************************************
2256 p o s t p o n e
2257** Lookup the next word in the input stream and compile code to
2258** insert it into definitions created by the resulting word
2259** (defers compilation, even of immediate words)
2260**************************************************************************/
2261
2262static void postponeCoIm(FICL_VM *pVM)
2263{
2264 FICL_DICT *dp = vmGetDict(pVM);
2265 FICL_WORD *pFW;
2266 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2267 assert(pComma);
2268
2269 ficlTick(pVM);
2270 pFW = stackGetTop(pVM->pStack).p;
2271 if (wordIsImmediate(pFW))
2272 {
2273 dictAppendCell(dp, stackPop(pVM->pStack));
2274 }
2275 else
2276 {
2277 literalIm(pVM);
2278 dictAppendCell(dp, LVALUEtoCELL(pComma));
2279 }
2280
2281 return;
2282}
2283
2284
2285
2286/**************************************************************************
2287 e x e c u t e
2288** Pop an execution token (pointer to a word) off the stack and
2289** run it
2290**************************************************************************/
2291
2292static void execute(FICL_VM *pVM)
2293{
2294 FICL_WORD *pFW;
2295#if FICL_ROBUST > 1
2296 vmCheckStack(pVM, 1, 0);
2297#endif
2298
2299 pFW = stackPopPtr(pVM->pStack);
2300 vmExecute(pVM, pFW);
2301
2302 return;
2303}
2304
2305
2306/**************************************************************************
2307 i m m e d i a t e
2308** Make the most recently compiled word IMMEDIATE -- it executes even
2309** in compile state (most often used for control compiling words
2310** such as IF, THEN, etc)
2311**************************************************************************/
2312
2313static void immediate(FICL_VM *pVM)
2314{
2315 IGNORE(pVM);
2316 dictSetImmediate(vmGetDict(pVM));
2317 return;
2318}
2319
2320
2321static void compileOnly(FICL_VM *pVM)
2322{
2323 IGNORE(pVM);
2324 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2325 return;
2326}
2327
2328
2329static void setObjectFlag(FICL_VM *pVM)
2330{
2331 IGNORE(pVM);
2332 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2333 return;
2334}
2335
2336static void isObject(FICL_VM *pVM)
2337{
2338 int flag;
2339 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2340
2341 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2342 stackPushINT(pVM->pStack, flag);
2343 return;
2344}
2345
2346static void cstringLit(FICL_VM *pVM)
2347{
2348 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2349
2350 char *cp = sp->text;
2351 cp += sp->count + 1;
2352 cp = alignPtr(cp);
2353 pVM->ip = (IPTYPE)(void *)cp;
2354
2355 stackPushPtr(pVM->pStack, sp);
2356 return;
2357}
2358
2359
2360static void cstringQuoteIm(FICL_VM *pVM)
2361{
2362 FICL_DICT *dp = vmGetDict(pVM);
2363
2364 if (pVM->state == INTERPRET)
2365 {
2366 FICL_STRING *sp = (FICL_STRING *) dp->here;
2367 vmGetString(pVM, sp, '\"');
2368 stackPushPtr(pVM->pStack, sp);
2369 /* move HERE past string so it doesn't get overwritten. --lch */
2370 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2371 }
2372 else /* COMPILE state */
2373 {
2374 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2375 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2376 dictAlign(dp);
2377 }
2378
2379 return;
2380}
2381
2382/**************************************************************************
2383 d o t Q u o t e
2384** IMMEDIATE word that compiles a string literal for later display
2385** Compile stringLit, then copy the bytes of the string from the TIB
2386** to the dictionary. Backpatch the count byte and align the dictionary.
2387**
2388** stringlit: Fetch the count from the dictionary, then push the address
2389** and count on the stack. Finally, update ip to point to the first
2390** aligned address after the string text.
2391**************************************************************************/
2392
2393static void stringLit(FICL_VM *pVM)
2394{
2395 FICL_STRING *sp;
2396 FICL_COUNT count;
2397 char *cp;
2398#if FICL_ROBUST > 1
2399 vmCheckStack(pVM, 0, 2);
2400#endif
2401
2402 sp = (FICL_STRING *)(pVM->ip);
2403 count = sp->count;
2404 cp = sp->text;
2405 PUSHPTR(cp);
2406 PUSHUNS(count);
2407 cp += count + 1;
2408 cp = alignPtr(cp);
2409 pVM->ip = (IPTYPE)(void *)cp;
2410}
2411
2412static void dotQuoteCoIm(FICL_VM *pVM)
2413{
2414 FICL_DICT *dp = vmGetDict(pVM);
2415 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2416 assert(pType);
2417 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2418 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2419 dictAlign(dp);
2420 dictAppendCell(dp, LVALUEtoCELL(pType));
2421 return;
2422}
2423
2424
2425static void dotParen(FICL_VM *pVM)
2426{
2427 char *pSrc = vmGetInBuf(pVM);
2428 char *pEnd = vmGetInBufEnd(pVM);
2429 char *pDest = pVM->pad;
2430 char ch;
2431
2432 /*
2433 ** Note: the standard does not want leading spaces skipped (apparently)
2434 */
2435 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2436 *pDest++ = ch;
2437
2438 *pDest = '\0';
2439 if ((pEnd != pSrc) && (ch == ')'))
2440 pSrc++;
2441
2442 vmTextOut(pVM, pVM->pad, 0);
2443 vmUpdateTib(pVM, pSrc);
2444
2445 return;
2446}
2447
2448
2449/**************************************************************************
2450 s l i t e r a l
2451** STRING
2452** Interpretation: Interpretation semantics for this word are undefined.
2453** Compilation: ( c-addr1 u -- )
2454** Append the run-time semantics given below to the current definition.
2455** Run-time: ( -- c-addr2 u )
2456** Return c-addr2 u describing a string consisting of the characters
2457** specified by c-addr1 u during compilation. A program shall not alter
2458** the returned string.
2459**************************************************************************/
2460static void sLiteralCoIm(FICL_VM *pVM)
2461{
2462 FICL_DICT *dp;
2463 char *cp, *cpDest;
2464 FICL_UNS u;
2465
2466#if FICL_ROBUST > 1
2467 vmCheckStack(pVM, 2, 0);
2468#endif
2469
2470 dp = vmGetDict(pVM);
2471 u = POPUNS();
2472 cp = POPPTR();
2473
2474 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2475 cpDest = (char *) dp->here;
2476 *cpDest++ = (char) u;
2477
2478 for (; u > 0; --u)
2479 {
2480 *cpDest++ = *cp++;
2481 }
2482
2483 *cpDest++ = 0;
2484 dp->here = PTRtoCELL alignPtr(cpDest);
2485 return;
2486}
2487
2488
2489/**************************************************************************
2490 s t a t e
2491** Return the address of the VM's state member (must be sized the
2492** same as a CELL for this reason)
2493**************************************************************************/
2494static void state(FICL_VM *pVM)
2495{
2496#if FICL_ROBUST > 1
2497 vmCheckStack(pVM, 0, 1);
2498#endif
2499 PUSHPTR(&pVM->state);
2500 return;
2501}
2502
2503
2504/**************************************************************************
2505 c r e a t e . . . d o e s >
2506** Make a new word in the dictionary with the run-time effect of
2507** a variable (push my address), but with extra space allotted
2508** for use by does> .
2509**************************************************************************/
2510
2511static void createParen(FICL_VM *pVM)
2512{
2513 CELL *pCell;
2514
2515#if FICL_ROBUST > 1
2516 vmCheckStack(pVM, 0, 1);
2517#endif
2518
2519 pCell = pVM->runningWord->param;
2520 PUSHPTR(pCell+1);
2521 return;
2522}
2523
2524
2525static void create(FICL_VM *pVM)
2526{
2527 FICL_DICT *dp = vmGetDict(pVM);
2528 STRINGINFO si = vmGetWord(pVM);
2529
2530 dictCheckThreshold(dp);
2531
2532 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2533 dictAllotCells(dp, 1);
2534 return;
2535}
2536
2537
2538static void doDoes(FICL_VM *pVM)
2539{
2540 CELL *pCell;
2541 IPTYPE tempIP;
2542#if FICL_ROBUST > 1
2543 vmCheckStack(pVM, 0, 1);
2544#endif
2545
2546 pCell = pVM->runningWord->param;
2547 tempIP = (IPTYPE)((*pCell).p);
2548 PUSHPTR(pCell+1);
2549 vmPushIP(pVM, tempIP);
2550 return;
2551}
2552
2553
2554static void doesParen(FICL_VM *pVM)
2555{
2556 FICL_DICT *dp = vmGetDict(pVM);
2557 dp->smudge->code = doDoes;
2558 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2559 vmPopIP(pVM);
2560 return;
2561}
2562
2563
2564static void doesCoIm(FICL_VM *pVM)
2565{
2566 FICL_DICT *dp = vmGetDict(pVM);
2567#if FICL_WANT_LOCALS
2568 assert(pVM->pSys->pUnLinkParen);
2569 if (pVM->pSys->nLocals > 0)
2570 {
2571 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2572 dictEmpty(pLoc, pLoc->pForthWords->size);
2573 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2574 }
2575
2576 pVM->pSys->nLocals = 0;
2577#endif
2578 IGNORE(pVM);
2579
2580 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2581 return;
2582}
2583
2584
2585/**************************************************************************
2586 t o b o d y
2587** to-body CORE ( xt -- a-addr )
2588** a-addr is the data-field address corresponding to xt. An ambiguous
2589** condition exists if xt is not for a word defined via CREATE.
2590**************************************************************************/
2591static void toBody(FICL_VM *pVM)
2592{
2593 FICL_WORD *pFW;
2594/*#$-GUY CHANGE: Added robustness.-$#*/
2595#if FICL_ROBUST > 1
2596 vmCheckStack(pVM, 1, 1);
2597#endif
2598
2599 pFW = POPPTR();
2600 PUSHPTR(pFW->param + 1);
2601 return;
2602}
2603
2604
2605/*
2606** from-body ficl ( a-addr -- xt )
2607** Reverse effect of >body
2608*/
2609static void fromBody(FICL_VM *pVM)
2610{
2611 char *ptr;
2612#if FICL_ROBUST > 1
2613 vmCheckStack(pVM, 1, 1);
2614#endif
2615
2616 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2617 PUSHPTR(ptr);
2618 return;
2619}
2620
2621
2622/*
2623** >name ficl ( xt -- c-addr u )
2624** Push the address and length of a word's name given its address
2625** xt.
2626*/
2627static void toName(FICL_VM *pVM)
2628{
2629 FICL_WORD *pFW;
2630#if FICL_ROBUST > 1
2631 vmCheckStack(pVM, 1, 2);
2632#endif
2633
2634 pFW = POPPTR();
2635 PUSHPTR(pFW->name);
2636 PUSHUNS(pFW->nName);
2637 return;
2638}
2639
2640
2641static void getLastWord(FICL_VM *pVM)
2642{
2643 FICL_DICT *pDict = vmGetDict(pVM);
2644 FICL_WORD *wp = pDict->smudge;
2645 assert(wp);
2646 vmPush(pVM, LVALUEtoCELL(wp));
2647 return;
2648}
2649
2650
2651/**************************************************************************
2652 l b r a c k e t e t c
2653**
2654**************************************************************************/
2655
2656static void lbracketCoIm(FICL_VM *pVM)
2657{
2658 pVM->state = INTERPRET;
2659 return;
2660}
2661
2662
2663static void rbracket(FICL_VM *pVM)
2664{
2665 pVM->state = COMPILE;
2666 return;
2667}
2668
2669
2670/**************************************************************************
2671 p i c t u r e d n u m e r i c w o r d s
2672**
2673** less-number-sign CORE ( -- )
2674** Initialize the pictured numeric output conversion process.
2675** (clear the pad)
2676**************************************************************************/
2677static void lessNumberSign(FICL_VM *pVM)
2678{
2679 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2680 sp->count = 0;
2681 return;
2682}
2683
2684/*
2685** number-sign CORE ( ud1 -- ud2 )
2686** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2687** n. (n is the least-significant digit of ud1.) Convert n to external form
2688** and add the resulting character to the beginning of the pictured numeric
2689** output string. An ambiguous condition exists if # executes outside of a
2690** <# #> delimited number conversion.
2691*/
2692static void numberSign(FICL_VM *pVM)
2693{
2694 FICL_STRING *sp;
2695 DPUNS u;
2696 UNS16 rem;
2697#if FICL_ROBUST > 1
2698 vmCheckStack(pVM, 2, 2);
2699#endif
2700
2701 sp = PTRtoSTRING pVM->pad;
2702 u = u64Pop(pVM->pStack);
2703 rem = m64UMod(&u, (UNS16)(pVM->base));
2704 sp->text[sp->count++] = digit_to_char(rem);
2705 u64Push(pVM->pStack, u);
2706 return;
2707}
2708
2709/*
2710** number-sign-greater CORE ( xd -- c-addr u )
2711** Drop xd. Make the pictured numeric output string available as a character
2712** string. c-addr and u specify the resulting character string. A program
2713** may replace characters within the string.
2714*/
2715static void numberSignGreater(FICL_VM *pVM)
2716{
2717 FICL_STRING *sp;
2718#if FICL_ROBUST > 1
2719 vmCheckStack(pVM, 2, 2);
2720#endif
2721
2722 sp = PTRtoSTRING pVM->pad;
2723 sp->text[sp->count] = 0;
2724 strrev(sp->text);
2725 DROP(2);
2726 PUSHPTR(sp->text);
2727 PUSHUNS(sp->count);
2728 return;
2729}
2730
2731/*
2732** number-sign-s CORE ( ud1 -- ud2 )
2733** Convert one digit of ud1 according to the rule for #. Continue conversion
2734** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2735** #S executes outside of a <# #> delimited number conversion.
2736** TO DO: presently does not use ud1 hi cell - use it!
2737*/
2738static void numberSignS(FICL_VM *pVM)
2739{
2740 FICL_STRING *sp;
2741 DPUNS u;
2742 UNS16 rem;
2743#if FICL_ROBUST > 1
2744 vmCheckStack(pVM, 2, 2);
2745#endif
2746
2747 sp = PTRtoSTRING pVM->pad;
2748 u = u64Pop(pVM->pStack);
2749
2750 do
2751 {
2752 rem = m64UMod(&u, (UNS16)(pVM->base));
2753 sp->text[sp->count++] = digit_to_char(rem);
2754 }
2755 while (u.hi || u.lo);
2756
2757 u64Push(pVM->pStack, u);
2758 return;
2759}
2760
2761/*
2762** HOLD CORE ( char -- )
2763** Add char to the beginning of the pictured numeric output string. An ambiguous
2764** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2765*/
2766static void hold(FICL_VM *pVM)
2767{
2768 FICL_STRING *sp;
2769 int i;
2770#if FICL_ROBUST > 1
2771 vmCheckStack(pVM, 1, 0);
2772#endif
2773
2774 sp = PTRtoSTRING pVM->pad;
2775 i = POPINT();
2776 sp->text[sp->count++] = (char) i;
2777 return;
2778}
2779
2780/*
2781** SIGN CORE ( n -- )
2782** If n is negative, add a minus sign to the beginning of the pictured
2783** numeric output string. An ambiguous condition exists if SIGN
2784** executes outside of a <# #> delimited number conversion.
2785*/
2786static void sign(FICL_VM *pVM)
2787{
2788 FICL_STRING *sp;
2789 int i;
2790#if FICL_ROBUST > 1
2791 vmCheckStack(pVM, 1, 0);
2792#endif
2793
2794 sp = PTRtoSTRING pVM->pad;
2795 i = POPINT();
2796 if (i < 0)
2797 sp->text[sp->count++] = '-';
2798 return;
2799}
2800
2801
2802/**************************************************************************
2803 t o N u m b e r
2804** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2805** ud2 is the unsigned result of converting the characters within the
2806** string specified by c-addr1 u1 into digits, using the number in BASE,
2807** and adding each into ud1 after multiplying ud1 by the number in BASE.
2808** Conversion continues left-to-right until a character that is not
2809** convertible, including any + or -, is encountered or the string is
2810** entirely converted. c-addr2 is the location of the first unconverted
2811** character or the first character past the end of the string if the string
2812** was entirely converted. u2 is the number of unconverted characters in the
2813** string. An ambiguous condition exists if ud2 overflows during the
2814** conversion.
2815**************************************************************************/
2816static void toNumber(FICL_VM *pVM)
2817{
2818 FICL_UNS count;
2819 char *cp;
2820 DPUNS accum;
2821 FICL_UNS base = pVM->base;
2822 FICL_UNS ch;
2823 FICL_UNS digit;
2824
2825#if FICL_ROBUST > 1
2826 vmCheckStack(pVM,4,4);
2827#endif
2828
2829 count = POPUNS();
2830 cp = (char *)POPPTR();
2831 accum = u64Pop(pVM->pStack);
2832
2833 for (ch = *cp; count > 0; ch = *++cp, count--)
2834 {
2835 if (ch < '0')
2836 break;
2837
2838 digit = ch - '0';
2839
2840 if (digit > 9)
2841 digit = tolower(ch) - 'a' + 10;
2842 /*
2843 ** Note: following test also catches chars between 9 and a
2844 ** because 'digit' is unsigned!
2845 */
2846 if (digit >= base)
2847 break;
2848
2849 accum = m64Mac(accum, base, digit);
2850 }
2851
2852 u64Push(pVM->pStack, accum);
2853 PUSHPTR(cp);
2854 PUSHUNS(count);
2855
2856 return;
2857}
2858
2859
2860
2861/**************************************************************************
2862 q u i t & a b o r t
2863** quit CORE ( -- ) ( R: i*x -- )
2864** Empty the return stack, store zero in SOURCE-ID if it is present, make
2865** the user input device the input source, and enter interpretation state.
2866** Do not display a message. Repeat the following:
2867**
2868** Accept a line from the input source into the input buffer, set >IN to
2869** zero, and interpret.
2870** Display the implementation-defined system prompt if in
2871** interpretation state, all processing has been completed, and no
2872** ambiguous condition exists.
2873**************************************************************************/
2874
2875static void quit(FICL_VM *pVM)
2876{
2877 vmThrow(pVM, VM_QUIT);
2878 return;
2879}
2880
2881
2882static void ficlAbort(FICL_VM *pVM)
2883{
2884 vmThrow(pVM, VM_ABORT);
2885 return;
2886}
2887
2888
2889/**************************************************************************
2890 a c c e p t
2891** accept CORE ( c-addr +n1 -- +n2 )
2892** Receive a string of at most +n1 characters. An ambiguous condition
2893** exists if +n1 is zero or greater than 32,767. Display graphic characters
2894** as they are received. A program that depends on the presence or absence
2895** of non-graphic characters in the string has an environmental dependency.
2896** The editing functions, if any, that the system performs in order to
2897** construct the string are implementation-defined.
2898**
2899** (Although the standard text doesn't say so, I assume that the intent
2900** of 'accept' is to store the string at the address specified on
2901** the stack.)
2902** Implementation: if there's more text in the TIB, use it. Otherwise
2903** throw out for more text. Copy characters up to the max count into the
2904** address given, and return the number of actual characters copied.
2905**
2906** Note (sobral) this may not be the behavior you'd expect if you're
2907** trying to get user input at load time!
2908**************************************************************************/
2909static void accept(FICL_VM *pVM)
2910{
2911 FICL_UNS count, len;
2912 char *cp;
2913 char *pBuf, *pEnd;
2914
2915#if FICL_ROBUST > 1
2916 vmCheckStack(pVM,2,1);
2917#endif
2918
2919 pBuf = vmGetInBuf(pVM);
2920 pEnd = vmGetInBufEnd(pVM);
2921 len = pEnd - pBuf;
2922 if (len == 0)
2923 vmThrow(pVM, VM_RESTART);
2924
2925 /*
2926 ** Now we have something in the text buffer - use it
2927 */
2928 count = stackPopINT(pVM->pStack);
2929 cp = stackPopPtr(pVM->pStack);
2930
2931 len = (count < len) ? count : len;
2932 strncpy(cp, vmGetInBuf(pVM), len);
2933 pBuf += len;
2934 vmUpdateTib(pVM, pBuf);
2935 PUSHINT(len);
2936
2937 return;
2938}
2939
2940
2941/**************************************************************************
2942 a l i g n
2943** 6.1.0705 ALIGN CORE ( -- )
2944** If the data-space pointer is not aligned, reserve enough space to
2945** align it.
2946**************************************************************************/
2947static void align(FICL_VM *pVM)
2948{
2949 FICL_DICT *dp = vmGetDict(pVM);
2950 IGNORE(pVM);
2951 dictAlign(dp);
2952 return;
2953}
2954
2955
2956/**************************************************************************
2957 a l i g n e d
2958**
2959**************************************************************************/
2960static void aligned(FICL_VM *pVM)
2961{
2962 void *addr;
2963#if FICL_ROBUST > 1
2964 vmCheckStack(pVM,1,1);
2965#endif
2966
2967 addr = POPPTR();
2968 PUSHPTR(alignPtr(addr));
2969 return;
2970}
2971
2972
2973/**************************************************************************
2974 b e g i n & f r i e n d s
2975** Indefinite loop control structures
2976** A.6.1.0760 BEGIN
2977** Typical use:
2978** : X ... BEGIN ... test UNTIL ;
2979** or
2980** : X ... BEGIN ... test WHILE ... REPEAT ;
2981**************************************************************************/
2982static void beginCoIm(FICL_VM *pVM)
2983{
2984 FICL_DICT *dp = vmGetDict(pVM);
2985 markBranch(dp, pVM, destTag);
2986 return;
2987}
2988
2989static void untilCoIm(FICL_VM *pVM)
2990{
2991 FICL_DICT *dp = vmGetDict(pVM);
2992
2993 assert(pVM->pSys->pIfParen);
2994
2995 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
2996 resolveBackBranch(dp, pVM, destTag);
2997 return;
2998}
2999
3000static void whileCoIm(FICL_VM *pVM)
3001{
3002 FICL_DICT *dp = vmGetDict(pVM);
3003
3004 assert(pVM->pSys->pIfParen);
3005
3006 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
3007 markBranch(dp, pVM, origTag);
3008 twoSwap(pVM);
3009 dictAppendUNS(dp, 1);
3010 return;
3011}
3012
3013static void repeatCoIm(FICL_VM *pVM)
3014{
3015 FICL_DICT *dp = vmGetDict(pVM);
3016
3017 assert(pVM->pSys->pBranchParen);
3018 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3019
3020 /* expect "begin" branch marker */
3021 resolveBackBranch(dp, pVM, destTag);
3022 /* expect "while" branch marker */
3023 resolveForwardBranch(dp, pVM, origTag);
3024 return;
3025}
3026
3027
3028static void againCoIm(FICL_VM *pVM)
3029{
3030 FICL_DICT *dp = vmGetDict(pVM);
3031
3032 assert(pVM->pSys->pBranchParen);
3033 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3034
3035 /* expect "begin" branch marker */
3036 resolveBackBranch(dp, pVM, destTag);
3037 return;
3038}
3039
3040
3041/**************************************************************************
3042 c h a r & f r i e n d s
3043** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
3044** Skip leading space delimiters. Parse name delimited by a space.
3045** Put the value of its first character onto the stack.
3046**
3047** bracket-char CORE
3048** Interpretation: Interpretation semantics for this word are undefined.
3049** Compilation: ( "<spaces>name" -- )
3050** Skip leading space delimiters. Parse name delimited by a space.
3051** Append the run-time semantics given below to the current definition.
3052** Run-time: ( -- char )
3053** Place char, the value of the first character of name, on the stack.
3054**************************************************************************/
3055static void ficlChar(FICL_VM *pVM)
3056{
3057 STRINGINFO si;
3058#if FICL_ROBUST > 1
3059 vmCheckStack(pVM,0,1);
3060#endif
3061
3062 si = vmGetWord(pVM);
3063 PUSHUNS((FICL_UNS)(si.cp[0]));
3064 return;
3065}
3066
3067static void charCoIm(FICL_VM *pVM)
3068{
3069 ficlChar(pVM);
3070 literalIm(pVM);
3071 return;
3072}
3073
3074/**************************************************************************
3075 c h a r P l u s
3076** char-plus CORE ( c-addr1 -- c-addr2 )
3077** Add the size in address units of a character to c-addr1, giving c-addr2.
3078**************************************************************************/
3079static void charPlus(FICL_VM *pVM)
3080{
3081 char *cp;
3082#if FICL_ROBUST > 1
3083 vmCheckStack(pVM,1,1);
3084#endif
3085
3086 cp = POPPTR();
3087 PUSHPTR(cp + 1);
3088 return;
3089}
3090
3091/**************************************************************************
3092 c h a r s
3093** chars CORE ( n1 -- n2 )
3094** n2 is the size in address units of n1 characters.
3095** For most processors, this function can be a no-op. To guarantee
3096** portability, we'll multiply by sizeof (char).
3097**************************************************************************/
3098#if defined (_M_IX86)
3099#pragma warning(disable: 4127)
3100#endif
3101static void ficlChars(FICL_VM *pVM)
3102{
3103 if (sizeof (char) > 1)
3104 {
3105 FICL_INT i;
3106#if FICL_ROBUST > 1
3107 vmCheckStack(pVM,1,1);
3108#endif
3109 i = POPINT();
3110 PUSHINT(i * sizeof (char));
3111 }
3112 /* otherwise no-op! */
3113 return;
3114}
3115#if defined (_M_IX86)
3116#pragma warning(default: 4127)
3117#endif
3118
3119
3120/**************************************************************************
3121 c o u n t
3122** COUNT CORE ( c-addr1 -- c-addr2 u )
3123** Return the character string specification for the counted string stored
3124** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3125** u is the contents of the character at c-addr1, which is the length in
3126** characters of the string at c-addr2.
3127**************************************************************************/
3128static void count(FICL_VM *pVM)
3129{
3130 FICL_STRING *sp;
3131#if FICL_ROBUST > 1
3132 vmCheckStack(pVM,1,2);
3133#endif
3134
3135 sp = POPPTR();
3136 PUSHPTR(sp->text);
3137 PUSHUNS(sp->count);
3138 return;
3139}
3140
3141/**************************************************************************
3142 e n v i r o n m e n t ?
3143** environment-query CORE ( c-addr u -- false | i*x true )
3144** c-addr is the address of a character string and u is the string's
3145** character count. u may have a value in the range from zero to an
3146** implementation-defined maximum which shall not be less than 31. The
3147** character string should contain a keyword from 3.2.6 Environmental
3148** queries or the optional word sets to be checked for correspondence
3149** with an attribute of the present environment. If the system treats the
3150** attribute as unknown, the returned flag is false; otherwise, the flag
3151** is true and the i*x returned is of the type specified in the table for
3152** the attribute queried.
3153**************************************************************************/
3154static void environmentQ(FICL_VM *pVM)
3155{
3156 FICL_DICT *envp;
3157 FICL_WORD *pFW;
3158 STRINGINFO si;
3159#if FICL_ROBUST > 1
3160 vmCheckStack(pVM,2,1);
3161#endif
3162
3163 envp = pVM->pSys->envp;
3164 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3165 si.cp = stackPopPtr(pVM->pStack);
3166
3167 pFW = dictLookup(envp, si);
3168
3169 if (pFW != NULL)
3170 {
3171 vmExecute(pVM, pFW);
3172 PUSHINT(FICL_TRUE);
3173 }
3174 else
3175 {
3176 PUSHINT(FICL_FALSE);
3177 }
3178 return;
3179}
3180
3181/**************************************************************************
3182 e v a l u a t e
3183** EVALUATE CORE ( i*x c-addr u -- j*x )
3184** Save the current input source specification. Store minus-one (-1) in
3185** SOURCE-ID if it is present. Make the string described by c-addr and u
3186** both the input source and input buffer, set >IN to zero, and interpret.
3187** When the parse area is empty, restore the prior input source
3188** specification. Other stack effects are due to the words EVALUATEd.
3189**
3190**************************************************************************/
3191static void evaluate(FICL_VM *pVM)
3192{
3193 FICL_UNS count;
3194 char *cp;
3195 CELL id;
3196 int result;
3197#if FICL_ROBUST > 1
3198 vmCheckStack(pVM,2,0);
3199#endif
3200
3201 count = POPUNS();
3202 cp = POPPTR();
3203
3204 IGNORE(count);
3205 id = pVM->sourceID;
3206 pVM->sourceID.i = -1;
3207 result = ficlExecC(pVM, cp, count);
3208 pVM->sourceID = id;
3209 if (result != VM_OUTOFTEXT)
3210 vmThrow(pVM, result);
3211
3212 return;
3213}
3214
3215
3216/**************************************************************************
3217 s t r i n g q u o t e
3218** Interpreting: get string delimited by a quote from the input stream,
3219** copy to a scratch area, and put its count and address on the stack.
3220** Compiling: compile code to push the address and count of a string
3221** literal, compile the string from the input stream, and align the dict
3222** pointer.
3223**************************************************************************/
3224static void stringQuoteIm(FICL_VM *pVM)
3225{
3226 FICL_DICT *dp = vmGetDict(pVM);
3227
3228 if (pVM->state == INTERPRET)
3229 {
3230 FICL_STRING *sp = (FICL_STRING *) dp->here;
3231 vmGetString(pVM, sp, '\"');
3232 PUSHPTR(sp->text);
3233 PUSHUNS(sp->count);
3234 }
3235 else /* COMPILE state */
3236 {
3237 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3238 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3239 dictAlign(dp);
3240 }
3241
3242 return;
3243}
3244
3245
3246/**************************************************************************
3247 t y p e
3248** Pop count and char address from stack and print the designated string.
3249**************************************************************************/
3250static void type(FICL_VM *pVM)
3251{
3252 FICL_UNS count = stackPopUNS(pVM->pStack);
3253 char *cp = stackPopPtr(pVM->pStack);
3254 char *pDest = (char *)ficlMalloc(count + 1);
3255
3256 /*
3257 ** Since we don't have an output primitive for a counted string
3258 ** (oops), make sure the string is null terminated. If not, copy
3259 ** and terminate it.
3260 */
3261 if (!pDest)
3262 vmThrowErr(pVM, "Error: out of memory");
3263
3264 strncpy(pDest, cp, count);
3265 pDest[count] = '\0';
3266
3267 vmTextOut(pVM, pDest, 0);
3268
3269 ficlFree(pDest);
3270 return;
3271}
3272
3273/**************************************************************************
3274 w o r d
3275** word CORE ( char "<chars>ccc<char>" -- c-addr )
3276** Skip leading delimiters. Parse characters ccc delimited by char. An
3277** ambiguous condition exists if the length of the parsed string is greater
3278** than the implementation-defined length of a counted string.
3279**
3280** c-addr is the address of a transient region containing the parsed word
3281** as a counted string. If the parse area was empty or contained no
3282** characters other than the delimiter, the resulting string has a zero
3283** length. A space, not included in the length, follows the string. A
3284** program may replace characters within the string.
3285** NOTE! Ficl also NULL-terminates the dest string.
3286**************************************************************************/
3287static void ficlWord(FICL_VM *pVM)
3288{
3289 FICL_STRING *sp;
3290 char delim;
3291 STRINGINFO si;
3292#if FICL_ROBUST > 1
3293 vmCheckStack(pVM,1,1);
3294#endif
3295
3296 sp = (FICL_STRING *)pVM->pad;
3297 delim = (char)POPINT();
3298 si = vmParseStringEx(pVM, delim, 1);
3299
3300 if (SI_COUNT(si) > nPAD-1)
3301 SI_SETLEN(si, nPAD-1);
3302
3303 sp->count = (FICL_COUNT)SI_COUNT(si);
3304 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3305 /*#$-GUY CHANGE: I added this.-$#*/
3306 sp->text[sp->count] = 0;
3307 strcat(sp->text, " ");
3308
3309 PUSHPTR(sp);
3310 return;
3311}
3312
3313
3314/**************************************************************************
3315 p a r s e - w o r d
3316** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3317** Skip leading spaces and parse name delimited by a space. c-addr is the
3318** address within the input buffer and u is the length of the selected
3319** string. If the parse area is empty, the resulting string has a zero length.
3320**************************************************************************/
3321static void parseNoCopy(FICL_VM *pVM)
3322{
3323 STRINGINFO si;
3324#if FICL_ROBUST > 1
3325 vmCheckStack(pVM,0,2);
3326#endif
3327
3328 si = vmGetWord0(pVM);
3329 PUSHPTR(SI_PTR(si));
3330 PUSHUNS(SI_COUNT(si));
3331 return;
3332}
3333
3334
3335/**************************************************************************
3336 p a r s e
3337** CORE EXT ( char "ccc<char>" -- c-addr u )
3338** Parse ccc delimited by the delimiter char.
3339** c-addr is the address (within the input buffer) and u is the length of
3340** the parsed string. If the parse area was empty, the resulting string has
3341** a zero length.
3342** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3343**************************************************************************/
3344static void parse(FICL_VM *pVM)
3345{
3346 STRINGINFO si;
3347 char delim;
3348
3349#if FICL_ROBUST > 1
3350 vmCheckStack(pVM,1,2);
3351#endif
3352
3353 delim = (char)POPINT();
3354
3355 si = vmParseStringEx(pVM, delim, 0);
3356 PUSHPTR(SI_PTR(si));
3357 PUSHUNS(SI_COUNT(si));
3358 return;
3359}
3360
3361
3362/**************************************************************************
3363 f i l l
3364** CORE ( c-addr u char -- )
3365** If u is greater than zero, store char in each of u consecutive
3366** characters of memory beginning at c-addr.
3367**************************************************************************/
3368static void fill(FICL_VM *pVM)
3369{
3370 char ch;
3371 FICL_UNS u;
3372 char *cp;
3373#if FICL_ROBUST > 1
3374 vmCheckStack(pVM,3,0);
3375#endif
3376 ch = (char)POPINT();
3377 u = POPUNS();
3378 cp = (char *)POPPTR();
3379
3380 while (u > 0)
3381 {
3382 *cp++ = ch;
3383 u--;
3384 }
3385 return;
3386}
3387
3388
3389/**************************************************************************
3390 f i n d
3391** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3392** Find the definition named in the counted string at c-addr. If the
3393** definition is not found, return c-addr and zero. If the definition is
3394** found, return its execution token xt. If the definition is immediate,
3395** also return one (1), otherwise also return minus-one (-1). For a given
3396** string, the values returned by FIND while compiling may differ from
3397** those returned while not compiling.
3398**************************************************************************/
3399static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3400{
3401 FICL_WORD *pFW;
3402
3403 pFW = dictLookup(vmGetDict(pVM), si);
3404 if (pFW)
3405 {
3406 PUSHPTR(pFW);
3407 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3408 }
3409 else
3410 {
3411 PUSHPTR(returnForFailure);
3412 PUSHUNS(0);
3413 }
3414 return;
3415}
3416
3417
3418
3419/**************************************************************************
3420 f i n d
3421** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3422** Find the definition named in the counted string at c-addr. If the
3423** definition is not found, return c-addr and zero. If the definition is
3424** found, return its execution token xt. If the definition is immediate,
3425** also return one (1), otherwise also return minus-one (-1). For a given
3426** string, the values returned by FIND while compiling may differ from
3427** those returned while not compiling.
3428**************************************************************************/
3429static void cFind(FICL_VM *pVM)
3430{
3431 FICL_STRING *sp;
3432 STRINGINFO si;
3433
3434#if FICL_ROBUST > 1
3435 vmCheckStack(pVM,1,2);
3436#endif
3437 sp = POPPTR();
3438 SI_PFS(si, sp);
3439 do_find(pVM, si, sp);
3440}
3441
3442
3443
3444/**************************************************************************
3445 s f i n d
3446** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3447** Like FIND, but takes "c-addr u" for the string.
3448**************************************************************************/
3449static void sFind(FICL_VM *pVM)
3450{
3451 STRINGINFO si;
3452
3453#if FICL_ROBUST > 1
3454 vmCheckStack(pVM,2,2);
3455#endif
3456
3457 si.count = stackPopINT(pVM->pStack);
3458 si.cp = stackPopPtr(pVM->pStack);
3459
3460 do_find(pVM, si, NULL);
3461}
3462
3463
3464
3465/**************************************************************************
3466 f m S l a s h M o d
3467** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3468** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3469** Input and output stack arguments are signed. An ambiguous condition
3470** exists if n1 is zero or if the quotient lies outside the range of a
3471** single-cell signed integer.
3472**************************************************************************/
3473static void fmSlashMod(FICL_VM *pVM)
3474{
3475 DPINT d1;
3476 FICL_INT n1;
3477 INTQR qr;
3478#if FICL_ROBUST > 1
3479 vmCheckStack(pVM,3,2);
3480#endif
3481
3482 n1 = POPINT();
3483 d1 = i64Pop(pVM->pStack);
3484 qr = m64FlooredDivI(d1, n1);
3485 PUSHINT(qr.rem);
3486 PUSHINT(qr.quot);
3487 return;
3488}
3489
3490
3491/**************************************************************************
3492 s m S l a s h R e m
3493** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3494** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3495** Input and output stack arguments are signed. An ambiguous condition
3496** exists if n1 is zero or if the quotient lies outside the range of a
3497** single-cell signed integer.
3498**************************************************************************/
3499static void smSlashRem(FICL_VM *pVM)
3500{
3501 DPINT d1;
3502 FICL_INT n1;
3503 INTQR qr;
3504#if FICL_ROBUST > 1
3505 vmCheckStack(pVM,3,2);
3506#endif
3507
3508 n1 = POPINT();
3509 d1 = i64Pop(pVM->pStack);
3510 qr = m64SymmetricDivI(d1, n1);
3511 PUSHINT(qr.rem);
3512 PUSHINT(qr.quot);
3513 return;
3514}
3515
3516
3517static void ficlMod(FICL_VM *pVM)
3518{
3519 DPINT d1;
3520 FICL_INT n1;
3521 INTQR qr;
3522#if FICL_ROBUST > 1
3523 vmCheckStack(pVM,2,1);
3524#endif
3525
3526 n1 = POPINT();
3527 d1.lo = POPINT();
3528 i64Extend(d1);
3529 qr = m64SymmetricDivI(d1, n1);
3530 PUSHINT(qr.rem);
3531 return;
3532}
3533
3534
3535/**************************************************************************
3536 u m S l a s h M o d
3537** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3538** Divide ud by u1, giving the quotient u3 and the remainder u2.
3539** All values and arithmetic are unsigned. An ambiguous condition
3540** exists if u1 is zero or if the quotient lies outside the range of a
3541** single-cell unsigned integer.
3542*************************************************************************/
3543static void umSlashMod(FICL_VM *pVM)
3544{
3545 DPUNS ud;
3546 FICL_UNS u1;
3547 UNSQR qr;
3548
3549 u1 = stackPopUNS(pVM->pStack);
3550 ud = u64Pop(pVM->pStack);
3551 qr = ficlLongDiv(ud, u1);
3552 PUSHUNS(qr.rem);
3553 PUSHUNS(qr.quot);
3554 return;
3555}
3556
3557
3558/**************************************************************************
3559 l s h i f t
3560** l-shift CORE ( x1 u -- x2 )
3561** Perform a logical left shift of u bit-places on x1, giving x2.
3562** Put zeroes into the least significant bits vacated by the shift.
3563** An ambiguous condition exists if u is greater than or equal to the
3564** number of bits in a cell.
3565**
3566** r-shift CORE ( x1 u -- x2 )
3567** Perform a logical right shift of u bit-places on x1, giving x2.
3568** Put zeroes into the most significant bits vacated by the shift. An
3569** ambiguous condition exists if u is greater than or equal to the
3570** number of bits in a cell.
3571**************************************************************************/
3572static void lshift(FICL_VM *pVM)
3573{
3574 FICL_UNS nBits;
3575 FICL_UNS x1;
3576#if FICL_ROBUST > 1
3577 vmCheckStack(pVM,2,1);
3578#endif
3579
3580 nBits = POPUNS();
3581 x1 = POPUNS();
3582 PUSHUNS(x1 << nBits);
3583 return;
3584}
3585
3586
3587static void rshift(FICL_VM *pVM)
3588{
3589 FICL_UNS nBits;
3590 FICL_UNS x1;
3591#if FICL_ROBUST > 1
3592 vmCheckStack(pVM,2,1);
3593#endif
3594
3595 nBits = POPUNS();
3596 x1 = POPUNS();
3597
3598 PUSHUNS(x1 >> nBits);
3599 return;
3600}
3601
3602
3603/**************************************************************************
3604 m S t a r
3605** m-star CORE ( n1 n2 -- d )
3606** d is the signed product of n1 times n2.
3607**************************************************************************/
3608static void mStar(FICL_VM *pVM)
3609{
3610 FICL_INT n2;
3611 FICL_INT n1;
3612 DPINT d;
3613#if FICL_ROBUST > 1
3614 vmCheckStack(pVM,2,2);
3615#endif
3616
3617 n2 = POPINT();
3618 n1 = POPINT();
3619
3620 d = m64MulI(n1, n2);
3621 i64Push(pVM->pStack, d);
3622 return;
3623}
3624
3625
3626static void umStar(FICL_VM *pVM)
3627{
3628 FICL_UNS u2;
3629 FICL_UNS u1;
3630 DPUNS ud;
3631#if FICL_ROBUST > 1
3632 vmCheckStack(pVM,2,2);
3633#endif
3634
3635 u2 = POPUNS();
3636 u1 = POPUNS();
3637
3638 ud = ficlLongMul(u1, u2);
3639 u64Push(pVM->pStack, ud);
3640 return;
3641}
3642
3643
3644/**************************************************************************
3645 m a x & m i n
3646**
3647**************************************************************************/
3648static void ficlMax(FICL_VM *pVM)
3649{
3650 FICL_INT n2;
3651 FICL_INT n1;
3652#if FICL_ROBUST > 1
3653 vmCheckStack(pVM,2,1);
3654#endif
3655
3656 n2 = POPINT();
3657 n1 = POPINT();
3658
3659 PUSHINT((n1 > n2) ? n1 : n2);
3660 return;
3661}
3662
3663static void ficlMin(FICL_VM *pVM)
3664{
3665 FICL_INT n2;
3666 FICL_INT n1;
3667#if FICL_ROBUST > 1
3668 vmCheckStack(pVM,2,1);
3669#endif
3670
3671 n2 = POPINT();
3672 n1 = POPINT();
3673
3674 PUSHINT((n1 < n2) ? n1 : n2);
3675 return;
3676}
3677
3678
3679/**************************************************************************
3680 m o v e
3681** CORE ( addr1 addr2 u -- )
3682** If u is greater than zero, copy the contents of u consecutive address
3683** units at addr1 to the u consecutive address units at addr2. After MOVE
3684** completes, the u consecutive address units at addr2 contain exactly
3685** what the u consecutive address units at addr1 contained before the move.
3686** NOTE! This implementation assumes that a char is the same size as
3687** an address unit.
3688**************************************************************************/
3689static void move(FICL_VM *pVM)
3690{
3691 FICL_UNS u;
3692 char *addr2;
3693 char *addr1;
3694#if FICL_ROBUST > 1
3695 vmCheckStack(pVM,3,0);
3696#endif
3697
3698 u = POPUNS();
3699 addr2 = POPPTR();
3700 addr1 = POPPTR();
3701
3702 if (u == 0)
3703 return;
3704 /*
3705 ** Do the copy carefully, so as to be
3706 ** correct even if the two ranges overlap
3707 */
3708 if (addr1 >= addr2)
3709 {
3710 for (; u > 0; u--)
3711 *addr2++ = *addr1++;
3712 }
3713 else
3714 {
3715 addr2 += u-1;
3716 addr1 += u-1;
3717 for (; u > 0; u--)
3718 *addr2-- = *addr1--;
3719 }
3720
3721 return;
3722}
3723
3724
3725/**************************************************************************
3726 r e c u r s e
3727**
3728**************************************************************************/
3729static void recurseCoIm(FICL_VM *pVM)
3730{
3731 FICL_DICT *pDict = vmGetDict(pVM);
3732
3733 IGNORE(pVM);
3734 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3735 return;
3736}
3737
3738
3739/**************************************************************************
3740 s t o d
3741** s-to-d CORE ( n -- d )
3742** Convert the number n to the double-cell number d with the same
3743** numerical value.
3744**************************************************************************/
3745static void sToD(FICL_VM *pVM)
3746{
3747 FICL_INT s;
3748#if FICL_ROBUST > 1
3749 vmCheckStack(pVM,1,2);
3750#endif
3751
3752 s = POPINT();
3753
3754 /* sign extend to 64 bits.. */
3755 PUSHINT(s);
3756 PUSHINT((s < 0) ? -1 : 0);
3757 return;
3758}
3759
3760
3761/**************************************************************************
3762 s o u r c e
3763** CORE ( -- c-addr u )
3764** c-addr is the address of, and u is the number of characters in, the
3765** input buffer.
3766**************************************************************************/
3767static void source(FICL_VM *pVM)
3768{
3769#if FICL_ROBUST > 1
3770 vmCheckStack(pVM,0,2);
3771#endif
3772 PUSHPTR(pVM->tib.cp);
3773 PUSHINT(vmGetInBufLen(pVM));
3774 return;
3775}
3776
3777
3778/**************************************************************************
3779 v e r s i o n
3780** non-standard...
3781**************************************************************************/
3782static void ficlVersion(FICL_VM *pVM)
3783{
3784 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3785 return;
3786}
3787
3788
3789/**************************************************************************
3790 t o I n
3791** to-in CORE
3792**************************************************************************/
3793static void toIn(FICL_VM *pVM)
3794{
3795#if FICL_ROBUST > 1
3796 vmCheckStack(pVM,0,1);
3797#endif
3798 PUSHPTR(&pVM->tib.index);
3799 return;
3800}
3801
3802
3803/**************************************************************************
3804 c o l o n N o N a m e
3805** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3806** Create an unnamed colon definition and push its address.
3807** Change state to compile.
3808**************************************************************************/
3809static void colonNoName(FICL_VM *pVM)
3810{
3811 FICL_DICT *dp = vmGetDict(pVM);
3812 FICL_WORD *pFW;
3813 STRINGINFO si;
3814
3815 SI_SETLEN(si, 0);
3816 SI_SETPTR(si, NULL);
3817
3818 pVM->state = COMPILE;
3819 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3820 PUSHPTR(pFW);
3821 markControlTag(pVM, colonTag);
3822 return;
3823}
3824
3825
3826/**************************************************************************
3827 u s e r V a r i a b l e
3828** user ( u -- ) "<spaces>name"
3829** Get a name from the input stream and create a user variable
3830** with the name and the index supplied. The run-time effect
3831** of a user variable is to push the address of the indexed cell
3832** in the running vm's user array.
3833**
3834** User variables are vm local cells. Each vm has an array of
3835** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3836** Ficl's user facility is implemented with two primitives,
3837** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3838** holds the index of the next free user cell, and a redefinition
3839** (also in softcore) of "user" that defines a user word and increments
3840** nUser.
3841**************************************************************************/
3842#if FICL_WANT_USER
3843static void userParen(FICL_VM *pVM)
3844{
3845 FICL_INT i = pVM->runningWord->param[0].i;
3846 PUSHPTR(&pVM->user[i]);
3847 return;
3848}
3849
3850
3851static void userVariable(FICL_VM *pVM)
3852{
3853 FICL_DICT *dp = vmGetDict(pVM);
3854 STRINGINFO si = vmGetWord(pVM);
3855 CELL c;
3856
3857 c = stackPop(pVM->pStack);
3858 if (c.i >= FICL_USER_CELLS)
3859 {
3860 vmThrowErr(pVM, "Error - out of user space");
3861 }
3862
3863 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3864 dictAppendCell(dp, c);
3865 return;
3866}
3867#endif
3868
3869
3870/**************************************************************************
3871 t o V a l u e
3872** CORE EXT
3873** Interpretation: ( x "<spaces>name" -- )
3874** Skip leading spaces and parse name delimited by a space. Store x in
3875** name. An ambiguous condition exists if name was not defined by VALUE.
3876** NOTE: In ficl, VALUE is an alias of CONSTANT
3877**************************************************************************/
3878static void toValue(FICL_VM *pVM)
3879{
3880 STRINGINFO si = vmGetWord(pVM);
3881 FICL_DICT *dp = vmGetDict(pVM);
3882 FICL_WORD *pFW;
3883
3884#if FICL_WANT_LOCALS
3885 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
3886 {
3887 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
3888 pFW = dictLookup(pLoc, si);
3889 if (pFW && (pFW->code == doLocalIm))
3890 {
3891 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
3892 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3893 return;
3894 }
3895 else if (pFW && pFW->code == do2LocalIm)
3896 {
3897 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
3898 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3899 return;
3900 }
3901 }
3902#endif
3903
3904 assert(pVM->pSys->pStore);
3905
3906 pFW = dictLookup(dp, si);
3907 if (!pFW)
3908 {
3909 int i = SI_COUNT(si);
3910 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3911 }
3912
3913 if (pVM->state == INTERPRET)
3914 pFW->param[0] = stackPop(pVM->pStack);
3915 else /* compile code to store to word's param */
3916 {
3917 PUSHPTR(&pFW->param[0]);
3918 literalIm(pVM);
3919 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
3920 }
3921 return;
3922}
3923
3924
3925#if FICL_WANT_LOCALS
3926/**************************************************************************
3927 l i n k P a r e n
3928** ( -- )
3929** Link a frame on the return stack, reserving nCells of space for
3930** locals - the value of nCells is the next cell in the instruction
3931** stream.
3932**************************************************************************/
3933static void linkParen(FICL_VM *pVM)
3934{
3935 FICL_INT nLink = *(FICL_INT *)(pVM->ip);
3936 vmBranchRelative(pVM, 1);
3937 stackLink(pVM->rStack, nLink);
3938 return;
3939}
3940
3941
3942static void unlinkParen(FICL_VM *pVM)
3943{
3944 stackUnlink(pVM->rStack);
3945 return;
3946}
3947
3948
3949/**************************************************************************
3950 d o L o c a l I m
3951** Immediate - cfa of a local while compiling - when executed, compiles
3952** code to fetch the value of a local given the local's index in the
3953** word's pfa
3954**************************************************************************/
3955static void getLocalParen(FICL_VM *pVM)
3956{
3957 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3958 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3959 return;
3960}
3961
3962
3963static void toLocalParen(FICL_VM *pVM)
3964{
3965 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3966 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3967 return;
3968}
3969
3970
3971static void getLocal0(FICL_VM *pVM)
3972{
3973 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3974 return;
3975}
3976
3977
3978static void toLocal0(FICL_VM *pVM)
3979{
3980 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3981 return;
3982}
3983
3984
3985static void getLocal1(FICL_VM *pVM)
3986{
3987 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3988 return;
3989}
3990
3991
3992static void toLocal1(FICL_VM *pVM)
3993{
3994 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
3995 return;
3996}
3997
3998
3999/*
4000** Each local is recorded in a private locals dictionary as a
4001** word that does doLocalIm at runtime. DoLocalIm compiles code
4002** into the client definition to fetch the value of the
4003** corresponding local variable from the return stack.
4004** The private dictionary gets initialized at the end of each block
4005** that uses locals (in ; and does> for example).
4006*/
4007static void doLocalIm(FICL_VM *pVM)
4008{
4009 FICL_DICT *pDict = vmGetDict(pVM);
4010 FICL_INT nLocal = pVM->runningWord->param[0].i;
4011
4012 if (pVM->state == INTERPRET)
4013 {
4014 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4015 }
4016 else
4017 {
4018
4019 if (nLocal == 0)
4020 {
4021 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
4022 }
4023 else if (nLocal == 1)
4024 {
4025 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
4026 }
4027 else
4028 {
4029 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
4030 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4031 }
4032 }
4033 return;
4034}
4035
4036
4037/**************************************************************************
4038 l o c a l P a r e n
4039** paren-local-paren LOCAL
4040** Interpretation: Interpretation semantics for this word are undefined.
4041** Execution: ( c-addr u -- )
4042** When executed during compilation, (LOCAL) passes a message to the
4043** system that has one of two meanings. If u is non-zero,
4044** the message identifies a new local whose definition name is given by
4045** the string of characters identified by c-addr u. If u is zero,
4046** the message is last local and c-addr has no significance.
4047**
4048** The result of executing (LOCAL) during compilation of a definition is
4049** to create a set of named local identifiers, each of which is
4050** a definition name, that only have execution semantics within the scope
4051** of that definition's source.
4052**
4053** local Execution: ( -- x )
4054**
4055** Push the local's value, x, onto the stack. The local's value is
4056** initialized as described in 13.3.3 Processing locals and may be
4057** changed by preceding the local's name with TO. An ambiguous condition
4058** exists when local is executed while in interpretation state.
4059**************************************************************************/
4060static void localParen(FICL_VM *pVM)
4061{
4062 FICL_DICT *pDict;
4063 STRINGINFO si;
4064#if FICL_ROBUST > 1
4065 vmCheckStack(pVM,2,0);
4066#endif
4067
4068 pDict = vmGetDict(pVM);
4069 SI_SETLEN(si, POPUNS());
4070 SI_SETPTR(si, (char *)POPPTR());
4071
4072 if (SI_COUNT(si) > 0)
4073 { /* add a local to the **locals** dict and update nLocals */
4074 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4075 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4076 {
4077 vmThrowErr(pVM, "Error: out of local space");
4078 }
4079
4080 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4081 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4082
4083 if (pVM->pSys->nLocals == 0)
4084 { /* compile code to create a local stack frame */
4085 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4086 /* save location in dictionary for #locals */
4087 pVM->pSys->pMarkLocals = pDict->here;
4088 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4089 /* compile code to initialize first local */
4090 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
4091 }
4092 else if (pVM->pSys->nLocals == 1)
4093 {
4094 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
4095 }
4096 else
4097 {
4098 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4099 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4100 }
4101
4102 (pVM->pSys->nLocals)++;
4103 }
4104 else if (pVM->pSys->nLocals > 0)
4105 { /* write nLocals to (link) param area in dictionary */
4106 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4107 }
4108
4109 return;
4110}
4111
4112
4113static void get2LocalParen(FICL_VM *pVM)
4114{
4115 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4116 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4117 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4118 return;
4119}
4120
4121
4122static void do2LocalIm(FICL_VM *pVM)
4123{
4124 FICL_DICT *pDict = vmGetDict(pVM);
4125 FICL_INT nLocal = pVM->runningWord->param[0].i;
4126
4127 if (pVM->state == INTERPRET)
4128 {
4129 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4130 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4131 }
4132 else
4133 {
4134 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
4135 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4136 }
4137 return;
4138}
4139
4140
4141static void to2LocalParen(FICL_VM *pVM)
4142{
4143 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4144 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4145 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4146 return;
4147}
4148
4149
4150static void twoLocalParen(FICL_VM *pVM)
4151{
4152 FICL_DICT *pDict = vmGetDict(pVM);
4153 STRINGINFO si;
4154 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4155 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4156
4157 if (SI_COUNT(si) > 0)
4158 { /* add a local to the **locals** dict and update nLocals */
4159 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4160 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4161 {
4162 vmThrowErr(pVM, "Error: out of local space");
4163 }
4164
4165 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4166 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4167
4168 if (pVM->pSys->nLocals == 0)
4169 { /* compile code to create a local stack frame */
4170 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4171 /* save location in dictionary for #locals */
4172 pVM->pSys->pMarkLocals = pDict->here;
4173 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4174 }
4175
4176 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4177 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4178
4179 pVM->pSys->nLocals += 2;
4180 }
4181 else if (pVM->pSys->nLocals > 0)
4182 { /* write nLocals to (link) param area in dictionary */
4183 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4184 }
4185
4186 return;
4187}
4188
4189
4190#endif
4191/**************************************************************************
4192 c o m p a r e
4193** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4194** Compare the string specified by c-addr1 u1 to the string specified by
4195** c-addr2 u2. The strings are compared, beginning at the given addresses,
4196** character by character, up to the length of the shorter string or until a
4197** difference is found. If the two strings are identical, n is zero. If the two
4198** strings are identical up to the length of the shorter string, n is minus-one
4199** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4200** identical up to the length of the shorter string, n is minus-one (-1) if the
4201** first non-matching character in the string specified by c-addr1 u1 has a
4202** lesser numeric value than the corresponding character in the string specified
4203** by c-addr2 u2 and one (1) otherwise.
4204**************************************************************************/
4205static void compareInternal(FICL_VM *pVM, int caseInsensitive)
4206{
4207 char *cp1, *cp2;
4208 FICL_UNS u1, u2, uMin;
4209 int n = 0;
4210
4211 vmCheckStack(pVM, 4, 1);
4212 u2 = stackPopUNS(pVM->pStack);
4213 cp2 = (char *)stackPopPtr(pVM->pStack);
4214 u1 = stackPopUNS(pVM->pStack);
4215 cp1 = (char *)stackPopPtr(pVM->pStack);
4216
4217 uMin = (u1 < u2)? u1 : u2;
4218 for ( ; (uMin > 0) && (n == 0); uMin--)
4219 {
4220 char c1 = *cp1++;
4221 char c2 = *cp2++;
4222 if (caseInsensitive)
4223 {
4224 c1 = (char)tolower(c1);
4225 c2 = (char)tolower(c2);
4226 }
4227 n = (int)(c1 - c2);
4228 }
4229
4230 if (n == 0)
4231 n = (int)(u1 - u2);
4232
4233 if (n < 0)
4234 n = -1;
4235 else if (n > 0)
4236 n = 1;
4237
4238 PUSHINT(n);
4239 return;
4240}
4241
4242
4243static void compareString(FICL_VM *pVM)
4244{
4245 compareInternal(pVM, FALSE);
4246}
4247
4248
4249static void compareStringInsensitive(FICL_VM *pVM)
4250{
4251 compareInternal(pVM, TRUE);
4252}
4253
4254
4255/**************************************************************************
4256 p a d
4257** CORE EXT ( -- c-addr )
4258** c-addr is the address of a transient region that can be used to hold
4259** data for intermediate processing.
4260**************************************************************************/
4261static void pad(FICL_VM *pVM)
4262{
4263 stackPushPtr(pVM->pStack, pVM->pad);
4264}
4265
4266
4267/**************************************************************************
4268 s o u r c e - i d
4269** CORE EXT, FILE ( -- 0 | -1 | fileid )
4270** Identifies the input source as follows:
4271**
4272** SOURCE-ID Input source
4273** --------- ------------
4274** fileid Text file fileid
4275** -1 String (via EVALUATE)
4276** 0 User input device
4277**************************************************************************/
4278static void sourceid(FICL_VM *pVM)
4279{
4280 PUSHINT(pVM->sourceID.i);
4281 return;
4282}
4283
4284
4285/**************************************************************************
4286 r e f i l l
4287** CORE EXT ( -- flag )
4288** Attempt to fill the input buffer from the input source, returning a true
4289** flag if successful.
4290** When the input source is the user input device, attempt to receive input
4291** into the terminal input buffer. If successful, make the result the input
4292** buffer, set >IN to zero, and return true. Receipt of a line containing no
4293** characters is considered successful. If there is no input available from
4294** the current input source, return false.
4295** When the input source is a string from EVALUATE, return false and
4296** perform no other action.
4297**************************************************************************/
4298static void refill(FICL_VM *pVM)
4299{
4300 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4301 if (ret && (pVM->fRestart == 0))
4302 vmThrow(pVM, VM_RESTART);
4303
4304 PUSHINT(ret);
4305 return;
4306}
4307
4308
4309/**************************************************************************
4310 freebsd exception handling words
4311** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4312** the word in ToS. If an exception happens, restore the state to what
4313** it was before, and pushes the exception value on the stack. If not,
4314** push zero.
4315**
4316** Notice that Catch implements an inner interpreter. This is ugly,
4317** but given how ficl works, it cannot be helped. The problem is that
4318** colon definitions will be executed *after* the function returns,
4319** while "code" definitions will be executed immediately. I considered
4320** other solutions to this problem, but all of them shared the same
4321** basic problem (with added disadvantages): if ficl ever changes it's
4322** inner thread modus operandi, one would have to fix this word.
4323**
4324** More comments can be found throughout catch's code.
4325**
4326** Daniel C. Sobral Jan 09/1999
4327** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4328**************************************************************************/
4329
4330static void ficlCatch(FICL_VM *pVM)
4331{
4332 int except;
4333 jmp_buf vmState;
4334 FICL_VM VM;
4335 FICL_STACK pStack;
4336 FICL_STACK rStack;
4337 FICL_WORD *pFW;
4338
4339 assert(pVM);
4340 assert(pVM->pSys->pExitInner);
4341
4342
4343 /*
4344 ** Get xt.
4345 ** We need this *before* we save the stack pointer, or
4346 ** we'll have to pop one element out of the stack after
4347 ** an exception. I prefer to get done with it up front. :-)
4348 */
4349#if FICL_ROBUST > 1
4350 vmCheckStack(pVM, 1, 0);
4351#endif
4352 pFW = stackPopPtr(pVM->pStack);
4353
4354 /*
4355 ** Save vm's state -- a catch will not back out environmental
4356 ** changes.
4357 **
4358 ** We are *not* saving dictionary state, since it is
4359 ** global instead of per vm, and we are not saving
4360 ** stack contents, since we are not required to (and,
4361 ** thus, it would be useless). We save pVM, and pVM
4362 ** "stacks" (a structure containing general information
4363 ** about it, including the current stack pointer).
4364 */
4365 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4366 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4367 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4368
4369 /*
4370 ** Give pVM a jmp_buf
4371 */
4372 pVM->pState = &vmState;
4373
4374 /*
4375 ** Safety net
4376 */
4377 except = setjmp(vmState);
4378
4379 switch (except)
4380 {
4381 /*
4382 ** Setup condition - push poison pill so that the VM throws
4383 ** VM_INNEREXIT if the XT terminates normally, then execute
4384 ** the XT
4385 */
4386 case 0:
4387 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4388 vmExecute(pVM, pFW);
4389 vmInnerLoop(pVM);
4390 break;
4391
4392 /*
4393 ** Normal exit from XT - lose the poison pill,
4394 ** restore old setjmp vector and push a zero.
4395 */
4396 case VM_INNEREXIT:
4397 vmPopIP(pVM); /* Gack - hurl poison pill */
4398 pVM->pState = VM.pState; /* Restore just the setjmp vector */
4399 PUSHINT(0); /* Push 0 -- everything is ok */
4400 break;
4401
4402 /*
4403 ** Some other exception got thrown - restore pre-existing VM state
4404 ** and push the exception code
4405 */
4406 default:
4407 /* Restore vm's state */
4408 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4409 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4410 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4411
4412 PUSHINT(except);/* Push error */
4413 break;
4414 }
4415}
4416
4417/**************************************************************************
4418** t h r o w
4419** EXCEPTION
4420** Throw -- From ANS Forth standard.
4421**
4422** Throw takes the ToS and, if that's different from zero,
4423** returns to the last executed catch context. Further throws will
4424** unstack previously executed "catches", in LIFO mode.
4425**
4426** Daniel C. Sobral Jan 09/1999
4427**************************************************************************/
4428static void ficlThrow(FICL_VM *pVM)
4429{
4430 int except;
4431
4432 except = stackPopINT(pVM->pStack);
4433
4434 if (except)
4435 vmThrow(pVM, except);
4436}
4437
4438
4439/**************************************************************************
4440** a l l o c a t e
4441** MEMORY
4442**************************************************************************/
4443static void ansAllocate(FICL_VM *pVM)
4444{
4445 size_t size;
4446 void *p;
4447
4448 size = stackPopINT(pVM->pStack);
4449 p = ficlMalloc(size);
4450 PUSHPTR(p);
4451 if (p)
4452 PUSHINT(0);
4453 else
4454 PUSHINT(1);
4455}
4456
4457
4458/**************************************************************************
4459** f r e e
4460** MEMORY
4461**************************************************************************/
4462static void ansFree(FICL_VM *pVM)
4463{
4464 void *p;
4465
4466 p = stackPopPtr(pVM->pStack);
4467 ficlFree(p);
4468 PUSHINT(0);
4469}
4470
4471
4472/**************************************************************************
4473** r e s i z e
4474** MEMORY
4475**************************************************************************/
4476static void ansResize(FICL_VM *pVM)
4477{
4478 size_t size;
4479 void *new, *old;
4480
4481 size = stackPopINT(pVM->pStack);
4482 old = stackPopPtr(pVM->pStack);
4483 new = ficlRealloc(old, size);
4484 if (new)
4485 {
4486 PUSHPTR(new);
4487 PUSHINT(0);
4488 }
4489 else
4490 {
4491 PUSHPTR(old);
4492 PUSHINT(1);
4493 }
4494}
4495
4496
4497/**************************************************************************
4498** e x i t - i n n e r
4499** Signals execXT that an inner loop has completed
4500**************************************************************************/
4501static void ficlExitInner(FICL_VM *pVM)
4502{
4503 vmThrow(pVM, VM_INNEREXIT);
4504}
4505
4506
4507/**************************************************************************
4508 d n e g a t e
4509** DOUBLE ( d1 -- d2 )
4510** d2 is the negation of d1.
4511**************************************************************************/
4512static void dnegate(FICL_VM *pVM)
4513{
4514 DPINT i = i64Pop(pVM->pStack);
4515 i = m64Negate(i);
4516 i64Push(pVM->pStack, i);
4517
4518 return;
4519}
4520
4521
4522#if 0
4523/**************************************************************************
4524
4525**
4526**************************************************************************/
4527static void funcname(FICL_VM *pVM)
4528{
4529 IGNORE(pVM);
4530 return;
4531}
4532
4533
4534#endif
4535/**************************************************************************
4536 f i c l W o r d C l a s s i f y
4537** This public function helps to classify word types for SEE
4538** and the deugger in tools.c. Given an pointer to a word, it returns
4539** a member of WOR
4540**************************************************************************/
4541WORDKIND ficlWordClassify(FICL_WORD *pFW)
4542{
4543 typedef struct
4544 {
4545 WORDKIND kind;
4546 FICL_CODE code;
4547 } CODEtoKIND;
4548
4549 static CODEtoKIND codeMap[] =
4550 {
4551 {BRANCH, branchParen},
4552 {COLON, colonParen},
4553 {CONSTANT, constantParen},
4554 {CREATE, createParen},
4555 {DO, doParen},
4556 {DOES, doDoes},
4557 {IF, ifParen},
4558 {LITERAL, literalParen},
4559 {LOOP, loopParen},
4560 {PLOOP, plusLoopParen},
4561 {QDO, qDoParen},
4562 {CSTRINGLIT, cstringLit},
4563 {STRINGLIT, stringLit},
4564#if FICL_WANT_USER
4565 {USER, userParen},
4566#endif
4567 {VARIABLE, variableParen},
4568 };
4569
4570#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4571
4572 FICL_CODE code = pFW->code;
4573 int i;
4574
4575 for (i=0; i < nMAP; i++)
4576 {
4577 if (codeMap[i].code == code)
4578 return codeMap[i].kind;
4579 }
4580
4581 return PRIMITIVE;
4582}
4583
4584
4585/**************************************************************************
4586 f i c l C o m p i l e C o r e
4587** Builds the primitive wordset and the environment-query namespace.
4588**************************************************************************/
4589
4590void ficlCompileCore(FICL_SYSTEM *pSys)
4591{
4592 FICL_DICT *dp = pSys->dp;
4593 assert (dp);
4594
4595
4596 /*
4597 ** CORE word set
4598 ** see softcore.c for definitions of: abs bl space spaces abort"
4599 */
4600 pSys->pStore =
4601 dictAppendWord(dp, "!", store, FW_DEFAULT);
4602 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4603 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4604 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4605 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4606 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4607 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4608 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4609 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4610 dictAppendWord(dp, "+", add, FW_DEFAULT);
4611 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4612 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4613 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4614 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4615 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4616 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4617 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4618 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4619 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4620 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4621 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4622 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4623 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4624 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4625 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4626 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4627 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4628 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4629 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4630 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4631 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4632 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4633 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4634 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4635 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4636 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4637 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4638 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4639 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4640 dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
4641 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4642 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4643 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4644 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4645 dictAppendWord(dp, "align", align, FW_DEFAULT);
4646 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4647 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4648 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4649 dictAppendWord(dp, "base", base, FW_DEFAULT);
4650 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4651 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4652 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4653 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4654 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4655 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4656 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4657 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4658 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4659 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4660 dictAppendWord(dp, "count", count, FW_DEFAULT);
4661 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4662 dictAppendWord(dp, "create", create, FW_DEFAULT);
4663 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4664 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4665 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4666 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4667 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4668 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4669 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4670 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4671 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4672 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4673 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4674 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4675 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4676 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4677 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4678 dictAppendWord(dp, "here", here, FW_DEFAULT);
4679 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4680 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4681 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4682 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4683 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4684 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4685 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4686 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4687 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4688 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4689 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4690 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4691 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4692 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4693 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4694 dictAppendWord(dp, "move", move, FW_DEFAULT);
4695 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4696 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4697 dictAppendWord(dp, "over", over, FW_DEFAULT);
4698 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4699 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4700 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
4701 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
4702 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4703 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4704 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4705 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4706 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4707 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4708 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4709 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4710 dictAppendWord(dp, "source", source, FW_DEFAULT);
4711 dictAppendWord(dp, "state", state, FW_DEFAULT);
4712 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4713 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4714 dictAppendWord(dp, "type", type, FW_DEFAULT);
4715 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4716 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4717 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4718 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4719 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4720 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4721 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4722 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4723 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4724 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4725 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4726 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4727 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4728 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4729 /*
4730 ** CORE EXT word set...
4731 ** see softcore.fr for other definitions
4732 */
4733 /* "#tib" */
4734 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
4735 /* ".r" */
4736 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4737 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4738 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
4739 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
4740 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4741 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4742 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
4743 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
4744 /* case of endof endcase */
4745 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4746 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
4747 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4748 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4749 /* query restore-input save-input tib u.r u> unused [compile] */
4750 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4751 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4752 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
4753 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4754 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4755 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4756
4757
4758 /*
4759 ** Set CORE environment query values
4760 */
4761 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
4762 ficlSetEnv(pSys, "/hold", nPAD);
4763 ficlSetEnv(pSys, "/pad", nPAD);
4764 ficlSetEnv(pSys, "address-unit-bits", 8);
4765 ficlSetEnv(pSys, "core", FICL_TRUE);
4766 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
4767 ficlSetEnv(pSys, "floored", FICL_FALSE);
4768 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
4769 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
4770 ficlSetEnv(pSys, "max-n", 0x7fffffff);
4771 ficlSetEnv(pSys, "max-u", 0xffffffff);
4772 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
4773 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
4774 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
4775
4776 /*
4777 ** DOUBLE word set (partial)
4778 */
4779 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
4780 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
4781 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
4782 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
4783
4784
4785 /*
4786 ** EXCEPTION word set
4787 */
4788 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
4789 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
4790
4791 ficlSetEnv(pSys, "exception", FICL_TRUE);
4792 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
4793
4794 /*
4795 ** LOCAL and LOCAL EXT
4796 ** see softcore.c for implementation of locals|
4797 */
4798#if FICL_WANT_LOCALS
4799 pSys->pLinkParen =
4800 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4801 pSys->pUnLinkParen =
4802 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4803 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4804 pSys->pGetLocalParen =
4805 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4806 pSys->pToLocalParen =
4807 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4808 pSys->pGetLocal0 =
4809 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4810 pSys->pToLocal0 =
4811 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4812 pSys->pGetLocal1 =
4813 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4814 pSys->pToLocal1 =
4815 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4816 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4817
4818 pSys->pGet2LocalParen =
4819 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4820 pSys->pTo2LocalParen =
4821 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
4822 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
4823
4824 ficlSetEnv(pSys, "locals", FICL_TRUE);
4825 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
4826 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
4827#endif
4828
4829 /*
4830 ** Optional MEMORY-ALLOC word set
4831 */
4832
4833 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
4834 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
4835 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
4836
4837 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
4838
4839 /*
4840 ** optional SEARCH-ORDER word set
4841 */
4842 ficlCompileSearch(pSys);
4843
4844 /*
4845 ** TOOLS and TOOLS EXT
4846 */
4847 ficlCompileTools(pSys);
4848
4849 /*
4850 ** FILE and FILE EXT
4851 */
4852#if FICL_WANT_FILE
4853 ficlCompileFile(pSys);
4854#endif
4855
4856 /*
4857 ** Ficl extras
4858 */
4859#if FICL_WANT_FLOAT
4860 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4861#endif
4862 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4863 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4864 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4865 dictAppendWord(dp, "add-parse-step",
4866 addParseStep, FW_DEFAULT);
4867 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4868 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4869 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
4870 dictAppendWord(dp, "compile-only",
4871 compileOnly, FW_DEFAULT);
4872 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4873 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
4874 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
4875 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
4876 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
4877 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4878 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
4879 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4880 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
4881 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
4882 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
4883 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
4884 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4885 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4886 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4887#if FICL_WANT_USER
4888 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4889 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4890#endif
4891
4892 /*
4893 ** internal support words
4894 */
4895 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
4896 pSys->pExitParen =
4897 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4898 pSys->pSemiParen =
4899 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4900 pSys->pLitParen =
4901 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4902 pSys->pTwoLitParen =
4903 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
4904 pSys->pStringLit =
4905 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4906 pSys->pCStringLit =
4907 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
4908 pSys->pIfParen =
4909 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4910 pSys->pBranchParen =
4911 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4912 pSys->pDoParen =
4913 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4914 pSys->pDoesParen =
4915 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4916 pSys->pQDoParen =
4917 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4918 pSys->pLoopParen =
4919 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4920 pSys->pPLoopParen =
4921 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4922 pSys->pInterpret =
4923 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4924 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
4925 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4926 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4927 dictAppendWord(dp, "(parse-step)",
4928 parseStepParen, FW_DEFAULT);
4929 pSys->pExitInner =
4930 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
4931
4932 /*
4933 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
4934 */
4935 pSys->pInterp[0] = pSys->pInterpret;
4936 pSys->pInterp[1] = pSys->pBranchParen;
4937 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
4938
4939 assert(dictCellsAvail(dp) > 0);
4940
4941 return;
4942}
4943
| 1961 }
1962
1963 return;
1964}
1965
1966
1967static void loopICo(FICL_VM *pVM)
1968{
1969 CELL index = stackGetTop(pVM->rStack);
1970 stackPush(pVM->pStack, index);
1971
1972 return;
1973}
1974
1975
1976static void loopJCo(FICL_VM *pVM)
1977{
1978 CELL index = stackFetch(pVM->rStack, 3);
1979 stackPush(pVM->pStack, index);
1980
1981 return;
1982}
1983
1984
1985static void loopKCo(FICL_VM *pVM)
1986{
1987 CELL index = stackFetch(pVM->rStack, 6);
1988 stackPush(pVM->pStack, index);
1989
1990 return;
1991}
1992
1993
1994/**************************************************************************
1995 r e t u r n s t a c k
1996**
1997**************************************************************************/
1998static void toRStack(FICL_VM *pVM)
1999{
2000#if FICL_ROBUST > 1
2001 vmCheckStack(pVM, 1, 0);
2002#endif
2003
2004 stackPush(pVM->rStack, POP());
2005}
2006
2007static void fromRStack(FICL_VM *pVM)
2008{
2009#if FICL_ROBUST > 1
2010 vmCheckStack(pVM, 0, 1);
2011#endif
2012
2013 PUSH(stackPop(pVM->rStack));
2014}
2015
2016static void fetchRStack(FICL_VM *pVM)
2017{
2018#if FICL_ROBUST > 1
2019 vmCheckStack(pVM, 0, 1);
2020#endif
2021
2022 PUSH(stackGetTop(pVM->rStack));
2023}
2024
2025static void twoToR(FICL_VM *pVM)
2026{
2027#if FICL_ROBUST > 1
2028 vmCheckStack(pVM, 2, 0);
2029#endif
2030 stackRoll(pVM->pStack, 1);
2031 stackPush(pVM->rStack, stackPop(pVM->pStack));
2032 stackPush(pVM->rStack, stackPop(pVM->pStack));
2033 return;
2034}
2035
2036static void twoRFrom(FICL_VM *pVM)
2037{
2038#if FICL_ROBUST > 1
2039 vmCheckStack(pVM, 0, 2);
2040#endif
2041 stackPush(pVM->pStack, stackPop(pVM->rStack));
2042 stackPush(pVM->pStack, stackPop(pVM->rStack));
2043 stackRoll(pVM->pStack, 1);
2044 return;
2045}
2046
2047static void twoRFetch(FICL_VM *pVM)
2048{
2049#if FICL_ROBUST > 1
2050 vmCheckStack(pVM, 0, 2);
2051#endif
2052 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2053 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2054 return;
2055}
2056
2057
2058/**************************************************************************
2059 v a r i a b l e
2060**
2061**************************************************************************/
2062
2063static void variableParen(FICL_VM *pVM)
2064{
2065 FICL_WORD *fw;
2066#if FICL_ROBUST > 1
2067 vmCheckStack(pVM, 0, 1);
2068#endif
2069
2070 fw = pVM->runningWord;
2071 PUSHPTR(fw->param);
2072}
2073
2074
2075static void variable(FICL_VM *pVM)
2076{
2077 FICL_DICT *dp = vmGetDict(pVM);
2078 STRINGINFO si = vmGetWord(pVM);
2079
2080 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2081 dictAllotCells(dp, 1);
2082 return;
2083}
2084
2085
2086static void twoVariable(FICL_VM *pVM)
2087{
2088 FICL_DICT *dp = vmGetDict(pVM);
2089 STRINGINFO si = vmGetWord(pVM);
2090
2091 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2092 dictAllotCells(dp, 2);
2093 return;
2094}
2095
2096
2097/**************************************************************************
2098 b a s e & f r i e n d s
2099**
2100**************************************************************************/
2101
2102static void base(FICL_VM *pVM)
2103{
2104 CELL *pBase;
2105#if FICL_ROBUST > 1
2106 vmCheckStack(pVM, 0, 1);
2107#endif
2108
2109 pBase = (CELL *)(&pVM->base);
2110 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2111 return;
2112}
2113
2114
2115static void decimal(FICL_VM *pVM)
2116{
2117 pVM->base = 10;
2118 return;
2119}
2120
2121
2122static void hex(FICL_VM *pVM)
2123{
2124 pVM->base = 16;
2125 return;
2126}
2127
2128
2129/**************************************************************************
2130 a l l o t & f r i e n d s
2131**
2132**************************************************************************/
2133
2134static void allot(FICL_VM *pVM)
2135{
2136 FICL_DICT *dp;
2137 FICL_INT i;
2138#if FICL_ROBUST > 1
2139 vmCheckStack(pVM, 1, 0);
2140#endif
2141
2142 dp = vmGetDict(pVM);
2143 i = POPINT();
2144
2145#if FICL_ROBUST
2146 dictCheck(dp, pVM, i);
2147#endif
2148
2149 dictAllot(dp, i);
2150 return;
2151}
2152
2153
2154static void here(FICL_VM *pVM)
2155{
2156 FICL_DICT *dp;
2157#if FICL_ROBUST > 1
2158 vmCheckStack(pVM, 0, 1);
2159#endif
2160
2161 dp = vmGetDict(pVM);
2162 PUSHPTR(dp->here);
2163 return;
2164}
2165
2166static void comma(FICL_VM *pVM)
2167{
2168 FICL_DICT *dp;
2169 CELL c;
2170#if FICL_ROBUST > 1
2171 vmCheckStack(pVM, 1, 0);
2172#endif
2173
2174 dp = vmGetDict(pVM);
2175 c = POP();
2176 dictAppendCell(dp, c);
2177 return;
2178}
2179
2180static void cComma(FICL_VM *pVM)
2181{
2182 FICL_DICT *dp;
2183 char c;
2184#if FICL_ROBUST > 1
2185 vmCheckStack(pVM, 1, 0);
2186#endif
2187
2188 dp = vmGetDict(pVM);
2189 c = (char)POPINT();
2190 dictAppendChar(dp, c);
2191 return;
2192}
2193
2194static void cells(FICL_VM *pVM)
2195{
2196 FICL_INT i;
2197#if FICL_ROBUST > 1
2198 vmCheckStack(pVM, 1, 1);
2199#endif
2200
2201 i = POPINT();
2202 PUSHINT(i * (FICL_INT)sizeof (CELL));
2203 return;
2204}
2205
2206static void cellPlus(FICL_VM *pVM)
2207{
2208 char *cp;
2209#if FICL_ROBUST > 1
2210 vmCheckStack(pVM, 1, 1);
2211#endif
2212
2213 cp = POPPTR();
2214 PUSHPTR(cp + sizeof (CELL));
2215 return;
2216}
2217
2218
2219
2220/**************************************************************************
2221 t i c k
2222** tick CORE ( "<spaces>name" -- xt )
2223** Skip leading space delimiters. Parse name delimited by a space. Find
2224** name and return xt, the execution token for name. An ambiguous condition
2225** exists if name is not found.
2226**************************************************************************/
2227void ficlTick(FICL_VM *pVM)
2228{
2229 FICL_WORD *pFW = NULL;
2230 STRINGINFO si = vmGetWord(pVM);
2231#if FICL_ROBUST > 1
2232 vmCheckStack(pVM, 0, 1);
2233#endif
2234
2235 pFW = dictLookup(vmGetDict(pVM), si);
2236 if (!pFW)
2237 {
2238 int i = SI_COUNT(si);
2239 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2240 }
2241 PUSHPTR(pFW);
2242 return;
2243}
2244
2245
2246static void bracketTickCoIm(FICL_VM *pVM)
2247{
2248 ficlTick(pVM);
2249 literalIm(pVM);
2250
2251 return;
2252}
2253
2254
2255/**************************************************************************
2256 p o s t p o n e
2257** Lookup the next word in the input stream and compile code to
2258** insert it into definitions created by the resulting word
2259** (defers compilation, even of immediate words)
2260**************************************************************************/
2261
2262static void postponeCoIm(FICL_VM *pVM)
2263{
2264 FICL_DICT *dp = vmGetDict(pVM);
2265 FICL_WORD *pFW;
2266 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2267 assert(pComma);
2268
2269 ficlTick(pVM);
2270 pFW = stackGetTop(pVM->pStack).p;
2271 if (wordIsImmediate(pFW))
2272 {
2273 dictAppendCell(dp, stackPop(pVM->pStack));
2274 }
2275 else
2276 {
2277 literalIm(pVM);
2278 dictAppendCell(dp, LVALUEtoCELL(pComma));
2279 }
2280
2281 return;
2282}
2283
2284
2285
2286/**************************************************************************
2287 e x e c u t e
2288** Pop an execution token (pointer to a word) off the stack and
2289** run it
2290**************************************************************************/
2291
2292static void execute(FICL_VM *pVM)
2293{
2294 FICL_WORD *pFW;
2295#if FICL_ROBUST > 1
2296 vmCheckStack(pVM, 1, 0);
2297#endif
2298
2299 pFW = stackPopPtr(pVM->pStack);
2300 vmExecute(pVM, pFW);
2301
2302 return;
2303}
2304
2305
2306/**************************************************************************
2307 i m m e d i a t e
2308** Make the most recently compiled word IMMEDIATE -- it executes even
2309** in compile state (most often used for control compiling words
2310** such as IF, THEN, etc)
2311**************************************************************************/
2312
2313static void immediate(FICL_VM *pVM)
2314{
2315 IGNORE(pVM);
2316 dictSetImmediate(vmGetDict(pVM));
2317 return;
2318}
2319
2320
2321static void compileOnly(FICL_VM *pVM)
2322{
2323 IGNORE(pVM);
2324 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2325 return;
2326}
2327
2328
2329static void setObjectFlag(FICL_VM *pVM)
2330{
2331 IGNORE(pVM);
2332 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2333 return;
2334}
2335
2336static void isObject(FICL_VM *pVM)
2337{
2338 int flag;
2339 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2340
2341 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2342 stackPushINT(pVM->pStack, flag);
2343 return;
2344}
2345
2346static void cstringLit(FICL_VM *pVM)
2347{
2348 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2349
2350 char *cp = sp->text;
2351 cp += sp->count + 1;
2352 cp = alignPtr(cp);
2353 pVM->ip = (IPTYPE)(void *)cp;
2354
2355 stackPushPtr(pVM->pStack, sp);
2356 return;
2357}
2358
2359
2360static void cstringQuoteIm(FICL_VM *pVM)
2361{
2362 FICL_DICT *dp = vmGetDict(pVM);
2363
2364 if (pVM->state == INTERPRET)
2365 {
2366 FICL_STRING *sp = (FICL_STRING *) dp->here;
2367 vmGetString(pVM, sp, '\"');
2368 stackPushPtr(pVM->pStack, sp);
2369 /* move HERE past string so it doesn't get overwritten. --lch */
2370 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2371 }
2372 else /* COMPILE state */
2373 {
2374 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2375 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2376 dictAlign(dp);
2377 }
2378
2379 return;
2380}
2381
2382/**************************************************************************
2383 d o t Q u o t e
2384** IMMEDIATE word that compiles a string literal for later display
2385** Compile stringLit, then copy the bytes of the string from the TIB
2386** to the dictionary. Backpatch the count byte and align the dictionary.
2387**
2388** stringlit: Fetch the count from the dictionary, then push the address
2389** and count on the stack. Finally, update ip to point to the first
2390** aligned address after the string text.
2391**************************************************************************/
2392
2393static void stringLit(FICL_VM *pVM)
2394{
2395 FICL_STRING *sp;
2396 FICL_COUNT count;
2397 char *cp;
2398#if FICL_ROBUST > 1
2399 vmCheckStack(pVM, 0, 2);
2400#endif
2401
2402 sp = (FICL_STRING *)(pVM->ip);
2403 count = sp->count;
2404 cp = sp->text;
2405 PUSHPTR(cp);
2406 PUSHUNS(count);
2407 cp += count + 1;
2408 cp = alignPtr(cp);
2409 pVM->ip = (IPTYPE)(void *)cp;
2410}
2411
2412static void dotQuoteCoIm(FICL_VM *pVM)
2413{
2414 FICL_DICT *dp = vmGetDict(pVM);
2415 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2416 assert(pType);
2417 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2418 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2419 dictAlign(dp);
2420 dictAppendCell(dp, LVALUEtoCELL(pType));
2421 return;
2422}
2423
2424
2425static void dotParen(FICL_VM *pVM)
2426{
2427 char *pSrc = vmGetInBuf(pVM);
2428 char *pEnd = vmGetInBufEnd(pVM);
2429 char *pDest = pVM->pad;
2430 char ch;
2431
2432 /*
2433 ** Note: the standard does not want leading spaces skipped (apparently)
2434 */
2435 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2436 *pDest++ = ch;
2437
2438 *pDest = '\0';
2439 if ((pEnd != pSrc) && (ch == ')'))
2440 pSrc++;
2441
2442 vmTextOut(pVM, pVM->pad, 0);
2443 vmUpdateTib(pVM, pSrc);
2444
2445 return;
2446}
2447
2448
2449/**************************************************************************
2450 s l i t e r a l
2451** STRING
2452** Interpretation: Interpretation semantics for this word are undefined.
2453** Compilation: ( c-addr1 u -- )
2454** Append the run-time semantics given below to the current definition.
2455** Run-time: ( -- c-addr2 u )
2456** Return c-addr2 u describing a string consisting of the characters
2457** specified by c-addr1 u during compilation. A program shall not alter
2458** the returned string.
2459**************************************************************************/
2460static void sLiteralCoIm(FICL_VM *pVM)
2461{
2462 FICL_DICT *dp;
2463 char *cp, *cpDest;
2464 FICL_UNS u;
2465
2466#if FICL_ROBUST > 1
2467 vmCheckStack(pVM, 2, 0);
2468#endif
2469
2470 dp = vmGetDict(pVM);
2471 u = POPUNS();
2472 cp = POPPTR();
2473
2474 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2475 cpDest = (char *) dp->here;
2476 *cpDest++ = (char) u;
2477
2478 for (; u > 0; --u)
2479 {
2480 *cpDest++ = *cp++;
2481 }
2482
2483 *cpDest++ = 0;
2484 dp->here = PTRtoCELL alignPtr(cpDest);
2485 return;
2486}
2487
2488
2489/**************************************************************************
2490 s t a t e
2491** Return the address of the VM's state member (must be sized the
2492** same as a CELL for this reason)
2493**************************************************************************/
2494static void state(FICL_VM *pVM)
2495{
2496#if FICL_ROBUST > 1
2497 vmCheckStack(pVM, 0, 1);
2498#endif
2499 PUSHPTR(&pVM->state);
2500 return;
2501}
2502
2503
2504/**************************************************************************
2505 c r e a t e . . . d o e s >
2506** Make a new word in the dictionary with the run-time effect of
2507** a variable (push my address), but with extra space allotted
2508** for use by does> .
2509**************************************************************************/
2510
2511static void createParen(FICL_VM *pVM)
2512{
2513 CELL *pCell;
2514
2515#if FICL_ROBUST > 1
2516 vmCheckStack(pVM, 0, 1);
2517#endif
2518
2519 pCell = pVM->runningWord->param;
2520 PUSHPTR(pCell+1);
2521 return;
2522}
2523
2524
2525static void create(FICL_VM *pVM)
2526{
2527 FICL_DICT *dp = vmGetDict(pVM);
2528 STRINGINFO si = vmGetWord(pVM);
2529
2530 dictCheckThreshold(dp);
2531
2532 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2533 dictAllotCells(dp, 1);
2534 return;
2535}
2536
2537
2538static void doDoes(FICL_VM *pVM)
2539{
2540 CELL *pCell;
2541 IPTYPE tempIP;
2542#if FICL_ROBUST > 1
2543 vmCheckStack(pVM, 0, 1);
2544#endif
2545
2546 pCell = pVM->runningWord->param;
2547 tempIP = (IPTYPE)((*pCell).p);
2548 PUSHPTR(pCell+1);
2549 vmPushIP(pVM, tempIP);
2550 return;
2551}
2552
2553
2554static void doesParen(FICL_VM *pVM)
2555{
2556 FICL_DICT *dp = vmGetDict(pVM);
2557 dp->smudge->code = doDoes;
2558 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2559 vmPopIP(pVM);
2560 return;
2561}
2562
2563
2564static void doesCoIm(FICL_VM *pVM)
2565{
2566 FICL_DICT *dp = vmGetDict(pVM);
2567#if FICL_WANT_LOCALS
2568 assert(pVM->pSys->pUnLinkParen);
2569 if (pVM->pSys->nLocals > 0)
2570 {
2571 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2572 dictEmpty(pLoc, pLoc->pForthWords->size);
2573 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2574 }
2575
2576 pVM->pSys->nLocals = 0;
2577#endif
2578 IGNORE(pVM);
2579
2580 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2581 return;
2582}
2583
2584
2585/**************************************************************************
2586 t o b o d y
2587** to-body CORE ( xt -- a-addr )
2588** a-addr is the data-field address corresponding to xt. An ambiguous
2589** condition exists if xt is not for a word defined via CREATE.
2590**************************************************************************/
2591static void toBody(FICL_VM *pVM)
2592{
2593 FICL_WORD *pFW;
2594/*#$-GUY CHANGE: Added robustness.-$#*/
2595#if FICL_ROBUST > 1
2596 vmCheckStack(pVM, 1, 1);
2597#endif
2598
2599 pFW = POPPTR();
2600 PUSHPTR(pFW->param + 1);
2601 return;
2602}
2603
2604
2605/*
2606** from-body ficl ( a-addr -- xt )
2607** Reverse effect of >body
2608*/
2609static void fromBody(FICL_VM *pVM)
2610{
2611 char *ptr;
2612#if FICL_ROBUST > 1
2613 vmCheckStack(pVM, 1, 1);
2614#endif
2615
2616 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2617 PUSHPTR(ptr);
2618 return;
2619}
2620
2621
2622/*
2623** >name ficl ( xt -- c-addr u )
2624** Push the address and length of a word's name given its address
2625** xt.
2626*/
2627static void toName(FICL_VM *pVM)
2628{
2629 FICL_WORD *pFW;
2630#if FICL_ROBUST > 1
2631 vmCheckStack(pVM, 1, 2);
2632#endif
2633
2634 pFW = POPPTR();
2635 PUSHPTR(pFW->name);
2636 PUSHUNS(pFW->nName);
2637 return;
2638}
2639
2640
2641static void getLastWord(FICL_VM *pVM)
2642{
2643 FICL_DICT *pDict = vmGetDict(pVM);
2644 FICL_WORD *wp = pDict->smudge;
2645 assert(wp);
2646 vmPush(pVM, LVALUEtoCELL(wp));
2647 return;
2648}
2649
2650
2651/**************************************************************************
2652 l b r a c k e t e t c
2653**
2654**************************************************************************/
2655
2656static void lbracketCoIm(FICL_VM *pVM)
2657{
2658 pVM->state = INTERPRET;
2659 return;
2660}
2661
2662
2663static void rbracket(FICL_VM *pVM)
2664{
2665 pVM->state = COMPILE;
2666 return;
2667}
2668
2669
2670/**************************************************************************
2671 p i c t u r e d n u m e r i c w o r d s
2672**
2673** less-number-sign CORE ( -- )
2674** Initialize the pictured numeric output conversion process.
2675** (clear the pad)
2676**************************************************************************/
2677static void lessNumberSign(FICL_VM *pVM)
2678{
2679 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2680 sp->count = 0;
2681 return;
2682}
2683
2684/*
2685** number-sign CORE ( ud1 -- ud2 )
2686** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2687** n. (n is the least-significant digit of ud1.) Convert n to external form
2688** and add the resulting character to the beginning of the pictured numeric
2689** output string. An ambiguous condition exists if # executes outside of a
2690** <# #> delimited number conversion.
2691*/
2692static void numberSign(FICL_VM *pVM)
2693{
2694 FICL_STRING *sp;
2695 DPUNS u;
2696 UNS16 rem;
2697#if FICL_ROBUST > 1
2698 vmCheckStack(pVM, 2, 2);
2699#endif
2700
2701 sp = PTRtoSTRING pVM->pad;
2702 u = u64Pop(pVM->pStack);
2703 rem = m64UMod(&u, (UNS16)(pVM->base));
2704 sp->text[sp->count++] = digit_to_char(rem);
2705 u64Push(pVM->pStack, u);
2706 return;
2707}
2708
2709/*
2710** number-sign-greater CORE ( xd -- c-addr u )
2711** Drop xd. Make the pictured numeric output string available as a character
2712** string. c-addr and u specify the resulting character string. A program
2713** may replace characters within the string.
2714*/
2715static void numberSignGreater(FICL_VM *pVM)
2716{
2717 FICL_STRING *sp;
2718#if FICL_ROBUST > 1
2719 vmCheckStack(pVM, 2, 2);
2720#endif
2721
2722 sp = PTRtoSTRING pVM->pad;
2723 sp->text[sp->count] = 0;
2724 strrev(sp->text);
2725 DROP(2);
2726 PUSHPTR(sp->text);
2727 PUSHUNS(sp->count);
2728 return;
2729}
2730
2731/*
2732** number-sign-s CORE ( ud1 -- ud2 )
2733** Convert one digit of ud1 according to the rule for #. Continue conversion
2734** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2735** #S executes outside of a <# #> delimited number conversion.
2736** TO DO: presently does not use ud1 hi cell - use it!
2737*/
2738static void numberSignS(FICL_VM *pVM)
2739{
2740 FICL_STRING *sp;
2741 DPUNS u;
2742 UNS16 rem;
2743#if FICL_ROBUST > 1
2744 vmCheckStack(pVM, 2, 2);
2745#endif
2746
2747 sp = PTRtoSTRING pVM->pad;
2748 u = u64Pop(pVM->pStack);
2749
2750 do
2751 {
2752 rem = m64UMod(&u, (UNS16)(pVM->base));
2753 sp->text[sp->count++] = digit_to_char(rem);
2754 }
2755 while (u.hi || u.lo);
2756
2757 u64Push(pVM->pStack, u);
2758 return;
2759}
2760
2761/*
2762** HOLD CORE ( char -- )
2763** Add char to the beginning of the pictured numeric output string. An ambiguous
2764** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2765*/
2766static void hold(FICL_VM *pVM)
2767{
2768 FICL_STRING *sp;
2769 int i;
2770#if FICL_ROBUST > 1
2771 vmCheckStack(pVM, 1, 0);
2772#endif
2773
2774 sp = PTRtoSTRING pVM->pad;
2775 i = POPINT();
2776 sp->text[sp->count++] = (char) i;
2777 return;
2778}
2779
2780/*
2781** SIGN CORE ( n -- )
2782** If n is negative, add a minus sign to the beginning of the pictured
2783** numeric output string. An ambiguous condition exists if SIGN
2784** executes outside of a <# #> delimited number conversion.
2785*/
2786static void sign(FICL_VM *pVM)
2787{
2788 FICL_STRING *sp;
2789 int i;
2790#if FICL_ROBUST > 1
2791 vmCheckStack(pVM, 1, 0);
2792#endif
2793
2794 sp = PTRtoSTRING pVM->pad;
2795 i = POPINT();
2796 if (i < 0)
2797 sp->text[sp->count++] = '-';
2798 return;
2799}
2800
2801
2802/**************************************************************************
2803 t o N u m b e r
2804** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2805** ud2 is the unsigned result of converting the characters within the
2806** string specified by c-addr1 u1 into digits, using the number in BASE,
2807** and adding each into ud1 after multiplying ud1 by the number in BASE.
2808** Conversion continues left-to-right until a character that is not
2809** convertible, including any + or -, is encountered or the string is
2810** entirely converted. c-addr2 is the location of the first unconverted
2811** character or the first character past the end of the string if the string
2812** was entirely converted. u2 is the number of unconverted characters in the
2813** string. An ambiguous condition exists if ud2 overflows during the
2814** conversion.
2815**************************************************************************/
2816static void toNumber(FICL_VM *pVM)
2817{
2818 FICL_UNS count;
2819 char *cp;
2820 DPUNS accum;
2821 FICL_UNS base = pVM->base;
2822 FICL_UNS ch;
2823 FICL_UNS digit;
2824
2825#if FICL_ROBUST > 1
2826 vmCheckStack(pVM,4,4);
2827#endif
2828
2829 count = POPUNS();
2830 cp = (char *)POPPTR();
2831 accum = u64Pop(pVM->pStack);
2832
2833 for (ch = *cp; count > 0; ch = *++cp, count--)
2834 {
2835 if (ch < '0')
2836 break;
2837
2838 digit = ch - '0';
2839
2840 if (digit > 9)
2841 digit = tolower(ch) - 'a' + 10;
2842 /*
2843 ** Note: following test also catches chars between 9 and a
2844 ** because 'digit' is unsigned!
2845 */
2846 if (digit >= base)
2847 break;
2848
2849 accum = m64Mac(accum, base, digit);
2850 }
2851
2852 u64Push(pVM->pStack, accum);
2853 PUSHPTR(cp);
2854 PUSHUNS(count);
2855
2856 return;
2857}
2858
2859
2860
2861/**************************************************************************
2862 q u i t & a b o r t
2863** quit CORE ( -- ) ( R: i*x -- )
2864** Empty the return stack, store zero in SOURCE-ID if it is present, make
2865** the user input device the input source, and enter interpretation state.
2866** Do not display a message. Repeat the following:
2867**
2868** Accept a line from the input source into the input buffer, set >IN to
2869** zero, and interpret.
2870** Display the implementation-defined system prompt if in
2871** interpretation state, all processing has been completed, and no
2872** ambiguous condition exists.
2873**************************************************************************/
2874
2875static void quit(FICL_VM *pVM)
2876{
2877 vmThrow(pVM, VM_QUIT);
2878 return;
2879}
2880
2881
2882static void ficlAbort(FICL_VM *pVM)
2883{
2884 vmThrow(pVM, VM_ABORT);
2885 return;
2886}
2887
2888
2889/**************************************************************************
2890 a c c e p t
2891** accept CORE ( c-addr +n1 -- +n2 )
2892** Receive a string of at most +n1 characters. An ambiguous condition
2893** exists if +n1 is zero or greater than 32,767. Display graphic characters
2894** as they are received. A program that depends on the presence or absence
2895** of non-graphic characters in the string has an environmental dependency.
2896** The editing functions, if any, that the system performs in order to
2897** construct the string are implementation-defined.
2898**
2899** (Although the standard text doesn't say so, I assume that the intent
2900** of 'accept' is to store the string at the address specified on
2901** the stack.)
2902** Implementation: if there's more text in the TIB, use it. Otherwise
2903** throw out for more text. Copy characters up to the max count into the
2904** address given, and return the number of actual characters copied.
2905**
2906** Note (sobral) this may not be the behavior you'd expect if you're
2907** trying to get user input at load time!
2908**************************************************************************/
2909static void accept(FICL_VM *pVM)
2910{
2911 FICL_UNS count, len;
2912 char *cp;
2913 char *pBuf, *pEnd;
2914
2915#if FICL_ROBUST > 1
2916 vmCheckStack(pVM,2,1);
2917#endif
2918
2919 pBuf = vmGetInBuf(pVM);
2920 pEnd = vmGetInBufEnd(pVM);
2921 len = pEnd - pBuf;
2922 if (len == 0)
2923 vmThrow(pVM, VM_RESTART);
2924
2925 /*
2926 ** Now we have something in the text buffer - use it
2927 */
2928 count = stackPopINT(pVM->pStack);
2929 cp = stackPopPtr(pVM->pStack);
2930
2931 len = (count < len) ? count : len;
2932 strncpy(cp, vmGetInBuf(pVM), len);
2933 pBuf += len;
2934 vmUpdateTib(pVM, pBuf);
2935 PUSHINT(len);
2936
2937 return;
2938}
2939
2940
2941/**************************************************************************
2942 a l i g n
2943** 6.1.0705 ALIGN CORE ( -- )
2944** If the data-space pointer is not aligned, reserve enough space to
2945** align it.
2946**************************************************************************/
2947static void align(FICL_VM *pVM)
2948{
2949 FICL_DICT *dp = vmGetDict(pVM);
2950 IGNORE(pVM);
2951 dictAlign(dp);
2952 return;
2953}
2954
2955
2956/**************************************************************************
2957 a l i g n e d
2958**
2959**************************************************************************/
2960static void aligned(FICL_VM *pVM)
2961{
2962 void *addr;
2963#if FICL_ROBUST > 1
2964 vmCheckStack(pVM,1,1);
2965#endif
2966
2967 addr = POPPTR();
2968 PUSHPTR(alignPtr(addr));
2969 return;
2970}
2971
2972
2973/**************************************************************************
2974 b e g i n & f r i e n d s
2975** Indefinite loop control structures
2976** A.6.1.0760 BEGIN
2977** Typical use:
2978** : X ... BEGIN ... test UNTIL ;
2979** or
2980** : X ... BEGIN ... test WHILE ... REPEAT ;
2981**************************************************************************/
2982static void beginCoIm(FICL_VM *pVM)
2983{
2984 FICL_DICT *dp = vmGetDict(pVM);
2985 markBranch(dp, pVM, destTag);
2986 return;
2987}
2988
2989static void untilCoIm(FICL_VM *pVM)
2990{
2991 FICL_DICT *dp = vmGetDict(pVM);
2992
2993 assert(pVM->pSys->pIfParen);
2994
2995 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
2996 resolveBackBranch(dp, pVM, destTag);
2997 return;
2998}
2999
3000static void whileCoIm(FICL_VM *pVM)
3001{
3002 FICL_DICT *dp = vmGetDict(pVM);
3003
3004 assert(pVM->pSys->pIfParen);
3005
3006 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
3007 markBranch(dp, pVM, origTag);
3008 twoSwap(pVM);
3009 dictAppendUNS(dp, 1);
3010 return;
3011}
3012
3013static void repeatCoIm(FICL_VM *pVM)
3014{
3015 FICL_DICT *dp = vmGetDict(pVM);
3016
3017 assert(pVM->pSys->pBranchParen);
3018 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3019
3020 /* expect "begin" branch marker */
3021 resolveBackBranch(dp, pVM, destTag);
3022 /* expect "while" branch marker */
3023 resolveForwardBranch(dp, pVM, origTag);
3024 return;
3025}
3026
3027
3028static void againCoIm(FICL_VM *pVM)
3029{
3030 FICL_DICT *dp = vmGetDict(pVM);
3031
3032 assert(pVM->pSys->pBranchParen);
3033 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3034
3035 /* expect "begin" branch marker */
3036 resolveBackBranch(dp, pVM, destTag);
3037 return;
3038}
3039
3040
3041/**************************************************************************
3042 c h a r & f r i e n d s
3043** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
3044** Skip leading space delimiters. Parse name delimited by a space.
3045** Put the value of its first character onto the stack.
3046**
3047** bracket-char CORE
3048** Interpretation: Interpretation semantics for this word are undefined.
3049** Compilation: ( "<spaces>name" -- )
3050** Skip leading space delimiters. Parse name delimited by a space.
3051** Append the run-time semantics given below to the current definition.
3052** Run-time: ( -- char )
3053** Place char, the value of the first character of name, on the stack.
3054**************************************************************************/
3055static void ficlChar(FICL_VM *pVM)
3056{
3057 STRINGINFO si;
3058#if FICL_ROBUST > 1
3059 vmCheckStack(pVM,0,1);
3060#endif
3061
3062 si = vmGetWord(pVM);
3063 PUSHUNS((FICL_UNS)(si.cp[0]));
3064 return;
3065}
3066
3067static void charCoIm(FICL_VM *pVM)
3068{
3069 ficlChar(pVM);
3070 literalIm(pVM);
3071 return;
3072}
3073
3074/**************************************************************************
3075 c h a r P l u s
3076** char-plus CORE ( c-addr1 -- c-addr2 )
3077** Add the size in address units of a character to c-addr1, giving c-addr2.
3078**************************************************************************/
3079static void charPlus(FICL_VM *pVM)
3080{
3081 char *cp;
3082#if FICL_ROBUST > 1
3083 vmCheckStack(pVM,1,1);
3084#endif
3085
3086 cp = POPPTR();
3087 PUSHPTR(cp + 1);
3088 return;
3089}
3090
3091/**************************************************************************
3092 c h a r s
3093** chars CORE ( n1 -- n2 )
3094** n2 is the size in address units of n1 characters.
3095** For most processors, this function can be a no-op. To guarantee
3096** portability, we'll multiply by sizeof (char).
3097**************************************************************************/
3098#if defined (_M_IX86)
3099#pragma warning(disable: 4127)
3100#endif
3101static void ficlChars(FICL_VM *pVM)
3102{
3103 if (sizeof (char) > 1)
3104 {
3105 FICL_INT i;
3106#if FICL_ROBUST > 1
3107 vmCheckStack(pVM,1,1);
3108#endif
3109 i = POPINT();
3110 PUSHINT(i * sizeof (char));
3111 }
3112 /* otherwise no-op! */
3113 return;
3114}
3115#if defined (_M_IX86)
3116#pragma warning(default: 4127)
3117#endif
3118
3119
3120/**************************************************************************
3121 c o u n t
3122** COUNT CORE ( c-addr1 -- c-addr2 u )
3123** Return the character string specification for the counted string stored
3124** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3125** u is the contents of the character at c-addr1, which is the length in
3126** characters of the string at c-addr2.
3127**************************************************************************/
3128static void count(FICL_VM *pVM)
3129{
3130 FICL_STRING *sp;
3131#if FICL_ROBUST > 1
3132 vmCheckStack(pVM,1,2);
3133#endif
3134
3135 sp = POPPTR();
3136 PUSHPTR(sp->text);
3137 PUSHUNS(sp->count);
3138 return;
3139}
3140
3141/**************************************************************************
3142 e n v i r o n m e n t ?
3143** environment-query CORE ( c-addr u -- false | i*x true )
3144** c-addr is the address of a character string and u is the string's
3145** character count. u may have a value in the range from zero to an
3146** implementation-defined maximum which shall not be less than 31. The
3147** character string should contain a keyword from 3.2.6 Environmental
3148** queries or the optional word sets to be checked for correspondence
3149** with an attribute of the present environment. If the system treats the
3150** attribute as unknown, the returned flag is false; otherwise, the flag
3151** is true and the i*x returned is of the type specified in the table for
3152** the attribute queried.
3153**************************************************************************/
3154static void environmentQ(FICL_VM *pVM)
3155{
3156 FICL_DICT *envp;
3157 FICL_WORD *pFW;
3158 STRINGINFO si;
3159#if FICL_ROBUST > 1
3160 vmCheckStack(pVM,2,1);
3161#endif
3162
3163 envp = pVM->pSys->envp;
3164 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3165 si.cp = stackPopPtr(pVM->pStack);
3166
3167 pFW = dictLookup(envp, si);
3168
3169 if (pFW != NULL)
3170 {
3171 vmExecute(pVM, pFW);
3172 PUSHINT(FICL_TRUE);
3173 }
3174 else
3175 {
3176 PUSHINT(FICL_FALSE);
3177 }
3178 return;
3179}
3180
3181/**************************************************************************
3182 e v a l u a t e
3183** EVALUATE CORE ( i*x c-addr u -- j*x )
3184** Save the current input source specification. Store minus-one (-1) in
3185** SOURCE-ID if it is present. Make the string described by c-addr and u
3186** both the input source and input buffer, set >IN to zero, and interpret.
3187** When the parse area is empty, restore the prior input source
3188** specification. Other stack effects are due to the words EVALUATEd.
3189**
3190**************************************************************************/
3191static void evaluate(FICL_VM *pVM)
3192{
3193 FICL_UNS count;
3194 char *cp;
3195 CELL id;
3196 int result;
3197#if FICL_ROBUST > 1
3198 vmCheckStack(pVM,2,0);
3199#endif
3200
3201 count = POPUNS();
3202 cp = POPPTR();
3203
3204 IGNORE(count);
3205 id = pVM->sourceID;
3206 pVM->sourceID.i = -1;
3207 result = ficlExecC(pVM, cp, count);
3208 pVM->sourceID = id;
3209 if (result != VM_OUTOFTEXT)
3210 vmThrow(pVM, result);
3211
3212 return;
3213}
3214
3215
3216/**************************************************************************
3217 s t r i n g q u o t e
3218** Interpreting: get string delimited by a quote from the input stream,
3219** copy to a scratch area, and put its count and address on the stack.
3220** Compiling: compile code to push the address and count of a string
3221** literal, compile the string from the input stream, and align the dict
3222** pointer.
3223**************************************************************************/
3224static void stringQuoteIm(FICL_VM *pVM)
3225{
3226 FICL_DICT *dp = vmGetDict(pVM);
3227
3228 if (pVM->state == INTERPRET)
3229 {
3230 FICL_STRING *sp = (FICL_STRING *) dp->here;
3231 vmGetString(pVM, sp, '\"');
3232 PUSHPTR(sp->text);
3233 PUSHUNS(sp->count);
3234 }
3235 else /* COMPILE state */
3236 {
3237 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3238 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3239 dictAlign(dp);
3240 }
3241
3242 return;
3243}
3244
3245
3246/**************************************************************************
3247 t y p e
3248** Pop count and char address from stack and print the designated string.
3249**************************************************************************/
3250static void type(FICL_VM *pVM)
3251{
3252 FICL_UNS count = stackPopUNS(pVM->pStack);
3253 char *cp = stackPopPtr(pVM->pStack);
3254 char *pDest = (char *)ficlMalloc(count + 1);
3255
3256 /*
3257 ** Since we don't have an output primitive for a counted string
3258 ** (oops), make sure the string is null terminated. If not, copy
3259 ** and terminate it.
3260 */
3261 if (!pDest)
3262 vmThrowErr(pVM, "Error: out of memory");
3263
3264 strncpy(pDest, cp, count);
3265 pDest[count] = '\0';
3266
3267 vmTextOut(pVM, pDest, 0);
3268
3269 ficlFree(pDest);
3270 return;
3271}
3272
3273/**************************************************************************
3274 w o r d
3275** word CORE ( char "<chars>ccc<char>" -- c-addr )
3276** Skip leading delimiters. Parse characters ccc delimited by char. An
3277** ambiguous condition exists if the length of the parsed string is greater
3278** than the implementation-defined length of a counted string.
3279**
3280** c-addr is the address of a transient region containing the parsed word
3281** as a counted string. If the parse area was empty or contained no
3282** characters other than the delimiter, the resulting string has a zero
3283** length. A space, not included in the length, follows the string. A
3284** program may replace characters within the string.
3285** NOTE! Ficl also NULL-terminates the dest string.
3286**************************************************************************/
3287static void ficlWord(FICL_VM *pVM)
3288{
3289 FICL_STRING *sp;
3290 char delim;
3291 STRINGINFO si;
3292#if FICL_ROBUST > 1
3293 vmCheckStack(pVM,1,1);
3294#endif
3295
3296 sp = (FICL_STRING *)pVM->pad;
3297 delim = (char)POPINT();
3298 si = vmParseStringEx(pVM, delim, 1);
3299
3300 if (SI_COUNT(si) > nPAD-1)
3301 SI_SETLEN(si, nPAD-1);
3302
3303 sp->count = (FICL_COUNT)SI_COUNT(si);
3304 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3305 /*#$-GUY CHANGE: I added this.-$#*/
3306 sp->text[sp->count] = 0;
3307 strcat(sp->text, " ");
3308
3309 PUSHPTR(sp);
3310 return;
3311}
3312
3313
3314/**************************************************************************
3315 p a r s e - w o r d
3316** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3317** Skip leading spaces and parse name delimited by a space. c-addr is the
3318** address within the input buffer and u is the length of the selected
3319** string. If the parse area is empty, the resulting string has a zero length.
3320**************************************************************************/
3321static void parseNoCopy(FICL_VM *pVM)
3322{
3323 STRINGINFO si;
3324#if FICL_ROBUST > 1
3325 vmCheckStack(pVM,0,2);
3326#endif
3327
3328 si = vmGetWord0(pVM);
3329 PUSHPTR(SI_PTR(si));
3330 PUSHUNS(SI_COUNT(si));
3331 return;
3332}
3333
3334
3335/**************************************************************************
3336 p a r s e
3337** CORE EXT ( char "ccc<char>" -- c-addr u )
3338** Parse ccc delimited by the delimiter char.
3339** c-addr is the address (within the input buffer) and u is the length of
3340** the parsed string. If the parse area was empty, the resulting string has
3341** a zero length.
3342** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3343**************************************************************************/
3344static void parse(FICL_VM *pVM)
3345{
3346 STRINGINFO si;
3347 char delim;
3348
3349#if FICL_ROBUST > 1
3350 vmCheckStack(pVM,1,2);
3351#endif
3352
3353 delim = (char)POPINT();
3354
3355 si = vmParseStringEx(pVM, delim, 0);
3356 PUSHPTR(SI_PTR(si));
3357 PUSHUNS(SI_COUNT(si));
3358 return;
3359}
3360
3361
3362/**************************************************************************
3363 f i l l
3364** CORE ( c-addr u char -- )
3365** If u is greater than zero, store char in each of u consecutive
3366** characters of memory beginning at c-addr.
3367**************************************************************************/
3368static void fill(FICL_VM *pVM)
3369{
3370 char ch;
3371 FICL_UNS u;
3372 char *cp;
3373#if FICL_ROBUST > 1
3374 vmCheckStack(pVM,3,0);
3375#endif
3376 ch = (char)POPINT();
3377 u = POPUNS();
3378 cp = (char *)POPPTR();
3379
3380 while (u > 0)
3381 {
3382 *cp++ = ch;
3383 u--;
3384 }
3385 return;
3386}
3387
3388
3389/**************************************************************************
3390 f i n d
3391** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3392** Find the definition named in the counted string at c-addr. If the
3393** definition is not found, return c-addr and zero. If the definition is
3394** found, return its execution token xt. If the definition is immediate,
3395** also return one (1), otherwise also return minus-one (-1). For a given
3396** string, the values returned by FIND while compiling may differ from
3397** those returned while not compiling.
3398**************************************************************************/
3399static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3400{
3401 FICL_WORD *pFW;
3402
3403 pFW = dictLookup(vmGetDict(pVM), si);
3404 if (pFW)
3405 {
3406 PUSHPTR(pFW);
3407 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3408 }
3409 else
3410 {
3411 PUSHPTR(returnForFailure);
3412 PUSHUNS(0);
3413 }
3414 return;
3415}
3416
3417
3418
3419/**************************************************************************
3420 f i n d
3421** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3422** Find the definition named in the counted string at c-addr. If the
3423** definition is not found, return c-addr and zero. If the definition is
3424** found, return its execution token xt. If the definition is immediate,
3425** also return one (1), otherwise also return minus-one (-1). For a given
3426** string, the values returned by FIND while compiling may differ from
3427** those returned while not compiling.
3428**************************************************************************/
3429static void cFind(FICL_VM *pVM)
3430{
3431 FICL_STRING *sp;
3432 STRINGINFO si;
3433
3434#if FICL_ROBUST > 1
3435 vmCheckStack(pVM,1,2);
3436#endif
3437 sp = POPPTR();
3438 SI_PFS(si, sp);
3439 do_find(pVM, si, sp);
3440}
3441
3442
3443
3444/**************************************************************************
3445 s f i n d
3446** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3447** Like FIND, but takes "c-addr u" for the string.
3448**************************************************************************/
3449static void sFind(FICL_VM *pVM)
3450{
3451 STRINGINFO si;
3452
3453#if FICL_ROBUST > 1
3454 vmCheckStack(pVM,2,2);
3455#endif
3456
3457 si.count = stackPopINT(pVM->pStack);
3458 si.cp = stackPopPtr(pVM->pStack);
3459
3460 do_find(pVM, si, NULL);
3461}
3462
3463
3464
3465/**************************************************************************
3466 f m S l a s h M o d
3467** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3468** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3469** Input and output stack arguments are signed. An ambiguous condition
3470** exists if n1 is zero or if the quotient lies outside the range of a
3471** single-cell signed integer.
3472**************************************************************************/
3473static void fmSlashMod(FICL_VM *pVM)
3474{
3475 DPINT d1;
3476 FICL_INT n1;
3477 INTQR qr;
3478#if FICL_ROBUST > 1
3479 vmCheckStack(pVM,3,2);
3480#endif
3481
3482 n1 = POPINT();
3483 d1 = i64Pop(pVM->pStack);
3484 qr = m64FlooredDivI(d1, n1);
3485 PUSHINT(qr.rem);
3486 PUSHINT(qr.quot);
3487 return;
3488}
3489
3490
3491/**************************************************************************
3492 s m S l a s h R e m
3493** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3494** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3495** Input and output stack arguments are signed. An ambiguous condition
3496** exists if n1 is zero or if the quotient lies outside the range of a
3497** single-cell signed integer.
3498**************************************************************************/
3499static void smSlashRem(FICL_VM *pVM)
3500{
3501 DPINT d1;
3502 FICL_INT n1;
3503 INTQR qr;
3504#if FICL_ROBUST > 1
3505 vmCheckStack(pVM,3,2);
3506#endif
3507
3508 n1 = POPINT();
3509 d1 = i64Pop(pVM->pStack);
3510 qr = m64SymmetricDivI(d1, n1);
3511 PUSHINT(qr.rem);
3512 PUSHINT(qr.quot);
3513 return;
3514}
3515
3516
3517static void ficlMod(FICL_VM *pVM)
3518{
3519 DPINT d1;
3520 FICL_INT n1;
3521 INTQR qr;
3522#if FICL_ROBUST > 1
3523 vmCheckStack(pVM,2,1);
3524#endif
3525
3526 n1 = POPINT();
3527 d1.lo = POPINT();
3528 i64Extend(d1);
3529 qr = m64SymmetricDivI(d1, n1);
3530 PUSHINT(qr.rem);
3531 return;
3532}
3533
3534
3535/**************************************************************************
3536 u m S l a s h M o d
3537** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3538** Divide ud by u1, giving the quotient u3 and the remainder u2.
3539** All values and arithmetic are unsigned. An ambiguous condition
3540** exists if u1 is zero or if the quotient lies outside the range of a
3541** single-cell unsigned integer.
3542*************************************************************************/
3543static void umSlashMod(FICL_VM *pVM)
3544{
3545 DPUNS ud;
3546 FICL_UNS u1;
3547 UNSQR qr;
3548
3549 u1 = stackPopUNS(pVM->pStack);
3550 ud = u64Pop(pVM->pStack);
3551 qr = ficlLongDiv(ud, u1);
3552 PUSHUNS(qr.rem);
3553 PUSHUNS(qr.quot);
3554 return;
3555}
3556
3557
3558/**************************************************************************
3559 l s h i f t
3560** l-shift CORE ( x1 u -- x2 )
3561** Perform a logical left shift of u bit-places on x1, giving x2.
3562** Put zeroes into the least significant bits vacated by the shift.
3563** An ambiguous condition exists if u is greater than or equal to the
3564** number of bits in a cell.
3565**
3566** r-shift CORE ( x1 u -- x2 )
3567** Perform a logical right shift of u bit-places on x1, giving x2.
3568** Put zeroes into the most significant bits vacated by the shift. An
3569** ambiguous condition exists if u is greater than or equal to the
3570** number of bits in a cell.
3571**************************************************************************/
3572static void lshift(FICL_VM *pVM)
3573{
3574 FICL_UNS nBits;
3575 FICL_UNS x1;
3576#if FICL_ROBUST > 1
3577 vmCheckStack(pVM,2,1);
3578#endif
3579
3580 nBits = POPUNS();
3581 x1 = POPUNS();
3582 PUSHUNS(x1 << nBits);
3583 return;
3584}
3585
3586
3587static void rshift(FICL_VM *pVM)
3588{
3589 FICL_UNS nBits;
3590 FICL_UNS x1;
3591#if FICL_ROBUST > 1
3592 vmCheckStack(pVM,2,1);
3593#endif
3594
3595 nBits = POPUNS();
3596 x1 = POPUNS();
3597
3598 PUSHUNS(x1 >> nBits);
3599 return;
3600}
3601
3602
3603/**************************************************************************
3604 m S t a r
3605** m-star CORE ( n1 n2 -- d )
3606** d is the signed product of n1 times n2.
3607**************************************************************************/
3608static void mStar(FICL_VM *pVM)
3609{
3610 FICL_INT n2;
3611 FICL_INT n1;
3612 DPINT d;
3613#if FICL_ROBUST > 1
3614 vmCheckStack(pVM,2,2);
3615#endif
3616
3617 n2 = POPINT();
3618 n1 = POPINT();
3619
3620 d = m64MulI(n1, n2);
3621 i64Push(pVM->pStack, d);
3622 return;
3623}
3624
3625
3626static void umStar(FICL_VM *pVM)
3627{
3628 FICL_UNS u2;
3629 FICL_UNS u1;
3630 DPUNS ud;
3631#if FICL_ROBUST > 1
3632 vmCheckStack(pVM,2,2);
3633#endif
3634
3635 u2 = POPUNS();
3636 u1 = POPUNS();
3637
3638 ud = ficlLongMul(u1, u2);
3639 u64Push(pVM->pStack, ud);
3640 return;
3641}
3642
3643
3644/**************************************************************************
3645 m a x & m i n
3646**
3647**************************************************************************/
3648static void ficlMax(FICL_VM *pVM)
3649{
3650 FICL_INT n2;
3651 FICL_INT n1;
3652#if FICL_ROBUST > 1
3653 vmCheckStack(pVM,2,1);
3654#endif
3655
3656 n2 = POPINT();
3657 n1 = POPINT();
3658
3659 PUSHINT((n1 > n2) ? n1 : n2);
3660 return;
3661}
3662
3663static void ficlMin(FICL_VM *pVM)
3664{
3665 FICL_INT n2;
3666 FICL_INT n1;
3667#if FICL_ROBUST > 1
3668 vmCheckStack(pVM,2,1);
3669#endif
3670
3671 n2 = POPINT();
3672 n1 = POPINT();
3673
3674 PUSHINT((n1 < n2) ? n1 : n2);
3675 return;
3676}
3677
3678
3679/**************************************************************************
3680 m o v e
3681** CORE ( addr1 addr2 u -- )
3682** If u is greater than zero, copy the contents of u consecutive address
3683** units at addr1 to the u consecutive address units at addr2. After MOVE
3684** completes, the u consecutive address units at addr2 contain exactly
3685** what the u consecutive address units at addr1 contained before the move.
3686** NOTE! This implementation assumes that a char is the same size as
3687** an address unit.
3688**************************************************************************/
3689static void move(FICL_VM *pVM)
3690{
3691 FICL_UNS u;
3692 char *addr2;
3693 char *addr1;
3694#if FICL_ROBUST > 1
3695 vmCheckStack(pVM,3,0);
3696#endif
3697
3698 u = POPUNS();
3699 addr2 = POPPTR();
3700 addr1 = POPPTR();
3701
3702 if (u == 0)
3703 return;
3704 /*
3705 ** Do the copy carefully, so as to be
3706 ** correct even if the two ranges overlap
3707 */
3708 if (addr1 >= addr2)
3709 {
3710 for (; u > 0; u--)
3711 *addr2++ = *addr1++;
3712 }
3713 else
3714 {
3715 addr2 += u-1;
3716 addr1 += u-1;
3717 for (; u > 0; u--)
3718 *addr2-- = *addr1--;
3719 }
3720
3721 return;
3722}
3723
3724
3725/**************************************************************************
3726 r e c u r s e
3727**
3728**************************************************************************/
3729static void recurseCoIm(FICL_VM *pVM)
3730{
3731 FICL_DICT *pDict = vmGetDict(pVM);
3732
3733 IGNORE(pVM);
3734 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3735 return;
3736}
3737
3738
3739/**************************************************************************
3740 s t o d
3741** s-to-d CORE ( n -- d )
3742** Convert the number n to the double-cell number d with the same
3743** numerical value.
3744**************************************************************************/
3745static void sToD(FICL_VM *pVM)
3746{
3747 FICL_INT s;
3748#if FICL_ROBUST > 1
3749 vmCheckStack(pVM,1,2);
3750#endif
3751
3752 s = POPINT();
3753
3754 /* sign extend to 64 bits.. */
3755 PUSHINT(s);
3756 PUSHINT((s < 0) ? -1 : 0);
3757 return;
3758}
3759
3760
3761/**************************************************************************
3762 s o u r c e
3763** CORE ( -- c-addr u )
3764** c-addr is the address of, and u is the number of characters in, the
3765** input buffer.
3766**************************************************************************/
3767static void source(FICL_VM *pVM)
3768{
3769#if FICL_ROBUST > 1
3770 vmCheckStack(pVM,0,2);
3771#endif
3772 PUSHPTR(pVM->tib.cp);
3773 PUSHINT(vmGetInBufLen(pVM));
3774 return;
3775}
3776
3777
3778/**************************************************************************
3779 v e r s i o n
3780** non-standard...
3781**************************************************************************/
3782static void ficlVersion(FICL_VM *pVM)
3783{
3784 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3785 return;
3786}
3787
3788
3789/**************************************************************************
3790 t o I n
3791** to-in CORE
3792**************************************************************************/
3793static void toIn(FICL_VM *pVM)
3794{
3795#if FICL_ROBUST > 1
3796 vmCheckStack(pVM,0,1);
3797#endif
3798 PUSHPTR(&pVM->tib.index);
3799 return;
3800}
3801
3802
3803/**************************************************************************
3804 c o l o n N o N a m e
3805** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3806** Create an unnamed colon definition and push its address.
3807** Change state to compile.
3808**************************************************************************/
3809static void colonNoName(FICL_VM *pVM)
3810{
3811 FICL_DICT *dp = vmGetDict(pVM);
3812 FICL_WORD *pFW;
3813 STRINGINFO si;
3814
3815 SI_SETLEN(si, 0);
3816 SI_SETPTR(si, NULL);
3817
3818 pVM->state = COMPILE;
3819 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3820 PUSHPTR(pFW);
3821 markControlTag(pVM, colonTag);
3822 return;
3823}
3824
3825
3826/**************************************************************************
3827 u s e r V a r i a b l e
3828** user ( u -- ) "<spaces>name"
3829** Get a name from the input stream and create a user variable
3830** with the name and the index supplied. The run-time effect
3831** of a user variable is to push the address of the indexed cell
3832** in the running vm's user array.
3833**
3834** User variables are vm local cells. Each vm has an array of
3835** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3836** Ficl's user facility is implemented with two primitives,
3837** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3838** holds the index of the next free user cell, and a redefinition
3839** (also in softcore) of "user" that defines a user word and increments
3840** nUser.
3841**************************************************************************/
3842#if FICL_WANT_USER
3843static void userParen(FICL_VM *pVM)
3844{
3845 FICL_INT i = pVM->runningWord->param[0].i;
3846 PUSHPTR(&pVM->user[i]);
3847 return;
3848}
3849
3850
3851static void userVariable(FICL_VM *pVM)
3852{
3853 FICL_DICT *dp = vmGetDict(pVM);
3854 STRINGINFO si = vmGetWord(pVM);
3855 CELL c;
3856
3857 c = stackPop(pVM->pStack);
3858 if (c.i >= FICL_USER_CELLS)
3859 {
3860 vmThrowErr(pVM, "Error - out of user space");
3861 }
3862
3863 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3864 dictAppendCell(dp, c);
3865 return;
3866}
3867#endif
3868
3869
3870/**************************************************************************
3871 t o V a l u e
3872** CORE EXT
3873** Interpretation: ( x "<spaces>name" -- )
3874** Skip leading spaces and parse name delimited by a space. Store x in
3875** name. An ambiguous condition exists if name was not defined by VALUE.
3876** NOTE: In ficl, VALUE is an alias of CONSTANT
3877**************************************************************************/
3878static void toValue(FICL_VM *pVM)
3879{
3880 STRINGINFO si = vmGetWord(pVM);
3881 FICL_DICT *dp = vmGetDict(pVM);
3882 FICL_WORD *pFW;
3883
3884#if FICL_WANT_LOCALS
3885 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
3886 {
3887 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
3888 pFW = dictLookup(pLoc, si);
3889 if (pFW && (pFW->code == doLocalIm))
3890 {
3891 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
3892 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3893 return;
3894 }
3895 else if (pFW && pFW->code == do2LocalIm)
3896 {
3897 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
3898 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3899 return;
3900 }
3901 }
3902#endif
3903
3904 assert(pVM->pSys->pStore);
3905
3906 pFW = dictLookup(dp, si);
3907 if (!pFW)
3908 {
3909 int i = SI_COUNT(si);
3910 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3911 }
3912
3913 if (pVM->state == INTERPRET)
3914 pFW->param[0] = stackPop(pVM->pStack);
3915 else /* compile code to store to word's param */
3916 {
3917 PUSHPTR(&pFW->param[0]);
3918 literalIm(pVM);
3919 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
3920 }
3921 return;
3922}
3923
3924
3925#if FICL_WANT_LOCALS
3926/**************************************************************************
3927 l i n k P a r e n
3928** ( -- )
3929** Link a frame on the return stack, reserving nCells of space for
3930** locals - the value of nCells is the next cell in the instruction
3931** stream.
3932**************************************************************************/
3933static void linkParen(FICL_VM *pVM)
3934{
3935 FICL_INT nLink = *(FICL_INT *)(pVM->ip);
3936 vmBranchRelative(pVM, 1);
3937 stackLink(pVM->rStack, nLink);
3938 return;
3939}
3940
3941
3942static void unlinkParen(FICL_VM *pVM)
3943{
3944 stackUnlink(pVM->rStack);
3945 return;
3946}
3947
3948
3949/**************************************************************************
3950 d o L o c a l I m
3951** Immediate - cfa of a local while compiling - when executed, compiles
3952** code to fetch the value of a local given the local's index in the
3953** word's pfa
3954**************************************************************************/
3955static void getLocalParen(FICL_VM *pVM)
3956{
3957 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3958 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3959 return;
3960}
3961
3962
3963static void toLocalParen(FICL_VM *pVM)
3964{
3965 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3966 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3967 return;
3968}
3969
3970
3971static void getLocal0(FICL_VM *pVM)
3972{
3973 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3974 return;
3975}
3976
3977
3978static void toLocal0(FICL_VM *pVM)
3979{
3980 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3981 return;
3982}
3983
3984
3985static void getLocal1(FICL_VM *pVM)
3986{
3987 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3988 return;
3989}
3990
3991
3992static void toLocal1(FICL_VM *pVM)
3993{
3994 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
3995 return;
3996}
3997
3998
3999/*
4000** Each local is recorded in a private locals dictionary as a
4001** word that does doLocalIm at runtime. DoLocalIm compiles code
4002** into the client definition to fetch the value of the
4003** corresponding local variable from the return stack.
4004** The private dictionary gets initialized at the end of each block
4005** that uses locals (in ; and does> for example).
4006*/
4007static void doLocalIm(FICL_VM *pVM)
4008{
4009 FICL_DICT *pDict = vmGetDict(pVM);
4010 FICL_INT nLocal = pVM->runningWord->param[0].i;
4011
4012 if (pVM->state == INTERPRET)
4013 {
4014 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4015 }
4016 else
4017 {
4018
4019 if (nLocal == 0)
4020 {
4021 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
4022 }
4023 else if (nLocal == 1)
4024 {
4025 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
4026 }
4027 else
4028 {
4029 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
4030 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4031 }
4032 }
4033 return;
4034}
4035
4036
4037/**************************************************************************
4038 l o c a l P a r e n
4039** paren-local-paren LOCAL
4040** Interpretation: Interpretation semantics for this word are undefined.
4041** Execution: ( c-addr u -- )
4042** When executed during compilation, (LOCAL) passes a message to the
4043** system that has one of two meanings. If u is non-zero,
4044** the message identifies a new local whose definition name is given by
4045** the string of characters identified by c-addr u. If u is zero,
4046** the message is last local and c-addr has no significance.
4047**
4048** The result of executing (LOCAL) during compilation of a definition is
4049** to create a set of named local identifiers, each of which is
4050** a definition name, that only have execution semantics within the scope
4051** of that definition's source.
4052**
4053** local Execution: ( -- x )
4054**
4055** Push the local's value, x, onto the stack. The local's value is
4056** initialized as described in 13.3.3 Processing locals and may be
4057** changed by preceding the local's name with TO. An ambiguous condition
4058** exists when local is executed while in interpretation state.
4059**************************************************************************/
4060static void localParen(FICL_VM *pVM)
4061{
4062 FICL_DICT *pDict;
4063 STRINGINFO si;
4064#if FICL_ROBUST > 1
4065 vmCheckStack(pVM,2,0);
4066#endif
4067
4068 pDict = vmGetDict(pVM);
4069 SI_SETLEN(si, POPUNS());
4070 SI_SETPTR(si, (char *)POPPTR());
4071
4072 if (SI_COUNT(si) > 0)
4073 { /* add a local to the **locals** dict and update nLocals */
4074 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4075 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4076 {
4077 vmThrowErr(pVM, "Error: out of local space");
4078 }
4079
4080 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4081 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4082
4083 if (pVM->pSys->nLocals == 0)
4084 { /* compile code to create a local stack frame */
4085 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4086 /* save location in dictionary for #locals */
4087 pVM->pSys->pMarkLocals = pDict->here;
4088 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4089 /* compile code to initialize first local */
4090 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
4091 }
4092 else if (pVM->pSys->nLocals == 1)
4093 {
4094 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
4095 }
4096 else
4097 {
4098 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4099 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4100 }
4101
4102 (pVM->pSys->nLocals)++;
4103 }
4104 else if (pVM->pSys->nLocals > 0)
4105 { /* write nLocals to (link) param area in dictionary */
4106 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4107 }
4108
4109 return;
4110}
4111
4112
4113static void get2LocalParen(FICL_VM *pVM)
4114{
4115 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4116 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4117 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4118 return;
4119}
4120
4121
4122static void do2LocalIm(FICL_VM *pVM)
4123{
4124 FICL_DICT *pDict = vmGetDict(pVM);
4125 FICL_INT nLocal = pVM->runningWord->param[0].i;
4126
4127 if (pVM->state == INTERPRET)
4128 {
4129 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4130 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4131 }
4132 else
4133 {
4134 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
4135 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4136 }
4137 return;
4138}
4139
4140
4141static void to2LocalParen(FICL_VM *pVM)
4142{
4143 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4144 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4145 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4146 return;
4147}
4148
4149
4150static void twoLocalParen(FICL_VM *pVM)
4151{
4152 FICL_DICT *pDict = vmGetDict(pVM);
4153 STRINGINFO si;
4154 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4155 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4156
4157 if (SI_COUNT(si) > 0)
4158 { /* add a local to the **locals** dict and update nLocals */
4159 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4160 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4161 {
4162 vmThrowErr(pVM, "Error: out of local space");
4163 }
4164
4165 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4166 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4167
4168 if (pVM->pSys->nLocals == 0)
4169 { /* compile code to create a local stack frame */
4170 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4171 /* save location in dictionary for #locals */
4172 pVM->pSys->pMarkLocals = pDict->here;
4173 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4174 }
4175
4176 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4177 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4178
4179 pVM->pSys->nLocals += 2;
4180 }
4181 else if (pVM->pSys->nLocals > 0)
4182 { /* write nLocals to (link) param area in dictionary */
4183 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4184 }
4185
4186 return;
4187}
4188
4189
4190#endif
4191/**************************************************************************
4192 c o m p a r e
4193** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4194** Compare the string specified by c-addr1 u1 to the string specified by
4195** c-addr2 u2. The strings are compared, beginning at the given addresses,
4196** character by character, up to the length of the shorter string or until a
4197** difference is found. If the two strings are identical, n is zero. If the two
4198** strings are identical up to the length of the shorter string, n is minus-one
4199** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4200** identical up to the length of the shorter string, n is minus-one (-1) if the
4201** first non-matching character in the string specified by c-addr1 u1 has a
4202** lesser numeric value than the corresponding character in the string specified
4203** by c-addr2 u2 and one (1) otherwise.
4204**************************************************************************/
4205static void compareInternal(FICL_VM *pVM, int caseInsensitive)
4206{
4207 char *cp1, *cp2;
4208 FICL_UNS u1, u2, uMin;
4209 int n = 0;
4210
4211 vmCheckStack(pVM, 4, 1);
4212 u2 = stackPopUNS(pVM->pStack);
4213 cp2 = (char *)stackPopPtr(pVM->pStack);
4214 u1 = stackPopUNS(pVM->pStack);
4215 cp1 = (char *)stackPopPtr(pVM->pStack);
4216
4217 uMin = (u1 < u2)? u1 : u2;
4218 for ( ; (uMin > 0) && (n == 0); uMin--)
4219 {
4220 char c1 = *cp1++;
4221 char c2 = *cp2++;
4222 if (caseInsensitive)
4223 {
4224 c1 = (char)tolower(c1);
4225 c2 = (char)tolower(c2);
4226 }
4227 n = (int)(c1 - c2);
4228 }
4229
4230 if (n == 0)
4231 n = (int)(u1 - u2);
4232
4233 if (n < 0)
4234 n = -1;
4235 else if (n > 0)
4236 n = 1;
4237
4238 PUSHINT(n);
4239 return;
4240}
4241
4242
4243static void compareString(FICL_VM *pVM)
4244{
4245 compareInternal(pVM, FALSE);
4246}
4247
4248
4249static void compareStringInsensitive(FICL_VM *pVM)
4250{
4251 compareInternal(pVM, TRUE);
4252}
4253
4254
4255/**************************************************************************
4256 p a d
4257** CORE EXT ( -- c-addr )
4258** c-addr is the address of a transient region that can be used to hold
4259** data for intermediate processing.
4260**************************************************************************/
4261static void pad(FICL_VM *pVM)
4262{
4263 stackPushPtr(pVM->pStack, pVM->pad);
4264}
4265
4266
4267/**************************************************************************
4268 s o u r c e - i d
4269** CORE EXT, FILE ( -- 0 | -1 | fileid )
4270** Identifies the input source as follows:
4271**
4272** SOURCE-ID Input source
4273** --------- ------------
4274** fileid Text file fileid
4275** -1 String (via EVALUATE)
4276** 0 User input device
4277**************************************************************************/
4278static void sourceid(FICL_VM *pVM)
4279{
4280 PUSHINT(pVM->sourceID.i);
4281 return;
4282}
4283
4284
4285/**************************************************************************
4286 r e f i l l
4287** CORE EXT ( -- flag )
4288** Attempt to fill the input buffer from the input source, returning a true
4289** flag if successful.
4290** When the input source is the user input device, attempt to receive input
4291** into the terminal input buffer. If successful, make the result the input
4292** buffer, set >IN to zero, and return true. Receipt of a line containing no
4293** characters is considered successful. If there is no input available from
4294** the current input source, return false.
4295** When the input source is a string from EVALUATE, return false and
4296** perform no other action.
4297**************************************************************************/
4298static void refill(FICL_VM *pVM)
4299{
4300 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4301 if (ret && (pVM->fRestart == 0))
4302 vmThrow(pVM, VM_RESTART);
4303
4304 PUSHINT(ret);
4305 return;
4306}
4307
4308
4309/**************************************************************************
4310 freebsd exception handling words
4311** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4312** the word in ToS. If an exception happens, restore the state to what
4313** it was before, and pushes the exception value on the stack. If not,
4314** push zero.
4315**
4316** Notice that Catch implements an inner interpreter. This is ugly,
4317** but given how ficl works, it cannot be helped. The problem is that
4318** colon definitions will be executed *after* the function returns,
4319** while "code" definitions will be executed immediately. I considered
4320** other solutions to this problem, but all of them shared the same
4321** basic problem (with added disadvantages): if ficl ever changes it's
4322** inner thread modus operandi, one would have to fix this word.
4323**
4324** More comments can be found throughout catch's code.
4325**
4326** Daniel C. Sobral Jan 09/1999
4327** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4328**************************************************************************/
4329
4330static void ficlCatch(FICL_VM *pVM)
4331{
4332 int except;
4333 jmp_buf vmState;
4334 FICL_VM VM;
4335 FICL_STACK pStack;
4336 FICL_STACK rStack;
4337 FICL_WORD *pFW;
4338
4339 assert(pVM);
4340 assert(pVM->pSys->pExitInner);
4341
4342
4343 /*
4344 ** Get xt.
4345 ** We need this *before* we save the stack pointer, or
4346 ** we'll have to pop one element out of the stack after
4347 ** an exception. I prefer to get done with it up front. :-)
4348 */
4349#if FICL_ROBUST > 1
4350 vmCheckStack(pVM, 1, 0);
4351#endif
4352 pFW = stackPopPtr(pVM->pStack);
4353
4354 /*
4355 ** Save vm's state -- a catch will not back out environmental
4356 ** changes.
4357 **
4358 ** We are *not* saving dictionary state, since it is
4359 ** global instead of per vm, and we are not saving
4360 ** stack contents, since we are not required to (and,
4361 ** thus, it would be useless). We save pVM, and pVM
4362 ** "stacks" (a structure containing general information
4363 ** about it, including the current stack pointer).
4364 */
4365 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4366 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4367 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4368
4369 /*
4370 ** Give pVM a jmp_buf
4371 */
4372 pVM->pState = &vmState;
4373
4374 /*
4375 ** Safety net
4376 */
4377 except = setjmp(vmState);
4378
4379 switch (except)
4380 {
4381 /*
4382 ** Setup condition - push poison pill so that the VM throws
4383 ** VM_INNEREXIT if the XT terminates normally, then execute
4384 ** the XT
4385 */
4386 case 0:
4387 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4388 vmExecute(pVM, pFW);
4389 vmInnerLoop(pVM);
4390 break;
4391
4392 /*
4393 ** Normal exit from XT - lose the poison pill,
4394 ** restore old setjmp vector and push a zero.
4395 */
4396 case VM_INNEREXIT:
4397 vmPopIP(pVM); /* Gack - hurl poison pill */
4398 pVM->pState = VM.pState; /* Restore just the setjmp vector */
4399 PUSHINT(0); /* Push 0 -- everything is ok */
4400 break;
4401
4402 /*
4403 ** Some other exception got thrown - restore pre-existing VM state
4404 ** and push the exception code
4405 */
4406 default:
4407 /* Restore vm's state */
4408 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4409 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4410 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4411
4412 PUSHINT(except);/* Push error */
4413 break;
4414 }
4415}
4416
4417/**************************************************************************
4418** t h r o w
4419** EXCEPTION
4420** Throw -- From ANS Forth standard.
4421**
4422** Throw takes the ToS and, if that's different from zero,
4423** returns to the last executed catch context. Further throws will
4424** unstack previously executed "catches", in LIFO mode.
4425**
4426** Daniel C. Sobral Jan 09/1999
4427**************************************************************************/
4428static void ficlThrow(FICL_VM *pVM)
4429{
4430 int except;
4431
4432 except = stackPopINT(pVM->pStack);
4433
4434 if (except)
4435 vmThrow(pVM, except);
4436}
4437
4438
4439/**************************************************************************
4440** a l l o c a t e
4441** MEMORY
4442**************************************************************************/
4443static void ansAllocate(FICL_VM *pVM)
4444{
4445 size_t size;
4446 void *p;
4447
4448 size = stackPopINT(pVM->pStack);
4449 p = ficlMalloc(size);
4450 PUSHPTR(p);
4451 if (p)
4452 PUSHINT(0);
4453 else
4454 PUSHINT(1);
4455}
4456
4457
4458/**************************************************************************
4459** f r e e
4460** MEMORY
4461**************************************************************************/
4462static void ansFree(FICL_VM *pVM)
4463{
4464 void *p;
4465
4466 p = stackPopPtr(pVM->pStack);
4467 ficlFree(p);
4468 PUSHINT(0);
4469}
4470
4471
4472/**************************************************************************
4473** r e s i z e
4474** MEMORY
4475**************************************************************************/
4476static void ansResize(FICL_VM *pVM)
4477{
4478 size_t size;
4479 void *new, *old;
4480
4481 size = stackPopINT(pVM->pStack);
4482 old = stackPopPtr(pVM->pStack);
4483 new = ficlRealloc(old, size);
4484 if (new)
4485 {
4486 PUSHPTR(new);
4487 PUSHINT(0);
4488 }
4489 else
4490 {
4491 PUSHPTR(old);
4492 PUSHINT(1);
4493 }
4494}
4495
4496
4497/**************************************************************************
4498** e x i t - i n n e r
4499** Signals execXT that an inner loop has completed
4500**************************************************************************/
4501static void ficlExitInner(FICL_VM *pVM)
4502{
4503 vmThrow(pVM, VM_INNEREXIT);
4504}
4505
4506
4507/**************************************************************************
4508 d n e g a t e
4509** DOUBLE ( d1 -- d2 )
4510** d2 is the negation of d1.
4511**************************************************************************/
4512static void dnegate(FICL_VM *pVM)
4513{
4514 DPINT i = i64Pop(pVM->pStack);
4515 i = m64Negate(i);
4516 i64Push(pVM->pStack, i);
4517
4518 return;
4519}
4520
4521
4522#if 0
4523/**************************************************************************
4524
4525**
4526**************************************************************************/
4527static void funcname(FICL_VM *pVM)
4528{
4529 IGNORE(pVM);
4530 return;
4531}
4532
4533
4534#endif
4535/**************************************************************************
4536 f i c l W o r d C l a s s i f y
4537** This public function helps to classify word types for SEE
4538** and the deugger in tools.c. Given an pointer to a word, it returns
4539** a member of WOR
4540**************************************************************************/
4541WORDKIND ficlWordClassify(FICL_WORD *pFW)
4542{
4543 typedef struct
4544 {
4545 WORDKIND kind;
4546 FICL_CODE code;
4547 } CODEtoKIND;
4548
4549 static CODEtoKIND codeMap[] =
4550 {
4551 {BRANCH, branchParen},
4552 {COLON, colonParen},
4553 {CONSTANT, constantParen},
4554 {CREATE, createParen},
4555 {DO, doParen},
4556 {DOES, doDoes},
4557 {IF, ifParen},
4558 {LITERAL, literalParen},
4559 {LOOP, loopParen},
4560 {PLOOP, plusLoopParen},
4561 {QDO, qDoParen},
4562 {CSTRINGLIT, cstringLit},
4563 {STRINGLIT, stringLit},
4564#if FICL_WANT_USER
4565 {USER, userParen},
4566#endif
4567 {VARIABLE, variableParen},
4568 };
4569
4570#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4571
4572 FICL_CODE code = pFW->code;
4573 int i;
4574
4575 for (i=0; i < nMAP; i++)
4576 {
4577 if (codeMap[i].code == code)
4578 return codeMap[i].kind;
4579 }
4580
4581 return PRIMITIVE;
4582}
4583
4584
4585/**************************************************************************
4586 f i c l C o m p i l e C o r e
4587** Builds the primitive wordset and the environment-query namespace.
4588**************************************************************************/
4589
4590void ficlCompileCore(FICL_SYSTEM *pSys)
4591{
4592 FICL_DICT *dp = pSys->dp;
4593 assert (dp);
4594
4595
4596 /*
4597 ** CORE word set
4598 ** see softcore.c for definitions of: abs bl space spaces abort"
4599 */
4600 pSys->pStore =
4601 dictAppendWord(dp, "!", store, FW_DEFAULT);
4602 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4603 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4604 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4605 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4606 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4607 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4608 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4609 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4610 dictAppendWord(dp, "+", add, FW_DEFAULT);
4611 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4612 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4613 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4614 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4615 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4616 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4617 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4618 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4619 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4620 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4621 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4622 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4623 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4624 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4625 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4626 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4627 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4628 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4629 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4630 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4631 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4632 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4633 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4634 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4635 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4636 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4637 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4638 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4639 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4640 dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
4641 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4642 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4643 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4644 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4645 dictAppendWord(dp, "align", align, FW_DEFAULT);
4646 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4647 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4648 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4649 dictAppendWord(dp, "base", base, FW_DEFAULT);
4650 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4651 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4652 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4653 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4654 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4655 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4656 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4657 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4658 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4659 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4660 dictAppendWord(dp, "count", count, FW_DEFAULT);
4661 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4662 dictAppendWord(dp, "create", create, FW_DEFAULT);
4663 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4664 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4665 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4666 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4667 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4668 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4669 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4670 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4671 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4672 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4673 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4674 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4675 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4676 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4677 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4678 dictAppendWord(dp, "here", here, FW_DEFAULT);
4679 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4680 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4681 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4682 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4683 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4684 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4685 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4686 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4687 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4688 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4689 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4690 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4691 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4692 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4693 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4694 dictAppendWord(dp, "move", move, FW_DEFAULT);
4695 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4696 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4697 dictAppendWord(dp, "over", over, FW_DEFAULT);
4698 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4699 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4700 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
4701 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
4702 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4703 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4704 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4705 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4706 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4707 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4708 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4709 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4710 dictAppendWord(dp, "source", source, FW_DEFAULT);
4711 dictAppendWord(dp, "state", state, FW_DEFAULT);
4712 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4713 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4714 dictAppendWord(dp, "type", type, FW_DEFAULT);
4715 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4716 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4717 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4718 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4719 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4720 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4721 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4722 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4723 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4724 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4725 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4726 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4727 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4728 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4729 /*
4730 ** CORE EXT word set...
4731 ** see softcore.fr for other definitions
4732 */
4733 /* "#tib" */
4734 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
4735 /* ".r" */
4736 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4737 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4738 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
4739 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
4740 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4741 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4742 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
4743 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
4744 /* case of endof endcase */
4745 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4746 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
4747 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4748 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4749 /* query restore-input save-input tib u.r u> unused [compile] */
4750 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4751 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4752 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
4753 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4754 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4755 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4756
4757
4758 /*
4759 ** Set CORE environment query values
4760 */
4761 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
4762 ficlSetEnv(pSys, "/hold", nPAD);
4763 ficlSetEnv(pSys, "/pad", nPAD);
4764 ficlSetEnv(pSys, "address-unit-bits", 8);
4765 ficlSetEnv(pSys, "core", FICL_TRUE);
4766 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
4767 ficlSetEnv(pSys, "floored", FICL_FALSE);
4768 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
4769 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
4770 ficlSetEnv(pSys, "max-n", 0x7fffffff);
4771 ficlSetEnv(pSys, "max-u", 0xffffffff);
4772 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
4773 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
4774 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
4775
4776 /*
4777 ** DOUBLE word set (partial)
4778 */
4779 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
4780 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
4781 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
4782 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
4783
4784
4785 /*
4786 ** EXCEPTION word set
4787 */
4788 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
4789 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
4790
4791 ficlSetEnv(pSys, "exception", FICL_TRUE);
4792 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
4793
4794 /*
4795 ** LOCAL and LOCAL EXT
4796 ** see softcore.c for implementation of locals|
4797 */
4798#if FICL_WANT_LOCALS
4799 pSys->pLinkParen =
4800 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4801 pSys->pUnLinkParen =
4802 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4803 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4804 pSys->pGetLocalParen =
4805 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4806 pSys->pToLocalParen =
4807 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4808 pSys->pGetLocal0 =
4809 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4810 pSys->pToLocal0 =
4811 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4812 pSys->pGetLocal1 =
4813 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4814 pSys->pToLocal1 =
4815 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4816 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4817
4818 pSys->pGet2LocalParen =
4819 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4820 pSys->pTo2LocalParen =
4821 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
4822 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
4823
4824 ficlSetEnv(pSys, "locals", FICL_TRUE);
4825 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
4826 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
4827#endif
4828
4829 /*
4830 ** Optional MEMORY-ALLOC word set
4831 */
4832
4833 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
4834 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
4835 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
4836
4837 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
4838
4839 /*
4840 ** optional SEARCH-ORDER word set
4841 */
4842 ficlCompileSearch(pSys);
4843
4844 /*
4845 ** TOOLS and TOOLS EXT
4846 */
4847 ficlCompileTools(pSys);
4848
4849 /*
4850 ** FILE and FILE EXT
4851 */
4852#if FICL_WANT_FILE
4853 ficlCompileFile(pSys);
4854#endif
4855
4856 /*
4857 ** Ficl extras
4858 */
4859#if FICL_WANT_FLOAT
4860 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4861#endif
4862 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4863 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4864 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4865 dictAppendWord(dp, "add-parse-step",
4866 addParseStep, FW_DEFAULT);
4867 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4868 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4869 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
4870 dictAppendWord(dp, "compile-only",
4871 compileOnly, FW_DEFAULT);
4872 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4873 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
4874 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
4875 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
4876 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
4877 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4878 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
4879 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4880 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
4881 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
4882 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
4883 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
4884 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4885 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4886 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4887#if FICL_WANT_USER
4888 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4889 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4890#endif
4891
4892 /*
4893 ** internal support words
4894 */
4895 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
4896 pSys->pExitParen =
4897 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4898 pSys->pSemiParen =
4899 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4900 pSys->pLitParen =
4901 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4902 pSys->pTwoLitParen =
4903 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
4904 pSys->pStringLit =
4905 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4906 pSys->pCStringLit =
4907 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
4908 pSys->pIfParen =
4909 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4910 pSys->pBranchParen =
4911 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4912 pSys->pDoParen =
4913 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4914 pSys->pDoesParen =
4915 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4916 pSys->pQDoParen =
4917 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4918 pSys->pLoopParen =
4919 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4920 pSys->pPLoopParen =
4921 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4922 pSys->pInterpret =
4923 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4924 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
4925 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4926 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4927 dictAppendWord(dp, "(parse-step)",
4928 parseStepParen, FW_DEFAULT);
4929 pSys->pExitInner =
4930 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
4931
4932 /*
4933 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
4934 */
4935 pSys->pInterp[0] = pSys->pInterpret;
4936 pSys->pInterp[1] = pSys->pBranchParen;
4937 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
4938
4939 assert(dictCellsAvail(dp) > 0);
4940
4941 return;
4942}
4943
|