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