?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
dmake: do not set MAKEFLAGS=k
[unleashed/tickless.git] / usr / src / common / ficl / vm.c
bloba284008deb77bac2857e2c38f3c89e8a20dcfa83
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 case ficlInstructionBranchParen:
151 destination++;
152 destination += *(ficlInteger *)destination;
153 *ip = (ficlWord *)(destination - ip);
154 break;
155 }
156 }
157 }
158
159 /*
160 * v m I n n e r L o o p
161 * the mysterious inner interpreter...
162 * This loop is the address interpreter that makes colon definitions
163 * work. Upon entry, it assumes that the IP points to an entry in
164 * a definition (the body of a colon word). It runs one word at a time
165 * until something does vmThrow. The catcher for this is expected to exist
166 * in the calling code.
167 * vmThrow gets you out of this loop with a longjmp()
168 */
169
170 #if FICL_ROBUST <= 1
171 /* turn off stack checking for primitives */
172 #define _CHECK_STACK(stack, top, pop, push)
173 #else
174
175 #define _CHECK_STACK(stack, top, pop, push) \
176 ficlStackCheckNospill(stack, top, pop, push)
177
178 FICL_PLATFORM_INLINE void
179 ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells,
180 int pushCells)
181 {
182 /*
183 * Why save and restore stack->top?
184 * So the simple act of stack checking doesn't force a "register" spill,
185 * which might mask bugs (places where we needed to spill but didn't).
186 * --lch
187 */
188 ficlCell *oldTop = stack->top;
189 stack->top = top;
190 ficlStackCheck(stack, popCells, pushCells);
191 stack->top = oldTop;
192 }
193
194 #endif /* FICL_ROBUST <= 1 */
195
196 #define CHECK_STACK(pop, push) \
197 _CHECK_STACK(vm->dataStack, dataTop, pop, push)
198 #define CHECK_FLOAT_STACK(pop, push) \
199 _CHECK_STACK(vm->floatStack, floatTop, pop, push)
200 #define CHECK_RETURN_STACK(pop, push) \
201 _CHECK_STACK(vm->returnStack, returnTop, pop, push)
202
203 #if FICL_WANT_FLOAT
204 #define FLOAT_LOCAL_VARIABLE_SPILL \
205 vm->floatStack->top = floatTop;
206 #define FLOAT_LOCAL_VARIABLE_REFILL \
207 floatTop = vm->floatStack->top;
208 #else
209 #define FLOAT_LOCAL_VARIABLE_SPILL
210 #define FLOAT_LOCAL_VARIABLE_REFILL
211 #endif /* FICL_WANT_FLOAT */
212
213 #if FICL_WANT_LOCALS
214 #define LOCALS_LOCAL_VARIABLE_SPILL \
215 vm->returnStack->frame = frame;
216 #define LOCALS_LOCAL_VARIABLE_REFILL \
217 frame = vm->returnStack->frame;
218 #else
219 #define LOCALS_LOCAL_VARIABLE_SPILL
220 #define LOCALS_LOCAL_VARIABLE_REFILL
221 #endif /* FICL_WANT_FLOAT */
222
223 #define LOCAL_VARIABLE_SPILL \
224 vm->ip = (ficlIp)ip; \
225 vm->dataStack->top = dataTop; \
226 vm->returnStack->top = returnTop; \
227 FLOAT_LOCAL_VARIABLE_SPILL \
228 LOCALS_LOCAL_VARIABLE_SPILL
229
230 #define LOCAL_VARIABLE_REFILL \
231 ip = (ficlInstruction *)vm->ip; \
232 dataTop = vm->dataStack->top; \
233 returnTop = vm->returnStack->top; \
234 FLOAT_LOCAL_VARIABLE_REFILL \
235 LOCALS_LOCAL_VARIABLE_REFILL
236
237 void
238 ficlVmInnerLoop(ficlVm *vm, ficlWord *fw)
239 {
240 register ficlInstruction *ip;
241 register ficlCell *dataTop;
242 register ficlCell *returnTop;
243 #if FICL_WANT_FLOAT
244 register ficlCell *floatTop;
245 ficlFloat f;
246 #endif /* FICL_WANT_FLOAT */
247 #if FICL_WANT_LOCALS
248 register ficlCell *frame;
249 #endif /* FICL_WANT_LOCALS */
250 jmp_buf *oldExceptionHandler;
251 jmp_buf exceptionHandler;
252 int except;
253 int once;
254 int count;
255 ficlInstruction instruction;
256 ficlInteger i;
257 ficlUnsigned u;
258 ficlCell c;
259 ficlCountedString *s;
260 ficlCell *cell;
261 char *cp;
262
263 once = (fw != NULL);
264 if (once)
265 count = 1;
266
267 oldExceptionHandler = vm->exceptionHandler;
268 /* This has to come before the setjmp! */
269 vm->exceptionHandler = &exceptionHandler;
270 except = setjmp(exceptionHandler);
271
272 LOCAL_VARIABLE_REFILL;
273
274 if (except) {
275 LOCAL_VARIABLE_SPILL;
276 vm->exceptionHandler = oldExceptionHandler;
277 ficlVmThrow(vm, except);
278 }
279
280 for (;;) {
281 if (once) {
282 if (!count--)
283 break;
284 instruction = (ficlInstruction)((void *)fw);
285 } else {
286 instruction = *ip++;
287 fw = (ficlWord *)instruction;
288 }
289
290 AGAIN:
291 switch (instruction) {
292 case ficlInstructionInvalid:
293 ficlVmThrowError(vm,
294 "Error: NULL instruction executed!");
295 return;
296
297 case ficlInstruction1:
298 case ficlInstruction2:
299 case ficlInstruction3:
300 case ficlInstruction4:
301 case ficlInstruction5:
302 case ficlInstruction6:
303 case ficlInstruction7:
304 case ficlInstruction8:
305 case ficlInstruction9:
306 case ficlInstruction10:
307 case ficlInstruction11:
308 case ficlInstruction12:
309 case ficlInstruction13:
310 case ficlInstruction14:
311 case ficlInstruction15:
312 case ficlInstruction16:
313 CHECK_STACK(0, 1);
314 (++dataTop)->i = instruction;
315 continue;
316
317 case ficlInstruction0:
318 case ficlInstructionNeg1:
319 case ficlInstructionNeg2:
320 case ficlInstructionNeg3:
321 case ficlInstructionNeg4:
322 case ficlInstructionNeg5:
323 case ficlInstructionNeg6:
324 case ficlInstructionNeg7:
325 case ficlInstructionNeg8:
326 case ficlInstructionNeg9:
327 case ficlInstructionNeg10:
328 case ficlInstructionNeg11:
329 case ficlInstructionNeg12:
330 case ficlInstructionNeg13:
331 case ficlInstructionNeg14:
332 case ficlInstructionNeg15:
333 case ficlInstructionNeg16:
334 CHECK_STACK(0, 1);
335 (++dataTop)->i = ficlInstruction0 - instruction;
336 continue;
337
338 /*
339 * stringlit: Fetch the count from the dictionary, then push
340 * the address and count on the stack. Finally, update ip to
341 * point to the first aligned address after the string text.
342 */
343 case ficlInstructionStringLiteralParen: {
344 ficlUnsigned8 length;
345 CHECK_STACK(0, 2);
346
347 s = (ficlCountedString *)(ip);
348 length = s->length;
349 cp = s->text;
350 (++dataTop)->p = cp;
351 (++dataTop)->i = length;
352
353 cp += length + 1;
354 cp = ficlAlignPointer(cp);
355 ip = (void *)cp;
356 continue;
357 }
358
359 case ficlInstructionCStringLiteralParen:
360 CHECK_STACK(0, 1);
361
362 s = (ficlCountedString *)(ip);
363 cp = s->text + s->length + 1;
364 cp = ficlAlignPointer(cp);
365 ip = (void *)cp;
366 (++dataTop)->p = s;
367 continue;
368
369 #if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE
370 #if FICL_WANT_FLOAT
371 FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC:
372 *++floatTop = cell[1];
373 /* intentional fall-through */
374 FLOAT_PUSH_CELL_POINTER_MINIPROC:
375 *++floatTop = cell[0];
376 continue;
377
378 FLOAT_POP_CELL_POINTER_MINIPROC:
379 cell[0] = *floatTop--;
380 continue;
381
382 FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC:
383 cell[0] = *floatTop--;
384 cell[1] = *floatTop--;
385 continue;
386
387 #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \
388 cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC
389 #define FLOAT_PUSH_CELL_POINTER(cp) \
390 cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC
391 #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \
392 cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC
393 #define FLOAT_POP_CELL_POINTER(cp) \
394 cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC
395 #endif /* FICL_WANT_FLOAT */
396
397 /*
398 * Think of these as little mini-procedures.
399 * --lch
400 */
401 PUSH_CELL_POINTER_DOUBLE_MINIPROC:
402 *++dataTop = cell[1];
403 /* intentional fall-through */
404 PUSH_CELL_POINTER_MINIPROC:
405 *++dataTop = cell[0];
406 continue;
407
408 POP_CELL_POINTER_MINIPROC:
409 cell[0] = *dataTop--;
410 continue;
411 POP_CELL_POINTER_DOUBLE_MINIPROC:
412 cell[0] = *dataTop--;
413 cell[1] = *dataTop--;
414 continue;
415
416 #define PUSH_CELL_POINTER_DOUBLE(cp) \
417 cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC
418 #define PUSH_CELL_POINTER(cp) \
419 cell = (cp); goto PUSH_CELL_POINTER_MINIPROC
420 #define POP_CELL_POINTER_DOUBLE(cp) \
421 cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC
422 #define POP_CELL_POINTER(cp) \
423 cell = (cp); goto POP_CELL_POINTER_MINIPROC
424
425 BRANCH_MINIPROC:
426 ip += *(ficlInteger *)ip;
427 continue;
428
429 #define BRANCH() goto BRANCH_MINIPROC
430
431 EXIT_FUNCTION_MINIPROC:
432 ip = (ficlInstruction *)((returnTop--)->p);
433 continue;
434
435 #define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC
436
437 #else /* FICL_WANT_SIZE */
438
439 #if FICL_WANT_FLOAT
440 #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \
441 cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue
442 #define FLOAT_PUSH_CELL_POINTER(cp) \
443 cell = (cp); *++floatTop = *cell; continue
444 #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \
445 cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue
446 #define FLOAT_POP_CELL_POINTER(cp) \
447 cell = (cp); *cell = *floatTop--; continue
448 #endif /* FICL_WANT_FLOAT */
449
450 #define PUSH_CELL_POINTER_DOUBLE(cp) \
451 cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue
452 #define PUSH_CELL_POINTER(cp) \
453 cell = (cp); *++dataTop = *cell; continue
454 #define POP_CELL_POINTER_DOUBLE(cp) \
455 cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue
456 #define POP_CELL_POINTER(cp) \
457 cell = (cp); *cell = *dataTop--; continue
458
459 #define BRANCH() ip += *(ficlInteger *)ip; continue
460 #define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue
461
462 #endif /* FICL_WANT_SIZE */
463
464
465 /*
466 * This is the runtime for (literal). It assumes that it is
467 * part of a colon definition, and that the next ficlCell
468 * contains a value to be pushed on the parameter stack at
469 * runtime. This code is compiled by "literal".
470 */
471
472 case ficlInstructionLiteralParen:
473 CHECK_STACK(0, 1);
474 (++dataTop)->i = *ip++;
475 continue;
476
477 case ficlInstruction2LiteralParen:
478 CHECK_STACK(0, 2);
479 (++dataTop)->i = ip[1];
480 (++dataTop)->i = ip[0];
481 ip += 2;
482 continue;
483
484 #if FICL_WANT_LOCALS
485 /*
486 * Link a frame on the return stack, reserving nCells of space
487 * for locals - the value of nCells is the next ficlCell in
488 * the instruction stream.
489 * 1) Push frame onto returnTop
490 * 2) frame = returnTop
491 * 3) returnTop += nCells
492 */
493 case ficlInstructionLinkParen: {
494 ficlInteger nCells = *ip++;
495 (++returnTop)->p = frame;
496 frame = returnTop + 1;
497 returnTop += nCells;
498 continue;
499 }
500
501 /*
502 * Unink a stack frame previously created by stackLink
503 * 1) dataTop = frame
504 * 2) frame = pop()
505 */
506 case ficlInstructionUnlinkParen:
507 returnTop = frame - 1;
508 frame = (returnTop--)->p;
509 continue;
510
511 /*
512 * Immediate - cfa of a local while compiling - when executed,
513 * compiles code to fetch the value of a local given the
514 * local's index in the word's pfa
515 */
516 #if FICL_WANT_FLOAT
517 case ficlInstructionGetF2LocalParen:
518 FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
519
520 case ficlInstructionGetFLocalParen:
521 FLOAT_PUSH_CELL_POINTER(frame + *ip++);
522
523 case ficlInstructionToF2LocalParen:
524 FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++);
525
526 case ficlInstructionToFLocalParen:
527 FLOAT_POP_CELL_POINTER(frame + *ip++);
528 #endif /* FICL_WANT_FLOAT */
529
530 case ficlInstructionGet2LocalParen:
531 PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
532
533 case ficlInstructionGetLocalParen:
534 PUSH_CELL_POINTER(frame + *ip++);
535
536 /*
537 * Immediate - cfa of a local while compiling - when executed,
538 * compiles code to store the value of a local given the
539 * local's index in the word's pfa
540 */
541
542 case ficlInstructionTo2LocalParen:
543 POP_CELL_POINTER_DOUBLE(frame + *ip++);
544
545 case ficlInstructionToLocalParen:
546 POP_CELL_POINTER(frame + *ip++);
547
548 /*
549 * Silly little minor optimizations.
550 * --lch
551 */
552 case ficlInstructionGetLocal0:
553 PUSH_CELL_POINTER(frame);
554
555 case ficlInstructionGetLocal1:
556 PUSH_CELL_POINTER(frame + 1);
557
558 case ficlInstructionGet2Local0:
559 PUSH_CELL_POINTER_DOUBLE(frame);
560
561 case ficlInstructionToLocal0:
562 POP_CELL_POINTER(frame);
563
564 case ficlInstructionToLocal1:
565 POP_CELL_POINTER(frame + 1);
566
567 case ficlInstructionTo2Local0:
568 POP_CELL_POINTER_DOUBLE(frame);
569
570 #endif /* FICL_WANT_LOCALS */
571
572 case ficlInstructionPlus:
573 CHECK_STACK(2, 1);
574 i = (dataTop--)->i;
575 dataTop->i += i;
576 continue;
577
578 case ficlInstructionMinus:
579 CHECK_STACK(2, 1);
580 i = (dataTop--)->i;
581 dataTop->i -= i;
582 continue;
583
584 case ficlInstruction1Plus:
585 CHECK_STACK(1, 1);
586 dataTop->i++;
587 continue;
588
589 case ficlInstruction1Minus:
590 CHECK_STACK(1, 1);
591 dataTop->i--;
592 continue;
593
594 case ficlInstruction2Plus:
595 CHECK_STACK(1, 1);
596 dataTop->i += 2;
597 continue;
598
599 case ficlInstruction2Minus:
600 CHECK_STACK(1, 1);
601 dataTop->i -= 2;
602 continue;
603
604 case ficlInstructionDup: {
605 ficlInteger i = dataTop->i;
606 CHECK_STACK(0, 1);
607 (++dataTop)->i = i;
608 continue;
609 }
610
611 case ficlInstructionQuestionDup:
612 CHECK_STACK(1, 2);
613
614 if (dataTop->i != 0) {
615 dataTop[1] = dataTop[0];
616 dataTop++;
617 }
618
619 continue;
620
621 case ficlInstructionSwap: {
622 ficlCell swap;
623 CHECK_STACK(2, 2);
624 swap = dataTop[0];
625 dataTop[0] = dataTop[-1];
626 dataTop[-1] = swap;
627 }
628 continue;
629
630 case ficlInstructionDrop:
631 CHECK_STACK(1, 0);
632 dataTop--;
633 continue;
634
635 case ficlInstruction2Drop:
636 CHECK_STACK(2, 0);
637 dataTop -= 2;
638 continue;
639
640 case ficlInstruction2Dup:
641 CHECK_STACK(2, 4);
642 dataTop[1] = dataTop[-1];
643 dataTop[2] = *dataTop;
644 dataTop += 2;
645 continue;
646
647 case ficlInstructionOver:
648 CHECK_STACK(2, 3);
649 dataTop[1] = dataTop[-1];
650 dataTop++;
651 continue;
652
653 case ficlInstruction2Over:
654 CHECK_STACK(4, 6);
655 dataTop[1] = dataTop[-3];
656 dataTop[2] = dataTop[-2];
657 dataTop += 2;
658 continue;
659
660 case ficlInstructionPick:
661 CHECK_STACK(1, 0);
662 i = dataTop->i;
663 if (i < 0)
664 continue;
665 CHECK_STACK(i + 2, i + 3);
666 *dataTop = dataTop[-i - 1];
667 continue;
668
669 /*
670 * Do stack rot.
671 * rot ( 1 2 3 -- 2 3 1 )
672 */
673 case ficlInstructionRot:
674 i = 2;
675 goto ROLL;
676
677 /*
678 * Do stack roll.
679 * roll ( n -- )
680 */
681 case ficlInstructionRoll:
682 CHECK_STACK(1, 0);
683 i = (dataTop--)->i;
684
685 if (i < 1)
686 continue;
687
688 ROLL:
689 CHECK_STACK(i+1, i+2);
690 c = dataTop[-i];
691 memmove(dataTop - i, dataTop - (i - 1),
692 i * sizeof (ficlCell));
693 *dataTop = c;
694 continue;
695
696 /*
697 * Do stack -rot.
698 * -rot ( 1 2 3 -- 3 1 2 )
699 */
700 case ficlInstructionMinusRot:
701 i = 2;
702 goto MINUSROLL;
703
704 /*
705 * Do stack -roll.
706 * -roll ( n -- )
707 */
708 case ficlInstructionMinusRoll:
709 CHECK_STACK(1, 0);
710 i = (dataTop--)->i;
711
712 if (i < 1)
713 continue;
714
715 MINUSROLL:
716 CHECK_STACK(i+1, i+2);
717 c = *dataTop;
718 memmove(dataTop - (i - 1), dataTop - i,
719 i * sizeof (ficlCell));
720 dataTop[-i] = c;
721
722 continue;
723
724 /*
725 * Do stack 2swap
726 * 2swap ( 1 2 3 4 -- 3 4 1 2 )
727 */
728 case ficlInstruction2Swap: {
729 ficlCell c2;
730 CHECK_STACK(4, 4);
731
732 c = *dataTop;
733 c2 = dataTop[-1];
734
735 *dataTop = dataTop[-2];
736 dataTop[-1] = dataTop[-3];
737
738 dataTop[-2] = c;
739 dataTop[-3] = c2;
740 continue;
741 }
742
743 case ficlInstructionPlusStore: {
744 ficlCell *cell;
745 CHECK_STACK(2, 0);
746 cell = (ficlCell *)(dataTop--)->p;
747 cell->i += (dataTop--)->i;
748 continue;
749 }
750
751 case ficlInstructionQuadFetch: {
752 ficlUnsigned32 *integer32;
753 CHECK_STACK(1, 1);
754 integer32 = (ficlUnsigned32 *)dataTop->i;
755 dataTop->u = (ficlUnsigned)*integer32;
756 continue;
757 }
758
759 case ficlInstructionQuadStore: {
760 ficlUnsigned32 *integer32;
761 CHECK_STACK(2, 0);
762 integer32 = (ficlUnsigned32 *)(dataTop--)->p;
763 *integer32 = (ficlUnsigned32)((dataTop--)->u);
764 continue;
765 }
766
767 case ficlInstructionWFetch: {
768 ficlUnsigned16 *integer16;
769 CHECK_STACK(1, 1);
770 integer16 = (ficlUnsigned16 *)dataTop->p;
771 dataTop->u = ((ficlUnsigned)*integer16);
772 continue;
773 }
774
775 case ficlInstructionWStore: {
776 ficlUnsigned16 *integer16;
777 CHECK_STACK(2, 0);
778 integer16 = (ficlUnsigned16 *)(dataTop--)->p;
779 *integer16 = (ficlUnsigned16)((dataTop--)->u);
780 continue;
781 }
782
783 case ficlInstructionCFetch: {
784 ficlUnsigned8 *integer8;
785 CHECK_STACK(1, 1);
786 integer8 = (ficlUnsigned8 *)dataTop->p;
787 dataTop->u = ((ficlUnsigned)*integer8);
788 continue;
789 }
790
791 case ficlInstructionCStore: {
792 ficlUnsigned8 *integer8;
793 CHECK_STACK(2, 0);
794 integer8 = (ficlUnsigned8 *)(dataTop--)->p;
795 *integer8 = (ficlUnsigned8)((dataTop--)->u);
796 continue;
797 }
798
799
800 /*
801 * l o g i c a n d c o m p a r i s o n s
802 */
803
804 case ficlInstruction0Equals:
805 CHECK_STACK(1, 1);
806 dataTop->i = FICL_BOOL(dataTop->i == 0);
807 continue;
808
809 case ficlInstruction0Less:
810 CHECK_STACK(1, 1);
811 dataTop->i = FICL_BOOL(dataTop->i < 0);
812 continue;
813
814 case ficlInstruction0Greater:
815 CHECK_STACK(1, 1);
816 dataTop->i = FICL_BOOL(dataTop->i > 0);
817 continue;
818
819 case ficlInstructionEquals:
820 CHECK_STACK(2, 1);
821 i = (dataTop--)->i;
822 dataTop->i = FICL_BOOL(dataTop->i == i);
823 continue;
824
825 case ficlInstructionLess:
826 CHECK_STACK(2, 1);
827 i = (dataTop--)->i;
828 dataTop->i = FICL_BOOL(dataTop->i < i);
829 continue;
830
831 case ficlInstructionULess:
832 CHECK_STACK(2, 1);
833 u = (dataTop--)->u;
834 dataTop->i = FICL_BOOL(dataTop->u < u);
835 continue;
836
837 case ficlInstructionAnd:
838 CHECK_STACK(2, 1);
839 i = (dataTop--)->i;
840 dataTop->i = dataTop->i & i;
841 continue;
842
843 case ficlInstructionOr:
844 CHECK_STACK(2, 1);
845 i = (dataTop--)->i;
846 dataTop->i = dataTop->i | i;
847 continue;
848
849 case ficlInstructionXor:
850 CHECK_STACK(2, 1);
851 i = (dataTop--)->i;
852 dataTop->i = dataTop->i ^ i;
853 continue;
854
855 case ficlInstructionInvert:
856 CHECK_STACK(1, 1);
857 dataTop->i = ~dataTop->i;
858 continue;
859
860 /*
861 * r e t u r n s t a c k
862 */
863 case ficlInstructionToRStack:
864 CHECK_STACK(1, 0);
865 CHECK_RETURN_STACK(0, 1);
866 *++returnTop = *dataTop--;
867 continue;
868
869 case ficlInstructionFromRStack:
870 CHECK_STACK(0, 1);
871 CHECK_RETURN_STACK(1, 0);
872 *++dataTop = *returnTop--;
873 continue;
874
875 case ficlInstructionFetchRStack:
876 CHECK_STACK(0, 1);
877 CHECK_RETURN_STACK(1, 1);
878 *++dataTop = *returnTop;
879 continue;
880
881 case ficlInstruction2ToR:
882 CHECK_STACK(2, 0);
883 CHECK_RETURN_STACK(0, 2);
884 *++returnTop = dataTop[-1];
885 *++returnTop = dataTop[0];
886 dataTop -= 2;
887 continue;
888
889 case ficlInstruction2RFrom:
890 CHECK_STACK(0, 2);
891 CHECK_RETURN_STACK(2, 0);
892 *++dataTop = returnTop[-1];
893 *++dataTop = returnTop[0];
894 returnTop -= 2;
895 continue;
896
897 case ficlInstruction2RFetch:
898 CHECK_STACK(0, 2);
899 CHECK_RETURN_STACK(2, 2);
900 *++dataTop = returnTop[-1];
901 *++dataTop = returnTop[0];
902 continue;
903
904 /*
905 * f i l l
906 * CORE ( c-addr u char -- )
907 * If u is greater than zero, store char in each of u
908 * consecutive characters of memory beginning at c-addr.
909 */
910 case ficlInstructionFill: {
911 char c;
912 char *memory;
913 CHECK_STACK(3, 0);
914 c = (char)(dataTop--)->i;
915 u = (dataTop--)->u;
916 memory = (char *)(dataTop--)->p;
917
918 /*
919 * memset() is faster than the previous hand-rolled
920 * solution. --lch
921 */
922 memset(memory, c, u);
923 continue;
924 }
925
926 /*
927 * l s h i f t
928 * l-shift CORE ( x1 u -- x2 )
929 * Perform a logical left shift of u bit-places on x1,
930 * giving x2. Put zeroes into the least significant bits
931 * vacated by the shift. An ambiguous condition exists if
932 * u is greater than or equal to the number of bits in a
933 * ficlCell.
934 *
935 * r-shift CORE ( x1 u -- x2 )
936 * Perform a logical right shift of u bit-places on x1,
937 * giving x2. Put zeroes into the most significant bits
938 * vacated by the shift. An ambiguous condition exists
939 * if u is greater than or equal to the number of bits
940 * in a ficlCell.
941 */
942 case ficlInstructionLShift: {
943 ficlUnsigned nBits;
944 ficlUnsigned x1;
945 CHECK_STACK(2, 1);
946
947 nBits = (dataTop--)->u;
948 x1 = dataTop->u;
949 dataTop->u = x1 << nBits;
950 continue;
951 }
952
953 case ficlInstructionRShift: {
954 ficlUnsigned nBits;
955 ficlUnsigned x1;
956 CHECK_STACK(2, 1);
957
958 nBits = (dataTop--)->u;
959 x1 = dataTop->u;
960 dataTop->u = x1 >> nBits;
961 continue;
962 }
963
964 /*
965 * m a x & m i n
966 */
967 case ficlInstructionMax: {
968 ficlInteger n2;
969 ficlInteger n1;
970 CHECK_STACK(2, 1);
971
972 n2 = (dataTop--)->i;
973 n1 = dataTop->i;
974
975 dataTop->i = ((n1 > n2) ? n1 : n2);
976 continue;
977 }
978
979 case ficlInstructionMin: {
980 ficlInteger n2;
981 ficlInteger n1;
982 CHECK_STACK(2, 1);
983
984 n2 = (dataTop--)->i;
985 n1 = dataTop->i;
986
987 dataTop->i = ((n1 < n2) ? n1 : n2);
988 continue;
989 }
990
991 /*
992 * m o v e
993 * CORE ( addr1 addr2 u -- )
994 * If u is greater than zero, copy the contents of u
995 * consecutive address units at addr1 to the u consecutive
996 * address units at addr2. After MOVE completes, the u
997 * consecutive address units at addr2 contain exactly
998 * what the u consecutive address units at addr1 contained
999 * before the move.
1000 * NOTE! This implementation assumes that a char is the same
1001 * size as an address unit.
1002 */
1003 case ficlInstructionMove: {
1004 ficlUnsigned u;
1005 char *addr2;
1006 char *addr1;
1007 CHECK_STACK(3, 0);
1008
1009 u = (dataTop--)->u;
1010 addr2 = (dataTop--)->p;
1011 addr1 = (dataTop--)->p;
1012
1013 if (u == 0)
1014 continue;
1015 /*
1016 * Do the copy carefully, so as to be
1017 * correct even if the two ranges overlap
1018 */
1019 /* Which ANSI C's memmove() does for you! Yay! --lch */
1020 memmove(addr2, addr1, u);
1021 continue;
1022 }
1023
1024 /*
1025 * s t o d
1026 * s-to-d CORE ( n -- d )
1027 * Convert the number n to the double-ficlCell number d with
1028 * the same numerical value.
1029 */
1030 case ficlInstructionSToD: {
1031 ficlInteger s;
1032 CHECK_STACK(1, 2);
1033
1034 s = dataTop->i;
1035
1036 /* sign extend to 64 bits.. */
1037 (++dataTop)->i = (s < 0) ? -1 : 0;
1038 continue;
1039 }
1040
1041 /*
1042 * c o m p a r e
1043 * STRING ( c-addr1 u1 c-addr2 u2 -- n )
1044 * Compare the string specified by c-addr1 u1 to the string
1045 * specified by c-addr2 u2. The strings are compared, beginning
1046 * at the given addresses, character by character, up to the
1047 * length of the shorter string or until a difference is found.
1048 * If the two strings are identical, n is zero. If the two
1049 * strings are identical up to the length of the shorter string,
1050 * n is minus-one (-1) if u1 is less than u2 and one (1)
1051 * otherwise. If the two strings are not identical up to the
1052 * length of the shorter string, n is minus-one (-1) if the
1053 * first non-matching character in the string specified by
1054 * c-addr1 u1 has a lesser numeric value than the corresponding
1055 * character in the string specified by c-addr2 u2 and
1056 * one (1) otherwise.
1057 */
1058 case ficlInstructionCompare:
1059 i = FICL_FALSE;
1060 goto COMPARE;
1061
1062
1063 case ficlInstructionCompareInsensitive:
1064 i = FICL_TRUE;
1065 goto COMPARE;
1066
1067 COMPARE:
1068 {
1069 char *cp1, *cp2;
1070 ficlUnsigned u1, u2, uMin;
1071 int n = 0;
1072
1073 CHECK_STACK(4, 1);
1074 u2 = (dataTop--)->u;
1075 cp2 = (char *)(dataTop--)->p;
1076 u1 = (dataTop--)->u;
1077 cp1 = (char *)(dataTop--)->p;
1078
1079 uMin = (u1 < u2)? u1 : u2;
1080 for (; (uMin > 0) && (n == 0); uMin--) {
1081 int c1 = (unsigned char)*cp1++;
1082 int c2 = (unsigned char)*cp2++;
1083
1084 if (i) {
1085 c1 = tolower(c1);
1086 c2 = tolower(c2);
1087 }
1088 n = (c1 - c2);
1089 }
1090
1091 if (n == 0)
1092 n = (int)(u1 - u2);
1093
1094 if (n < 0)
1095 n = -1;
1096 else if (n > 0)
1097 n = 1;
1098
1099 (++dataTop)->i = n;
1100 continue;
1101 }
1102
1103 /*
1104 * r a n d o m
1105 * Ficl-specific
1106 */
1107 case ficlInstructionRandom:
1108 (++dataTop)->i = random();
1109 continue;
1110
1111 /*
1112 * s e e d - r a n d o m
1113 * Ficl-specific
1114 */
1115 case ficlInstructionSeedRandom:
1116 srandom((dataTop--)->i);
1117 continue;
1118
1119 case ficlInstructionGreaterThan: {
1120 ficlInteger x, y;
1121 CHECK_STACK(2, 1);
1122 y = (dataTop--)->i;
1123 x = dataTop->i;
1124 dataTop->i = FICL_BOOL(x > y);
1125 continue;
1126
1127 case ficlInstructionUGreaterThan:
1128 CHECK_STACK(2, 1);
1129 u = (dataTop--)->u;
1130 dataTop->i = FICL_BOOL(dataTop->u > u);
1131 continue;
1132
1133 }
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 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 strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s));
2172 pad[FICL_STRING_GET_LENGTH(s)] = '\0';
2173 return ((int)(FICL_STRING_GET_LENGTH(s)));
2174 }
2175
2176 /*
2177 * v m P a r s e S t r i n g
2178 * Parses a string out of the input buffer using the delimiter
2179 * specified. Skips leading delimiters, marks the start of the string,
2180 * and counts characters to the next delimiter it encounters. It then
2181 * updates the vm input buffer to consume all these chars, including the
2182 * trailing delimiter.
2183 * Returns the address and length of the parsed string, not including the
2184 * trailing delimiter.
2185 */
2186 ficlString
2187 ficlVmParseString(ficlVm *vm, char delimiter)
2188 {
2189 return (ficlVmParseStringEx(vm, delimiter, 1));
2190 }
2191
2192 ficlString
2193 ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters)
2194 {
2195 ficlString s;
2196 char *trace = ficlVmGetInBuf(vm);
2197 char *stop = ficlVmGetInBufEnd(vm);
2198 char c;
2199
2200 if (skipLeadingDelimiters) {
2201 while ((trace != stop) && (*trace == delimiter))
2202 trace++;
2203 }
2204
2205 FICL_STRING_SET_POINTER(s, trace); /* mark start of text */
2206
2207 /* find next delimiter or end of line */
2208 for (c = *trace;
2209 (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n');
2210 c = *++trace) {
2211 ;
2212 }
2213
2214 /* set length of result */
2215 FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s));
2216
2217 /* gobble trailing delimiter */
2218 if ((trace != stop) && (*trace == delimiter))
2219 trace++;
2220
2221 ficlVmUpdateTib(vm, trace);
2222 return (s);
2223 }
2224
2225
2226 /*
2227 * v m P o p
2228 */
2229 ficlCell
2230 ficlVmPop(ficlVm *vm)
2231 {
2232 return (ficlStackPop(vm->dataStack));
2233 }
2234
2235 /*
2236 * v m P u s h
2237 */
2238 void
2239 ficlVmPush(ficlVm *vm, ficlCell c)
2240 {
2241 ficlStackPush(vm->dataStack, c);
2242 }
2243
2244 /*
2245 * v m P o p I P
2246 */
2247 void
2248 ficlVmPopIP(ficlVm *vm)
2249 {
2250 vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack));
2251 }
2252
2253 /*
2254 * v m P u s h I P
2255 */
2256 void
2257 ficlVmPushIP(ficlVm *vm, ficlIp newIP)
2258 {
2259 ficlStackPushPointer(vm->returnStack, (void *)vm->ip);
2260 vm->ip = newIP;
2261 }
2262
2263 /*
2264 * v m P u s h T i b
2265 * Binds the specified input string to the VM and clears >IN (the index)
2266 */
2267 void
2268 ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib)
2269 {
2270 if (pSaveTib) {
2271 *pSaveTib = vm->tib;
2272 }
2273 vm->tib.text = text;
2274 vm->tib.end = text + nChars;
2275 vm->tib.index = 0;
2276 }
2277
2278 void
2279 ficlVmPopTib(ficlVm *vm, ficlTIB *pTib)
2280 {
2281 if (pTib) {
2282 vm->tib = *pTib;
2283 }
2284 }
2285
2286 /*
2287 * v m Q u i t
2288 */
2289 void
2290 ficlVmQuit(ficlVm *vm)
2291 {
2292 ficlStackReset(vm->returnStack);
2293 vm->restart = 0;
2294 vm->ip = NULL;
2295 vm->runningWord = NULL;
2296 vm->state = FICL_VM_STATE_INTERPRET;
2297 vm->tib.text = NULL;
2298 vm->tib.end = NULL;
2299 vm->tib.index = 0;
2300 vm->pad[0] = '\0';
2301 vm->sourceId.i = 0;
2302 }
2303
2304 /*
2305 * v m R e s e t
2306 */
2307 void
2308 ficlVmReset(ficlVm *vm)
2309 {
2310 ficlVmQuit(vm);
2311 ficlStackReset(vm->dataStack);
2312 #if FICL_WANT_FLOAT
2313 ficlStackReset(vm->floatStack);
2314 #endif
2315 vm->base = 10;
2316 }
2317
2318 /*
2319 * v m S e t T e x t O u t
2320 * Binds the specified output callback to the vm. If you pass NULL,
2321 * binds the default output function (ficlTextOut)
2322 */
2323 void
2324 ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
2325 {
2326 vm->callback.textOut = textOut;
2327 }
2328
2329 void
2330 ficlVmTextOut(ficlVm *vm, char *text)
2331 {
2332 ficlCallbackTextOut((ficlCallback *)vm, text);
2333 }
2334
2335
2336 void
2337 ficlVmErrorOut(ficlVm *vm, char *text)
2338 {
2339 ficlCallbackErrorOut((ficlCallback *)vm, text);
2340 }
2341
2342
2343 /*
2344 * v m T h r o w
2345 */
2346 void
2347 ficlVmThrow(ficlVm *vm, int except)
2348 {
2349 if (vm->exceptionHandler)
2350 longjmp(*(vm->exceptionHandler), except);
2351 }
2352
2353 void
2354 ficlVmThrowError(ficlVm *vm, char *fmt, ...)
2355 {
2356 va_list list;
2357
2358 va_start(list, fmt);
2359 vsprintf(vm->pad, fmt, list);
2360 va_end(list);
2361 strcat(vm->pad, "\n");
2362
2363 ficlVmErrorOut(vm, vm->pad);
2364 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
2365 }
2366
2367 void
2368 ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list)
2369 {
2370 vsprintf(vm->pad, fmt, list);
2371 /*
2372 * well, we can try anyway, we're certainly not
2373 * returning to our caller!
2374 */
2375 va_end(list);
2376 strcat(vm->pad, "\n");
2377
2378 ficlVmErrorOut(vm, vm->pad);
2379 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
2380 }
2381
2382 /*
2383 * f i c l E v a l u a t e
2384 * Wrapper for ficlExec() which sets SOURCE-ID to -1.
2385 */
2386 int
2387 ficlVmEvaluate(ficlVm *vm, char *s)
2388 {
2389 int returnValue;
2390 ficlCell id = vm->sourceId;
2391 ficlString string;
2392 vm->sourceId.i = -1;
2393 FICL_STRING_SET_FROM_CSTRING(string, s);
2394 returnValue = ficlVmExecuteString(vm, string);
2395 vm->sourceId = id;
2396 return (returnValue);
2397 }
2398
2399 /*
2400 * f i c l E x e c
2401 * Evaluates a block of input text in the context of the
2402 * specified interpreter. Emits any requested output to the
2403 * interpreter's output function.
2404 *
2405 * Contains the "inner interpreter" code in a tight loop
2406 *
2407 * Returns one of the VM_XXXX codes defined in ficl.h:
2408 * VM_OUTOFTEXT is the normal exit condition
2409 * VM_ERREXIT means that the interpreter encountered a syntax error
2410 * and the vm has been reset to recover (some or all
2411 * of the text block got ignored
2412 * VM_USEREXIT means that the user executed the "bye" command
2413 * to shut down the interpreter. This would be a good
2414 * time to delete the vm, etc -- or you can ignore this
2415 * signal.
2416 */
2417 int
2418 ficlVmExecuteString(ficlVm *vm, ficlString s)
2419 {
2420 ficlSystem *system = vm->callback.system;
2421 ficlDictionary *dictionary = system->dictionary;
2422
2423 int except;
2424 jmp_buf vmState;
2425 jmp_buf *oldState;
2426 ficlTIB saveficlTIB;
2427
2428 FICL_VM_ASSERT(vm, vm);
2429 FICL_VM_ASSERT(vm, system->interpreterLoop[0]);
2430
2431 ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s),
2432 FICL_STRING_GET_LENGTH(s), &saveficlTIB);
2433
2434 /*
2435 * Save and restore VM's jmp_buf to enable nested calls to ficlExec
2436 */
2437 oldState = vm->exceptionHandler;
2438
2439 /* This has to come before the setjmp! */
2440 vm->exceptionHandler = &vmState;
2441 except = setjmp(vmState);
2442
2443 switch (except) {
2444 case 0:
2445 if (vm->restart) {
2446 vm->runningWord->code(vm);
2447 vm->restart = 0;
2448 } else { /* set VM up to interpret text */
2449 ficlVmPushIP(vm, &(system->interpreterLoop[0]));
2450 }
2451
2452 ficlVmInnerLoop(vm, 0);
2453 break;
2454
2455 case FICL_VM_STATUS_RESTART:
2456 vm->restart = 1;
2457 except = FICL_VM_STATUS_OUT_OF_TEXT;
2458 break;
2459
2460 case FICL_VM_STATUS_OUT_OF_TEXT:
2461 ficlVmPopIP(vm);
2462 #if 0 /* we dont output prompt in loader */
2463 if ((vm->state != FICL_VM_STATE_COMPILE) &&
2464 (vm->sourceId.i == 0))
2465 ficlVmTextOut(vm, FICL_PROMPT);
2466 #endif
2467 break;
2468
2469 case FICL_VM_STATUS_USER_EXIT:
2470 case FICL_VM_STATUS_INNER_EXIT:
2471 case FICL_VM_STATUS_BREAK:
2472 break;
2473
2474 case FICL_VM_STATUS_QUIT:
2475 if (vm->state == FICL_VM_STATE_COMPILE) {
2476 ficlDictionaryAbortDefinition(dictionary);
2477 #if FICL_WANT_LOCALS
2478 ficlDictionaryEmpty(system->locals,
2479 system->locals->forthWordlist->size);
2480 #endif
2481 }
2482 ficlVmQuit(vm);
2483 break;
2484
2485 case FICL_VM_STATUS_ERROR_EXIT:
2486 case FICL_VM_STATUS_ABORT:
2487 case FICL_VM_STATUS_ABORTQ:
2488 default: /* user defined exit code?? */
2489 if (vm->state == FICL_VM_STATE_COMPILE) {
2490 ficlDictionaryAbortDefinition(dictionary);
2491 #if FICL_WANT_LOCALS
2492 ficlDictionaryEmpty(system->locals,
2493 system->locals->forthWordlist->size);
2494 #endif
2495 }
2496 ficlDictionaryResetSearchOrder(dictionary);
2497 ficlVmReset(vm);
2498 break;
2499 }
2500
2501 vm->exceptionHandler = oldState;
2502 ficlVmPopTib(vm, &saveficlTIB);
2503 return (except);
2504 }
2505
2506 /*
2507 * f i c l E x e c X T
2508 * Given a pointer to a ficlWord, push an inner interpreter and
2509 * execute the word to completion. This is in contrast with vmExecute,
2510 * which does not guarantee that the word will have completed when
2511 * the function returns (ie in the case of colon definitions, which
2512 * need an inner interpreter to finish)
2513 *
2514 * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
2515 * exit condition is VM_INNEREXIT, Ficl's private signal to exit the
2516 * inner loop under normal circumstances. If another code is thrown to
2517 * exit the loop, this function will re-throw it if it's nested under
2518 * itself or ficlExec.
2519 *
2520 * NOTE: this function is intended so that C code can execute ficlWords
2521 * given their address in the dictionary (xt).
2522 */
2523 int
2524 ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord)
2525 {
2526 int except;
2527 jmp_buf vmState;
2528 jmp_buf *oldState;
2529 ficlWord *oldRunningWord;
2530
2531 FICL_VM_ASSERT(vm, vm);
2532 FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
2533
2534 /*
2535 * Save the runningword so that RESTART behaves correctly
2536 * over nested calls.
2537 */
2538 oldRunningWord = vm->runningWord;
2539 /*
2540 * Save and restore VM's jmp_buf to enable nested calls
2541 */
2542 oldState = vm->exceptionHandler;
2543 /* This has to come before the setjmp! */
2544 vm->exceptionHandler = &vmState;
2545 except = setjmp(vmState);
2546
2547 if (except)
2548 ficlVmPopIP(vm);
2549 else
2550 ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
2551
2552 switch (except) {
2553 case 0:
2554 ficlVmExecuteWord(vm, pWord);
2555 ficlVmInnerLoop(vm, 0);
2556 break;
2557
2558 case FICL_VM_STATUS_INNER_EXIT:
2559 case FICL_VM_STATUS_BREAK:
2560 break;
2561
2562 case FICL_VM_STATUS_RESTART:
2563 case FICL_VM_STATUS_OUT_OF_TEXT:
2564 case FICL_VM_STATUS_USER_EXIT:
2565 case FICL_VM_STATUS_QUIT:
2566 case FICL_VM_STATUS_ERROR_EXIT:
2567 case FICL_VM_STATUS_ABORT:
2568 case FICL_VM_STATUS_ABORTQ:
2569 default: /* user defined exit code?? */
2570 if (oldState) {
2571 vm->exceptionHandler = oldState;
2572 ficlVmThrow(vm, except);
2573 }
2574 break;
2575 }
2576
2577 vm->exceptionHandler = oldState;
2578 vm->runningWord = oldRunningWord;
2579 return (except);
2580 }
2581
2582 /*
2583 * f i c l P a r s e N u m b e r
2584 * Attempts to convert the NULL terminated string in the VM's pad to
2585 * a number using the VM's current base. If successful, pushes the number
2586 * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE.
2587 * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See
2588 * the standard for DOUBLE wordset.
2589 */
2590 int
2591 ficlVmParseNumber(ficlVm *vm, ficlString s)
2592 {
2593 ficlInteger accumulator = 0;
2594 char isNegative = 0;
2595 char isDouble = 0;
2596 unsigned base = vm->base;
2597 char *trace = FICL_STRING_GET_POINTER(s);
2598 ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
2599 unsigned c;
2600 unsigned digit;
2601
2602 if (length > 1) {
2603 switch (*trace) {
2604 case '-':
2605 trace++;
2606 length--;
2607 isNegative = 1;
2608 break;
2609 case '+':
2610 trace++;
2611 length--;
2612 isNegative = 0;
2613 break;
2614 default:
2615 break;
2616 }
2617 }
2618
2619 /* detect & remove trailing decimal */
2620 if ((length > 0) && (trace[length - 1] == '.')) {
2621 isDouble = 1;
2622 length--;
2623 }
2624
2625 if (length == 0) /* detect "+", "-", ".", "+." etc */
2626 return (0); /* false */
2627
2628 while ((length--) && ((c = *trace++) != '\0')) {
2629 if (!isalnum(c))
2630 return (0); /* false */
2631
2632 digit = c - '0';
2633
2634 if (digit > 9)
2635 digit = tolower(c) - 'a' + 10;
2636
2637 if (digit >= base)
2638 return (0); /* false */
2639
2640 accumulator = accumulator * base + digit;
2641 }
2642
2643 if (isNegative)
2644 accumulator = -accumulator;
2645
2646 ficlStackPushInteger(vm->dataStack, accumulator);
2647 if (vm->state == FICL_VM_STATE_COMPILE)
2648 ficlPrimitiveLiteralIm(vm);
2649
2650 if (isDouble) { /* simple (required) DOUBLE support */
2651 if (isNegative)
2652 ficlStackPushInteger(vm->dataStack, -1);
2653 else
2654 ficlStackPushInteger(vm->dataStack, 0);
2655 if (vm->state == FICL_VM_STATE_COMPILE)
2656 ficlPrimitiveLiteralIm(vm);
2657 }
2658
2659 return (1); /* true */
2660 }
2661
2662 /*
2663 * d i c t C h e c k
2664 * Checks the dictionary for corruption and throws appropriate
2665 * errors.
2666 * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot
2667 * -n number of ADDRESS UNITS proposed to de-allot
2668 * 0 just do a consistency check
2669 */
2670 void
2671 ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
2672 {
2673 #if FICL_ROBUST >= 1
2674 if ((cells >= 0) &&
2675 (ficlDictionaryCellsAvailable(dictionary) *
2676 (int)sizeof (ficlCell) < cells)) {
2677 ficlVmThrowError(vm, "Error: dictionary full");
2678 }
2679
2680 if ((cells <= 0) &&
2681 (ficlDictionaryCellsUsed(dictionary) *
2682 (int)sizeof (ficlCell) < -cells)) {
2683 ficlVmThrowError(vm, "Error: dictionary underflow");
2684 }
2685 #else /* FICL_ROBUST >= 1 */
2686 FICL_IGNORE(vm);
2687 FICL_IGNORE(dictionary);
2688 FICL_IGNORE(cells);
2689 #endif /* FICL_ROBUST >= 1 */
2690 }
2691
2692 void
2693 ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
2694 {
2695 #if FICL_ROBUST >= 1
2696 ficlVmDictionarySimpleCheck(vm, dictionary, cells);
2697
2698 if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) {
2699 ficlDictionaryResetSearchOrder(dictionary);
2700 ficlVmThrowError(vm, "Error: search order overflow");
2701 } else if (dictionary->wordlistCount < 0) {
2702 ficlDictionaryResetSearchOrder(dictionary);
2703 ficlVmThrowError(vm, "Error: search order underflow");
2704 }
2705 #else /* FICL_ROBUST >= 1 */
2706 FICL_IGNORE(vm);
2707 FICL_IGNORE(dictionary);
2708 FICL_IGNORE(cells);
2709 #endif /* FICL_ROBUST >= 1 */
2710 }
2711
2712 void
2713 ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n)
2714 {
2715 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n);
2716 FICL_IGNORE(vm);
2717 ficlDictionaryAllot(dictionary, n);
2718 }
2719
2720 void
2721 ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells)
2722 {
2723 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells);
2724 FICL_IGNORE(vm);
2725 ficlDictionaryAllotCells(dictionary, cells);
2726 }
2727
2728 /*
2729 * f i c l P a r s e W o r d
2730 * From the standard, section 3.4
2731 * b) Search the dictionary name space (see 3.4.2). If a definition name
2732 * matching the string is found:
2733 * 1.if interpreting, perform the interpretation semantics of the definition
2734 * (see 3.4.3.2), and continue at a);
2735 * 2.if compiling, perform the compilation semantics of the definition
2736 * (see 3.4.3.3), and continue at a).
2737 *
2738 * c) If a definition name matching the string is not found, attempt to
2739 * convert the string to a number (see 3.4.1.3). If successful:
2740 * 1.if interpreting, place the number on the data stack, and continue at a);
2741 * 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place
2742 * the number on the stack (see 6.1.1780 LITERAL), and continue at a);
2743 *
2744 * d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
2745 *
2746 * (jws 4/01) Modified to be a ficlParseStep
2747 */
2748 int
2749 ficlVmParseWord(ficlVm *vm, ficlString name)
2750 {
2751 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2752 ficlWord *tempFW;
2753
2754 FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
2755 FICL_STACK_CHECK(vm->dataStack, 0, 0);
2756
2757 #if FICL_WANT_LOCALS
2758 if (vm->callback.system->localsCount > 0) {
2759 tempFW = ficlSystemLookupLocal(vm->callback.system, name);
2760 } else
2761 #endif
2762 tempFW = ficlDictionaryLookup(dictionary, name);
2763
2764 if (vm->state == FICL_VM_STATE_INTERPRET) {
2765 if (tempFW != NULL) {
2766 if (ficlWordIsCompileOnly(tempFW)) {
2767 ficlVmThrowError(vm,
2768 "Error: FICL_VM_STATE_COMPILE only!");
2769 }
2770
2771 ficlVmExecuteWord(vm, tempFW);
2772 return (1); /* true */
2773 }
2774 } else { /* (vm->state == FICL_VM_STATE_COMPILE) */
2775 if (tempFW != NULL) {
2776 if (ficlWordIsImmediate(tempFW)) {
2777 ficlVmExecuteWord(vm, tempFW);
2778 } else {
2779 ficlCell c;
2780 c.p = tempFW;
2781 if (tempFW->flags & FICL_WORD_INSTRUCTION)
2782 ficlDictionaryAppendUnsigned(dictionary,
2783 (ficlInteger)tempFW->code);
2784 else
2785 ficlDictionaryAppendCell(dictionary, c);
2786 }
2787 return (1); /* true */
2788 }
2789 }
2790
2791 return (0); /* false */
2792 }
unleashed repo fork