1afc2ba1dSToomas Soome /*
2afc2ba1dSToomas Soome * w o r d s . c
3afc2ba1dSToomas Soome * Forth Inspired Command Language
4afc2ba1dSToomas Soome * ANS Forth CORE word-set written in C
5afc2ba1dSToomas Soome * Author: John Sadler (john_sadler@alum.mit.edu)
6afc2ba1dSToomas Soome * Created: 19 July 1997
7afc2ba1dSToomas Soome * $Id: primitives.c,v 1.4 2010/09/13 18:43:04 asau Exp $
8afc2ba1dSToomas Soome */
9afc2ba1dSToomas Soome /*
10afc2ba1dSToomas Soome * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11afc2ba1dSToomas Soome * All rights reserved.
12afc2ba1dSToomas Soome *
13afc2ba1dSToomas Soome * Get the latest Ficl release at http://ficl.sourceforge.net
14afc2ba1dSToomas Soome *
15afc2ba1dSToomas Soome * I am interested in hearing from anyone who uses Ficl. If you have
16afc2ba1dSToomas Soome * a problem, a success story, a defect, an enhancement request, or
17afc2ba1dSToomas Soome * if you would like to contribute to the Ficl release, please
18afc2ba1dSToomas Soome * contact me by email at the address above.
19afc2ba1dSToomas Soome *
20afc2ba1dSToomas Soome * L I C E N S E and D I S C L A I M E R
21afc2ba1dSToomas Soome *
22afc2ba1dSToomas Soome * Redistribution and use in source and binary forms, with or without
23afc2ba1dSToomas Soome * modification, are permitted provided that the following conditions
24afc2ba1dSToomas Soome * are met:
25afc2ba1dSToomas Soome * 1. Redistributions of source code must retain the above copyright
26afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer.
27afc2ba1dSToomas Soome * 2. Redistributions in binary form must reproduce the above copyright
28afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer in the
29afc2ba1dSToomas Soome * documentation and/or other materials provided with the distribution.
30afc2ba1dSToomas Soome *
31afc2ba1dSToomas Soome * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32afc2ba1dSToomas Soome * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33afc2ba1dSToomas Soome * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34afc2ba1dSToomas Soome * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35afc2ba1dSToomas Soome * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36afc2ba1dSToomas Soome * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37afc2ba1dSToomas Soome * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38afc2ba1dSToomas Soome * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39afc2ba1dSToomas Soome * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40afc2ba1dSToomas Soome * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41afc2ba1dSToomas Soome * SUCH DAMAGE.
42afc2ba1dSToomas Soome */
43afc2ba1dSToomas Soome
44afc2ba1dSToomas Soome #include "ficl.h"
45afc2ba1dSToomas Soome #include <limits.h>
46afc2ba1dSToomas Soome
47afc2ba1dSToomas Soome /*
48afc2ba1dSToomas Soome * Control structure building words use these
49afc2ba1dSToomas Soome * strings' addresses as markers on the stack to
50afc2ba1dSToomas Soome * check for structure completion.
51afc2ba1dSToomas Soome */
52afc2ba1dSToomas Soome static char doTag[] = "do";
53afc2ba1dSToomas Soome static char colonTag[] = "colon";
54afc2ba1dSToomas Soome static char leaveTag[] = "leave";
55afc2ba1dSToomas Soome
56afc2ba1dSToomas Soome static char destTag[] = "target";
57afc2ba1dSToomas Soome static char origTag[] = "origin";
58afc2ba1dSToomas Soome
59afc2ba1dSToomas Soome static char caseTag[] = "case";
60afc2ba1dSToomas Soome static char ofTag[] = "of";
61afc2ba1dSToomas Soome static char fallthroughTag[] = "fallthrough";
62afc2ba1dSToomas Soome
63afc2ba1dSToomas Soome /*
64afc2ba1dSToomas Soome * C O N T R O L S T R U C T U R E B U I L D E R S
65afc2ba1dSToomas Soome *
66afc2ba1dSToomas Soome * Push current dictionary location for later branch resolution.
67afc2ba1dSToomas Soome * The location may be either a branch target or a patch address...
68afc2ba1dSToomas Soome */
69afc2ba1dSToomas Soome static void
markBranch(ficlDictionary * dictionary,ficlVm * vm,char * tag)70afc2ba1dSToomas Soome markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
71afc2ba1dSToomas Soome {
72afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here);
73afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, tag);
74afc2ba1dSToomas Soome }
75afc2ba1dSToomas Soome
76afc2ba1dSToomas Soome static void
markControlTag(ficlVm * vm,char * tag)77afc2ba1dSToomas Soome markControlTag(ficlVm *vm, char *tag)
78afc2ba1dSToomas Soome {
79afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, tag);
80afc2ba1dSToomas Soome }
81afc2ba1dSToomas Soome
82afc2ba1dSToomas Soome static void
matchControlTag(ficlVm * vm,char * wantTag)83afc2ba1dSToomas Soome matchControlTag(ficlVm *vm, char *wantTag)
84afc2ba1dSToomas Soome {
85afc2ba1dSToomas Soome char *tag;
86afc2ba1dSToomas Soome
87afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
88afc2ba1dSToomas Soome
89afc2ba1dSToomas Soome tag = (char *)ficlStackPopPointer(vm->dataStack);
90afc2ba1dSToomas Soome
91afc2ba1dSToomas Soome /*
92afc2ba1dSToomas Soome * Changed the code below to compare the pointers first
93afc2ba1dSToomas Soome * (by popular demand)
94afc2ba1dSToomas Soome */
95afc2ba1dSToomas Soome if ((tag != wantTag) && strcmp(tag, wantTag)) {
96afc2ba1dSToomas Soome ficlVmThrowError(vm,
97afc2ba1dSToomas Soome "Error -- unmatched control structure \"%s\"", wantTag);
98afc2ba1dSToomas Soome }
99afc2ba1dSToomas Soome }
100afc2ba1dSToomas Soome
101afc2ba1dSToomas Soome /*
102afc2ba1dSToomas Soome * Expect a branch target address on the param stack,
103afc2ba1dSToomas Soome * FICL_VM_STATE_COMPILE a literal offset from the current dictionary location
104afc2ba1dSToomas Soome * to the target address
105afc2ba1dSToomas Soome */
106afc2ba1dSToomas Soome static void
resolveBackBranch(ficlDictionary * dictionary,ficlVm * vm,char * tag)107afc2ba1dSToomas Soome resolveBackBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
108afc2ba1dSToomas Soome {
109afc2ba1dSToomas Soome ficlCell *patchAddr, c;
110afc2ba1dSToomas Soome
111afc2ba1dSToomas Soome matchControlTag(vm, tag);
112afc2ba1dSToomas Soome
113afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
114afc2ba1dSToomas Soome
115afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
116afc2ba1dSToomas Soome c.i = patchAddr - dictionary->here;
117afc2ba1dSToomas Soome
118afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, c);
119afc2ba1dSToomas Soome }
120afc2ba1dSToomas Soome
121afc2ba1dSToomas Soome /*
122afc2ba1dSToomas Soome * Expect a branch patch address on the param stack,
123afc2ba1dSToomas Soome * FICL_VM_STATE_COMPILE a literal offset from the patch location
124afc2ba1dSToomas Soome * to the current dictionary location
125afc2ba1dSToomas Soome */
126afc2ba1dSToomas Soome static void
resolveForwardBranch(ficlDictionary * dictionary,ficlVm * vm,char * tag)127afc2ba1dSToomas Soome resolveForwardBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
128afc2ba1dSToomas Soome {
129afc2ba1dSToomas Soome ficlInteger offset;
130afc2ba1dSToomas Soome ficlCell *patchAddr;
131afc2ba1dSToomas Soome
132afc2ba1dSToomas Soome matchControlTag(vm, tag);
133afc2ba1dSToomas Soome
134afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
135afc2ba1dSToomas Soome
136afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
137afc2ba1dSToomas Soome offset = dictionary->here - patchAddr;
138afc2ba1dSToomas Soome (*patchAddr).i = offset;
139afc2ba1dSToomas Soome }
140afc2ba1dSToomas Soome
141afc2ba1dSToomas Soome /*
142afc2ba1dSToomas Soome * Match the tag to the top of the stack. If success,
143afc2ba1dSToomas Soome * sopy "here" address into the ficlCell whose address is next
144afc2ba1dSToomas Soome * on the stack. Used by do..leave..loop.
145afc2ba1dSToomas Soome */
146afc2ba1dSToomas Soome static void
resolveAbsBranch(ficlDictionary * dictionary,ficlVm * vm,char * wantTag)147afc2ba1dSToomas Soome resolveAbsBranch(ficlDictionary *dictionary, ficlVm *vm, char *wantTag)
148afc2ba1dSToomas Soome {
149afc2ba1dSToomas Soome ficlCell *patchAddr;
150afc2ba1dSToomas Soome char *tag;
151afc2ba1dSToomas Soome
152afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
153afc2ba1dSToomas Soome
154afc2ba1dSToomas Soome tag = ficlStackPopPointer(vm->dataStack);
155afc2ba1dSToomas Soome
156afc2ba1dSToomas Soome /*
157afc2ba1dSToomas Soome * Changed the comparison below to compare the pointers first
158afc2ba1dSToomas Soome * (by popular demand)
159afc2ba1dSToomas Soome */
160afc2ba1dSToomas Soome if ((tag != wantTag) && strcmp(tag, wantTag)) {
161afc2ba1dSToomas Soome ficlVmTextOut(vm, "Warning -- Unmatched control word: ");
162afc2ba1dSToomas Soome ficlVmTextOut(vm, wantTag);
163afc2ba1dSToomas Soome ficlVmTextOut(vm, "\n");
164afc2ba1dSToomas Soome }
165afc2ba1dSToomas Soome
166afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
167afc2ba1dSToomas Soome (*patchAddr).p = dictionary->here;
168afc2ba1dSToomas Soome }
169afc2ba1dSToomas Soome
170afc2ba1dSToomas Soome /*
171afc2ba1dSToomas Soome * c o l o n d e f i n i t i o n s
172afc2ba1dSToomas Soome * Code to begin compiling a colon definition
173afc2ba1dSToomas Soome * This function sets the state to FICL_VM_STATE_COMPILE, then creates a
174afc2ba1dSToomas Soome * new word whose name is the next word in the input stream
175afc2ba1dSToomas Soome * and whose code is colonParen.
176afc2ba1dSToomas Soome */
177afc2ba1dSToomas Soome static void
ficlPrimitiveColon(ficlVm * vm)178afc2ba1dSToomas Soome ficlPrimitiveColon(ficlVm *vm)
179afc2ba1dSToomas Soome {
180afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
181afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
182afc2ba1dSToomas Soome
183afc2ba1dSToomas Soome vm->state = FICL_VM_STATE_COMPILE;
184afc2ba1dSToomas Soome markControlTag(vm, colonTag);
185*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
186afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionColonParen,
187afc2ba1dSToomas Soome FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
188afc2ba1dSToomas Soome
189afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
190afc2ba1dSToomas Soome vm->callback.system->localsCount = 0;
191afc2ba1dSToomas Soome #endif
192afc2ba1dSToomas Soome }
193afc2ba1dSToomas Soome
194afc2ba1dSToomas Soome static void
ficlPrimitiveSemicolonCoIm(ficlVm * vm)195afc2ba1dSToomas Soome ficlPrimitiveSemicolonCoIm(ficlVm *vm)
196afc2ba1dSToomas Soome {
197afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
198afc2ba1dSToomas Soome
199afc2ba1dSToomas Soome matchControlTag(vm, colonTag);
200afc2ba1dSToomas Soome
201afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
202afc2ba1dSToomas Soome if (vm->callback.system->localsCount > 0) {
203afc2ba1dSToomas Soome ficlDictionary *locals;
204afc2ba1dSToomas Soome locals = ficlSystemGetLocals(vm->callback.system);
205afc2ba1dSToomas Soome ficlDictionaryEmpty(locals, locals->forthWordlist->size);
206afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
207afc2ba1dSToomas Soome ficlInstructionUnlinkParen);
208afc2ba1dSToomas Soome }
209afc2ba1dSToomas Soome vm->callback.system->localsCount = 0;
210afc2ba1dSToomas Soome #endif
211afc2ba1dSToomas Soome
212afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen);
213afc2ba1dSToomas Soome vm->state = FICL_VM_STATE_INTERPRET;
214afc2ba1dSToomas Soome ficlDictionaryUnsmudge(dictionary);
215afc2ba1dSToomas Soome }
216afc2ba1dSToomas Soome
217afc2ba1dSToomas Soome /*
218afc2ba1dSToomas Soome * e x i t
219afc2ba1dSToomas Soome * CORE
220afc2ba1dSToomas Soome * This function simply pops the previous instruction
221afc2ba1dSToomas Soome * pointer and returns to the "next" loop. Used for exiting from within
222afc2ba1dSToomas Soome * a definition. Note that exitParen is identical to semiParen - they
223afc2ba1dSToomas Soome * are in two different functions so that "see" can correctly identify
224afc2ba1dSToomas Soome * the end of a colon definition, even if it uses "exit".
225afc2ba1dSToomas Soome */
226afc2ba1dSToomas Soome static void
ficlPrimitiveExitCoIm(ficlVm * vm)227afc2ba1dSToomas Soome ficlPrimitiveExitCoIm(ficlVm *vm)
228afc2ba1dSToomas Soome {
229afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
230afc2ba1dSToomas Soome FICL_IGNORE(vm);
231afc2ba1dSToomas Soome
232afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
233afc2ba1dSToomas Soome if (vm->callback.system->localsCount > 0) {
234afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
235afc2ba1dSToomas Soome ficlInstructionUnlinkParen);
236afc2ba1dSToomas Soome }
237afc2ba1dSToomas Soome #endif
238afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen);
239afc2ba1dSToomas Soome }
240afc2ba1dSToomas Soome
241afc2ba1dSToomas Soome /*
242afc2ba1dSToomas Soome * c o n s t a n t
243afc2ba1dSToomas Soome * IMMEDIATE
244afc2ba1dSToomas Soome * Compiles a constant into the dictionary. Constants return their
245afc2ba1dSToomas Soome * value when invoked. Expects a value on top of the parm stack.
246afc2ba1dSToomas Soome */
247afc2ba1dSToomas Soome static void
ficlPrimitiveConstant(ficlVm * vm)248afc2ba1dSToomas Soome ficlPrimitiveConstant(ficlVm *vm)
249afc2ba1dSToomas Soome {
250afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
251afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
252afc2ba1dSToomas Soome
253afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
254afc2ba1dSToomas Soome
255*c0bb4f73SToomas Soome (void) ficlDictionaryAppendConstantInstruction(dictionary, name,
256afc2ba1dSToomas Soome ficlInstructionConstantParen, ficlStackPopInteger(vm->dataStack));
257afc2ba1dSToomas Soome }
258afc2ba1dSToomas Soome
259afc2ba1dSToomas Soome static void
ficlPrimitive2Constant(ficlVm * vm)260afc2ba1dSToomas Soome ficlPrimitive2Constant(ficlVm *vm)
261afc2ba1dSToomas Soome {
262afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
263afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
264afc2ba1dSToomas Soome
265afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
266afc2ba1dSToomas Soome
267*c0bb4f73SToomas Soome (void) ficlDictionaryAppend2ConstantInstruction(dictionary, name,
268afc2ba1dSToomas Soome ficlInstruction2ConstantParen, ficlStackPop2Integer(vm->dataStack));
269afc2ba1dSToomas Soome }
270afc2ba1dSToomas Soome
271afc2ba1dSToomas Soome /*
272afc2ba1dSToomas Soome * d i s p l a y C e l l
273afc2ba1dSToomas Soome * Drop and print the contents of the ficlCell at the top of the param
274afc2ba1dSToomas Soome * stack
275afc2ba1dSToomas Soome */
276afc2ba1dSToomas Soome static void
ficlPrimitiveDot(ficlVm * vm)277afc2ba1dSToomas Soome ficlPrimitiveDot(ficlVm *vm)
278afc2ba1dSToomas Soome {
279afc2ba1dSToomas Soome ficlCell c;
280afc2ba1dSToomas Soome
281afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
282afc2ba1dSToomas Soome
283afc2ba1dSToomas Soome c = ficlStackPop(vm->dataStack);
284*c0bb4f73SToomas Soome (void) ficlLtoa((c).i, vm->pad, vm->base);
285*c0bb4f73SToomas Soome (void) strcat(vm->pad, " ");
286afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad);
287afc2ba1dSToomas Soome }
288afc2ba1dSToomas Soome
289afc2ba1dSToomas Soome static void
ficlPrimitiveUDot(ficlVm * vm)290afc2ba1dSToomas Soome ficlPrimitiveUDot(ficlVm *vm)
291afc2ba1dSToomas Soome {
292afc2ba1dSToomas Soome ficlUnsigned u;
293afc2ba1dSToomas Soome
294afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
295afc2ba1dSToomas Soome
296afc2ba1dSToomas Soome u = ficlStackPopUnsigned(vm->dataStack);
297*c0bb4f73SToomas Soome (void) ficlUltoa(u, vm->pad, vm->base);
298*c0bb4f73SToomas Soome (void) strcat(vm->pad, " ");
299afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad);
300afc2ba1dSToomas Soome }
301afc2ba1dSToomas Soome
302afc2ba1dSToomas Soome static void
ficlPrimitiveHexDot(ficlVm * vm)303afc2ba1dSToomas Soome ficlPrimitiveHexDot(ficlVm *vm)
304afc2ba1dSToomas Soome {
305afc2ba1dSToomas Soome ficlUnsigned u;
306afc2ba1dSToomas Soome
307afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
308afc2ba1dSToomas Soome
309afc2ba1dSToomas Soome u = ficlStackPopUnsigned(vm->dataStack);
310*c0bb4f73SToomas Soome (void) ficlUltoa(u, vm->pad, 16);
311*c0bb4f73SToomas Soome (void) strcat(vm->pad, " ");
312afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad);
313afc2ba1dSToomas Soome }
314afc2ba1dSToomas Soome
315afc2ba1dSToomas Soome /*
316afc2ba1dSToomas Soome * s t r l e n
317afc2ba1dSToomas Soome * Ficl ( c-string -- length )
318afc2ba1dSToomas Soome *
319afc2ba1dSToomas Soome * Returns the length of a C-style (zero-terminated) string.
320afc2ba1dSToomas Soome *
321afc2ba1dSToomas Soome * --lch
322afc2ba1dSToomas Soome */
323afc2ba1dSToomas Soome static void
ficlPrimitiveStrlen(ficlVm * vm)324afc2ba1dSToomas Soome ficlPrimitiveStrlen(ficlVm *vm)
325afc2ba1dSToomas Soome {
326afc2ba1dSToomas Soome char *address = (char *)ficlStackPopPointer(vm->dataStack);
327afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, strlen(address));
328afc2ba1dSToomas Soome }
329afc2ba1dSToomas Soome
330afc2ba1dSToomas Soome /*
331afc2ba1dSToomas Soome * s p r i n t f
332afc2ba1dSToomas Soome * Ficl ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer --
333afc2ba1dSToomas Soome * c-addr-buffer u-written success-flag )
334afc2ba1dSToomas Soome * Similar to the C sprintf() function. It formats into a buffer based on
335afc2ba1dSToomas Soome * a "format" string. Each character in the format string is copied verbatim
336afc2ba1dSToomas Soome * to the output buffer, until SPRINTF encounters a percent sign ("%").
337afc2ba1dSToomas Soome * SPRINTF then skips the percent sign, and examines the next character
338afc2ba1dSToomas Soome * (the "format character"). Here are the valid format characters:
339afc2ba1dSToomas Soome * s - read a C-ADDR U-LENGTH string from the stack and copy it to
340afc2ba1dSToomas Soome * the buffer
341afc2ba1dSToomas Soome * d - read a ficlCell from the stack, format it as a string (base-10,
342afc2ba1dSToomas Soome * signed), and copy it to the buffer
343afc2ba1dSToomas Soome * x - same as d, except in base-16
344afc2ba1dSToomas Soome * u - same as d, but unsigned
345afc2ba1dSToomas Soome * % - output a literal percent-sign to the buffer
346afc2ba1dSToomas Soome * SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
347afc2ba1dSToomas Soome * written, and a flag indicating whether or not it ran out of space while
348afc2ba1dSToomas Soome * writing to the output buffer (FICL_TRUE if it ran out of space).
349afc2ba1dSToomas Soome *
350afc2ba1dSToomas Soome * If SPRINTF runs out of space in the buffer to store the formatted string,
351afc2ba1dSToomas Soome * it still continues parsing, in an effort to preserve your stack (otherwise
352afc2ba1dSToomas Soome * it might leave uneaten arguments behind).
353afc2ba1dSToomas Soome *
354afc2ba1dSToomas Soome * --lch
355afc2ba1dSToomas Soome */
356afc2ba1dSToomas Soome static void
ficlPrimitiveSprintf(ficlVm * vm)357afc2ba1dSToomas Soome ficlPrimitiveSprintf(ficlVm *vm)
358afc2ba1dSToomas Soome {
359afc2ba1dSToomas Soome int bufferLength = ficlStackPopInteger(vm->dataStack);
360afc2ba1dSToomas Soome char *buffer = (char *)ficlStackPopPointer(vm->dataStack);
361afc2ba1dSToomas Soome char *bufferStart = buffer;
362afc2ba1dSToomas Soome
363afc2ba1dSToomas Soome int formatLength = ficlStackPopInteger(vm->dataStack);
364afc2ba1dSToomas Soome char *format = (char *)ficlStackPopPointer(vm->dataStack);
365afc2ba1dSToomas Soome char *formatStop = format + formatLength;
366afc2ba1dSToomas Soome
367afc2ba1dSToomas Soome int base = 10;
368afc2ba1dSToomas Soome int unsignedInteger = 0; /* false */
369afc2ba1dSToomas Soome
370afc2ba1dSToomas Soome int append = 1; /* true */
371afc2ba1dSToomas Soome
372afc2ba1dSToomas Soome while (format < formatStop) {
373afc2ba1dSToomas Soome char scratch[64];
374afc2ba1dSToomas Soome char *source;
375afc2ba1dSToomas Soome int actualLength;
376afc2ba1dSToomas Soome int desiredLength;
377afc2ba1dSToomas Soome int leadingZeroes;
378afc2ba1dSToomas Soome
379afc2ba1dSToomas Soome if (*format != '%') {
380afc2ba1dSToomas Soome source = format;
381afc2ba1dSToomas Soome actualLength = desiredLength = 1;
382afc2ba1dSToomas Soome leadingZeroes = 0;
383afc2ba1dSToomas Soome } else {
384afc2ba1dSToomas Soome format++;
385afc2ba1dSToomas Soome if (format == formatStop)
386afc2ba1dSToomas Soome break;
387afc2ba1dSToomas Soome
388afc2ba1dSToomas Soome leadingZeroes = (*format == '0');
389afc2ba1dSToomas Soome if (leadingZeroes) {
390afc2ba1dSToomas Soome format++;
391afc2ba1dSToomas Soome if (format == formatStop)
392afc2ba1dSToomas Soome break;
393afc2ba1dSToomas Soome }
394afc2ba1dSToomas Soome
395afc2ba1dSToomas Soome desiredLength = isdigit((unsigned char)*format);
396afc2ba1dSToomas Soome if (desiredLength) {
397afc2ba1dSToomas Soome desiredLength = strtoul(format, &format, 10);
398afc2ba1dSToomas Soome if (format == formatStop)
399afc2ba1dSToomas Soome break;
400afc2ba1dSToomas Soome } else if (*format == '*') {
401afc2ba1dSToomas Soome desiredLength =
402afc2ba1dSToomas Soome ficlStackPopInteger(vm->dataStack);
403afc2ba1dSToomas Soome
404afc2ba1dSToomas Soome format++;
405afc2ba1dSToomas Soome if (format == formatStop)
406afc2ba1dSToomas Soome break;
407afc2ba1dSToomas Soome }
408afc2ba1dSToomas Soome
409afc2ba1dSToomas Soome switch (*format) {
410afc2ba1dSToomas Soome case 's':
411afc2ba1dSToomas Soome case 'S':
412afc2ba1dSToomas Soome actualLength =
413afc2ba1dSToomas Soome ficlStackPopInteger(vm->dataStack);
414afc2ba1dSToomas Soome source = (char *)
415afc2ba1dSToomas Soome ficlStackPopPointer(vm->dataStack);
416afc2ba1dSToomas Soome break;
417afc2ba1dSToomas Soome case 'x':
418afc2ba1dSToomas Soome case 'X':
419afc2ba1dSToomas Soome base = 16;
420d65dfb0aSToomas Soome /* FALLTHROUGH */
421afc2ba1dSToomas Soome case 'u':
422afc2ba1dSToomas Soome case 'U':
423afc2ba1dSToomas Soome unsignedInteger = 1; /* true */
424d65dfb0aSToomas Soome /* FALLTHROUGH */
425afc2ba1dSToomas Soome case 'd':
426afc2ba1dSToomas Soome case 'D': {
427afc2ba1dSToomas Soome int integer;
428afc2ba1dSToomas Soome integer = ficlStackPopInteger(vm->dataStack);
429afc2ba1dSToomas Soome if (unsignedInteger)
430*c0bb4f73SToomas Soome (void) ficlUltoa(integer, scratch,
431*c0bb4f73SToomas Soome base);
432afc2ba1dSToomas Soome else
433*c0bb4f73SToomas Soome (void) ficlLtoa(integer, scratch, base);
434afc2ba1dSToomas Soome base = 10;
435afc2ba1dSToomas Soome unsignedInteger = 0; /* false */
436afc2ba1dSToomas Soome source = scratch;
437afc2ba1dSToomas Soome actualLength = strlen(scratch);
438afc2ba1dSToomas Soome break;
439afc2ba1dSToomas Soome }
440afc2ba1dSToomas Soome case '%':
441afc2ba1dSToomas Soome source = format;
442afc2ba1dSToomas Soome actualLength = 1;
443d65dfb0aSToomas Soome /* FALLTHROUGH */
444afc2ba1dSToomas Soome default:
445afc2ba1dSToomas Soome continue;
446afc2ba1dSToomas Soome }
447afc2ba1dSToomas Soome }
448afc2ba1dSToomas Soome
449afc2ba1dSToomas Soome if (append) {
450afc2ba1dSToomas Soome if (!desiredLength)
451afc2ba1dSToomas Soome desiredLength = actualLength;
452afc2ba1dSToomas Soome if (desiredLength > bufferLength) {
453afc2ba1dSToomas Soome append = 0; /* false */
454afc2ba1dSToomas Soome desiredLength = bufferLength;
455afc2ba1dSToomas Soome }
456afc2ba1dSToomas Soome while (desiredLength > actualLength) {
457afc2ba1dSToomas Soome *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
458afc2ba1dSToomas Soome bufferLength--;
459afc2ba1dSToomas Soome desiredLength--;
460afc2ba1dSToomas Soome }
461afc2ba1dSToomas Soome memcpy(buffer, source, actualLength);
462afc2ba1dSToomas Soome buffer += actualLength;
463afc2ba1dSToomas Soome bufferLength -= actualLength;
464afc2ba1dSToomas Soome }
465afc2ba1dSToomas Soome
466afc2ba1dSToomas Soome format++;
467afc2ba1dSToomas Soome }
468afc2ba1dSToomas Soome
469afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, bufferStart);
470afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, buffer - bufferStart);
471afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, FICL_BOOL(!append));
472afc2ba1dSToomas Soome }
473afc2ba1dSToomas Soome
474afc2ba1dSToomas Soome /*
475afc2ba1dSToomas Soome * d u p & f r i e n d s
476afc2ba1dSToomas Soome */
477afc2ba1dSToomas Soome static void
ficlPrimitiveDepth(ficlVm * vm)478afc2ba1dSToomas Soome ficlPrimitiveDepth(ficlVm *vm)
479afc2ba1dSToomas Soome {
480afc2ba1dSToomas Soome int i;
481afc2ba1dSToomas Soome
482afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
483afc2ba1dSToomas Soome
484afc2ba1dSToomas Soome i = ficlStackDepth(vm->dataStack);
485afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, i);
486afc2ba1dSToomas Soome }
487afc2ba1dSToomas Soome
488afc2ba1dSToomas Soome /*
489afc2ba1dSToomas Soome * e m i t & f r i e n d s
490afc2ba1dSToomas Soome */
491afc2ba1dSToomas Soome static void
ficlPrimitiveEmit(ficlVm * vm)492afc2ba1dSToomas Soome ficlPrimitiveEmit(ficlVm *vm)
493afc2ba1dSToomas Soome {
494afc2ba1dSToomas Soome char buffer[2];
495afc2ba1dSToomas Soome int i;
496afc2ba1dSToomas Soome
497afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
498afc2ba1dSToomas Soome
499afc2ba1dSToomas Soome i = ficlStackPopInteger(vm->dataStack);
500afc2ba1dSToomas Soome buffer[0] = (char)i;
501afc2ba1dSToomas Soome buffer[1] = '\0';
502afc2ba1dSToomas Soome ficlVmTextOut(vm, buffer);
503afc2ba1dSToomas Soome }
504afc2ba1dSToomas Soome
505afc2ba1dSToomas Soome static void
ficlPrimitiveCR(ficlVm * vm)506afc2ba1dSToomas Soome ficlPrimitiveCR(ficlVm *vm)
507afc2ba1dSToomas Soome {
508afc2ba1dSToomas Soome ficlVmTextOut(vm, "\n");
509afc2ba1dSToomas Soome }
510afc2ba1dSToomas Soome
511afc2ba1dSToomas Soome static void
ficlPrimitiveBackslash(ficlVm * vm)512afc2ba1dSToomas Soome ficlPrimitiveBackslash(ficlVm *vm)
513afc2ba1dSToomas Soome {
514afc2ba1dSToomas Soome char *trace = ficlVmGetInBuf(vm);
515afc2ba1dSToomas Soome char *stop = ficlVmGetInBufEnd(vm);
516afc2ba1dSToomas Soome char c = *trace;
517afc2ba1dSToomas Soome
518afc2ba1dSToomas Soome while ((trace != stop) && (c != '\r') && (c != '\n')) {
519afc2ba1dSToomas Soome c = *++trace;
520afc2ba1dSToomas Soome }
521afc2ba1dSToomas Soome
522afc2ba1dSToomas Soome /*
523afc2ba1dSToomas Soome * Cope with DOS or UNIX-style EOLs -
524afc2ba1dSToomas Soome * Check for /r, /n, /r/n, or /n/r end-of-line sequences,
525afc2ba1dSToomas Soome * and point trace to next char. If EOL is \0, we're done.
526afc2ba1dSToomas Soome */
527afc2ba1dSToomas Soome if (trace != stop) {
528afc2ba1dSToomas Soome trace++;
529afc2ba1dSToomas Soome
530afc2ba1dSToomas Soome if ((trace != stop) && (c != *trace) &&
531afc2ba1dSToomas Soome ((*trace == '\r') || (*trace == '\n')))
532afc2ba1dSToomas Soome trace++;
533afc2ba1dSToomas Soome }
534afc2ba1dSToomas Soome
535afc2ba1dSToomas Soome ficlVmUpdateTib(vm, trace);
536afc2ba1dSToomas Soome }
537afc2ba1dSToomas Soome
538afc2ba1dSToomas Soome /*
539afc2ba1dSToomas Soome * paren CORE
540afc2ba1dSToomas Soome * Compilation: Perform the execution semantics given below.
541afc2ba1dSToomas Soome * Execution: ( "ccc<paren>" -- )
542afc2ba1dSToomas Soome * Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
543afc2ba1dSToomas Soome * The number of characters in ccc may be zero to the number of characters
544afc2ba1dSToomas Soome * in the parse area.
545afc2ba1dSToomas Soome */
546afc2ba1dSToomas Soome static void
ficlPrimitiveParenthesis(ficlVm * vm)547afc2ba1dSToomas Soome ficlPrimitiveParenthesis(ficlVm *vm)
548afc2ba1dSToomas Soome {
549*c0bb4f73SToomas Soome (void) ficlVmParseStringEx(vm, ')', 0);
550afc2ba1dSToomas Soome }
551afc2ba1dSToomas Soome
552afc2ba1dSToomas Soome /*
553afc2ba1dSToomas Soome * F E T C H & S T O R E
554afc2ba1dSToomas Soome */
555afc2ba1dSToomas Soome
556afc2ba1dSToomas Soome /*
557afc2ba1dSToomas Soome * i f C o I m
558afc2ba1dSToomas Soome * IMMEDIATE
559afc2ba1dSToomas Soome * Compiles code for a conditional branch into the dictionary
560afc2ba1dSToomas Soome * and pushes the branch patch address on the stack for later
561afc2ba1dSToomas Soome * patching by ELSE or THEN/ENDIF.
562afc2ba1dSToomas Soome */
563afc2ba1dSToomas Soome static void
ficlPrimitiveIfCoIm(ficlVm * vm)564afc2ba1dSToomas Soome ficlPrimitiveIfCoIm(ficlVm *vm)
565afc2ba1dSToomas Soome {
566afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
567afc2ba1dSToomas Soome
568afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
569afc2ba1dSToomas Soome ficlInstructionBranch0ParenWithCheck);
570afc2ba1dSToomas Soome markBranch(dictionary, vm, origTag);
571afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1);
572afc2ba1dSToomas Soome }
573afc2ba1dSToomas Soome
574afc2ba1dSToomas Soome /*
575afc2ba1dSToomas Soome * e l s e C o I m
576afc2ba1dSToomas Soome *
577afc2ba1dSToomas Soome * IMMEDIATE -- compiles an "else"...
578afc2ba1dSToomas Soome * 1) FICL_VM_STATE_COMPILE a branch and a patch address;
579afc2ba1dSToomas Soome * the address gets patched
580afc2ba1dSToomas Soome * by "endif" to point past the "else" code.
581afc2ba1dSToomas Soome * 2) Pop the the "if" patch address
582afc2ba1dSToomas Soome * 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE
583afc2ba1dSToomas Soome * address.
584afc2ba1dSToomas Soome * 4) Push the "else" patch address. ("endif" patches this to jump past
585afc2ba1dSToomas Soome * the "else" code.
586afc2ba1dSToomas Soome */
587afc2ba1dSToomas Soome static void
ficlPrimitiveElseCoIm(ficlVm * vm)588afc2ba1dSToomas Soome ficlPrimitiveElseCoIm(ficlVm *vm)
589afc2ba1dSToomas Soome {
590afc2ba1dSToomas Soome ficlCell *patchAddr;
591afc2ba1dSToomas Soome ficlInteger offset;
592afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
593afc2ba1dSToomas Soome
594afc2ba1dSToomas Soome /* (1) FICL_VM_STATE_COMPILE branch runtime */
595afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
596afc2ba1dSToomas Soome ficlInstructionBranchParenWithCheck);
597afc2ba1dSToomas Soome
598afc2ba1dSToomas Soome matchControlTag(vm, origTag);
599afc2ba1dSToomas Soome /* (2) pop "if" patch addr */
600afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
601afc2ba1dSToomas Soome markBranch(dictionary, vm, origTag); /* (4) push "else" patch addr */
602afc2ba1dSToomas Soome
603afc2ba1dSToomas Soome /* (1) FICL_VM_STATE_COMPILE patch placeholder */
604afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1);
605afc2ba1dSToomas Soome offset = dictionary->here - patchAddr;
606afc2ba1dSToomas Soome (*patchAddr).i = offset; /* (3) Patch "if" */
607afc2ba1dSToomas Soome }
608afc2ba1dSToomas Soome
609afc2ba1dSToomas Soome /*
610afc2ba1dSToomas Soome * e n d i f C o I m
611afc2ba1dSToomas Soome */
612afc2ba1dSToomas Soome static void
ficlPrimitiveEndifCoIm(ficlVm * vm)613afc2ba1dSToomas Soome ficlPrimitiveEndifCoIm(ficlVm *vm)
614afc2ba1dSToomas Soome {
615afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
616afc2ba1dSToomas Soome resolveForwardBranch(dictionary, vm, origTag);
617afc2ba1dSToomas Soome }
618afc2ba1dSToomas Soome
619afc2ba1dSToomas Soome /*
620afc2ba1dSToomas Soome * c a s e C o I m
621afc2ba1dSToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
622afc2ba1dSToomas Soome *
623afc2ba1dSToomas Soome *
624afc2ba1dSToomas Soome * At FICL_VM_STATE_COMPILE-time, a CASE-SYS (see DPANS94 6.2.0873) looks
625afc2ba1dSToomas Soome * like this:
626afc2ba1dSToomas Soome * i*addr i caseTag
627afc2ba1dSToomas Soome * and an OF-SYS (see DPANS94 6.2.1950) looks like this:
628afc2ba1dSToomas Soome * i*addr i caseTag addr ofTag
629afc2ba1dSToomas Soome * The integer under caseTag is the count of fixup addresses that branch
630afc2ba1dSToomas Soome * to ENDCASE.
631afc2ba1dSToomas Soome */
632afc2ba1dSToomas Soome static void
ficlPrimitiveCaseCoIm(ficlVm * vm)633afc2ba1dSToomas Soome ficlPrimitiveCaseCoIm(ficlVm *vm)
634afc2ba1dSToomas Soome {
635afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 2);
636afc2ba1dSToomas Soome
637afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, 0);
638afc2ba1dSToomas Soome markControlTag(vm, caseTag);
639afc2ba1dSToomas Soome }
640afc2ba1dSToomas Soome
641afc2ba1dSToomas Soome /*
642afc2ba1dSToomas Soome * e n d c a s eC o I m
643afc2ba1dSToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
644afc2ba1dSToomas Soome */
645afc2ba1dSToomas Soome static void
ficlPrimitiveEndcaseCoIm(ficlVm * vm)646afc2ba1dSToomas Soome ficlPrimitiveEndcaseCoIm(ficlVm *vm)
647afc2ba1dSToomas Soome {
648afc2ba1dSToomas Soome ficlUnsigned fixupCount;
649afc2ba1dSToomas Soome ficlDictionary *dictionary;
650afc2ba1dSToomas Soome ficlCell *patchAddr;
651afc2ba1dSToomas Soome ficlInteger offset;
652afc2ba1dSToomas Soome
653afc2ba1dSToomas Soome /*
654afc2ba1dSToomas Soome * if the last OF ended with FALLTHROUGH,
655afc2ba1dSToomas Soome * just add the FALLTHROUGH fixup to the
656afc2ba1dSToomas Soome * ENDOF fixups
657afc2ba1dSToomas Soome */
658afc2ba1dSToomas Soome if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) {
659afc2ba1dSToomas Soome matchControlTag(vm, fallthroughTag);
660afc2ba1dSToomas Soome patchAddr = ficlStackPopPointer(vm->dataStack);
661afc2ba1dSToomas Soome matchControlTag(vm, caseTag);
662afc2ba1dSToomas Soome fixupCount = ficlStackPopUnsigned(vm->dataStack);
663afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, patchAddr);
664afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
665afc2ba1dSToomas Soome markControlTag(vm, caseTag);
666afc2ba1dSToomas Soome }
667afc2ba1dSToomas Soome
668afc2ba1dSToomas Soome matchControlTag(vm, caseTag);
669afc2ba1dSToomas Soome
670afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
671afc2ba1dSToomas Soome
672afc2ba1dSToomas Soome fixupCount = ficlStackPopUnsigned(vm->dataStack);
673afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, fixupCount, 0);
674afc2ba1dSToomas Soome
675afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
676afc2ba1dSToomas Soome
677afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop);
678afc2ba1dSToomas Soome
679afc2ba1dSToomas Soome while (fixupCount--) {
680afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
681afc2ba1dSToomas Soome offset = dictionary->here - patchAddr;
682afc2ba1dSToomas Soome (*patchAddr).i = offset;
683afc2ba1dSToomas Soome }
684afc2ba1dSToomas Soome }
685afc2ba1dSToomas Soome
686afc2ba1dSToomas Soome /*
687afc2ba1dSToomas Soome * o f C o I m
688afc2ba1dSToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
689afc2ba1dSToomas Soome */
690afc2ba1dSToomas Soome static void
ficlPrimitiveOfCoIm(ficlVm * vm)691afc2ba1dSToomas Soome ficlPrimitiveOfCoIm(ficlVm *vm)
692afc2ba1dSToomas Soome {
693afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
694afc2ba1dSToomas Soome ficlCell *fallthroughFixup = NULL;
695afc2ba1dSToomas Soome
696afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 3);
697afc2ba1dSToomas Soome
698afc2ba1dSToomas Soome if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) {
699afc2ba1dSToomas Soome matchControlTag(vm, fallthroughTag);
700afc2ba1dSToomas Soome fallthroughFixup = ficlStackPopPointer(vm->dataStack);
701afc2ba1dSToomas Soome }
702afc2ba1dSToomas Soome
703afc2ba1dSToomas Soome matchControlTag(vm, caseTag);
704afc2ba1dSToomas Soome
705afc2ba1dSToomas Soome markControlTag(vm, caseTag);
706afc2ba1dSToomas Soome
707afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionOfParen);
708afc2ba1dSToomas Soome markBranch(dictionary, vm, ofTag);
709afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2);
710afc2ba1dSToomas Soome
711afc2ba1dSToomas Soome if (fallthroughFixup != NULL) {
712afc2ba1dSToomas Soome ficlInteger offset = dictionary->here - fallthroughFixup;
713afc2ba1dSToomas Soome (*fallthroughFixup).i = offset;
714afc2ba1dSToomas Soome }
715afc2ba1dSToomas Soome }
716afc2ba1dSToomas Soome
717afc2ba1dSToomas Soome /*
718afc2ba1dSToomas Soome * e n d o f C o I m
719afc2ba1dSToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
720afc2ba1dSToomas Soome */
721afc2ba1dSToomas Soome static void
ficlPrimitiveEndofCoIm(ficlVm * vm)722afc2ba1dSToomas Soome ficlPrimitiveEndofCoIm(ficlVm *vm)
723afc2ba1dSToomas Soome {
724afc2ba1dSToomas Soome ficlCell *patchAddr;
725afc2ba1dSToomas Soome ficlUnsigned fixupCount;
726afc2ba1dSToomas Soome ficlInteger offset;
727afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
728afc2ba1dSToomas Soome
729afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 4, 3);
730afc2ba1dSToomas Soome
731afc2ba1dSToomas Soome /* ensure we're in an OF, */
732afc2ba1dSToomas Soome matchControlTag(vm, ofTag);
733afc2ba1dSToomas Soome
734afc2ba1dSToomas Soome /* grab the address of the branch location after the OF */
735afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
736afc2ba1dSToomas Soome /* ensure we're also in a "case" */
737afc2ba1dSToomas Soome matchControlTag(vm, caseTag);
738afc2ba1dSToomas Soome /* grab the current number of ENDOF fixups */
739afc2ba1dSToomas Soome fixupCount = ficlStackPopUnsigned(vm->dataStack);
740afc2ba1dSToomas Soome
741afc2ba1dSToomas Soome /* FICL_VM_STATE_COMPILE branch runtime */
742afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
743afc2ba1dSToomas Soome ficlInstructionBranchParenWithCheck);
744afc2ba1dSToomas Soome
745afc2ba1dSToomas Soome /*
746afc2ba1dSToomas Soome * push a new ENDOF fixup, the updated count of ENDOF fixups,
747afc2ba1dSToomas Soome * and the caseTag
748afc2ba1dSToomas Soome */
749afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here);
750afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
751afc2ba1dSToomas Soome markControlTag(vm, caseTag);
752afc2ba1dSToomas Soome
753afc2ba1dSToomas Soome /* reserve space for the ENDOF fixup */
754afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2);
755afc2ba1dSToomas Soome
756afc2ba1dSToomas Soome /* and patch the original OF */
757afc2ba1dSToomas Soome offset = dictionary->here - patchAddr;
758afc2ba1dSToomas Soome (*patchAddr).i = offset;
759afc2ba1dSToomas Soome }
760afc2ba1dSToomas Soome
761afc2ba1dSToomas Soome /*
762afc2ba1dSToomas Soome * f a l l t h r o u g h C o I m
763afc2ba1dSToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
764afc2ba1dSToomas Soome */
765afc2ba1dSToomas Soome static void
ficlPrimitiveFallthroughCoIm(ficlVm * vm)766afc2ba1dSToomas Soome ficlPrimitiveFallthroughCoIm(ficlVm *vm)
767afc2ba1dSToomas Soome {
768afc2ba1dSToomas Soome ficlCell *patchAddr;
769afc2ba1dSToomas Soome ficlInteger offset;
770afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
771afc2ba1dSToomas Soome
772afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 4, 3);
773afc2ba1dSToomas Soome
774afc2ba1dSToomas Soome /* ensure we're in an OF, */
775afc2ba1dSToomas Soome matchControlTag(vm, ofTag);
776afc2ba1dSToomas Soome /* grab the address of the branch location after the OF */
777afc2ba1dSToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
778afc2ba1dSToomas Soome /* ensure we're also in a "case" */
779afc2ba1dSToomas Soome matchControlTag(vm, caseTag);
780afc2ba1dSToomas Soome
781afc2ba1dSToomas Soome /* okay, here we go. put the case tag back. */
782afc2ba1dSToomas Soome markControlTag(vm, caseTag);
783afc2ba1dSToomas Soome
784afc2ba1dSToomas Soome /* FICL_VM_STATE_COMPILE branch runtime */
785afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
786afc2ba1dSToomas Soome ficlInstructionBranchParenWithCheck);
787afc2ba1dSToomas Soome
788afc2ba1dSToomas Soome /* push a new FALLTHROUGH fixup and the fallthroughTag */
789afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here);
790afc2ba1dSToomas Soome markControlTag(vm, fallthroughTag);
791afc2ba1dSToomas Soome
792afc2ba1dSToomas Soome /* reserve space for the FALLTHROUGH fixup */
793afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2);
794afc2ba1dSToomas Soome
795afc2ba1dSToomas Soome /* and patch the original OF */
796afc2ba1dSToomas Soome offset = dictionary->here - patchAddr;
797afc2ba1dSToomas Soome (*patchAddr).i = offset;
798afc2ba1dSToomas Soome }
799afc2ba1dSToomas Soome
800afc2ba1dSToomas Soome /*
801afc2ba1dSToomas Soome * h a s h
802afc2ba1dSToomas Soome * hash ( c-addr u -- code)
803afc2ba1dSToomas Soome * calculates hashcode of specified string and leaves it on the stack
804afc2ba1dSToomas Soome */
805afc2ba1dSToomas Soome static void
ficlPrimitiveHash(ficlVm * vm)806afc2ba1dSToomas Soome ficlPrimitiveHash(ficlVm *vm)
807afc2ba1dSToomas Soome {
808afc2ba1dSToomas Soome ficlString s;
809afc2ba1dSToomas Soome
810afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack));
811afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
812afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s));
813afc2ba1dSToomas Soome }
814afc2ba1dSToomas Soome
815afc2ba1dSToomas Soome /*
816afc2ba1dSToomas Soome * i n t e r p r e t
817afc2ba1dSToomas Soome * This is the "user interface" of a Forth. It does the following:
818afc2ba1dSToomas Soome * while there are words in the VM's Text Input Buffer
819afc2ba1dSToomas Soome * Copy next word into the pad (ficlVmGetWord)
820afc2ba1dSToomas Soome * Attempt to find the word in the dictionary (ficlDictionaryLookup)
821afc2ba1dSToomas Soome * If successful, execute the word.
822afc2ba1dSToomas Soome * Otherwise, attempt to convert the word to a number (isNumber)
823afc2ba1dSToomas Soome * If successful, push the number onto the parameter stack.
824afc2ba1dSToomas Soome * Otherwise, print an error message and exit loop...
825afc2ba1dSToomas Soome * End Loop
826afc2ba1dSToomas Soome *
827afc2ba1dSToomas Soome * From the standard, section 3.4
828afc2ba1dSToomas Soome * Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
829afc2ba1dSToomas Soome * repeat the following steps until either the parse area is empty or an
830afc2ba1dSToomas Soome * ambiguous condition exists:
831afc2ba1dSToomas Soome * a) Skip leading spaces and parse a name (see 3.4.1);
832afc2ba1dSToomas Soome */
833afc2ba1dSToomas Soome static void
ficlPrimitiveInterpret(ficlVm * vm)834afc2ba1dSToomas Soome ficlPrimitiveInterpret(ficlVm *vm)
835afc2ba1dSToomas Soome {
836afc2ba1dSToomas Soome ficlString s;
837afc2ba1dSToomas Soome int i;
838afc2ba1dSToomas Soome ficlSystem *system;
839afc2ba1dSToomas Soome
840afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm);
841afc2ba1dSToomas Soome
842afc2ba1dSToomas Soome system = vm->callback.system;
843afc2ba1dSToomas Soome s = ficlVmGetWord0(vm);
844afc2ba1dSToomas Soome
845afc2ba1dSToomas Soome /*
846afc2ba1dSToomas Soome * Get next word...if out of text, we're done.
847afc2ba1dSToomas Soome */
848afc2ba1dSToomas Soome if (s.length == 0) {
849afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT);
850afc2ba1dSToomas Soome }
851afc2ba1dSToomas Soome
852afc2ba1dSToomas Soome /*
853afc2ba1dSToomas Soome * Run the parse chain against the incoming token until somebody
854afc2ba1dSToomas Soome * eats it. Otherwise emit an error message and give up.
855afc2ba1dSToomas Soome */
856afc2ba1dSToomas Soome for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
857afc2ba1dSToomas Soome ficlWord *word = system->parseList[i];
858afc2ba1dSToomas Soome
859afc2ba1dSToomas Soome if (word == NULL)
860afc2ba1dSToomas Soome break;
861afc2ba1dSToomas Soome
862afc2ba1dSToomas Soome if (word->code == ficlPrimitiveParseStepParen) {
863afc2ba1dSToomas Soome ficlParseStep pStep;
864afc2ba1dSToomas Soome pStep = (ficlParseStep)(word->param->fn);
865afc2ba1dSToomas Soome if ((*pStep)(vm, s))
866afc2ba1dSToomas Soome return;
867afc2ba1dSToomas Soome } else {
868afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack,
869afc2ba1dSToomas Soome FICL_STRING_GET_POINTER(s));
870afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack,
871afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(s));
872*c0bb4f73SToomas Soome (void) ficlVmExecuteXT(vm, word);
873afc2ba1dSToomas Soome if (ficlStackPopInteger(vm->dataStack))
874afc2ba1dSToomas Soome return;
875afc2ba1dSToomas Soome }
876afc2ba1dSToomas Soome }
877afc2ba1dSToomas Soome
878afc2ba1dSToomas Soome ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s),
879afc2ba1dSToomas Soome FICL_STRING_GET_POINTER(s));
880afc2ba1dSToomas Soome /* back to inner interpreter */
881afc2ba1dSToomas Soome }
882afc2ba1dSToomas Soome
883afc2ba1dSToomas Soome /*
884afc2ba1dSToomas Soome * Surrogate precompiled parse step for ficlParseWord
885afc2ba1dSToomas Soome * (this step is hard coded in FICL_VM_STATE_INTERPRET)
886afc2ba1dSToomas Soome */
887afc2ba1dSToomas Soome static void
ficlPrimitiveLookup(ficlVm * vm)888afc2ba1dSToomas Soome ficlPrimitiveLookup(ficlVm *vm)
889afc2ba1dSToomas Soome {
890afc2ba1dSToomas Soome ficlString name;
891afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
892afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack));
893afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name));
894afc2ba1dSToomas Soome }
895afc2ba1dSToomas Soome
896afc2ba1dSToomas Soome /*
897afc2ba1dSToomas Soome * p a r e n P a r s e S t e p
898afc2ba1dSToomas Soome * (parse-step) ( c-addr u -- flag )
899afc2ba1dSToomas Soome * runtime for a precompiled parse step - pop a counted string off the
900afc2ba1dSToomas Soome * stack, run the parse step against it, and push the result flag (FICL_TRUE
901afc2ba1dSToomas Soome * if success, FICL_FALSE otherwise).
902afc2ba1dSToomas Soome */
903afc2ba1dSToomas Soome void
ficlPrimitiveParseStepParen(ficlVm * vm)904afc2ba1dSToomas Soome ficlPrimitiveParseStepParen(ficlVm *vm)
905afc2ba1dSToomas Soome {
906afc2ba1dSToomas Soome ficlString s;
907afc2ba1dSToomas Soome ficlWord *word = vm->runningWord;
908afc2ba1dSToomas Soome ficlParseStep pStep = (ficlParseStep)(word->param->fn);
909afc2ba1dSToomas Soome
910afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(s, ficlStackPopInteger(vm->dataStack));
911afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
912afc2ba1dSToomas Soome
913afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s));
914afc2ba1dSToomas Soome }
915afc2ba1dSToomas Soome
916afc2ba1dSToomas Soome static void
ficlPrimitiveAddParseStep(ficlVm * vm)917afc2ba1dSToomas Soome ficlPrimitiveAddParseStep(ficlVm *vm)
918afc2ba1dSToomas Soome {
919afc2ba1dSToomas Soome ficlWord *pStep;
920afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
921afc2ba1dSToomas Soome
922afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
923afc2ba1dSToomas Soome
924afc2ba1dSToomas Soome pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p);
925afc2ba1dSToomas Soome if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep))
926*c0bb4f73SToomas Soome (void) ficlSystemAddParseStep(vm->callback.system, pStep);
927afc2ba1dSToomas Soome }
928afc2ba1dSToomas Soome
929afc2ba1dSToomas Soome /*
930afc2ba1dSToomas Soome * l i t e r a l I m
931afc2ba1dSToomas Soome *
932afc2ba1dSToomas Soome * IMMEDIATE code for "literal". This function gets a value from the stack
933afc2ba1dSToomas Soome * and compiles it into the dictionary preceded by the code for "(literal)".
934afc2ba1dSToomas Soome * IMMEDIATE
935afc2ba1dSToomas Soome */
936afc2ba1dSToomas Soome void
ficlPrimitiveLiteralIm(ficlVm * vm)937afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(ficlVm *vm)
938afc2ba1dSToomas Soome {
939afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
940afc2ba1dSToomas Soome ficlInteger value;
941afc2ba1dSToomas Soome
942afc2ba1dSToomas Soome value = ficlStackPopInteger(vm->dataStack);
943afc2ba1dSToomas Soome
944afc2ba1dSToomas Soome switch (value) {
945afc2ba1dSToomas Soome case 1:
946afc2ba1dSToomas Soome case 2:
947afc2ba1dSToomas Soome case 3:
948afc2ba1dSToomas Soome case 4:
949afc2ba1dSToomas Soome case 5:
950afc2ba1dSToomas Soome case 6:
951afc2ba1dSToomas Soome case 7:
952afc2ba1dSToomas Soome case 8:
953afc2ba1dSToomas Soome case 9:
954afc2ba1dSToomas Soome case 10:
955afc2ba1dSToomas Soome case 11:
956afc2ba1dSToomas Soome case 12:
957afc2ba1dSToomas Soome case 13:
958afc2ba1dSToomas Soome case 14:
959afc2ba1dSToomas Soome case 15:
960afc2ba1dSToomas Soome case 16:
961afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, value);
962afc2ba1dSToomas Soome break;
963afc2ba1dSToomas Soome
964afc2ba1dSToomas Soome case 0:
965afc2ba1dSToomas Soome case -1:
966afc2ba1dSToomas Soome case -2:
967afc2ba1dSToomas Soome case -3:
968afc2ba1dSToomas Soome case -4:
969afc2ba1dSToomas Soome case -5:
970afc2ba1dSToomas Soome case -6:
971afc2ba1dSToomas Soome case -7:
972afc2ba1dSToomas Soome case -8:
973afc2ba1dSToomas Soome case -9:
974afc2ba1dSToomas Soome case -10:
975afc2ba1dSToomas Soome case -11:
976afc2ba1dSToomas Soome case -12:
977afc2ba1dSToomas Soome case -13:
978afc2ba1dSToomas Soome case -14:
979afc2ba1dSToomas Soome case -15:
980afc2ba1dSToomas Soome case -16:
981afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
982afc2ba1dSToomas Soome ficlInstruction0 - value);
983afc2ba1dSToomas Soome break;
984afc2ba1dSToomas Soome
985afc2ba1dSToomas Soome default:
986afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
987afc2ba1dSToomas Soome ficlInstructionLiteralParen);
988afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, value);
989afc2ba1dSToomas Soome break;
990afc2ba1dSToomas Soome }
991afc2ba1dSToomas Soome }
992afc2ba1dSToomas Soome
993afc2ba1dSToomas Soome static void
ficlPrimitive2LiteralIm(ficlVm * vm)994afc2ba1dSToomas Soome ficlPrimitive2LiteralIm(ficlVm *vm)
995afc2ba1dSToomas Soome {
996afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
997afc2ba1dSToomas Soome
998afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstruction2LiteralParen);
999afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
1000afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
1001afc2ba1dSToomas Soome }
1002afc2ba1dSToomas Soome
1003afc2ba1dSToomas Soome /*
1004afc2ba1dSToomas Soome * D o / L o o p
1005afc2ba1dSToomas Soome * do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
1006afc2ba1dSToomas Soome * Compiles code to initialize a loop: FICL_VM_STATE_COMPILE (do),
1007afc2ba1dSToomas Soome * allot space to hold the "leave" address, push a branch
1008afc2ba1dSToomas Soome * target address for the loop.
1009afc2ba1dSToomas Soome * (do) -- runtime for "do"
1010afc2ba1dSToomas Soome * pops index and limit from the p stack and moves them
1011afc2ba1dSToomas Soome * to the r stack, then skips to the loop body.
1012afc2ba1dSToomas Soome * loop -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
1013afc2ba1dSToomas Soome * +loop
1014afc2ba1dSToomas Soome * Compiles code for the test part of a loop:
1015afc2ba1dSToomas Soome * FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and
1016afc2ba1dSToomas Soome * copy "here" address to the "leave" address allotted by "do"
1017afc2ba1dSToomas Soome * i,j,k -- FICL_VM_STATE_COMPILE ONLY
1018afc2ba1dSToomas Soome * Runtime: Push loop indices on param stack (i is innermost loop...)
1019afc2ba1dSToomas Soome * Note: each loop has three values on the return stack:
1020afc2ba1dSToomas Soome * ( R: leave limit index )
1021afc2ba1dSToomas Soome * "leave" is the absolute address of the next ficlCell after the loop
1022afc2ba1dSToomas Soome * limit and index are the loop control variables.
1023afc2ba1dSToomas Soome * leave -- FICL_VM_STATE_COMPILE ONLY
1024afc2ba1dSToomas Soome * Runtime: pop the loop control variables, then pop the
1025afc2ba1dSToomas Soome * "leave" address and jump (absolute) there.
1026afc2ba1dSToomas Soome */
1027afc2ba1dSToomas Soome static void
ficlPrimitiveDoCoIm(ficlVm * vm)1028afc2ba1dSToomas Soome ficlPrimitiveDoCoIm(ficlVm *vm)
1029afc2ba1dSToomas Soome {
1030afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1031afc2ba1dSToomas Soome
1032afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoParen);
1033afc2ba1dSToomas Soome /*
1034afc2ba1dSToomas Soome * Allot space for a pointer to the end
1035afc2ba1dSToomas Soome * of the loop - "leave" uses this...
1036afc2ba1dSToomas Soome */
1037afc2ba1dSToomas Soome markBranch(dictionary, vm, leaveTag);
1038afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 0);
1039afc2ba1dSToomas Soome /*
1040afc2ba1dSToomas Soome * Mark location of head of loop...
1041afc2ba1dSToomas Soome */
1042afc2ba1dSToomas Soome markBranch(dictionary, vm, doTag);
1043afc2ba1dSToomas Soome }
1044afc2ba1dSToomas Soome
1045afc2ba1dSToomas Soome static void
ficlPrimitiveQDoCoIm(ficlVm * vm)1046afc2ba1dSToomas Soome ficlPrimitiveQDoCoIm(ficlVm *vm)
1047afc2ba1dSToomas Soome {
1048afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1049afc2ba1dSToomas Soome
1050afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionQDoParen);
1051afc2ba1dSToomas Soome /*
1052afc2ba1dSToomas Soome * Allot space for a pointer to the end
1053afc2ba1dSToomas Soome * of the loop - "leave" uses this...
1054afc2ba1dSToomas Soome */
1055afc2ba1dSToomas Soome markBranch(dictionary, vm, leaveTag);
1056afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 0);
1057afc2ba1dSToomas Soome /*
1058afc2ba1dSToomas Soome * Mark location of head of loop...
1059afc2ba1dSToomas Soome */
1060afc2ba1dSToomas Soome markBranch(dictionary, vm, doTag);
1061afc2ba1dSToomas Soome }
1062afc2ba1dSToomas Soome
1063afc2ba1dSToomas Soome
1064afc2ba1dSToomas Soome static void
ficlPrimitiveLoopCoIm(ficlVm * vm)1065afc2ba1dSToomas Soome ficlPrimitiveLoopCoIm(ficlVm *vm)
1066afc2ba1dSToomas Soome {
1067afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1068afc2ba1dSToomas Soome
1069afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLoopParen);
1070afc2ba1dSToomas Soome resolveBackBranch(dictionary, vm, doTag);
1071afc2ba1dSToomas Soome resolveAbsBranch(dictionary, vm, leaveTag);
1072afc2ba1dSToomas Soome }
1073afc2ba1dSToomas Soome
1074afc2ba1dSToomas Soome static void
ficlPrimitivePlusLoopCoIm(ficlVm * vm)1075afc2ba1dSToomas Soome ficlPrimitivePlusLoopCoIm(ficlVm *vm)
1076afc2ba1dSToomas Soome {
1077afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1078afc2ba1dSToomas Soome
1079afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionPlusLoopParen);
1080afc2ba1dSToomas Soome resolveBackBranch(dictionary, vm, doTag);
1081afc2ba1dSToomas Soome resolveAbsBranch(dictionary, vm, leaveTag);
1082afc2ba1dSToomas Soome }
1083afc2ba1dSToomas Soome
1084afc2ba1dSToomas Soome /*
1085afc2ba1dSToomas Soome * v a r i a b l e
1086afc2ba1dSToomas Soome */
1087afc2ba1dSToomas Soome static void
ficlPrimitiveVariable(ficlVm * vm)1088afc2ba1dSToomas Soome ficlPrimitiveVariable(ficlVm *vm)
1089afc2ba1dSToomas Soome {
1090afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1091afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
1092afc2ba1dSToomas Soome
1093*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
1094afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
1095afc2ba1dSToomas Soome ficlVmDictionaryAllotCells(vm, dictionary, 1);
1096afc2ba1dSToomas Soome }
1097afc2ba1dSToomas Soome
1098afc2ba1dSToomas Soome static void
ficlPrimitive2Variable(ficlVm * vm)1099afc2ba1dSToomas Soome ficlPrimitive2Variable(ficlVm *vm)
1100afc2ba1dSToomas Soome {
1101afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1102afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
1103afc2ba1dSToomas Soome
1104*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
1105afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
1106afc2ba1dSToomas Soome ficlVmDictionaryAllotCells(vm, dictionary, 2);
1107afc2ba1dSToomas Soome }
1108afc2ba1dSToomas Soome
1109afc2ba1dSToomas Soome /*
1110afc2ba1dSToomas Soome * b a s e & f r i e n d s
1111afc2ba1dSToomas Soome */
1112afc2ba1dSToomas Soome static void
ficlPrimitiveBase(ficlVm * vm)1113afc2ba1dSToomas Soome ficlPrimitiveBase(ficlVm *vm)
1114afc2ba1dSToomas Soome {
1115afc2ba1dSToomas Soome ficlCell *pBase, c;
1116afc2ba1dSToomas Soome
1117afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
1118afc2ba1dSToomas Soome
1119afc2ba1dSToomas Soome pBase = (ficlCell *)(&vm->base);
1120afc2ba1dSToomas Soome c.p = pBase;
1121afc2ba1dSToomas Soome ficlStackPush(vm->dataStack, c);
1122afc2ba1dSToomas Soome }
1123afc2ba1dSToomas Soome
1124afc2ba1dSToomas Soome static void
ficlPrimitiveDecimal(ficlVm * vm)1125afc2ba1dSToomas Soome ficlPrimitiveDecimal(ficlVm *vm)
1126afc2ba1dSToomas Soome {
1127afc2ba1dSToomas Soome vm->base = 10;
1128afc2ba1dSToomas Soome }
1129afc2ba1dSToomas Soome
1130afc2ba1dSToomas Soome
1131afc2ba1dSToomas Soome static void
ficlPrimitiveHex(ficlVm * vm)1132afc2ba1dSToomas Soome ficlPrimitiveHex(ficlVm *vm)
1133afc2ba1dSToomas Soome {
1134afc2ba1dSToomas Soome vm->base = 16;
1135afc2ba1dSToomas Soome }
1136afc2ba1dSToomas Soome
1137afc2ba1dSToomas Soome /*
1138afc2ba1dSToomas Soome * a l l o t & f r i e n d s
1139afc2ba1dSToomas Soome */
1140afc2ba1dSToomas Soome static void
ficlPrimitiveAllot(ficlVm * vm)1141afc2ba1dSToomas Soome ficlPrimitiveAllot(ficlVm *vm)
1142afc2ba1dSToomas Soome {
1143afc2ba1dSToomas Soome ficlDictionary *dictionary;
1144afc2ba1dSToomas Soome ficlInteger i;
1145afc2ba1dSToomas Soome
1146afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
1147afc2ba1dSToomas Soome
1148afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
1149afc2ba1dSToomas Soome i = ficlStackPopInteger(vm->dataStack);
1150afc2ba1dSToomas Soome
1151afc2ba1dSToomas Soome FICL_VM_DICTIONARY_CHECK(vm, dictionary, i);
1152afc2ba1dSToomas Soome
1153afc2ba1dSToomas Soome ficlVmDictionaryAllot(vm, dictionary, i);
1154afc2ba1dSToomas Soome }
1155afc2ba1dSToomas Soome
1156afc2ba1dSToomas Soome static void
ficlPrimitiveHere(ficlVm * vm)1157afc2ba1dSToomas Soome ficlPrimitiveHere(ficlVm *vm)
1158afc2ba1dSToomas Soome {
1159afc2ba1dSToomas Soome ficlDictionary *dictionary;
1160afc2ba1dSToomas Soome
1161afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
1162afc2ba1dSToomas Soome
1163afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
1164afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here);
1165afc2ba1dSToomas Soome }
1166afc2ba1dSToomas Soome
1167afc2ba1dSToomas Soome /*
1168afc2ba1dSToomas Soome * t i c k
1169afc2ba1dSToomas Soome * tick CORE ( "<spaces>name" -- xt )
1170afc2ba1dSToomas Soome * Skip leading space delimiters. Parse name delimited by a space. Find
1171afc2ba1dSToomas Soome * name and return xt, the execution token for name. An ambiguous condition
1172afc2ba1dSToomas Soome * exists if name is not found.
1173afc2ba1dSToomas Soome */
1174afc2ba1dSToomas Soome void
ficlPrimitiveTick(ficlVm * vm)1175afc2ba1dSToomas Soome ficlPrimitiveTick(ficlVm *vm)
1176afc2ba1dSToomas Soome {
1177afc2ba1dSToomas Soome ficlWord *word = NULL;
1178afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
1179afc2ba1dSToomas Soome
1180afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
1181afc2ba1dSToomas Soome
1182afc2ba1dSToomas Soome word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
1183afc2ba1dSToomas Soome if (!word)
1184afc2ba1dSToomas Soome ficlVmThrowError(vm, "%.*s not found",
1185afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(name),
1186afc2ba1dSToomas Soome FICL_STRING_GET_POINTER(name));
1187afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, word);
1188afc2ba1dSToomas Soome }
1189afc2ba1dSToomas Soome
1190afc2ba1dSToomas Soome static void
ficlPrimitiveBracketTickCoIm(ficlVm * vm)1191afc2ba1dSToomas Soome ficlPrimitiveBracketTickCoIm(ficlVm *vm)
1192afc2ba1dSToomas Soome {
1193afc2ba1dSToomas Soome ficlPrimitiveTick(vm);
1194afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(vm);
1195afc2ba1dSToomas Soome }
1196afc2ba1dSToomas Soome
1197afc2ba1dSToomas Soome /*
1198afc2ba1dSToomas Soome * p o s t p o n e
1199afc2ba1dSToomas Soome * Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to
1200afc2ba1dSToomas Soome * insert it into definitions created by the resulting word
1201afc2ba1dSToomas Soome * (defers compilation, even of immediate words)
1202afc2ba1dSToomas Soome */
1203afc2ba1dSToomas Soome static void
ficlPrimitivePostponeCoIm(ficlVm * vm)1204afc2ba1dSToomas Soome ficlPrimitivePostponeCoIm(ficlVm *vm)
1205afc2ba1dSToomas Soome {
1206afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1207afc2ba1dSToomas Soome ficlWord *word;
1208afc2ba1dSToomas Soome ficlWord *pComma = ficlSystemLookup(vm->callback.system, ",");
1209afc2ba1dSToomas Soome ficlCell c;
1210afc2ba1dSToomas Soome
1211afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, pComma);
1212afc2ba1dSToomas Soome
1213afc2ba1dSToomas Soome ficlPrimitiveTick(vm);
1214afc2ba1dSToomas Soome word = ficlStackGetTop(vm->dataStack).p;
1215afc2ba1dSToomas Soome if (ficlWordIsImmediate(word)) {
1216afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary,
1217afc2ba1dSToomas Soome ficlStackPop(vm->dataStack));
1218afc2ba1dSToomas Soome } else {
1219afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(vm);
1220afc2ba1dSToomas Soome c.p = pComma;
1221afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, c);
1222afc2ba1dSToomas Soome }
1223afc2ba1dSToomas Soome }
1224afc2ba1dSToomas Soome
1225afc2ba1dSToomas Soome /*
1226afc2ba1dSToomas Soome * e x e c u t e
1227afc2ba1dSToomas Soome * Pop an execution token (pointer to a word) off the stack and
1228afc2ba1dSToomas Soome * run it
1229afc2ba1dSToomas Soome */
1230afc2ba1dSToomas Soome static void
ficlPrimitiveExecute(ficlVm * vm)1231afc2ba1dSToomas Soome ficlPrimitiveExecute(ficlVm *vm)
1232afc2ba1dSToomas Soome {
1233afc2ba1dSToomas Soome ficlWord *word;
1234afc2ba1dSToomas Soome
1235afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
1236afc2ba1dSToomas Soome
1237afc2ba1dSToomas Soome word = ficlStackPopPointer(vm->dataStack);
1238afc2ba1dSToomas Soome ficlVmExecuteWord(vm, word);
1239afc2ba1dSToomas Soome }
1240afc2ba1dSToomas Soome
1241afc2ba1dSToomas Soome /*
1242afc2ba1dSToomas Soome * i m m e d i a t e
1243afc2ba1dSToomas Soome * Make the most recently compiled word IMMEDIATE -- it executes even
1244afc2ba1dSToomas Soome * in FICL_VM_STATE_COMPILE state (most often used for control compiling words
1245afc2ba1dSToomas Soome * such as IF, THEN, etc)
1246afc2ba1dSToomas Soome */
1247afc2ba1dSToomas Soome static void
ficlPrimitiveImmediate(ficlVm * vm)1248afc2ba1dSToomas Soome ficlPrimitiveImmediate(ficlVm *vm)
1249afc2ba1dSToomas Soome {
1250afc2ba1dSToomas Soome FICL_IGNORE(vm);
1251afc2ba1dSToomas Soome ficlDictionarySetImmediate(ficlVmGetDictionary(vm));
1252afc2ba1dSToomas Soome }
1253afc2ba1dSToomas Soome
1254afc2ba1dSToomas Soome static void
ficlPrimitiveCompileOnly(ficlVm * vm)1255afc2ba1dSToomas Soome ficlPrimitiveCompileOnly(ficlVm *vm)
1256afc2ba1dSToomas Soome {
1257afc2ba1dSToomas Soome FICL_IGNORE(vm);
1258afc2ba1dSToomas Soome ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_COMPILE_ONLY);
1259afc2ba1dSToomas Soome }
1260afc2ba1dSToomas Soome
1261afc2ba1dSToomas Soome static void
ficlPrimitiveSetObjectFlag(ficlVm * vm)1262afc2ba1dSToomas Soome ficlPrimitiveSetObjectFlag(ficlVm *vm)
1263afc2ba1dSToomas Soome {
1264afc2ba1dSToomas Soome FICL_IGNORE(vm);
1265afc2ba1dSToomas Soome ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_OBJECT);
1266afc2ba1dSToomas Soome }
1267afc2ba1dSToomas Soome
1268afc2ba1dSToomas Soome static void
ficlPrimitiveIsObject(ficlVm * vm)1269afc2ba1dSToomas Soome ficlPrimitiveIsObject(ficlVm *vm)
1270afc2ba1dSToomas Soome {
1271afc2ba1dSToomas Soome ficlInteger flag;
1272afc2ba1dSToomas Soome ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
1273afc2ba1dSToomas Soome
1274afc2ba1dSToomas Soome flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT))?
1275afc2ba1dSToomas Soome FICL_TRUE : FICL_FALSE;
1276afc2ba1dSToomas Soome
1277afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, flag);
1278afc2ba1dSToomas Soome }
1279afc2ba1dSToomas Soome
1280afc2ba1dSToomas Soome static void
ficlPrimitiveCountedStringQuoteIm(ficlVm * vm)1281afc2ba1dSToomas Soome ficlPrimitiveCountedStringQuoteIm(ficlVm *vm)
1282afc2ba1dSToomas Soome {
1283afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1284afc2ba1dSToomas Soome
1285afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) {
1286afc2ba1dSToomas Soome ficlCountedString *counted = (ficlCountedString *)
1287afc2ba1dSToomas Soome dictionary->here;
1288afc2ba1dSToomas Soome
1289*c0bb4f73SToomas Soome (void) ficlVmGetString(vm, counted, '\"');
1290afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, counted);
1291afc2ba1dSToomas Soome
1292afc2ba1dSToomas Soome /*
1293afc2ba1dSToomas Soome * move HERE past string so it doesn't get overwritten. --lch
1294afc2ba1dSToomas Soome */
1295afc2ba1dSToomas Soome ficlVmDictionaryAllot(vm, dictionary,
1296afc2ba1dSToomas Soome counted->length + sizeof (ficlUnsigned8));
1297afc2ba1dSToomas Soome } else { /* FICL_VM_STATE_COMPILE state */
1298afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1299afc2ba1dSToomas Soome ficlInstructionCStringLiteralParen);
1300afc2ba1dSToomas Soome dictionary->here =
1301afc2ba1dSToomas Soome FICL_POINTER_TO_CELL(ficlVmGetString(vm,
1302afc2ba1dSToomas Soome (ficlCountedString *)dictionary->here, '\"'));
1303afc2ba1dSToomas Soome ficlDictionaryAlign(dictionary);
1304afc2ba1dSToomas Soome }
1305afc2ba1dSToomas Soome }
1306afc2ba1dSToomas Soome
1307afc2ba1dSToomas Soome /*
1308afc2ba1dSToomas Soome * d o t Q u o t e
1309afc2ba1dSToomas Soome * IMMEDIATE word that compiles a string literal for later display
1310afc2ba1dSToomas Soome * FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the
1311afc2ba1dSToomas Soome * string from the
1312afc2ba1dSToomas Soome * TIB to the dictionary. Backpatch the count byte and align the dictionary.
1313afc2ba1dSToomas Soome */
1314afc2ba1dSToomas Soome static void
ficlPrimitiveDotQuoteCoIm(ficlVm * vm)1315afc2ba1dSToomas Soome ficlPrimitiveDotQuoteCoIm(ficlVm *vm)
1316afc2ba1dSToomas Soome {
1317afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1318afc2ba1dSToomas Soome ficlWord *pType = ficlSystemLookup(vm->callback.system, "type");
1319afc2ba1dSToomas Soome ficlCell c;
1320afc2ba1dSToomas Soome
1321afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, pType);
1322afc2ba1dSToomas Soome
1323afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1324afc2ba1dSToomas Soome ficlInstructionStringLiteralParen);
1325afc2ba1dSToomas Soome dictionary->here =
1326afc2ba1dSToomas Soome FICL_POINTER_TO_CELL(ficlVmGetString(vm,
1327afc2ba1dSToomas Soome (ficlCountedString *)dictionary->here, '\"'));
1328afc2ba1dSToomas Soome ficlDictionaryAlign(dictionary);
1329afc2ba1dSToomas Soome c.p = pType;
1330afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, c);
1331afc2ba1dSToomas Soome }
1332afc2ba1dSToomas Soome
1333afc2ba1dSToomas Soome static void
ficlPrimitiveDotParen(ficlVm * vm)1334afc2ba1dSToomas Soome ficlPrimitiveDotParen(ficlVm *vm)
1335afc2ba1dSToomas Soome {
1336afc2ba1dSToomas Soome char *from = ficlVmGetInBuf(vm);
1337afc2ba1dSToomas Soome char *stop = ficlVmGetInBufEnd(vm);
1338afc2ba1dSToomas Soome char *to = vm->pad;
1339afc2ba1dSToomas Soome char c;
1340afc2ba1dSToomas Soome
1341afc2ba1dSToomas Soome /*
1342afc2ba1dSToomas Soome * Note: the standard does not want leading spaces skipped.
1343afc2ba1dSToomas Soome */
1344afc2ba1dSToomas Soome for (c = *from; (from != stop) && (c != ')'); c = *++from)
1345afc2ba1dSToomas Soome *to++ = c;
1346afc2ba1dSToomas Soome
1347afc2ba1dSToomas Soome *to = '\0';
1348afc2ba1dSToomas Soome if ((from != stop) && (c == ')'))
1349afc2ba1dSToomas Soome from++;
1350afc2ba1dSToomas Soome
1351afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad);
1352afc2ba1dSToomas Soome ficlVmUpdateTib(vm, from);
1353afc2ba1dSToomas Soome }
1354afc2ba1dSToomas Soome
1355afc2ba1dSToomas Soome /*
1356afc2ba1dSToomas Soome * s l i t e r a l
1357afc2ba1dSToomas Soome * STRING
1358afc2ba1dSToomas Soome * Interpretation: Interpretation semantics for this word are undefined.
1359afc2ba1dSToomas Soome * Compilation: ( c-addr1 u -- )
1360afc2ba1dSToomas Soome * Append the run-time semantics given below to the current definition.
1361afc2ba1dSToomas Soome * Run-time: ( -- c-addr2 u )
1362afc2ba1dSToomas Soome * Return c-addr2 u describing a string consisting of the characters
1363afc2ba1dSToomas Soome * specified by c-addr1 u during compilation. A program shall not alter
1364afc2ba1dSToomas Soome * the returned string.
1365afc2ba1dSToomas Soome */
ficlPrimitiveSLiteralCoIm(ficlVm * vm)1366afc2ba1dSToomas Soome static void ficlPrimitiveSLiteralCoIm(ficlVm *vm)
1367afc2ba1dSToomas Soome {
1368afc2ba1dSToomas Soome ficlDictionary *dictionary;
1369afc2ba1dSToomas Soome char *from;
1370afc2ba1dSToomas Soome char *to;
1371afc2ba1dSToomas Soome ficlUnsigned length;
1372afc2ba1dSToomas Soome
1373afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
1374afc2ba1dSToomas Soome
1375afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
1376afc2ba1dSToomas Soome length = ficlStackPopUnsigned(vm->dataStack);
1377afc2ba1dSToomas Soome from = ficlStackPopPointer(vm->dataStack);
1378afc2ba1dSToomas Soome
1379afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1380afc2ba1dSToomas Soome ficlInstructionStringLiteralParen);
1381afc2ba1dSToomas Soome to = (char *)dictionary->here;
1382afc2ba1dSToomas Soome *to++ = (char)length;
1383afc2ba1dSToomas Soome
1384afc2ba1dSToomas Soome for (; length > 0; --length) {
1385afc2ba1dSToomas Soome *to++ = *from++;
1386afc2ba1dSToomas Soome }
1387afc2ba1dSToomas Soome
1388afc2ba1dSToomas Soome *to++ = 0;
1389afc2ba1dSToomas Soome dictionary->here = FICL_POINTER_TO_CELL(ficlAlignPointer(to));
1390afc2ba1dSToomas Soome }
1391afc2ba1dSToomas Soome
1392afc2ba1dSToomas Soome /*
1393afc2ba1dSToomas Soome * s t a t e
1394afc2ba1dSToomas Soome * Return the address of the VM's state member (must be sized the
1395afc2ba1dSToomas Soome * same as a ficlCell for this reason)
1396afc2ba1dSToomas Soome */
ficlPrimitiveState(ficlVm * vm)1397afc2ba1dSToomas Soome static void ficlPrimitiveState(ficlVm *vm)
1398afc2ba1dSToomas Soome {
1399afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
1400afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, &vm->state);
1401afc2ba1dSToomas Soome }
1402afc2ba1dSToomas Soome
1403afc2ba1dSToomas Soome /*
1404afc2ba1dSToomas Soome * c r e a t e . . . d o e s >
1405afc2ba1dSToomas Soome * Make a new word in the dictionary with the run-time effect of
1406afc2ba1dSToomas Soome * a variable (push my address), but with extra space allotted
1407afc2ba1dSToomas Soome * for use by does> .
1408afc2ba1dSToomas Soome */
1409afc2ba1dSToomas Soome static void
ficlPrimitiveCreate(ficlVm * vm)1410afc2ba1dSToomas Soome ficlPrimitiveCreate(ficlVm *vm)
1411afc2ba1dSToomas Soome {
1412afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1413afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
1414afc2ba1dSToomas Soome
1415*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
1416afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionCreateParen, FICL_WORD_DEFAULT);
1417afc2ba1dSToomas Soome ficlVmDictionaryAllotCells(vm, dictionary, 1);
1418afc2ba1dSToomas Soome }
1419afc2ba1dSToomas Soome
1420afc2ba1dSToomas Soome static void
ficlPrimitiveDoesCoIm(ficlVm * vm)1421afc2ba1dSToomas Soome ficlPrimitiveDoesCoIm(ficlVm *vm)
1422afc2ba1dSToomas Soome {
1423afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1424afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
1425afc2ba1dSToomas Soome if (vm->callback.system->localsCount > 0) {
1426afc2ba1dSToomas Soome ficlDictionary *locals =
1427afc2ba1dSToomas Soome ficlSystemGetLocals(vm->callback.system);
1428afc2ba1dSToomas Soome ficlDictionaryEmpty(locals, locals->forthWordlist->size);
1429afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1430afc2ba1dSToomas Soome ficlInstructionUnlinkParen);
1431afc2ba1dSToomas Soome }
1432afc2ba1dSToomas Soome
1433afc2ba1dSToomas Soome vm->callback.system->localsCount = 0;
1434afc2ba1dSToomas Soome #endif
1435afc2ba1dSToomas Soome FICL_IGNORE(vm);
1436afc2ba1dSToomas Soome
1437afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen);
1438afc2ba1dSToomas Soome }
1439afc2ba1dSToomas Soome
1440afc2ba1dSToomas Soome /*
1441afc2ba1dSToomas Soome * t o b o d y
1442afc2ba1dSToomas Soome * to-body CORE ( xt -- a-addr )
1443afc2ba1dSToomas Soome * a-addr is the data-field address corresponding to xt. An ambiguous
1444afc2ba1dSToomas Soome * condition exists if xt is not for a word defined via CREATE.
1445afc2ba1dSToomas Soome */
1446afc2ba1dSToomas Soome static void
ficlPrimitiveToBody(ficlVm * vm)1447afc2ba1dSToomas Soome ficlPrimitiveToBody(ficlVm *vm)
1448afc2ba1dSToomas Soome {
1449afc2ba1dSToomas Soome ficlWord *word;
1450afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1);
1451afc2ba1dSToomas Soome
1452afc2ba1dSToomas Soome word = ficlStackPopPointer(vm->dataStack);
1453afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, word->param + 1);
1454afc2ba1dSToomas Soome }
1455afc2ba1dSToomas Soome
1456afc2ba1dSToomas Soome /*
1457afc2ba1dSToomas Soome * from-body Ficl ( a-addr -- xt )
1458afc2ba1dSToomas Soome * Reverse effect of >body
1459afc2ba1dSToomas Soome */
1460afc2ba1dSToomas Soome static void
ficlPrimitiveFromBody(ficlVm * vm)1461afc2ba1dSToomas Soome ficlPrimitiveFromBody(ficlVm *vm)
1462afc2ba1dSToomas Soome {
1463afc2ba1dSToomas Soome char *ptr;
1464afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1);
1465afc2ba1dSToomas Soome
1466afc2ba1dSToomas Soome ptr = (char *)ficlStackPopPointer(vm->dataStack) - sizeof (ficlWord);
1467afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, ptr);
1468afc2ba1dSToomas Soome }
1469afc2ba1dSToomas Soome
1470afc2ba1dSToomas Soome /*
1471afc2ba1dSToomas Soome * >name Ficl ( xt -- c-addr u )
1472afc2ba1dSToomas Soome * Push the address and length of a word's name given its address
1473afc2ba1dSToomas Soome * xt.
1474afc2ba1dSToomas Soome */
1475afc2ba1dSToomas Soome static void
ficlPrimitiveToName(ficlVm * vm)1476afc2ba1dSToomas Soome ficlPrimitiveToName(ficlVm *vm)
1477afc2ba1dSToomas Soome {
1478afc2ba1dSToomas Soome ficlWord *word;
1479afc2ba1dSToomas Soome
1480afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2);
1481afc2ba1dSToomas Soome
1482afc2ba1dSToomas Soome word = ficlStackPopPointer(vm->dataStack);
1483afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, word->name);
1484afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, word->length);
1485afc2ba1dSToomas Soome }
1486afc2ba1dSToomas Soome
1487afc2ba1dSToomas Soome static void
ficlPrimitiveLastWord(ficlVm * vm)1488afc2ba1dSToomas Soome ficlPrimitiveLastWord(ficlVm *vm)
1489afc2ba1dSToomas Soome {
1490afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1491afc2ba1dSToomas Soome ficlWord *wp = dictionary->smudge;
1492afc2ba1dSToomas Soome ficlCell c;
1493afc2ba1dSToomas Soome
1494afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, wp);
1495afc2ba1dSToomas Soome
1496afc2ba1dSToomas Soome c.p = wp;
1497afc2ba1dSToomas Soome ficlVmPush(vm, c);
1498afc2ba1dSToomas Soome }
1499afc2ba1dSToomas Soome
1500afc2ba1dSToomas Soome /*
1501afc2ba1dSToomas Soome * l b r a c k e t e t c
1502afc2ba1dSToomas Soome */
1503afc2ba1dSToomas Soome static void
ficlPrimitiveLeftBracketCoIm(ficlVm * vm)1504afc2ba1dSToomas Soome ficlPrimitiveLeftBracketCoIm(ficlVm *vm)
1505afc2ba1dSToomas Soome {
1506afc2ba1dSToomas Soome vm->state = FICL_VM_STATE_INTERPRET;
1507afc2ba1dSToomas Soome }
1508afc2ba1dSToomas Soome
1509afc2ba1dSToomas Soome static void
ficlPrimitiveRightBracket(ficlVm * vm)1510afc2ba1dSToomas Soome ficlPrimitiveRightBracket(ficlVm *vm)
1511afc2ba1dSToomas Soome {
1512afc2ba1dSToomas Soome vm->state = FICL_VM_STATE_COMPILE;
1513afc2ba1dSToomas Soome }
1514afc2ba1dSToomas Soome
1515afc2ba1dSToomas Soome /*
1516afc2ba1dSToomas Soome * p i c t u r e d n u m e r i c w o r d s
1517afc2ba1dSToomas Soome *
1518afc2ba1dSToomas Soome * less-number-sign CORE ( -- )
1519afc2ba1dSToomas Soome * Initialize the pictured numeric output conversion process.
1520afc2ba1dSToomas Soome * (clear the pad)
1521afc2ba1dSToomas Soome */
1522afc2ba1dSToomas Soome static void
ficlPrimitiveLessNumberSign(ficlVm * vm)1523afc2ba1dSToomas Soome ficlPrimitiveLessNumberSign(ficlVm *vm)
1524afc2ba1dSToomas Soome {
1525afc2ba1dSToomas Soome ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1526afc2ba1dSToomas Soome counted->length = 0;
1527afc2ba1dSToomas Soome }
1528afc2ba1dSToomas Soome
1529afc2ba1dSToomas Soome /*
1530afc2ba1dSToomas Soome * number-sign CORE ( ud1 -- ud2 )
1531afc2ba1dSToomas Soome * Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
1532afc2ba1dSToomas Soome * n. (n is the least-significant digit of ud1.) Convert n to external form
1533afc2ba1dSToomas Soome * and add the resulting character to the beginning of the pictured numeric
1534afc2ba1dSToomas Soome * output string. An ambiguous condition exists if # executes outside of a
1535afc2ba1dSToomas Soome * <# #> delimited number conversion.
1536afc2ba1dSToomas Soome */
1537afc2ba1dSToomas Soome static void
ficlPrimitiveNumberSign(ficlVm * vm)1538afc2ba1dSToomas Soome ficlPrimitiveNumberSign(ficlVm *vm)
1539afc2ba1dSToomas Soome {
1540afc2ba1dSToomas Soome ficlCountedString *counted;
1541afc2ba1dSToomas Soome ficl2Unsigned u;
1542afc2ba1dSToomas Soome ficl2UnsignedQR uqr;
1543afc2ba1dSToomas Soome
1544afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2);
1545afc2ba1dSToomas Soome
1546afc2ba1dSToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1547afc2ba1dSToomas Soome u = ficlStackPop2Unsigned(vm->dataStack);
1548afc2ba1dSToomas Soome uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
1549afc2ba1dSToomas Soome counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
1550afc2ba1dSToomas Soome ficlStackPush2Unsigned(vm->dataStack, uqr.quotient);
1551afc2ba1dSToomas Soome }
1552afc2ba1dSToomas Soome
1553afc2ba1dSToomas Soome /*
1554afc2ba1dSToomas Soome * number-sign-greater CORE ( xd -- c-addr u )
1555afc2ba1dSToomas Soome * Drop xd. Make the pictured numeric output string available as a character
1556afc2ba1dSToomas Soome * string. c-addr and u specify the resulting character string. A program
1557afc2ba1dSToomas Soome * may replace characters within the string.
1558afc2ba1dSToomas Soome */
1559afc2ba1dSToomas Soome static void
ficlPrimitiveNumberSignGreater(ficlVm * vm)1560afc2ba1dSToomas Soome ficlPrimitiveNumberSignGreater(ficlVm *vm)
1561afc2ba1dSToomas Soome {
1562afc2ba1dSToomas Soome ficlCountedString *counted;
1563afc2ba1dSToomas Soome
1564afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2);
1565afc2ba1dSToomas Soome
1566afc2ba1dSToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1567afc2ba1dSToomas Soome counted->text[counted->length] = 0;
1568*c0bb4f73SToomas Soome (void) ficlStringReverse(counted->text);
1569afc2ba1dSToomas Soome ficlStackDrop(vm->dataStack, 2);
1570afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, counted->text);
1571afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, counted->length);
1572afc2ba1dSToomas Soome }
1573afc2ba1dSToomas Soome
1574afc2ba1dSToomas Soome /*
1575afc2ba1dSToomas Soome * number-sign-s CORE ( ud1 -- ud2 )
1576afc2ba1dSToomas Soome * Convert one digit of ud1 according to the rule for #. Continue conversion
1577afc2ba1dSToomas Soome * until the quotient is zero. ud2 is zero. An ambiguous condition exists if
1578afc2ba1dSToomas Soome * #S executes outside of a <# #> delimited number conversion.
1579afc2ba1dSToomas Soome * TO DO: presently does not use ud1 hi ficlCell - use it!
1580afc2ba1dSToomas Soome */
1581afc2ba1dSToomas Soome static void
ficlPrimitiveNumberSignS(ficlVm * vm)1582afc2ba1dSToomas Soome ficlPrimitiveNumberSignS(ficlVm *vm)
1583afc2ba1dSToomas Soome {
1584afc2ba1dSToomas Soome ficlCountedString *counted;
1585afc2ba1dSToomas Soome ficl2Unsigned u;
1586afc2ba1dSToomas Soome ficl2UnsignedQR uqr;
1587afc2ba1dSToomas Soome
1588afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2);
1589afc2ba1dSToomas Soome
1590afc2ba1dSToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1591afc2ba1dSToomas Soome u = ficlStackPop2Unsigned(vm->dataStack);
1592afc2ba1dSToomas Soome
1593afc2ba1dSToomas Soome do {
1594afc2ba1dSToomas Soome uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
1595afc2ba1dSToomas Soome counted->text[counted->length++] =
1596afc2ba1dSToomas Soome ficlDigitToCharacter(uqr.remainder);
1597afc2ba1dSToomas Soome u = uqr.quotient;
1598afc2ba1dSToomas Soome } while (FICL_2UNSIGNED_NOT_ZERO(u));
1599afc2ba1dSToomas Soome
1600afc2ba1dSToomas Soome ficlStackPush2Unsigned(vm->dataStack, u);
1601afc2ba1dSToomas Soome }
1602afc2ba1dSToomas Soome
1603afc2ba1dSToomas Soome /*
1604afc2ba1dSToomas Soome * HOLD CORE ( char -- )
1605afc2ba1dSToomas Soome * Add char to the beginning of the pictured numeric output string.
1606afc2ba1dSToomas Soome * An ambiguous condition exists if HOLD executes outside of a <# #>
1607afc2ba1dSToomas Soome * delimited number conversion.
1608afc2ba1dSToomas Soome */
1609afc2ba1dSToomas Soome static void
ficlPrimitiveHold(ficlVm * vm)1610afc2ba1dSToomas Soome ficlPrimitiveHold(ficlVm *vm)
1611afc2ba1dSToomas Soome {
1612afc2ba1dSToomas Soome ficlCountedString *counted;
1613afc2ba1dSToomas Soome int i;
1614afc2ba1dSToomas Soome
1615afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
1616afc2ba1dSToomas Soome
1617afc2ba1dSToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1618afc2ba1dSToomas Soome i = ficlStackPopInteger(vm->dataStack);
1619afc2ba1dSToomas Soome counted->text[counted->length++] = (char)i;
1620afc2ba1dSToomas Soome }
1621afc2ba1dSToomas Soome
1622afc2ba1dSToomas Soome /*
1623afc2ba1dSToomas Soome * SIGN CORE ( n -- )
1624afc2ba1dSToomas Soome * If n is negative, add a minus sign to the beginning of the pictured
1625afc2ba1dSToomas Soome * numeric output string. An ambiguous condition exists if SIGN
1626afc2ba1dSToomas Soome * executes outside of a <# #> delimited number conversion.
1627afc2ba1dSToomas Soome */
1628afc2ba1dSToomas Soome static void
ficlPrimitiveSign(ficlVm * vm)1629afc2ba1dSToomas Soome ficlPrimitiveSign(ficlVm *vm)
1630afc2ba1dSToomas Soome {
1631afc2ba1dSToomas Soome ficlCountedString *counted;
1632afc2ba1dSToomas Soome int i;
1633afc2ba1dSToomas Soome
1634afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
1635afc2ba1dSToomas Soome
1636afc2ba1dSToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1637afc2ba1dSToomas Soome i = ficlStackPopInteger(vm->dataStack);
1638afc2ba1dSToomas Soome if (i < 0)
1639afc2ba1dSToomas Soome counted->text[counted->length++] = '-';
1640afc2ba1dSToomas Soome }
1641afc2ba1dSToomas Soome
1642afc2ba1dSToomas Soome /*
1643afc2ba1dSToomas Soome * t o N u m b e r
1644afc2ba1dSToomas Soome * to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
1645afc2ba1dSToomas Soome * ud2 is the unsigned result of converting the characters within the
1646afc2ba1dSToomas Soome * string specified by c-addr1 u1 into digits, using the number in BASE,
1647afc2ba1dSToomas Soome * and adding each into ud1 after multiplying ud1 by the number in BASE.
1648afc2ba1dSToomas Soome * Conversion continues left-to-right until a character that is not
1649afc2ba1dSToomas Soome * convertible, including any + or -, is encountered or the string is
1650afc2ba1dSToomas Soome * entirely converted. c-addr2 is the location of the first unconverted
1651afc2ba1dSToomas Soome * character or the first character past the end of the string if the string
1652afc2ba1dSToomas Soome * was entirely converted. u2 is the number of unconverted characters in the
1653afc2ba1dSToomas Soome * string. An ambiguous condition exists if ud2 overflows during the
1654afc2ba1dSToomas Soome * conversion.
1655afc2ba1dSToomas Soome */
1656afc2ba1dSToomas Soome static void
ficlPrimitiveToNumber(ficlVm * vm)1657afc2ba1dSToomas Soome ficlPrimitiveToNumber(ficlVm *vm)
1658afc2ba1dSToomas Soome {
1659afc2ba1dSToomas Soome ficlUnsigned length;
1660afc2ba1dSToomas Soome char *trace;
1661afc2ba1dSToomas Soome ficl2Unsigned accumulator;
1662afc2ba1dSToomas Soome ficlUnsigned base = vm->base;
1663afc2ba1dSToomas Soome ficlUnsigned c;
1664afc2ba1dSToomas Soome ficlUnsigned digit;
1665afc2ba1dSToomas Soome
1666afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 4, 4);
1667afc2ba1dSToomas Soome
1668afc2ba1dSToomas Soome length = ficlStackPopUnsigned(vm->dataStack);
1669afc2ba1dSToomas Soome trace = (char *)ficlStackPopPointer(vm->dataStack);
1670afc2ba1dSToomas Soome accumulator = ficlStackPop2Unsigned(vm->dataStack);
1671afc2ba1dSToomas Soome
1672afc2ba1dSToomas Soome for (c = *trace; length > 0; c = *++trace, length--) {
1673afc2ba1dSToomas Soome if (c < '0')
1674afc2ba1dSToomas Soome break;
1675afc2ba1dSToomas Soome
1676afc2ba1dSToomas Soome digit = c - '0';
1677afc2ba1dSToomas Soome
1678afc2ba1dSToomas Soome if (digit > 9)
1679afc2ba1dSToomas Soome digit = tolower(c) - 'a' + 10;
1680afc2ba1dSToomas Soome /*
1681afc2ba1dSToomas Soome * Note: following test also catches chars between 9 and a
1682afc2ba1dSToomas Soome * because 'digit' is unsigned!
1683afc2ba1dSToomas Soome */
1684afc2ba1dSToomas Soome if (digit >= base)
1685afc2ba1dSToomas Soome break;
1686afc2ba1dSToomas Soome
1687afc2ba1dSToomas Soome accumulator = ficl2UnsignedMultiplyAccumulate(accumulator,
1688afc2ba1dSToomas Soome base, digit);
1689afc2ba1dSToomas Soome }
1690afc2ba1dSToomas Soome
1691afc2ba1dSToomas Soome ficlStackPush2Unsigned(vm->dataStack, accumulator);
1692afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, trace);
1693afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, length);
1694afc2ba1dSToomas Soome }
1695afc2ba1dSToomas Soome
1696afc2ba1dSToomas Soome /*
1697afc2ba1dSToomas Soome * q u i t & a b o r t
1698afc2ba1dSToomas Soome * quit CORE ( -- ) ( R: i*x -- )
1699afc2ba1dSToomas Soome * Empty the return stack, store zero in SOURCE-ID if it is present, make
1700afc2ba1dSToomas Soome * the user input device the input source, and enter interpretation state.
1701afc2ba1dSToomas Soome * Do not display a message. Repeat the following:
1702afc2ba1dSToomas Soome *
1703afc2ba1dSToomas Soome * Accept a line from the input source into the input buffer, set >IN to
1704afc2ba1dSToomas Soome * zero, and FICL_VM_STATE_INTERPRET.
1705afc2ba1dSToomas Soome * Display the implementation-defined system prompt if in
1706afc2ba1dSToomas Soome * interpretation state, all processing has been completed, and no
1707afc2ba1dSToomas Soome * ambiguous condition exists.
1708afc2ba1dSToomas Soome */
1709afc2ba1dSToomas Soome static void
ficlPrimitiveQuit(ficlVm * vm)1710afc2ba1dSToomas Soome ficlPrimitiveQuit(ficlVm *vm)
1711afc2ba1dSToomas Soome {
1712afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
1713afc2ba1dSToomas Soome }
1714afc2ba1dSToomas Soome
1715afc2ba1dSToomas Soome static void
ficlPrimitiveAbort(ficlVm * vm)1716afc2ba1dSToomas Soome ficlPrimitiveAbort(ficlVm *vm)
1717afc2ba1dSToomas Soome {
1718afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
1719afc2ba1dSToomas Soome }
1720afc2ba1dSToomas Soome
1721afc2ba1dSToomas Soome /*
1722afc2ba1dSToomas Soome * a c c e p t
1723afc2ba1dSToomas Soome * accept CORE ( c-addr +n1 -- +n2 )
1724afc2ba1dSToomas Soome * Receive a string of at most +n1 characters. An ambiguous condition
1725afc2ba1dSToomas Soome * exists if +n1 is zero or greater than 32,767. Display graphic characters
1726afc2ba1dSToomas Soome * as they are received. A program that depends on the presence or absence
1727afc2ba1dSToomas Soome * of non-graphic characters in the string has an environmental dependency.
1728afc2ba1dSToomas Soome * The editing functions, if any, that the system performs in order to
1729afc2ba1dSToomas Soome * construct the string are implementation-defined.
1730afc2ba1dSToomas Soome *
1731afc2ba1dSToomas Soome * (Although the standard text doesn't say so, I assume that the intent
1732afc2ba1dSToomas Soome * of 'accept' is to store the string at the address specified on
1733afc2ba1dSToomas Soome * the stack.)
1734afc2ba1dSToomas Soome *
1735afc2ba1dSToomas Soome * NOTE: getchar() is used there as its present both in loader and
1736afc2ba1dSToomas Soome * userland; however, the more correct solution would be to set
1737afc2ba1dSToomas Soome * terminal to raw mode for userland.
1738afc2ba1dSToomas Soome */
1739afc2ba1dSToomas Soome static void
ficlPrimitiveAccept(ficlVm * vm)1740afc2ba1dSToomas Soome ficlPrimitiveAccept(ficlVm *vm)
1741afc2ba1dSToomas Soome {
1742afc2ba1dSToomas Soome ficlUnsigned size;
1743afc2ba1dSToomas Soome char *address;
1744afc2ba1dSToomas Soome int c;
1745afc2ba1dSToomas Soome ficlUnsigned length = 0;
1746afc2ba1dSToomas Soome
1747afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 1);
1748afc2ba1dSToomas Soome
1749afc2ba1dSToomas Soome size = ficlStackPopInteger(vm->dataStack);
1750afc2ba1dSToomas Soome address = ficlStackPopPointer(vm->dataStack);
1751afc2ba1dSToomas Soome
1752afc2ba1dSToomas Soome while (size != length) {
1753afc2ba1dSToomas Soome c = getchar();
1754afc2ba1dSToomas Soome if (c == '\n' || c == '\r')
1755afc2ba1dSToomas Soome break;
1756afc2ba1dSToomas Soome address[length++] = c;
1757afc2ba1dSToomas Soome }
1758afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, length);
1759afc2ba1dSToomas Soome }
1760afc2ba1dSToomas Soome
1761afc2ba1dSToomas Soome /*
1762afc2ba1dSToomas Soome * a l i g n
1763afc2ba1dSToomas Soome * 6.1.0705 ALIGN CORE ( -- )
1764afc2ba1dSToomas Soome * If the data-space pointer is not aligned, reserve enough space to
1765afc2ba1dSToomas Soome * align it.
1766afc2ba1dSToomas Soome */
1767afc2ba1dSToomas Soome static void
ficlPrimitiveAlign(ficlVm * vm)1768afc2ba1dSToomas Soome ficlPrimitiveAlign(ficlVm *vm)
1769afc2ba1dSToomas Soome {
1770afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1771afc2ba1dSToomas Soome FICL_IGNORE(vm);
1772afc2ba1dSToomas Soome ficlDictionaryAlign(dictionary);
1773afc2ba1dSToomas Soome }
1774afc2ba1dSToomas Soome
1775afc2ba1dSToomas Soome /*
1776afc2ba1dSToomas Soome * a l i g n e d
1777afc2ba1dSToomas Soome */
1778afc2ba1dSToomas Soome static void
ficlPrimitiveAligned(ficlVm * vm)1779afc2ba1dSToomas Soome ficlPrimitiveAligned(ficlVm *vm)
1780afc2ba1dSToomas Soome {
1781afc2ba1dSToomas Soome void *addr;
1782afc2ba1dSToomas Soome
1783afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1);
1784afc2ba1dSToomas Soome
1785afc2ba1dSToomas Soome addr = ficlStackPopPointer(vm->dataStack);
1786afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, ficlAlignPointer(addr));
1787afc2ba1dSToomas Soome }
1788afc2ba1dSToomas Soome
1789afc2ba1dSToomas Soome /*
1790afc2ba1dSToomas Soome * b e g i n & f r i e n d s
1791afc2ba1dSToomas Soome * Indefinite loop control structures
1792afc2ba1dSToomas Soome * A.6.1.0760 BEGIN
1793afc2ba1dSToomas Soome * Typical use:
1794afc2ba1dSToomas Soome * : X ... BEGIN ... test UNTIL ;
1795afc2ba1dSToomas Soome * or
1796afc2ba1dSToomas Soome * : X ... BEGIN ... test WHILE ... REPEAT ;
1797afc2ba1dSToomas Soome */
1798afc2ba1dSToomas Soome static void
ficlPrimitiveBeginCoIm(ficlVm * vm)1799afc2ba1dSToomas Soome ficlPrimitiveBeginCoIm(ficlVm *vm)
1800afc2ba1dSToomas Soome {
1801afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1802afc2ba1dSToomas Soome markBranch(dictionary, vm, destTag);
1803afc2ba1dSToomas Soome }
1804afc2ba1dSToomas Soome
1805afc2ba1dSToomas Soome static void
ficlPrimitiveUntilCoIm(ficlVm * vm)1806afc2ba1dSToomas Soome ficlPrimitiveUntilCoIm(ficlVm *vm)
1807afc2ba1dSToomas Soome {
1808afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1809afc2ba1dSToomas Soome
1810afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1811afc2ba1dSToomas Soome ficlInstructionBranch0ParenWithCheck);
1812afc2ba1dSToomas Soome resolveBackBranch(dictionary, vm, destTag);
1813afc2ba1dSToomas Soome }
1814afc2ba1dSToomas Soome
1815afc2ba1dSToomas Soome static void
ficlPrimitiveWhileCoIm(ficlVm * vm)1816afc2ba1dSToomas Soome ficlPrimitiveWhileCoIm(ficlVm *vm)
1817afc2ba1dSToomas Soome {
1818afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1819afc2ba1dSToomas Soome
1820afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 5);
1821afc2ba1dSToomas Soome
1822afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1823afc2ba1dSToomas Soome ficlInstructionBranch0ParenWithCheck);
1824afc2ba1dSToomas Soome markBranch(dictionary, vm, origTag);
1825afc2ba1dSToomas Soome
1826afc2ba1dSToomas Soome /* equivalent to 2swap */
1827afc2ba1dSToomas Soome ficlStackRoll(vm->dataStack, 3);
1828afc2ba1dSToomas Soome ficlStackRoll(vm->dataStack, 3);
1829afc2ba1dSToomas Soome
1830afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1);
1831afc2ba1dSToomas Soome }
1832afc2ba1dSToomas Soome
1833afc2ba1dSToomas Soome static void
ficlPrimitiveRepeatCoIm(ficlVm * vm)1834afc2ba1dSToomas Soome ficlPrimitiveRepeatCoIm(ficlVm *vm)
1835afc2ba1dSToomas Soome {
1836afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1837afc2ba1dSToomas Soome
1838afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1839afc2ba1dSToomas Soome ficlInstructionBranchParenWithCheck);
1840afc2ba1dSToomas Soome /* expect "begin" branch marker */
1841afc2ba1dSToomas Soome resolveBackBranch(dictionary, vm, destTag);
1842afc2ba1dSToomas Soome /* expect "while" branch marker */
1843afc2ba1dSToomas Soome resolveForwardBranch(dictionary, vm, origTag);
1844afc2ba1dSToomas Soome }
1845afc2ba1dSToomas Soome
1846afc2ba1dSToomas Soome static void
ficlPrimitiveAgainCoIm(ficlVm * vm)1847afc2ba1dSToomas Soome ficlPrimitiveAgainCoIm(ficlVm *vm)
1848afc2ba1dSToomas Soome {
1849afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1850afc2ba1dSToomas Soome
1851afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
1852afc2ba1dSToomas Soome ficlInstructionBranchParenWithCheck);
1853afc2ba1dSToomas Soome /* expect "begin" branch marker */
1854afc2ba1dSToomas Soome resolveBackBranch(dictionary, vm, destTag);
1855afc2ba1dSToomas Soome }
1856afc2ba1dSToomas Soome
1857afc2ba1dSToomas Soome /*
1858afc2ba1dSToomas Soome * c h a r & f r i e n d s
1859afc2ba1dSToomas Soome * 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
1860afc2ba1dSToomas Soome * Skip leading space delimiters. Parse name delimited by a space.
1861afc2ba1dSToomas Soome * Put the value of its first character onto the stack.
1862afc2ba1dSToomas Soome *
1863afc2ba1dSToomas Soome * bracket-char CORE
1864afc2ba1dSToomas Soome * Interpretation: Interpretation semantics for this word are undefined.
1865afc2ba1dSToomas Soome * Compilation: ( "<spaces>name" -- )
1866afc2ba1dSToomas Soome * Skip leading space delimiters. Parse name delimited by a space.
1867afc2ba1dSToomas Soome * Append the run-time semantics given below to the current definition.
1868afc2ba1dSToomas Soome * Run-time: ( -- char )
1869afc2ba1dSToomas Soome * Place char, the value of the first character of name, on the stack.
1870afc2ba1dSToomas Soome */
1871afc2ba1dSToomas Soome static void
ficlPrimitiveChar(ficlVm * vm)1872afc2ba1dSToomas Soome ficlPrimitiveChar(ficlVm *vm)
1873afc2ba1dSToomas Soome {
1874afc2ba1dSToomas Soome ficlString s;
1875afc2ba1dSToomas Soome
1876afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
1877afc2ba1dSToomas Soome
1878afc2ba1dSToomas Soome s = ficlVmGetWord(vm);
1879afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)(s.text[0]));
1880afc2ba1dSToomas Soome }
1881afc2ba1dSToomas Soome
1882afc2ba1dSToomas Soome static void
ficlPrimitiveCharCoIm(ficlVm * vm)1883afc2ba1dSToomas Soome ficlPrimitiveCharCoIm(ficlVm *vm)
1884afc2ba1dSToomas Soome {
1885afc2ba1dSToomas Soome ficlPrimitiveChar(vm);
1886afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(vm);
1887afc2ba1dSToomas Soome }
1888afc2ba1dSToomas Soome
1889afc2ba1dSToomas Soome /*
1890afc2ba1dSToomas Soome * c h a r P l u s
1891afc2ba1dSToomas Soome * char-plus CORE ( c-addr1 -- c-addr2 )
1892afc2ba1dSToomas Soome * Add the size in address units of a character to c-addr1, giving c-addr2.
1893afc2ba1dSToomas Soome */
1894afc2ba1dSToomas Soome static void
ficlPrimitiveCharPlus(ficlVm * vm)1895afc2ba1dSToomas Soome ficlPrimitiveCharPlus(ficlVm *vm)
1896afc2ba1dSToomas Soome {
1897afc2ba1dSToomas Soome char *p;
1898afc2ba1dSToomas Soome
1899afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1);
1900afc2ba1dSToomas Soome
1901afc2ba1dSToomas Soome p = ficlStackPopPointer(vm->dataStack);
1902afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, p + 1);
1903afc2ba1dSToomas Soome }
1904afc2ba1dSToomas Soome
1905afc2ba1dSToomas Soome /*
1906afc2ba1dSToomas Soome * c h a r s
1907afc2ba1dSToomas Soome * chars CORE ( n1 -- n2 )
1908afc2ba1dSToomas Soome * n2 is the size in address units of n1 characters.
1909afc2ba1dSToomas Soome * For most processors, this function can be a no-op. To guarantee
1910afc2ba1dSToomas Soome * portability, we'll multiply by sizeof (char).
1911afc2ba1dSToomas Soome */
1912afc2ba1dSToomas Soome #if defined(_M_IX86)
1913afc2ba1dSToomas Soome #pragma warning(disable: 4127)
1914afc2ba1dSToomas Soome #endif
1915afc2ba1dSToomas Soome static void
ficlPrimitiveChars(ficlVm * vm)1916afc2ba1dSToomas Soome ficlPrimitiveChars(ficlVm *vm)
1917afc2ba1dSToomas Soome {
1918afc2ba1dSToomas Soome if (sizeof (char) > 1) {
1919afc2ba1dSToomas Soome ficlInteger i;
1920afc2ba1dSToomas Soome
1921afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1);
1922afc2ba1dSToomas Soome
1923afc2ba1dSToomas Soome i = ficlStackPopInteger(vm->dataStack);
1924afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, i * sizeof (char));
1925afc2ba1dSToomas Soome }
1926afc2ba1dSToomas Soome /* otherwise no-op! */
1927afc2ba1dSToomas Soome }
1928afc2ba1dSToomas Soome #if defined(_M_IX86)
1929afc2ba1dSToomas Soome #pragma warning(default: 4127)
1930afc2ba1dSToomas Soome #endif
1931afc2ba1dSToomas Soome
1932afc2ba1dSToomas Soome /*
1933afc2ba1dSToomas Soome * c o u n t
1934afc2ba1dSToomas Soome * COUNT CORE ( c-addr1 -- c-addr2 u )
1935afc2ba1dSToomas Soome * Return the character string specification for the counted string stored
1936afc2ba1dSToomas Soome * at c-addr1. c-addr2 is the address of the first character after c-addr1.
1937afc2ba1dSToomas Soome * u is the contents of the character at c-addr1, which is the length in
1938afc2ba1dSToomas Soome * characters of the string at c-addr2.
1939afc2ba1dSToomas Soome */
1940afc2ba1dSToomas Soome static void
ficlPrimitiveCount(ficlVm * vm)1941afc2ba1dSToomas Soome ficlPrimitiveCount(ficlVm *vm)
1942afc2ba1dSToomas Soome {
1943afc2ba1dSToomas Soome ficlCountedString *counted;
1944afc2ba1dSToomas Soome
1945afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2);
1946afc2ba1dSToomas Soome
1947afc2ba1dSToomas Soome counted = ficlStackPopPointer(vm->dataStack);
1948afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, counted->text);
1949afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, counted->length);
1950afc2ba1dSToomas Soome }
1951afc2ba1dSToomas Soome
1952afc2ba1dSToomas Soome /*
1953afc2ba1dSToomas Soome * e n v i r o n m e n t ?
1954afc2ba1dSToomas Soome * environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE )
1955afc2ba1dSToomas Soome * c-addr is the address of a character string and u is the string's
1956afc2ba1dSToomas Soome * character count. u may have a value in the range from zero to an
1957afc2ba1dSToomas Soome * implementation-defined maximum which shall not be less than 31. The
1958afc2ba1dSToomas Soome * character string should contain a keyword from 3.2.6 Environmental
1959afc2ba1dSToomas Soome * queries or the optional word sets to be checked for correspondence
1960afc2ba1dSToomas Soome * with an attribute of the present environment. If the system treats the
1961afc2ba1dSToomas Soome * attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag
1962afc2ba1dSToomas Soome * is FICL_TRUE and the i*x returned is of the type specified in the table for
1963afc2ba1dSToomas Soome * the attribute queried.
1964afc2ba1dSToomas Soome */
1965afc2ba1dSToomas Soome static void
ficlPrimitiveEnvironmentQ(ficlVm * vm)1966afc2ba1dSToomas Soome ficlPrimitiveEnvironmentQ(ficlVm *vm)
1967afc2ba1dSToomas Soome {
1968afc2ba1dSToomas Soome ficlDictionary *environment;
1969afc2ba1dSToomas Soome ficlWord *word;
1970afc2ba1dSToomas Soome ficlString name;
1971afc2ba1dSToomas Soome
1972afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 1);
1973afc2ba1dSToomas Soome
1974afc2ba1dSToomas Soome environment = vm->callback.system->environment;
1975afc2ba1dSToomas Soome name.length = ficlStackPopUnsigned(vm->dataStack);
1976afc2ba1dSToomas Soome name.text = ficlStackPopPointer(vm->dataStack);
1977afc2ba1dSToomas Soome
1978afc2ba1dSToomas Soome word = ficlDictionaryLookup(environment, name);
1979afc2ba1dSToomas Soome
1980afc2ba1dSToomas Soome if (word != NULL) {
1981afc2ba1dSToomas Soome ficlVmExecuteWord(vm, word);
1982afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, FICL_TRUE);
1983afc2ba1dSToomas Soome } else {
1984afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, FICL_FALSE);
1985afc2ba1dSToomas Soome }
1986afc2ba1dSToomas Soome }
1987afc2ba1dSToomas Soome
1988afc2ba1dSToomas Soome /*
1989afc2ba1dSToomas Soome * e v a l u a t e
1990afc2ba1dSToomas Soome * EVALUATE CORE ( i*x c-addr u -- j*x )
1991afc2ba1dSToomas Soome * Save the current input source specification. Store minus-one (-1) in
1992afc2ba1dSToomas Soome * SOURCE-ID if it is present. Make the string described by c-addr and u
1993afc2ba1dSToomas Soome * both the input source and input buffer, set >IN to zero, and
1994afc2ba1dSToomas Soome * FICL_VM_STATE_INTERPRET.
1995afc2ba1dSToomas Soome * When the parse area is empty, restore the prior input source
1996afc2ba1dSToomas Soome * specification. Other stack effects are due to the words EVALUATEd.
1997afc2ba1dSToomas Soome */
1998afc2ba1dSToomas Soome static void
ficlPrimitiveEvaluate(ficlVm * vm)1999afc2ba1dSToomas Soome ficlPrimitiveEvaluate(ficlVm *vm)
2000afc2ba1dSToomas Soome {
2001afc2ba1dSToomas Soome ficlCell id;
2002afc2ba1dSToomas Soome int result;
2003afc2ba1dSToomas Soome ficlString string;
2004afc2ba1dSToomas Soome
2005afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
2006afc2ba1dSToomas Soome
2007afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(string, ficlStackPopUnsigned(vm->dataStack));
2008afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(string, ficlStackPopPointer(vm->dataStack));
2009afc2ba1dSToomas Soome
2010afc2ba1dSToomas Soome id = vm->sourceId;
2011afc2ba1dSToomas Soome vm->sourceId.i = -1;
2012afc2ba1dSToomas Soome result = ficlVmExecuteString(vm, string);
2013afc2ba1dSToomas Soome vm->sourceId = id;
2014afc2ba1dSToomas Soome if (result != FICL_VM_STATUS_OUT_OF_TEXT)
2015afc2ba1dSToomas Soome ficlVmThrow(vm, result);
2016afc2ba1dSToomas Soome }
2017afc2ba1dSToomas Soome
2018afc2ba1dSToomas Soome /*
2019afc2ba1dSToomas Soome * s t r i n g q u o t e
2020afc2ba1dSToomas Soome * Interpreting: get string delimited by a quote from the input stream,
2021afc2ba1dSToomas Soome * copy to a scratch area, and put its count and address on the stack.
2022afc2ba1dSToomas Soome * Compiling: FICL_VM_STATE_COMPILE code to push the address and count
2023afc2ba1dSToomas Soome * of a string literal, FICL_VM_STATE_COMPILE the string from the input
2024afc2ba1dSToomas Soome * stream, and align the dictionary pointer.
2025afc2ba1dSToomas Soome */
2026afc2ba1dSToomas Soome static void
ficlPrimitiveStringQuoteIm(ficlVm * vm)2027afc2ba1dSToomas Soome ficlPrimitiveStringQuoteIm(ficlVm *vm)
2028afc2ba1dSToomas Soome {
2029afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2030afc2ba1dSToomas Soome
2031afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) {
2032afc2ba1dSToomas Soome ficlCountedString *counted;
2033afc2ba1dSToomas Soome counted = (ficlCountedString *)dictionary->here;
2034*c0bb4f73SToomas Soome (void) ficlVmGetString(vm, counted, '\"');
2035afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, counted->text);
2036afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, counted->length);
2037afc2ba1dSToomas Soome } else { /* FICL_VM_STATE_COMPILE state */
2038afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
2039afc2ba1dSToomas Soome ficlInstructionStringLiteralParen);
2040afc2ba1dSToomas Soome dictionary->here = FICL_POINTER_TO_CELL(
2041afc2ba1dSToomas Soome ficlVmGetString(vm, (ficlCountedString *)dictionary->here,
2042afc2ba1dSToomas Soome '\"'));
2043afc2ba1dSToomas Soome ficlDictionaryAlign(dictionary);
2044afc2ba1dSToomas Soome }
2045afc2ba1dSToomas Soome }
2046afc2ba1dSToomas Soome
2047afc2ba1dSToomas Soome /*
2048afc2ba1dSToomas Soome * t y p e
2049afc2ba1dSToomas Soome * Pop count and char address from stack and print the designated string.
2050afc2ba1dSToomas Soome */
2051afc2ba1dSToomas Soome static void
ficlPrimitiveType(ficlVm * vm)2052afc2ba1dSToomas Soome ficlPrimitiveType(ficlVm *vm)
2053afc2ba1dSToomas Soome {
2054afc2ba1dSToomas Soome ficlUnsigned length;
2055afc2ba1dSToomas Soome char *s;
2056afc2ba1dSToomas Soome
2057afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
2058afc2ba1dSToomas Soome
2059afc2ba1dSToomas Soome length = ficlStackPopUnsigned(vm->dataStack);
2060afc2ba1dSToomas Soome s = ficlStackPopPointer(vm->dataStack);
2061afc2ba1dSToomas Soome
2062afc2ba1dSToomas Soome if ((s == NULL) || (length == 0))
2063afc2ba1dSToomas Soome return;
2064afc2ba1dSToomas Soome
2065afc2ba1dSToomas Soome /*
2066afc2ba1dSToomas Soome * Since we don't have an output primitive for a counted string
2067afc2ba1dSToomas Soome * (oops), make sure the string is null terminated. If not, copy
2068afc2ba1dSToomas Soome * and terminate it.
2069afc2ba1dSToomas Soome */
2070afc2ba1dSToomas Soome if (s[length] != 0) {
2071afc2ba1dSToomas Soome char *here = (char *)ficlVmGetDictionary(vm)->here;
2072afc2ba1dSToomas Soome if (s != here)
2073*c0bb4f73SToomas Soome (void) strncpy(here, s, length);
2074afc2ba1dSToomas Soome
2075afc2ba1dSToomas Soome here[length] = '\0';
2076afc2ba1dSToomas Soome s = here;
2077afc2ba1dSToomas Soome }
2078afc2ba1dSToomas Soome
2079afc2ba1dSToomas Soome ficlVmTextOut(vm, s);
2080afc2ba1dSToomas Soome }
2081afc2ba1dSToomas Soome
2082afc2ba1dSToomas Soome /*
2083afc2ba1dSToomas Soome * w o r d
2084afc2ba1dSToomas Soome * word CORE ( char "<chars>ccc<char>" -- c-addr )
2085afc2ba1dSToomas Soome * Skip leading delimiters. Parse characters ccc delimited by char. An
2086afc2ba1dSToomas Soome * ambiguous condition exists if the length of the parsed string is greater
2087afc2ba1dSToomas Soome * than the implementation-defined length of a counted string.
2088afc2ba1dSToomas Soome *
2089afc2ba1dSToomas Soome * c-addr is the address of a transient region containing the parsed word
2090afc2ba1dSToomas Soome * as a counted string. If the parse area was empty or contained no
2091afc2ba1dSToomas Soome * characters other than the delimiter, the resulting string has a zero
2092afc2ba1dSToomas Soome * length. A space, not included in the length, follows the string. A
2093afc2ba1dSToomas Soome * program may replace characters within the string.
2094afc2ba1dSToomas Soome * NOTE! Ficl also NULL-terminates the dest string.
2095afc2ba1dSToomas Soome */
2096afc2ba1dSToomas Soome static void
ficlPrimitiveWord(ficlVm * vm)2097afc2ba1dSToomas Soome ficlPrimitiveWord(ficlVm *vm)
2098afc2ba1dSToomas Soome {
2099afc2ba1dSToomas Soome ficlCountedString *counted;
2100afc2ba1dSToomas Soome char delim;
2101afc2ba1dSToomas Soome ficlString name;
2102afc2ba1dSToomas Soome
2103afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1);
2104afc2ba1dSToomas Soome
2105afc2ba1dSToomas Soome counted = (ficlCountedString *)vm->pad;
2106afc2ba1dSToomas Soome delim = (char)ficlStackPopInteger(vm->dataStack);
2107afc2ba1dSToomas Soome name = ficlVmParseStringEx(vm, delim, 1);
2108afc2ba1dSToomas Soome
2109afc2ba1dSToomas Soome if (FICL_STRING_GET_LENGTH(name) > FICL_PAD_SIZE - 1)
2110afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(name, FICL_PAD_SIZE - 1);
2111afc2ba1dSToomas Soome
2112afc2ba1dSToomas Soome counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name);
2113*c0bb4f73SToomas Soome (void) strncpy(counted->text, FICL_STRING_GET_POINTER(name),
2114afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(name));
2115afc2ba1dSToomas Soome
2116afc2ba1dSToomas Soome /*
2117afc2ba1dSToomas Soome * store an extra space at the end of the primitive...
2118afc2ba1dSToomas Soome * why? dunno yet. Guy Carver did it.
2119afc2ba1dSToomas Soome */
2120afc2ba1dSToomas Soome counted->text[counted->length] = ' ';
2121afc2ba1dSToomas Soome counted->text[counted->length + 1] = 0;
2122afc2ba1dSToomas Soome
2123afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, counted);
2124afc2ba1dSToomas Soome }
2125afc2ba1dSToomas Soome
2126afc2ba1dSToomas Soome /*
2127afc2ba1dSToomas Soome * p a r s e - w o r d
2128afc2ba1dSToomas Soome * Ficl PARSE-WORD ( <spaces>name -- c-addr u )
2129afc2ba1dSToomas Soome * Skip leading spaces and parse name delimited by a space. c-addr is the
2130afc2ba1dSToomas Soome * address within the input buffer and u is the length of the selected
2131afc2ba1dSToomas Soome * string. If the parse area is empty, the resulting string has a zero length.
2132afc2ba1dSToomas Soome */
ficlPrimitiveParseNoCopy(ficlVm * vm)2133afc2ba1dSToomas Soome static void ficlPrimitiveParseNoCopy(ficlVm *vm)
2134afc2ba1dSToomas Soome {
2135afc2ba1dSToomas Soome ficlString s;
2136afc2ba1dSToomas Soome
2137afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 2);
2138afc2ba1dSToomas Soome
2139afc2ba1dSToomas Soome s = ficlVmGetWord0(vm);
2140afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
2141afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
2142afc2ba1dSToomas Soome }
2143afc2ba1dSToomas Soome
2144afc2ba1dSToomas Soome /*
2145afc2ba1dSToomas Soome * p a r s e
2146afc2ba1dSToomas Soome * CORE EXT ( char "ccc<char>" -- c-addr u )
2147afc2ba1dSToomas Soome * Parse ccc delimited by the delimiter char.
2148afc2ba1dSToomas Soome * c-addr is the address (within the input buffer) and u is the length of
2149afc2ba1dSToomas Soome * the parsed string. If the parse area was empty, the resulting string has
2150afc2ba1dSToomas Soome * a zero length.
2151afc2ba1dSToomas Soome * NOTE! PARSE differs from WORD: it does not skip leading delimiters.
2152afc2ba1dSToomas Soome */
2153afc2ba1dSToomas Soome static void
ficlPrimitiveParse(ficlVm * vm)2154afc2ba1dSToomas Soome ficlPrimitiveParse(ficlVm *vm)
2155afc2ba1dSToomas Soome {
2156afc2ba1dSToomas Soome ficlString s;
2157afc2ba1dSToomas Soome char delim;
2158afc2ba1dSToomas Soome
2159afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2);
2160afc2ba1dSToomas Soome
2161afc2ba1dSToomas Soome delim = (char)ficlStackPopInteger(vm->dataStack);
2162afc2ba1dSToomas Soome
2163afc2ba1dSToomas Soome s = ficlVmParseStringEx(vm, delim, 0);
2164afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
2165afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
2166afc2ba1dSToomas Soome }
2167afc2ba1dSToomas Soome
2168afc2ba1dSToomas Soome /*
2169afc2ba1dSToomas Soome * f i n d
2170afc2ba1dSToomas Soome * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2171afc2ba1dSToomas Soome * Find the definition named in the counted string at c-addr. If the
2172afc2ba1dSToomas Soome * definition is not found, return c-addr and zero. If the definition is
2173afc2ba1dSToomas Soome * found, return its execution token xt. If the definition is immediate,
2174afc2ba1dSToomas Soome * also return one (1), otherwise also return minus-one (-1). For a given
2175afc2ba1dSToomas Soome * string, the values returned by FIND while compiling may differ from
2176afc2ba1dSToomas Soome * those returned while not compiling.
2177afc2ba1dSToomas Soome */
2178afc2ba1dSToomas Soome static void
do_find(ficlVm * vm,ficlString name,void * returnForFailure)2179afc2ba1dSToomas Soome do_find(ficlVm *vm, ficlString name, void *returnForFailure)
2180afc2ba1dSToomas Soome {
2181afc2ba1dSToomas Soome ficlWord *word;
2182afc2ba1dSToomas Soome
2183afc2ba1dSToomas Soome word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
2184afc2ba1dSToomas Soome if (word) {
2185afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, word);
2186afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack,
2187afc2ba1dSToomas Soome (ficlWordIsImmediate(word) ? 1 : -1));
2188afc2ba1dSToomas Soome } else {
2189afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, returnForFailure);
2190afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, 0);
2191afc2ba1dSToomas Soome }
2192afc2ba1dSToomas Soome }
2193afc2ba1dSToomas Soome
2194afc2ba1dSToomas Soome /*
2195afc2ba1dSToomas Soome * f i n d
2196afc2ba1dSToomas Soome * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2197afc2ba1dSToomas Soome * Find the definition named in the counted string at c-addr. If the
2198afc2ba1dSToomas Soome * definition is not found, return c-addr and zero. If the definition is
2199afc2ba1dSToomas Soome * found, return its execution token xt. If the definition is immediate,
2200afc2ba1dSToomas Soome * also return one (1), otherwise also return minus-one (-1). For a given
2201afc2ba1dSToomas Soome * string, the values returned by FIND while compiling may differ from
2202afc2ba1dSToomas Soome * those returned while not compiling.
2203afc2ba1dSToomas Soome */
2204afc2ba1dSToomas Soome static void
ficlPrimitiveCFind(ficlVm * vm)2205afc2ba1dSToomas Soome ficlPrimitiveCFind(ficlVm *vm)
2206afc2ba1dSToomas Soome {
2207afc2ba1dSToomas Soome ficlCountedString *counted;
2208afc2ba1dSToomas Soome ficlString name;
2209afc2ba1dSToomas Soome
2210afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2);
2211afc2ba1dSToomas Soome
2212afc2ba1dSToomas Soome counted = ficlStackPopPointer(vm->dataStack);
2213afc2ba1dSToomas Soome FICL_STRING_SET_FROM_COUNTED_STRING(name, *counted);
2214afc2ba1dSToomas Soome do_find(vm, name, counted);
2215afc2ba1dSToomas Soome }
2216afc2ba1dSToomas Soome
2217afc2ba1dSToomas Soome /*
2218afc2ba1dSToomas Soome * s f i n d
2219afc2ba1dSToomas Soome * Ficl ( c-addr u -- 0 0 | xt 1 | xt -1 )
2220afc2ba1dSToomas Soome * Like FIND, but takes "c-addr u" for the string.
2221afc2ba1dSToomas Soome */
2222afc2ba1dSToomas Soome static void
ficlPrimitiveSFind(ficlVm * vm)2223afc2ba1dSToomas Soome ficlPrimitiveSFind(ficlVm *vm)
2224afc2ba1dSToomas Soome {
2225afc2ba1dSToomas Soome ficlString name;
2226afc2ba1dSToomas Soome
2227afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2);
2228afc2ba1dSToomas Soome
2229afc2ba1dSToomas Soome name.length = ficlStackPopInteger(vm->dataStack);
2230afc2ba1dSToomas Soome name.text = ficlStackPopPointer(vm->dataStack);
2231afc2ba1dSToomas Soome
2232afc2ba1dSToomas Soome do_find(vm, name, NULL);
2233afc2ba1dSToomas Soome }
2234afc2ba1dSToomas Soome
2235afc2ba1dSToomas Soome /*
2236afc2ba1dSToomas Soome * r e c u r s e
2237afc2ba1dSToomas Soome */
2238afc2ba1dSToomas Soome static void
ficlPrimitiveRecurseCoIm(ficlVm * vm)2239afc2ba1dSToomas Soome ficlPrimitiveRecurseCoIm(ficlVm *vm)
2240afc2ba1dSToomas Soome {
2241afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2242afc2ba1dSToomas Soome ficlCell c;
2243afc2ba1dSToomas Soome
2244afc2ba1dSToomas Soome FICL_IGNORE(vm);
2245afc2ba1dSToomas Soome c.p = dictionary->smudge;
2246afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, c);
2247afc2ba1dSToomas Soome }
2248afc2ba1dSToomas Soome
2249afc2ba1dSToomas Soome /*
2250afc2ba1dSToomas Soome * s o u r c e
2251afc2ba1dSToomas Soome * CORE ( -- c-addr u )
2252afc2ba1dSToomas Soome * c-addr is the address of, and u is the number of characters in, the
2253afc2ba1dSToomas Soome * input buffer.
2254afc2ba1dSToomas Soome */
2255afc2ba1dSToomas Soome static void
ficlPrimitiveSource(ficlVm * vm)2256afc2ba1dSToomas Soome ficlPrimitiveSource(ficlVm *vm)
2257afc2ba1dSToomas Soome {
2258afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 2);
2259afc2ba1dSToomas Soome
2260afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, vm->tib.text);
2261afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, ficlVmGetInBufLen(vm));
2262afc2ba1dSToomas Soome }
2263afc2ba1dSToomas Soome
2264afc2ba1dSToomas Soome /*
2265afc2ba1dSToomas Soome * v e r s i o n
2266afc2ba1dSToomas Soome * non-standard...
2267afc2ba1dSToomas Soome */
2268afc2ba1dSToomas Soome static void
ficlPrimitiveVersion(ficlVm * vm)2269afc2ba1dSToomas Soome ficlPrimitiveVersion(ficlVm *vm)
2270afc2ba1dSToomas Soome {
2271afc2ba1dSToomas Soome ficlVmTextOut(vm, "Ficl version " FICL_VERSION "\n");
2272afc2ba1dSToomas Soome }
2273afc2ba1dSToomas Soome
2274afc2ba1dSToomas Soome /*
2275afc2ba1dSToomas Soome * t o I n
2276afc2ba1dSToomas Soome * to-in CORE
2277afc2ba1dSToomas Soome */
2278afc2ba1dSToomas Soome static void
ficlPrimitiveToIn(ficlVm * vm)2279afc2ba1dSToomas Soome ficlPrimitiveToIn(ficlVm *vm)
2280afc2ba1dSToomas Soome {
2281afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
2282afc2ba1dSToomas Soome
2283afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, &vm->tib.index);
2284afc2ba1dSToomas Soome }
2285afc2ba1dSToomas Soome
2286afc2ba1dSToomas Soome /*
2287afc2ba1dSToomas Soome * c o l o n N o N a m e
2288afc2ba1dSToomas Soome * CORE EXT ( C: -- colon-sys ) ( S: -- xt )
2289afc2ba1dSToomas Soome * Create an unnamed colon definition and push its address.
2290afc2ba1dSToomas Soome * Change state to FICL_VM_STATE_COMPILE.
2291afc2ba1dSToomas Soome */
2292afc2ba1dSToomas Soome static void
ficlPrimitiveColonNoName(ficlVm * vm)2293afc2ba1dSToomas Soome ficlPrimitiveColonNoName(ficlVm *vm)
2294afc2ba1dSToomas Soome {
2295afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2296afc2ba1dSToomas Soome ficlWord *word;
2297afc2ba1dSToomas Soome ficlString name;
2298afc2ba1dSToomas Soome
2299afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(name, 0);
2300afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(name, NULL);
2301afc2ba1dSToomas Soome
2302afc2ba1dSToomas Soome vm->state = FICL_VM_STATE_COMPILE;
2303afc2ba1dSToomas Soome word = ficlDictionaryAppendWord(dictionary, name,
2304afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionColonParen,
2305afc2ba1dSToomas Soome FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
2306afc2ba1dSToomas Soome
2307afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, word);
2308afc2ba1dSToomas Soome markControlTag(vm, colonTag);
2309afc2ba1dSToomas Soome }
2310afc2ba1dSToomas Soome
2311afc2ba1dSToomas Soome /*
2312afc2ba1dSToomas Soome * u s e r V a r i a b l e
2313afc2ba1dSToomas Soome * user ( u -- ) "<spaces>name"
2314afc2ba1dSToomas Soome * Get a name from the input stream and create a user variable
2315afc2ba1dSToomas Soome * with the name and the index supplied. The run-time effect
2316afc2ba1dSToomas Soome * of a user variable is to push the address of the indexed ficlCell
2317afc2ba1dSToomas Soome * in the running vm's user array.
2318afc2ba1dSToomas Soome *
2319afc2ba1dSToomas Soome * User variables are vm local cells. Each vm has an array of
2320afc2ba1dSToomas Soome * FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
2321afc2ba1dSToomas Soome * Ficl's user facility is implemented with two primitives,
2322afc2ba1dSToomas Soome * "user" and "(user)", a variable ("nUser") (in softcore.c) that
2323afc2ba1dSToomas Soome * holds the index of the next free user ficlCell, and a redefinition
2324afc2ba1dSToomas Soome * (also in softcore) of "user" that defines a user word and increments
2325afc2ba1dSToomas Soome * nUser.
2326afc2ba1dSToomas Soome */
2327afc2ba1dSToomas Soome #if FICL_WANT_USER
2328afc2ba1dSToomas Soome static void
ficlPrimitiveUser(ficlVm * vm)2329afc2ba1dSToomas Soome ficlPrimitiveUser(ficlVm *vm)
2330afc2ba1dSToomas Soome {
2331afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2332afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
2333afc2ba1dSToomas Soome ficlCell c;
2334afc2ba1dSToomas Soome
2335afc2ba1dSToomas Soome c = ficlStackPop(vm->dataStack);
2336afc2ba1dSToomas Soome if (c.i >= FICL_USER_CELLS) {
2337afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error - out of user space");
2338afc2ba1dSToomas Soome }
2339afc2ba1dSToomas Soome
2340*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
2341afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT);
2342afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, c);
2343afc2ba1dSToomas Soome }
2344afc2ba1dSToomas Soome #endif
2345afc2ba1dSToomas Soome
2346afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2347afc2ba1dSToomas Soome /*
2348afc2ba1dSToomas Soome * Each local is recorded in a private locals dictionary as a
2349afc2ba1dSToomas Soome * word that does doLocalIm at runtime. DoLocalIm compiles code
2350afc2ba1dSToomas Soome * into the client definition to fetch the value of the
2351afc2ba1dSToomas Soome * corresponding local variable from the return stack.
2352afc2ba1dSToomas Soome * The private dictionary gets initialized at the end of each block
2353afc2ba1dSToomas Soome * that uses locals (in ; and does> for example).
2354afc2ba1dSToomas Soome */
2355afc2ba1dSToomas Soome void
ficlLocalParenIm(ficlVm * vm,int isDouble,int isFloat)2356afc2ba1dSToomas Soome ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat)
2357afc2ba1dSToomas Soome {
2358afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2359afc2ba1dSToomas Soome ficlInteger nLocal = vm->runningWord->param[0].i;
2360afc2ba1dSToomas Soome
2361afc2ba1dSToomas Soome #if !FICL_WANT_FLOAT
2362afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, !isFloat);
2363afc2ba1dSToomas Soome /* get rid of unused parameter warning */
2364afc2ba1dSToomas Soome isFloat = 0;
2365afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2366afc2ba1dSToomas Soome
2367afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) {
2368afc2ba1dSToomas Soome ficlStack *stack;
2369afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2370afc2ba1dSToomas Soome if (isFloat)
2371afc2ba1dSToomas Soome stack = vm->floatStack;
2372afc2ba1dSToomas Soome else
2373afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2374afc2ba1dSToomas Soome stack = vm->dataStack;
2375afc2ba1dSToomas Soome
2376afc2ba1dSToomas Soome ficlStackPush(stack, vm->returnStack->frame[nLocal]);
2377afc2ba1dSToomas Soome if (isDouble)
2378afc2ba1dSToomas Soome ficlStackPush(stack, vm->returnStack->frame[nLocal+1]);
2379afc2ba1dSToomas Soome } else {
2380afc2ba1dSToomas Soome ficlInstruction instruction;
2381afc2ba1dSToomas Soome ficlInteger appendLocalOffset;
2382afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2383afc2ba1dSToomas Soome if (isFloat) {
2384afc2ba1dSToomas Soome instruction =
2385afc2ba1dSToomas Soome (isDouble) ? ficlInstructionGetF2LocalParen :
2386afc2ba1dSToomas Soome ficlInstructionGetFLocalParen;
2387afc2ba1dSToomas Soome appendLocalOffset = FICL_TRUE;
2388afc2ba1dSToomas Soome } else
2389afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2390afc2ba1dSToomas Soome if (nLocal == 0) {
2391afc2ba1dSToomas Soome instruction = (isDouble) ? ficlInstructionGet2Local0 :
2392afc2ba1dSToomas Soome ficlInstructionGetLocal0;
2393afc2ba1dSToomas Soome appendLocalOffset = FICL_FALSE;
2394afc2ba1dSToomas Soome } else if ((nLocal == 1) && !isDouble) {
2395afc2ba1dSToomas Soome instruction = ficlInstructionGetLocal1;
2396afc2ba1dSToomas Soome appendLocalOffset = FICL_FALSE;
2397afc2ba1dSToomas Soome } else {
2398afc2ba1dSToomas Soome instruction =
2399afc2ba1dSToomas Soome (isDouble) ? ficlInstructionGet2LocalParen :
2400afc2ba1dSToomas Soome ficlInstructionGetLocalParen;
2401afc2ba1dSToomas Soome appendLocalOffset = FICL_TRUE;
2402afc2ba1dSToomas Soome }
2403afc2ba1dSToomas Soome
2404afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction);
2405afc2ba1dSToomas Soome if (appendLocalOffset)
2406afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, nLocal);
2407afc2ba1dSToomas Soome }
2408afc2ba1dSToomas Soome }
2409afc2ba1dSToomas Soome
2410afc2ba1dSToomas Soome static void
ficlPrimitiveDoLocalIm(ficlVm * vm)2411afc2ba1dSToomas Soome ficlPrimitiveDoLocalIm(ficlVm *vm)
2412afc2ba1dSToomas Soome {
2413afc2ba1dSToomas Soome ficlLocalParenIm(vm, 0, 0);
2414afc2ba1dSToomas Soome }
2415afc2ba1dSToomas Soome
2416afc2ba1dSToomas Soome static void
ficlPrimitiveDo2LocalIm(ficlVm * vm)2417afc2ba1dSToomas Soome ficlPrimitiveDo2LocalIm(ficlVm *vm)
2418afc2ba1dSToomas Soome {
2419afc2ba1dSToomas Soome ficlLocalParenIm(vm, 1, 0);
2420afc2ba1dSToomas Soome }
2421afc2ba1dSToomas Soome
2422afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2423afc2ba1dSToomas Soome static void
ficlPrimitiveDoFLocalIm(ficlVm * vm)2424afc2ba1dSToomas Soome ficlPrimitiveDoFLocalIm(ficlVm *vm)
2425afc2ba1dSToomas Soome {
2426afc2ba1dSToomas Soome ficlLocalParenIm(vm, 0, 1);
2427afc2ba1dSToomas Soome }
2428afc2ba1dSToomas Soome
2429afc2ba1dSToomas Soome static void
ficlPrimitiveDoF2LocalIm(ficlVm * vm)2430afc2ba1dSToomas Soome ficlPrimitiveDoF2LocalIm(ficlVm *vm)
2431afc2ba1dSToomas Soome {
2432afc2ba1dSToomas Soome ficlLocalParenIm(vm, 1, 1);
2433afc2ba1dSToomas Soome }
2434afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2435afc2ba1dSToomas Soome
2436afc2ba1dSToomas Soome /*
2437afc2ba1dSToomas Soome * l o c a l P a r e n
2438afc2ba1dSToomas Soome * paren-local-paren LOCAL
2439afc2ba1dSToomas Soome * Interpretation: Interpretation semantics for this word are undefined.
2440afc2ba1dSToomas Soome * Execution: ( c-addr u -- )
2441afc2ba1dSToomas Soome * When executed during compilation, (LOCAL) passes a message to the
2442afc2ba1dSToomas Soome * system that has one of two meanings. If u is non-zero,
2443afc2ba1dSToomas Soome * the message identifies a new local whose definition name is given by
2444afc2ba1dSToomas Soome * the string of characters identified by c-addr u. If u is zero,
2445afc2ba1dSToomas Soome * the message is last local and c-addr has no significance.
2446afc2ba1dSToomas Soome *
2447afc2ba1dSToomas Soome * The result of executing (LOCAL) during compilation of a definition is
2448afc2ba1dSToomas Soome * to create a set of named local identifiers, each of which is
2449afc2ba1dSToomas Soome * a definition name, that only have execution semantics within the scope
2450afc2ba1dSToomas Soome * of that definition's source.
2451afc2ba1dSToomas Soome *
2452afc2ba1dSToomas Soome * local Execution: ( -- x )
2453afc2ba1dSToomas Soome *
2454afc2ba1dSToomas Soome * Push the local's value, x, onto the stack. The local's value is
2455afc2ba1dSToomas Soome * initialized as described in 13.3.3 Processing locals and may be
2456afc2ba1dSToomas Soome * changed by preceding the local's name with TO. An ambiguous condition
2457afc2ba1dSToomas Soome * exists when local is executed while in interpretation state.
2458afc2ba1dSToomas Soome */
2459afc2ba1dSToomas Soome void
ficlLocalParen(ficlVm * vm,int isDouble,int isFloat)2460afc2ba1dSToomas Soome ficlLocalParen(ficlVm *vm, int isDouble, int isFloat)
2461afc2ba1dSToomas Soome {
2462afc2ba1dSToomas Soome ficlDictionary *dictionary;
2463afc2ba1dSToomas Soome ficlString name;
2464afc2ba1dSToomas Soome
2465afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0);
2466afc2ba1dSToomas Soome
2467afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
2468afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
2469afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(name,
2470afc2ba1dSToomas Soome (char *)ficlStackPopPointer(vm->dataStack));
2471afc2ba1dSToomas Soome
2472afc2ba1dSToomas Soome if (FICL_STRING_GET_LENGTH(name) > 0) {
2473afc2ba1dSToomas Soome /*
2474afc2ba1dSToomas Soome * add a local to the **locals** dictionary and
2475afc2ba1dSToomas Soome * update localsCount
2476afc2ba1dSToomas Soome */
2477afc2ba1dSToomas Soome ficlPrimitive code;
2478afc2ba1dSToomas Soome ficlInstruction instruction;
2479afc2ba1dSToomas Soome ficlDictionary *locals;
2480afc2ba1dSToomas Soome
2481afc2ba1dSToomas Soome locals = ficlSystemGetLocals(vm->callback.system);
2482afc2ba1dSToomas Soome if (vm->callback.system->localsCount >= FICL_MAX_LOCALS) {
2483afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error: out of local space");
2484afc2ba1dSToomas Soome }
2485afc2ba1dSToomas Soome
2486afc2ba1dSToomas Soome #if !FICL_WANT_FLOAT
2487afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, !isFloat);
2488afc2ba1dSToomas Soome /* get rid of unused parameter warning */
2489afc2ba1dSToomas Soome isFloat = 0;
2490afc2ba1dSToomas Soome #else /* FICL_WANT_FLOAT */
2491afc2ba1dSToomas Soome if (isFloat) {
2492afc2ba1dSToomas Soome if (isDouble) {
2493afc2ba1dSToomas Soome code = ficlPrimitiveDoF2LocalIm;
2494afc2ba1dSToomas Soome instruction = ficlInstructionToF2LocalParen;
2495afc2ba1dSToomas Soome } else {
2496afc2ba1dSToomas Soome code = ficlPrimitiveDoFLocalIm;
2497afc2ba1dSToomas Soome instruction = ficlInstructionToFLocalParen;
2498afc2ba1dSToomas Soome }
2499afc2ba1dSToomas Soome } else
2500afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2501afc2ba1dSToomas Soome if (isDouble) {
2502afc2ba1dSToomas Soome code = ficlPrimitiveDo2LocalIm;
2503afc2ba1dSToomas Soome instruction = ficlInstructionTo2LocalParen;
2504afc2ba1dSToomas Soome } else {
2505afc2ba1dSToomas Soome code = ficlPrimitiveDoLocalIm;
2506afc2ba1dSToomas Soome instruction = ficlInstructionToLocalParen;
2507afc2ba1dSToomas Soome }
2508afc2ba1dSToomas Soome
2509*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(locals, name, code,
2510afc2ba1dSToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE);
2511afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(locals,
2512afc2ba1dSToomas Soome vm->callback.system->localsCount);
2513afc2ba1dSToomas Soome
2514afc2ba1dSToomas Soome if (vm->callback.system->localsCount == 0) {
2515afc2ba1dSToomas Soome /*
2516afc2ba1dSToomas Soome * FICL_VM_STATE_COMPILE code to create a local
2517afc2ba1dSToomas Soome * stack frame
2518afc2ba1dSToomas Soome */
2519afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
2520afc2ba1dSToomas Soome ficlInstructionLinkParen);
2521afc2ba1dSToomas Soome
2522afc2ba1dSToomas Soome /* save location in dictionary for #locals */
2523afc2ba1dSToomas Soome vm->callback.system->localsFixup = dictionary->here;
2524afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
2525afc2ba1dSToomas Soome vm->callback.system->localsCount);
2526afc2ba1dSToomas Soome }
2527afc2ba1dSToomas Soome
2528afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction);
2529afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
2530afc2ba1dSToomas Soome vm->callback.system->localsCount);
2531afc2ba1dSToomas Soome
2532afc2ba1dSToomas Soome vm->callback.system->localsCount += (isDouble) ? 2 : 1;
2533afc2ba1dSToomas Soome } else if (vm->callback.system->localsCount > 0) {
2534afc2ba1dSToomas Soome /* write localsCount to (link) param area in dictionary */
2535afc2ba1dSToomas Soome *(ficlInteger *)(vm->callback.system->localsFixup) =
2536afc2ba1dSToomas Soome vm->callback.system->localsCount;
2537afc2ba1dSToomas Soome }
2538afc2ba1dSToomas Soome }
2539afc2ba1dSToomas Soome
2540afc2ba1dSToomas Soome static void
ficlPrimitiveLocalParen(ficlVm * vm)2541afc2ba1dSToomas Soome ficlPrimitiveLocalParen(ficlVm *vm)
2542afc2ba1dSToomas Soome {
2543afc2ba1dSToomas Soome ficlLocalParen(vm, 0, 0);
2544afc2ba1dSToomas Soome }
2545afc2ba1dSToomas Soome
2546afc2ba1dSToomas Soome static void
ficlPrimitive2LocalParen(ficlVm * vm)2547afc2ba1dSToomas Soome ficlPrimitive2LocalParen(ficlVm *vm)
2548afc2ba1dSToomas Soome {
2549afc2ba1dSToomas Soome ficlLocalParen(vm, 1, 0);
2550afc2ba1dSToomas Soome }
2551afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
2552afc2ba1dSToomas Soome
2553afc2ba1dSToomas Soome /*
2554afc2ba1dSToomas Soome * t o V a l u e
2555afc2ba1dSToomas Soome * CORE EXT
2556afc2ba1dSToomas Soome * Interpretation: ( x "<spaces>name" -- )
2557afc2ba1dSToomas Soome * Skip leading spaces and parse name delimited by a space. Store x in
2558afc2ba1dSToomas Soome * name. An ambiguous condition exists if name was not defined by VALUE.
2559afc2ba1dSToomas Soome * NOTE: In Ficl, VALUE is an alias of CONSTANT
2560afc2ba1dSToomas Soome */
2561afc2ba1dSToomas Soome static void
ficlPrimitiveToValue(ficlVm * vm)2562afc2ba1dSToomas Soome ficlPrimitiveToValue(ficlVm *vm)
2563afc2ba1dSToomas Soome {
2564afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
2565afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2566afc2ba1dSToomas Soome ficlWord *word;
2567afc2ba1dSToomas Soome ficlInstruction instruction = 0;
2568afc2ba1dSToomas Soome ficlStack *stack;
2569afc2ba1dSToomas Soome ficlInteger isDouble;
2570afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2571afc2ba1dSToomas Soome ficlInteger nLocal;
2572afc2ba1dSToomas Soome ficlInteger appendLocalOffset;
2573afc2ba1dSToomas Soome ficlInteger isFloat;
2574afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
2575afc2ba1dSToomas Soome
2576afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2577afc2ba1dSToomas Soome if ((vm->callback.system->localsCount > 0) &&
2578afc2ba1dSToomas Soome (vm->state == FICL_VM_STATE_COMPILE)) {
2579afc2ba1dSToomas Soome ficlDictionary *locals;
2580afc2ba1dSToomas Soome
2581afc2ba1dSToomas Soome locals = ficlSystemGetLocals(vm->callback.system);
2582afc2ba1dSToomas Soome word = ficlDictionaryLookup(locals, name);
2583afc2ba1dSToomas Soome if (!word)
2584afc2ba1dSToomas Soome goto TO_GLOBAL;
2585afc2ba1dSToomas Soome
2586afc2ba1dSToomas Soome if (word->code == ficlPrimitiveDoLocalIm) {
2587afc2ba1dSToomas Soome instruction = ficlInstructionToLocalParen;
2588afc2ba1dSToomas Soome isDouble = isFloat = FICL_FALSE;
2589afc2ba1dSToomas Soome } else if (word->code == ficlPrimitiveDo2LocalIm) {
2590afc2ba1dSToomas Soome instruction = ficlInstructionTo2LocalParen;
2591afc2ba1dSToomas Soome isDouble = FICL_TRUE;
2592afc2ba1dSToomas Soome isFloat = FICL_FALSE;
2593afc2ba1dSToomas Soome }
2594afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2595afc2ba1dSToomas Soome else if (word->code == ficlPrimitiveDoFLocalIm) {
2596afc2ba1dSToomas Soome instruction = ficlInstructionToFLocalParen;
2597afc2ba1dSToomas Soome isDouble = FICL_FALSE;
2598afc2ba1dSToomas Soome isFloat = FICL_TRUE;
2599afc2ba1dSToomas Soome } else if (word->code == ficlPrimitiveDoF2LocalIm) {
2600afc2ba1dSToomas Soome instruction = ficlInstructionToF2LocalParen;
2601afc2ba1dSToomas Soome isDouble = isFloat = FICL_TRUE;
2602afc2ba1dSToomas Soome }
2603afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2604afc2ba1dSToomas Soome else {
2605afc2ba1dSToomas Soome ficlVmThrowError(vm,
2606afc2ba1dSToomas Soome "to %.*s : local is of unknown type",
2607afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(name),
2608afc2ba1dSToomas Soome FICL_STRING_GET_POINTER(name));
2609afc2ba1dSToomas Soome }
2610afc2ba1dSToomas Soome
2611afc2ba1dSToomas Soome nLocal = word->param[0].i;
2612afc2ba1dSToomas Soome appendLocalOffset = FICL_TRUE;
2613afc2ba1dSToomas Soome
2614afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2615afc2ba1dSToomas Soome if (!isFloat) {
2616afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2617afc2ba1dSToomas Soome if (nLocal == 0) {
2618afc2ba1dSToomas Soome instruction =
2619afc2ba1dSToomas Soome (isDouble) ? ficlInstructionTo2Local0 :
2620afc2ba1dSToomas Soome ficlInstructionToLocal0;
2621afc2ba1dSToomas Soome appendLocalOffset = FICL_FALSE;
2622afc2ba1dSToomas Soome } else if ((nLocal == 1) && !isDouble) {
2623afc2ba1dSToomas Soome instruction = ficlInstructionToLocal1;
2624afc2ba1dSToomas Soome appendLocalOffset = FICL_FALSE;
2625afc2ba1dSToomas Soome }
2626afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2627afc2ba1dSToomas Soome }
2628afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2629afc2ba1dSToomas Soome
2630afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction);
2631afc2ba1dSToomas Soome if (appendLocalOffset)
2632afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, nLocal);
2633afc2ba1dSToomas Soome return;
2634afc2ba1dSToomas Soome }
2635afc2ba1dSToomas Soome #endif
2636afc2ba1dSToomas Soome
2637afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2638afc2ba1dSToomas Soome TO_GLOBAL:
2639afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
2640afc2ba1dSToomas Soome word = ficlDictionaryLookup(dictionary, name);
2641afc2ba1dSToomas Soome if (!word)
2642afc2ba1dSToomas Soome ficlVmThrowError(vm, "%.*s not found",
2643afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(name),
2644afc2ba1dSToomas Soome FICL_STRING_GET_POINTER(name));
2645afc2ba1dSToomas Soome
2646afc2ba1dSToomas Soome switch ((ficlInstruction)word->code) {
2647afc2ba1dSToomas Soome case ficlInstructionConstantParen:
2648afc2ba1dSToomas Soome instruction = ficlInstructionStore;
2649afc2ba1dSToomas Soome stack = vm->dataStack;
2650afc2ba1dSToomas Soome isDouble = FICL_FALSE;
2651*c0bb4f73SToomas Soome break;
2652afc2ba1dSToomas Soome case ficlInstruction2ConstantParen:
2653afc2ba1dSToomas Soome instruction = ficlInstruction2Store;
2654afc2ba1dSToomas Soome stack = vm->dataStack;
2655afc2ba1dSToomas Soome isDouble = FICL_TRUE;
2656*c0bb4f73SToomas Soome break;
2657afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2658afc2ba1dSToomas Soome case ficlInstructionFConstantParen:
2659afc2ba1dSToomas Soome instruction = ficlInstructionFStore;
2660afc2ba1dSToomas Soome stack = vm->floatStack;
2661afc2ba1dSToomas Soome isDouble = FICL_FALSE;
2662*c0bb4f73SToomas Soome break;
2663afc2ba1dSToomas Soome case ficlInstructionF2ConstantParen:
2664afc2ba1dSToomas Soome instruction = ficlInstructionF2Store;
2665afc2ba1dSToomas Soome stack = vm->floatStack;
2666afc2ba1dSToomas Soome isDouble = FICL_TRUE;
2667*c0bb4f73SToomas Soome break;
2668afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2669afc2ba1dSToomas Soome default:
2670afc2ba1dSToomas Soome ficlVmThrowError(vm,
2671afc2ba1dSToomas Soome "to %.*s : value/constant is of unknown type",
2672afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(name),
2673afc2ba1dSToomas Soome FICL_STRING_GET_POINTER(name));
2674*c0bb4f73SToomas Soome break;
2675afc2ba1dSToomas Soome }
2676afc2ba1dSToomas Soome
2677afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) {
2678afc2ba1dSToomas Soome word->param[0] = ficlStackPop(stack);
2679afc2ba1dSToomas Soome if (isDouble)
2680afc2ba1dSToomas Soome word->param[1] = ficlStackPop(stack);
2681afc2ba1dSToomas Soome } else {
2682afc2ba1dSToomas Soome /* FICL_VM_STATE_COMPILE code to store to word's param */
2683afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, &word->param[0]);
2684afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(vm);
2685afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction);
2686afc2ba1dSToomas Soome }
2687afc2ba1dSToomas Soome }
2688afc2ba1dSToomas Soome
2689afc2ba1dSToomas Soome /*
2690afc2ba1dSToomas Soome * f m S l a s h M o d
2691afc2ba1dSToomas Soome * f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
2692afc2ba1dSToomas Soome * Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
2693afc2ba1dSToomas Soome * Input and output stack arguments are signed. An ambiguous condition
2694afc2ba1dSToomas Soome * exists if n1 is zero or if the quotient lies outside the range of a
2695afc2ba1dSToomas Soome * single-ficlCell signed integer.
2696afc2ba1dSToomas Soome */
2697afc2ba1dSToomas Soome static void
ficlPrimitiveFMSlashMod(ficlVm * vm)2698afc2ba1dSToomas Soome ficlPrimitiveFMSlashMod(ficlVm *vm)
2699afc2ba1dSToomas Soome {
2700afc2ba1dSToomas Soome ficl2Integer d1;
2701afc2ba1dSToomas Soome ficlInteger n1;
2702afc2ba1dSToomas Soome ficl2IntegerQR qr;
2703afc2ba1dSToomas Soome
2704afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 3, 2);
2705afc2ba1dSToomas Soome
2706afc2ba1dSToomas Soome n1 = ficlStackPopInteger(vm->dataStack);
2707afc2ba1dSToomas Soome d1 = ficlStackPop2Integer(vm->dataStack);
2708afc2ba1dSToomas Soome qr = ficl2IntegerDivideFloored(d1, n1);
2709afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, qr.remainder);
2710afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack,
2711afc2ba1dSToomas Soome FICL_2UNSIGNED_GET_LOW(qr.quotient));
2712afc2ba1dSToomas Soome }
2713afc2ba1dSToomas Soome
2714afc2ba1dSToomas Soome /*
2715afc2ba1dSToomas Soome * s m S l a s h R e m
2716afc2ba1dSToomas Soome * s-m-slash-remainder CORE ( d1 n1 -- n2 n3 )
2717afc2ba1dSToomas Soome * Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
2718afc2ba1dSToomas Soome * Input and output stack arguments are signed. An ambiguous condition
2719afc2ba1dSToomas Soome * exists if n1 is zero or if the quotient lies outside the range of a
2720afc2ba1dSToomas Soome * single-ficlCell signed integer.
2721afc2ba1dSToomas Soome */
2722afc2ba1dSToomas Soome static void
ficlPrimitiveSMSlashRem(ficlVm * vm)2723afc2ba1dSToomas Soome ficlPrimitiveSMSlashRem(ficlVm *vm)
2724afc2ba1dSToomas Soome {
2725afc2ba1dSToomas Soome ficl2Integer d1;
2726afc2ba1dSToomas Soome ficlInteger n1;
2727afc2ba1dSToomas Soome ficl2IntegerQR qr;
2728afc2ba1dSToomas Soome
2729afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 3, 2);
2730afc2ba1dSToomas Soome
2731afc2ba1dSToomas Soome n1 = ficlStackPopInteger(vm->dataStack);
2732afc2ba1dSToomas Soome d1 = ficlStackPop2Integer(vm->dataStack);
2733afc2ba1dSToomas Soome qr = ficl2IntegerDivideSymmetric(d1, n1);
2734afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, qr.remainder);
2735afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack,
2736afc2ba1dSToomas Soome FICL_2UNSIGNED_GET_LOW(qr.quotient));
2737afc2ba1dSToomas Soome }
2738afc2ba1dSToomas Soome
2739afc2ba1dSToomas Soome static void
ficlPrimitiveMod(ficlVm * vm)2740afc2ba1dSToomas Soome ficlPrimitiveMod(ficlVm *vm)
2741afc2ba1dSToomas Soome {
2742afc2ba1dSToomas Soome ficl2Integer d1;
2743afc2ba1dSToomas Soome ficlInteger n1;
2744afc2ba1dSToomas Soome ficlInteger i;
2745afc2ba1dSToomas Soome ficl2IntegerQR qr;
2746afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 1);
2747afc2ba1dSToomas Soome
2748afc2ba1dSToomas Soome n1 = ficlStackPopInteger(vm->dataStack);
2749afc2ba1dSToomas Soome i = ficlStackPopInteger(vm->dataStack);
2750afc2ba1dSToomas Soome FICL_INTEGER_TO_2INTEGER(i, d1);
2751afc2ba1dSToomas Soome qr = ficl2IntegerDivideSymmetric(d1, n1);
2752afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, qr.remainder);
2753afc2ba1dSToomas Soome }
2754afc2ba1dSToomas Soome
2755afc2ba1dSToomas Soome /*
2756afc2ba1dSToomas Soome * u m S l a s h M o d
2757afc2ba1dSToomas Soome * u-m-slash-mod CORE ( ud u1 -- u2 u3 )
2758afc2ba1dSToomas Soome * Divide ud by u1, giving the quotient u3 and the remainder u2.
2759afc2ba1dSToomas Soome * All values and arithmetic are unsigned. An ambiguous condition
2760afc2ba1dSToomas Soome * exists if u1 is zero or if the quotient lies outside the range of a
2761afc2ba1dSToomas Soome * single-ficlCell unsigned integer.
2762afc2ba1dSToomas Soome */
2763afc2ba1dSToomas Soome static void
ficlPrimitiveUMSlashMod(ficlVm * vm)2764afc2ba1dSToomas Soome ficlPrimitiveUMSlashMod(ficlVm *vm)
2765afc2ba1dSToomas Soome {
2766afc2ba1dSToomas Soome ficl2Unsigned ud;
2767afc2ba1dSToomas Soome ficlUnsigned u1;
2768afc2ba1dSToomas Soome ficl2UnsignedQR uqr;
2769afc2ba1dSToomas Soome
2770afc2ba1dSToomas Soome u1 = ficlStackPopUnsigned(vm->dataStack);
2771afc2ba1dSToomas Soome ud = ficlStackPop2Unsigned(vm->dataStack);
2772afc2ba1dSToomas Soome uqr = ficl2UnsignedDivide(ud, u1);
2773afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack, uqr.remainder);
2774afc2ba1dSToomas Soome ficlStackPushUnsigned(vm->dataStack,
2775afc2ba1dSToomas Soome FICL_2UNSIGNED_GET_LOW(uqr.quotient));
2776afc2ba1dSToomas Soome }
2777afc2ba1dSToomas Soome
2778afc2ba1dSToomas Soome /*
2779afc2ba1dSToomas Soome * m S t a r
2780afc2ba1dSToomas Soome * m-star CORE ( n1 n2 -- d )
2781afc2ba1dSToomas Soome * d is the signed product of n1 times n2.
2782afc2ba1dSToomas Soome */
2783afc2ba1dSToomas Soome static void
ficlPrimitiveMStar(ficlVm * vm)2784afc2ba1dSToomas Soome ficlPrimitiveMStar(ficlVm *vm)
2785afc2ba1dSToomas Soome {
2786afc2ba1dSToomas Soome ficlInteger n2;
2787afc2ba1dSToomas Soome ficlInteger n1;
2788afc2ba1dSToomas Soome ficl2Integer d;
2789afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2);
2790afc2ba1dSToomas Soome
2791afc2ba1dSToomas Soome n2 = ficlStackPopInteger(vm->dataStack);
2792afc2ba1dSToomas Soome n1 = ficlStackPopInteger(vm->dataStack);
2793afc2ba1dSToomas Soome
2794afc2ba1dSToomas Soome d = ficl2IntegerMultiply(n1, n2);
2795afc2ba1dSToomas Soome ficlStackPush2Integer(vm->dataStack, d);
2796afc2ba1dSToomas Soome }
2797afc2ba1dSToomas Soome
2798afc2ba1dSToomas Soome static void
ficlPrimitiveUMStar(ficlVm * vm)2799afc2ba1dSToomas Soome ficlPrimitiveUMStar(ficlVm *vm)
2800afc2ba1dSToomas Soome {
2801afc2ba1dSToomas Soome ficlUnsigned u2;
2802afc2ba1dSToomas Soome ficlUnsigned u1;
2803afc2ba1dSToomas Soome ficl2Unsigned ud;
2804afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2);
2805afc2ba1dSToomas Soome
2806afc2ba1dSToomas Soome u2 = ficlStackPopUnsigned(vm->dataStack);
2807afc2ba1dSToomas Soome u1 = ficlStackPopUnsigned(vm->dataStack);
2808afc2ba1dSToomas Soome
2809afc2ba1dSToomas Soome ud = ficl2UnsignedMultiply(u1, u2);
2810afc2ba1dSToomas Soome ficlStackPush2Unsigned(vm->dataStack, ud);
2811afc2ba1dSToomas Soome }
2812afc2ba1dSToomas Soome
2813afc2ba1dSToomas Soome /*
2814afc2ba1dSToomas Soome * 2 r o t
2815afc2ba1dSToomas Soome * DOUBLE ( d1 d2 d3 -- d2 d3 d1 )
2816afc2ba1dSToomas Soome */
2817afc2ba1dSToomas Soome static void
ficlPrimitive2Rot(ficlVm * vm)2818afc2ba1dSToomas Soome ficlPrimitive2Rot(ficlVm *vm)
2819afc2ba1dSToomas Soome {
2820afc2ba1dSToomas Soome ficl2Integer d1, d2, d3;
2821afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 6, 6);
2822afc2ba1dSToomas Soome
2823afc2ba1dSToomas Soome d3 = ficlStackPop2Integer(vm->dataStack);
2824afc2ba1dSToomas Soome d2 = ficlStackPop2Integer(vm->dataStack);
2825afc2ba1dSToomas Soome d1 = ficlStackPop2Integer(vm->dataStack);
2826afc2ba1dSToomas Soome ficlStackPush2Integer(vm->dataStack, d2);
2827afc2ba1dSToomas Soome ficlStackPush2Integer(vm->dataStack, d3);
2828afc2ba1dSToomas Soome ficlStackPush2Integer(vm->dataStack, d1);
2829afc2ba1dSToomas Soome }
2830afc2ba1dSToomas Soome
2831afc2ba1dSToomas Soome /*
2832afc2ba1dSToomas Soome * p a d
2833afc2ba1dSToomas Soome * CORE EXT ( -- c-addr )
2834afc2ba1dSToomas Soome * c-addr is the address of a transient region that can be used to hold
2835afc2ba1dSToomas Soome * data for intermediate processing.
2836afc2ba1dSToomas Soome */
2837afc2ba1dSToomas Soome static void
ficlPrimitivePad(ficlVm * vm)2838afc2ba1dSToomas Soome ficlPrimitivePad(ficlVm *vm)
2839afc2ba1dSToomas Soome {
2840afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, vm->pad);
2841afc2ba1dSToomas Soome }
2842afc2ba1dSToomas Soome
2843afc2ba1dSToomas Soome /*
2844afc2ba1dSToomas Soome * s o u r c e - i d
2845afc2ba1dSToomas Soome * CORE EXT, FILE ( -- 0 | -1 | fileid )
2846afc2ba1dSToomas Soome * Identifies the input source as follows:
2847afc2ba1dSToomas Soome *
2848afc2ba1dSToomas Soome * SOURCE-ID Input source
2849afc2ba1dSToomas Soome * --------- ------------
2850afc2ba1dSToomas Soome * fileid Text file fileid
2851afc2ba1dSToomas Soome * -1 String (via EVALUATE)
2852afc2ba1dSToomas Soome * 0 User input device
2853afc2ba1dSToomas Soome */
2854afc2ba1dSToomas Soome static void
ficlPrimitiveSourceID(ficlVm * vm)2855afc2ba1dSToomas Soome ficlPrimitiveSourceID(ficlVm *vm)
2856afc2ba1dSToomas Soome {
2857afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, vm->sourceId.i);
2858afc2ba1dSToomas Soome }
2859afc2ba1dSToomas Soome
2860afc2ba1dSToomas Soome /*
2861afc2ba1dSToomas Soome * r e f i l l
2862afc2ba1dSToomas Soome * CORE EXT ( -- flag )
2863afc2ba1dSToomas Soome * Attempt to fill the input buffer from the input source, returning
2864afc2ba1dSToomas Soome * a FICL_TRUE flag if successful.
2865afc2ba1dSToomas Soome * When the input source is the user input device, attempt to receive input
2866afc2ba1dSToomas Soome * into the terminal input buffer. If successful, make the result the input
2867afc2ba1dSToomas Soome * buffer, set >IN to zero, and return FICL_TRUE. Receipt of a line containing
2868afc2ba1dSToomas Soome * no characters is considered successful. If there is no input available from
2869afc2ba1dSToomas Soome * the current input source, return FICL_FALSE.
2870afc2ba1dSToomas Soome * When the input source is a string from EVALUATE, return FICL_FALSE and
2871afc2ba1dSToomas Soome * perform no other action.
2872afc2ba1dSToomas Soome */
2873afc2ba1dSToomas Soome static void
ficlPrimitiveRefill(ficlVm * vm)2874afc2ba1dSToomas Soome ficlPrimitiveRefill(ficlVm *vm)
2875afc2ba1dSToomas Soome {
2876afc2ba1dSToomas Soome ficlInteger ret = (vm->sourceId.i == -1) ? FICL_FALSE : FICL_TRUE;
2877afc2ba1dSToomas Soome if (ret && (vm->restart == 0))
2878afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
2879afc2ba1dSToomas Soome
2880afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, ret);
2881afc2ba1dSToomas Soome }
2882afc2ba1dSToomas Soome
2883afc2ba1dSToomas Soome /*
2884afc2ba1dSToomas Soome * freebsd exception handling words
2885afc2ba1dSToomas Soome * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
2886afc2ba1dSToomas Soome * the word in ToS. If an exception happens, restore the state to what
2887afc2ba1dSToomas Soome * it was before, and pushes the exception value on the stack. If not,
2888afc2ba1dSToomas Soome * push zero.
2889afc2ba1dSToomas Soome *
2890afc2ba1dSToomas Soome * Notice that Catch implements an inner interpreter. This is ugly,
2891afc2ba1dSToomas Soome * but given how Ficl works, it cannot be helped. The problem is that
2892afc2ba1dSToomas Soome * colon definitions will be executed *after* the function returns,
2893afc2ba1dSToomas Soome * while "code" definitions will be executed immediately. I considered
2894afc2ba1dSToomas Soome * other solutions to this problem, but all of them shared the same
2895afc2ba1dSToomas Soome * basic problem (with added disadvantages): if Ficl ever changes it's
2896afc2ba1dSToomas Soome * inner thread modus operandi, one would have to fix this word.
2897afc2ba1dSToomas Soome *
2898afc2ba1dSToomas Soome * More comments can be found throughout catch's code.
2899afc2ba1dSToomas Soome *
2900afc2ba1dSToomas Soome * Daniel C. Sobral Jan 09/1999
2901afc2ba1dSToomas Soome * sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
2902afc2ba1dSToomas Soome */
2903afc2ba1dSToomas Soome static void
ficlPrimitiveCatch(ficlVm * vm)2904afc2ba1dSToomas Soome ficlPrimitiveCatch(ficlVm *vm)
2905afc2ba1dSToomas Soome {
2906afc2ba1dSToomas Soome int except;
2907afc2ba1dSToomas Soome jmp_buf vmState;
2908afc2ba1dSToomas Soome ficlVm vmCopy;
2909afc2ba1dSToomas Soome ficlStack dataStackCopy;
2910afc2ba1dSToomas Soome ficlStack returnStackCopy;
2911afc2ba1dSToomas Soome ficlWord *word;
2912afc2ba1dSToomas Soome
2913afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm);
2914afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
2915afc2ba1dSToomas Soome
2916afc2ba1dSToomas Soome /*
2917afc2ba1dSToomas Soome * Get xt.
2918afc2ba1dSToomas Soome * We need this *before* we save the stack pointer, or
2919afc2ba1dSToomas Soome * we'll have to pop one element out of the stack after
2920afc2ba1dSToomas Soome * an exception. I prefer to get done with it up front. :-)
2921afc2ba1dSToomas Soome */
2922afc2ba1dSToomas Soome
2923afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0);
2924afc2ba1dSToomas Soome
2925afc2ba1dSToomas Soome word = ficlStackPopPointer(vm->dataStack);
2926afc2ba1dSToomas Soome
2927afc2ba1dSToomas Soome /*
2928afc2ba1dSToomas Soome * Save vm's state -- a catch will not back out environmental
2929afc2ba1dSToomas Soome * changes.
2930afc2ba1dSToomas Soome *
2931afc2ba1dSToomas Soome * We are *not* saving dictionary state, since it is
2932afc2ba1dSToomas Soome * global instead of per vm, and we are not saving
2933afc2ba1dSToomas Soome * stack contents, since we are not required to (and,
2934afc2ba1dSToomas Soome * thus, it would be useless). We save vm, and vm
2935afc2ba1dSToomas Soome * "stacks" (a structure containing general information
2936afc2ba1dSToomas Soome * about it, including the current stack pointer).
2937afc2ba1dSToomas Soome */
2938afc2ba1dSToomas Soome memcpy((void*)&vmCopy, (void*)vm, sizeof (ficlVm));
2939afc2ba1dSToomas Soome memcpy((void*)&dataStackCopy, (void*)vm->dataStack, sizeof (ficlStack));
2940afc2ba1dSToomas Soome memcpy((void*)&returnStackCopy, (void*)vm->returnStack,
2941afc2ba1dSToomas Soome sizeof (ficlStack));
2942afc2ba1dSToomas Soome
2943afc2ba1dSToomas Soome /*
2944afc2ba1dSToomas Soome * Give vm a jmp_buf
2945afc2ba1dSToomas Soome */
2946afc2ba1dSToomas Soome vm->exceptionHandler = &vmState;
2947afc2ba1dSToomas Soome
2948afc2ba1dSToomas Soome /*
2949afc2ba1dSToomas Soome * Safety net
2950afc2ba1dSToomas Soome */
2951afc2ba1dSToomas Soome except = setjmp(vmState);
2952afc2ba1dSToomas Soome
2953afc2ba1dSToomas Soome switch (except) {
2954afc2ba1dSToomas Soome /*
2955afc2ba1dSToomas Soome * Setup condition - push poison pill so that the VM throws
2956afc2ba1dSToomas Soome * VM_INNEREXIT if the XT terminates normally, then execute
2957afc2ba1dSToomas Soome * the XT
2958afc2ba1dSToomas Soome */
2959afc2ba1dSToomas Soome case 0:
2960afc2ba1dSToomas Soome /* Open mouth, insert emetic */
2961afc2ba1dSToomas Soome ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
2962afc2ba1dSToomas Soome ficlVmExecuteWord(vm, word);
2963afc2ba1dSToomas Soome ficlVmInnerLoop(vm, 0);
2964afc2ba1dSToomas Soome break;
2965afc2ba1dSToomas Soome
2966afc2ba1dSToomas Soome /*
2967afc2ba1dSToomas Soome * Normal exit from XT - lose the poison pill,
2968afc2ba1dSToomas Soome * restore old setjmp vector and push a zero.
2969afc2ba1dSToomas Soome */
2970afc2ba1dSToomas Soome case FICL_VM_STATUS_INNER_EXIT:
2971afc2ba1dSToomas Soome ficlVmPopIP(vm); /* Gack - hurl poison pill */
2972afc2ba1dSToomas Soome /* Restore just the setjmp vector */
2973afc2ba1dSToomas Soome vm->exceptionHandler = vmCopy.exceptionHandler;
2974afc2ba1dSToomas Soome /* Push 0 -- everything is ok */
2975afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 0);
2976afc2ba1dSToomas Soome break;
2977afc2ba1dSToomas Soome
2978afc2ba1dSToomas Soome /*
2979afc2ba1dSToomas Soome * Some other exception got thrown - restore pre-existing VM state
2980afc2ba1dSToomas Soome * and push the exception code
2981afc2ba1dSToomas Soome */
2982afc2ba1dSToomas Soome default:
2983afc2ba1dSToomas Soome /* Restore vm's state */
2984afc2ba1dSToomas Soome memcpy((void*)vm, (void*)&vmCopy, sizeof (ficlVm));
2985afc2ba1dSToomas Soome memcpy((void*)vm->dataStack, (void*)&dataStackCopy,
2986afc2ba1dSToomas Soome sizeof (ficlStack));
2987afc2ba1dSToomas Soome memcpy((void*)vm->returnStack, (void*)&returnStackCopy,
2988afc2ba1dSToomas Soome sizeof (ficlStack));
2989afc2ba1dSToomas Soome
2990afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, except); /* Push error */
2991afc2ba1dSToomas Soome break;
2992afc2ba1dSToomas Soome }
2993afc2ba1dSToomas Soome }
2994afc2ba1dSToomas Soome
2995afc2ba1dSToomas Soome /*
2996afc2ba1dSToomas Soome * t h r o w
2997afc2ba1dSToomas Soome * EXCEPTION
2998afc2ba1dSToomas Soome * Throw -- From ANS Forth standard.
2999afc2ba1dSToomas Soome *
3000afc2ba1dSToomas Soome * Throw takes the ToS and, if that's different from zero,
3001afc2ba1dSToomas Soome * returns to the last executed catch context. Further throws will
3002afc2ba1dSToomas Soome * unstack previously executed "catches", in LIFO mode.
3003afc2ba1dSToomas Soome *
3004afc2ba1dSToomas Soome * Daniel C. Sobral Jan 09/1999
3005afc2ba1dSToomas Soome */
3006afc2ba1dSToomas Soome static void
ficlPrimitiveThrow(ficlVm * vm)3007afc2ba1dSToomas Soome ficlPrimitiveThrow(ficlVm *vm)
3008afc2ba1dSToomas Soome {
3009afc2ba1dSToomas Soome int except;
3010afc2ba1dSToomas Soome
3011afc2ba1dSToomas Soome except = ficlStackPopInteger(vm->dataStack);
3012afc2ba1dSToomas Soome
3013afc2ba1dSToomas Soome if (except)
3014afc2ba1dSToomas Soome ficlVmThrow(vm, except);
3015afc2ba1dSToomas Soome }
3016afc2ba1dSToomas Soome
3017afc2ba1dSToomas Soome /*
3018afc2ba1dSToomas Soome * a l l o c a t e
3019afc2ba1dSToomas Soome * MEMORY
3020afc2ba1dSToomas Soome */
3021afc2ba1dSToomas Soome static void
ficlPrimitiveAllocate(ficlVm * vm)3022afc2ba1dSToomas Soome ficlPrimitiveAllocate(ficlVm *vm)
3023afc2ba1dSToomas Soome {
3024afc2ba1dSToomas Soome size_t size;
3025afc2ba1dSToomas Soome void *p;
3026afc2ba1dSToomas Soome
3027afc2ba1dSToomas Soome size = ficlStackPopInteger(vm->dataStack);
3028afc2ba1dSToomas Soome p = ficlMalloc(size);
3029afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, p);
3030afc2ba1dSToomas Soome if (p != NULL)
3031afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 0);
3032afc2ba1dSToomas Soome else
3033afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 1);
3034afc2ba1dSToomas Soome }
3035afc2ba1dSToomas Soome
3036afc2ba1dSToomas Soome /*
3037afc2ba1dSToomas Soome * f r e e
3038afc2ba1dSToomas Soome * MEMORY
3039afc2ba1dSToomas Soome */
3040afc2ba1dSToomas Soome static void
ficlPrimitiveFree(ficlVm * vm)3041afc2ba1dSToomas Soome ficlPrimitiveFree(ficlVm *vm)
3042afc2ba1dSToomas Soome {
3043afc2ba1dSToomas Soome void *p;
3044afc2ba1dSToomas Soome
3045afc2ba1dSToomas Soome p = ficlStackPopPointer(vm->dataStack);
3046afc2ba1dSToomas Soome ficlFree(p);
3047afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 0);
3048afc2ba1dSToomas Soome }
3049afc2ba1dSToomas Soome
3050afc2ba1dSToomas Soome /*
3051afc2ba1dSToomas Soome * r e s i z e
3052afc2ba1dSToomas Soome * MEMORY
3053afc2ba1dSToomas Soome */
3054afc2ba1dSToomas Soome static void
ficlPrimitiveResize(ficlVm * vm)3055afc2ba1dSToomas Soome ficlPrimitiveResize(ficlVm *vm)
3056afc2ba1dSToomas Soome {
3057afc2ba1dSToomas Soome size_t size;
3058afc2ba1dSToomas Soome void *new, *old;
3059afc2ba1dSToomas Soome
3060afc2ba1dSToomas Soome size = ficlStackPopInteger(vm->dataStack);
3061afc2ba1dSToomas Soome old = ficlStackPopPointer(vm->dataStack);
3062afc2ba1dSToomas Soome new = ficlRealloc(old, size);
3063afc2ba1dSToomas Soome
3064afc2ba1dSToomas Soome if (new) {
3065afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, new);
3066afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 0);
3067afc2ba1dSToomas Soome } else {
3068afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, old);
3069afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 1);
3070afc2ba1dSToomas Soome }
3071afc2ba1dSToomas Soome }
3072afc2ba1dSToomas Soome
3073afc2ba1dSToomas Soome /*
3074afc2ba1dSToomas Soome * e x i t - i n n e r
3075afc2ba1dSToomas Soome * Signals execXT that an inner loop has completed
3076afc2ba1dSToomas Soome */
3077afc2ba1dSToomas Soome static void
ficlPrimitiveExitInner(ficlVm * vm)3078afc2ba1dSToomas Soome ficlPrimitiveExitInner(ficlVm *vm)
3079afc2ba1dSToomas Soome {
3080afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_INNER_EXIT);
3081afc2ba1dSToomas Soome }
3082afc2ba1dSToomas Soome
3083afc2ba1dSToomas Soome #if 0
3084afc2ba1dSToomas Soome static void
3085afc2ba1dSToomas Soome ficlPrimitiveName(ficlVm *vm)
3086afc2ba1dSToomas Soome {
3087afc2ba1dSToomas Soome FICL_IGNORE(vm);
3088afc2ba1dSToomas Soome }
3089afc2ba1dSToomas Soome #endif
3090afc2ba1dSToomas Soome
3091afc2ba1dSToomas Soome /*
3092afc2ba1dSToomas Soome * f i c l C o m p i l e C o r e
3093afc2ba1dSToomas Soome * Builds the primitive wordset and the environment-query namespace.
3094afc2ba1dSToomas Soome */
3095afc2ba1dSToomas Soome void
ficlSystemCompileCore(ficlSystem * system)3096afc2ba1dSToomas Soome ficlSystemCompileCore(ficlSystem *system)
3097afc2ba1dSToomas Soome {
3098afc2ba1dSToomas Soome ficlWord *interpret;
3099afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlSystemGetDictionary(system);
3100afc2ba1dSToomas Soome ficlDictionary *environment = ficlSystemGetEnvironment(system);
3101afc2ba1dSToomas Soome
3102afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, dictionary);
3103afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, environment);
3104afc2ba1dSToomas Soome
3105afc2ba1dSToomas Soome #define FICL_TOKEN(token, description)
3106afc2ba1dSToomas Soome #define FICL_INSTRUCTION_TOKEN(token, description, flags) \
3107*c0bb4f73SToomas Soome (void) ficlDictionarySetInstruction(dictionary, description, token, \
3108*c0bb4f73SToomas Soome flags);
3109afc2ba1dSToomas Soome #include "ficltokens.h"
3110afc2ba1dSToomas Soome #undef FICL_TOKEN
3111afc2ba1dSToomas Soome #undef FICL_INSTRUCTION_TOKEN
3112afc2ba1dSToomas Soome
3113afc2ba1dSToomas Soome /*
3114afc2ba1dSToomas Soome * The Core word set
3115afc2ba1dSToomas Soome * see softcore.c for definitions of: abs bl space spaces abort"
3116afc2ba1dSToomas Soome */
3117*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "#",
3118*c0bb4f73SToomas Soome ficlPrimitiveNumberSign, FICL_WORD_DEFAULT);
3119*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "#>",
3120afc2ba1dSToomas Soome ficlPrimitiveNumberSignGreater, FICL_WORD_DEFAULT);
3121*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "#s",
3122*c0bb4f73SToomas Soome ficlPrimitiveNumberSignS, FICL_WORD_DEFAULT);
3123*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "\'",
3124*c0bb4f73SToomas Soome ficlPrimitiveTick, FICL_WORD_DEFAULT);
3125*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "(",
3126*c0bb4f73SToomas Soome ficlPrimitiveParenthesis, FICL_WORD_IMMEDIATE);
3127*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "+loop",
3128afc2ba1dSToomas Soome ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3129*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".",
3130*c0bb4f73SToomas Soome ficlPrimitiveDot, FICL_WORD_DEFAULT);
3131*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".\"",
3132afc2ba1dSToomas Soome ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3133*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ":",
3134*c0bb4f73SToomas Soome ficlPrimitiveColon, FICL_WORD_DEFAULT);
3135*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ";",
3136*c0bb4f73SToomas Soome ficlPrimitiveSemicolonCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3137*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "<#",
3138afc2ba1dSToomas Soome ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT);
3139*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ">body",
3140*c0bb4f73SToomas Soome ficlPrimitiveToBody, FICL_WORD_DEFAULT);
3141*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ">in",
3142*c0bb4f73SToomas Soome ficlPrimitiveToIn, FICL_WORD_DEFAULT);
3143*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ">number",
3144*c0bb4f73SToomas Soome ficlPrimitiveToNumber, FICL_WORD_DEFAULT);
3145*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "abort",
3146*c0bb4f73SToomas Soome ficlPrimitiveAbort, FICL_WORD_DEFAULT);
3147*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "accept",
3148*c0bb4f73SToomas Soome ficlPrimitiveAccept, FICL_WORD_DEFAULT);
3149*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "align",
3150*c0bb4f73SToomas Soome ficlPrimitiveAlign, FICL_WORD_DEFAULT);
3151*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "aligned",
3152*c0bb4f73SToomas Soome ficlPrimitiveAligned, FICL_WORD_DEFAULT);
3153*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "allot",
3154*c0bb4f73SToomas Soome ficlPrimitiveAllot, FICL_WORD_DEFAULT);
3155*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "base",
3156*c0bb4f73SToomas Soome ficlPrimitiveBase, FICL_WORD_DEFAULT);
3157*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "begin",
3158*c0bb4f73SToomas Soome ficlPrimitiveBeginCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3159*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "case",
3160*c0bb4f73SToomas Soome ficlPrimitiveCaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3161*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "char",
3162*c0bb4f73SToomas Soome ficlPrimitiveChar, FICL_WORD_DEFAULT);
3163*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "char+",
3164*c0bb4f73SToomas Soome ficlPrimitiveCharPlus, FICL_WORD_DEFAULT);
3165*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "chars",
3166*c0bb4f73SToomas Soome ficlPrimitiveChars, FICL_WORD_DEFAULT);
3167*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "constant",
3168afc2ba1dSToomas Soome ficlPrimitiveConstant, FICL_WORD_DEFAULT);
3169*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "count",
3170*c0bb4f73SToomas Soome ficlPrimitiveCount, FICL_WORD_DEFAULT);
3171*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "cr",
3172*c0bb4f73SToomas Soome ficlPrimitiveCR, FICL_WORD_DEFAULT);
3173*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "create",
3174*c0bb4f73SToomas Soome ficlPrimitiveCreate, FICL_WORD_DEFAULT);
3175*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "decimal",
3176*c0bb4f73SToomas Soome ficlPrimitiveDecimal, FICL_WORD_DEFAULT);
3177*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "depth",
3178*c0bb4f73SToomas Soome ficlPrimitiveDepth, FICL_WORD_DEFAULT);
3179*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "do",
3180*c0bb4f73SToomas Soome ficlPrimitiveDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3181*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "does>",
3182*c0bb4f73SToomas Soome ficlPrimitiveDoesCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3183*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "else",
3184*c0bb4f73SToomas Soome ficlPrimitiveElseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3185*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "emit",
3186*c0bb4f73SToomas Soome ficlPrimitiveEmit, FICL_WORD_DEFAULT);
3187*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "endcase",
3188afc2ba1dSToomas Soome ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3189*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "endof",
3190*c0bb4f73SToomas Soome ficlPrimitiveEndofCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3191*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "environment?",
3192afc2ba1dSToomas Soome ficlPrimitiveEnvironmentQ, FICL_WORD_DEFAULT);
3193*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "evaluate",
3194afc2ba1dSToomas Soome ficlPrimitiveEvaluate, FICL_WORD_DEFAULT);
3195*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "execute",
3196*c0bb4f73SToomas Soome ficlPrimitiveExecute, FICL_WORD_DEFAULT);
3197*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "exit",
3198*c0bb4f73SToomas Soome ficlPrimitiveExitCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3199*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fallthrough",
3200afc2ba1dSToomas Soome ficlPrimitiveFallthroughCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3201*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "find",
3202*c0bb4f73SToomas Soome ficlPrimitiveCFind, FICL_WORD_DEFAULT);
3203*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fm/mod",
3204afc2ba1dSToomas Soome ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT);
3205*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "here",
3206*c0bb4f73SToomas Soome ficlPrimitiveHere, FICL_WORD_DEFAULT);
3207*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "hold",
3208*c0bb4f73SToomas Soome ficlPrimitiveHold, FICL_WORD_DEFAULT);
3209*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "if",
3210*c0bb4f73SToomas Soome ficlPrimitiveIfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3211*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "immediate",
3212afc2ba1dSToomas Soome ficlPrimitiveImmediate, FICL_WORD_DEFAULT);
3213*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "literal",
3214afc2ba1dSToomas Soome ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE);
3215*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "loop",
3216*c0bb4f73SToomas Soome ficlPrimitiveLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3217*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "m*",
3218*c0bb4f73SToomas Soome ficlPrimitiveMStar, FICL_WORD_DEFAULT);
3219*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "mod",
3220*c0bb4f73SToomas Soome ficlPrimitiveMod, FICL_WORD_DEFAULT);
3221*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "of",
3222*c0bb4f73SToomas Soome ficlPrimitiveOfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3223*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "postpone",
3224afc2ba1dSToomas Soome ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3225*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "quit",
3226*c0bb4f73SToomas Soome ficlPrimitiveQuit, FICL_WORD_DEFAULT);
3227*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "recurse",
3228afc2ba1dSToomas Soome ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3229*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "repeat",
3230afc2ba1dSToomas Soome ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3231*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "s\"",
3232afc2ba1dSToomas Soome ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE);
3233*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "sign",
3234*c0bb4f73SToomas Soome ficlPrimitiveSign, FICL_WORD_DEFAULT);
3235*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "sm/rem",
3236afc2ba1dSToomas Soome ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT);
3237*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "source",
3238*c0bb4f73SToomas Soome ficlPrimitiveSource, FICL_WORD_DEFAULT);
3239*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "state",
3240*c0bb4f73SToomas Soome ficlPrimitiveState, FICL_WORD_DEFAULT);
3241*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "then",
3242*c0bb4f73SToomas Soome ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3243*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "type",
3244*c0bb4f73SToomas Soome ficlPrimitiveType, FICL_WORD_DEFAULT);
3245*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "u.",
3246*c0bb4f73SToomas Soome ficlPrimitiveUDot, FICL_WORD_DEFAULT);
3247*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "um*",
3248*c0bb4f73SToomas Soome ficlPrimitiveUMStar, FICL_WORD_DEFAULT);
3249*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "um/mod",
3250afc2ba1dSToomas Soome ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT);
3251*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "until",
3252afc2ba1dSToomas Soome ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3253*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "variable",
3254afc2ba1dSToomas Soome ficlPrimitiveVariable, FICL_WORD_DEFAULT);
3255*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "while",
3256afc2ba1dSToomas Soome ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3257*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "word",
3258*c0bb4f73SToomas Soome ficlPrimitiveWord, FICL_WORD_DEFAULT);
3259*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "[",
3260afc2ba1dSToomas Soome ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3261*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "[\']",
3262afc2ba1dSToomas Soome ficlPrimitiveBracketTickCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3263*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "[char]",
3264*c0bb4f73SToomas Soome ficlPrimitiveCharCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3265*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "]",
3266*c0bb4f73SToomas Soome ficlPrimitiveRightBracket, FICL_WORD_DEFAULT);
3267afc2ba1dSToomas Soome /*
3268afc2ba1dSToomas Soome * The Core Extensions word set...
3269afc2ba1dSToomas Soome * see softcore.fr for other definitions
3270afc2ba1dSToomas Soome */
3271afc2ba1dSToomas Soome /* "#tib" */
3272*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".(",
3273*c0bb4f73SToomas Soome ficlPrimitiveDotParen, FICL_WORD_IMMEDIATE);
3274afc2ba1dSToomas Soome /* ".r" is in softcore */
3275*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ":noname",
3276afc2ba1dSToomas Soome ficlPrimitiveColonNoName, FICL_WORD_DEFAULT);
3277*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "?do",
3278*c0bb4f73SToomas Soome ficlPrimitiveQDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3279*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "again",
3280*c0bb4f73SToomas Soome ficlPrimitiveAgainCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3281*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "c\"",
3282afc2ba1dSToomas Soome ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE);
3283*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "hex",
3284*c0bb4f73SToomas Soome ficlPrimitiveHex, FICL_WORD_DEFAULT);
3285*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "pad",
3286*c0bb4f73SToomas Soome ficlPrimitivePad, FICL_WORD_DEFAULT);
3287*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "parse",
3288*c0bb4f73SToomas Soome ficlPrimitiveParse, FICL_WORD_DEFAULT);
3289afc2ba1dSToomas Soome
3290afc2ba1dSToomas Soome /*
3291afc2ba1dSToomas Soome * query restore-input save-input tib u.r u> unused
3292afc2ba1dSToomas Soome * [FICL_VM_STATE_COMPILE]
3293afc2ba1dSToomas Soome */
3294*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "refill",
3295*c0bb4f73SToomas Soome ficlPrimitiveRefill, FICL_WORD_DEFAULT);
3296*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "source-id",
3297afc2ba1dSToomas Soome ficlPrimitiveSourceID, FICL_WORD_DEFAULT);
3298*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "to",
3299*c0bb4f73SToomas Soome ficlPrimitiveToValue, FICL_WORD_IMMEDIATE);
3300*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "value",
3301*c0bb4f73SToomas Soome ficlPrimitiveConstant, FICL_WORD_DEFAULT);
3302*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "\\",
3303*c0bb4f73SToomas Soome ficlPrimitiveBackslash, FICL_WORD_IMMEDIATE);
3304afc2ba1dSToomas Soome
3305afc2ba1dSToomas Soome /*
3306afc2ba1dSToomas Soome * Environment query values for the Core word set
3307afc2ba1dSToomas Soome */
3308*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "/counted-string",
3309afc2ba1dSToomas Soome FICL_COUNTED_STRING_MAX);
3310*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE);
3311*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE);
3312*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "address-unit-bits", 8);
3313*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "core", FICL_TRUE);
3314*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE);
3315*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "floored", FICL_FALSE);
3316*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX);
3317*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "max-n", LONG_MAX);
3318*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "max-u", ULONG_MAX);
3319afc2ba1dSToomas Soome
3320afc2ba1dSToomas Soome {
3321afc2ba1dSToomas Soome ficl2Integer id;
3322afc2ba1dSToomas Soome ficlInteger low, high;
3323afc2ba1dSToomas Soome
3324afc2ba1dSToomas Soome low = ULONG_MAX;
3325afc2ba1dSToomas Soome high = LONG_MAX;
3326afc2ba1dSToomas Soome FICL_2INTEGER_SET(high, low, id);
3327*c0bb4f73SToomas Soome (void) ficlDictionarySet2Constant(environment, "max-d", id);
3328afc2ba1dSToomas Soome high = ULONG_MAX;
3329afc2ba1dSToomas Soome FICL_2INTEGER_SET(high, low, id);
3330*c0bb4f73SToomas Soome (void) ficlDictionarySet2Constant(environment, "max-ud", id);
3331afc2ba1dSToomas Soome }
3332afc2ba1dSToomas Soome
3333*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "return-stack-cells",
3334afc2ba1dSToomas Soome FICL_DEFAULT_STACK_SIZE);
3335*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "stack-cells",
3336afc2ba1dSToomas Soome FICL_DEFAULT_STACK_SIZE);
3337afc2ba1dSToomas Soome
3338afc2ba1dSToomas Soome /*
3339afc2ba1dSToomas Soome * The optional Double-Number word set (partial)
3340afc2ba1dSToomas Soome */
3341*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "2constant",
3342afc2ba1dSToomas Soome ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
3343*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "2literal",
3344afc2ba1dSToomas Soome ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE);
3345*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "2variable",
3346afc2ba1dSToomas Soome ficlPrimitive2Variable, FICL_WORD_IMMEDIATE);
3347afc2ba1dSToomas Soome /*
3348afc2ba1dSToomas Soome * D+ D- D. D.R D0< D0= D2* D2/ in softcore
3349afc2ba1dSToomas Soome * D< D= D>S DABS DMAX DMIN DNEGATE in softcore
3350afc2ba1dSToomas Soome * m-star-slash is TODO
3351afc2ba1dSToomas Soome * M+ in softcore
3352afc2ba1dSToomas Soome */
3353afc2ba1dSToomas Soome
3354afc2ba1dSToomas Soome /*
3355afc2ba1dSToomas Soome * DOUBLE EXT
3356afc2ba1dSToomas Soome */
3357*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "2rot",
3358afc2ba1dSToomas Soome ficlPrimitive2Rot, FICL_WORD_DEFAULT);
3359*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "2value",
3360afc2ba1dSToomas Soome ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
3361afc2ba1dSToomas Soome /* du< in softcore */
3362afc2ba1dSToomas Soome /*
3363afc2ba1dSToomas Soome * The optional Exception and Exception Extensions word set
3364afc2ba1dSToomas Soome */
3365*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "catch",
3366*c0bb4f73SToomas Soome ficlPrimitiveCatch, FICL_WORD_DEFAULT);
3367*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "throw",
3368*c0bb4f73SToomas Soome ficlPrimitiveThrow, FICL_WORD_DEFAULT);
3369afc2ba1dSToomas Soome
3370*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "exception", FICL_TRUE);
3371*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "exception-ext",
3372*c0bb4f73SToomas Soome FICL_TRUE);
3373afc2ba1dSToomas Soome
3374afc2ba1dSToomas Soome /*
3375afc2ba1dSToomas Soome * The optional Locals and Locals Extensions word set
3376afc2ba1dSToomas Soome * see softcore.c for implementation of locals|
3377afc2ba1dSToomas Soome */
3378afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
3379*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "doLocal",
3380afc2ba1dSToomas Soome ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3381*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "(local)",
3382afc2ba1dSToomas Soome ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY);
3383*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "(2local)",
3384afc2ba1dSToomas Soome ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY);
3385afc2ba1dSToomas Soome
3386*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "locals", FICL_TRUE);
3387*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "locals-ext", FICL_TRUE);
3388*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "#locals",
3389*c0bb4f73SToomas Soome FICL_MAX_LOCALS);
3390afc2ba1dSToomas Soome #endif
3391afc2ba1dSToomas Soome
3392afc2ba1dSToomas Soome /*
3393afc2ba1dSToomas Soome * The optional Memory-Allocation word set
3394afc2ba1dSToomas Soome */
3395afc2ba1dSToomas Soome
3396*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "allocate",
3397afc2ba1dSToomas Soome ficlPrimitiveAllocate, FICL_WORD_DEFAULT);
3398*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "free",
3399*c0bb4f73SToomas Soome ficlPrimitiveFree, FICL_WORD_DEFAULT);
3400*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "resize",
3401*c0bb4f73SToomas Soome ficlPrimitiveResize, FICL_WORD_DEFAULT);
3402afc2ba1dSToomas Soome
3403*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "memory-alloc",
3404*c0bb4f73SToomas Soome FICL_TRUE);
3405afc2ba1dSToomas Soome
3406afc2ba1dSToomas Soome /*
3407afc2ba1dSToomas Soome * The optional Search-Order word set
3408afc2ba1dSToomas Soome */
3409afc2ba1dSToomas Soome ficlSystemCompileSearch(system);
3410afc2ba1dSToomas Soome
3411afc2ba1dSToomas Soome /*
3412afc2ba1dSToomas Soome * The optional Programming-Tools and Programming-Tools
3413afc2ba1dSToomas Soome * Extensions word set
3414afc2ba1dSToomas Soome */
3415afc2ba1dSToomas Soome ficlSystemCompileTools(system);
3416afc2ba1dSToomas Soome
3417afc2ba1dSToomas Soome /*
3418afc2ba1dSToomas Soome * The optional File-Access and File-Access Extensions word set
3419afc2ba1dSToomas Soome */
3420afc2ba1dSToomas Soome #if FICL_WANT_FILE
3421afc2ba1dSToomas Soome ficlSystemCompileFile(system);
3422afc2ba1dSToomas Soome #endif
3423afc2ba1dSToomas Soome
3424afc2ba1dSToomas Soome /*
3425afc2ba1dSToomas Soome * Ficl extras
3426afc2ba1dSToomas Soome */
3427*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ".ver",
3428*c0bb4f73SToomas Soome ficlPrimitiveVersion, FICL_WORD_DEFAULT);
3429*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, ">name",
3430*c0bb4f73SToomas Soome ficlPrimitiveToName, FICL_WORD_DEFAULT);
3431*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "add-parse-step",
3432afc2ba1dSToomas Soome ficlPrimitiveAddParseStep, FICL_WORD_DEFAULT);
3433*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "body>",
3434*c0bb4f73SToomas Soome ficlPrimitiveFromBody, FICL_WORD_DEFAULT);
3435*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "compile-only",
3436afc2ba1dSToomas Soome ficlPrimitiveCompileOnly, FICL_WORD_DEFAULT);
3437*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "endif",
3438*c0bb4f73SToomas Soome ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3439*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "last-word",
3440afc2ba1dSToomas Soome ficlPrimitiveLastWord, FICL_WORD_DEFAULT);
3441*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "hash",
3442*c0bb4f73SToomas Soome ficlPrimitiveHash, FICL_WORD_DEFAULT);
3443*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "objectify",
3444afc2ba1dSToomas Soome ficlPrimitiveSetObjectFlag, FICL_WORD_DEFAULT);
3445*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "?object",
3446afc2ba1dSToomas Soome ficlPrimitiveIsObject, FICL_WORD_DEFAULT);
3447*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "parse-word",
3448afc2ba1dSToomas Soome ficlPrimitiveParseNoCopy, FICL_WORD_DEFAULT);
3449*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "sfind",
3450*c0bb4f73SToomas Soome ficlPrimitiveSFind, FICL_WORD_DEFAULT);
3451*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "sliteral",
3452afc2ba1dSToomas Soome ficlPrimitiveSLiteralCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3453*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "sprintf",
3454*c0bb4f73SToomas Soome ficlPrimitiveSprintf, FICL_WORD_DEFAULT);
3455*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "strlen",
3456*c0bb4f73SToomas Soome ficlPrimitiveStrlen, FICL_WORD_DEFAULT);
3457*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "x.",
3458*c0bb4f73SToomas Soome ficlPrimitiveHexDot, FICL_WORD_DEFAULT);
3459afc2ba1dSToomas Soome #if FICL_WANT_USER
3460*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "user",
3461*c0bb4f73SToomas Soome ficlPrimitiveUser, FICL_WORD_DEFAULT);
3462afc2ba1dSToomas Soome #endif
3463afc2ba1dSToomas Soome
3464afc2ba1dSToomas Soome /*
3465afc2ba1dSToomas Soome * internal support words
3466afc2ba1dSToomas Soome */
3467afc2ba1dSToomas Soome interpret = ficlDictionarySetPrimitive(dictionary, "interpret",
3468afc2ba1dSToomas Soome ficlPrimitiveInterpret, FICL_WORD_DEFAULT);
3469*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "lookup",
3470*c0bb4f73SToomas Soome ficlPrimitiveLookup, FICL_WORD_DEFAULT);
3471*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "(parse-step)",
3472afc2ba1dSToomas Soome ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
3473afc2ba1dSToomas Soome system->exitInnerWord = ficlDictionarySetPrimitive(dictionary,
3474afc2ba1dSToomas Soome "exit-inner", ficlPrimitiveExitInner, FICL_WORD_DEFAULT);
3475afc2ba1dSToomas Soome
3476afc2ba1dSToomas Soome /*
3477afc2ba1dSToomas Soome * Set constants representing the internal instruction words
3478afc2ba1dSToomas Soome * If you want all of 'em, turn that "#if 0" to "#if 1".
3479afc2ba1dSToomas Soome * By default you only get the numbers (fi0, fiNeg1, etc).
3480afc2ba1dSToomas Soome */
3481afc2ba1dSToomas Soome #define FICL_TOKEN(token, description) \
3482*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(dictionary, #token, token);
3483afc2ba1dSToomas Soome #if 0
3484afc2ba1dSToomas Soome #define FICL_INSTRUCTION_TOKEN(token, description, flags) \
3485afc2ba1dSToomas Soome ficlDictionarySetConstant(dictionary, #token, token);
3486afc2ba1dSToomas Soome #else
3487afc2ba1dSToomas Soome #define FICL_INSTRUCTION_TOKEN(token, description, flags)
3488afc2ba1dSToomas Soome #endif /* 0 */
3489afc2ba1dSToomas Soome #include "ficltokens.h"
3490afc2ba1dSToomas Soome #undef FICL_TOKEN
3491afc2ba1dSToomas Soome #undef FICL_INSTRUCTION_TOKEN
3492afc2ba1dSToomas Soome
3493afc2ba1dSToomas Soome /*
3494afc2ba1dSToomas Soome * Set up system's outer interpreter loop - maybe this should
3495afc2ba1dSToomas Soome * be in initSystem?
3496afc2ba1dSToomas Soome */
3497afc2ba1dSToomas Soome system->interpreterLoop[0] = interpret;
3498afc2ba1dSToomas Soome system->interpreterLoop[1] = (ficlWord *)ficlInstructionBranchParen;
3499afc2ba1dSToomas Soome system->interpreterLoop[2] = (ficlWord *)(void *)(-2);
3500afc2ba1dSToomas Soome
3501afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system,
3502afc2ba1dSToomas Soome ficlDictionaryCellsAvailable(dictionary) > 0);
3503afc2ba1dSToomas Soome }
3504