1 /*
2 * w o r d s . c
3 * Forth Inspired Command Language
4 * ANS Forth CORE word-set written in C
5 * Author: John Sadler (john_sadler@alum.mit.edu)
6 * Created: 19 July 1997
7 * $Id: primitives.c,v 1.4 2010/09/13 18:43:04 asau Exp $
8 */
9 /*
10 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 * All rights reserved.
12 *
13 * Get the latest Ficl release at http://ficl.sourceforge.net
14 *
15 * I am interested in hearing from anyone who uses Ficl. If you have
16 * a problem, a success story, a defect, an enhancement request, or
17 * if you would like to contribute to the Ficl release, please
18 * contact me by email at the address above.
19 *
20 * L I C E N S E and D I S C L A I M E R
21 *
22 * Redistribution and use in source and binary forms, with or without
23 * modification, are permitted provided that the following conditions
24 * are met:
25 * 1. Redistributions of source code must retain the above copyright
26 * notice, this list of conditions and the following disclaimer.
27 * 2. Redistributions in binary form must reproduce the above copyright
28 * notice, this list of conditions and the following disclaimer in the
29 * documentation and/or other materials provided with the distribution.
30 *
31 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41 * SUCH DAMAGE.
42 */
43
44 #include "ficl.h"
45 #include <limits.h>
46
47 /*
48 * Control structure building words use these
49 * strings' addresses as markers on the stack to
50 * check for structure completion.
51 */
52 static char doTag[] = "do";
53 static char colonTag[] = "colon";
54 static char leaveTag[] = "leave";
55
56 static char destTag[] = "target";
57 static char origTag[] = "origin";
58
59 static char caseTag[] = "case";
60 static char ofTag[] = "of";
61 static char fallthroughTag[] = "fallthrough";
62
63 /*
64 * C O N T R O L S T R U C T U R E B U I L D E R S
65 *
66 * Push current dictionary location for later branch resolution.
67 * The location may be either a branch target or a patch address...
68 */
69 static void
markBranch(ficlDictionary * dictionary,ficlVm * vm,char * tag)70 markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
71 {
72 ficlStackPushPointer(vm->dataStack, dictionary->here);
73 ficlStackPushPointer(vm->dataStack, tag);
74 }
75
76 static void
markControlTag(ficlVm * vm,char * tag)77 markControlTag(ficlVm *vm, char *tag)
78 {
79 ficlStackPushPointer(vm->dataStack, tag);
80 }
81
82 static void
matchControlTag(ficlVm * vm,char * wantTag)83 matchControlTag(ficlVm *vm, char *wantTag)
84 {
85 char *tag;
86
87 FICL_STACK_CHECK(vm->dataStack, 1, 0);
88
89 tag = (char *)ficlStackPopPointer(vm->dataStack);
90
91 /*
92 * Changed the code below to compare the pointers first
93 * (by popular demand)
94 */
95 if ((tag != wantTag) && strcmp(tag, wantTag)) {
96 ficlVmThrowError(vm,
97 "Error -- unmatched control structure \"%s\"", wantTag);
98 }
99 }
100
101 /*
102 * Expect a branch target address on the param stack,
103 * FICL_VM_STATE_COMPILE a literal offset from the current dictionary location
104 * to the target address
105 */
106 static void
resolveBackBranch(ficlDictionary * dictionary,ficlVm * vm,char * tag)107 resolveBackBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
108 {
109 ficlCell *patchAddr, c;
110
111 matchControlTag(vm, tag);
112
113 FICL_STACK_CHECK(vm->dataStack, 1, 0);
114
115 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
116 c.i = patchAddr - dictionary->here;
117
118 ficlDictionaryAppendCell(dictionary, c);
119 }
120
121 /*
122 * Expect a branch patch address on the param stack,
123 * FICL_VM_STATE_COMPILE a literal offset from the patch location
124 * to the current dictionary location
125 */
126 static void
resolveForwardBranch(ficlDictionary * dictionary,ficlVm * vm,char * tag)127 resolveForwardBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
128 {
129 ficlInteger offset;
130 ficlCell *patchAddr;
131
132 matchControlTag(vm, tag);
133
134 FICL_STACK_CHECK(vm->dataStack, 1, 0);
135
136 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
137 offset = dictionary->here - patchAddr;
138 (*patchAddr).i = offset;
139 }
140
141 /*
142 * Match the tag to the top of the stack. If success,
143 * sopy "here" address into the ficlCell whose address is next
144 * on the stack. Used by do..leave..loop.
145 */
146 static void
resolveAbsBranch(ficlDictionary * dictionary,ficlVm * vm,char * wantTag)147 resolveAbsBranch(ficlDictionary *dictionary, ficlVm *vm, char *wantTag)
148 {
149 ficlCell *patchAddr;
150 char *tag;
151
152 FICL_STACK_CHECK(vm->dataStack, 2, 0);
153
154 tag = ficlStackPopPointer(vm->dataStack);
155
156 /*
157 * Changed the comparison below to compare the pointers first
158 * (by popular demand)
159 */
160 if ((tag != wantTag) && strcmp(tag, wantTag)) {
161 ficlVmTextOut(vm, "Warning -- Unmatched control word: ");
162 ficlVmTextOut(vm, wantTag);
163 ficlVmTextOut(vm, "\n");
164 }
165
166 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
167 (*patchAddr).p = dictionary->here;
168 }
169
170 /*
171 * c o l o n d e f i n i t i o n s
172 * Code to begin compiling a colon definition
173 * This function sets the state to FICL_VM_STATE_COMPILE, then creates a
174 * new word whose name is the next word in the input stream
175 * and whose code is colonParen.
176 */
177 static void
ficlPrimitiveColon(ficlVm * vm)178 ficlPrimitiveColon(ficlVm *vm)
179 {
180 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
181 ficlString name = ficlVmGetWord(vm);
182
183 vm->state = FICL_VM_STATE_COMPILE;
184 markControlTag(vm, colonTag);
185 (void) ficlDictionaryAppendWord(dictionary, name,
186 (ficlPrimitive)ficlInstructionColonParen,
187 FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
188
189 #if FICL_WANT_LOCALS
190 vm->callback.system->localsCount = 0;
191 #endif
192 }
193
194 static void
ficlPrimitiveSemicolonCoIm(ficlVm * vm)195 ficlPrimitiveSemicolonCoIm(ficlVm *vm)
196 {
197 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
198
199 matchControlTag(vm, colonTag);
200
201 #if FICL_WANT_LOCALS
202 if (vm->callback.system->localsCount > 0) {
203 ficlDictionary *locals;
204 locals = ficlSystemGetLocals(vm->callback.system);
205 ficlDictionaryEmpty(locals, locals->forthWordlist->size);
206 ficlDictionaryAppendUnsigned(dictionary,
207 ficlInstructionUnlinkParen);
208 }
209 vm->callback.system->localsCount = 0;
210 #endif
211
212 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen);
213 vm->state = FICL_VM_STATE_INTERPRET;
214 ficlDictionaryUnsmudge(dictionary);
215 }
216
217 /*
218 * e x i t
219 * CORE
220 * This function simply pops the previous instruction
221 * pointer and returns to the "next" loop. Used for exiting from within
222 * a definition. Note that exitParen is identical to semiParen - they
223 * are in two different functions so that "see" can correctly identify
224 * the end of a colon definition, even if it uses "exit".
225 */
226 static void
ficlPrimitiveExitCoIm(ficlVm * vm)227 ficlPrimitiveExitCoIm(ficlVm *vm)
228 {
229 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
230 FICL_IGNORE(vm);
231
232 #if FICL_WANT_LOCALS
233 if (vm->callback.system->localsCount > 0) {
234 ficlDictionaryAppendUnsigned(dictionary,
235 ficlInstructionUnlinkParen);
236 }
237 #endif
238 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen);
239 }
240
241 /*
242 * c o n s t a n t
243 * IMMEDIATE
244 * Compiles a constant into the dictionary. Constants return their
245 * value when invoked. Expects a value on top of the parm stack.
246 */
247 static void
ficlPrimitiveConstant(ficlVm * vm)248 ficlPrimitiveConstant(ficlVm *vm)
249 {
250 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
251 ficlString name = ficlVmGetWord(vm);
252
253 FICL_STACK_CHECK(vm->dataStack, 1, 0);
254
255 (void) ficlDictionaryAppendConstantInstruction(dictionary, name,
256 ficlInstructionConstantParen, ficlStackPopInteger(vm->dataStack));
257 }
258
259 static void
ficlPrimitive2Constant(ficlVm * vm)260 ficlPrimitive2Constant(ficlVm *vm)
261 {
262 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
263 ficlString name = ficlVmGetWord(vm);
264
265 FICL_STACK_CHECK(vm->dataStack, 2, 0);
266
267 (void) ficlDictionaryAppend2ConstantInstruction(dictionary, name,
268 ficlInstruction2ConstantParen, ficlStackPop2Integer(vm->dataStack));
269 }
270
271 /*
272 * d i s p l a y C e l l
273 * Drop and print the contents of the ficlCell at the top of the param
274 * stack
275 */
276 static void
ficlPrimitiveDot(ficlVm * vm)277 ficlPrimitiveDot(ficlVm *vm)
278 {
279 ficlCell c;
280
281 FICL_STACK_CHECK(vm->dataStack, 1, 0);
282
283 c = ficlStackPop(vm->dataStack);
284 (void) ficlLtoa((c).i, vm->pad, vm->base);
285 (void) strcat(vm->pad, " ");
286 ficlVmTextOut(vm, vm->pad);
287 }
288
289 static void
ficlPrimitiveUDot(ficlVm * vm)290 ficlPrimitiveUDot(ficlVm *vm)
291 {
292 ficlUnsigned u;
293
294 FICL_STACK_CHECK(vm->dataStack, 1, 0);
295
296 u = ficlStackPopUnsigned(vm->dataStack);
297 (void) ficlUltoa(u, vm->pad, vm->base);
298 (void) strcat(vm->pad, " ");
299 ficlVmTextOut(vm, vm->pad);
300 }
301
302 static void
ficlPrimitiveHexDot(ficlVm * vm)303 ficlPrimitiveHexDot(ficlVm *vm)
304 {
305 ficlUnsigned u;
306
307 FICL_STACK_CHECK(vm->dataStack, 1, 0);
308
309 u = ficlStackPopUnsigned(vm->dataStack);
310 (void) ficlUltoa(u, vm->pad, 16);
311 (void) strcat(vm->pad, " ");
312 ficlVmTextOut(vm, vm->pad);
313 }
314
315 /*
316 * s t r l e n
317 * Ficl ( c-string -- length )
318 *
319 * Returns the length of a C-style (zero-terminated) string.
320 *
321 * --lch
322 */
323 static void
ficlPrimitiveStrlen(ficlVm * vm)324 ficlPrimitiveStrlen(ficlVm *vm)
325 {
326 char *address = (char *)ficlStackPopPointer(vm->dataStack);
327 ficlStackPushInteger(vm->dataStack, strlen(address));
328 }
329
330 /*
331 * s p r i n t f
332 * Ficl ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer --
333 * c-addr-buffer u-written success-flag )
334 * Similar to the C sprintf() function. It formats into a buffer based on
335 * a "format" string. Each character in the format string is copied verbatim
336 * to the output buffer, until SPRINTF encounters a percent sign ("%").
337 * SPRINTF then skips the percent sign, and examines the next character
338 * (the "format character"). Here are the valid format characters:
339 * s - read a C-ADDR U-LENGTH string from the stack and copy it to
340 * the buffer
341 * d - read a ficlCell from the stack, format it as a string (base-10,
342 * signed), and copy it to the buffer
343 * x - same as d, except in base-16
344 * u - same as d, but unsigned
345 * % - output a literal percent-sign to the buffer
346 * SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
347 * written, and a flag indicating whether or not it ran out of space while
348 * writing to the output buffer (FICL_TRUE if it ran out of space).
349 *
350 * If SPRINTF runs out of space in the buffer to store the formatted string,
351 * it still continues parsing, in an effort to preserve your stack (otherwise
352 * it might leave uneaten arguments behind).
353 *
354 * --lch
355 */
356 static void
ficlPrimitiveSprintf(ficlVm * vm)357 ficlPrimitiveSprintf(ficlVm *vm)
358 {
359 int bufferLength = ficlStackPopInteger(vm->dataStack);
360 char *buffer = (char *)ficlStackPopPointer(vm->dataStack);
361 char *bufferStart = buffer;
362
363 int formatLength = ficlStackPopInteger(vm->dataStack);
364 char *format = (char *)ficlStackPopPointer(vm->dataStack);
365 char *formatStop = format + formatLength;
366
367 int base = 10;
368 int unsignedInteger = 0; /* false */
369
370 int append = 1; /* true */
371
372 while (format < formatStop) {
373 char scratch[64];
374 char *source;
375 int actualLength;
376 int desiredLength;
377 int leadingZeroes;
378
379 if (*format != '%') {
380 source = format;
381 actualLength = desiredLength = 1;
382 leadingZeroes = 0;
383 } else {
384 format++;
385 if (format == formatStop)
386 break;
387
388 leadingZeroes = (*format == '0');
389 if (leadingZeroes) {
390 format++;
391 if (format == formatStop)
392 break;
393 }
394
395 desiredLength = isdigit((unsigned char)*format);
396 if (desiredLength) {
397 desiredLength = strtoul(format, &format, 10);
398 if (format == formatStop)
399 break;
400 } else if (*format == '*') {
401 desiredLength =
402 ficlStackPopInteger(vm->dataStack);
403
404 format++;
405 if (format == formatStop)
406 break;
407 }
408
409 switch (*format) {
410 case 's':
411 case 'S':
412 actualLength =
413 ficlStackPopInteger(vm->dataStack);
414 source = (char *)
415 ficlStackPopPointer(vm->dataStack);
416 break;
417 case 'x':
418 case 'X':
419 base = 16;
420 /* FALLTHROUGH */
421 case 'u':
422 case 'U':
423 unsignedInteger = 1; /* true */
424 /* FALLTHROUGH */
425 case 'd':
426 case 'D': {
427 int integer;
428 integer = ficlStackPopInteger(vm->dataStack);
429 if (unsignedInteger)
430 (void) ficlUltoa(integer, scratch,
431 base);
432 else
433 (void) ficlLtoa(integer, scratch, base);
434 base = 10;
435 unsignedInteger = 0; /* false */
436 source = scratch;
437 actualLength = strlen(scratch);
438 break;
439 }
440 case '%':
441 source = format;
442 actualLength = 1;
443 /* FALLTHROUGH */
444 default:
445 continue;
446 }
447 }
448
449 if (append) {
450 if (!desiredLength)
451 desiredLength = actualLength;
452 if (desiredLength > bufferLength) {
453 append = 0; /* false */
454 desiredLength = bufferLength;
455 }
456 while (desiredLength > actualLength) {
457 *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
458 bufferLength--;
459 desiredLength--;
460 }
461 memcpy(buffer, source, actualLength);
462 buffer += actualLength;
463 bufferLength -= actualLength;
464 }
465
466 format++;
467 }
468
469 ficlStackPushPointer(vm->dataStack, bufferStart);
470 ficlStackPushInteger(vm->dataStack, buffer - bufferStart);
471 ficlStackPushInteger(vm->dataStack, FICL_BOOL(!append));
472 }
473
474 /*
475 * d u p & f r i e n d s
476 */
477 static void
ficlPrimitiveDepth(ficlVm * vm)478 ficlPrimitiveDepth(ficlVm *vm)
479 {
480 int i;
481
482 FICL_STACK_CHECK(vm->dataStack, 0, 1);
483
484 i = ficlStackDepth(vm->dataStack);
485 ficlStackPushInteger(vm->dataStack, i);
486 }
487
488 /*
489 * e m i t & f r i e n d s
490 */
491 static void
ficlPrimitiveEmit(ficlVm * vm)492 ficlPrimitiveEmit(ficlVm *vm)
493 {
494 char buffer[2];
495 int i;
496
497 FICL_STACK_CHECK(vm->dataStack, 1, 0);
498
499 i = ficlStackPopInteger(vm->dataStack);
500 buffer[0] = (char)i;
501 buffer[1] = '\0';
502 ficlVmTextOut(vm, buffer);
503 }
504
505 static void
ficlPrimitiveCR(ficlVm * vm)506 ficlPrimitiveCR(ficlVm *vm)
507 {
508 ficlVmTextOut(vm, "\n");
509 }
510
511 static void
ficlPrimitiveBackslash(ficlVm * vm)512 ficlPrimitiveBackslash(ficlVm *vm)
513 {
514 char *trace = ficlVmGetInBuf(vm);
515 char *stop = ficlVmGetInBufEnd(vm);
516 char c = *trace;
517
518 while ((trace != stop) && (c != '\r') && (c != '\n')) {
519 c = *++trace;
520 }
521
522 /*
523 * Cope with DOS or UNIX-style EOLs -
524 * Check for /r, /n, /r/n, or /n/r end-of-line sequences,
525 * and point trace to next char. If EOL is \0, we're done.
526 */
527 if (trace != stop) {
528 trace++;
529
530 if ((trace != stop) && (c != *trace) &&
531 ((*trace == '\r') || (*trace == '\n')))
532 trace++;
533 }
534
535 ficlVmUpdateTib(vm, trace);
536 }
537
538 /*
539 * paren CORE
540 * Compilation: Perform the execution semantics given below.
541 * Execution: ( "ccc<paren>" -- )
542 * Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
543 * The number of characters in ccc may be zero to the number of characters
544 * in the parse area.
545 */
546 static void
ficlPrimitiveParenthesis(ficlVm * vm)547 ficlPrimitiveParenthesis(ficlVm *vm)
548 {
549 (void) ficlVmParseStringEx(vm, ')', 0);
550 }
551
552 /*
553 * F E T C H & S T O R E
554 */
555
556 /*
557 * i f C o I m
558 * IMMEDIATE
559 * Compiles code for a conditional branch into the dictionary
560 * and pushes the branch patch address on the stack for later
561 * patching by ELSE or THEN/ENDIF.
562 */
563 static void
ficlPrimitiveIfCoIm(ficlVm * vm)564 ficlPrimitiveIfCoIm(ficlVm *vm)
565 {
566 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
567
568 ficlDictionaryAppendUnsigned(dictionary,
569 ficlInstructionBranch0ParenWithCheck);
570 markBranch(dictionary, vm, origTag);
571 ficlDictionaryAppendUnsigned(dictionary, 1);
572 }
573
574 /*
575 * e l s e C o I m
576 *
577 * IMMEDIATE -- compiles an "else"...
578 * 1) FICL_VM_STATE_COMPILE a branch and a patch address;
579 * the address gets patched
580 * by "endif" to point past the "else" code.
581 * 2) Pop the the "if" patch address
582 * 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE
583 * address.
584 * 4) Push the "else" patch address. ("endif" patches this to jump past
585 * the "else" code.
586 */
587 static void
ficlPrimitiveElseCoIm(ficlVm * vm)588 ficlPrimitiveElseCoIm(ficlVm *vm)
589 {
590 ficlCell *patchAddr;
591 ficlInteger offset;
592 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
593
594 /* (1) FICL_VM_STATE_COMPILE branch runtime */
595 ficlDictionaryAppendUnsigned(dictionary,
596 ficlInstructionBranchParenWithCheck);
597
598 matchControlTag(vm, origTag);
599 /* (2) pop "if" patch addr */
600 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
601 markBranch(dictionary, vm, origTag); /* (4) push "else" patch addr */
602
603 /* (1) FICL_VM_STATE_COMPILE patch placeholder */
604 ficlDictionaryAppendUnsigned(dictionary, 1);
605 offset = dictionary->here - patchAddr;
606 (*patchAddr).i = offset; /* (3) Patch "if" */
607 }
608
609 /*
610 * e n d i f C o I m
611 */
612 static void
ficlPrimitiveEndifCoIm(ficlVm * vm)613 ficlPrimitiveEndifCoIm(ficlVm *vm)
614 {
615 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
616 resolveForwardBranch(dictionary, vm, origTag);
617 }
618
619 /*
620 * c a s e C o I m
621 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
622 *
623 *
624 * At FICL_VM_STATE_COMPILE-time, a CASE-SYS (see DPANS94 6.2.0873) looks
625 * like this:
626 * i*addr i caseTag
627 * and an OF-SYS (see DPANS94 6.2.1950) looks like this:
628 * i*addr i caseTag addr ofTag
629 * The integer under caseTag is the count of fixup addresses that branch
630 * to ENDCASE.
631 */
632 static void
ficlPrimitiveCaseCoIm(ficlVm * vm)633 ficlPrimitiveCaseCoIm(ficlVm *vm)
634 {
635 FICL_STACK_CHECK(vm->dataStack, 0, 2);
636
637 ficlStackPushUnsigned(vm->dataStack, 0);
638 markControlTag(vm, caseTag);
639 }
640
641 /*
642 * e n d c a s eC o I m
643 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
644 */
645 static void
ficlPrimitiveEndcaseCoIm(ficlVm * vm)646 ficlPrimitiveEndcaseCoIm(ficlVm *vm)
647 {
648 ficlUnsigned fixupCount;
649 ficlDictionary *dictionary;
650 ficlCell *patchAddr;
651 ficlInteger offset;
652
653 /*
654 * if the last OF ended with FALLTHROUGH,
655 * just add the FALLTHROUGH fixup to the
656 * ENDOF fixups
657 */
658 if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) {
659 matchControlTag(vm, fallthroughTag);
660 patchAddr = ficlStackPopPointer(vm->dataStack);
661 matchControlTag(vm, caseTag);
662 fixupCount = ficlStackPopUnsigned(vm->dataStack);
663 ficlStackPushPointer(vm->dataStack, patchAddr);
664 ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
665 markControlTag(vm, caseTag);
666 }
667
668 matchControlTag(vm, caseTag);
669
670 FICL_STACK_CHECK(vm->dataStack, 1, 0);
671
672 fixupCount = ficlStackPopUnsigned(vm->dataStack);
673 FICL_STACK_CHECK(vm->dataStack, fixupCount, 0);
674
675 dictionary = ficlVmGetDictionary(vm);
676
677 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop);
678
679 while (fixupCount--) {
680 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
681 offset = dictionary->here - patchAddr;
682 (*patchAddr).i = offset;
683 }
684 }
685
686 /*
687 * o f C o I m
688 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
689 */
690 static void
ficlPrimitiveOfCoIm(ficlVm * vm)691 ficlPrimitiveOfCoIm(ficlVm *vm)
692 {
693 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
694 ficlCell *fallthroughFixup = NULL;
695
696 FICL_STACK_CHECK(vm->dataStack, 1, 3);
697
698 if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) {
699 matchControlTag(vm, fallthroughTag);
700 fallthroughFixup = ficlStackPopPointer(vm->dataStack);
701 }
702
703 matchControlTag(vm, caseTag);
704
705 markControlTag(vm, caseTag);
706
707 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionOfParen);
708 markBranch(dictionary, vm, ofTag);
709 ficlDictionaryAppendUnsigned(dictionary, 2);
710
711 if (fallthroughFixup != NULL) {
712 ficlInteger offset = dictionary->here - fallthroughFixup;
713 (*fallthroughFixup).i = offset;
714 }
715 }
716
717 /*
718 * e n d o f C o I m
719 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
720 */
721 static void
ficlPrimitiveEndofCoIm(ficlVm * vm)722 ficlPrimitiveEndofCoIm(ficlVm *vm)
723 {
724 ficlCell *patchAddr;
725 ficlUnsigned fixupCount;
726 ficlInteger offset;
727 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
728
729 FICL_STACK_CHECK(vm->dataStack, 4, 3);
730
731 /* ensure we're in an OF, */
732 matchControlTag(vm, ofTag);
733
734 /* grab the address of the branch location after the OF */
735 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
736 /* ensure we're also in a "case" */
737 matchControlTag(vm, caseTag);
738 /* grab the current number of ENDOF fixups */
739 fixupCount = ficlStackPopUnsigned(vm->dataStack);
740
741 /* FICL_VM_STATE_COMPILE branch runtime */
742 ficlDictionaryAppendUnsigned(dictionary,
743 ficlInstructionBranchParenWithCheck);
744
745 /*
746 * push a new ENDOF fixup, the updated count of ENDOF fixups,
747 * and the caseTag
748 */
749 ficlStackPushPointer(vm->dataStack, dictionary->here);
750 ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
751 markControlTag(vm, caseTag);
752
753 /* reserve space for the ENDOF fixup */
754 ficlDictionaryAppendUnsigned(dictionary, 2);
755
756 /* and patch the original OF */
757 offset = dictionary->here - patchAddr;
758 (*patchAddr).i = offset;
759 }
760
761 /*
762 * f a l l t h r o u g h C o I m
763 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
764 */
765 static void
ficlPrimitiveFallthroughCoIm(ficlVm * vm)766 ficlPrimitiveFallthroughCoIm(ficlVm *vm)
767 {
768 ficlCell *patchAddr;
769 ficlInteger offset;
770 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
771
772 FICL_STACK_CHECK(vm->dataStack, 4, 3);
773
774 /* ensure we're in an OF, */
775 matchControlTag(vm, ofTag);
776 /* grab the address of the branch location after the OF */
777 patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
778 /* ensure we're also in a "case" */
779 matchControlTag(vm, caseTag);
780
781 /* okay, here we go. put the case tag back. */
782 markControlTag(vm, caseTag);
783
784 /* FICL_VM_STATE_COMPILE branch runtime */
785 ficlDictionaryAppendUnsigned(dictionary,
786 ficlInstructionBranchParenWithCheck);
787
788 /* push a new FALLTHROUGH fixup and the fallthroughTag */
789 ficlStackPushPointer(vm->dataStack, dictionary->here);
790 markControlTag(vm, fallthroughTag);
791
792 /* reserve space for the FALLTHROUGH fixup */
793 ficlDictionaryAppendUnsigned(dictionary, 2);
794
795 /* and patch the original OF */
796 offset = dictionary->here - patchAddr;
797 (*patchAddr).i = offset;
798 }
799
800 /*
801 * h a s h
802 * hash ( c-addr u -- code)
803 * calculates hashcode of specified string and leaves it on the stack
804 */
805 static void
ficlPrimitiveHash(ficlVm * vm)806 ficlPrimitiveHash(ficlVm *vm)
807 {
808 ficlString s;
809
810 FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack));
811 FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
812 ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s));
813 }
814
815 /*
816 * i n t e r p r e t
817 * This is the "user interface" of a Forth. It does the following:
818 * while there are words in the VM's Text Input Buffer
819 * Copy next word into the pad (ficlVmGetWord)
820 * Attempt to find the word in the dictionary (ficlDictionaryLookup)
821 * If successful, execute the word.
822 * Otherwise, attempt to convert the word to a number (isNumber)
823 * If successful, push the number onto the parameter stack.
824 * Otherwise, print an error message and exit loop...
825 * End Loop
826 *
827 * From the standard, section 3.4
828 * Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
829 * repeat the following steps until either the parse area is empty or an
830 * ambiguous condition exists:
831 * a) Skip leading spaces and parse a name (see 3.4.1);
832 */
833 static void
ficlPrimitiveInterpret(ficlVm * vm)834 ficlPrimitiveInterpret(ficlVm *vm)
835 {
836 ficlString s;
837 int i;
838 ficlSystem *system;
839
840 FICL_VM_ASSERT(vm, vm);
841
842 system = vm->callback.system;
843 s = ficlVmGetWord0(vm);
844
845 /*
846 * Get next word...if out of text, we're done.
847 */
848 if (s.length == 0) {
849 ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT);
850 }
851
852 /*
853 * Run the parse chain against the incoming token until somebody
854 * eats it. Otherwise emit an error message and give up.
855 */
856 for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
857 ficlWord *word = system->parseList[i];
858
859 if (word == NULL)
860 break;
861
862 if (word->code == ficlPrimitiveParseStepParen) {
863 ficlParseStep pStep;
864 pStep = (ficlParseStep)(word->param->fn);
865 if ((*pStep)(vm, s))
866 return;
867 } else {
868 ficlStackPushPointer(vm->dataStack,
869 FICL_STRING_GET_POINTER(s));
870 ficlStackPushUnsigned(vm->dataStack,
871 FICL_STRING_GET_LENGTH(s));
872 (void) ficlVmExecuteXT(vm, word);
873 if (ficlStackPopInteger(vm->dataStack))
874 return;
875 }
876 }
877
878 ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s),
879 FICL_STRING_GET_POINTER(s));
880 /* back to inner interpreter */
881 }
882
883 /*
884 * Surrogate precompiled parse step for ficlParseWord
885 * (this step is hard coded in FICL_VM_STATE_INTERPRET)
886 */
887 static void
ficlPrimitiveLookup(ficlVm * vm)888 ficlPrimitiveLookup(ficlVm *vm)
889 {
890 ficlString name;
891 FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
892 FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack));
893 ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name));
894 }
895
896 /*
897 * p a r e n P a r s e S t e p
898 * (parse-step) ( c-addr u -- flag )
899 * runtime for a precompiled parse step - pop a counted string off the
900 * stack, run the parse step against it, and push the result flag (FICL_TRUE
901 * if success, FICL_FALSE otherwise).
902 */
903 void
ficlPrimitiveParseStepParen(ficlVm * vm)904 ficlPrimitiveParseStepParen(ficlVm *vm)
905 {
906 ficlString s;
907 ficlWord *word = vm->runningWord;
908 ficlParseStep pStep = (ficlParseStep)(word->param->fn);
909
910 FICL_STRING_SET_LENGTH(s, ficlStackPopInteger(vm->dataStack));
911 FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
912
913 ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s));
914 }
915
916 static void
ficlPrimitiveAddParseStep(ficlVm * vm)917 ficlPrimitiveAddParseStep(ficlVm *vm)
918 {
919 ficlWord *pStep;
920 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
921
922 FICL_STACK_CHECK(vm->dataStack, 1, 0);
923
924 pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p);
925 if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep))
926 (void) ficlSystemAddParseStep(vm->callback.system, pStep);
927 }
928
929 /*
930 * l i t e r a l I m
931 *
932 * IMMEDIATE code for "literal". This function gets a value from the stack
933 * and compiles it into the dictionary preceded by the code for "(literal)".
934 * IMMEDIATE
935 */
936 void
ficlPrimitiveLiteralIm(ficlVm * vm)937 ficlPrimitiveLiteralIm(ficlVm *vm)
938 {
939 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
940 ficlInteger value;
941
942 value = ficlStackPopInteger(vm->dataStack);
943
944 switch (value) {
945 case 1:
946 case 2:
947 case 3:
948 case 4:
949 case 5:
950 case 6:
951 case 7:
952 case 8:
953 case 9:
954 case 10:
955 case 11:
956 case 12:
957 case 13:
958 case 14:
959 case 15:
960 case 16:
961 ficlDictionaryAppendUnsigned(dictionary, value);
962 break;
963
964 case 0:
965 case -1:
966 case -2:
967 case -3:
968 case -4:
969 case -5:
970 case -6:
971 case -7:
972 case -8:
973 case -9:
974 case -10:
975 case -11:
976 case -12:
977 case -13:
978 case -14:
979 case -15:
980 case -16:
981 ficlDictionaryAppendUnsigned(dictionary,
982 ficlInstruction0 - value);
983 break;
984
985 default:
986 ficlDictionaryAppendUnsigned(dictionary,
987 ficlInstructionLiteralParen);
988 ficlDictionaryAppendUnsigned(dictionary, value);
989 break;
990 }
991 }
992
993 static void
ficlPrimitive2LiteralIm(ficlVm * vm)994 ficlPrimitive2LiteralIm(ficlVm *vm)
995 {
996 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
997
998 ficlDictionaryAppendUnsigned(dictionary, ficlInstruction2LiteralParen);
999 ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
1000 ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
1001 }
1002
1003 /*
1004 * D o / L o o p
1005 * do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
1006 * Compiles code to initialize a loop: FICL_VM_STATE_COMPILE (do),
1007 * allot space to hold the "leave" address, push a branch
1008 * target address for the loop.
1009 * (do) -- runtime for "do"
1010 * pops index and limit from the p stack and moves them
1011 * to the r stack, then skips to the loop body.
1012 * loop -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
1013 * +loop
1014 * Compiles code for the test part of a loop:
1015 * FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and
1016 * copy "here" address to the "leave" address allotted by "do"
1017 * i,j,k -- FICL_VM_STATE_COMPILE ONLY
1018 * Runtime: Push loop indices on param stack (i is innermost loop...)
1019 * Note: each loop has three values on the return stack:
1020 * ( R: leave limit index )
1021 * "leave" is the absolute address of the next ficlCell after the loop
1022 * limit and index are the loop control variables.
1023 * leave -- FICL_VM_STATE_COMPILE ONLY
1024 * Runtime: pop the loop control variables, then pop the
1025 * "leave" address and jump (absolute) there.
1026 */
1027 static void
ficlPrimitiveDoCoIm(ficlVm * vm)1028 ficlPrimitiveDoCoIm(ficlVm *vm)
1029 {
1030 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1031
1032 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoParen);
1033 /*
1034 * Allot space for a pointer to the end
1035 * of the loop - "leave" uses this...
1036 */
1037 markBranch(dictionary, vm, leaveTag);
1038 ficlDictionaryAppendUnsigned(dictionary, 0);
1039 /*
1040 * Mark location of head of loop...
1041 */
1042 markBranch(dictionary, vm, doTag);
1043 }
1044
1045 static void
ficlPrimitiveQDoCoIm(ficlVm * vm)1046 ficlPrimitiveQDoCoIm(ficlVm *vm)
1047 {
1048 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1049
1050 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionQDoParen);
1051 /*
1052 * Allot space for a pointer to the end
1053 * of the loop - "leave" uses this...
1054 */
1055 markBranch(dictionary, vm, leaveTag);
1056 ficlDictionaryAppendUnsigned(dictionary, 0);
1057 /*
1058 * Mark location of head of loop...
1059 */
1060 markBranch(dictionary, vm, doTag);
1061 }
1062
1063
1064 static void
ficlPrimitiveLoopCoIm(ficlVm * vm)1065 ficlPrimitiveLoopCoIm(ficlVm *vm)
1066 {
1067 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1068
1069 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLoopParen);
1070 resolveBackBranch(dictionary, vm, doTag);
1071 resolveAbsBranch(dictionary, vm, leaveTag);
1072 }
1073
1074 static void
ficlPrimitivePlusLoopCoIm(ficlVm * vm)1075 ficlPrimitivePlusLoopCoIm(ficlVm *vm)
1076 {
1077 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1078
1079 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionPlusLoopParen);
1080 resolveBackBranch(dictionary, vm, doTag);
1081 resolveAbsBranch(dictionary, vm, leaveTag);
1082 }
1083
1084 /*
1085 * v a r i a b l e
1086 */
1087 static void
ficlPrimitiveVariable(ficlVm * vm)1088 ficlPrimitiveVariable(ficlVm *vm)
1089 {
1090 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1091 ficlString name = ficlVmGetWord(vm);
1092
1093 (void) ficlDictionaryAppendWord(dictionary, name,
1094 (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
1095 ficlVmDictionaryAllotCells(vm, dictionary, 1);
1096 }
1097
1098 static void
ficlPrimitive2Variable(ficlVm * vm)1099 ficlPrimitive2Variable(ficlVm *vm)
1100 {
1101 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1102 ficlString name = ficlVmGetWord(vm);
1103
1104 (void) ficlDictionaryAppendWord(dictionary, name,
1105 (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
1106 ficlVmDictionaryAllotCells(vm, dictionary, 2);
1107 }
1108
1109 /*
1110 * b a s e & f r i e n d s
1111 */
1112 static void
ficlPrimitiveBase(ficlVm * vm)1113 ficlPrimitiveBase(ficlVm *vm)
1114 {
1115 ficlCell *pBase, c;
1116
1117 FICL_STACK_CHECK(vm->dataStack, 0, 1);
1118
1119 pBase = (ficlCell *)(&vm->base);
1120 c.p = pBase;
1121 ficlStackPush(vm->dataStack, c);
1122 }
1123
1124 static void
ficlPrimitiveDecimal(ficlVm * vm)1125 ficlPrimitiveDecimal(ficlVm *vm)
1126 {
1127 vm->base = 10;
1128 }
1129
1130
1131 static void
ficlPrimitiveHex(ficlVm * vm)1132 ficlPrimitiveHex(ficlVm *vm)
1133 {
1134 vm->base = 16;
1135 }
1136
1137 /*
1138 * a l l o t & f r i e n d s
1139 */
1140 static void
ficlPrimitiveAllot(ficlVm * vm)1141 ficlPrimitiveAllot(ficlVm *vm)
1142 {
1143 ficlDictionary *dictionary;
1144 ficlInteger i;
1145
1146 FICL_STACK_CHECK(vm->dataStack, 1, 0);
1147
1148 dictionary = ficlVmGetDictionary(vm);
1149 i = ficlStackPopInteger(vm->dataStack);
1150
1151 FICL_VM_DICTIONARY_CHECK(vm, dictionary, i);
1152
1153 ficlVmDictionaryAllot(vm, dictionary, i);
1154 }
1155
1156 static void
ficlPrimitiveHere(ficlVm * vm)1157 ficlPrimitiveHere(ficlVm *vm)
1158 {
1159 ficlDictionary *dictionary;
1160
1161 FICL_STACK_CHECK(vm->dataStack, 0, 1);
1162
1163 dictionary = ficlVmGetDictionary(vm);
1164 ficlStackPushPointer(vm->dataStack, dictionary->here);
1165 }
1166
1167 /*
1168 * t i c k
1169 * tick CORE ( "<spaces>name" -- xt )
1170 * Skip leading space delimiters. Parse name delimited by a space. Find
1171 * name and return xt, the execution token for name. An ambiguous condition
1172 * exists if name is not found.
1173 */
1174 void
ficlPrimitiveTick(ficlVm * vm)1175 ficlPrimitiveTick(ficlVm *vm)
1176 {
1177 ficlWord *word = NULL;
1178 ficlString name = ficlVmGetWord(vm);
1179
1180 FICL_STACK_CHECK(vm->dataStack, 0, 1);
1181
1182 word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
1183 if (!word)
1184 ficlVmThrowError(vm, "%.*s not found",
1185 FICL_STRING_GET_LENGTH(name),
1186 FICL_STRING_GET_POINTER(name));
1187 ficlStackPushPointer(vm->dataStack, word);
1188 }
1189
1190 static void
ficlPrimitiveBracketTickCoIm(ficlVm * vm)1191 ficlPrimitiveBracketTickCoIm(ficlVm *vm)
1192 {
1193 ficlPrimitiveTick(vm);
1194 ficlPrimitiveLiteralIm(vm);
1195 }
1196
1197 /*
1198 * p o s t p o n e
1199 * Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to
1200 * insert it into definitions created by the resulting word
1201 * (defers compilation, even of immediate words)
1202 */
1203 static void
ficlPrimitivePostponeCoIm(ficlVm * vm)1204 ficlPrimitivePostponeCoIm(ficlVm *vm)
1205 {
1206 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1207 ficlWord *word;
1208 ficlWord *pComma = ficlSystemLookup(vm->callback.system, ",");
1209 ficlCell c;
1210
1211 FICL_VM_ASSERT(vm, pComma);
1212
1213 ficlPrimitiveTick(vm);
1214 word = ficlStackGetTop(vm->dataStack).p;
1215 if (ficlWordIsImmediate(word)) {
1216 ficlDictionaryAppendCell(dictionary,
1217 ficlStackPop(vm->dataStack));
1218 } else {
1219 ficlPrimitiveLiteralIm(vm);
1220 c.p = pComma;
1221 ficlDictionaryAppendCell(dictionary, c);
1222 }
1223 }
1224
1225 /*
1226 * e x e c u t e
1227 * Pop an execution token (pointer to a word) off the stack and
1228 * run it
1229 */
1230 static void
ficlPrimitiveExecute(ficlVm * vm)1231 ficlPrimitiveExecute(ficlVm *vm)
1232 {
1233 ficlWord *word;
1234
1235 FICL_STACK_CHECK(vm->dataStack, 1, 0);
1236
1237 word = ficlStackPopPointer(vm->dataStack);
1238 ficlVmExecuteWord(vm, word);
1239 }
1240
1241 /*
1242 * i m m e d i a t e
1243 * Make the most recently compiled word IMMEDIATE -- it executes even
1244 * in FICL_VM_STATE_COMPILE state (most often used for control compiling words
1245 * such as IF, THEN, etc)
1246 */
1247 static void
ficlPrimitiveImmediate(ficlVm * vm)1248 ficlPrimitiveImmediate(ficlVm *vm)
1249 {
1250 FICL_IGNORE(vm);
1251 ficlDictionarySetImmediate(ficlVmGetDictionary(vm));
1252 }
1253
1254 static void
ficlPrimitiveCompileOnly(ficlVm * vm)1255 ficlPrimitiveCompileOnly(ficlVm *vm)
1256 {
1257 FICL_IGNORE(vm);
1258 ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_COMPILE_ONLY);
1259 }
1260
1261 static void
ficlPrimitiveSetObjectFlag(ficlVm * vm)1262 ficlPrimitiveSetObjectFlag(ficlVm *vm)
1263 {
1264 FICL_IGNORE(vm);
1265 ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_OBJECT);
1266 }
1267
1268 static void
ficlPrimitiveIsObject(ficlVm * vm)1269 ficlPrimitiveIsObject(ficlVm *vm)
1270 {
1271 ficlInteger flag;
1272 ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
1273
1274 flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT))?
1275 FICL_TRUE : FICL_FALSE;
1276
1277 ficlStackPushInteger(vm->dataStack, flag);
1278 }
1279
1280 static void
ficlPrimitiveCountedStringQuoteIm(ficlVm * vm)1281 ficlPrimitiveCountedStringQuoteIm(ficlVm *vm)
1282 {
1283 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1284
1285 if (vm->state == FICL_VM_STATE_INTERPRET) {
1286 ficlCountedString *counted = (ficlCountedString *)
1287 dictionary->here;
1288
1289 (void) ficlVmGetString(vm, counted, '\"');
1290 ficlStackPushPointer(vm->dataStack, counted);
1291
1292 /*
1293 * move HERE past string so it doesn't get overwritten. --lch
1294 */
1295 ficlVmDictionaryAllot(vm, dictionary,
1296 counted->length + sizeof (ficlUnsigned8));
1297 } else { /* FICL_VM_STATE_COMPILE state */
1298 ficlDictionaryAppendUnsigned(dictionary,
1299 ficlInstructionCStringLiteralParen);
1300 dictionary->here =
1301 FICL_POINTER_TO_CELL(ficlVmGetString(vm,
1302 (ficlCountedString *)dictionary->here, '\"'));
1303 ficlDictionaryAlign(dictionary);
1304 }
1305 }
1306
1307 /*
1308 * d o t Q u o t e
1309 * IMMEDIATE word that compiles a string literal for later display
1310 * FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the
1311 * string from the
1312 * TIB to the dictionary. Backpatch the count byte and align the dictionary.
1313 */
1314 static void
ficlPrimitiveDotQuoteCoIm(ficlVm * vm)1315 ficlPrimitiveDotQuoteCoIm(ficlVm *vm)
1316 {
1317 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1318 ficlWord *pType = ficlSystemLookup(vm->callback.system, "type");
1319 ficlCell c;
1320
1321 FICL_VM_ASSERT(vm, pType);
1322
1323 ficlDictionaryAppendUnsigned(dictionary,
1324 ficlInstructionStringLiteralParen);
1325 dictionary->here =
1326 FICL_POINTER_TO_CELL(ficlVmGetString(vm,
1327 (ficlCountedString *)dictionary->here, '\"'));
1328 ficlDictionaryAlign(dictionary);
1329 c.p = pType;
1330 ficlDictionaryAppendCell(dictionary, c);
1331 }
1332
1333 static void
ficlPrimitiveDotParen(ficlVm * vm)1334 ficlPrimitiveDotParen(ficlVm *vm)
1335 {
1336 char *from = ficlVmGetInBuf(vm);
1337 char *stop = ficlVmGetInBufEnd(vm);
1338 char *to = vm->pad;
1339 char c;
1340
1341 /*
1342 * Note: the standard does not want leading spaces skipped.
1343 */
1344 for (c = *from; (from != stop) && (c != ')'); c = *++from)
1345 *to++ = c;
1346
1347 *to = '\0';
1348 if ((from != stop) && (c == ')'))
1349 from++;
1350
1351 ficlVmTextOut(vm, vm->pad);
1352 ficlVmUpdateTib(vm, from);
1353 }
1354
1355 /*
1356 * s l i t e r a l
1357 * STRING
1358 * Interpretation: Interpretation semantics for this word are undefined.
1359 * Compilation: ( c-addr1 u -- )
1360 * Append the run-time semantics given below to the current definition.
1361 * Run-time: ( -- c-addr2 u )
1362 * Return c-addr2 u describing a string consisting of the characters
1363 * specified by c-addr1 u during compilation. A program shall not alter
1364 * the returned string.
1365 */
ficlPrimitiveSLiteralCoIm(ficlVm * vm)1366 static void ficlPrimitiveSLiteralCoIm(ficlVm *vm)
1367 {
1368 ficlDictionary *dictionary;
1369 char *from;
1370 char *to;
1371 ficlUnsigned length;
1372
1373 FICL_STACK_CHECK(vm->dataStack, 2, 0);
1374
1375 dictionary = ficlVmGetDictionary(vm);
1376 length = ficlStackPopUnsigned(vm->dataStack);
1377 from = ficlStackPopPointer(vm->dataStack);
1378
1379 ficlDictionaryAppendUnsigned(dictionary,
1380 ficlInstructionStringLiteralParen);
1381 to = (char *)dictionary->here;
1382 *to++ = (char)length;
1383
1384 for (; length > 0; --length) {
1385 *to++ = *from++;
1386 }
1387
1388 *to++ = 0;
1389 dictionary->here = FICL_POINTER_TO_CELL(ficlAlignPointer(to));
1390 }
1391
1392 /*
1393 * s t a t e
1394 * Return the address of the VM's state member (must be sized the
1395 * same as a ficlCell for this reason)
1396 */
ficlPrimitiveState(ficlVm * vm)1397 static void ficlPrimitiveState(ficlVm *vm)
1398 {
1399 FICL_STACK_CHECK(vm->dataStack, 0, 1);
1400 ficlStackPushPointer(vm->dataStack, &vm->state);
1401 }
1402
1403 /*
1404 * c r e a t e . . . d o e s >
1405 * Make a new word in the dictionary with the run-time effect of
1406 * a variable (push my address), but with extra space allotted
1407 * for use by does> .
1408 */
1409 static void
ficlPrimitiveCreate(ficlVm * vm)1410 ficlPrimitiveCreate(ficlVm *vm)
1411 {
1412 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1413 ficlString name = ficlVmGetWord(vm);
1414
1415 (void) ficlDictionaryAppendWord(dictionary, name,
1416 (ficlPrimitive)ficlInstructionCreateParen, FICL_WORD_DEFAULT);
1417 ficlVmDictionaryAllotCells(vm, dictionary, 1);
1418 }
1419
1420 static void
ficlPrimitiveDoesCoIm(ficlVm * vm)1421 ficlPrimitiveDoesCoIm(ficlVm *vm)
1422 {
1423 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1424 #if FICL_WANT_LOCALS
1425 if (vm->callback.system->localsCount > 0) {
1426 ficlDictionary *locals =
1427 ficlSystemGetLocals(vm->callback.system);
1428 ficlDictionaryEmpty(locals, locals->forthWordlist->size);
1429 ficlDictionaryAppendUnsigned(dictionary,
1430 ficlInstructionUnlinkParen);
1431 }
1432
1433 vm->callback.system->localsCount = 0;
1434 #endif
1435 FICL_IGNORE(vm);
1436
1437 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen);
1438 }
1439
1440 /*
1441 * t o b o d y
1442 * to-body CORE ( xt -- a-addr )
1443 * a-addr is the data-field address corresponding to xt. An ambiguous
1444 * condition exists if xt is not for a word defined via CREATE.
1445 */
1446 static void
ficlPrimitiveToBody(ficlVm * vm)1447 ficlPrimitiveToBody(ficlVm *vm)
1448 {
1449 ficlWord *word;
1450 FICL_STACK_CHECK(vm->dataStack, 1, 1);
1451
1452 word = ficlStackPopPointer(vm->dataStack);
1453 ficlStackPushPointer(vm->dataStack, word->param + 1);
1454 }
1455
1456 /*
1457 * from-body Ficl ( a-addr -- xt )
1458 * Reverse effect of >body
1459 */
1460 static void
ficlPrimitiveFromBody(ficlVm * vm)1461 ficlPrimitiveFromBody(ficlVm *vm)
1462 {
1463 char *ptr;
1464 FICL_STACK_CHECK(vm->dataStack, 1, 1);
1465
1466 ptr = (char *)ficlStackPopPointer(vm->dataStack) - sizeof (ficlWord);
1467 ficlStackPushPointer(vm->dataStack, ptr);
1468 }
1469
1470 /*
1471 * >name Ficl ( xt -- c-addr u )
1472 * Push the address and length of a word's name given its address
1473 * xt.
1474 */
1475 static void
ficlPrimitiveToName(ficlVm * vm)1476 ficlPrimitiveToName(ficlVm *vm)
1477 {
1478 ficlWord *word;
1479
1480 FICL_STACK_CHECK(vm->dataStack, 1, 2);
1481
1482 word = ficlStackPopPointer(vm->dataStack);
1483 ficlStackPushPointer(vm->dataStack, word->name);
1484 ficlStackPushUnsigned(vm->dataStack, word->length);
1485 }
1486
1487 static void
ficlPrimitiveLastWord(ficlVm * vm)1488 ficlPrimitiveLastWord(ficlVm *vm)
1489 {
1490 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1491 ficlWord *wp = dictionary->smudge;
1492 ficlCell c;
1493
1494 FICL_VM_ASSERT(vm, wp);
1495
1496 c.p = wp;
1497 ficlVmPush(vm, c);
1498 }
1499
1500 /*
1501 * l b r a c k e t e t c
1502 */
1503 static void
ficlPrimitiveLeftBracketCoIm(ficlVm * vm)1504 ficlPrimitiveLeftBracketCoIm(ficlVm *vm)
1505 {
1506 vm->state = FICL_VM_STATE_INTERPRET;
1507 }
1508
1509 static void
ficlPrimitiveRightBracket(ficlVm * vm)1510 ficlPrimitiveRightBracket(ficlVm *vm)
1511 {
1512 vm->state = FICL_VM_STATE_COMPILE;
1513 }
1514
1515 /*
1516 * p i c t u r e d n u m e r i c w o r d s
1517 *
1518 * less-number-sign CORE ( -- )
1519 * Initialize the pictured numeric output conversion process.
1520 * (clear the pad)
1521 */
1522 static void
ficlPrimitiveLessNumberSign(ficlVm * vm)1523 ficlPrimitiveLessNumberSign(ficlVm *vm)
1524 {
1525 ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1526 counted->length = 0;
1527 }
1528
1529 /*
1530 * number-sign CORE ( ud1 -- ud2 )
1531 * Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
1532 * n. (n is the least-significant digit of ud1.) Convert n to external form
1533 * and add the resulting character to the beginning of the pictured numeric
1534 * output string. An ambiguous condition exists if # executes outside of a
1535 * <# #> delimited number conversion.
1536 */
1537 static void
ficlPrimitiveNumberSign(ficlVm * vm)1538 ficlPrimitiveNumberSign(ficlVm *vm)
1539 {
1540 ficlCountedString *counted;
1541 ficl2Unsigned u;
1542 ficl2UnsignedQR uqr;
1543
1544 FICL_STACK_CHECK(vm->dataStack, 2, 2);
1545
1546 counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1547 u = ficlStackPop2Unsigned(vm->dataStack);
1548 uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
1549 counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
1550 ficlStackPush2Unsigned(vm->dataStack, uqr.quotient);
1551 }
1552
1553 /*
1554 * number-sign-greater CORE ( xd -- c-addr u )
1555 * Drop xd. Make the pictured numeric output string available as a character
1556 * string. c-addr and u specify the resulting character string. A program
1557 * may replace characters within the string.
1558 */
1559 static void
ficlPrimitiveNumberSignGreater(ficlVm * vm)1560 ficlPrimitiveNumberSignGreater(ficlVm *vm)
1561 {
1562 ficlCountedString *counted;
1563
1564 FICL_STACK_CHECK(vm->dataStack, 2, 2);
1565
1566 counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1567 counted->text[counted->length] = 0;
1568 (void) ficlStringReverse(counted->text);
1569 ficlStackDrop(vm->dataStack, 2);
1570 ficlStackPushPointer(vm->dataStack, counted->text);
1571 ficlStackPushUnsigned(vm->dataStack, counted->length);
1572 }
1573
1574 /*
1575 * number-sign-s CORE ( ud1 -- ud2 )
1576 * Convert one digit of ud1 according to the rule for #. Continue conversion
1577 * until the quotient is zero. ud2 is zero. An ambiguous condition exists if
1578 * #S executes outside of a <# #> delimited number conversion.
1579 * TO DO: presently does not use ud1 hi ficlCell - use it!
1580 */
1581 static void
ficlPrimitiveNumberSignS(ficlVm * vm)1582 ficlPrimitiveNumberSignS(ficlVm *vm)
1583 {
1584 ficlCountedString *counted;
1585 ficl2Unsigned u;
1586 ficl2UnsignedQR uqr;
1587
1588 FICL_STACK_CHECK(vm->dataStack, 2, 2);
1589
1590 counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1591 u = ficlStackPop2Unsigned(vm->dataStack);
1592
1593 do {
1594 uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
1595 counted->text[counted->length++] =
1596 ficlDigitToCharacter(uqr.remainder);
1597 u = uqr.quotient;
1598 } while (FICL_2UNSIGNED_NOT_ZERO(u));
1599
1600 ficlStackPush2Unsigned(vm->dataStack, u);
1601 }
1602
1603 /*
1604 * HOLD CORE ( char -- )
1605 * Add char to the beginning of the pictured numeric output string.
1606 * An ambiguous condition exists if HOLD executes outside of a <# #>
1607 * delimited number conversion.
1608 */
1609 static void
ficlPrimitiveHold(ficlVm * vm)1610 ficlPrimitiveHold(ficlVm *vm)
1611 {
1612 ficlCountedString *counted;
1613 int i;
1614
1615 FICL_STACK_CHECK(vm->dataStack, 1, 0);
1616
1617 counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1618 i = ficlStackPopInteger(vm->dataStack);
1619 counted->text[counted->length++] = (char)i;
1620 }
1621
1622 /*
1623 * SIGN CORE ( n -- )
1624 * If n is negative, add a minus sign to the beginning of the pictured
1625 * numeric output string. An ambiguous condition exists if SIGN
1626 * executes outside of a <# #> delimited number conversion.
1627 */
1628 static void
ficlPrimitiveSign(ficlVm * vm)1629 ficlPrimitiveSign(ficlVm *vm)
1630 {
1631 ficlCountedString *counted;
1632 int i;
1633
1634 FICL_STACK_CHECK(vm->dataStack, 1, 0);
1635
1636 counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
1637 i = ficlStackPopInteger(vm->dataStack);
1638 if (i < 0)
1639 counted->text[counted->length++] = '-';
1640 }
1641
1642 /*
1643 * t o N u m b e r
1644 * to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
1645 * ud2 is the unsigned result of converting the characters within the
1646 * string specified by c-addr1 u1 into digits, using the number in BASE,
1647 * and adding each into ud1 after multiplying ud1 by the number in BASE.
1648 * Conversion continues left-to-right until a character that is not
1649 * convertible, including any + or -, is encountered or the string is
1650 * entirely converted. c-addr2 is the location of the first unconverted
1651 * character or the first character past the end of the string if the string
1652 * was entirely converted. u2 is the number of unconverted characters in the
1653 * string. An ambiguous condition exists if ud2 overflows during the
1654 * conversion.
1655 */
1656 static void
ficlPrimitiveToNumber(ficlVm * vm)1657 ficlPrimitiveToNumber(ficlVm *vm)
1658 {
1659 ficlUnsigned length;
1660 char *trace;
1661 ficl2Unsigned accumulator;
1662 ficlUnsigned base = vm->base;
1663 ficlUnsigned c;
1664 ficlUnsigned digit;
1665
1666 FICL_STACK_CHECK(vm->dataStack, 4, 4);
1667
1668 length = ficlStackPopUnsigned(vm->dataStack);
1669 trace = (char *)ficlStackPopPointer(vm->dataStack);
1670 accumulator = ficlStackPop2Unsigned(vm->dataStack);
1671
1672 for (c = *trace; length > 0; c = *++trace, length--) {
1673 if (c < '0')
1674 break;
1675
1676 digit = c - '0';
1677
1678 if (digit > 9)
1679 digit = tolower(c) - 'a' + 10;
1680 /*
1681 * Note: following test also catches chars between 9 and a
1682 * because 'digit' is unsigned!
1683 */
1684 if (digit >= base)
1685 break;
1686
1687 accumulator = ficl2UnsignedMultiplyAccumulate(accumulator,
1688 base, digit);
1689 }
1690
1691 ficlStackPush2Unsigned(vm->dataStack, accumulator);
1692 ficlStackPushPointer(vm->dataStack, trace);
1693 ficlStackPushUnsigned(vm->dataStack, length);
1694 }
1695
1696 /*
1697 * q u i t & a b o r t
1698 * quit CORE ( -- ) ( R: i*x -- )
1699 * Empty the return stack, store zero in SOURCE-ID if it is present, make
1700 * the user input device the input source, and enter interpretation state.
1701 * Do not display a message. Repeat the following:
1702 *
1703 * Accept a line from the input source into the input buffer, set >IN to
1704 * zero, and FICL_VM_STATE_INTERPRET.
1705 * Display the implementation-defined system prompt if in
1706 * interpretation state, all processing has been completed, and no
1707 * ambiguous condition exists.
1708 */
1709 static void
ficlPrimitiveQuit(ficlVm * vm)1710 ficlPrimitiveQuit(ficlVm *vm)
1711 {
1712 ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
1713 }
1714
1715 static void
ficlPrimitiveAbort(ficlVm * vm)1716 ficlPrimitiveAbort(ficlVm *vm)
1717 {
1718 ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
1719 }
1720
1721 /*
1722 * a c c e p t
1723 * accept CORE ( c-addr +n1 -- +n2 )
1724 * Receive a string of at most +n1 characters. An ambiguous condition
1725 * exists if +n1 is zero or greater than 32,767. Display graphic characters
1726 * as they are received. A program that depends on the presence or absence
1727 * of non-graphic characters in the string has an environmental dependency.
1728 * The editing functions, if any, that the system performs in order to
1729 * construct the string are implementation-defined.
1730 *
1731 * (Although the standard text doesn't say so, I assume that the intent
1732 * of 'accept' is to store the string at the address specified on
1733 * the stack.)
1734 *
1735 * NOTE: getchar() is used there as its present both in loader and
1736 * userland; however, the more correct solution would be to set
1737 * terminal to raw mode for userland.
1738 */
1739 static void
ficlPrimitiveAccept(ficlVm * vm)1740 ficlPrimitiveAccept(ficlVm *vm)
1741 {
1742 ficlUnsigned size;
1743 char *address;
1744 int c;
1745 ficlUnsigned length = 0;
1746
1747 FICL_STACK_CHECK(vm->dataStack, 2, 1);
1748
1749 size = ficlStackPopInteger(vm->dataStack);
1750 address = ficlStackPopPointer(vm->dataStack);
1751
1752 while (size != length) {
1753 c = getchar();
1754 if (c == '\n' || c == '\r')
1755 break;
1756 address[length++] = c;
1757 }
1758 ficlStackPushInteger(vm->dataStack, length);
1759 }
1760
1761 /*
1762 * a l i g n
1763 * 6.1.0705 ALIGN CORE ( -- )
1764 * If the data-space pointer is not aligned, reserve enough space to
1765 * align it.
1766 */
1767 static void
ficlPrimitiveAlign(ficlVm * vm)1768 ficlPrimitiveAlign(ficlVm *vm)
1769 {
1770 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1771 FICL_IGNORE(vm);
1772 ficlDictionaryAlign(dictionary);
1773 }
1774
1775 /*
1776 * a l i g n e d
1777 */
1778 static void
ficlPrimitiveAligned(ficlVm * vm)1779 ficlPrimitiveAligned(ficlVm *vm)
1780 {
1781 void *addr;
1782
1783 FICL_STACK_CHECK(vm->dataStack, 1, 1);
1784
1785 addr = ficlStackPopPointer(vm->dataStack);
1786 ficlStackPushPointer(vm->dataStack, ficlAlignPointer(addr));
1787 }
1788
1789 /*
1790 * b e g i n & f r i e n d s
1791 * Indefinite loop control structures
1792 * A.6.1.0760 BEGIN
1793 * Typical use:
1794 * : X ... BEGIN ... test UNTIL ;
1795 * or
1796 * : X ... BEGIN ... test WHILE ... REPEAT ;
1797 */
1798 static void
ficlPrimitiveBeginCoIm(ficlVm * vm)1799 ficlPrimitiveBeginCoIm(ficlVm *vm)
1800 {
1801 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1802 markBranch(dictionary, vm, destTag);
1803 }
1804
1805 static void
ficlPrimitiveUntilCoIm(ficlVm * vm)1806 ficlPrimitiveUntilCoIm(ficlVm *vm)
1807 {
1808 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1809
1810 ficlDictionaryAppendUnsigned(dictionary,
1811 ficlInstructionBranch0ParenWithCheck);
1812 resolveBackBranch(dictionary, vm, destTag);
1813 }
1814
1815 static void
ficlPrimitiveWhileCoIm(ficlVm * vm)1816 ficlPrimitiveWhileCoIm(ficlVm *vm)
1817 {
1818 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1819
1820 FICL_STACK_CHECK(vm->dataStack, 2, 5);
1821
1822 ficlDictionaryAppendUnsigned(dictionary,
1823 ficlInstructionBranch0ParenWithCheck);
1824 markBranch(dictionary, vm, origTag);
1825
1826 /* equivalent to 2swap */
1827 ficlStackRoll(vm->dataStack, 3);
1828 ficlStackRoll(vm->dataStack, 3);
1829
1830 ficlDictionaryAppendUnsigned(dictionary, 1);
1831 }
1832
1833 static void
ficlPrimitiveRepeatCoIm(ficlVm * vm)1834 ficlPrimitiveRepeatCoIm(ficlVm *vm)
1835 {
1836 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1837
1838 ficlDictionaryAppendUnsigned(dictionary,
1839 ficlInstructionBranchParenWithCheck);
1840 /* expect "begin" branch marker */
1841 resolveBackBranch(dictionary, vm, destTag);
1842 /* expect "while" branch marker */
1843 resolveForwardBranch(dictionary, vm, origTag);
1844 }
1845
1846 static void
ficlPrimitiveAgainCoIm(ficlVm * vm)1847 ficlPrimitiveAgainCoIm(ficlVm *vm)
1848 {
1849 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1850
1851 ficlDictionaryAppendUnsigned(dictionary,
1852 ficlInstructionBranchParenWithCheck);
1853 /* expect "begin" branch marker */
1854 resolveBackBranch(dictionary, vm, destTag);
1855 }
1856
1857 /*
1858 * c h a r & f r i e n d s
1859 * 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
1860 * Skip leading space delimiters. Parse name delimited by a space.
1861 * Put the value of its first character onto the stack.
1862 *
1863 * bracket-char CORE
1864 * Interpretation: Interpretation semantics for this word are undefined.
1865 * Compilation: ( "<spaces>name" -- )
1866 * Skip leading space delimiters. Parse name delimited by a space.
1867 * Append the run-time semantics given below to the current definition.
1868 * Run-time: ( -- char )
1869 * Place char, the value of the first character of name, on the stack.
1870 */
1871 static void
ficlPrimitiveChar(ficlVm * vm)1872 ficlPrimitiveChar(ficlVm *vm)
1873 {
1874 ficlString s;
1875
1876 FICL_STACK_CHECK(vm->dataStack, 0, 1);
1877
1878 s = ficlVmGetWord(vm);
1879 ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)(s.text[0]));
1880 }
1881
1882 static void
ficlPrimitiveCharCoIm(ficlVm * vm)1883 ficlPrimitiveCharCoIm(ficlVm *vm)
1884 {
1885 ficlPrimitiveChar(vm);
1886 ficlPrimitiveLiteralIm(vm);
1887 }
1888
1889 /*
1890 * c h a r P l u s
1891 * char-plus CORE ( c-addr1 -- c-addr2 )
1892 * Add the size in address units of a character to c-addr1, giving c-addr2.
1893 */
1894 static void
ficlPrimitiveCharPlus(ficlVm * vm)1895 ficlPrimitiveCharPlus(ficlVm *vm)
1896 {
1897 char *p;
1898
1899 FICL_STACK_CHECK(vm->dataStack, 1, 1);
1900
1901 p = ficlStackPopPointer(vm->dataStack);
1902 ficlStackPushPointer(vm->dataStack, p + 1);
1903 }
1904
1905 /*
1906 * c h a r s
1907 * chars CORE ( n1 -- n2 )
1908 * n2 is the size in address units of n1 characters.
1909 * For most processors, this function can be a no-op. To guarantee
1910 * portability, we'll multiply by sizeof (char).
1911 */
1912 #if defined(_M_IX86)
1913 #pragma warning(disable: 4127)
1914 #endif
1915 static void
ficlPrimitiveChars(ficlVm * vm)1916 ficlPrimitiveChars(ficlVm *vm)
1917 {
1918 if (sizeof (char) > 1) {
1919 ficlInteger i;
1920
1921 FICL_STACK_CHECK(vm->dataStack, 1, 1);
1922
1923 i = ficlStackPopInteger(vm->dataStack);
1924 ficlStackPushInteger(vm->dataStack, i * sizeof (char));
1925 }
1926 /* otherwise no-op! */
1927 }
1928 #if defined(_M_IX86)
1929 #pragma warning(default: 4127)
1930 #endif
1931
1932 /*
1933 * c o u n t
1934 * COUNT CORE ( c-addr1 -- c-addr2 u )
1935 * Return the character string specification for the counted string stored
1936 * at c-addr1. c-addr2 is the address of the first character after c-addr1.
1937 * u is the contents of the character at c-addr1, which is the length in
1938 * characters of the string at c-addr2.
1939 */
1940 static void
ficlPrimitiveCount(ficlVm * vm)1941 ficlPrimitiveCount(ficlVm *vm)
1942 {
1943 ficlCountedString *counted;
1944
1945 FICL_STACK_CHECK(vm->dataStack, 1, 2);
1946
1947 counted = ficlStackPopPointer(vm->dataStack);
1948 ficlStackPushPointer(vm->dataStack, counted->text);
1949 ficlStackPushUnsigned(vm->dataStack, counted->length);
1950 }
1951
1952 /*
1953 * e n v i r o n m e n t ?
1954 * environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE )
1955 * c-addr is the address of a character string and u is the string's
1956 * character count. u may have a value in the range from zero to an
1957 * implementation-defined maximum which shall not be less than 31. The
1958 * character string should contain a keyword from 3.2.6 Environmental
1959 * queries or the optional word sets to be checked for correspondence
1960 * with an attribute of the present environment. If the system treats the
1961 * attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag
1962 * is FICL_TRUE and the i*x returned is of the type specified in the table for
1963 * the attribute queried.
1964 */
1965 static void
ficlPrimitiveEnvironmentQ(ficlVm * vm)1966 ficlPrimitiveEnvironmentQ(ficlVm *vm)
1967 {
1968 ficlDictionary *environment;
1969 ficlWord *word;
1970 ficlString name;
1971
1972 FICL_STACK_CHECK(vm->dataStack, 2, 1);
1973
1974 environment = vm->callback.system->environment;
1975 name.length = ficlStackPopUnsigned(vm->dataStack);
1976 name.text = ficlStackPopPointer(vm->dataStack);
1977
1978 word = ficlDictionaryLookup(environment, name);
1979
1980 if (word != NULL) {
1981 ficlVmExecuteWord(vm, word);
1982 ficlStackPushInteger(vm->dataStack, FICL_TRUE);
1983 } else {
1984 ficlStackPushInteger(vm->dataStack, FICL_FALSE);
1985 }
1986 }
1987
1988 /*
1989 * e v a l u a t e
1990 * EVALUATE CORE ( i*x c-addr u -- j*x )
1991 * Save the current input source specification. Store minus-one (-1) in
1992 * SOURCE-ID if it is present. Make the string described by c-addr and u
1993 * both the input source and input buffer, set >IN to zero, and
1994 * FICL_VM_STATE_INTERPRET.
1995 * When the parse area is empty, restore the prior input source
1996 * specification. Other stack effects are due to the words EVALUATEd.
1997 */
1998 static void
ficlPrimitiveEvaluate(ficlVm * vm)1999 ficlPrimitiveEvaluate(ficlVm *vm)
2000 {
2001 ficlCell id;
2002 int result;
2003 ficlString string;
2004
2005 FICL_STACK_CHECK(vm->dataStack, 2, 0);
2006
2007 FICL_STRING_SET_LENGTH(string, ficlStackPopUnsigned(vm->dataStack));
2008 FICL_STRING_SET_POINTER(string, ficlStackPopPointer(vm->dataStack));
2009
2010 id = vm->sourceId;
2011 vm->sourceId.i = -1;
2012 result = ficlVmExecuteString(vm, string);
2013 vm->sourceId = id;
2014 if (result != FICL_VM_STATUS_OUT_OF_TEXT)
2015 ficlVmThrow(vm, result);
2016 }
2017
2018 /*
2019 * s t r i n g q u o t e
2020 * Interpreting: get string delimited by a quote from the input stream,
2021 * copy to a scratch area, and put its count and address on the stack.
2022 * Compiling: FICL_VM_STATE_COMPILE code to push the address and count
2023 * of a string literal, FICL_VM_STATE_COMPILE the string from the input
2024 * stream, and align the dictionary pointer.
2025 */
2026 static void
ficlPrimitiveStringQuoteIm(ficlVm * vm)2027 ficlPrimitiveStringQuoteIm(ficlVm *vm)
2028 {
2029 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2030
2031 if (vm->state == FICL_VM_STATE_INTERPRET) {
2032 ficlCountedString *counted;
2033 counted = (ficlCountedString *)dictionary->here;
2034 (void) ficlVmGetString(vm, counted, '\"');
2035 ficlStackPushPointer(vm->dataStack, counted->text);
2036 ficlStackPushUnsigned(vm->dataStack, counted->length);
2037 } else { /* FICL_VM_STATE_COMPILE state */
2038 ficlDictionaryAppendUnsigned(dictionary,
2039 ficlInstructionStringLiteralParen);
2040 dictionary->here = FICL_POINTER_TO_CELL(
2041 ficlVmGetString(vm, (ficlCountedString *)dictionary->here,
2042 '\"'));
2043 ficlDictionaryAlign(dictionary);
2044 }
2045 }
2046
2047 /*
2048 * t y p e
2049 * Pop count and char address from stack and print the designated string.
2050 */
2051 static void
ficlPrimitiveType(ficlVm * vm)2052 ficlPrimitiveType(ficlVm *vm)
2053 {
2054 ficlUnsigned length;
2055 char *s;
2056
2057 FICL_STACK_CHECK(vm->dataStack, 2, 0);
2058
2059 length = ficlStackPopUnsigned(vm->dataStack);
2060 s = ficlStackPopPointer(vm->dataStack);
2061
2062 if ((s == NULL) || (length == 0))
2063 return;
2064
2065 /*
2066 * Since we don't have an output primitive for a counted string
2067 * (oops), make sure the string is null terminated. If not, copy
2068 * and terminate it.
2069 */
2070 if (s[length] != 0) {
2071 char *here = (char *)ficlVmGetDictionary(vm)->here;
2072 if (s != here)
2073 (void) strncpy(here, s, length);
2074
2075 here[length] = '\0';
2076 s = here;
2077 }
2078
2079 ficlVmTextOut(vm, s);
2080 }
2081
2082 /*
2083 * w o r d
2084 * word CORE ( char "<chars>ccc<char>" -- c-addr )
2085 * Skip leading delimiters. Parse characters ccc delimited by char. An
2086 * ambiguous condition exists if the length of the parsed string is greater
2087 * than the implementation-defined length of a counted string.
2088 *
2089 * c-addr is the address of a transient region containing the parsed word
2090 * as a counted string. If the parse area was empty or contained no
2091 * characters other than the delimiter, the resulting string has a zero
2092 * length. A space, not included in the length, follows the string. A
2093 * program may replace characters within the string.
2094 * NOTE! Ficl also NULL-terminates the dest string.
2095 */
2096 static void
ficlPrimitiveWord(ficlVm * vm)2097 ficlPrimitiveWord(ficlVm *vm)
2098 {
2099 ficlCountedString *counted;
2100 char delim;
2101 ficlString name;
2102
2103 FICL_STACK_CHECK(vm->dataStack, 1, 1);
2104
2105 counted = (ficlCountedString *)vm->pad;
2106 delim = (char)ficlStackPopInteger(vm->dataStack);
2107 name = ficlVmParseStringEx(vm, delim, 1);
2108
2109 if (FICL_STRING_GET_LENGTH(name) > FICL_PAD_SIZE - 1)
2110 FICL_STRING_SET_LENGTH(name, FICL_PAD_SIZE - 1);
2111
2112 counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name);
2113 (void) strncpy(counted->text, FICL_STRING_GET_POINTER(name),
2114 FICL_STRING_GET_LENGTH(name));
2115
2116 /*
2117 * store an extra space at the end of the primitive...
2118 * why? dunno yet. Guy Carver did it.
2119 */
2120 counted->text[counted->length] = ' ';
2121 counted->text[counted->length + 1] = 0;
2122
2123 ficlStackPushPointer(vm->dataStack, counted);
2124 }
2125
2126 /*
2127 * p a r s e - w o r d
2128 * Ficl PARSE-WORD ( <spaces>name -- c-addr u )
2129 * Skip leading spaces and parse name delimited by a space. c-addr is the
2130 * address within the input buffer and u is the length of the selected
2131 * string. If the parse area is empty, the resulting string has a zero length.
2132 */
ficlPrimitiveParseNoCopy(ficlVm * vm)2133 static void ficlPrimitiveParseNoCopy(ficlVm *vm)
2134 {
2135 ficlString s;
2136
2137 FICL_STACK_CHECK(vm->dataStack, 0, 2);
2138
2139 s = ficlVmGetWord0(vm);
2140 ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
2141 ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
2142 }
2143
2144 /*
2145 * p a r s e
2146 * CORE EXT ( char "ccc<char>" -- c-addr u )
2147 * Parse ccc delimited by the delimiter char.
2148 * c-addr is the address (within the input buffer) and u is the length of
2149 * the parsed string. If the parse area was empty, the resulting string has
2150 * a zero length.
2151 * NOTE! PARSE differs from WORD: it does not skip leading delimiters.
2152 */
2153 static void
ficlPrimitiveParse(ficlVm * vm)2154 ficlPrimitiveParse(ficlVm *vm)
2155 {
2156 ficlString s;
2157 char delim;
2158
2159 FICL_STACK_CHECK(vm->dataStack, 1, 2);
2160
2161 delim = (char)ficlStackPopInteger(vm->dataStack);
2162
2163 s = ficlVmParseStringEx(vm, delim, 0);
2164 ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
2165 ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
2166 }
2167
2168 /*
2169 * f i n d
2170 * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2171 * Find the definition named in the counted string at c-addr. If the
2172 * definition is not found, return c-addr and zero. If the definition is
2173 * found, return its execution token xt. If the definition is immediate,
2174 * also return one (1), otherwise also return minus-one (-1). For a given
2175 * string, the values returned by FIND while compiling may differ from
2176 * those returned while not compiling.
2177 */
2178 static void
do_find(ficlVm * vm,ficlString name,void * returnForFailure)2179 do_find(ficlVm *vm, ficlString name, void *returnForFailure)
2180 {
2181 ficlWord *word;
2182
2183 word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
2184 if (word) {
2185 ficlStackPushPointer(vm->dataStack, word);
2186 ficlStackPushInteger(vm->dataStack,
2187 (ficlWordIsImmediate(word) ? 1 : -1));
2188 } else {
2189 ficlStackPushPointer(vm->dataStack, returnForFailure);
2190 ficlStackPushUnsigned(vm->dataStack, 0);
2191 }
2192 }
2193
2194 /*
2195 * f i n d
2196 * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2197 * Find the definition named in the counted string at c-addr. If the
2198 * definition is not found, return c-addr and zero. If the definition is
2199 * found, return its execution token xt. If the definition is immediate,
2200 * also return one (1), otherwise also return minus-one (-1). For a given
2201 * string, the values returned by FIND while compiling may differ from
2202 * those returned while not compiling.
2203 */
2204 static void
ficlPrimitiveCFind(ficlVm * vm)2205 ficlPrimitiveCFind(ficlVm *vm)
2206 {
2207 ficlCountedString *counted;
2208 ficlString name;
2209
2210 FICL_STACK_CHECK(vm->dataStack, 1, 2);
2211
2212 counted = ficlStackPopPointer(vm->dataStack);
2213 FICL_STRING_SET_FROM_COUNTED_STRING(name, *counted);
2214 do_find(vm, name, counted);
2215 }
2216
2217 /*
2218 * s f i n d
2219 * Ficl ( c-addr u -- 0 0 | xt 1 | xt -1 )
2220 * Like FIND, but takes "c-addr u" for the string.
2221 */
2222 static void
ficlPrimitiveSFind(ficlVm * vm)2223 ficlPrimitiveSFind(ficlVm *vm)
2224 {
2225 ficlString name;
2226
2227 FICL_STACK_CHECK(vm->dataStack, 2, 2);
2228
2229 name.length = ficlStackPopInteger(vm->dataStack);
2230 name.text = ficlStackPopPointer(vm->dataStack);
2231
2232 do_find(vm, name, NULL);
2233 }
2234
2235 /*
2236 * r e c u r s e
2237 */
2238 static void
ficlPrimitiveRecurseCoIm(ficlVm * vm)2239 ficlPrimitiveRecurseCoIm(ficlVm *vm)
2240 {
2241 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2242 ficlCell c;
2243
2244 FICL_IGNORE(vm);
2245 c.p = dictionary->smudge;
2246 ficlDictionaryAppendCell(dictionary, c);
2247 }
2248
2249 /*
2250 * s o u r c e
2251 * CORE ( -- c-addr u )
2252 * c-addr is the address of, and u is the number of characters in, the
2253 * input buffer.
2254 */
2255 static void
ficlPrimitiveSource(ficlVm * vm)2256 ficlPrimitiveSource(ficlVm *vm)
2257 {
2258 FICL_STACK_CHECK(vm->dataStack, 0, 2);
2259
2260 ficlStackPushPointer(vm->dataStack, vm->tib.text);
2261 ficlStackPushInteger(vm->dataStack, ficlVmGetInBufLen(vm));
2262 }
2263
2264 /*
2265 * v e r s i o n
2266 * non-standard...
2267 */
2268 static void
ficlPrimitiveVersion(ficlVm * vm)2269 ficlPrimitiveVersion(ficlVm *vm)
2270 {
2271 ficlVmTextOut(vm, "Ficl version " FICL_VERSION "\n");
2272 }
2273
2274 /*
2275 * t o I n
2276 * to-in CORE
2277 */
2278 static void
ficlPrimitiveToIn(ficlVm * vm)2279 ficlPrimitiveToIn(ficlVm *vm)
2280 {
2281 FICL_STACK_CHECK(vm->dataStack, 0, 1);
2282
2283 ficlStackPushPointer(vm->dataStack, &vm->tib.index);
2284 }
2285
2286 /*
2287 * c o l o n N o N a m e
2288 * CORE EXT ( C: -- colon-sys ) ( S: -- xt )
2289 * Create an unnamed colon definition and push its address.
2290 * Change state to FICL_VM_STATE_COMPILE.
2291 */
2292 static void
ficlPrimitiveColonNoName(ficlVm * vm)2293 ficlPrimitiveColonNoName(ficlVm *vm)
2294 {
2295 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2296 ficlWord *word;
2297 ficlString name;
2298
2299 FICL_STRING_SET_LENGTH(name, 0);
2300 FICL_STRING_SET_POINTER(name, NULL);
2301
2302 vm->state = FICL_VM_STATE_COMPILE;
2303 word = ficlDictionaryAppendWord(dictionary, name,
2304 (ficlPrimitive)ficlInstructionColonParen,
2305 FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
2306
2307 ficlStackPushPointer(vm->dataStack, word);
2308 markControlTag(vm, colonTag);
2309 }
2310
2311 /*
2312 * u s e r V a r i a b l e
2313 * user ( u -- ) "<spaces>name"
2314 * Get a name from the input stream and create a user variable
2315 * with the name and the index supplied. The run-time effect
2316 * of a user variable is to push the address of the indexed ficlCell
2317 * in the running vm's user array.
2318 *
2319 * User variables are vm local cells. Each vm has an array of
2320 * FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
2321 * Ficl's user facility is implemented with two primitives,
2322 * "user" and "(user)", a variable ("nUser") (in softcore.c) that
2323 * holds the index of the next free user ficlCell, and a redefinition
2324 * (also in softcore) of "user" that defines a user word and increments
2325 * nUser.
2326 */
2327 #if FICL_WANT_USER
2328 static void
ficlPrimitiveUser(ficlVm * vm)2329 ficlPrimitiveUser(ficlVm *vm)
2330 {
2331 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2332 ficlString name = ficlVmGetWord(vm);
2333 ficlCell c;
2334
2335 c = ficlStackPop(vm->dataStack);
2336 if (c.i >= FICL_USER_CELLS) {
2337 ficlVmThrowError(vm, "Error - out of user space");
2338 }
2339
2340 (void) ficlDictionaryAppendWord(dictionary, name,
2341 (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT);
2342 ficlDictionaryAppendCell(dictionary, c);
2343 }
2344 #endif
2345
2346 #if FICL_WANT_LOCALS
2347 /*
2348 * Each local is recorded in a private locals dictionary as a
2349 * word that does doLocalIm at runtime. DoLocalIm compiles code
2350 * into the client definition to fetch the value of the
2351 * corresponding local variable from the return stack.
2352 * The private dictionary gets initialized at the end of each block
2353 * that uses locals (in ; and does> for example).
2354 */
2355 void
ficlLocalParenIm(ficlVm * vm,int isDouble,int isFloat)2356 ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat)
2357 {
2358 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2359 ficlInteger nLocal = vm->runningWord->param[0].i;
2360
2361 #if !FICL_WANT_FLOAT
2362 FICL_VM_ASSERT(vm, !isFloat);
2363 /* get rid of unused parameter warning */
2364 isFloat = 0;
2365 #endif /* FICL_WANT_FLOAT */
2366
2367 if (vm->state == FICL_VM_STATE_INTERPRET) {
2368 ficlStack *stack;
2369 #if FICL_WANT_FLOAT
2370 if (isFloat)
2371 stack = vm->floatStack;
2372 else
2373 #endif /* FICL_WANT_FLOAT */
2374 stack = vm->dataStack;
2375
2376 ficlStackPush(stack, vm->returnStack->frame[nLocal]);
2377 if (isDouble)
2378 ficlStackPush(stack, vm->returnStack->frame[nLocal+1]);
2379 } else {
2380 ficlInstruction instruction;
2381 ficlInteger appendLocalOffset;
2382 #if FICL_WANT_FLOAT
2383 if (isFloat) {
2384 instruction =
2385 (isDouble) ? ficlInstructionGetF2LocalParen :
2386 ficlInstructionGetFLocalParen;
2387 appendLocalOffset = FICL_TRUE;
2388 } else
2389 #endif /* FICL_WANT_FLOAT */
2390 if (nLocal == 0) {
2391 instruction = (isDouble) ? ficlInstructionGet2Local0 :
2392 ficlInstructionGetLocal0;
2393 appendLocalOffset = FICL_FALSE;
2394 } else if ((nLocal == 1) && !isDouble) {
2395 instruction = ficlInstructionGetLocal1;
2396 appendLocalOffset = FICL_FALSE;
2397 } else {
2398 instruction =
2399 (isDouble) ? ficlInstructionGet2LocalParen :
2400 ficlInstructionGetLocalParen;
2401 appendLocalOffset = FICL_TRUE;
2402 }
2403
2404 ficlDictionaryAppendUnsigned(dictionary, instruction);
2405 if (appendLocalOffset)
2406 ficlDictionaryAppendUnsigned(dictionary, nLocal);
2407 }
2408 }
2409
2410 static void
ficlPrimitiveDoLocalIm(ficlVm * vm)2411 ficlPrimitiveDoLocalIm(ficlVm *vm)
2412 {
2413 ficlLocalParenIm(vm, 0, 0);
2414 }
2415
2416 static void
ficlPrimitiveDo2LocalIm(ficlVm * vm)2417 ficlPrimitiveDo2LocalIm(ficlVm *vm)
2418 {
2419 ficlLocalParenIm(vm, 1, 0);
2420 }
2421
2422 #if FICL_WANT_FLOAT
2423 static void
ficlPrimitiveDoFLocalIm(ficlVm * vm)2424 ficlPrimitiveDoFLocalIm(ficlVm *vm)
2425 {
2426 ficlLocalParenIm(vm, 0, 1);
2427 }
2428
2429 static void
ficlPrimitiveDoF2LocalIm(ficlVm * vm)2430 ficlPrimitiveDoF2LocalIm(ficlVm *vm)
2431 {
2432 ficlLocalParenIm(vm, 1, 1);
2433 }
2434 #endif /* FICL_WANT_FLOAT */
2435
2436 /*
2437 * l o c a l P a r e n
2438 * paren-local-paren LOCAL
2439 * Interpretation: Interpretation semantics for this word are undefined.
2440 * Execution: ( c-addr u -- )
2441 * When executed during compilation, (LOCAL) passes a message to the
2442 * system that has one of two meanings. If u is non-zero,
2443 * the message identifies a new local whose definition name is given by
2444 * the string of characters identified by c-addr u. If u is zero,
2445 * the message is last local and c-addr has no significance.
2446 *
2447 * The result of executing (LOCAL) during compilation of a definition is
2448 * to create a set of named local identifiers, each of which is
2449 * a definition name, that only have execution semantics within the scope
2450 * of that definition's source.
2451 *
2452 * local Execution: ( -- x )
2453 *
2454 * Push the local's value, x, onto the stack. The local's value is
2455 * initialized as described in 13.3.3 Processing locals and may be
2456 * changed by preceding the local's name with TO. An ambiguous condition
2457 * exists when local is executed while in interpretation state.
2458 */
2459 void
ficlLocalParen(ficlVm * vm,int isDouble,int isFloat)2460 ficlLocalParen(ficlVm *vm, int isDouble, int isFloat)
2461 {
2462 ficlDictionary *dictionary;
2463 ficlString name;
2464
2465 FICL_STACK_CHECK(vm->dataStack, 2, 0);
2466
2467 dictionary = ficlVmGetDictionary(vm);
2468 FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
2469 FICL_STRING_SET_POINTER(name,
2470 (char *)ficlStackPopPointer(vm->dataStack));
2471
2472 if (FICL_STRING_GET_LENGTH(name) > 0) {
2473 /*
2474 * add a local to the **locals** dictionary and
2475 * update localsCount
2476 */
2477 ficlPrimitive code;
2478 ficlInstruction instruction;
2479 ficlDictionary *locals;
2480
2481 locals = ficlSystemGetLocals(vm->callback.system);
2482 if (vm->callback.system->localsCount >= FICL_MAX_LOCALS) {
2483 ficlVmThrowError(vm, "Error: out of local space");
2484 }
2485
2486 #if !FICL_WANT_FLOAT
2487 FICL_VM_ASSERT(vm, !isFloat);
2488 /* get rid of unused parameter warning */
2489 isFloat = 0;
2490 #else /* FICL_WANT_FLOAT */
2491 if (isFloat) {
2492 if (isDouble) {
2493 code = ficlPrimitiveDoF2LocalIm;
2494 instruction = ficlInstructionToF2LocalParen;
2495 } else {
2496 code = ficlPrimitiveDoFLocalIm;
2497 instruction = ficlInstructionToFLocalParen;
2498 }
2499 } else
2500 #endif /* FICL_WANT_FLOAT */
2501 if (isDouble) {
2502 code = ficlPrimitiveDo2LocalIm;
2503 instruction = ficlInstructionTo2LocalParen;
2504 } else {
2505 code = ficlPrimitiveDoLocalIm;
2506 instruction = ficlInstructionToLocalParen;
2507 }
2508
2509 (void) ficlDictionaryAppendWord(locals, name, code,
2510 FICL_WORD_COMPILE_ONLY_IMMEDIATE);
2511 ficlDictionaryAppendUnsigned(locals,
2512 vm->callback.system->localsCount);
2513
2514 if (vm->callback.system->localsCount == 0) {
2515 /*
2516 * FICL_VM_STATE_COMPILE code to create a local
2517 * stack frame
2518 */
2519 ficlDictionaryAppendUnsigned(dictionary,
2520 ficlInstructionLinkParen);
2521
2522 /* save location in dictionary for #locals */
2523 vm->callback.system->localsFixup = dictionary->here;
2524 ficlDictionaryAppendUnsigned(dictionary,
2525 vm->callback.system->localsCount);
2526 }
2527
2528 ficlDictionaryAppendUnsigned(dictionary, instruction);
2529 ficlDictionaryAppendUnsigned(dictionary,
2530 vm->callback.system->localsCount);
2531
2532 vm->callback.system->localsCount += (isDouble) ? 2 : 1;
2533 } else if (vm->callback.system->localsCount > 0) {
2534 /* write localsCount to (link) param area in dictionary */
2535 *(ficlInteger *)(vm->callback.system->localsFixup) =
2536 vm->callback.system->localsCount;
2537 }
2538 }
2539
2540 static void
ficlPrimitiveLocalParen(ficlVm * vm)2541 ficlPrimitiveLocalParen(ficlVm *vm)
2542 {
2543 ficlLocalParen(vm, 0, 0);
2544 }
2545
2546 static void
ficlPrimitive2LocalParen(ficlVm * vm)2547 ficlPrimitive2LocalParen(ficlVm *vm)
2548 {
2549 ficlLocalParen(vm, 1, 0);
2550 }
2551 #endif /* FICL_WANT_LOCALS */
2552
2553 /*
2554 * t o V a l u e
2555 * CORE EXT
2556 * Interpretation: ( x "<spaces>name" -- )
2557 * Skip leading spaces and parse name delimited by a space. Store x in
2558 * name. An ambiguous condition exists if name was not defined by VALUE.
2559 * NOTE: In Ficl, VALUE is an alias of CONSTANT
2560 */
2561 static void
ficlPrimitiveToValue(ficlVm * vm)2562 ficlPrimitiveToValue(ficlVm *vm)
2563 {
2564 ficlString name = ficlVmGetWord(vm);
2565 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2566 ficlWord *word;
2567 ficlInstruction instruction = 0;
2568 ficlStack *stack;
2569 ficlInteger isDouble;
2570 #if FICL_WANT_LOCALS
2571 ficlInteger nLocal;
2572 ficlInteger appendLocalOffset;
2573 ficlInteger isFloat;
2574 #endif /* FICL_WANT_LOCALS */
2575
2576 #if FICL_WANT_LOCALS
2577 if ((vm->callback.system->localsCount > 0) &&
2578 (vm->state == FICL_VM_STATE_COMPILE)) {
2579 ficlDictionary *locals;
2580
2581 locals = ficlSystemGetLocals(vm->callback.system);
2582 word = ficlDictionaryLookup(locals, name);
2583 if (!word)
2584 goto TO_GLOBAL;
2585
2586 if (word->code == ficlPrimitiveDoLocalIm) {
2587 instruction = ficlInstructionToLocalParen;
2588 isDouble = isFloat = FICL_FALSE;
2589 } else if (word->code == ficlPrimitiveDo2LocalIm) {
2590 instruction = ficlInstructionTo2LocalParen;
2591 isDouble = FICL_TRUE;
2592 isFloat = FICL_FALSE;
2593 }
2594 #if FICL_WANT_FLOAT
2595 else if (word->code == ficlPrimitiveDoFLocalIm) {
2596 instruction = ficlInstructionToFLocalParen;
2597 isDouble = FICL_FALSE;
2598 isFloat = FICL_TRUE;
2599 } else if (word->code == ficlPrimitiveDoF2LocalIm) {
2600 instruction = ficlInstructionToF2LocalParen;
2601 isDouble = isFloat = FICL_TRUE;
2602 }
2603 #endif /* FICL_WANT_FLOAT */
2604 else {
2605 ficlVmThrowError(vm,
2606 "to %.*s : local is of unknown type",
2607 FICL_STRING_GET_LENGTH(name),
2608 FICL_STRING_GET_POINTER(name));
2609 }
2610
2611 nLocal = word->param[0].i;
2612 appendLocalOffset = FICL_TRUE;
2613
2614 #if FICL_WANT_FLOAT
2615 if (!isFloat) {
2616 #endif /* FICL_WANT_FLOAT */
2617 if (nLocal == 0) {
2618 instruction =
2619 (isDouble) ? ficlInstructionTo2Local0 :
2620 ficlInstructionToLocal0;
2621 appendLocalOffset = FICL_FALSE;
2622 } else if ((nLocal == 1) && !isDouble) {
2623 instruction = ficlInstructionToLocal1;
2624 appendLocalOffset = FICL_FALSE;
2625 }
2626 #if FICL_WANT_FLOAT
2627 }
2628 #endif /* FICL_WANT_FLOAT */
2629
2630 ficlDictionaryAppendUnsigned(dictionary, instruction);
2631 if (appendLocalOffset)
2632 ficlDictionaryAppendUnsigned(dictionary, nLocal);
2633 return;
2634 }
2635 #endif
2636
2637 #if FICL_WANT_LOCALS
2638 TO_GLOBAL:
2639 #endif /* FICL_WANT_LOCALS */
2640 word = ficlDictionaryLookup(dictionary, name);
2641 if (!word)
2642 ficlVmThrowError(vm, "%.*s not found",
2643 FICL_STRING_GET_LENGTH(name),
2644 FICL_STRING_GET_POINTER(name));
2645
2646 switch ((ficlInstruction)word->code) {
2647 case ficlInstructionConstantParen:
2648 instruction = ficlInstructionStore;
2649 stack = vm->dataStack;
2650 isDouble = FICL_FALSE;
2651 break;
2652 case ficlInstruction2ConstantParen:
2653 instruction = ficlInstruction2Store;
2654 stack = vm->dataStack;
2655 isDouble = FICL_TRUE;
2656 break;
2657 #if FICL_WANT_FLOAT
2658 case ficlInstructionFConstantParen:
2659 instruction = ficlInstructionFStore;
2660 stack = vm->floatStack;
2661 isDouble = FICL_FALSE;
2662 break;
2663 case ficlInstructionF2ConstantParen:
2664 instruction = ficlInstructionF2Store;
2665 stack = vm->floatStack;
2666 isDouble = FICL_TRUE;
2667 break;
2668 #endif /* FICL_WANT_FLOAT */
2669 default:
2670 ficlVmThrowError(vm,
2671 "to %.*s : value/constant is of unknown type",
2672 FICL_STRING_GET_LENGTH(name),
2673 FICL_STRING_GET_POINTER(name));
2674 break;
2675 }
2676
2677 if (vm->state == FICL_VM_STATE_INTERPRET) {
2678 word->param[0] = ficlStackPop(stack);
2679 if (isDouble)
2680 word->param[1] = ficlStackPop(stack);
2681 } else {
2682 /* FICL_VM_STATE_COMPILE code to store to word's param */
2683 ficlStackPushPointer(vm->dataStack, &word->param[0]);
2684 ficlPrimitiveLiteralIm(vm);
2685 ficlDictionaryAppendUnsigned(dictionary, instruction);
2686 }
2687 }
2688
2689 /*
2690 * f m S l a s h M o d
2691 * f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
2692 * Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
2693 * Input and output stack arguments are signed. An ambiguous condition
2694 * exists if n1 is zero or if the quotient lies outside the range of a
2695 * single-ficlCell signed integer.
2696 */
2697 static void
ficlPrimitiveFMSlashMod(ficlVm * vm)2698 ficlPrimitiveFMSlashMod(ficlVm *vm)
2699 {
2700 ficl2Integer d1;
2701 ficlInteger n1;
2702 ficl2IntegerQR qr;
2703
2704 FICL_STACK_CHECK(vm->dataStack, 3, 2);
2705
2706 n1 = ficlStackPopInteger(vm->dataStack);
2707 d1 = ficlStackPop2Integer(vm->dataStack);
2708 qr = ficl2IntegerDivideFloored(d1, n1);
2709 ficlStackPushInteger(vm->dataStack, qr.remainder);
2710 ficlStackPushInteger(vm->dataStack,
2711 FICL_2UNSIGNED_GET_LOW(qr.quotient));
2712 }
2713
2714 /*
2715 * s m S l a s h R e m
2716 * s-m-slash-remainder CORE ( d1 n1 -- n2 n3 )
2717 * Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
2718 * Input and output stack arguments are signed. An ambiguous condition
2719 * exists if n1 is zero or if the quotient lies outside the range of a
2720 * single-ficlCell signed integer.
2721 */
2722 static void
ficlPrimitiveSMSlashRem(ficlVm * vm)2723 ficlPrimitiveSMSlashRem(ficlVm *vm)
2724 {
2725 ficl2Integer d1;
2726 ficlInteger n1;
2727 ficl2IntegerQR qr;
2728
2729 FICL_STACK_CHECK(vm->dataStack, 3, 2);
2730
2731 n1 = ficlStackPopInteger(vm->dataStack);
2732 d1 = ficlStackPop2Integer(vm->dataStack);
2733 qr = ficl2IntegerDivideSymmetric(d1, n1);
2734 ficlStackPushInteger(vm->dataStack, qr.remainder);
2735 ficlStackPushInteger(vm->dataStack,
2736 FICL_2UNSIGNED_GET_LOW(qr.quotient));
2737 }
2738
2739 static void
ficlPrimitiveMod(ficlVm * vm)2740 ficlPrimitiveMod(ficlVm *vm)
2741 {
2742 ficl2Integer d1;
2743 ficlInteger n1;
2744 ficlInteger i;
2745 ficl2IntegerQR qr;
2746 FICL_STACK_CHECK(vm->dataStack, 2, 1);
2747
2748 n1 = ficlStackPopInteger(vm->dataStack);
2749 i = ficlStackPopInteger(vm->dataStack);
2750 FICL_INTEGER_TO_2INTEGER(i, d1);
2751 qr = ficl2IntegerDivideSymmetric(d1, n1);
2752 ficlStackPushInteger(vm->dataStack, qr.remainder);
2753 }
2754
2755 /*
2756 * u m S l a s h M o d
2757 * u-m-slash-mod CORE ( ud u1 -- u2 u3 )
2758 * Divide ud by u1, giving the quotient u3 and the remainder u2.
2759 * All values and arithmetic are unsigned. An ambiguous condition
2760 * exists if u1 is zero or if the quotient lies outside the range of a
2761 * single-ficlCell unsigned integer.
2762 */
2763 static void
ficlPrimitiveUMSlashMod(ficlVm * vm)2764 ficlPrimitiveUMSlashMod(ficlVm *vm)
2765 {
2766 ficl2Unsigned ud;
2767 ficlUnsigned u1;
2768 ficl2UnsignedQR uqr;
2769
2770 u1 = ficlStackPopUnsigned(vm->dataStack);
2771 ud = ficlStackPop2Unsigned(vm->dataStack);
2772 uqr = ficl2UnsignedDivide(ud, u1);
2773 ficlStackPushUnsigned(vm->dataStack, uqr.remainder);
2774 ficlStackPushUnsigned(vm->dataStack,
2775 FICL_2UNSIGNED_GET_LOW(uqr.quotient));
2776 }
2777
2778 /*
2779 * m S t a r
2780 * m-star CORE ( n1 n2 -- d )
2781 * d is the signed product of n1 times n2.
2782 */
2783 static void
ficlPrimitiveMStar(ficlVm * vm)2784 ficlPrimitiveMStar(ficlVm *vm)
2785 {
2786 ficlInteger n2;
2787 ficlInteger n1;
2788 ficl2Integer d;
2789 FICL_STACK_CHECK(vm->dataStack, 2, 2);
2790
2791 n2 = ficlStackPopInteger(vm->dataStack);
2792 n1 = ficlStackPopInteger(vm->dataStack);
2793
2794 d = ficl2IntegerMultiply(n1, n2);
2795 ficlStackPush2Integer(vm->dataStack, d);
2796 }
2797
2798 static void
ficlPrimitiveUMStar(ficlVm * vm)2799 ficlPrimitiveUMStar(ficlVm *vm)
2800 {
2801 ficlUnsigned u2;
2802 ficlUnsigned u1;
2803 ficl2Unsigned ud;
2804 FICL_STACK_CHECK(vm->dataStack, 2, 2);
2805
2806 u2 = ficlStackPopUnsigned(vm->dataStack);
2807 u1 = ficlStackPopUnsigned(vm->dataStack);
2808
2809 ud = ficl2UnsignedMultiply(u1, u2);
2810 ficlStackPush2Unsigned(vm->dataStack, ud);
2811 }
2812
2813 /*
2814 * 2 r o t
2815 * DOUBLE ( d1 d2 d3 -- d2 d3 d1 )
2816 */
2817 static void
ficlPrimitive2Rot(ficlVm * vm)2818 ficlPrimitive2Rot(ficlVm *vm)
2819 {
2820 ficl2Integer d1, d2, d3;
2821 FICL_STACK_CHECK(vm->dataStack, 6, 6);
2822
2823 d3 = ficlStackPop2Integer(vm->dataStack);
2824 d2 = ficlStackPop2Integer(vm->dataStack);
2825 d1 = ficlStackPop2Integer(vm->dataStack);
2826 ficlStackPush2Integer(vm->dataStack, d2);
2827 ficlStackPush2Integer(vm->dataStack, d3);
2828 ficlStackPush2Integer(vm->dataStack, d1);
2829 }
2830
2831 /*
2832 * p a d
2833 * CORE EXT ( -- c-addr )
2834 * c-addr is the address of a transient region that can be used to hold
2835 * data for intermediate processing.
2836 */
2837 static void
ficlPrimitivePad(ficlVm * vm)2838 ficlPrimitivePad(ficlVm *vm)
2839 {
2840 ficlStackPushPointer(vm->dataStack, vm->pad);
2841 }
2842
2843 /*
2844 * s o u r c e - i d
2845 * CORE EXT, FILE ( -- 0 | -1 | fileid )
2846 * Identifies the input source as follows:
2847 *
2848 * SOURCE-ID Input source
2849 * --------- ------------
2850 * fileid Text file fileid
2851 * -1 String (via EVALUATE)
2852 * 0 User input device
2853 */
2854 static void
ficlPrimitiveSourceID(ficlVm * vm)2855 ficlPrimitiveSourceID(ficlVm *vm)
2856 {
2857 ficlStackPushInteger(vm->dataStack, vm->sourceId.i);
2858 }
2859
2860 /*
2861 * r e f i l l
2862 * CORE EXT ( -- flag )
2863 * Attempt to fill the input buffer from the input source, returning
2864 * a FICL_TRUE flag if successful.
2865 * When the input source is the user input device, attempt to receive input
2866 * into the terminal input buffer. If successful, make the result the input
2867 * buffer, set >IN to zero, and return FICL_TRUE. Receipt of a line containing
2868 * no characters is considered successful. If there is no input available from
2869 * the current input source, return FICL_FALSE.
2870 * When the input source is a string from EVALUATE, return FICL_FALSE and
2871 * perform no other action.
2872 */
2873 static void
ficlPrimitiveRefill(ficlVm * vm)2874 ficlPrimitiveRefill(ficlVm *vm)
2875 {
2876 ficlInteger ret = (vm->sourceId.i == -1) ? FICL_FALSE : FICL_TRUE;
2877 if (ret && (vm->restart == 0))
2878 ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
2879
2880 ficlStackPushInteger(vm->dataStack, ret);
2881 }
2882
2883 /*
2884 * freebsd exception handling words
2885 * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
2886 * the word in ToS. If an exception happens, restore the state to what
2887 * it was before, and pushes the exception value on the stack. If not,
2888 * push zero.
2889 *
2890 * Notice that Catch implements an inner interpreter. This is ugly,
2891 * but given how Ficl works, it cannot be helped. The problem is that
2892 * colon definitions will be executed *after* the function returns,
2893 * while "code" definitions will be executed immediately. I considered
2894 * other solutions to this problem, but all of them shared the same
2895 * basic problem (with added disadvantages): if Ficl ever changes it's
2896 * inner thread modus operandi, one would have to fix this word.
2897 *
2898 * More comments can be found throughout catch's code.
2899 *
2900 * Daniel C. Sobral Jan 09/1999
2901 * sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
2902 */
2903 static void
ficlPrimitiveCatch(ficlVm * vm)2904 ficlPrimitiveCatch(ficlVm *vm)
2905 {
2906 int except;
2907 jmp_buf vmState;
2908 ficlVm vmCopy;
2909 ficlStack dataStackCopy;
2910 ficlStack returnStackCopy;
2911 ficlWord *word;
2912
2913 FICL_VM_ASSERT(vm, vm);
2914 FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
2915
2916 /*
2917 * Get xt.
2918 * We need this *before* we save the stack pointer, or
2919 * we'll have to pop one element out of the stack after
2920 * an exception. I prefer to get done with it up front. :-)
2921 */
2922
2923 FICL_STACK_CHECK(vm->dataStack, 1, 0);
2924
2925 word = ficlStackPopPointer(vm->dataStack);
2926
2927 /*
2928 * Save vm's state -- a catch will not back out environmental
2929 * changes.
2930 *
2931 * We are *not* saving dictionary state, since it is
2932 * global instead of per vm, and we are not saving
2933 * stack contents, since we are not required to (and,
2934 * thus, it would be useless). We save vm, and vm
2935 * "stacks" (a structure containing general information
2936 * about it, including the current stack pointer).
2937 */
2938 memcpy((void*)&vmCopy, (void*)vm, sizeof (ficlVm));
2939 memcpy((void*)&dataStackCopy, (void*)vm->dataStack, sizeof (ficlStack));
2940 memcpy((void*)&returnStackCopy, (void*)vm->returnStack,
2941 sizeof (ficlStack));
2942
2943 /*
2944 * Give vm a jmp_buf
2945 */
2946 vm->exceptionHandler = &vmState;
2947
2948 /*
2949 * Safety net
2950 */
2951 except = setjmp(vmState);
2952
2953 switch (except) {
2954 /*
2955 * Setup condition - push poison pill so that the VM throws
2956 * VM_INNEREXIT if the XT terminates normally, then execute
2957 * the XT
2958 */
2959 case 0:
2960 /* Open mouth, insert emetic */
2961 ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
2962 ficlVmExecuteWord(vm, word);
2963 ficlVmInnerLoop(vm, 0);
2964 break;
2965
2966 /*
2967 * Normal exit from XT - lose the poison pill,
2968 * restore old setjmp vector and push a zero.
2969 */
2970 case FICL_VM_STATUS_INNER_EXIT:
2971 ficlVmPopIP(vm); /* Gack - hurl poison pill */
2972 /* Restore just the setjmp vector */
2973 vm->exceptionHandler = vmCopy.exceptionHandler;
2974 /* Push 0 -- everything is ok */
2975 ficlStackPushInteger(vm->dataStack, 0);
2976 break;
2977
2978 /*
2979 * Some other exception got thrown - restore pre-existing VM state
2980 * and push the exception code
2981 */
2982 default:
2983 /* Restore vm's state */
2984 memcpy((void*)vm, (void*)&vmCopy, sizeof (ficlVm));
2985 memcpy((void*)vm->dataStack, (void*)&dataStackCopy,
2986 sizeof (ficlStack));
2987 memcpy((void*)vm->returnStack, (void*)&returnStackCopy,
2988 sizeof (ficlStack));
2989
2990 ficlStackPushInteger(vm->dataStack, except); /* Push error */
2991 break;
2992 }
2993 }
2994
2995 /*
2996 * t h r o w
2997 * EXCEPTION
2998 * Throw -- From ANS Forth standard.
2999 *
3000 * Throw takes the ToS and, if that's different from zero,
3001 * returns to the last executed catch context. Further throws will
3002 * unstack previously executed "catches", in LIFO mode.
3003 *
3004 * Daniel C. Sobral Jan 09/1999
3005 */
3006 static void
ficlPrimitiveThrow(ficlVm * vm)3007 ficlPrimitiveThrow(ficlVm *vm)
3008 {
3009 int except;
3010
3011 except = ficlStackPopInteger(vm->dataStack);
3012
3013 if (except)
3014 ficlVmThrow(vm, except);
3015 }
3016
3017 /*
3018 * a l l o c a t e
3019 * MEMORY
3020 */
3021 static void
ficlPrimitiveAllocate(ficlVm * vm)3022 ficlPrimitiveAllocate(ficlVm *vm)
3023 {
3024 size_t size;
3025 void *p;
3026
3027 size = ficlStackPopInteger(vm->dataStack);
3028 p = ficlMalloc(size);
3029 ficlStackPushPointer(vm->dataStack, p);
3030 if (p != NULL)
3031 ficlStackPushInteger(vm->dataStack, 0);
3032 else
3033 ficlStackPushInteger(vm->dataStack, 1);
3034 }
3035
3036 /*
3037 * f r e e
3038 * MEMORY
3039 */
3040 static void
ficlPrimitiveFree(ficlVm * vm)3041 ficlPrimitiveFree(ficlVm *vm)
3042 {
3043 void *p;
3044
3045 p = ficlStackPopPointer(vm->dataStack);
3046 ficlFree(p);
3047 ficlStackPushInteger(vm->dataStack, 0);
3048 }
3049
3050 /*
3051 * r e s i z e
3052 * MEMORY
3053 */
3054 static void
ficlPrimitiveResize(ficlVm * vm)3055 ficlPrimitiveResize(ficlVm *vm)
3056 {
3057 size_t size;
3058 void *new, *old;
3059
3060 size = ficlStackPopInteger(vm->dataStack);
3061 old = ficlStackPopPointer(vm->dataStack);
3062 new = ficlRealloc(old, size);
3063
3064 if (new) {
3065 ficlStackPushPointer(vm->dataStack, new);
3066 ficlStackPushInteger(vm->dataStack, 0);
3067 } else {
3068 ficlStackPushPointer(vm->dataStack, old);
3069 ficlStackPushInteger(vm->dataStack, 1);
3070 }
3071 }
3072
3073 /*
3074 * e x i t - i n n e r
3075 * Signals execXT that an inner loop has completed
3076 */
3077 static void
ficlPrimitiveExitInner(ficlVm * vm)3078 ficlPrimitiveExitInner(ficlVm *vm)
3079 {
3080 ficlVmThrow(vm, FICL_VM_STATUS_INNER_EXIT);
3081 }
3082
3083 #if 0
3084 static void
3085 ficlPrimitiveName(ficlVm *vm)
3086 {
3087 FICL_IGNORE(vm);
3088 }
3089 #endif
3090
3091 /*
3092 * f i c l C o m p i l e C o r e
3093 * Builds the primitive wordset and the environment-query namespace.
3094 */
3095 void
ficlSystemCompileCore(ficlSystem * system)3096 ficlSystemCompileCore(ficlSystem *system)
3097 {
3098 ficlWord *interpret;
3099 ficlDictionary *dictionary = ficlSystemGetDictionary(system);
3100 ficlDictionary *environment = ficlSystemGetEnvironment(system);
3101
3102 FICL_SYSTEM_ASSERT(system, dictionary);
3103 FICL_SYSTEM_ASSERT(system, environment);
3104
3105 #define FICL_TOKEN(token, description)
3106 #define FICL_INSTRUCTION_TOKEN(token, description, flags) \
3107 (void) ficlDictionarySetInstruction(dictionary, description, token, \
3108 flags);
3109 #include "ficltokens.h"
3110 #undef FICL_TOKEN
3111 #undef FICL_INSTRUCTION_TOKEN
3112
3113 /*
3114 * The Core word set
3115 * see softcore.c for definitions of: abs bl space spaces abort"
3116 */
3117 (void) ficlDictionarySetPrimitive(dictionary, "#",
3118 ficlPrimitiveNumberSign, FICL_WORD_DEFAULT);
3119 (void) ficlDictionarySetPrimitive(dictionary, "#>",
3120 ficlPrimitiveNumberSignGreater, FICL_WORD_DEFAULT);
3121 (void) ficlDictionarySetPrimitive(dictionary, "#s",
3122 ficlPrimitiveNumberSignS, FICL_WORD_DEFAULT);
3123 (void) ficlDictionarySetPrimitive(dictionary, "\'",
3124 ficlPrimitiveTick, FICL_WORD_DEFAULT);
3125 (void) ficlDictionarySetPrimitive(dictionary, "(",
3126 ficlPrimitiveParenthesis, FICL_WORD_IMMEDIATE);
3127 (void) ficlDictionarySetPrimitive(dictionary, "+loop",
3128 ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3129 (void) ficlDictionarySetPrimitive(dictionary, ".",
3130 ficlPrimitiveDot, FICL_WORD_DEFAULT);
3131 (void) ficlDictionarySetPrimitive(dictionary, ".\"",
3132 ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3133 (void) ficlDictionarySetPrimitive(dictionary, ":",
3134 ficlPrimitiveColon, FICL_WORD_DEFAULT);
3135 (void) ficlDictionarySetPrimitive(dictionary, ";",
3136 ficlPrimitiveSemicolonCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3137 (void) ficlDictionarySetPrimitive(dictionary, "<#",
3138 ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT);
3139 (void) ficlDictionarySetPrimitive(dictionary, ">body",
3140 ficlPrimitiveToBody, FICL_WORD_DEFAULT);
3141 (void) ficlDictionarySetPrimitive(dictionary, ">in",
3142 ficlPrimitiveToIn, FICL_WORD_DEFAULT);
3143 (void) ficlDictionarySetPrimitive(dictionary, ">number",
3144 ficlPrimitiveToNumber, FICL_WORD_DEFAULT);
3145 (void) ficlDictionarySetPrimitive(dictionary, "abort",
3146 ficlPrimitiveAbort, FICL_WORD_DEFAULT);
3147 (void) ficlDictionarySetPrimitive(dictionary, "accept",
3148 ficlPrimitiveAccept, FICL_WORD_DEFAULT);
3149 (void) ficlDictionarySetPrimitive(dictionary, "align",
3150 ficlPrimitiveAlign, FICL_WORD_DEFAULT);
3151 (void) ficlDictionarySetPrimitive(dictionary, "aligned",
3152 ficlPrimitiveAligned, FICL_WORD_DEFAULT);
3153 (void) ficlDictionarySetPrimitive(dictionary, "allot",
3154 ficlPrimitiveAllot, FICL_WORD_DEFAULT);
3155 (void) ficlDictionarySetPrimitive(dictionary, "base",
3156 ficlPrimitiveBase, FICL_WORD_DEFAULT);
3157 (void) ficlDictionarySetPrimitive(dictionary, "begin",
3158 ficlPrimitiveBeginCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3159 (void) ficlDictionarySetPrimitive(dictionary, "case",
3160 ficlPrimitiveCaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3161 (void) ficlDictionarySetPrimitive(dictionary, "char",
3162 ficlPrimitiveChar, FICL_WORD_DEFAULT);
3163 (void) ficlDictionarySetPrimitive(dictionary, "char+",
3164 ficlPrimitiveCharPlus, FICL_WORD_DEFAULT);
3165 (void) ficlDictionarySetPrimitive(dictionary, "chars",
3166 ficlPrimitiveChars, FICL_WORD_DEFAULT);
3167 (void) ficlDictionarySetPrimitive(dictionary, "constant",
3168 ficlPrimitiveConstant, FICL_WORD_DEFAULT);
3169 (void) ficlDictionarySetPrimitive(dictionary, "count",
3170 ficlPrimitiveCount, FICL_WORD_DEFAULT);
3171 (void) ficlDictionarySetPrimitive(dictionary, "cr",
3172 ficlPrimitiveCR, FICL_WORD_DEFAULT);
3173 (void) ficlDictionarySetPrimitive(dictionary, "create",
3174 ficlPrimitiveCreate, FICL_WORD_DEFAULT);
3175 (void) ficlDictionarySetPrimitive(dictionary, "decimal",
3176 ficlPrimitiveDecimal, FICL_WORD_DEFAULT);
3177 (void) ficlDictionarySetPrimitive(dictionary, "depth",
3178 ficlPrimitiveDepth, FICL_WORD_DEFAULT);
3179 (void) ficlDictionarySetPrimitive(dictionary, "do",
3180 ficlPrimitiveDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3181 (void) ficlDictionarySetPrimitive(dictionary, "does>",
3182 ficlPrimitiveDoesCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3183 (void) ficlDictionarySetPrimitive(dictionary, "else",
3184 ficlPrimitiveElseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3185 (void) ficlDictionarySetPrimitive(dictionary, "emit",
3186 ficlPrimitiveEmit, FICL_WORD_DEFAULT);
3187 (void) ficlDictionarySetPrimitive(dictionary, "endcase",
3188 ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3189 (void) ficlDictionarySetPrimitive(dictionary, "endof",
3190 ficlPrimitiveEndofCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3191 (void) ficlDictionarySetPrimitive(dictionary, "environment?",
3192 ficlPrimitiveEnvironmentQ, FICL_WORD_DEFAULT);
3193 (void) ficlDictionarySetPrimitive(dictionary, "evaluate",
3194 ficlPrimitiveEvaluate, FICL_WORD_DEFAULT);
3195 (void) ficlDictionarySetPrimitive(dictionary, "execute",
3196 ficlPrimitiveExecute, FICL_WORD_DEFAULT);
3197 (void) ficlDictionarySetPrimitive(dictionary, "exit",
3198 ficlPrimitiveExitCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3199 (void) ficlDictionarySetPrimitive(dictionary, "fallthrough",
3200 ficlPrimitiveFallthroughCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3201 (void) ficlDictionarySetPrimitive(dictionary, "find",
3202 ficlPrimitiveCFind, FICL_WORD_DEFAULT);
3203 (void) ficlDictionarySetPrimitive(dictionary, "fm/mod",
3204 ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT);
3205 (void) ficlDictionarySetPrimitive(dictionary, "here",
3206 ficlPrimitiveHere, FICL_WORD_DEFAULT);
3207 (void) ficlDictionarySetPrimitive(dictionary, "hold",
3208 ficlPrimitiveHold, FICL_WORD_DEFAULT);
3209 (void) ficlDictionarySetPrimitive(dictionary, "if",
3210 ficlPrimitiveIfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3211 (void) ficlDictionarySetPrimitive(dictionary, "immediate",
3212 ficlPrimitiveImmediate, FICL_WORD_DEFAULT);
3213 (void) ficlDictionarySetPrimitive(dictionary, "literal",
3214 ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE);
3215 (void) ficlDictionarySetPrimitive(dictionary, "loop",
3216 ficlPrimitiveLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3217 (void) ficlDictionarySetPrimitive(dictionary, "m*",
3218 ficlPrimitiveMStar, FICL_WORD_DEFAULT);
3219 (void) ficlDictionarySetPrimitive(dictionary, "mod",
3220 ficlPrimitiveMod, FICL_WORD_DEFAULT);
3221 (void) ficlDictionarySetPrimitive(dictionary, "of",
3222 ficlPrimitiveOfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3223 (void) ficlDictionarySetPrimitive(dictionary, "postpone",
3224 ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3225 (void) ficlDictionarySetPrimitive(dictionary, "quit",
3226 ficlPrimitiveQuit, FICL_WORD_DEFAULT);
3227 (void) ficlDictionarySetPrimitive(dictionary, "recurse",
3228 ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3229 (void) ficlDictionarySetPrimitive(dictionary, "repeat",
3230 ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3231 (void) ficlDictionarySetPrimitive(dictionary, "s\"",
3232 ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE);
3233 (void) ficlDictionarySetPrimitive(dictionary, "sign",
3234 ficlPrimitiveSign, FICL_WORD_DEFAULT);
3235 (void) ficlDictionarySetPrimitive(dictionary, "sm/rem",
3236 ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT);
3237 (void) ficlDictionarySetPrimitive(dictionary, "source",
3238 ficlPrimitiveSource, FICL_WORD_DEFAULT);
3239 (void) ficlDictionarySetPrimitive(dictionary, "state",
3240 ficlPrimitiveState, FICL_WORD_DEFAULT);
3241 (void) ficlDictionarySetPrimitive(dictionary, "then",
3242 ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3243 (void) ficlDictionarySetPrimitive(dictionary, "type",
3244 ficlPrimitiveType, FICL_WORD_DEFAULT);
3245 (void) ficlDictionarySetPrimitive(dictionary, "u.",
3246 ficlPrimitiveUDot, FICL_WORD_DEFAULT);
3247 (void) ficlDictionarySetPrimitive(dictionary, "um*",
3248 ficlPrimitiveUMStar, FICL_WORD_DEFAULT);
3249 (void) ficlDictionarySetPrimitive(dictionary, "um/mod",
3250 ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT);
3251 (void) ficlDictionarySetPrimitive(dictionary, "until",
3252 ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3253 (void) ficlDictionarySetPrimitive(dictionary, "variable",
3254 ficlPrimitiveVariable, FICL_WORD_DEFAULT);
3255 (void) ficlDictionarySetPrimitive(dictionary, "while",
3256 ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3257 (void) ficlDictionarySetPrimitive(dictionary, "word",
3258 ficlPrimitiveWord, FICL_WORD_DEFAULT);
3259 (void) ficlDictionarySetPrimitive(dictionary, "[",
3260 ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3261 (void) ficlDictionarySetPrimitive(dictionary, "[\']",
3262 ficlPrimitiveBracketTickCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3263 (void) ficlDictionarySetPrimitive(dictionary, "[char]",
3264 ficlPrimitiveCharCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3265 (void) ficlDictionarySetPrimitive(dictionary, "]",
3266 ficlPrimitiveRightBracket, FICL_WORD_DEFAULT);
3267 /*
3268 * The Core Extensions word set...
3269 * see softcore.fr for other definitions
3270 */
3271 /* "#tib" */
3272 (void) ficlDictionarySetPrimitive(dictionary, ".(",
3273 ficlPrimitiveDotParen, FICL_WORD_IMMEDIATE);
3274 /* ".r" is in softcore */
3275 (void) ficlDictionarySetPrimitive(dictionary, ":noname",
3276 ficlPrimitiveColonNoName, FICL_WORD_DEFAULT);
3277 (void) ficlDictionarySetPrimitive(dictionary, "?do",
3278 ficlPrimitiveQDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3279 (void) ficlDictionarySetPrimitive(dictionary, "again",
3280 ficlPrimitiveAgainCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3281 (void) ficlDictionarySetPrimitive(dictionary, "c\"",
3282 ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE);
3283 (void) ficlDictionarySetPrimitive(dictionary, "hex",
3284 ficlPrimitiveHex, FICL_WORD_DEFAULT);
3285 (void) ficlDictionarySetPrimitive(dictionary, "pad",
3286 ficlPrimitivePad, FICL_WORD_DEFAULT);
3287 (void) ficlDictionarySetPrimitive(dictionary, "parse",
3288 ficlPrimitiveParse, FICL_WORD_DEFAULT);
3289
3290 /*
3291 * query restore-input save-input tib u.r u> unused
3292 * [FICL_VM_STATE_COMPILE]
3293 */
3294 (void) ficlDictionarySetPrimitive(dictionary, "refill",
3295 ficlPrimitiveRefill, FICL_WORD_DEFAULT);
3296 (void) ficlDictionarySetPrimitive(dictionary, "source-id",
3297 ficlPrimitiveSourceID, FICL_WORD_DEFAULT);
3298 (void) ficlDictionarySetPrimitive(dictionary, "to",
3299 ficlPrimitiveToValue, FICL_WORD_IMMEDIATE);
3300 (void) ficlDictionarySetPrimitive(dictionary, "value",
3301 ficlPrimitiveConstant, FICL_WORD_DEFAULT);
3302 (void) ficlDictionarySetPrimitive(dictionary, "\\",
3303 ficlPrimitiveBackslash, FICL_WORD_IMMEDIATE);
3304
3305 /*
3306 * Environment query values for the Core word set
3307 */
3308 (void) ficlDictionarySetConstant(environment, "/counted-string",
3309 FICL_COUNTED_STRING_MAX);
3310 (void) ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE);
3311 (void) ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE);
3312 (void) ficlDictionarySetConstant(environment, "address-unit-bits", 8);
3313 (void) ficlDictionarySetConstant(environment, "core", FICL_TRUE);
3314 (void) ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE);
3315 (void) ficlDictionarySetConstant(environment, "floored", FICL_FALSE);
3316 (void) ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX);
3317 (void) ficlDictionarySetConstant(environment, "max-n", LONG_MAX);
3318 (void) ficlDictionarySetConstant(environment, "max-u", ULONG_MAX);
3319
3320 {
3321 ficl2Integer id;
3322 ficlInteger low, high;
3323
3324 low = ULONG_MAX;
3325 high = LONG_MAX;
3326 FICL_2INTEGER_SET(high, low, id);
3327 (void) ficlDictionarySet2Constant(environment, "max-d", id);
3328 high = ULONG_MAX;
3329 FICL_2INTEGER_SET(high, low, id);
3330 (void) ficlDictionarySet2Constant(environment, "max-ud", id);
3331 }
3332
3333 (void) ficlDictionarySetConstant(environment, "return-stack-cells",
3334 FICL_DEFAULT_STACK_SIZE);
3335 (void) ficlDictionarySetConstant(environment, "stack-cells",
3336 FICL_DEFAULT_STACK_SIZE);
3337
3338 /*
3339 * The optional Double-Number word set (partial)
3340 */
3341 (void) ficlDictionarySetPrimitive(dictionary, "2constant",
3342 ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
3343 (void) ficlDictionarySetPrimitive(dictionary, "2literal",
3344 ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE);
3345 (void) ficlDictionarySetPrimitive(dictionary, "2variable",
3346 ficlPrimitive2Variable, FICL_WORD_IMMEDIATE);
3347 /*
3348 * D+ D- D. D.R D0< D0= D2* D2/ in softcore
3349 * D< D= D>S DABS DMAX DMIN DNEGATE in softcore
3350 * m-star-slash is TODO
3351 * M+ in softcore
3352 */
3353
3354 /*
3355 * DOUBLE EXT
3356 */
3357 (void) ficlDictionarySetPrimitive(dictionary, "2rot",
3358 ficlPrimitive2Rot, FICL_WORD_DEFAULT);
3359 (void) ficlDictionarySetPrimitive(dictionary, "2value",
3360 ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
3361 /* du< in softcore */
3362 /*
3363 * The optional Exception and Exception Extensions word set
3364 */
3365 (void) ficlDictionarySetPrimitive(dictionary, "catch",
3366 ficlPrimitiveCatch, FICL_WORD_DEFAULT);
3367 (void) ficlDictionarySetPrimitive(dictionary, "throw",
3368 ficlPrimitiveThrow, FICL_WORD_DEFAULT);
3369
3370 (void) ficlDictionarySetConstant(environment, "exception", FICL_TRUE);
3371 (void) ficlDictionarySetConstant(environment, "exception-ext",
3372 FICL_TRUE);
3373
3374 /*
3375 * The optional Locals and Locals Extensions word set
3376 * see softcore.c for implementation of locals|
3377 */
3378 #if FICL_WANT_LOCALS
3379 (void) ficlDictionarySetPrimitive(dictionary, "doLocal",
3380 ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3381 (void) ficlDictionarySetPrimitive(dictionary, "(local)",
3382 ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY);
3383 (void) ficlDictionarySetPrimitive(dictionary, "(2local)",
3384 ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY);
3385
3386 (void) ficlDictionarySetConstant(environment, "locals", FICL_TRUE);
3387 (void) ficlDictionarySetConstant(environment, "locals-ext", FICL_TRUE);
3388 (void) ficlDictionarySetConstant(environment, "#locals",
3389 FICL_MAX_LOCALS);
3390 #endif
3391
3392 /*
3393 * The optional Memory-Allocation word set
3394 */
3395
3396 (void) ficlDictionarySetPrimitive(dictionary, "allocate",
3397 ficlPrimitiveAllocate, FICL_WORD_DEFAULT);
3398 (void) ficlDictionarySetPrimitive(dictionary, "free",
3399 ficlPrimitiveFree, FICL_WORD_DEFAULT);
3400 (void) ficlDictionarySetPrimitive(dictionary, "resize",
3401 ficlPrimitiveResize, FICL_WORD_DEFAULT);
3402
3403 (void) ficlDictionarySetConstant(environment, "memory-alloc",
3404 FICL_TRUE);
3405
3406 /*
3407 * The optional Search-Order word set
3408 */
3409 ficlSystemCompileSearch(system);
3410
3411 /*
3412 * The optional Programming-Tools and Programming-Tools
3413 * Extensions word set
3414 */
3415 ficlSystemCompileTools(system);
3416
3417 /*
3418 * The optional File-Access and File-Access Extensions word set
3419 */
3420 #if FICL_WANT_FILE
3421 ficlSystemCompileFile(system);
3422 #endif
3423
3424 /*
3425 * Ficl extras
3426 */
3427 (void) ficlDictionarySetPrimitive(dictionary, ".ver",
3428 ficlPrimitiveVersion, FICL_WORD_DEFAULT);
3429 (void) ficlDictionarySetPrimitive(dictionary, ">name",
3430 ficlPrimitiveToName, FICL_WORD_DEFAULT);
3431 (void) ficlDictionarySetPrimitive(dictionary, "add-parse-step",
3432 ficlPrimitiveAddParseStep, FICL_WORD_DEFAULT);
3433 (void) ficlDictionarySetPrimitive(dictionary, "body>",
3434 ficlPrimitiveFromBody, FICL_WORD_DEFAULT);
3435 (void) ficlDictionarySetPrimitive(dictionary, "compile-only",
3436 ficlPrimitiveCompileOnly, FICL_WORD_DEFAULT);
3437 (void) ficlDictionarySetPrimitive(dictionary, "endif",
3438 ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3439 (void) ficlDictionarySetPrimitive(dictionary, "last-word",
3440 ficlPrimitiveLastWord, FICL_WORD_DEFAULT);
3441 (void) ficlDictionarySetPrimitive(dictionary, "hash",
3442 ficlPrimitiveHash, FICL_WORD_DEFAULT);
3443 (void) ficlDictionarySetPrimitive(dictionary, "objectify",
3444 ficlPrimitiveSetObjectFlag, FICL_WORD_DEFAULT);
3445 (void) ficlDictionarySetPrimitive(dictionary, "?object",
3446 ficlPrimitiveIsObject, FICL_WORD_DEFAULT);
3447 (void) ficlDictionarySetPrimitive(dictionary, "parse-word",
3448 ficlPrimitiveParseNoCopy, FICL_WORD_DEFAULT);
3449 (void) ficlDictionarySetPrimitive(dictionary, "sfind",
3450 ficlPrimitiveSFind, FICL_WORD_DEFAULT);
3451 (void) ficlDictionarySetPrimitive(dictionary, "sliteral",
3452 ficlPrimitiveSLiteralCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
3453 (void) ficlDictionarySetPrimitive(dictionary, "sprintf",
3454 ficlPrimitiveSprintf, FICL_WORD_DEFAULT);
3455 (void) ficlDictionarySetPrimitive(dictionary, "strlen",
3456 ficlPrimitiveStrlen, FICL_WORD_DEFAULT);
3457 (void) ficlDictionarySetPrimitive(dictionary, "x.",
3458 ficlPrimitiveHexDot, FICL_WORD_DEFAULT);
3459 #if FICL_WANT_USER
3460 (void) ficlDictionarySetPrimitive(dictionary, "user",
3461 ficlPrimitiveUser, FICL_WORD_DEFAULT);
3462 #endif
3463
3464 /*
3465 * internal support words
3466 */
3467 interpret = ficlDictionarySetPrimitive(dictionary, "interpret",
3468 ficlPrimitiveInterpret, FICL_WORD_DEFAULT);
3469 (void) ficlDictionarySetPrimitive(dictionary, "lookup",
3470 ficlPrimitiveLookup, FICL_WORD_DEFAULT);
3471 (void) ficlDictionarySetPrimitive(dictionary, "(parse-step)",
3472 ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
3473 system->exitInnerWord = ficlDictionarySetPrimitive(dictionary,
3474 "exit-inner", ficlPrimitiveExitInner, FICL_WORD_DEFAULT);
3475
3476 /*
3477 * Set constants representing the internal instruction words
3478 * If you want all of 'em, turn that "#if 0" to "#if 1".
3479 * By default you only get the numbers (fi0, fiNeg1, etc).
3480 */
3481 #define FICL_TOKEN(token, description) \
3482 (void) ficlDictionarySetConstant(dictionary, #token, token);
3483 #if 0
3484 #define FICL_INSTRUCTION_TOKEN(token, description, flags) \
3485 ficlDictionarySetConstant(dictionary, #token, token);
3486 #else
3487 #define FICL_INSTRUCTION_TOKEN(token, description, flags)
3488 #endif /* 0 */
3489 #include "ficltokens.h"
3490 #undef FICL_TOKEN
3491 #undef FICL_INSTRUCTION_TOKEN
3492
3493 /*
3494 * Set up system's outer interpreter loop - maybe this should
3495 * be in initSystem?
3496 */
3497 system->interpreterLoop[0] = interpret;
3498 system->interpreterLoop[1] = (ficlWord *)ficlInstructionBranchParen;
3499 system->interpreterLoop[2] = (ficlWord *)(void *)(-2);
3500
3501 FICL_SYSTEM_ASSERT(system,
3502 ficlDictionaryCellsAvailable(dictionary) > 0);
3503 }
3504