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