1afc2ba1dSToomas Soome /*
2afc2ba1dSToomas Soome * v m . c
3afc2ba1dSToomas Soome * Forth Inspired Command Language - virtual machine methods
4afc2ba1dSToomas Soome * Author: John Sadler (john_sadler@alum.mit.edu)
5afc2ba1dSToomas Soome * Created: 19 July 1997
6afc2ba1dSToomas Soome * $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $
7afc2ba1dSToomas Soome */
8afc2ba1dSToomas Soome /*
9afc2ba1dSToomas Soome * This file implements the virtual machine of Ficl. Each virtual
10afc2ba1dSToomas Soome * machine retains the state of an interpreter. A virtual machine
11afc2ba1dSToomas Soome * owns a pair of stacks for parameters and return addresses, as
12afc2ba1dSToomas Soome * well as a pile of state variables and the two dedicated registers
13afc2ba1dSToomas Soome * of the interpreter.
14afc2ba1dSToomas Soome */
15afc2ba1dSToomas Soome /*
16afc2ba1dSToomas Soome * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
17afc2ba1dSToomas Soome * All rights reserved.
18afc2ba1dSToomas Soome *
19afc2ba1dSToomas Soome * Get the latest Ficl release at http://ficl.sourceforge.net
20afc2ba1dSToomas Soome *
21afc2ba1dSToomas Soome * I am interested in hearing from anyone who uses Ficl. If you have
22afc2ba1dSToomas Soome * a problem, a success story, a defect, an enhancement request, or
23afc2ba1dSToomas Soome * if you would like to contribute to the Ficl release, please
24afc2ba1dSToomas Soome * contact me by email at the address above.
25afc2ba1dSToomas Soome *
26afc2ba1dSToomas Soome * L I C E N S E and D I S C L A I M E R
27afc2ba1dSToomas Soome *
28afc2ba1dSToomas Soome * Redistribution and use in source and binary forms, with or without
29afc2ba1dSToomas Soome * modification, are permitted provided that the following conditions
30afc2ba1dSToomas Soome * are met:
31afc2ba1dSToomas Soome * 1. Redistributions of source code must retain the above copyright
32afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer.
33afc2ba1dSToomas Soome * 2. Redistributions in binary form must reproduce the above copyright
34afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer in the
35afc2ba1dSToomas Soome * documentation and/or other materials provided with the distribution.
36afc2ba1dSToomas Soome *
37afc2ba1dSToomas Soome * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
38afc2ba1dSToomas Soome * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
39afc2ba1dSToomas Soome * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
40afc2ba1dSToomas Soome * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
41afc2ba1dSToomas Soome * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
42afc2ba1dSToomas Soome * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
43afc2ba1dSToomas Soome * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
44afc2ba1dSToomas Soome * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
45afc2ba1dSToomas Soome * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
46afc2ba1dSToomas Soome * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
47afc2ba1dSToomas Soome * SUCH DAMAGE.
48afc2ba1dSToomas Soome */
49afc2ba1dSToomas Soome
50*efe51d0cSJohn Levon /*
51*efe51d0cSJohn Levon * Copyright 2019 Joyent, Inc.
52*efe51d0cSJohn Levon */
53*efe51d0cSJohn Levon
54afc2ba1dSToomas Soome #include "ficl.h"
55afc2ba1dSToomas Soome
56afc2ba1dSToomas Soome #if FICL_ROBUST >= 2
57afc2ba1dSToomas Soome #define FICL_VM_CHECK(vm) \
58afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord)
59afc2ba1dSToomas Soome #else
60afc2ba1dSToomas Soome #define FICL_VM_CHECK(vm)
61afc2ba1dSToomas Soome #endif
62afc2ba1dSToomas Soome
63afc2ba1dSToomas Soome /*
64afc2ba1dSToomas Soome * v m B r a n c h R e l a t i v e
65afc2ba1dSToomas Soome */
66afc2ba1dSToomas Soome void
ficlVmBranchRelative(ficlVm * vm,int offset)67afc2ba1dSToomas Soome ficlVmBranchRelative(ficlVm *vm, int offset)
68afc2ba1dSToomas Soome {
69afc2ba1dSToomas Soome vm->ip += offset;
70afc2ba1dSToomas Soome }
71afc2ba1dSToomas Soome
72afc2ba1dSToomas Soome /*
73afc2ba1dSToomas Soome * v m C r e a t e
74afc2ba1dSToomas Soome * Creates a virtual machine either from scratch (if vm is NULL on entry)
75afc2ba1dSToomas Soome * or by resizing and reinitializing an existing VM to the specified stack
76afc2ba1dSToomas Soome * sizes.
77afc2ba1dSToomas Soome */
78afc2ba1dSToomas Soome ficlVm *
ficlVmCreate(ficlVm * vm,unsigned nPStack,unsigned nRStack)79afc2ba1dSToomas Soome ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack)
80afc2ba1dSToomas Soome {
81afc2ba1dSToomas Soome if (vm == NULL) {
82afc2ba1dSToomas Soome vm = (ficlVm *)ficlMalloc(sizeof (ficlVm));
83afc2ba1dSToomas Soome FICL_ASSERT(NULL, vm);
84afc2ba1dSToomas Soome memset(vm, 0, sizeof (ficlVm));
85afc2ba1dSToomas Soome }
86afc2ba1dSToomas Soome
87afc2ba1dSToomas Soome if (vm->dataStack)
88afc2ba1dSToomas Soome ficlStackDestroy(vm->dataStack);
89afc2ba1dSToomas Soome vm->dataStack = ficlStackCreate(vm, "data", nPStack);
90afc2ba1dSToomas Soome
91afc2ba1dSToomas Soome if (vm->returnStack)
92afc2ba1dSToomas Soome ficlStackDestroy(vm->returnStack);
93afc2ba1dSToomas Soome vm->returnStack = ficlStackCreate(vm, "return", nRStack);
94afc2ba1dSToomas Soome
95afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
96afc2ba1dSToomas Soome if (vm->floatStack)
97afc2ba1dSToomas Soome ficlStackDestroy(vm->floatStack);
98afc2ba1dSToomas Soome vm->floatStack = ficlStackCreate(vm, "float", nPStack);
99afc2ba1dSToomas Soome #endif
100afc2ba1dSToomas Soome
101afc2ba1dSToomas Soome ficlVmReset(vm);
102afc2ba1dSToomas Soome return (vm);
103afc2ba1dSToomas Soome }
104afc2ba1dSToomas Soome
105afc2ba1dSToomas Soome /*
106afc2ba1dSToomas Soome * v m D e l e t e
107afc2ba1dSToomas Soome * Free all memory allocated to the specified VM and its subordinate
108afc2ba1dSToomas Soome * structures.
109afc2ba1dSToomas Soome */
110afc2ba1dSToomas Soome void
ficlVmDestroy(ficlVm * vm)111afc2ba1dSToomas Soome ficlVmDestroy(ficlVm *vm)
112afc2ba1dSToomas Soome {
113afc2ba1dSToomas Soome if (vm) {
114afc2ba1dSToomas Soome ficlFree(vm->dataStack);
115afc2ba1dSToomas Soome ficlFree(vm->returnStack);
116afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
117afc2ba1dSToomas Soome ficlFree(vm->floatStack);
118afc2ba1dSToomas Soome #endif
119afc2ba1dSToomas Soome ficlFree(vm);
120afc2ba1dSToomas Soome }
121afc2ba1dSToomas Soome }
122afc2ba1dSToomas Soome
123afc2ba1dSToomas Soome /*
124afc2ba1dSToomas Soome * v m E x e c u t e
125afc2ba1dSToomas Soome * Sets up the specified word to be run by the inner interpreter.
126afc2ba1dSToomas Soome * Executes the word's code part immediately, but in the case of
127afc2ba1dSToomas Soome * colon definition, the definition itself needs the inner interpreter
128afc2ba1dSToomas Soome * to complete. This does not happen until control reaches ficlExec
129afc2ba1dSToomas Soome */
130afc2ba1dSToomas Soome void
ficlVmExecuteWord(ficlVm * vm,ficlWord * pWord)131afc2ba1dSToomas Soome ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord)
132afc2ba1dSToomas Soome {
133afc2ba1dSToomas Soome ficlVmInnerLoop(vm, pWord);
134afc2ba1dSToomas Soome }
135afc2ba1dSToomas Soome
136afc2ba1dSToomas Soome static void
ficlVmOptimizeJumpToJump(ficlVm * vm,ficlIp ip)137afc2ba1dSToomas Soome ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip)
138afc2ba1dSToomas Soome {
139afc2ba1dSToomas Soome ficlIp destination;
140afc2ba1dSToomas Soome switch ((ficlInstruction)(*ip)) {
141afc2ba1dSToomas Soome case ficlInstructionBranchParenWithCheck:
142afc2ba1dSToomas Soome *ip = (ficlWord *)ficlInstructionBranchParen;
143afc2ba1dSToomas Soome goto RUNTIME_FIXUP;
144afc2ba1dSToomas Soome
145afc2ba1dSToomas Soome case ficlInstructionBranch0ParenWithCheck:
146afc2ba1dSToomas Soome *ip = (ficlWord *)ficlInstructionBranch0Paren;
147afc2ba1dSToomas Soome RUNTIME_FIXUP:
148afc2ba1dSToomas Soome ip++;
149afc2ba1dSToomas Soome destination = ip + *(ficlInteger *)ip;
150afc2ba1dSToomas Soome switch ((ficlInstruction)*destination) {
151afc2ba1dSToomas Soome case ficlInstructionBranchParenWithCheck:
152afc2ba1dSToomas Soome /* preoptimize where we're jumping to */
153afc2ba1dSToomas Soome ficlVmOptimizeJumpToJump(vm, destination);
154d65dfb0aSToomas Soome /* FALLTHROUGH */
155afc2ba1dSToomas Soome case ficlInstructionBranchParen:
156afc2ba1dSToomas Soome destination++;
157afc2ba1dSToomas Soome destination += *(ficlInteger *)destination;
158afc2ba1dSToomas Soome *ip = (ficlWord *)(destination - ip);
159afc2ba1dSToomas Soome break;
160afc2ba1dSToomas Soome }
161afc2ba1dSToomas Soome }
162afc2ba1dSToomas Soome }
163afc2ba1dSToomas Soome
164afc2ba1dSToomas Soome /*
165afc2ba1dSToomas Soome * v m I n n e r L o o p
166afc2ba1dSToomas Soome * the mysterious inner interpreter...
167afc2ba1dSToomas Soome * This loop is the address interpreter that makes colon definitions
168afc2ba1dSToomas Soome * work. Upon entry, it assumes that the IP points to an entry in
169afc2ba1dSToomas Soome * a definition (the body of a colon word). It runs one word at a time
170afc2ba1dSToomas Soome * until something does vmThrow. The catcher for this is expected to exist
171afc2ba1dSToomas Soome * in the calling code.
172afc2ba1dSToomas Soome * vmThrow gets you out of this loop with a longjmp()
173afc2ba1dSToomas Soome */
174afc2ba1dSToomas Soome
175afc2ba1dSToomas Soome #if FICL_ROBUST <= 1
176afc2ba1dSToomas Soome /* turn off stack checking for primitives */
177afc2ba1dSToomas Soome #define _CHECK_STACK(stack, top, pop, push)
178afc2ba1dSToomas Soome #else
179afc2ba1dSToomas Soome
180afc2ba1dSToomas Soome #define _CHECK_STACK(stack, top, pop, push) \
181afc2ba1dSToomas Soome ficlStackCheckNospill(stack, top, pop, push)
182afc2ba1dSToomas Soome
1830c950529SToomas Soome static FICL_PLATFORM_INLINE void
ficlStackCheckNospill(ficlStack * stack,ficlCell * top,int popCells,int pushCells)184afc2ba1dSToomas Soome ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells,
185afc2ba1dSToomas Soome int pushCells)
186afc2ba1dSToomas Soome {
187afc2ba1dSToomas Soome /*
188afc2ba1dSToomas Soome * Why save and restore stack->top?
189afc2ba1dSToomas Soome * So the simple act of stack checking doesn't force a "register" spill,
190afc2ba1dSToomas Soome * which might mask bugs (places where we needed to spill but didn't).
191afc2ba1dSToomas Soome * --lch
192afc2ba1dSToomas Soome */
193afc2ba1dSToomas Soome ficlCell *oldTop = stack->top;
194afc2ba1dSToomas Soome stack->top = top;
195afc2ba1dSToomas Soome ficlStackCheck(stack, popCells, pushCells);
196afc2ba1dSToomas Soome stack->top = oldTop;
197afc2ba1dSToomas Soome }
198afc2ba1dSToomas Soome
199afc2ba1dSToomas Soome #endif /* FICL_ROBUST <= 1 */
200afc2ba1dSToomas Soome
201afc2ba1dSToomas Soome #define CHECK_STACK(pop, push) \
202afc2ba1dSToomas Soome _CHECK_STACK(vm->dataStack, dataTop, pop, push)
203afc2ba1dSToomas Soome #define CHECK_FLOAT_STACK(pop, push) \
204afc2ba1dSToomas Soome _CHECK_STACK(vm->floatStack, floatTop, pop, push)
205afc2ba1dSToomas Soome #define CHECK_RETURN_STACK(pop, push) \
206afc2ba1dSToomas Soome _CHECK_STACK(vm->returnStack, returnTop, pop, push)
207afc2ba1dSToomas Soome
208afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
209afc2ba1dSToomas Soome #define FLOAT_LOCAL_VARIABLE_SPILL \
210afc2ba1dSToomas Soome vm->floatStack->top = floatTop;
211afc2ba1dSToomas Soome #define FLOAT_LOCAL_VARIABLE_REFILL \
212afc2ba1dSToomas Soome floatTop = vm->floatStack->top;
213afc2ba1dSToomas Soome #else
214afc2ba1dSToomas Soome #define FLOAT_LOCAL_VARIABLE_SPILL
215afc2ba1dSToomas Soome #define FLOAT_LOCAL_VARIABLE_REFILL
216afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
217afc2ba1dSToomas Soome
218afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
219afc2ba1dSToomas Soome #define LOCALS_LOCAL_VARIABLE_SPILL \
220afc2ba1dSToomas Soome vm->returnStack->frame = frame;
221afc2ba1dSToomas Soome #define LOCALS_LOCAL_VARIABLE_REFILL \
222afc2ba1dSToomas Soome frame = vm->returnStack->frame;
223afc2ba1dSToomas Soome #else
224afc2ba1dSToomas Soome #define LOCALS_LOCAL_VARIABLE_SPILL
225afc2ba1dSToomas Soome #define LOCALS_LOCAL_VARIABLE_REFILL
226afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
227afc2ba1dSToomas Soome
228afc2ba1dSToomas Soome #define LOCAL_VARIABLE_SPILL \
229afc2ba1dSToomas Soome vm->ip = (ficlIp)ip; \
230afc2ba1dSToomas Soome vm->dataStack->top = dataTop; \
231afc2ba1dSToomas Soome vm->returnStack->top = returnTop; \
232afc2ba1dSToomas Soome FLOAT_LOCAL_VARIABLE_SPILL \
233afc2ba1dSToomas Soome LOCALS_LOCAL_VARIABLE_SPILL
234afc2ba1dSToomas Soome
235afc2ba1dSToomas Soome #define LOCAL_VARIABLE_REFILL \
236afc2ba1dSToomas Soome ip = (ficlInstruction *)vm->ip; \
237afc2ba1dSToomas Soome dataTop = vm->dataStack->top; \
238afc2ba1dSToomas Soome returnTop = vm->returnStack->top; \
239afc2ba1dSToomas Soome FLOAT_LOCAL_VARIABLE_REFILL \
240afc2ba1dSToomas Soome LOCALS_LOCAL_VARIABLE_REFILL
241afc2ba1dSToomas Soome
242afc2ba1dSToomas Soome void
ficlVmInnerLoop(ficlVm * vm,ficlWord * fw)243afc2ba1dSToomas Soome ficlVmInnerLoop(ficlVm *vm, ficlWord *fw)
244afc2ba1dSToomas Soome {
245afc2ba1dSToomas Soome register ficlInstruction *ip;
246afc2ba1dSToomas Soome register ficlCell *dataTop;
247afc2ba1dSToomas Soome register ficlCell *returnTop;
248afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
249afc2ba1dSToomas Soome register ficlCell *floatTop;
250afc2ba1dSToomas Soome ficlFloat f;
251afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
252afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
253afc2ba1dSToomas Soome register ficlCell *frame;
254afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
255afc2ba1dSToomas Soome jmp_buf *oldExceptionHandler;
256afc2ba1dSToomas Soome jmp_buf exceptionHandler;
257afc2ba1dSToomas Soome int except;
258afc2ba1dSToomas Soome int once;
259471b551fSToomas Soome volatile int count; /* volatile because of longjmp */
260afc2ba1dSToomas Soome ficlInstruction instruction;
261afc2ba1dSToomas Soome ficlInteger i;
262afc2ba1dSToomas Soome ficlUnsigned u;
263afc2ba1dSToomas Soome ficlCell c;
264afc2ba1dSToomas Soome ficlCountedString *s;
265afc2ba1dSToomas Soome ficlCell *cell;
266afc2ba1dSToomas Soome char *cp;
267afc2ba1dSToomas Soome
268afc2ba1dSToomas Soome once = (fw != NULL);
269afc2ba1dSToomas Soome if (once)
270afc2ba1dSToomas Soome count = 1;
271afc2ba1dSToomas Soome
272afc2ba1dSToomas Soome oldExceptionHandler = vm->exceptionHandler;
273afc2ba1dSToomas Soome /* This has to come before the setjmp! */
274afc2ba1dSToomas Soome vm->exceptionHandler = &exceptionHandler;
275afc2ba1dSToomas Soome except = setjmp(exceptionHandler);
276afc2ba1dSToomas Soome
277afc2ba1dSToomas Soome LOCAL_VARIABLE_REFILL;
278afc2ba1dSToomas Soome
279afc2ba1dSToomas Soome if (except) {
280afc2ba1dSToomas Soome LOCAL_VARIABLE_SPILL;
281afc2ba1dSToomas Soome vm->exceptionHandler = oldExceptionHandler;
282afc2ba1dSToomas Soome ficlVmThrow(vm, except);
283afc2ba1dSToomas Soome }
284afc2ba1dSToomas Soome
285afc2ba1dSToomas Soome for (;;) {
286afc2ba1dSToomas Soome if (once) {
287afc2ba1dSToomas Soome if (!count--)
288afc2ba1dSToomas Soome break;
289afc2ba1dSToomas Soome instruction = (ficlInstruction)((void *)fw);
290afc2ba1dSToomas Soome } else {
291afc2ba1dSToomas Soome instruction = *ip++;
292afc2ba1dSToomas Soome fw = (ficlWord *)instruction;
293afc2ba1dSToomas Soome }
294afc2ba1dSToomas Soome
295afc2ba1dSToomas Soome AGAIN:
296afc2ba1dSToomas Soome switch (instruction) {
297afc2ba1dSToomas Soome case ficlInstructionInvalid:
298afc2ba1dSToomas Soome ficlVmThrowError(vm,
299afc2ba1dSToomas Soome "Error: NULL instruction executed!");
300c0bb4f73SToomas Soome break;
301afc2ba1dSToomas Soome
302afc2ba1dSToomas Soome case ficlInstruction1:
303afc2ba1dSToomas Soome case ficlInstruction2:
304afc2ba1dSToomas Soome case ficlInstruction3:
305afc2ba1dSToomas Soome case ficlInstruction4:
306afc2ba1dSToomas Soome case ficlInstruction5:
307afc2ba1dSToomas Soome case ficlInstruction6:
308afc2ba1dSToomas Soome case ficlInstruction7:
309afc2ba1dSToomas Soome case ficlInstruction8:
310afc2ba1dSToomas Soome case ficlInstruction9:
311afc2ba1dSToomas Soome case ficlInstruction10:
312afc2ba1dSToomas Soome case ficlInstruction11:
313afc2ba1dSToomas Soome case ficlInstruction12:
314afc2ba1dSToomas Soome case ficlInstruction13:
315afc2ba1dSToomas Soome case ficlInstruction14:
316afc2ba1dSToomas Soome case ficlInstruction15:
317afc2ba1dSToomas Soome case ficlInstruction16:
318afc2ba1dSToomas Soome CHECK_STACK(0, 1);
319afc2ba1dSToomas Soome (++dataTop)->i = instruction;
320c0bb4f73SToomas Soome continue;
321afc2ba1dSToomas Soome
322afc2ba1dSToomas Soome case ficlInstruction0:
323afc2ba1dSToomas Soome case ficlInstructionNeg1:
324afc2ba1dSToomas Soome case ficlInstructionNeg2:
325afc2ba1dSToomas Soome case ficlInstructionNeg3:
326afc2ba1dSToomas Soome case ficlInstructionNeg4:
327afc2ba1dSToomas Soome case ficlInstructionNeg5:
328afc2ba1dSToomas Soome case ficlInstructionNeg6:
329afc2ba1dSToomas Soome case ficlInstructionNeg7:
330afc2ba1dSToomas Soome case ficlInstructionNeg8:
331afc2ba1dSToomas Soome case ficlInstructionNeg9:
332afc2ba1dSToomas Soome case ficlInstructionNeg10:
333afc2ba1dSToomas Soome case ficlInstructionNeg11:
334afc2ba1dSToomas Soome case ficlInstructionNeg12:
335afc2ba1dSToomas Soome case ficlInstructionNeg13:
336afc2ba1dSToomas Soome case ficlInstructionNeg14:
337afc2ba1dSToomas Soome case ficlInstructionNeg15:
338afc2ba1dSToomas Soome case ficlInstructionNeg16:
339afc2ba1dSToomas Soome CHECK_STACK(0, 1);
340afc2ba1dSToomas Soome (++dataTop)->i = ficlInstruction0 - instruction;
341c0bb4f73SToomas Soome continue;
342afc2ba1dSToomas Soome
343afc2ba1dSToomas Soome /*
344afc2ba1dSToomas Soome * stringlit: Fetch the count from the dictionary, then push
345afc2ba1dSToomas Soome * the address and count on the stack. Finally, update ip to
346afc2ba1dSToomas Soome * point to the first aligned address after the string text.
347afc2ba1dSToomas Soome */
348afc2ba1dSToomas Soome case ficlInstructionStringLiteralParen: {
349afc2ba1dSToomas Soome ficlUnsigned8 length;
350afc2ba1dSToomas Soome CHECK_STACK(0, 2);
351afc2ba1dSToomas Soome
352afc2ba1dSToomas Soome s = (ficlCountedString *)(ip);
353afc2ba1dSToomas Soome length = s->length;
354afc2ba1dSToomas Soome cp = s->text;
355afc2ba1dSToomas Soome (++dataTop)->p = cp;
356afc2ba1dSToomas Soome (++dataTop)->i = length;
357afc2ba1dSToomas Soome
358afc2ba1dSToomas Soome cp += length + 1;
359afc2ba1dSToomas Soome cp = ficlAlignPointer(cp);
360afc2ba1dSToomas Soome ip = (void *)cp;
361c0bb4f73SToomas Soome continue;
362afc2ba1dSToomas Soome }
363afc2ba1dSToomas Soome
364afc2ba1dSToomas Soome case ficlInstructionCStringLiteralParen:
365afc2ba1dSToomas Soome CHECK_STACK(0, 1);
366afc2ba1dSToomas Soome
367afc2ba1dSToomas Soome s = (ficlCountedString *)(ip);
368afc2ba1dSToomas Soome cp = s->text + s->length + 1;
369afc2ba1dSToomas Soome cp = ficlAlignPointer(cp);
370afc2ba1dSToomas Soome ip = (void *)cp;
371afc2ba1dSToomas Soome (++dataTop)->p = s;
372c0bb4f73SToomas Soome continue;
373afc2ba1dSToomas Soome
374afc2ba1dSToomas Soome #if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE
375afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
376afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC:
377afc2ba1dSToomas Soome *++floatTop = cell[1];
378afc2ba1dSToomas Soome /* intentional fall-through */
379afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER_MINIPROC:
380afc2ba1dSToomas Soome *++floatTop = cell[0];
381c0bb4f73SToomas Soome continue;
382afc2ba1dSToomas Soome
383afc2ba1dSToomas Soome FLOAT_POP_CELL_POINTER_MINIPROC:
384afc2ba1dSToomas Soome cell[0] = *floatTop--;
385c0bb4f73SToomas Soome continue;
386afc2ba1dSToomas Soome
387afc2ba1dSToomas Soome FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC:
388afc2ba1dSToomas Soome cell[0] = *floatTop--;
389afc2ba1dSToomas Soome cell[1] = *floatTop--;
390c0bb4f73SToomas Soome continue;
391afc2ba1dSToomas Soome
392afc2ba1dSToomas Soome #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \
393afc2ba1dSToomas Soome cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC
394afc2ba1dSToomas Soome #define FLOAT_PUSH_CELL_POINTER(cp) \
395afc2ba1dSToomas Soome cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC
396afc2ba1dSToomas Soome #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \
397afc2ba1dSToomas Soome cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC
398afc2ba1dSToomas Soome #define FLOAT_POP_CELL_POINTER(cp) \
399afc2ba1dSToomas Soome cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC
400afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
401afc2ba1dSToomas Soome
402afc2ba1dSToomas Soome /*
403afc2ba1dSToomas Soome * Think of these as little mini-procedures.
404afc2ba1dSToomas Soome * --lch
405afc2ba1dSToomas Soome */
406afc2ba1dSToomas Soome PUSH_CELL_POINTER_DOUBLE_MINIPROC:
407afc2ba1dSToomas Soome *++dataTop = cell[1];
408afc2ba1dSToomas Soome /* intentional fall-through */
409afc2ba1dSToomas Soome PUSH_CELL_POINTER_MINIPROC:
410afc2ba1dSToomas Soome *++dataTop = cell[0];
411c0bb4f73SToomas Soome continue;
412afc2ba1dSToomas Soome
413afc2ba1dSToomas Soome POP_CELL_POINTER_MINIPROC:
414afc2ba1dSToomas Soome cell[0] = *dataTop--;
415c0bb4f73SToomas Soome continue;
416afc2ba1dSToomas Soome POP_CELL_POINTER_DOUBLE_MINIPROC:
417afc2ba1dSToomas Soome cell[0] = *dataTop--;
418afc2ba1dSToomas Soome cell[1] = *dataTop--;
419c0bb4f73SToomas Soome continue;
420afc2ba1dSToomas Soome
421afc2ba1dSToomas Soome #define PUSH_CELL_POINTER_DOUBLE(cp) \
422afc2ba1dSToomas Soome cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC
423afc2ba1dSToomas Soome #define PUSH_CELL_POINTER(cp) \
424afc2ba1dSToomas Soome cell = (cp); goto PUSH_CELL_POINTER_MINIPROC
425afc2ba1dSToomas Soome #define POP_CELL_POINTER_DOUBLE(cp) \
426afc2ba1dSToomas Soome cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC
427afc2ba1dSToomas Soome #define POP_CELL_POINTER(cp) \
428afc2ba1dSToomas Soome cell = (cp); goto POP_CELL_POINTER_MINIPROC
429afc2ba1dSToomas Soome
430afc2ba1dSToomas Soome BRANCH_MINIPROC:
431afc2ba1dSToomas Soome ip += *(ficlInteger *)ip;
432c0bb4f73SToomas Soome continue;
433afc2ba1dSToomas Soome
434afc2ba1dSToomas Soome #define BRANCH() goto BRANCH_MINIPROC
435afc2ba1dSToomas Soome
436afc2ba1dSToomas Soome EXIT_FUNCTION_MINIPROC:
437afc2ba1dSToomas Soome ip = (ficlInstruction *)((returnTop--)->p);
438c0bb4f73SToomas Soome continue;
439afc2ba1dSToomas Soome
440afc2ba1dSToomas Soome #define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC
441afc2ba1dSToomas Soome
442afc2ba1dSToomas Soome #else /* FICL_WANT_SIZE */
443afc2ba1dSToomas Soome
444afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
445afc2ba1dSToomas Soome #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \
446afc2ba1dSToomas Soome cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue
447afc2ba1dSToomas Soome #define FLOAT_PUSH_CELL_POINTER(cp) \
448afc2ba1dSToomas Soome cell = (cp); *++floatTop = *cell; continue
449afc2ba1dSToomas Soome #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \
450afc2ba1dSToomas Soome cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue
451afc2ba1dSToomas Soome #define FLOAT_POP_CELL_POINTER(cp) \
452afc2ba1dSToomas Soome cell = (cp); *cell = *floatTop--; continue
453afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
454afc2ba1dSToomas Soome
455afc2ba1dSToomas Soome #define PUSH_CELL_POINTER_DOUBLE(cp) \
456afc2ba1dSToomas Soome cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue
457afc2ba1dSToomas Soome #define PUSH_CELL_POINTER(cp) \
458afc2ba1dSToomas Soome cell = (cp); *++dataTop = *cell; continue
459afc2ba1dSToomas Soome #define POP_CELL_POINTER_DOUBLE(cp) \
460afc2ba1dSToomas Soome cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue
461afc2ba1dSToomas Soome #define POP_CELL_POINTER(cp) \
462afc2ba1dSToomas Soome cell = (cp); *cell = *dataTop--; continue
463afc2ba1dSToomas Soome
464afc2ba1dSToomas Soome #define BRANCH() ip += *(ficlInteger *)ip; continue
465afc2ba1dSToomas Soome #define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue
466afc2ba1dSToomas Soome
467afc2ba1dSToomas Soome #endif /* FICL_WANT_SIZE */
468afc2ba1dSToomas Soome
469afc2ba1dSToomas Soome
470afc2ba1dSToomas Soome /*
471afc2ba1dSToomas Soome * This is the runtime for (literal). It assumes that it is
472afc2ba1dSToomas Soome * part of a colon definition, and that the next ficlCell
473afc2ba1dSToomas Soome * contains a value to be pushed on the parameter stack at
474afc2ba1dSToomas Soome * runtime. This code is compiled by "literal".
475afc2ba1dSToomas Soome */
476afc2ba1dSToomas Soome
477afc2ba1dSToomas Soome case ficlInstructionLiteralParen:
478afc2ba1dSToomas Soome CHECK_STACK(0, 1);
479afc2ba1dSToomas Soome (++dataTop)->i = *ip++;
480c0bb4f73SToomas Soome continue;
481afc2ba1dSToomas Soome
482afc2ba1dSToomas Soome case ficlInstruction2LiteralParen:
483afc2ba1dSToomas Soome CHECK_STACK(0, 2);
484afc2ba1dSToomas Soome (++dataTop)->i = ip[1];
485afc2ba1dSToomas Soome (++dataTop)->i = ip[0];
486afc2ba1dSToomas Soome ip += 2;
487c0bb4f73SToomas Soome continue;
488afc2ba1dSToomas Soome
489afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
490afc2ba1dSToomas Soome /*
491afc2ba1dSToomas Soome * Link a frame on the return stack, reserving nCells of space
492afc2ba1dSToomas Soome * for locals - the value of nCells is the next ficlCell in
493afc2ba1dSToomas Soome * the instruction stream.
494afc2ba1dSToomas Soome * 1) Push frame onto returnTop
495afc2ba1dSToomas Soome * 2) frame = returnTop
496afc2ba1dSToomas Soome * 3) returnTop += nCells
497afc2ba1dSToomas Soome */
498afc2ba1dSToomas Soome case ficlInstructionLinkParen: {
499afc2ba1dSToomas Soome ficlInteger nCells = *ip++;
500afc2ba1dSToomas Soome (++returnTop)->p = frame;
501afc2ba1dSToomas Soome frame = returnTop + 1;
502afc2ba1dSToomas Soome returnTop += nCells;
503c0bb4f73SToomas Soome continue;
504afc2ba1dSToomas Soome }
505afc2ba1dSToomas Soome
506afc2ba1dSToomas Soome /*
507afc2ba1dSToomas Soome * Unink a stack frame previously created by stackLink
508afc2ba1dSToomas Soome * 1) dataTop = frame
509afc2ba1dSToomas Soome * 2) frame = pop()
510afc2ba1dSToomas Soome */
511afc2ba1dSToomas Soome case ficlInstructionUnlinkParen:
512afc2ba1dSToomas Soome returnTop = frame - 1;
513afc2ba1dSToomas Soome frame = (returnTop--)->p;
514c0bb4f73SToomas Soome continue;
515afc2ba1dSToomas Soome
516afc2ba1dSToomas Soome /*
517afc2ba1dSToomas Soome * Immediate - cfa of a local while compiling - when executed,
518afc2ba1dSToomas Soome * compiles code to fetch the value of a local given the
519afc2ba1dSToomas Soome * local's index in the word's pfa
520afc2ba1dSToomas Soome */
521afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
522afc2ba1dSToomas Soome case ficlInstructionGetF2LocalParen:
523afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
524afc2ba1dSToomas Soome
525afc2ba1dSToomas Soome case ficlInstructionGetFLocalParen:
526afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER(frame + *ip++);
527afc2ba1dSToomas Soome
528afc2ba1dSToomas Soome case ficlInstructionToF2LocalParen:
529afc2ba1dSToomas Soome FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++);
530afc2ba1dSToomas Soome
531afc2ba1dSToomas Soome case ficlInstructionToFLocalParen:
532afc2ba1dSToomas Soome FLOAT_POP_CELL_POINTER(frame + *ip++);
533afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
534afc2ba1dSToomas Soome
535afc2ba1dSToomas Soome case ficlInstructionGet2LocalParen:
536afc2ba1dSToomas Soome PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
537afc2ba1dSToomas Soome
538afc2ba1dSToomas Soome case ficlInstructionGetLocalParen:
539afc2ba1dSToomas Soome PUSH_CELL_POINTER(frame + *ip++);
540afc2ba1dSToomas Soome
541afc2ba1dSToomas Soome /*
542afc2ba1dSToomas Soome * Immediate - cfa of a local while compiling - when executed,
543afc2ba1dSToomas Soome * compiles code to store the value of a local given the
544afc2ba1dSToomas Soome * local's index in the word's pfa
545afc2ba1dSToomas Soome */
546afc2ba1dSToomas Soome
547afc2ba1dSToomas Soome case ficlInstructionTo2LocalParen:
548afc2ba1dSToomas Soome POP_CELL_POINTER_DOUBLE(frame + *ip++);
549afc2ba1dSToomas Soome
550afc2ba1dSToomas Soome case ficlInstructionToLocalParen:
551afc2ba1dSToomas Soome POP_CELL_POINTER(frame + *ip++);
552afc2ba1dSToomas Soome
553afc2ba1dSToomas Soome /*
554afc2ba1dSToomas Soome * Silly little minor optimizations.
555afc2ba1dSToomas Soome * --lch
556afc2ba1dSToomas Soome */
557afc2ba1dSToomas Soome case ficlInstructionGetLocal0:
558afc2ba1dSToomas Soome PUSH_CELL_POINTER(frame);
559afc2ba1dSToomas Soome
560afc2ba1dSToomas Soome case ficlInstructionGetLocal1:
561afc2ba1dSToomas Soome PUSH_CELL_POINTER(frame + 1);
562afc2ba1dSToomas Soome
563afc2ba1dSToomas Soome case ficlInstructionGet2Local0:
564afc2ba1dSToomas Soome PUSH_CELL_POINTER_DOUBLE(frame);
565afc2ba1dSToomas Soome
566afc2ba1dSToomas Soome case ficlInstructionToLocal0:
567afc2ba1dSToomas Soome POP_CELL_POINTER(frame);
568afc2ba1dSToomas Soome
569afc2ba1dSToomas Soome case ficlInstructionToLocal1:
570afc2ba1dSToomas Soome POP_CELL_POINTER(frame + 1);
571afc2ba1dSToomas Soome
572afc2ba1dSToomas Soome case ficlInstructionTo2Local0:
573afc2ba1dSToomas Soome POP_CELL_POINTER_DOUBLE(frame);
574afc2ba1dSToomas Soome
575afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
576afc2ba1dSToomas Soome
577afc2ba1dSToomas Soome case ficlInstructionPlus:
578afc2ba1dSToomas Soome CHECK_STACK(2, 1);
579afc2ba1dSToomas Soome i = (dataTop--)->i;
580afc2ba1dSToomas Soome dataTop->i += i;
581c0bb4f73SToomas Soome continue;
582afc2ba1dSToomas Soome
583afc2ba1dSToomas Soome case ficlInstructionMinus:
584afc2ba1dSToomas Soome CHECK_STACK(2, 1);
585afc2ba1dSToomas Soome i = (dataTop--)->i;
586afc2ba1dSToomas Soome dataTop->i -= i;
587c0bb4f73SToomas Soome continue;
588afc2ba1dSToomas Soome
589afc2ba1dSToomas Soome case ficlInstruction1Plus:
590afc2ba1dSToomas Soome CHECK_STACK(1, 1);
591afc2ba1dSToomas Soome dataTop->i++;
592c0bb4f73SToomas Soome continue;
593afc2ba1dSToomas Soome
594afc2ba1dSToomas Soome case ficlInstruction1Minus:
595afc2ba1dSToomas Soome CHECK_STACK(1, 1);
596afc2ba1dSToomas Soome dataTop->i--;
597c0bb4f73SToomas Soome continue;
598afc2ba1dSToomas Soome
599afc2ba1dSToomas Soome case ficlInstruction2Plus:
600afc2ba1dSToomas Soome CHECK_STACK(1, 1);
601afc2ba1dSToomas Soome dataTop->i += 2;
602c0bb4f73SToomas Soome continue;
603afc2ba1dSToomas Soome
604afc2ba1dSToomas Soome case ficlInstruction2Minus:
605afc2ba1dSToomas Soome CHECK_STACK(1, 1);
606afc2ba1dSToomas Soome dataTop->i -= 2;
607c0bb4f73SToomas Soome continue;
608afc2ba1dSToomas Soome
609afc2ba1dSToomas Soome case ficlInstructionDup: {
610afc2ba1dSToomas Soome ficlInteger i = dataTop->i;
611afc2ba1dSToomas Soome CHECK_STACK(0, 1);
612afc2ba1dSToomas Soome (++dataTop)->i = i;
613afc2ba1dSToomas Soome continue;
614afc2ba1dSToomas Soome }
615afc2ba1dSToomas Soome
616afc2ba1dSToomas Soome case ficlInstructionQuestionDup:
617afc2ba1dSToomas Soome CHECK_STACK(1, 2);
618afc2ba1dSToomas Soome
619afc2ba1dSToomas Soome if (dataTop->i != 0) {
620afc2ba1dSToomas Soome dataTop[1] = dataTop[0];
621afc2ba1dSToomas Soome dataTop++;
622afc2ba1dSToomas Soome }
623afc2ba1dSToomas Soome
624c0bb4f73SToomas Soome continue;
625afc2ba1dSToomas Soome
626afc2ba1dSToomas Soome case ficlInstructionSwap: {
627afc2ba1dSToomas Soome ficlCell swap;
628afc2ba1dSToomas Soome CHECK_STACK(2, 2);
629afc2ba1dSToomas Soome swap = dataTop[0];
630afc2ba1dSToomas Soome dataTop[0] = dataTop[-1];
631afc2ba1dSToomas Soome dataTop[-1] = swap;
632c0bb4f73SToomas Soome continue;
633afc2ba1dSToomas Soome }
634afc2ba1dSToomas Soome
635afc2ba1dSToomas Soome case ficlInstructionDrop:
636afc2ba1dSToomas Soome CHECK_STACK(1, 0);
637afc2ba1dSToomas Soome dataTop--;
638c0bb4f73SToomas Soome continue;
639afc2ba1dSToomas Soome
640afc2ba1dSToomas Soome case ficlInstruction2Drop:
641afc2ba1dSToomas Soome CHECK_STACK(2, 0);
642afc2ba1dSToomas Soome dataTop -= 2;
643c0bb4f73SToomas Soome continue;
644afc2ba1dSToomas Soome
645afc2ba1dSToomas Soome case ficlInstruction2Dup:
646afc2ba1dSToomas Soome CHECK_STACK(2, 4);
647afc2ba1dSToomas Soome dataTop[1] = dataTop[-1];
648afc2ba1dSToomas Soome dataTop[2] = *dataTop;
649afc2ba1dSToomas Soome dataTop += 2;
650c0bb4f73SToomas Soome continue;
651afc2ba1dSToomas Soome
652afc2ba1dSToomas Soome case ficlInstructionOver:
653afc2ba1dSToomas Soome CHECK_STACK(2, 3);
654afc2ba1dSToomas Soome dataTop[1] = dataTop[-1];
655afc2ba1dSToomas Soome dataTop++;
656c0bb4f73SToomas Soome continue;
657afc2ba1dSToomas Soome
658afc2ba1dSToomas Soome case ficlInstruction2Over:
659afc2ba1dSToomas Soome CHECK_STACK(4, 6);
660afc2ba1dSToomas Soome dataTop[1] = dataTop[-3];
661afc2ba1dSToomas Soome dataTop[2] = dataTop[-2];
662afc2ba1dSToomas Soome dataTop += 2;
663c0bb4f73SToomas Soome continue;
664afc2ba1dSToomas Soome
665afc2ba1dSToomas Soome case ficlInstructionPick:
666afc2ba1dSToomas Soome CHECK_STACK(1, 0);
667afc2ba1dSToomas Soome i = dataTop->i;
668afc2ba1dSToomas Soome if (i < 0)
669afc2ba1dSToomas Soome continue;
670afc2ba1dSToomas Soome CHECK_STACK(i + 2, i + 3);
671afc2ba1dSToomas Soome *dataTop = dataTop[-i - 1];
672c0bb4f73SToomas Soome continue;
673afc2ba1dSToomas Soome
674afc2ba1dSToomas Soome /*
675afc2ba1dSToomas Soome * Do stack rot.
676afc2ba1dSToomas Soome * rot ( 1 2 3 -- 2 3 1 )
677afc2ba1dSToomas Soome */
678afc2ba1dSToomas Soome case ficlInstructionRot:
679afc2ba1dSToomas Soome i = 2;
680c0bb4f73SToomas Soome goto ROLL;
681afc2ba1dSToomas Soome
682afc2ba1dSToomas Soome /*
683afc2ba1dSToomas Soome * Do stack roll.
684afc2ba1dSToomas Soome * roll ( n -- )
685afc2ba1dSToomas Soome */
686afc2ba1dSToomas Soome case ficlInstructionRoll:
687afc2ba1dSToomas Soome CHECK_STACK(1, 0);
688afc2ba1dSToomas Soome i = (dataTop--)->i;
689afc2ba1dSToomas Soome
690afc2ba1dSToomas Soome if (i < 1)
691afc2ba1dSToomas Soome continue;
692afc2ba1dSToomas Soome
693afc2ba1dSToomas Soome ROLL:
694afc2ba1dSToomas Soome CHECK_STACK(i+1, i+2);
695afc2ba1dSToomas Soome c = dataTop[-i];
696afc2ba1dSToomas Soome memmove(dataTop - i, dataTop - (i - 1),
697afc2ba1dSToomas Soome i * sizeof (ficlCell));
698afc2ba1dSToomas Soome *dataTop = c;
699c0bb4f73SToomas Soome continue;
700afc2ba1dSToomas Soome
701afc2ba1dSToomas Soome /*
702afc2ba1dSToomas Soome * Do stack -rot.
703afc2ba1dSToomas Soome * -rot ( 1 2 3 -- 3 1 2 )
704afc2ba1dSToomas Soome */
705afc2ba1dSToomas Soome case ficlInstructionMinusRot:
706afc2ba1dSToomas Soome i = 2;
707c0bb4f73SToomas Soome goto MINUSROLL;
708afc2ba1dSToomas Soome
709afc2ba1dSToomas Soome /*
710afc2ba1dSToomas Soome * Do stack -roll.
711afc2ba1dSToomas Soome * -roll ( n -- )
712afc2ba1dSToomas Soome */
713afc2ba1dSToomas Soome case ficlInstructionMinusRoll:
714afc2ba1dSToomas Soome CHECK_STACK(1, 0);
715afc2ba1dSToomas Soome i = (dataTop--)->i;
716afc2ba1dSToomas Soome
717afc2ba1dSToomas Soome if (i < 1)
718afc2ba1dSToomas Soome continue;
719afc2ba1dSToomas Soome
720afc2ba1dSToomas Soome MINUSROLL:
721afc2ba1dSToomas Soome CHECK_STACK(i+1, i+2);
722afc2ba1dSToomas Soome c = *dataTop;
723afc2ba1dSToomas Soome memmove(dataTop - (i - 1), dataTop - i,
724afc2ba1dSToomas Soome i * sizeof (ficlCell));
725afc2ba1dSToomas Soome dataTop[-i] = c;
726afc2ba1dSToomas Soome
727c0bb4f73SToomas Soome continue;
728afc2ba1dSToomas Soome
729afc2ba1dSToomas Soome /*
730afc2ba1dSToomas Soome * Do stack 2swap
731afc2ba1dSToomas Soome * 2swap ( 1 2 3 4 -- 3 4 1 2 )
732afc2ba1dSToomas Soome */
733afc2ba1dSToomas Soome case ficlInstruction2Swap: {
734afc2ba1dSToomas Soome ficlCell c2;
735afc2ba1dSToomas Soome CHECK_STACK(4, 4);
736afc2ba1dSToomas Soome
737afc2ba1dSToomas Soome c = *dataTop;
738afc2ba1dSToomas Soome c2 = dataTop[-1];
739afc2ba1dSToomas Soome
740afc2ba1dSToomas Soome *dataTop = dataTop[-2];
741afc2ba1dSToomas Soome dataTop[-1] = dataTop[-3];
742afc2ba1dSToomas Soome
743afc2ba1dSToomas Soome dataTop[-2] = c;
744afc2ba1dSToomas Soome dataTop[-3] = c2;
745c0bb4f73SToomas Soome continue;
746afc2ba1dSToomas Soome }
747afc2ba1dSToomas Soome
748afc2ba1dSToomas Soome case ficlInstructionPlusStore: {
749afc2ba1dSToomas Soome ficlCell *cell;
750afc2ba1dSToomas Soome CHECK_STACK(2, 0);
751afc2ba1dSToomas Soome cell = (ficlCell *)(dataTop--)->p;
752afc2ba1dSToomas Soome cell->i += (dataTop--)->i;
753c0bb4f73SToomas Soome continue;
754afc2ba1dSToomas Soome }
755afc2ba1dSToomas Soome
756afc2ba1dSToomas Soome case ficlInstructionQuadFetch: {
757afc2ba1dSToomas Soome ficlUnsigned32 *integer32;
758afc2ba1dSToomas Soome CHECK_STACK(1, 1);
759afc2ba1dSToomas Soome integer32 = (ficlUnsigned32 *)dataTop->i;
760afc2ba1dSToomas Soome dataTop->u = (ficlUnsigned)*integer32;
761c0bb4f73SToomas Soome continue;
762afc2ba1dSToomas Soome }
763afc2ba1dSToomas Soome
764afc2ba1dSToomas Soome case ficlInstructionQuadStore: {
765afc2ba1dSToomas Soome ficlUnsigned32 *integer32;
766afc2ba1dSToomas Soome CHECK_STACK(2, 0);
767afc2ba1dSToomas Soome integer32 = (ficlUnsigned32 *)(dataTop--)->p;
768afc2ba1dSToomas Soome *integer32 = (ficlUnsigned32)((dataTop--)->u);
769c0bb4f73SToomas Soome continue;
770afc2ba1dSToomas Soome }
771afc2ba1dSToomas Soome
772afc2ba1dSToomas Soome case ficlInstructionWFetch: {
773afc2ba1dSToomas Soome ficlUnsigned16 *integer16;
774afc2ba1dSToomas Soome CHECK_STACK(1, 1);
775afc2ba1dSToomas Soome integer16 = (ficlUnsigned16 *)dataTop->p;
776afc2ba1dSToomas Soome dataTop->u = ((ficlUnsigned)*integer16);
777c0bb4f73SToomas Soome continue;
778afc2ba1dSToomas Soome }
779afc2ba1dSToomas Soome
780afc2ba1dSToomas Soome case ficlInstructionWStore: {
781afc2ba1dSToomas Soome ficlUnsigned16 *integer16;
782afc2ba1dSToomas Soome CHECK_STACK(2, 0);
783afc2ba1dSToomas Soome integer16 = (ficlUnsigned16 *)(dataTop--)->p;
784afc2ba1dSToomas Soome *integer16 = (ficlUnsigned16)((dataTop--)->u);
785c0bb4f73SToomas Soome continue;
786afc2ba1dSToomas Soome }
787afc2ba1dSToomas Soome
788afc2ba1dSToomas Soome case ficlInstructionCFetch: {
789afc2ba1dSToomas Soome ficlUnsigned8 *integer8;
790afc2ba1dSToomas Soome CHECK_STACK(1, 1);
791afc2ba1dSToomas Soome integer8 = (ficlUnsigned8 *)dataTop->p;
792afc2ba1dSToomas Soome dataTop->u = ((ficlUnsigned)*integer8);
793c0bb4f73SToomas Soome continue;
794afc2ba1dSToomas Soome }
795afc2ba1dSToomas Soome
796afc2ba1dSToomas Soome case ficlInstructionCStore: {
797afc2ba1dSToomas Soome ficlUnsigned8 *integer8;
798afc2ba1dSToomas Soome CHECK_STACK(2, 0);
799afc2ba1dSToomas Soome integer8 = (ficlUnsigned8 *)(dataTop--)->p;
800afc2ba1dSToomas Soome *integer8 = (ficlUnsigned8)((dataTop--)->u);
801c0bb4f73SToomas Soome continue;
802afc2ba1dSToomas Soome }
803afc2ba1dSToomas Soome
804afc2ba1dSToomas Soome
805afc2ba1dSToomas Soome /*
806afc2ba1dSToomas Soome * l o g i c a n d c o m p a r i s o n s
807afc2ba1dSToomas Soome */
808afc2ba1dSToomas Soome
809afc2ba1dSToomas Soome case ficlInstruction0Equals:
810afc2ba1dSToomas Soome CHECK_STACK(1, 1);
811afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(dataTop->i == 0);
812c0bb4f73SToomas Soome continue;
813afc2ba1dSToomas Soome
814afc2ba1dSToomas Soome case ficlInstruction0Less:
815afc2ba1dSToomas Soome CHECK_STACK(1, 1);
816afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(dataTop->i < 0);
817c0bb4f73SToomas Soome continue;
818afc2ba1dSToomas Soome
819afc2ba1dSToomas Soome case ficlInstruction0Greater:
820afc2ba1dSToomas Soome CHECK_STACK(1, 1);
821afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(dataTop->i > 0);
822c0bb4f73SToomas Soome continue;
823afc2ba1dSToomas Soome
824afc2ba1dSToomas Soome case ficlInstructionEquals:
825afc2ba1dSToomas Soome CHECK_STACK(2, 1);
826afc2ba1dSToomas Soome i = (dataTop--)->i;
827afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(dataTop->i == i);
828c0bb4f73SToomas Soome continue;
829afc2ba1dSToomas Soome
830afc2ba1dSToomas Soome case ficlInstructionLess:
831afc2ba1dSToomas Soome CHECK_STACK(2, 1);
832afc2ba1dSToomas Soome i = (dataTop--)->i;
833afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(dataTop->i < i);
834c0bb4f73SToomas Soome continue;
835afc2ba1dSToomas Soome
836afc2ba1dSToomas Soome case ficlInstructionULess:
837afc2ba1dSToomas Soome CHECK_STACK(2, 1);
838afc2ba1dSToomas Soome u = (dataTop--)->u;
839afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(dataTop->u < u);
840c0bb4f73SToomas Soome continue;
841afc2ba1dSToomas Soome
842afc2ba1dSToomas Soome case ficlInstructionAnd:
843afc2ba1dSToomas Soome CHECK_STACK(2, 1);
844afc2ba1dSToomas Soome i = (dataTop--)->i;
845afc2ba1dSToomas Soome dataTop->i = dataTop->i & i;
846c0bb4f73SToomas Soome continue;
847afc2ba1dSToomas Soome
848afc2ba1dSToomas Soome case ficlInstructionOr:
849afc2ba1dSToomas Soome CHECK_STACK(2, 1);
850afc2ba1dSToomas Soome i = (dataTop--)->i;
851afc2ba1dSToomas Soome dataTop->i = dataTop->i | i;
852c0bb4f73SToomas Soome continue;
853afc2ba1dSToomas Soome
854afc2ba1dSToomas Soome case ficlInstructionXor:
855afc2ba1dSToomas Soome CHECK_STACK(2, 1);
856afc2ba1dSToomas Soome i = (dataTop--)->i;
857afc2ba1dSToomas Soome dataTop->i = dataTop->i ^ i;
858c0bb4f73SToomas Soome continue;
859afc2ba1dSToomas Soome
860afc2ba1dSToomas Soome case ficlInstructionInvert:
861afc2ba1dSToomas Soome CHECK_STACK(1, 1);
862afc2ba1dSToomas Soome dataTop->i = ~dataTop->i;
863c0bb4f73SToomas Soome continue;
864afc2ba1dSToomas Soome
865afc2ba1dSToomas Soome /*
866afc2ba1dSToomas Soome * r e t u r n s t a c k
867afc2ba1dSToomas Soome */
868afc2ba1dSToomas Soome case ficlInstructionToRStack:
869afc2ba1dSToomas Soome CHECK_STACK(1, 0);
870afc2ba1dSToomas Soome CHECK_RETURN_STACK(0, 1);
871afc2ba1dSToomas Soome *++returnTop = *dataTop--;
872c0bb4f73SToomas Soome continue;
873afc2ba1dSToomas Soome
874afc2ba1dSToomas Soome case ficlInstructionFromRStack:
875afc2ba1dSToomas Soome CHECK_STACK(0, 1);
876afc2ba1dSToomas Soome CHECK_RETURN_STACK(1, 0);
877afc2ba1dSToomas Soome *++dataTop = *returnTop--;
878c0bb4f73SToomas Soome continue;
879afc2ba1dSToomas Soome
880afc2ba1dSToomas Soome case ficlInstructionFetchRStack:
881afc2ba1dSToomas Soome CHECK_STACK(0, 1);
882afc2ba1dSToomas Soome CHECK_RETURN_STACK(1, 1);
883afc2ba1dSToomas Soome *++dataTop = *returnTop;
884c0bb4f73SToomas Soome continue;
885afc2ba1dSToomas Soome
886afc2ba1dSToomas Soome case ficlInstruction2ToR:
887afc2ba1dSToomas Soome CHECK_STACK(2, 0);
888afc2ba1dSToomas Soome CHECK_RETURN_STACK(0, 2);
889afc2ba1dSToomas Soome *++returnTop = dataTop[-1];
890afc2ba1dSToomas Soome *++returnTop = dataTop[0];
891afc2ba1dSToomas Soome dataTop -= 2;
892c0bb4f73SToomas Soome continue;
893afc2ba1dSToomas Soome
894afc2ba1dSToomas Soome case ficlInstruction2RFrom:
895afc2ba1dSToomas Soome CHECK_STACK(0, 2);
896afc2ba1dSToomas Soome CHECK_RETURN_STACK(2, 0);
897afc2ba1dSToomas Soome *++dataTop = returnTop[-1];
898afc2ba1dSToomas Soome *++dataTop = returnTop[0];
899afc2ba1dSToomas Soome returnTop -= 2;
900c0bb4f73SToomas Soome continue;
901afc2ba1dSToomas Soome
902afc2ba1dSToomas Soome case ficlInstruction2RFetch:
903afc2ba1dSToomas Soome CHECK_STACK(0, 2);
904afc2ba1dSToomas Soome CHECK_RETURN_STACK(2, 2);
905afc2ba1dSToomas Soome *++dataTop = returnTop[-1];
906afc2ba1dSToomas Soome *++dataTop = returnTop[0];
907c0bb4f73SToomas Soome continue;
908afc2ba1dSToomas Soome
909afc2ba1dSToomas Soome /*
910afc2ba1dSToomas Soome * f i l l
911afc2ba1dSToomas Soome * CORE ( c-addr u char -- )
912afc2ba1dSToomas Soome * If u is greater than zero, store char in each of u
913afc2ba1dSToomas Soome * consecutive characters of memory beginning at c-addr.
914afc2ba1dSToomas Soome */
915afc2ba1dSToomas Soome case ficlInstructionFill: {
916afc2ba1dSToomas Soome char c;
917afc2ba1dSToomas Soome char *memory;
918afc2ba1dSToomas Soome CHECK_STACK(3, 0);
919afc2ba1dSToomas Soome c = (char)(dataTop--)->i;
920afc2ba1dSToomas Soome u = (dataTop--)->u;
921afc2ba1dSToomas Soome memory = (char *)(dataTop--)->p;
922afc2ba1dSToomas Soome
923afc2ba1dSToomas Soome /*
924afc2ba1dSToomas Soome * memset() is faster than the previous hand-rolled
925afc2ba1dSToomas Soome * solution. --lch
926afc2ba1dSToomas Soome */
927afc2ba1dSToomas Soome memset(memory, c, u);
928c0bb4f73SToomas Soome continue;
929afc2ba1dSToomas Soome }
930afc2ba1dSToomas Soome
931afc2ba1dSToomas Soome /*
932afc2ba1dSToomas Soome * l s h i f t
933afc2ba1dSToomas Soome * l-shift CORE ( x1 u -- x2 )
934afc2ba1dSToomas Soome * Perform a logical left shift of u bit-places on x1,
935afc2ba1dSToomas Soome * giving x2. Put zeroes into the least significant bits
936afc2ba1dSToomas Soome * vacated by the shift. An ambiguous condition exists if
937afc2ba1dSToomas Soome * u is greater than or equal to the number of bits in a
938afc2ba1dSToomas Soome * ficlCell.
939afc2ba1dSToomas Soome *
940afc2ba1dSToomas Soome * r-shift CORE ( x1 u -- x2 )
941afc2ba1dSToomas Soome * Perform a logical right shift of u bit-places on x1,
942afc2ba1dSToomas Soome * giving x2. Put zeroes into the most significant bits
943afc2ba1dSToomas Soome * vacated by the shift. An ambiguous condition exists
944afc2ba1dSToomas Soome * if u is greater than or equal to the number of bits
945afc2ba1dSToomas Soome * in a ficlCell.
946afc2ba1dSToomas Soome */
947afc2ba1dSToomas Soome case ficlInstructionLShift: {
948afc2ba1dSToomas Soome ficlUnsigned nBits;
949afc2ba1dSToomas Soome ficlUnsigned x1;
950afc2ba1dSToomas Soome CHECK_STACK(2, 1);
951afc2ba1dSToomas Soome
952afc2ba1dSToomas Soome nBits = (dataTop--)->u;
953afc2ba1dSToomas Soome x1 = dataTop->u;
954afc2ba1dSToomas Soome dataTop->u = x1 << nBits;
955c0bb4f73SToomas Soome continue;
956afc2ba1dSToomas Soome }
957afc2ba1dSToomas Soome
958afc2ba1dSToomas Soome case ficlInstructionRShift: {
959afc2ba1dSToomas Soome ficlUnsigned nBits;
960afc2ba1dSToomas Soome ficlUnsigned x1;
961afc2ba1dSToomas Soome CHECK_STACK(2, 1);
962afc2ba1dSToomas Soome
963afc2ba1dSToomas Soome nBits = (dataTop--)->u;
964afc2ba1dSToomas Soome x1 = dataTop->u;
965afc2ba1dSToomas Soome dataTop->u = x1 >> nBits;
966afc2ba1dSToomas Soome continue;
967afc2ba1dSToomas Soome }
968afc2ba1dSToomas Soome
969afc2ba1dSToomas Soome /*
970afc2ba1dSToomas Soome * m a x & m i n
971afc2ba1dSToomas Soome */
972afc2ba1dSToomas Soome case ficlInstructionMax: {
973afc2ba1dSToomas Soome ficlInteger n2;
974afc2ba1dSToomas Soome ficlInteger n1;
975afc2ba1dSToomas Soome CHECK_STACK(2, 1);
976afc2ba1dSToomas Soome
977afc2ba1dSToomas Soome n2 = (dataTop--)->i;
978afc2ba1dSToomas Soome n1 = dataTop->i;
979afc2ba1dSToomas Soome
980afc2ba1dSToomas Soome dataTop->i = ((n1 > n2) ? n1 : n2);
981c0bb4f73SToomas Soome continue;
982afc2ba1dSToomas Soome }
983afc2ba1dSToomas Soome
984afc2ba1dSToomas Soome case ficlInstructionMin: {
985afc2ba1dSToomas Soome ficlInteger n2;
986afc2ba1dSToomas Soome ficlInteger n1;
987afc2ba1dSToomas Soome CHECK_STACK(2, 1);
988afc2ba1dSToomas Soome
989afc2ba1dSToomas Soome n2 = (dataTop--)->i;
990c0bb4f73SToomas Soome n1 = dataTop->i;
991afc2ba1dSToomas Soome
992afc2ba1dSToomas Soome dataTop->i = ((n1 < n2) ? n1 : n2);
993afc2ba1dSToomas Soome continue;
994afc2ba1dSToomas Soome }
995afc2ba1dSToomas Soome
996afc2ba1dSToomas Soome /*
997afc2ba1dSToomas Soome * m o v e
998afc2ba1dSToomas Soome * CORE ( addr1 addr2 u -- )
999afc2ba1dSToomas Soome * If u is greater than zero, copy the contents of u
1000afc2ba1dSToomas Soome * consecutive address units at addr1 to the u consecutive
1001afc2ba1dSToomas Soome * address units at addr2. After MOVE completes, the u
1002afc2ba1dSToomas Soome * consecutive address units at addr2 contain exactly
1003afc2ba1dSToomas Soome * what the u consecutive address units at addr1 contained
1004afc2ba1dSToomas Soome * before the move.
1005afc2ba1dSToomas Soome * NOTE! This implementation assumes that a char is the same
1006afc2ba1dSToomas Soome * size as an address unit.
1007afc2ba1dSToomas Soome */
1008afc2ba1dSToomas Soome case ficlInstructionMove: {
1009afc2ba1dSToomas Soome ficlUnsigned u;
1010afc2ba1dSToomas Soome char *addr2;
1011afc2ba1dSToomas Soome char *addr1;
1012afc2ba1dSToomas Soome CHECK_STACK(3, 0);
1013afc2ba1dSToomas Soome
1014afc2ba1dSToomas Soome u = (dataTop--)->u;
1015afc2ba1dSToomas Soome addr2 = (dataTop--)->p;
1016afc2ba1dSToomas Soome addr1 = (dataTop--)->p;
1017afc2ba1dSToomas Soome
1018afc2ba1dSToomas Soome if (u == 0)
1019afc2ba1dSToomas Soome continue;
1020afc2ba1dSToomas Soome /*
1021afc2ba1dSToomas Soome * Do the copy carefully, so as to be
1022afc2ba1dSToomas Soome * correct even if the two ranges overlap
1023afc2ba1dSToomas Soome */
1024afc2ba1dSToomas Soome /* Which ANSI C's memmove() does for you! Yay! --lch */
1025afc2ba1dSToomas Soome memmove(addr2, addr1, u);
1026c0bb4f73SToomas Soome continue;
1027afc2ba1dSToomas Soome }
1028afc2ba1dSToomas Soome
1029afc2ba1dSToomas Soome /*
1030afc2ba1dSToomas Soome * s t o d
1031afc2ba1dSToomas Soome * s-to-d CORE ( n -- d )
1032afc2ba1dSToomas Soome * Convert the number n to the double-ficlCell number d with
1033afc2ba1dSToomas Soome * the same numerical value.
1034afc2ba1dSToomas Soome */
1035afc2ba1dSToomas Soome case ficlInstructionSToD: {
1036afc2ba1dSToomas Soome ficlInteger s;
1037afc2ba1dSToomas Soome CHECK_STACK(1, 2);
1038afc2ba1dSToomas Soome
1039afc2ba1dSToomas Soome s = dataTop->i;
1040afc2ba1dSToomas Soome
1041afc2ba1dSToomas Soome /* sign extend to 64 bits.. */
1042afc2ba1dSToomas Soome (++dataTop)->i = (s < 0) ? -1 : 0;
1043c0bb4f73SToomas Soome continue;
1044afc2ba1dSToomas Soome }
1045afc2ba1dSToomas Soome
1046afc2ba1dSToomas Soome /*
1047afc2ba1dSToomas Soome * c o m p a r e
1048afc2ba1dSToomas Soome * STRING ( c-addr1 u1 c-addr2 u2 -- n )
1049afc2ba1dSToomas Soome * Compare the string specified by c-addr1 u1 to the string
1050afc2ba1dSToomas Soome * specified by c-addr2 u2. The strings are compared, beginning
1051afc2ba1dSToomas Soome * at the given addresses, character by character, up to the
1052afc2ba1dSToomas Soome * length of the shorter string or until a difference is found.
1053afc2ba1dSToomas Soome * If the two strings are identical, n is zero. If the two
1054afc2ba1dSToomas Soome * strings are identical up to the length of the shorter string,
1055afc2ba1dSToomas Soome * n is minus-one (-1) if u1 is less than u2 and one (1)
1056afc2ba1dSToomas Soome * otherwise. If the two strings are not identical up to the
1057afc2ba1dSToomas Soome * length of the shorter string, n is minus-one (-1) if the
1058afc2ba1dSToomas Soome * first non-matching character in the string specified by
1059afc2ba1dSToomas Soome * c-addr1 u1 has a lesser numeric value than the corresponding
1060afc2ba1dSToomas Soome * character in the string specified by c-addr2 u2 and
1061afc2ba1dSToomas Soome * one (1) otherwise.
1062afc2ba1dSToomas Soome */
1063afc2ba1dSToomas Soome case ficlInstructionCompare:
1064afc2ba1dSToomas Soome i = FICL_FALSE;
1065afc2ba1dSToomas Soome goto COMPARE;
1066afc2ba1dSToomas Soome
1067afc2ba1dSToomas Soome
1068afc2ba1dSToomas Soome case ficlInstructionCompareInsensitive:
1069afc2ba1dSToomas Soome i = FICL_TRUE;
1070afc2ba1dSToomas Soome goto COMPARE;
1071afc2ba1dSToomas Soome
1072afc2ba1dSToomas Soome COMPARE:
1073afc2ba1dSToomas Soome {
1074afc2ba1dSToomas Soome char *cp1, *cp2;
1075afc2ba1dSToomas Soome ficlUnsigned u1, u2, uMin;
1076afc2ba1dSToomas Soome int n = 0;
1077afc2ba1dSToomas Soome
1078afc2ba1dSToomas Soome CHECK_STACK(4, 1);
1079afc2ba1dSToomas Soome u2 = (dataTop--)->u;
1080afc2ba1dSToomas Soome cp2 = (char *)(dataTop--)->p;
1081afc2ba1dSToomas Soome u1 = (dataTop--)->u;
1082afc2ba1dSToomas Soome cp1 = (char *)(dataTop--)->p;
1083afc2ba1dSToomas Soome
1084afc2ba1dSToomas Soome uMin = (u1 < u2)? u1 : u2;
1085afc2ba1dSToomas Soome for (; (uMin > 0) && (n == 0); uMin--) {
1086afc2ba1dSToomas Soome int c1 = (unsigned char)*cp1++;
1087afc2ba1dSToomas Soome int c2 = (unsigned char)*cp2++;
1088afc2ba1dSToomas Soome
1089afc2ba1dSToomas Soome if (i) {
1090afc2ba1dSToomas Soome c1 = tolower(c1);
1091afc2ba1dSToomas Soome c2 = tolower(c2);
1092afc2ba1dSToomas Soome }
1093afc2ba1dSToomas Soome n = (c1 - c2);
1094afc2ba1dSToomas Soome }
1095afc2ba1dSToomas Soome
1096afc2ba1dSToomas Soome if (n == 0)
1097afc2ba1dSToomas Soome n = (int)(u1 - u2);
1098afc2ba1dSToomas Soome
1099afc2ba1dSToomas Soome if (n < 0)
1100afc2ba1dSToomas Soome n = -1;
1101afc2ba1dSToomas Soome else if (n > 0)
1102afc2ba1dSToomas Soome n = 1;
1103afc2ba1dSToomas Soome
1104afc2ba1dSToomas Soome (++dataTop)->i = n;
1105c0bb4f73SToomas Soome continue;
1106afc2ba1dSToomas Soome }
1107afc2ba1dSToomas Soome
1108afc2ba1dSToomas Soome /*
1109afc2ba1dSToomas Soome * r a n d o m
1110afc2ba1dSToomas Soome * Ficl-specific
1111afc2ba1dSToomas Soome */
1112afc2ba1dSToomas Soome case ficlInstructionRandom:
1113afc2ba1dSToomas Soome (++dataTop)->i = random();
1114afc2ba1dSToomas Soome continue;
1115afc2ba1dSToomas Soome
1116afc2ba1dSToomas Soome /*
1117afc2ba1dSToomas Soome * s e e d - r a n d o m
1118afc2ba1dSToomas Soome * Ficl-specific
1119afc2ba1dSToomas Soome */
1120afc2ba1dSToomas Soome case ficlInstructionSeedRandom:
1121afc2ba1dSToomas Soome srandom((dataTop--)->i);
1122afc2ba1dSToomas Soome continue;
1123afc2ba1dSToomas Soome
1124afc2ba1dSToomas Soome case ficlInstructionGreaterThan: {
1125afc2ba1dSToomas Soome ficlInteger x, y;
1126afc2ba1dSToomas Soome CHECK_STACK(2, 1);
1127afc2ba1dSToomas Soome y = (dataTop--)->i;
1128afc2ba1dSToomas Soome x = dataTop->i;
1129afc2ba1dSToomas Soome dataTop->i = FICL_BOOL(x > y);
1130c0bb4f73SToomas Soome continue;
1131c0bb4f73SToomas Soome }
1132152e3753SToomas Soome
1133152e3753SToomas Soome case ficlInstructionUGreaterThan:
1134152e3753SToomas Soome CHECK_STACK(2, 1);
1135152e3753SToomas Soome u = (dataTop--)->u;
1136152e3753SToomas Soome dataTop->i = FICL_BOOL(dataTop->u > u);
1137c0bb4f73SToomas Soome continue;
1138afc2ba1dSToomas Soome
1139afc2ba1dSToomas Soome /*
1140afc2ba1dSToomas Soome * This function simply pops the previous instruction
1141afc2ba1dSToomas Soome * pointer and returns to the "next" loop. Used for exiting
1142afc2ba1dSToomas Soome * from within a definition. Note that exitParen is identical
1143afc2ba1dSToomas Soome * to semiParen - they are in two different functions so that
1144afc2ba1dSToomas Soome * "see" can correctly identify the end of a colon definition,
1145afc2ba1dSToomas Soome * even if it uses "exit".
1146afc2ba1dSToomas Soome */
1147afc2ba1dSToomas Soome case ficlInstructionExitParen:
1148afc2ba1dSToomas Soome case ficlInstructionSemiParen:
1149afc2ba1dSToomas Soome EXIT_FUNCTION();
1150afc2ba1dSToomas Soome
1151afc2ba1dSToomas Soome /*
1152afc2ba1dSToomas Soome * The first time we run "(branch)", perform a "peephole
1153afc2ba1dSToomas Soome * optimization" to see if we're jumping to another
1154afc2ba1dSToomas Soome * unconditional jump. If so, just jump directly there.
1155afc2ba1dSToomas Soome */
1156afc2ba1dSToomas Soome case ficlInstructionBranchParenWithCheck:
1157afc2ba1dSToomas Soome LOCAL_VARIABLE_SPILL;
1158afc2ba1dSToomas Soome ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
1159afc2ba1dSToomas Soome LOCAL_VARIABLE_REFILL;
1160afc2ba1dSToomas Soome goto BRANCH_PAREN;
1161afc2ba1dSToomas Soome
1162afc2ba1dSToomas Soome /*
1163afc2ba1dSToomas Soome * Same deal with branch0.
1164afc2ba1dSToomas Soome */
1165afc2ba1dSToomas Soome case ficlInstructionBranch0ParenWithCheck:
1166afc2ba1dSToomas Soome LOCAL_VARIABLE_SPILL;
1167afc2ba1dSToomas Soome ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
1168afc2ba1dSToomas Soome LOCAL_VARIABLE_REFILL;
1169afc2ba1dSToomas Soome /* intentional fall-through */
1170afc2ba1dSToomas Soome
1171afc2ba1dSToomas Soome /*
1172afc2ba1dSToomas Soome * Runtime code for "(branch0)"; pop a flag from the stack,
1173afc2ba1dSToomas Soome * branch if 0. fall through otherwise.
1174afc2ba1dSToomas Soome * The heart of "if" and "until".
1175afc2ba1dSToomas Soome */
1176afc2ba1dSToomas Soome case ficlInstructionBranch0Paren:
1177afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1178afc2ba1dSToomas Soome
1179afc2ba1dSToomas Soome if ((dataTop--)->i) {
1180afc2ba1dSToomas Soome /*
1181afc2ba1dSToomas Soome * don't branch, but skip over branch
1182afc2ba1dSToomas Soome * relative address
1183afc2ba1dSToomas Soome */
1184afc2ba1dSToomas Soome ip += 1;
1185afc2ba1dSToomas Soome continue;
1186afc2ba1dSToomas Soome }
1187afc2ba1dSToomas Soome /* otherwise, take branch (to else/endif/begin) */
1188afc2ba1dSToomas Soome /* intentional fall-through! */
1189afc2ba1dSToomas Soome
1190afc2ba1dSToomas Soome /*
1191afc2ba1dSToomas Soome * Runtime for "(branch)" -- expects a literal offset in the
1192afc2ba1dSToomas Soome * next compilation address, and branches to that location.
1193afc2ba1dSToomas Soome */
1194afc2ba1dSToomas Soome case ficlInstructionBranchParen:
1195afc2ba1dSToomas Soome BRANCH_PAREN:
1196afc2ba1dSToomas Soome BRANCH();
1197afc2ba1dSToomas Soome
1198afc2ba1dSToomas Soome case ficlInstructionOfParen: {
1199afc2ba1dSToomas Soome ficlUnsigned a, b;
1200afc2ba1dSToomas Soome
1201afc2ba1dSToomas Soome CHECK_STACK(2, 1);
1202afc2ba1dSToomas Soome
1203afc2ba1dSToomas Soome a = (dataTop--)->u;
1204afc2ba1dSToomas Soome b = dataTop->u;
1205afc2ba1dSToomas Soome
1206afc2ba1dSToomas Soome if (a == b) {
1207afc2ba1dSToomas Soome /* fall through */
1208afc2ba1dSToomas Soome ip++;
1209afc2ba1dSToomas Soome /* remove CASE argument */
1210afc2ba1dSToomas Soome dataTop--;
1211afc2ba1dSToomas Soome } else {
1212afc2ba1dSToomas Soome /* take branch to next of or endcase */
1213afc2ba1dSToomas Soome BRANCH();
1214afc2ba1dSToomas Soome }
1215afc2ba1dSToomas Soome
1216c0bb4f73SToomas Soome continue;
1217afc2ba1dSToomas Soome }
1218afc2ba1dSToomas Soome
1219afc2ba1dSToomas Soome case ficlInstructionDoParen: {
1220afc2ba1dSToomas Soome ficlCell index, limit;
1221afc2ba1dSToomas Soome
1222afc2ba1dSToomas Soome CHECK_STACK(2, 0);
1223afc2ba1dSToomas Soome
1224afc2ba1dSToomas Soome index = *dataTop--;
1225afc2ba1dSToomas Soome limit = *dataTop--;
1226afc2ba1dSToomas Soome
1227afc2ba1dSToomas Soome /* copy "leave" target addr to stack */
1228afc2ba1dSToomas Soome (++returnTop)->i = *(ip++);
1229afc2ba1dSToomas Soome *++returnTop = limit;
1230afc2ba1dSToomas Soome *++returnTop = index;
1231afc2ba1dSToomas Soome
1232c0bb4f73SToomas Soome continue;
1233afc2ba1dSToomas Soome }
1234afc2ba1dSToomas Soome
1235afc2ba1dSToomas Soome case ficlInstructionQDoParen: {
1236afc2ba1dSToomas Soome ficlCell index, limit, leave;
1237afc2ba1dSToomas Soome
1238afc2ba1dSToomas Soome CHECK_STACK(2, 0);
1239afc2ba1dSToomas Soome
1240afc2ba1dSToomas Soome index = *dataTop--;
1241afc2ba1dSToomas Soome limit = *dataTop--;
1242afc2ba1dSToomas Soome
1243afc2ba1dSToomas Soome leave.i = *ip;
1244afc2ba1dSToomas Soome
1245afc2ba1dSToomas Soome if (limit.u == index.u) {
1246afc2ba1dSToomas Soome ip = leave.p;
1247afc2ba1dSToomas Soome } else {
1248afc2ba1dSToomas Soome ip++;
1249afc2ba1dSToomas Soome *++returnTop = leave;
1250afc2ba1dSToomas Soome *++returnTop = limit;
1251afc2ba1dSToomas Soome *++returnTop = index;
1252afc2ba1dSToomas Soome }
1253afc2ba1dSToomas Soome
1254c0bb4f73SToomas Soome continue;
1255afc2ba1dSToomas Soome }
1256afc2ba1dSToomas Soome
1257afc2ba1dSToomas Soome case ficlInstructionLoopParen:
1258afc2ba1dSToomas Soome case ficlInstructionPlusLoopParen: {
1259afc2ba1dSToomas Soome ficlInteger index;
1260afc2ba1dSToomas Soome ficlInteger limit;
1261afc2ba1dSToomas Soome int direction = 0;
1262afc2ba1dSToomas Soome
1263afc2ba1dSToomas Soome index = returnTop->i;
1264afc2ba1dSToomas Soome limit = returnTop[-1].i;
1265afc2ba1dSToomas Soome
1266afc2ba1dSToomas Soome if (instruction == ficlInstructionLoopParen)
1267afc2ba1dSToomas Soome index++;
1268afc2ba1dSToomas Soome else {
1269afc2ba1dSToomas Soome ficlInteger increment;
1270afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1271afc2ba1dSToomas Soome increment = (dataTop--)->i;
1272afc2ba1dSToomas Soome index += increment;
1273afc2ba1dSToomas Soome direction = (increment < 0);
1274afc2ba1dSToomas Soome }
1275afc2ba1dSToomas Soome
1276afc2ba1dSToomas Soome if (direction ^ (index >= limit)) {
1277afc2ba1dSToomas Soome /* nuke the loop indices & "leave" addr */
1278afc2ba1dSToomas Soome returnTop -= 3;
1279afc2ba1dSToomas Soome ip++; /* fall through the loop */
1280afc2ba1dSToomas Soome } else { /* update index, branch to loop head */
1281afc2ba1dSToomas Soome returnTop->i = index;
1282afc2ba1dSToomas Soome BRANCH();
1283afc2ba1dSToomas Soome }
1284afc2ba1dSToomas Soome
1285c0bb4f73SToomas Soome continue;
1286afc2ba1dSToomas Soome }
1287afc2ba1dSToomas Soome
1288afc2ba1dSToomas Soome
1289afc2ba1dSToomas Soome /*
1290afc2ba1dSToomas Soome * Runtime code to break out of a do..loop construct
1291afc2ba1dSToomas Soome * Drop the loop control variables; the branch address
1292afc2ba1dSToomas Soome * past "loop" is next on the return stack.
1293afc2ba1dSToomas Soome */
1294afc2ba1dSToomas Soome case ficlInstructionLeave:
1295afc2ba1dSToomas Soome /* almost unloop */
1296afc2ba1dSToomas Soome returnTop -= 2;
1297afc2ba1dSToomas Soome /* exit */
1298afc2ba1dSToomas Soome EXIT_FUNCTION();
1299afc2ba1dSToomas Soome
1300afc2ba1dSToomas Soome case ficlInstructionUnloop:
1301afc2ba1dSToomas Soome returnTop -= 3;
1302c0bb4f73SToomas Soome continue;
1303afc2ba1dSToomas Soome
1304afc2ba1dSToomas Soome case ficlInstructionI:
1305afc2ba1dSToomas Soome *++dataTop = *returnTop;
1306c0bb4f73SToomas Soome continue;
1307afc2ba1dSToomas Soome
1308afc2ba1dSToomas Soome case ficlInstructionJ:
1309afc2ba1dSToomas Soome *++dataTop = returnTop[-3];
1310c0bb4f73SToomas Soome continue;
1311afc2ba1dSToomas Soome
1312afc2ba1dSToomas Soome case ficlInstructionK:
1313afc2ba1dSToomas Soome *++dataTop = returnTop[-6];
1314c0bb4f73SToomas Soome continue;
1315afc2ba1dSToomas Soome
1316afc2ba1dSToomas Soome case ficlInstructionDoesParen: {
1317afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1318afc2ba1dSToomas Soome dictionary->smudge->code =
1319afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionDoDoes;
1320afc2ba1dSToomas Soome dictionary->smudge->param[0].p = ip;
1321afc2ba1dSToomas Soome ip = (ficlInstruction *)((returnTop--)->p);
1322c0bb4f73SToomas Soome continue;
1323afc2ba1dSToomas Soome }
1324afc2ba1dSToomas Soome
1325afc2ba1dSToomas Soome case ficlInstructionDoDoes: {
1326afc2ba1dSToomas Soome ficlCell *cell;
1327afc2ba1dSToomas Soome ficlIp tempIP;
1328afc2ba1dSToomas Soome
1329afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1330afc2ba1dSToomas Soome
1331afc2ba1dSToomas Soome cell = fw->param;
1332afc2ba1dSToomas Soome tempIP = (ficlIp)((*cell).p);
1333afc2ba1dSToomas Soome (++dataTop)->p = (cell + 1);
1334afc2ba1dSToomas Soome (++returnTop)->p = (void *)ip;
1335afc2ba1dSToomas Soome ip = (ficlInstruction *)tempIP;
1336c0bb4f73SToomas Soome continue;
1337afc2ba1dSToomas Soome }
1338afc2ba1dSToomas Soome
1339afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
1340afc2ba1dSToomas Soome case ficlInstructionF2Fetch:
1341afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 2);
1342afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1343afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
1344afc2ba1dSToomas Soome
1345afc2ba1dSToomas Soome case ficlInstructionFFetch:
1346afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1347afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1348afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER((dataTop--)->p);
1349afc2ba1dSToomas Soome
1350afc2ba1dSToomas Soome case ficlInstructionF2Store:
1351afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 0);
1352afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1353afc2ba1dSToomas Soome FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p);
1354afc2ba1dSToomas Soome
1355afc2ba1dSToomas Soome case ficlInstructionFStore:
1356afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1357afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1358afc2ba1dSToomas Soome FLOAT_POP_CELL_POINTER((dataTop--)->p);
1359afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
1360afc2ba1dSToomas Soome
1361afc2ba1dSToomas Soome /*
1362afc2ba1dSToomas Soome * two-fetch CORE ( a-addr -- x1 x2 )
1363afc2ba1dSToomas Soome *
1364afc2ba1dSToomas Soome * Fetch the ficlCell pair x1 x2 stored at a-addr.
1365afc2ba1dSToomas Soome * x2 is stored at a-addr and x1 at the next consecutive
1366afc2ba1dSToomas Soome * ficlCell. It is equivalent to the sequence
1367afc2ba1dSToomas Soome * DUP ficlCell+ @ SWAP @ .
1368afc2ba1dSToomas Soome */
1369afc2ba1dSToomas Soome case ficlInstruction2Fetch:
1370afc2ba1dSToomas Soome CHECK_STACK(1, 2);
1371afc2ba1dSToomas Soome PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
1372afc2ba1dSToomas Soome
1373afc2ba1dSToomas Soome /*
1374afc2ba1dSToomas Soome * fetch CORE ( a-addr -- x )
1375afc2ba1dSToomas Soome *
1376afc2ba1dSToomas Soome * x is the value stored at a-addr.
1377afc2ba1dSToomas Soome */
1378afc2ba1dSToomas Soome case ficlInstructionFetch:
1379afc2ba1dSToomas Soome CHECK_STACK(1, 1);
1380afc2ba1dSToomas Soome PUSH_CELL_POINTER((dataTop--)->p);
1381afc2ba1dSToomas Soome
1382afc2ba1dSToomas Soome /*
1383afc2ba1dSToomas Soome * two-store CORE ( x1 x2 a-addr -- )
1384afc2ba1dSToomas Soome * Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr
1385afc2ba1dSToomas Soome * and x1 at the next consecutive ficlCell. It is equivalent
1386afc2ba1dSToomas Soome * to the sequence SWAP OVER ! ficlCell+ !
1387afc2ba1dSToomas Soome */
1388afc2ba1dSToomas Soome case ficlInstruction2Store:
1389afc2ba1dSToomas Soome CHECK_STACK(3, 0);
1390afc2ba1dSToomas Soome POP_CELL_POINTER_DOUBLE((dataTop--)->p);
1391afc2ba1dSToomas Soome
1392afc2ba1dSToomas Soome /*
1393afc2ba1dSToomas Soome * store CORE ( x a-addr -- )
1394afc2ba1dSToomas Soome * Store x at a-addr.
1395afc2ba1dSToomas Soome */
1396afc2ba1dSToomas Soome case ficlInstructionStore:
1397afc2ba1dSToomas Soome CHECK_STACK(2, 0);
1398afc2ba1dSToomas Soome POP_CELL_POINTER((dataTop--)->p);
1399afc2ba1dSToomas Soome
1400afc2ba1dSToomas Soome case ficlInstructionComma: {
1401afc2ba1dSToomas Soome ficlDictionary *dictionary;
1402afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1403afc2ba1dSToomas Soome
1404afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
1405afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, *dataTop--);
1406c0bb4f73SToomas Soome continue;
1407afc2ba1dSToomas Soome }
1408afc2ba1dSToomas Soome
1409afc2ba1dSToomas Soome case ficlInstructionCComma: {
1410afc2ba1dSToomas Soome ficlDictionary *dictionary;
1411afc2ba1dSToomas Soome char c;
1412afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1413afc2ba1dSToomas Soome
1414afc2ba1dSToomas Soome dictionary = ficlVmGetDictionary(vm);
1415afc2ba1dSToomas Soome c = (char)(dataTop--)->i;
1416afc2ba1dSToomas Soome ficlDictionaryAppendCharacter(dictionary, c);
1417c0bb4f73SToomas Soome continue;
1418afc2ba1dSToomas Soome }
1419afc2ba1dSToomas Soome
1420afc2ba1dSToomas Soome case ficlInstructionCells:
1421afc2ba1dSToomas Soome CHECK_STACK(1, 1);
1422afc2ba1dSToomas Soome dataTop->i *= sizeof (ficlCell);
1423c0bb4f73SToomas Soome continue;
1424afc2ba1dSToomas Soome
1425afc2ba1dSToomas Soome case ficlInstructionCellPlus:
1426afc2ba1dSToomas Soome CHECK_STACK(1, 1);
1427afc2ba1dSToomas Soome dataTop->i += sizeof (ficlCell);
1428c0bb4f73SToomas Soome continue;
1429afc2ba1dSToomas Soome
1430afc2ba1dSToomas Soome case ficlInstructionStar:
1431afc2ba1dSToomas Soome CHECK_STACK(2, 1);
1432afc2ba1dSToomas Soome i = (dataTop--)->i;
1433afc2ba1dSToomas Soome dataTop->i *= i;
1434c0bb4f73SToomas Soome continue;
1435afc2ba1dSToomas Soome
1436afc2ba1dSToomas Soome case ficlInstructionNegate:
1437afc2ba1dSToomas Soome CHECK_STACK(1, 1);
1438afc2ba1dSToomas Soome dataTop->i = - dataTop->i;
1439c0bb4f73SToomas Soome continue;
1440afc2ba1dSToomas Soome
1441afc2ba1dSToomas Soome case ficlInstructionSlash:
1442afc2ba1dSToomas Soome CHECK_STACK(2, 1);
1443afc2ba1dSToomas Soome i = (dataTop--)->i;
1444afc2ba1dSToomas Soome dataTop->i /= i;
1445c0bb4f73SToomas Soome continue;
1446afc2ba1dSToomas Soome
1447afc2ba1dSToomas Soome /*
1448afc2ba1dSToomas Soome * slash-mod CORE ( n1 n2 -- n3 n4 )
1449afc2ba1dSToomas Soome * Divide n1 by n2, giving the single-ficlCell remainder n3
1450afc2ba1dSToomas Soome * and the single-ficlCell quotient n4. An ambiguous condition
1451afc2ba1dSToomas Soome * exists if n2 is zero. If n1 and n2 differ in sign, the
1452afc2ba1dSToomas Soome * implementation-defined result returned will be the
1453afc2ba1dSToomas Soome * same as that returned by either the phrase
1454afc2ba1dSToomas Soome * >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM.
1455afc2ba1dSToomas Soome * NOTE: Ficl complies with the second phrase
1456afc2ba1dSToomas Soome * (symmetric division)
1457afc2ba1dSToomas Soome */
1458afc2ba1dSToomas Soome case ficlInstructionSlashMod: {
1459afc2ba1dSToomas Soome ficl2Integer n1;
1460afc2ba1dSToomas Soome ficlInteger n2;
1461afc2ba1dSToomas Soome ficl2IntegerQR qr;
1462afc2ba1dSToomas Soome
1463afc2ba1dSToomas Soome CHECK_STACK(2, 2);
1464afc2ba1dSToomas Soome n2 = dataTop[0].i;
1465afc2ba1dSToomas Soome FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1);
1466afc2ba1dSToomas Soome
1467afc2ba1dSToomas Soome qr = ficl2IntegerDivideSymmetric(n1, n2);
1468afc2ba1dSToomas Soome dataTop[-1].i = qr.remainder;
1469afc2ba1dSToomas Soome dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
1470c0bb4f73SToomas Soome continue;
1471afc2ba1dSToomas Soome }
1472afc2ba1dSToomas Soome
1473afc2ba1dSToomas Soome case ficlInstruction2Star:
1474afc2ba1dSToomas Soome CHECK_STACK(1, 1);
1475afc2ba1dSToomas Soome dataTop->i <<= 1;
1476c0bb4f73SToomas Soome continue;
1477afc2ba1dSToomas Soome
1478afc2ba1dSToomas Soome case ficlInstruction2Slash:
1479afc2ba1dSToomas Soome CHECK_STACK(1, 1);
1480afc2ba1dSToomas Soome dataTop->i >>= 1;
1481c0bb4f73SToomas Soome continue;
1482afc2ba1dSToomas Soome
1483afc2ba1dSToomas Soome case ficlInstructionStarSlash: {
1484afc2ba1dSToomas Soome ficlInteger x, y, z;
1485afc2ba1dSToomas Soome ficl2Integer prod;
1486afc2ba1dSToomas Soome CHECK_STACK(3, 1);
1487afc2ba1dSToomas Soome
1488afc2ba1dSToomas Soome z = (dataTop--)->i;
1489afc2ba1dSToomas Soome y = (dataTop--)->i;
1490afc2ba1dSToomas Soome x = dataTop->i;
1491afc2ba1dSToomas Soome
1492afc2ba1dSToomas Soome prod = ficl2IntegerMultiply(x, y);
1493afc2ba1dSToomas Soome dataTop->i = FICL_2UNSIGNED_GET_LOW(
1494afc2ba1dSToomas Soome ficl2IntegerDivideSymmetric(prod, z).quotient);
1495c0bb4f73SToomas Soome continue;
1496afc2ba1dSToomas Soome }
1497afc2ba1dSToomas Soome
1498afc2ba1dSToomas Soome case ficlInstructionStarSlashMod: {
1499afc2ba1dSToomas Soome ficlInteger x, y, z;
1500afc2ba1dSToomas Soome ficl2Integer prod;
1501afc2ba1dSToomas Soome ficl2IntegerQR qr;
1502afc2ba1dSToomas Soome
1503afc2ba1dSToomas Soome CHECK_STACK(3, 2);
1504afc2ba1dSToomas Soome
1505afc2ba1dSToomas Soome z = (dataTop--)->i;
1506afc2ba1dSToomas Soome y = dataTop[0].i;
1507afc2ba1dSToomas Soome x = dataTop[-1].i;
1508afc2ba1dSToomas Soome
1509afc2ba1dSToomas Soome prod = ficl2IntegerMultiply(x, y);
1510afc2ba1dSToomas Soome qr = ficl2IntegerDivideSymmetric(prod, z);
1511afc2ba1dSToomas Soome
1512afc2ba1dSToomas Soome dataTop[-1].i = qr.remainder;
1513afc2ba1dSToomas Soome dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
1514afc2ba1dSToomas Soome continue;
1515afc2ba1dSToomas Soome }
1516afc2ba1dSToomas Soome
1517afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
1518afc2ba1dSToomas Soome case ficlInstructionF0:
1519afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1520afc2ba1dSToomas Soome (++floatTop)->f = 0.0f;
1521c0bb4f73SToomas Soome continue;
1522afc2ba1dSToomas Soome
1523afc2ba1dSToomas Soome case ficlInstructionF1:
1524afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1525afc2ba1dSToomas Soome (++floatTop)->f = 1.0f;
1526c0bb4f73SToomas Soome continue;
1527afc2ba1dSToomas Soome
1528afc2ba1dSToomas Soome case ficlInstructionFNeg1:
1529afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1530afc2ba1dSToomas Soome (++floatTop)->f = -1.0f;
1531c0bb4f73SToomas Soome continue;
1532afc2ba1dSToomas Soome
1533afc2ba1dSToomas Soome /*
1534afc2ba1dSToomas Soome * Floating point literal execution word.
1535afc2ba1dSToomas Soome */
1536afc2ba1dSToomas Soome case ficlInstructionFLiteralParen:
1537afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1538afc2ba1dSToomas Soome
1539afc2ba1dSToomas Soome /*
1540afc2ba1dSToomas Soome * Yes, I'm using ->i here,
1541afc2ba1dSToomas Soome * but it's really a float. --lch
1542afc2ba1dSToomas Soome */
1543afc2ba1dSToomas Soome (++floatTop)->i = *ip++;
1544c0bb4f73SToomas Soome continue;
1545afc2ba1dSToomas Soome
1546afc2ba1dSToomas Soome /*
1547afc2ba1dSToomas Soome * Do float addition r1 + r2.
1548afc2ba1dSToomas Soome * f+ ( r1 r2 -- r )
1549afc2ba1dSToomas Soome */
1550afc2ba1dSToomas Soome case ficlInstructionFPlus:
1551afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 1);
1552afc2ba1dSToomas Soome
1553afc2ba1dSToomas Soome f = (floatTop--)->f;
1554afc2ba1dSToomas Soome floatTop->f += f;
1555c0bb4f73SToomas Soome continue;
1556afc2ba1dSToomas Soome
1557afc2ba1dSToomas Soome /*
1558afc2ba1dSToomas Soome * Do float subtraction r1 - r2.
1559afc2ba1dSToomas Soome * f- ( r1 r2 -- r )
1560afc2ba1dSToomas Soome */
1561afc2ba1dSToomas Soome case ficlInstructionFMinus:
1562afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 1);
1563afc2ba1dSToomas Soome
1564afc2ba1dSToomas Soome f = (floatTop--)->f;
1565afc2ba1dSToomas Soome floatTop->f -= f;
1566c0bb4f73SToomas Soome continue;
1567afc2ba1dSToomas Soome
1568afc2ba1dSToomas Soome /*
1569afc2ba1dSToomas Soome * Do float multiplication r1 * r2.
1570afc2ba1dSToomas Soome * f* ( r1 r2 -- r )
1571afc2ba1dSToomas Soome */
1572afc2ba1dSToomas Soome case ficlInstructionFStar:
1573afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 1);
1574afc2ba1dSToomas Soome
1575afc2ba1dSToomas Soome f = (floatTop--)->f;
1576afc2ba1dSToomas Soome floatTop->f *= f;
1577c0bb4f73SToomas Soome continue;
1578afc2ba1dSToomas Soome
1579afc2ba1dSToomas Soome /*
1580afc2ba1dSToomas Soome * Do float negation.
1581afc2ba1dSToomas Soome * fnegate ( r -- r )
1582afc2ba1dSToomas Soome */
1583afc2ba1dSToomas Soome case ficlInstructionFNegate:
1584afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1585afc2ba1dSToomas Soome
1586afc2ba1dSToomas Soome floatTop->f = -(floatTop->f);
1587c0bb4f73SToomas Soome continue;
1588afc2ba1dSToomas Soome
1589afc2ba1dSToomas Soome /*
1590afc2ba1dSToomas Soome * Do float division r1 / r2.
1591afc2ba1dSToomas Soome * f/ ( r1 r2 -- r )
1592afc2ba1dSToomas Soome */
1593afc2ba1dSToomas Soome case ficlInstructionFSlash:
1594afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 1);
1595afc2ba1dSToomas Soome
1596afc2ba1dSToomas Soome f = (floatTop--)->f;
1597afc2ba1dSToomas Soome floatTop->f /= f;
1598c0bb4f73SToomas Soome continue;
1599afc2ba1dSToomas Soome
1600afc2ba1dSToomas Soome /*
1601afc2ba1dSToomas Soome * Do float + integer r + n.
1602afc2ba1dSToomas Soome * f+i ( r n -- r )
1603afc2ba1dSToomas Soome */
1604afc2ba1dSToomas Soome case ficlInstructionFPlusI:
1605afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1606afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1607afc2ba1dSToomas Soome
1608afc2ba1dSToomas Soome f = (ficlFloat)(dataTop--)->f;
1609afc2ba1dSToomas Soome floatTop->f += f;
1610c0bb4f73SToomas Soome continue;
1611afc2ba1dSToomas Soome
1612afc2ba1dSToomas Soome /*
1613afc2ba1dSToomas Soome * Do float - integer r - n.
1614afc2ba1dSToomas Soome * f-i ( r n -- r )
1615afc2ba1dSToomas Soome */
1616afc2ba1dSToomas Soome case ficlInstructionFMinusI:
1617afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1618afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1619afc2ba1dSToomas Soome
1620afc2ba1dSToomas Soome f = (ficlFloat)(dataTop--)->f;
1621afc2ba1dSToomas Soome floatTop->f -= f;
1622c0bb4f73SToomas Soome continue;
1623afc2ba1dSToomas Soome
1624afc2ba1dSToomas Soome /*
1625afc2ba1dSToomas Soome * Do float * integer r * n.
1626afc2ba1dSToomas Soome * f*i ( r n -- r )
1627afc2ba1dSToomas Soome */
1628afc2ba1dSToomas Soome case ficlInstructionFStarI:
1629afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1630afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1631afc2ba1dSToomas Soome
1632afc2ba1dSToomas Soome f = (ficlFloat)(dataTop--)->f;
1633afc2ba1dSToomas Soome floatTop->f *= f;
1634c0bb4f73SToomas Soome continue;
1635afc2ba1dSToomas Soome
1636afc2ba1dSToomas Soome /*
1637afc2ba1dSToomas Soome * Do float / integer r / n.
1638afc2ba1dSToomas Soome * f/i ( r n -- r )
1639afc2ba1dSToomas Soome */
1640afc2ba1dSToomas Soome case ficlInstructionFSlashI:
1641afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1642afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1643afc2ba1dSToomas Soome
1644afc2ba1dSToomas Soome f = (ficlFloat)(dataTop--)->f;
1645afc2ba1dSToomas Soome floatTop->f /= f;
1646afc2ba1dSToomas Soome continue;
1647afc2ba1dSToomas Soome
1648afc2ba1dSToomas Soome /*
1649afc2ba1dSToomas Soome * Do integer - float n - r.
1650afc2ba1dSToomas Soome * i-f ( n r -- r )
1651afc2ba1dSToomas Soome */
1652afc2ba1dSToomas Soome case ficlInstructionIMinusF:
1653afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1654afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1655afc2ba1dSToomas Soome
1656afc2ba1dSToomas Soome f = (ficlFloat)(dataTop--)->f;
1657afc2ba1dSToomas Soome floatTop->f = f - floatTop->f;
1658c0bb4f73SToomas Soome continue;
1659afc2ba1dSToomas Soome
1660afc2ba1dSToomas Soome /*
1661afc2ba1dSToomas Soome * Do integer / float n / r.
1662afc2ba1dSToomas Soome * i/f ( n r -- r )
1663afc2ba1dSToomas Soome */
1664afc2ba1dSToomas Soome case ficlInstructionISlashF:
1665afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 1);
1666afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1667afc2ba1dSToomas Soome
1668afc2ba1dSToomas Soome f = (ficlFloat)(dataTop--)->f;
1669afc2ba1dSToomas Soome floatTop->f = f / floatTop->f;
1670c0bb4f73SToomas Soome continue;
1671afc2ba1dSToomas Soome
1672afc2ba1dSToomas Soome /*
1673afc2ba1dSToomas Soome * Do integer to float conversion.
1674afc2ba1dSToomas Soome * int>float ( n -- r )
1675afc2ba1dSToomas Soome */
1676afc2ba1dSToomas Soome case ficlInstructionIntToFloat:
1677afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1678afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1679afc2ba1dSToomas Soome
1680afc2ba1dSToomas Soome (++floatTop)->f = ((dataTop--)->f);
1681c0bb4f73SToomas Soome continue;
1682afc2ba1dSToomas Soome
1683afc2ba1dSToomas Soome /*
1684afc2ba1dSToomas Soome * Do float to integer conversion.
1685afc2ba1dSToomas Soome * float>int ( r -- n )
1686afc2ba1dSToomas Soome */
1687afc2ba1dSToomas Soome case ficlInstructionFloatToInt:
1688afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1689afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1690afc2ba1dSToomas Soome
1691afc2ba1dSToomas Soome (++dataTop)->i = ((floatTop--)->i);
1692c0bb4f73SToomas Soome continue;
1693afc2ba1dSToomas Soome
1694afc2ba1dSToomas Soome /*
1695afc2ba1dSToomas Soome * Add a floating point number to contents of a variable.
1696afc2ba1dSToomas Soome * f+! ( r n -- )
1697afc2ba1dSToomas Soome */
1698afc2ba1dSToomas Soome case ficlInstructionFPlusStore: {
1699afc2ba1dSToomas Soome ficlCell *cell;
1700afc2ba1dSToomas Soome
1701afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1702afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1703afc2ba1dSToomas Soome
1704afc2ba1dSToomas Soome cell = (ficlCell *)(dataTop--)->p;
1705afc2ba1dSToomas Soome cell->f += (floatTop--)->f;
1706c0bb4f73SToomas Soome continue;
1707afc2ba1dSToomas Soome }
1708afc2ba1dSToomas Soome
1709afc2ba1dSToomas Soome /*
1710afc2ba1dSToomas Soome * Do float stack drop.
1711afc2ba1dSToomas Soome * fdrop ( r -- )
1712afc2ba1dSToomas Soome */
1713afc2ba1dSToomas Soome case ficlInstructionFDrop:
1714afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1715afc2ba1dSToomas Soome floatTop--;
1716c0bb4f73SToomas Soome continue;
1717afc2ba1dSToomas Soome
1718afc2ba1dSToomas Soome /*
1719afc2ba1dSToomas Soome * Do float stack ?dup.
1720afc2ba1dSToomas Soome * f?dup ( r -- r )
1721afc2ba1dSToomas Soome */
1722afc2ba1dSToomas Soome case ficlInstructionFQuestionDup:
1723afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 2);
1724afc2ba1dSToomas Soome
1725afc2ba1dSToomas Soome if (floatTop->f != 0)
1726afc2ba1dSToomas Soome goto FDUP;
1727afc2ba1dSToomas Soome
1728c0bb4f73SToomas Soome continue;
1729afc2ba1dSToomas Soome
1730afc2ba1dSToomas Soome /*
1731afc2ba1dSToomas Soome * Do float stack dup.
1732afc2ba1dSToomas Soome * fdup ( r -- r r )
1733afc2ba1dSToomas Soome */
1734afc2ba1dSToomas Soome case ficlInstructionFDup:
1735afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 2);
1736afc2ba1dSToomas Soome
1737afc2ba1dSToomas Soome FDUP:
1738afc2ba1dSToomas Soome floatTop[1] = floatTop[0];
1739afc2ba1dSToomas Soome floatTop++;
1740afc2ba1dSToomas Soome continue;
1741afc2ba1dSToomas Soome
1742afc2ba1dSToomas Soome /*
1743afc2ba1dSToomas Soome * Do float stack swap.
1744afc2ba1dSToomas Soome * fswap ( r1 r2 -- r2 r1 )
1745afc2ba1dSToomas Soome */
1746afc2ba1dSToomas Soome case ficlInstructionFSwap:
1747afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 2);
1748afc2ba1dSToomas Soome
1749afc2ba1dSToomas Soome c = floatTop[0];
1750afc2ba1dSToomas Soome floatTop[0] = floatTop[-1];
1751afc2ba1dSToomas Soome floatTop[-1] = c;
1752c0bb4f73SToomas Soome continue;
1753afc2ba1dSToomas Soome
1754afc2ba1dSToomas Soome /*
1755afc2ba1dSToomas Soome * Do float stack 2drop.
1756afc2ba1dSToomas Soome * f2drop ( r r -- )
1757afc2ba1dSToomas Soome */
1758afc2ba1dSToomas Soome case ficlInstructionF2Drop:
1759afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 0);
1760afc2ba1dSToomas Soome
1761afc2ba1dSToomas Soome floatTop -= 2;
1762c0bb4f73SToomas Soome continue;
1763afc2ba1dSToomas Soome
1764afc2ba1dSToomas Soome /*
1765afc2ba1dSToomas Soome * Do float stack 2dup.
1766afc2ba1dSToomas Soome * f2dup ( r1 r2 -- r1 r2 r1 r2 )
1767afc2ba1dSToomas Soome */
1768afc2ba1dSToomas Soome case ficlInstructionF2Dup:
1769afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 4);
1770afc2ba1dSToomas Soome
1771afc2ba1dSToomas Soome floatTop[1] = floatTop[-1];
1772afc2ba1dSToomas Soome floatTop[2] = *floatTop;
1773afc2ba1dSToomas Soome floatTop += 2;
1774c0bb4f73SToomas Soome continue;
1775afc2ba1dSToomas Soome
1776afc2ba1dSToomas Soome /*
1777afc2ba1dSToomas Soome * Do float stack over.
1778afc2ba1dSToomas Soome * fover ( r1 r2 -- r1 r2 r1 )
1779afc2ba1dSToomas Soome */
1780afc2ba1dSToomas Soome case ficlInstructionFOver:
1781afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 3);
1782afc2ba1dSToomas Soome
1783afc2ba1dSToomas Soome floatTop[1] = floatTop[-1];
1784afc2ba1dSToomas Soome floatTop++;
1785c0bb4f73SToomas Soome continue;
1786afc2ba1dSToomas Soome
1787afc2ba1dSToomas Soome /*
1788afc2ba1dSToomas Soome * Do float stack 2over.
1789afc2ba1dSToomas Soome * f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
1790afc2ba1dSToomas Soome */
1791afc2ba1dSToomas Soome case ficlInstructionF2Over:
1792afc2ba1dSToomas Soome CHECK_FLOAT_STACK(4, 6);
1793afc2ba1dSToomas Soome
1794afc2ba1dSToomas Soome floatTop[1] = floatTop[-2];
1795afc2ba1dSToomas Soome floatTop[2] = floatTop[-1];
1796afc2ba1dSToomas Soome floatTop += 2;
1797c0bb4f73SToomas Soome continue;
1798afc2ba1dSToomas Soome
1799afc2ba1dSToomas Soome /*
1800afc2ba1dSToomas Soome * Do float stack pick.
1801afc2ba1dSToomas Soome * fpick ( n -- r )
1802afc2ba1dSToomas Soome */
1803afc2ba1dSToomas Soome case ficlInstructionFPick:
1804afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1805afc2ba1dSToomas Soome c = *dataTop--;
1806afc2ba1dSToomas Soome CHECK_FLOAT_STACK(c.i+2, c.i+3);
1807afc2ba1dSToomas Soome
1808afc2ba1dSToomas Soome floatTop[1] = floatTop[- c.i - 1];
1809c0bb4f73SToomas Soome continue;
1810afc2ba1dSToomas Soome
1811afc2ba1dSToomas Soome /*
1812afc2ba1dSToomas Soome * Do float stack rot.
1813afc2ba1dSToomas Soome * frot ( r1 r2 r3 -- r2 r3 r1 )
1814afc2ba1dSToomas Soome */
1815afc2ba1dSToomas Soome case ficlInstructionFRot:
1816afc2ba1dSToomas Soome i = 2;
1817afc2ba1dSToomas Soome goto FROLL;
1818afc2ba1dSToomas Soome
1819afc2ba1dSToomas Soome /*
1820afc2ba1dSToomas Soome * Do float stack roll.
1821afc2ba1dSToomas Soome * froll ( n -- )
1822afc2ba1dSToomas Soome */
1823afc2ba1dSToomas Soome case ficlInstructionFRoll:
1824afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1825afc2ba1dSToomas Soome i = (dataTop--)->i;
1826afc2ba1dSToomas Soome
1827afc2ba1dSToomas Soome if (i < 1)
1828afc2ba1dSToomas Soome continue;
1829afc2ba1dSToomas Soome
1830afc2ba1dSToomas Soome FROLL:
1831afc2ba1dSToomas Soome CHECK_FLOAT_STACK(i+1, i+2);
1832afc2ba1dSToomas Soome c = floatTop[-i];
1833afc2ba1dSToomas Soome memmove(floatTop - i, floatTop - (i - 1),
1834afc2ba1dSToomas Soome i * sizeof (ficlCell));
1835afc2ba1dSToomas Soome *floatTop = c;
1836afc2ba1dSToomas Soome
1837c0bb4f73SToomas Soome continue;
1838afc2ba1dSToomas Soome
1839afc2ba1dSToomas Soome /*
1840afc2ba1dSToomas Soome * Do float stack -rot.
1841afc2ba1dSToomas Soome * f-rot ( r1 r2 r3 -- r3 r1 r2 )
1842afc2ba1dSToomas Soome */
1843afc2ba1dSToomas Soome case ficlInstructionFMinusRot:
1844afc2ba1dSToomas Soome i = 2;
1845afc2ba1dSToomas Soome goto FMINUSROLL;
1846afc2ba1dSToomas Soome
1847afc2ba1dSToomas Soome
1848afc2ba1dSToomas Soome /*
1849afc2ba1dSToomas Soome * Do float stack -roll.
1850afc2ba1dSToomas Soome * f-roll ( n -- )
1851afc2ba1dSToomas Soome */
1852afc2ba1dSToomas Soome case ficlInstructionFMinusRoll:
1853afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1854afc2ba1dSToomas Soome i = (dataTop--)->i;
1855afc2ba1dSToomas Soome
1856afc2ba1dSToomas Soome if (i < 1)
1857afc2ba1dSToomas Soome continue;
1858afc2ba1dSToomas Soome
1859afc2ba1dSToomas Soome FMINUSROLL:
1860afc2ba1dSToomas Soome CHECK_FLOAT_STACK(i+1, i+2);
1861afc2ba1dSToomas Soome c = *floatTop;
1862afc2ba1dSToomas Soome memmove(floatTop - (i - 1), floatTop - i,
1863afc2ba1dSToomas Soome i * sizeof (ficlCell));
1864afc2ba1dSToomas Soome floatTop[-i] = c;
1865afc2ba1dSToomas Soome
1866c0bb4f73SToomas Soome continue;
1867afc2ba1dSToomas Soome
1868afc2ba1dSToomas Soome /*
1869afc2ba1dSToomas Soome * Do float stack 2swap
1870afc2ba1dSToomas Soome * f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
1871afc2ba1dSToomas Soome */
1872afc2ba1dSToomas Soome case ficlInstructionF2Swap: {
1873afc2ba1dSToomas Soome ficlCell c2;
1874afc2ba1dSToomas Soome CHECK_FLOAT_STACK(4, 4);
1875afc2ba1dSToomas Soome
1876afc2ba1dSToomas Soome c = *floatTop;
1877afc2ba1dSToomas Soome c2 = floatTop[-1];
1878afc2ba1dSToomas Soome
1879afc2ba1dSToomas Soome *floatTop = floatTop[-2];
1880afc2ba1dSToomas Soome floatTop[-1] = floatTop[-3];
1881afc2ba1dSToomas Soome
1882afc2ba1dSToomas Soome floatTop[-2] = c;
1883afc2ba1dSToomas Soome floatTop[-3] = c2;
1884c0bb4f73SToomas Soome continue;
1885afc2ba1dSToomas Soome }
1886afc2ba1dSToomas Soome
1887afc2ba1dSToomas Soome /*
1888afc2ba1dSToomas Soome * Do float 0= comparison r = 0.0.
1889afc2ba1dSToomas Soome * f0= ( r -- T/F )
1890afc2ba1dSToomas Soome */
1891afc2ba1dSToomas Soome case ficlInstructionF0Equals:
1892afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1893afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1894afc2ba1dSToomas Soome
1895afc2ba1dSToomas Soome (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f);
1896c0bb4f73SToomas Soome continue;
1897afc2ba1dSToomas Soome
1898afc2ba1dSToomas Soome /*
1899afc2ba1dSToomas Soome * Do float 0< comparison r < 0.0.
1900afc2ba1dSToomas Soome * f0< ( r -- T/F )
1901afc2ba1dSToomas Soome */
1902afc2ba1dSToomas Soome case ficlInstructionF0Less:
1903afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1904afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1905afc2ba1dSToomas Soome
1906afc2ba1dSToomas Soome (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f);
1907c0bb4f73SToomas Soome continue;
1908afc2ba1dSToomas Soome
1909afc2ba1dSToomas Soome /*
1910afc2ba1dSToomas Soome * Do float 0> comparison r > 0.0.
1911afc2ba1dSToomas Soome * f0> ( r -- T/F )
1912afc2ba1dSToomas Soome */
1913afc2ba1dSToomas Soome case ficlInstructionF0Greater:
1914afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1915afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1916afc2ba1dSToomas Soome
1917afc2ba1dSToomas Soome (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f);
1918c0bb4f73SToomas Soome continue;
1919afc2ba1dSToomas Soome
1920afc2ba1dSToomas Soome /*
1921afc2ba1dSToomas Soome * Do float = comparison r1 = r2.
1922afc2ba1dSToomas Soome * f= ( r1 r2 -- T/F )
1923afc2ba1dSToomas Soome */
1924afc2ba1dSToomas Soome case ficlInstructionFEquals:
1925afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 0);
1926afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1927afc2ba1dSToomas Soome
1928afc2ba1dSToomas Soome f = (floatTop--)->f;
1929afc2ba1dSToomas Soome (++dataTop)->i = FICL_BOOL((floatTop--)->f == f);
1930c0bb4f73SToomas Soome continue;
1931afc2ba1dSToomas Soome
1932afc2ba1dSToomas Soome /*
1933afc2ba1dSToomas Soome * Do float < comparison r1 < r2.
1934afc2ba1dSToomas Soome * f< ( r1 r2 -- T/F )
1935afc2ba1dSToomas Soome */
1936afc2ba1dSToomas Soome case ficlInstructionFLess:
1937afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 0);
1938afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1939afc2ba1dSToomas Soome
1940afc2ba1dSToomas Soome f = (floatTop--)->f;
1941afc2ba1dSToomas Soome (++dataTop)->i = FICL_BOOL((floatTop--)->f < f);
1942c0bb4f73SToomas Soome continue;
1943afc2ba1dSToomas Soome
1944afc2ba1dSToomas Soome /*
1945afc2ba1dSToomas Soome * Do float > comparison r1 > r2.
1946afc2ba1dSToomas Soome * f> ( r1 r2 -- T/F )
1947afc2ba1dSToomas Soome */
1948afc2ba1dSToomas Soome case ficlInstructionFGreater:
1949afc2ba1dSToomas Soome CHECK_FLOAT_STACK(2, 0);
1950afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1951afc2ba1dSToomas Soome
1952afc2ba1dSToomas Soome f = (floatTop--)->f;
1953afc2ba1dSToomas Soome (++dataTop)->i = FICL_BOOL((floatTop--)->f > f);
1954c0bb4f73SToomas Soome continue;
1955afc2ba1dSToomas Soome
1956afc2ba1dSToomas Soome
1957afc2ba1dSToomas Soome /*
1958afc2ba1dSToomas Soome * Move float to param stack (assumes they both fit in a
1959afc2ba1dSToomas Soome * single ficlCell) f>s
1960afc2ba1dSToomas Soome */
1961afc2ba1dSToomas Soome case ficlInstructionFFrom:
1962afc2ba1dSToomas Soome CHECK_FLOAT_STACK(1, 0);
1963afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1964afc2ba1dSToomas Soome
1965afc2ba1dSToomas Soome *++dataTop = *floatTop--;
1966c0bb4f73SToomas Soome continue;
1967afc2ba1dSToomas Soome
1968afc2ba1dSToomas Soome case ficlInstructionToF:
1969afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
1970afc2ba1dSToomas Soome CHECK_STACK(1, 0);
1971afc2ba1dSToomas Soome
1972afc2ba1dSToomas Soome *++floatTop = *dataTop--;
1973c0bb4f73SToomas Soome continue;
1974afc2ba1dSToomas Soome
1975afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
1976afc2ba1dSToomas Soome
1977afc2ba1dSToomas Soome /*
1978afc2ba1dSToomas Soome * c o l o n P a r e n
1979afc2ba1dSToomas Soome * This is the code that executes a colon definition. It
1980afc2ba1dSToomas Soome * assumes that the virtual machine is running a "next" loop
1981afc2ba1dSToomas Soome * (See the vm.c for its implementation of member function
1982afc2ba1dSToomas Soome * vmExecute()). The colon code simply copies the address of
1983afc2ba1dSToomas Soome * the first word in the list of words to interpret into IP
1984afc2ba1dSToomas Soome * after saving its old value. When we return to the "next"
1985afc2ba1dSToomas Soome * loop, the virtual machine will call the code for each
1986afc2ba1dSToomas Soome * word in turn.
1987afc2ba1dSToomas Soome */
1988afc2ba1dSToomas Soome case ficlInstructionColonParen:
1989afc2ba1dSToomas Soome (++returnTop)->p = (void *)ip;
1990afc2ba1dSToomas Soome ip = (ficlInstruction *)(fw->param);
1991c0bb4f73SToomas Soome continue;
1992afc2ba1dSToomas Soome
1993afc2ba1dSToomas Soome case ficlInstructionCreateParen:
1994afc2ba1dSToomas Soome CHECK_STACK(0, 1);
1995afc2ba1dSToomas Soome (++dataTop)->p = (fw->param + 1);
1996c0bb4f73SToomas Soome continue;
1997afc2ba1dSToomas Soome
1998afc2ba1dSToomas Soome case ficlInstructionVariableParen:
1999afc2ba1dSToomas Soome CHECK_STACK(0, 1);
2000afc2ba1dSToomas Soome (++dataTop)->p = fw->param;
2001c0bb4f73SToomas Soome continue;
2002afc2ba1dSToomas Soome
2003afc2ba1dSToomas Soome /*
2004afc2ba1dSToomas Soome * c o n s t a n t P a r e n
2005afc2ba1dSToomas Soome * This is the run-time code for "constant". It simply returns
2006afc2ba1dSToomas Soome * the contents of its word's first data ficlCell.
2007afc2ba1dSToomas Soome */
2008afc2ba1dSToomas Soome
2009afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2010afc2ba1dSToomas Soome case ficlInstructionF2ConstantParen:
2011afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 2);
2012afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param);
2013afc2ba1dSToomas Soome
2014afc2ba1dSToomas Soome case ficlInstructionFConstantParen:
2015afc2ba1dSToomas Soome CHECK_FLOAT_STACK(0, 1);
2016afc2ba1dSToomas Soome FLOAT_PUSH_CELL_POINTER(fw->param);
2017afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
2018afc2ba1dSToomas Soome
2019afc2ba1dSToomas Soome case ficlInstruction2ConstantParen:
2020afc2ba1dSToomas Soome CHECK_STACK(0, 2);
2021afc2ba1dSToomas Soome PUSH_CELL_POINTER_DOUBLE(fw->param);
2022afc2ba1dSToomas Soome
2023afc2ba1dSToomas Soome case ficlInstructionConstantParen:
2024afc2ba1dSToomas Soome CHECK_STACK(0, 1);
2025afc2ba1dSToomas Soome PUSH_CELL_POINTER(fw->param);
2026afc2ba1dSToomas Soome
2027afc2ba1dSToomas Soome #if FICL_WANT_USER
2028afc2ba1dSToomas Soome case ficlInstructionUserParen: {
2029afc2ba1dSToomas Soome ficlInteger i = fw->param[0].i;
2030afc2ba1dSToomas Soome (++dataTop)->p = &vm->user[i];
2031c0bb4f73SToomas Soome continue;
2032afc2ba1dSToomas Soome }
2033afc2ba1dSToomas Soome #endif
2034afc2ba1dSToomas Soome
2035afc2ba1dSToomas Soome default:
2036afc2ba1dSToomas Soome /*
2037afc2ba1dSToomas Soome * Clever hack, or evil coding? You be the judge.
2038afc2ba1dSToomas Soome *
2039afc2ba1dSToomas Soome * If the word we've been asked to execute is in fact
2040afc2ba1dSToomas Soome * an *instruction*, we grab the instruction, stow it
2041afc2ba1dSToomas Soome * in "i" (our local cache of *ip), and *jump* to the
2042afc2ba1dSToomas Soome * top of the switch statement. --lch
2043afc2ba1dSToomas Soome */
2044afc2ba1dSToomas Soome if (((ficlInstruction)fw->code >
2045afc2ba1dSToomas Soome ficlInstructionInvalid) &&
2046afc2ba1dSToomas Soome ((ficlInstruction)fw->code < ficlInstructionLast)) {
2047afc2ba1dSToomas Soome instruction = (ficlInstruction)fw->code;
2048afc2ba1dSToomas Soome goto AGAIN;
2049afc2ba1dSToomas Soome }
2050afc2ba1dSToomas Soome
2051afc2ba1dSToomas Soome LOCAL_VARIABLE_SPILL;
2052afc2ba1dSToomas Soome (vm)->runningWord = fw;
2053afc2ba1dSToomas Soome fw->code(vm);
2054afc2ba1dSToomas Soome LOCAL_VARIABLE_REFILL;
2055c0bb4f73SToomas Soome continue;
2056afc2ba1dSToomas Soome }
2057afc2ba1dSToomas Soome }
2058afc2ba1dSToomas Soome
2059afc2ba1dSToomas Soome LOCAL_VARIABLE_SPILL;
2060afc2ba1dSToomas Soome vm->exceptionHandler = oldExceptionHandler;
2061afc2ba1dSToomas Soome }
2062afc2ba1dSToomas Soome
2063afc2ba1dSToomas Soome /*
2064afc2ba1dSToomas Soome * v m G e t D i c t
2065afc2ba1dSToomas Soome * Returns the address dictionary for this VM's system
2066afc2ba1dSToomas Soome */
2067afc2ba1dSToomas Soome ficlDictionary *
ficlVmGetDictionary(ficlVm * vm)2068afc2ba1dSToomas Soome ficlVmGetDictionary(ficlVm *vm)
2069afc2ba1dSToomas Soome {
2070afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm);
2071afc2ba1dSToomas Soome return (vm->callback.system->dictionary);
2072afc2ba1dSToomas Soome }
2073afc2ba1dSToomas Soome
2074afc2ba1dSToomas Soome /*
2075afc2ba1dSToomas Soome * v m G e t S t r i n g
2076afc2ba1dSToomas Soome * Parses a string out of the VM input buffer and copies up to the first
2077afc2ba1dSToomas Soome * FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a
2078afc2ba1dSToomas Soome * ficlCountedString. The destination string is NULL terminated.
2079afc2ba1dSToomas Soome *
2080afc2ba1dSToomas Soome * Returns the address of the first unused character in the dest buffer.
2081afc2ba1dSToomas Soome */
2082afc2ba1dSToomas Soome char *
ficlVmGetString(ficlVm * vm,ficlCountedString * counted,char delimiter)2083afc2ba1dSToomas Soome ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter)
2084afc2ba1dSToomas Soome {
2085afc2ba1dSToomas Soome ficlString s = ficlVmParseStringEx(vm, delimiter, 0);
2086afc2ba1dSToomas Soome
2087afc2ba1dSToomas Soome if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) {
2088afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX);
2089afc2ba1dSToomas Soome }
2090afc2ba1dSToomas Soome
2091c0bb4f73SToomas Soome (void) strncpy(counted->text, FICL_STRING_GET_POINTER(s),
2092afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(s));
2093afc2ba1dSToomas Soome counted->text[FICL_STRING_GET_LENGTH(s)] = '\0';
2094afc2ba1dSToomas Soome counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
2095afc2ba1dSToomas Soome
2096afc2ba1dSToomas Soome return (counted->text + FICL_STRING_GET_LENGTH(s) + 1);
2097afc2ba1dSToomas Soome }
2098afc2ba1dSToomas Soome
2099afc2ba1dSToomas Soome /*
2100afc2ba1dSToomas Soome * v m G e t W o r d
2101afc2ba1dSToomas Soome * vmGetWord calls vmGetWord0 repeatedly until it gets a string with
2102afc2ba1dSToomas Soome * non-zero length.
2103afc2ba1dSToomas Soome */
2104afc2ba1dSToomas Soome ficlString
ficlVmGetWord(ficlVm * vm)2105afc2ba1dSToomas Soome ficlVmGetWord(ficlVm *vm)
2106afc2ba1dSToomas Soome {
2107afc2ba1dSToomas Soome ficlString s = ficlVmGetWord0(vm);
2108afc2ba1dSToomas Soome
2109afc2ba1dSToomas Soome if (FICL_STRING_GET_LENGTH(s) == 0) {
2110afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
2111afc2ba1dSToomas Soome }
2112afc2ba1dSToomas Soome
2113afc2ba1dSToomas Soome return (s);
2114afc2ba1dSToomas Soome }
2115afc2ba1dSToomas Soome
2116afc2ba1dSToomas Soome /*
2117afc2ba1dSToomas Soome * v m G e t W o r d 0
2118afc2ba1dSToomas Soome * Skip leading whitespace and parse a space delimited word from the tib.
2119afc2ba1dSToomas Soome * Returns the start address and length of the word. Updates the tib
2120afc2ba1dSToomas Soome * to reflect characters consumed, including the trailing delimiter.
2121afc2ba1dSToomas Soome * If there's nothing of interest in the tib, returns zero. This function
2122afc2ba1dSToomas Soome * does not use vmParseString because it uses isspace() rather than a
2123afc2ba1dSToomas Soome * single delimiter character.
2124afc2ba1dSToomas Soome */
2125afc2ba1dSToomas Soome ficlString
ficlVmGetWord0(ficlVm * vm)2126afc2ba1dSToomas Soome ficlVmGetWord0(ficlVm *vm)
2127afc2ba1dSToomas Soome {
2128afc2ba1dSToomas Soome char *trace = ficlVmGetInBuf(vm);
2129afc2ba1dSToomas Soome char *stop = ficlVmGetInBufEnd(vm);
2130afc2ba1dSToomas Soome ficlString s;
2131afc2ba1dSToomas Soome ficlUnsigned length = 0;
2132afc2ba1dSToomas Soome char c = 0;
2133afc2ba1dSToomas Soome
2134afc2ba1dSToomas Soome trace = ficlStringSkipSpace(trace, stop);
2135afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(s, trace);
2136afc2ba1dSToomas Soome
2137afc2ba1dSToomas Soome /* Please leave this loop this way; it makes Purify happier. --lch */
2138afc2ba1dSToomas Soome for (;;) {
2139afc2ba1dSToomas Soome if (trace == stop)
2140afc2ba1dSToomas Soome break;
2141afc2ba1dSToomas Soome c = *trace;
2142afc2ba1dSToomas Soome if (isspace((unsigned char)c))
2143afc2ba1dSToomas Soome break;
2144afc2ba1dSToomas Soome length++;
2145afc2ba1dSToomas Soome trace++;
2146afc2ba1dSToomas Soome }
2147afc2ba1dSToomas Soome
2148afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(s, length);
2149afc2ba1dSToomas Soome
2150afc2ba1dSToomas Soome /* skip one trailing delimiter */
2151afc2ba1dSToomas Soome if ((trace != stop) && isspace((unsigned char)c))
2152afc2ba1dSToomas Soome trace++;
2153afc2ba1dSToomas Soome
2154afc2ba1dSToomas Soome ficlVmUpdateTib(vm, trace);
2155afc2ba1dSToomas Soome
2156afc2ba1dSToomas Soome return (s);
2157afc2ba1dSToomas Soome }
2158afc2ba1dSToomas Soome
2159afc2ba1dSToomas Soome /*
2160afc2ba1dSToomas Soome * v m G e t W o r d T o P a d
2161afc2ba1dSToomas Soome * Does vmGetWord and copies the result to the pad as a NULL terminated
2162afc2ba1dSToomas Soome * string. Returns the length of the string. If the string is too long
2163afc2ba1dSToomas Soome * to fit in the pad, it is truncated.
2164afc2ba1dSToomas Soome */
2165afc2ba1dSToomas Soome int
ficlVmGetWordToPad(ficlVm * vm)2166afc2ba1dSToomas Soome ficlVmGetWordToPad(ficlVm *vm)
2167afc2ba1dSToomas Soome {
2168afc2ba1dSToomas Soome ficlString s;
2169afc2ba1dSToomas Soome char *pad = (char *)vm->pad;
2170afc2ba1dSToomas Soome s = ficlVmGetWord(vm);
2171afc2ba1dSToomas Soome
2172*efe51d0cSJohn Levon if (FICL_STRING_GET_LENGTH(s) >= FICL_PAD_SIZE)
2173*efe51d0cSJohn Levon FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE - 1);
2174afc2ba1dSToomas Soome
2175c0bb4f73SToomas Soome (void) strncpy(pad, FICL_STRING_GET_POINTER(s),
2176c0bb4f73SToomas Soome FICL_STRING_GET_LENGTH(s));
2177afc2ba1dSToomas Soome pad[FICL_STRING_GET_LENGTH(s)] = '\0';
2178afc2ba1dSToomas Soome return ((int)(FICL_STRING_GET_LENGTH(s)));
2179afc2ba1dSToomas Soome }
2180afc2ba1dSToomas Soome
2181afc2ba1dSToomas Soome /*
2182afc2ba1dSToomas Soome * v m P a r s e S t r i n g
2183afc2ba1dSToomas Soome * Parses a string out of the input buffer using the delimiter
2184afc2ba1dSToomas Soome * specified. Skips leading delimiters, marks the start of the string,
2185afc2ba1dSToomas Soome * and counts characters to the next delimiter it encounters. It then
2186afc2ba1dSToomas Soome * updates the vm input buffer to consume all these chars, including the
2187afc2ba1dSToomas Soome * trailing delimiter.
2188afc2ba1dSToomas Soome * Returns the address and length of the parsed string, not including the
2189afc2ba1dSToomas Soome * trailing delimiter.
2190afc2ba1dSToomas Soome */
2191afc2ba1dSToomas Soome ficlString
ficlVmParseString(ficlVm * vm,char delimiter)2192afc2ba1dSToomas Soome ficlVmParseString(ficlVm *vm, char delimiter)
2193afc2ba1dSToomas Soome {
2194afc2ba1dSToomas Soome return (ficlVmParseStringEx(vm, delimiter, 1));
2195afc2ba1dSToomas Soome }
2196afc2ba1dSToomas Soome
2197afc2ba1dSToomas Soome ficlString
ficlVmParseStringEx(ficlVm * vm,char delimiter,char skipLeadingDelimiters)2198afc2ba1dSToomas Soome ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters)
2199afc2ba1dSToomas Soome {
2200afc2ba1dSToomas Soome ficlString s;
2201afc2ba1dSToomas Soome char *trace = ficlVmGetInBuf(vm);
2202afc2ba1dSToomas Soome char *stop = ficlVmGetInBufEnd(vm);
2203afc2ba1dSToomas Soome char c;
2204afc2ba1dSToomas Soome
2205afc2ba1dSToomas Soome if (skipLeadingDelimiters) {
2206afc2ba1dSToomas Soome while ((trace != stop) && (*trace == delimiter))
2207afc2ba1dSToomas Soome trace++;
2208afc2ba1dSToomas Soome }
2209afc2ba1dSToomas Soome
2210afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(s, trace); /* mark start of text */
2211afc2ba1dSToomas Soome
2212afc2ba1dSToomas Soome /* find next delimiter or end of line */
2213afc2ba1dSToomas Soome for (c = *trace;
2214afc2ba1dSToomas Soome (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n');
2215afc2ba1dSToomas Soome c = *++trace) {
2216afc2ba1dSToomas Soome ;
2217afc2ba1dSToomas Soome }
2218afc2ba1dSToomas Soome
2219afc2ba1dSToomas Soome /* set length of result */
2220afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s));
2221afc2ba1dSToomas Soome
2222afc2ba1dSToomas Soome /* gobble trailing delimiter */
2223afc2ba1dSToomas Soome if ((trace != stop) && (*trace == delimiter))
2224afc2ba1dSToomas Soome trace++;
2225afc2ba1dSToomas Soome
2226afc2ba1dSToomas Soome ficlVmUpdateTib(vm, trace);
2227afc2ba1dSToomas Soome return (s);
2228afc2ba1dSToomas Soome }
2229afc2ba1dSToomas Soome
2230afc2ba1dSToomas Soome
2231afc2ba1dSToomas Soome /*
2232afc2ba1dSToomas Soome * v m P o p
2233afc2ba1dSToomas Soome */
2234afc2ba1dSToomas Soome ficlCell
ficlVmPop(ficlVm * vm)2235afc2ba1dSToomas Soome ficlVmPop(ficlVm *vm)
2236afc2ba1dSToomas Soome {
2237afc2ba1dSToomas Soome return (ficlStackPop(vm->dataStack));
2238afc2ba1dSToomas Soome }
2239afc2ba1dSToomas Soome
2240afc2ba1dSToomas Soome /*
2241afc2ba1dSToomas Soome * v m P u s h
2242afc2ba1dSToomas Soome */
2243afc2ba1dSToomas Soome void
ficlVmPush(ficlVm * vm,ficlCell c)2244afc2ba1dSToomas Soome ficlVmPush(ficlVm *vm, ficlCell c)
2245afc2ba1dSToomas Soome {
2246afc2ba1dSToomas Soome ficlStackPush(vm->dataStack, c);
2247afc2ba1dSToomas Soome }
2248afc2ba1dSToomas Soome
2249afc2ba1dSToomas Soome /*
2250afc2ba1dSToomas Soome * v m P o p I P
2251afc2ba1dSToomas Soome */
2252afc2ba1dSToomas Soome void
ficlVmPopIP(ficlVm * vm)2253afc2ba1dSToomas Soome ficlVmPopIP(ficlVm *vm)
2254afc2ba1dSToomas Soome {
2255afc2ba1dSToomas Soome vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack));
2256afc2ba1dSToomas Soome }
2257afc2ba1dSToomas Soome
2258afc2ba1dSToomas Soome /*
2259afc2ba1dSToomas Soome * v m P u s h I P
2260afc2ba1dSToomas Soome */
2261afc2ba1dSToomas Soome void
ficlVmPushIP(ficlVm * vm,ficlIp newIP)2262afc2ba1dSToomas Soome ficlVmPushIP(ficlVm *vm, ficlIp newIP)
2263afc2ba1dSToomas Soome {
2264afc2ba1dSToomas Soome ficlStackPushPointer(vm->returnStack, (void *)vm->ip);
2265afc2ba1dSToomas Soome vm->ip = newIP;
2266afc2ba1dSToomas Soome }
2267afc2ba1dSToomas Soome
2268afc2ba1dSToomas Soome /*
2269afc2ba1dSToomas Soome * v m P u s h T i b
2270afc2ba1dSToomas Soome * Binds the specified input string to the VM and clears >IN (the index)
2271afc2ba1dSToomas Soome */
2272afc2ba1dSToomas Soome void
ficlVmPushTib(ficlVm * vm,char * text,ficlInteger nChars,ficlTIB * pSaveTib)2273afc2ba1dSToomas Soome ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib)
2274afc2ba1dSToomas Soome {
2275afc2ba1dSToomas Soome if (pSaveTib) {
2276afc2ba1dSToomas Soome *pSaveTib = vm->tib;
2277afc2ba1dSToomas Soome }
2278afc2ba1dSToomas Soome vm->tib.text = text;
2279afc2ba1dSToomas Soome vm->tib.end = text + nChars;
2280afc2ba1dSToomas Soome vm->tib.index = 0;
2281afc2ba1dSToomas Soome }
2282afc2ba1dSToomas Soome
2283afc2ba1dSToomas Soome void
ficlVmPopTib(ficlVm * vm,ficlTIB * pTib)2284afc2ba1dSToomas Soome ficlVmPopTib(ficlVm *vm, ficlTIB *pTib)
2285afc2ba1dSToomas Soome {
2286afc2ba1dSToomas Soome if (pTib) {
2287afc2ba1dSToomas Soome vm->tib = *pTib;
2288afc2ba1dSToomas Soome }
2289afc2ba1dSToomas Soome }
2290afc2ba1dSToomas Soome
2291afc2ba1dSToomas Soome /*
2292afc2ba1dSToomas Soome * v m Q u i t
2293afc2ba1dSToomas Soome */
2294afc2ba1dSToomas Soome void
ficlVmQuit(ficlVm * vm)2295afc2ba1dSToomas Soome ficlVmQuit(ficlVm *vm)
2296afc2ba1dSToomas Soome {
2297afc2ba1dSToomas Soome ficlStackReset(vm->returnStack);
2298afc2ba1dSToomas Soome vm->restart = 0;
2299afc2ba1dSToomas Soome vm->ip = NULL;
2300afc2ba1dSToomas Soome vm->runningWord = NULL;
2301afc2ba1dSToomas Soome vm->state = FICL_VM_STATE_INTERPRET;
2302afc2ba1dSToomas Soome vm->tib.text = NULL;
2303afc2ba1dSToomas Soome vm->tib.end = NULL;
2304afc2ba1dSToomas Soome vm->tib.index = 0;
2305afc2ba1dSToomas Soome vm->pad[0] = '\0';
2306afc2ba1dSToomas Soome vm->sourceId.i = 0;
2307afc2ba1dSToomas Soome }
2308afc2ba1dSToomas Soome
2309afc2ba1dSToomas Soome /*
2310afc2ba1dSToomas Soome * v m R e s e t
2311afc2ba1dSToomas Soome */
2312afc2ba1dSToomas Soome void
ficlVmReset(ficlVm * vm)2313afc2ba1dSToomas Soome ficlVmReset(ficlVm *vm)
2314afc2ba1dSToomas Soome {
2315afc2ba1dSToomas Soome ficlVmQuit(vm);
2316afc2ba1dSToomas Soome ficlStackReset(vm->dataStack);
2317afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
2318afc2ba1dSToomas Soome ficlStackReset(vm->floatStack);
2319afc2ba1dSToomas Soome #endif
2320afc2ba1dSToomas Soome vm->base = 10;
2321afc2ba1dSToomas Soome }
2322afc2ba1dSToomas Soome
2323afc2ba1dSToomas Soome /*
2324afc2ba1dSToomas Soome * v m S e t T e x t O u t
2325afc2ba1dSToomas Soome * Binds the specified output callback to the vm. If you pass NULL,
2326afc2ba1dSToomas Soome * binds the default output function (ficlTextOut)
2327afc2ba1dSToomas Soome */
2328afc2ba1dSToomas Soome void
ficlVmSetTextOut(ficlVm * vm,ficlOutputFunction textOut)2329afc2ba1dSToomas Soome ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
2330afc2ba1dSToomas Soome {
2331afc2ba1dSToomas Soome vm->callback.textOut = textOut;
2332afc2ba1dSToomas Soome }
2333afc2ba1dSToomas Soome
2334afc2ba1dSToomas Soome void
ficlVmTextOut(ficlVm * vm,char * text)2335afc2ba1dSToomas Soome ficlVmTextOut(ficlVm *vm, char *text)
2336afc2ba1dSToomas Soome {
2337afc2ba1dSToomas Soome ficlCallbackTextOut((ficlCallback *)vm, text);
2338afc2ba1dSToomas Soome }
2339afc2ba1dSToomas Soome
2340afc2ba1dSToomas Soome
2341afc2ba1dSToomas Soome void
ficlVmErrorOut(ficlVm * vm,char * text)2342afc2ba1dSToomas Soome ficlVmErrorOut(ficlVm *vm, char *text)
2343afc2ba1dSToomas Soome {
2344afc2ba1dSToomas Soome ficlCallbackErrorOut((ficlCallback *)vm, text);
2345afc2ba1dSToomas Soome }
2346afc2ba1dSToomas Soome
2347afc2ba1dSToomas Soome
2348afc2ba1dSToomas Soome /*
2349afc2ba1dSToomas Soome * v m T h r o w
2350afc2ba1dSToomas Soome */
2351afc2ba1dSToomas Soome void
ficlVmThrow(ficlVm * vm,int except)2352afc2ba1dSToomas Soome ficlVmThrow(ficlVm *vm, int except)
2353afc2ba1dSToomas Soome {
2354afc2ba1dSToomas Soome if (vm->exceptionHandler)
2355afc2ba1dSToomas Soome longjmp(*(vm->exceptionHandler), except);
2356afc2ba1dSToomas Soome }
2357afc2ba1dSToomas Soome
2358afc2ba1dSToomas Soome void
ficlVmThrowError(ficlVm * vm,char * fmt,...)2359afc2ba1dSToomas Soome ficlVmThrowError(ficlVm *vm, char *fmt, ...)
2360afc2ba1dSToomas Soome {
2361afc2ba1dSToomas Soome va_list list;
2362afc2ba1dSToomas Soome
2363afc2ba1dSToomas Soome va_start(list, fmt);
2364c0bb4f73SToomas Soome (void) vsprintf(vm->pad, fmt, list);
2365afc2ba1dSToomas Soome va_end(list);
2366c0bb4f73SToomas Soome (void) strcat(vm->pad, "\n");
2367afc2ba1dSToomas Soome
2368afc2ba1dSToomas Soome ficlVmErrorOut(vm, vm->pad);
2369afc2ba1dSToomas Soome longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
2370afc2ba1dSToomas Soome }
2371afc2ba1dSToomas Soome
2372afc2ba1dSToomas Soome void
ficlVmThrowErrorVararg(ficlVm * vm,char * fmt,va_list list)2373afc2ba1dSToomas Soome ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list)
2374afc2ba1dSToomas Soome {
2375c0bb4f73SToomas Soome (void) vsprintf(vm->pad, fmt, list);
2376afc2ba1dSToomas Soome /*
2377afc2ba1dSToomas Soome * well, we can try anyway, we're certainly not
2378afc2ba1dSToomas Soome * returning to our caller!
2379afc2ba1dSToomas Soome */
2380afc2ba1dSToomas Soome va_end(list);
2381c0bb4f73SToomas Soome (void) strcat(vm->pad, "\n");
2382afc2ba1dSToomas Soome
2383afc2ba1dSToomas Soome ficlVmErrorOut(vm, vm->pad);
2384afc2ba1dSToomas Soome longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
2385afc2ba1dSToomas Soome }
2386afc2ba1dSToomas Soome
2387afc2ba1dSToomas Soome /*
2388afc2ba1dSToomas Soome * f i c l E v a l u a t e
2389afc2ba1dSToomas Soome * Wrapper for ficlExec() which sets SOURCE-ID to -1.
2390afc2ba1dSToomas Soome */
2391afc2ba1dSToomas Soome int
ficlVmEvaluate(ficlVm * vm,char * s)2392afc2ba1dSToomas Soome ficlVmEvaluate(ficlVm *vm, char *s)
2393afc2ba1dSToomas Soome {
2394afc2ba1dSToomas Soome int returnValue;
2395afc2ba1dSToomas Soome ficlCell id = vm->sourceId;
2396afc2ba1dSToomas Soome ficlString string;
2397afc2ba1dSToomas Soome vm->sourceId.i = -1;
2398afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(string, s);
2399afc2ba1dSToomas Soome returnValue = ficlVmExecuteString(vm, string);
2400afc2ba1dSToomas Soome vm->sourceId = id;
2401afc2ba1dSToomas Soome return (returnValue);
2402afc2ba1dSToomas Soome }
2403afc2ba1dSToomas Soome
2404afc2ba1dSToomas Soome /*
2405afc2ba1dSToomas Soome * f i c l E x e c
2406afc2ba1dSToomas Soome * Evaluates a block of input text in the context of the
2407afc2ba1dSToomas Soome * specified interpreter. Emits any requested output to the
2408afc2ba1dSToomas Soome * interpreter's output function.
2409afc2ba1dSToomas Soome *
2410afc2ba1dSToomas Soome * Contains the "inner interpreter" code in a tight loop
2411afc2ba1dSToomas Soome *
2412afc2ba1dSToomas Soome * Returns one of the VM_XXXX codes defined in ficl.h:
2413afc2ba1dSToomas Soome * VM_OUTOFTEXT is the normal exit condition
2414afc2ba1dSToomas Soome * VM_ERREXIT means that the interpreter encountered a syntax error
2415afc2ba1dSToomas Soome * and the vm has been reset to recover (some or all
2416afc2ba1dSToomas Soome * of the text block got ignored
2417afc2ba1dSToomas Soome * VM_USEREXIT means that the user executed the "bye" command
2418afc2ba1dSToomas Soome * to shut down the interpreter. This would be a good
2419afc2ba1dSToomas Soome * time to delete the vm, etc -- or you can ignore this
2420afc2ba1dSToomas Soome * signal.
2421afc2ba1dSToomas Soome */
2422afc2ba1dSToomas Soome int
ficlVmExecuteString(ficlVm * vm,ficlString s)2423afc2ba1dSToomas Soome ficlVmExecuteString(ficlVm *vm, ficlString s)
2424afc2ba1dSToomas Soome {
2425afc2ba1dSToomas Soome ficlSystem *system = vm->callback.system;
2426afc2ba1dSToomas Soome ficlDictionary *dictionary = system->dictionary;
2427afc2ba1dSToomas Soome
2428afc2ba1dSToomas Soome int except;
2429afc2ba1dSToomas Soome jmp_buf vmState;
2430afc2ba1dSToomas Soome jmp_buf *oldState;
2431afc2ba1dSToomas Soome ficlTIB saveficlTIB;
2432afc2ba1dSToomas Soome
2433afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm);
2434afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, system->interpreterLoop[0]);
2435afc2ba1dSToomas Soome
2436afc2ba1dSToomas Soome ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s),
2437afc2ba1dSToomas Soome FICL_STRING_GET_LENGTH(s), &saveficlTIB);
2438afc2ba1dSToomas Soome
2439afc2ba1dSToomas Soome /*
2440afc2ba1dSToomas Soome * Save and restore VM's jmp_buf to enable nested calls to ficlExec
2441afc2ba1dSToomas Soome */
2442afc2ba1dSToomas Soome oldState = vm->exceptionHandler;
2443afc2ba1dSToomas Soome
2444afc2ba1dSToomas Soome /* This has to come before the setjmp! */
2445afc2ba1dSToomas Soome vm->exceptionHandler = &vmState;
2446afc2ba1dSToomas Soome except = setjmp(vmState);
2447afc2ba1dSToomas Soome
2448afc2ba1dSToomas Soome switch (except) {
2449afc2ba1dSToomas Soome case 0:
2450afc2ba1dSToomas Soome if (vm->restart) {
2451afc2ba1dSToomas Soome vm->runningWord->code(vm);
2452afc2ba1dSToomas Soome vm->restart = 0;
2453afc2ba1dSToomas Soome } else { /* set VM up to interpret text */
2454afc2ba1dSToomas Soome ficlVmPushIP(vm, &(system->interpreterLoop[0]));
2455afc2ba1dSToomas Soome }
2456afc2ba1dSToomas Soome
2457afc2ba1dSToomas Soome ficlVmInnerLoop(vm, 0);
2458afc2ba1dSToomas Soome break;
2459afc2ba1dSToomas Soome
2460afc2ba1dSToomas Soome case FICL_VM_STATUS_RESTART:
2461afc2ba1dSToomas Soome vm->restart = 1;
2462afc2ba1dSToomas Soome except = FICL_VM_STATUS_OUT_OF_TEXT;
2463afc2ba1dSToomas Soome break;
2464afc2ba1dSToomas Soome
2465afc2ba1dSToomas Soome case FICL_VM_STATUS_OUT_OF_TEXT:
2466afc2ba1dSToomas Soome ficlVmPopIP(vm);
2467afc2ba1dSToomas Soome #if 0 /* we dont output prompt in loader */
2468afc2ba1dSToomas Soome if ((vm->state != FICL_VM_STATE_COMPILE) &&
2469afc2ba1dSToomas Soome (vm->sourceId.i == 0))
2470afc2ba1dSToomas Soome ficlVmTextOut(vm, FICL_PROMPT);
2471afc2ba1dSToomas Soome #endif
2472afc2ba1dSToomas Soome break;
2473afc2ba1dSToomas Soome
2474afc2ba1dSToomas Soome case FICL_VM_STATUS_USER_EXIT:
2475afc2ba1dSToomas Soome case FICL_VM_STATUS_INNER_EXIT:
2476afc2ba1dSToomas Soome case FICL_VM_STATUS_BREAK:
2477afc2ba1dSToomas Soome break;
2478afc2ba1dSToomas Soome
2479afc2ba1dSToomas Soome case FICL_VM_STATUS_QUIT:
2480afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_COMPILE) {
2481afc2ba1dSToomas Soome ficlDictionaryAbortDefinition(dictionary);
2482afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2483afc2ba1dSToomas Soome ficlDictionaryEmpty(system->locals,
2484afc2ba1dSToomas Soome system->locals->forthWordlist->size);
2485afc2ba1dSToomas Soome #endif
2486afc2ba1dSToomas Soome }
2487afc2ba1dSToomas Soome ficlVmQuit(vm);
2488afc2ba1dSToomas Soome break;
2489afc2ba1dSToomas Soome
2490afc2ba1dSToomas Soome case FICL_VM_STATUS_ERROR_EXIT:
2491afc2ba1dSToomas Soome case FICL_VM_STATUS_ABORT:
2492afc2ba1dSToomas Soome case FICL_VM_STATUS_ABORTQ:
2493afc2ba1dSToomas Soome default: /* user defined exit code?? */
2494afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_COMPILE) {
2495afc2ba1dSToomas Soome ficlDictionaryAbortDefinition(dictionary);
2496afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2497afc2ba1dSToomas Soome ficlDictionaryEmpty(system->locals,
2498afc2ba1dSToomas Soome system->locals->forthWordlist->size);
2499afc2ba1dSToomas Soome #endif
2500afc2ba1dSToomas Soome }
2501afc2ba1dSToomas Soome ficlDictionaryResetSearchOrder(dictionary);
2502afc2ba1dSToomas Soome ficlVmReset(vm);
2503afc2ba1dSToomas Soome break;
2504afc2ba1dSToomas Soome }
2505afc2ba1dSToomas Soome
2506afc2ba1dSToomas Soome vm->exceptionHandler = oldState;
2507afc2ba1dSToomas Soome ficlVmPopTib(vm, &saveficlTIB);
2508afc2ba1dSToomas Soome return (except);
2509afc2ba1dSToomas Soome }
2510afc2ba1dSToomas Soome
2511afc2ba1dSToomas Soome /*
2512afc2ba1dSToomas Soome * f i c l E x e c X T
2513afc2ba1dSToomas Soome * Given a pointer to a ficlWord, push an inner interpreter and
2514afc2ba1dSToomas Soome * execute the word to completion. This is in contrast with vmExecute,
2515afc2ba1dSToomas Soome * which does not guarantee that the word will have completed when
2516afc2ba1dSToomas Soome * the function returns (ie in the case of colon definitions, which
2517afc2ba1dSToomas Soome * need an inner interpreter to finish)
2518afc2ba1dSToomas Soome *
2519afc2ba1dSToomas Soome * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
2520afc2ba1dSToomas Soome * exit condition is VM_INNEREXIT, Ficl's private signal to exit the
2521afc2ba1dSToomas Soome * inner loop under normal circumstances. If another code is thrown to
2522afc2ba1dSToomas Soome * exit the loop, this function will re-throw it if it's nested under
2523afc2ba1dSToomas Soome * itself or ficlExec.
2524afc2ba1dSToomas Soome *
2525afc2ba1dSToomas Soome * NOTE: this function is intended so that C code can execute ficlWords
2526afc2ba1dSToomas Soome * given their address in the dictionary (xt).
2527afc2ba1dSToomas Soome */
2528afc2ba1dSToomas Soome int
ficlVmExecuteXT(ficlVm * vm,ficlWord * pWord)2529afc2ba1dSToomas Soome ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord)
2530afc2ba1dSToomas Soome {
2531afc2ba1dSToomas Soome int except;
2532afc2ba1dSToomas Soome jmp_buf vmState;
2533afc2ba1dSToomas Soome jmp_buf *oldState;
2534afc2ba1dSToomas Soome ficlWord *oldRunningWord;
2535afc2ba1dSToomas Soome
2536afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm);
2537afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
2538afc2ba1dSToomas Soome
2539afc2ba1dSToomas Soome /*
2540afc2ba1dSToomas Soome * Save the runningword so that RESTART behaves correctly
2541afc2ba1dSToomas Soome * over nested calls.
2542afc2ba1dSToomas Soome */
2543afc2ba1dSToomas Soome oldRunningWord = vm->runningWord;
2544afc2ba1dSToomas Soome /*
2545afc2ba1dSToomas Soome * Save and restore VM's jmp_buf to enable nested calls
2546afc2ba1dSToomas Soome */
2547afc2ba1dSToomas Soome oldState = vm->exceptionHandler;
2548afc2ba1dSToomas Soome /* This has to come before the setjmp! */
2549afc2ba1dSToomas Soome vm->exceptionHandler = &vmState;
2550afc2ba1dSToomas Soome except = setjmp(vmState);
2551afc2ba1dSToomas Soome
2552afc2ba1dSToomas Soome if (except)
2553afc2ba1dSToomas Soome ficlVmPopIP(vm);
2554afc2ba1dSToomas Soome else
2555afc2ba1dSToomas Soome ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
2556afc2ba1dSToomas Soome
2557afc2ba1dSToomas Soome switch (except) {
2558afc2ba1dSToomas Soome case 0:
2559afc2ba1dSToomas Soome ficlVmExecuteWord(vm, pWord);
2560afc2ba1dSToomas Soome ficlVmInnerLoop(vm, 0);
2561afc2ba1dSToomas Soome break;
2562afc2ba1dSToomas Soome
2563afc2ba1dSToomas Soome case FICL_VM_STATUS_INNER_EXIT:
2564afc2ba1dSToomas Soome case FICL_VM_STATUS_BREAK:
2565afc2ba1dSToomas Soome break;
2566afc2ba1dSToomas Soome
2567afc2ba1dSToomas Soome case FICL_VM_STATUS_RESTART:
2568afc2ba1dSToomas Soome case FICL_VM_STATUS_OUT_OF_TEXT:
2569afc2ba1dSToomas Soome case FICL_VM_STATUS_USER_EXIT:
2570afc2ba1dSToomas Soome case FICL_VM_STATUS_QUIT:
2571afc2ba1dSToomas Soome case FICL_VM_STATUS_ERROR_EXIT:
2572afc2ba1dSToomas Soome case FICL_VM_STATUS_ABORT:
2573afc2ba1dSToomas Soome case FICL_VM_STATUS_ABORTQ:
2574afc2ba1dSToomas Soome default: /* user defined exit code?? */
2575afc2ba1dSToomas Soome if (oldState) {
2576afc2ba1dSToomas Soome vm->exceptionHandler = oldState;
2577afc2ba1dSToomas Soome ficlVmThrow(vm, except);
2578afc2ba1dSToomas Soome }
2579afc2ba1dSToomas Soome break;
2580afc2ba1dSToomas Soome }
2581afc2ba1dSToomas Soome
2582afc2ba1dSToomas Soome vm->exceptionHandler = oldState;
2583afc2ba1dSToomas Soome vm->runningWord = oldRunningWord;
2584afc2ba1dSToomas Soome return (except);
2585afc2ba1dSToomas Soome }
2586afc2ba1dSToomas Soome
2587afc2ba1dSToomas Soome /*
2588afc2ba1dSToomas Soome * f i c l P a r s e N u m b e r
2589afc2ba1dSToomas Soome * Attempts to convert the NULL terminated string in the VM's pad to
2590afc2ba1dSToomas Soome * a number using the VM's current base. If successful, pushes the number
2591afc2ba1dSToomas Soome * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE.
2592afc2ba1dSToomas Soome * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See
2593afc2ba1dSToomas Soome * the standard for DOUBLE wordset.
2594afc2ba1dSToomas Soome */
2595afc2ba1dSToomas Soome int
ficlVmParseNumber(ficlVm * vm,ficlString s)2596afc2ba1dSToomas Soome ficlVmParseNumber(ficlVm *vm, ficlString s)
2597afc2ba1dSToomas Soome {
2598afc2ba1dSToomas Soome ficlInteger accumulator = 0;
2599afc2ba1dSToomas Soome char isNegative = 0;
2600afc2ba1dSToomas Soome char isDouble = 0;
2601afc2ba1dSToomas Soome unsigned base = vm->base;
2602afc2ba1dSToomas Soome char *trace = FICL_STRING_GET_POINTER(s);
2603afc2ba1dSToomas Soome ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
2604afc2ba1dSToomas Soome unsigned c;
2605afc2ba1dSToomas Soome unsigned digit;
2606afc2ba1dSToomas Soome
2607afc2ba1dSToomas Soome if (length > 1) {
2608afc2ba1dSToomas Soome switch (*trace) {
2609afc2ba1dSToomas Soome case '-':
2610afc2ba1dSToomas Soome trace++;
2611afc2ba1dSToomas Soome length--;
2612afc2ba1dSToomas Soome isNegative = 1;
2613afc2ba1dSToomas Soome break;
2614afc2ba1dSToomas Soome case '+':
2615afc2ba1dSToomas Soome trace++;
2616afc2ba1dSToomas Soome length--;
2617afc2ba1dSToomas Soome isNegative = 0;
2618afc2ba1dSToomas Soome break;
2619afc2ba1dSToomas Soome default:
2620afc2ba1dSToomas Soome break;
2621afc2ba1dSToomas Soome }
2622afc2ba1dSToomas Soome }
2623afc2ba1dSToomas Soome
2624afc2ba1dSToomas Soome /* detect & remove trailing decimal */
2625afc2ba1dSToomas Soome if ((length > 0) && (trace[length - 1] == '.')) {
2626afc2ba1dSToomas Soome isDouble = 1;
2627afc2ba1dSToomas Soome length--;
2628afc2ba1dSToomas Soome }
2629afc2ba1dSToomas Soome
2630afc2ba1dSToomas Soome if (length == 0) /* detect "+", "-", ".", "+." etc */
2631afc2ba1dSToomas Soome return (0); /* false */
2632afc2ba1dSToomas Soome
2633afc2ba1dSToomas Soome while ((length--) && ((c = *trace++) != '\0')) {
2634afc2ba1dSToomas Soome if (!isalnum(c))
2635afc2ba1dSToomas Soome return (0); /* false */
2636afc2ba1dSToomas Soome
2637afc2ba1dSToomas Soome digit = c - '0';
2638afc2ba1dSToomas Soome
2639afc2ba1dSToomas Soome if (digit > 9)
2640afc2ba1dSToomas Soome digit = tolower(c) - 'a' + 10;
2641afc2ba1dSToomas Soome
2642afc2ba1dSToomas Soome if (digit >= base)
2643afc2ba1dSToomas Soome return (0); /* false */
2644afc2ba1dSToomas Soome
2645afc2ba1dSToomas Soome accumulator = accumulator * base + digit;
2646afc2ba1dSToomas Soome }
2647afc2ba1dSToomas Soome
2648afc2ba1dSToomas Soome if (isNegative)
2649afc2ba1dSToomas Soome accumulator = -accumulator;
2650afc2ba1dSToomas Soome
2651afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, accumulator);
2652afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_COMPILE)
2653afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(vm);
2654afc2ba1dSToomas Soome
2655afc2ba1dSToomas Soome if (isDouble) { /* simple (required) DOUBLE support */
2656afc2ba1dSToomas Soome if (isNegative)
2657afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, -1);
2658afc2ba1dSToomas Soome else
2659afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, 0);
2660afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_COMPILE)
2661afc2ba1dSToomas Soome ficlPrimitiveLiteralIm(vm);
2662afc2ba1dSToomas Soome }
2663afc2ba1dSToomas Soome
2664afc2ba1dSToomas Soome return (1); /* true */
2665afc2ba1dSToomas Soome }
2666afc2ba1dSToomas Soome
2667afc2ba1dSToomas Soome /*
2668afc2ba1dSToomas Soome * d i c t C h e c k
2669afc2ba1dSToomas Soome * Checks the dictionary for corruption and throws appropriate
2670afc2ba1dSToomas Soome * errors.
2671afc2ba1dSToomas Soome * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot
2672afc2ba1dSToomas Soome * -n number of ADDRESS UNITS proposed to de-allot
2673afc2ba1dSToomas Soome * 0 just do a consistency check
2674afc2ba1dSToomas Soome */
2675afc2ba1dSToomas Soome void
ficlVmDictionarySimpleCheck(ficlVm * vm,ficlDictionary * dictionary,int cells)2676afc2ba1dSToomas Soome ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
2677afc2ba1dSToomas Soome {
2678afc2ba1dSToomas Soome #if FICL_ROBUST >= 1
2679afc2ba1dSToomas Soome if ((cells >= 0) &&
2680afc2ba1dSToomas Soome (ficlDictionaryCellsAvailable(dictionary) *
2681afc2ba1dSToomas Soome (int)sizeof (ficlCell) < cells)) {
2682afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error: dictionary full");
2683afc2ba1dSToomas Soome }
2684afc2ba1dSToomas Soome
2685afc2ba1dSToomas Soome if ((cells <= 0) &&
2686afc2ba1dSToomas Soome (ficlDictionaryCellsUsed(dictionary) *
2687afc2ba1dSToomas Soome (int)sizeof (ficlCell) < -cells)) {
2688afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error: dictionary underflow");
2689afc2ba1dSToomas Soome }
2690afc2ba1dSToomas Soome #else /* FICL_ROBUST >= 1 */
2691afc2ba1dSToomas Soome FICL_IGNORE(vm);
2692afc2ba1dSToomas Soome FICL_IGNORE(dictionary);
2693afc2ba1dSToomas Soome FICL_IGNORE(cells);
2694afc2ba1dSToomas Soome #endif /* FICL_ROBUST >= 1 */
2695afc2ba1dSToomas Soome }
2696afc2ba1dSToomas Soome
2697afc2ba1dSToomas Soome void
ficlVmDictionaryCheck(ficlVm * vm,ficlDictionary * dictionary,int cells)2698afc2ba1dSToomas Soome ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
2699afc2ba1dSToomas Soome {
2700afc2ba1dSToomas Soome #if FICL_ROBUST >= 1
2701afc2ba1dSToomas Soome ficlVmDictionarySimpleCheck(vm, dictionary, cells);
2702afc2ba1dSToomas Soome
2703afc2ba1dSToomas Soome if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) {
2704afc2ba1dSToomas Soome ficlDictionaryResetSearchOrder(dictionary);
2705afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error: search order overflow");
2706afc2ba1dSToomas Soome } else if (dictionary->wordlistCount < 0) {
2707afc2ba1dSToomas Soome ficlDictionaryResetSearchOrder(dictionary);
2708afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error: search order underflow");
2709afc2ba1dSToomas Soome }
2710afc2ba1dSToomas Soome #else /* FICL_ROBUST >= 1 */
2711afc2ba1dSToomas Soome FICL_IGNORE(vm);
2712afc2ba1dSToomas Soome FICL_IGNORE(dictionary);
2713afc2ba1dSToomas Soome FICL_IGNORE(cells);
2714afc2ba1dSToomas Soome #endif /* FICL_ROBUST >= 1 */
2715afc2ba1dSToomas Soome }
2716afc2ba1dSToomas Soome
2717afc2ba1dSToomas Soome void
ficlVmDictionaryAllot(ficlVm * vm,ficlDictionary * dictionary,int n)2718afc2ba1dSToomas Soome ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n)
2719afc2ba1dSToomas Soome {
2720afc2ba1dSToomas Soome FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n);
2721afc2ba1dSToomas Soome FICL_IGNORE(vm);
2722afc2ba1dSToomas Soome ficlDictionaryAllot(dictionary, n);
2723afc2ba1dSToomas Soome }
2724afc2ba1dSToomas Soome
2725afc2ba1dSToomas Soome void
ficlVmDictionaryAllotCells(ficlVm * vm,ficlDictionary * dictionary,int cells)2726afc2ba1dSToomas Soome ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells)
2727afc2ba1dSToomas Soome {
2728afc2ba1dSToomas Soome FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells);
2729afc2ba1dSToomas Soome FICL_IGNORE(vm);
2730afc2ba1dSToomas Soome ficlDictionaryAllotCells(dictionary, cells);
2731afc2ba1dSToomas Soome }
2732afc2ba1dSToomas Soome
2733afc2ba1dSToomas Soome /*
2734afc2ba1dSToomas Soome * f i c l P a r s e W o r d
2735afc2ba1dSToomas Soome * From the standard, section 3.4
2736afc2ba1dSToomas Soome * b) Search the dictionary name space (see 3.4.2). If a definition name
2737afc2ba1dSToomas Soome * matching the string is found:
2738afc2ba1dSToomas Soome * 1.if interpreting, perform the interpretation semantics of the definition
2739afc2ba1dSToomas Soome * (see 3.4.3.2), and continue at a);
2740afc2ba1dSToomas Soome * 2.if compiling, perform the compilation semantics of the definition
2741afc2ba1dSToomas Soome * (see 3.4.3.3), and continue at a).
2742afc2ba1dSToomas Soome *
2743afc2ba1dSToomas Soome * c) If a definition name matching the string is not found, attempt to
2744afc2ba1dSToomas Soome * convert the string to a number (see 3.4.1.3). If successful:
2745afc2ba1dSToomas Soome * 1.if interpreting, place the number on the data stack, and continue at a);
2746afc2ba1dSToomas Soome * 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place
2747afc2ba1dSToomas Soome * the number on the stack (see 6.1.1780 LITERAL), and continue at a);
2748afc2ba1dSToomas Soome *
2749afc2ba1dSToomas Soome * d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
2750afc2ba1dSToomas Soome *
2751afc2ba1dSToomas Soome * (jws 4/01) Modified to be a ficlParseStep
2752afc2ba1dSToomas Soome */
2753afc2ba1dSToomas Soome int
ficlVmParseWord(ficlVm * vm,ficlString name)2754afc2ba1dSToomas Soome ficlVmParseWord(ficlVm *vm, ficlString name)
2755afc2ba1dSToomas Soome {
2756afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2757afc2ba1dSToomas Soome ficlWord *tempFW;
2758afc2ba1dSToomas Soome
2759afc2ba1dSToomas Soome FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
2760afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 0);
2761afc2ba1dSToomas Soome
2762afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
2763afc2ba1dSToomas Soome if (vm->callback.system->localsCount > 0) {
2764afc2ba1dSToomas Soome tempFW = ficlSystemLookupLocal(vm->callback.system, name);
2765afc2ba1dSToomas Soome } else
2766afc2ba1dSToomas Soome #endif
2767afc2ba1dSToomas Soome tempFW = ficlDictionaryLookup(dictionary, name);
2768afc2ba1dSToomas Soome
2769afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) {
2770afc2ba1dSToomas Soome if (tempFW != NULL) {
2771afc2ba1dSToomas Soome if (ficlWordIsCompileOnly(tempFW)) {
2772afc2ba1dSToomas Soome ficlVmThrowError(vm,
2773afc2ba1dSToomas Soome "Error: FICL_VM_STATE_COMPILE only!");
2774afc2ba1dSToomas Soome }
2775afc2ba1dSToomas Soome
2776afc2ba1dSToomas Soome ficlVmExecuteWord(vm, tempFW);
2777afc2ba1dSToomas Soome return (1); /* true */
2778afc2ba1dSToomas Soome }
2779afc2ba1dSToomas Soome } else { /* (vm->state == FICL_VM_STATE_COMPILE) */
2780afc2ba1dSToomas Soome if (tempFW != NULL) {
2781afc2ba1dSToomas Soome if (ficlWordIsImmediate(tempFW)) {
2782afc2ba1dSToomas Soome ficlVmExecuteWord(vm, tempFW);
2783afc2ba1dSToomas Soome } else {
2784afc2ba1dSToomas Soome ficlCell c;
2785afc2ba1dSToomas Soome c.p = tempFW;
2786afc2ba1dSToomas Soome if (tempFW->flags & FICL_WORD_INSTRUCTION)
2787afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
2788afc2ba1dSToomas Soome (ficlInteger)tempFW->code);
2789afc2ba1dSToomas Soome else
2790afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, c);
2791afc2ba1dSToomas Soome }
2792afc2ba1dSToomas Soome return (1); /* true */
2793afc2ba1dSToomas Soome }
2794afc2ba1dSToomas Soome }
2795afc2ba1dSToomas Soome
2796afc2ba1dSToomas Soome return (0); /* false */
2797afc2ba1dSToomas Soome }
2798