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