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