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
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 *
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
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
131 ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord)
132 {
133 ficlVmInnerLoop(vm, pWord);
134 }
135
136 static void
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
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
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 *
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 *
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
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
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
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
2192 ficlVmParseString(ficlVm *vm, char delimiter)
2193 {
2194 return (ficlVmParseStringEx(vm, delimiter, 1));
2195 }
2196
2197 ficlString
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
2235 ficlVmPop(ficlVm *vm)
2236 {
2237 return (ficlStackPop(vm->dataStack));
2238 }
2239
2240 /*
2241 * v m P u s h
2242 */
2243 void
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
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
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
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
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
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
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
2329 ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
2330 {
2331 vm->callback.textOut = textOut;
2332 }
2333
2334 void
2335 ficlVmTextOut(ficlVm *vm, char *text)
2336 {
2337 ficlCallbackTextOut((ficlCallback *)vm, text);
2338 }
2339
2340
2341 void
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
2352 ficlVmThrow(ficlVm *vm, int except)
2353 {
2354 if (vm->exceptionHandler)
2355 longjmp(*(vm->exceptionHandler), except);
2356 }
2357
2358 void
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
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
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
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
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
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
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
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
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
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
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 }