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