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 $
10 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 * All rights reserved.
13 * Get the latest Ficl release at http://ficl.sourceforge.net
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.
20 * L I C E N S E and D I S C L A I M E R
22 * Redistribution and use in source and binary forms, with or without
23 * modification, are permitted provided that the following conditions
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.
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
48 * Control structure building words use these
49 * strings' addresses as markers on the stack to
50 * check for structure completion.
52 static char doTag
[] = "do";
53 static char colonTag
[] = "colon";
54 static char leaveTag
[] = "leave";
56 static char destTag
[] = "target";
57 static char origTag
[] = "origin";
59 static char caseTag
[] = "case";
60 static char ofTag
[] = "of";
61 static char fallthroughTag
[] = "fallthrough";
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
66 * Push current dictionary location for later branch resolution.
67 * The location may be either a branch target or a patch address...
70 markBranch(ficlDictionary
*dictionary
, ficlVm
*vm
, char *tag
)
72 ficlStackPushPointer(vm
->dataStack
, dictionary
->here
);
73 ficlStackPushPointer(vm
->dataStack
, tag
);
77 markControlTag(ficlVm
*vm
, char *tag
)
79 ficlStackPushPointer(vm
->dataStack
, tag
);
83 matchControlTag(ficlVm
*vm
, char *wantTag
)
87 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
89 tag
= (char *)ficlStackPopPointer(vm
->dataStack
);
92 * Changed the code below to compare the pointers first
95 if ((tag
!= wantTag
) && strcmp(tag
, wantTag
)) {
97 "Error -- unmatched control structure \"%s\"", wantTag
);
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
107 resolveBackBranch(ficlDictionary
*dictionary
, ficlVm
*vm
, char *tag
)
109 ficlCell
*patchAddr
, c
;
111 matchControlTag(vm
, tag
);
113 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
115 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
116 c
.i
= patchAddr
- dictionary
->here
;
118 ficlDictionaryAppendCell(dictionary
, c
);
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
127 resolveForwardBranch(ficlDictionary
*dictionary
, ficlVm
*vm
, char *tag
)
132 matchControlTag(vm
, tag
);
134 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
136 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
137 offset
= dictionary
->here
- patchAddr
;
138 (*patchAddr
).i
= offset
;
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.
147 resolveAbsBranch(ficlDictionary
*dictionary
, ficlVm
*vm
, char *wantTag
)
152 FICL_STACK_CHECK(vm
->dataStack
, 2, 0);
154 tag
= ficlStackPopPointer(vm
->dataStack
);
157 * Changed the comparison below to compare the pointers first
158 * (by popular demand)
160 if ((tag
!= wantTag
) && strcmp(tag
, wantTag
)) {
161 ficlVmTextOut(vm
, "Warning -- Unmatched control word: ");
162 ficlVmTextOut(vm
, wantTag
);
163 ficlVmTextOut(vm
, "\n");
166 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
167 (*patchAddr
).p
= dictionary
->here
;
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.
178 ficlPrimitiveColon(ficlVm
*vm
)
180 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
181 ficlString name
= ficlVmGetWord(vm
);
183 vm
->state
= FICL_VM_STATE_COMPILE
;
184 markControlTag(vm
, colonTag
);
185 ficlDictionaryAppendWord(dictionary
, name
,
186 (ficlPrimitive
)ficlInstructionColonParen
,
187 FICL_WORD_DEFAULT
| FICL_WORD_SMUDGED
);
190 vm
->callback
.system
->localsCount
= 0;
195 ficlPrimitiveSemicolonCoIm(ficlVm
*vm
)
197 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
199 matchControlTag(vm
, colonTag
);
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
);
209 vm
->callback
.system
->localsCount
= 0;
212 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionSemiParen
);
213 vm
->state
= FICL_VM_STATE_INTERPRET
;
214 ficlDictionaryUnsmudge(dictionary
);
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".
227 ficlPrimitiveExitCoIm(ficlVm
*vm
)
229 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
233 if (vm
->callback
.system
->localsCount
> 0) {
234 ficlDictionaryAppendUnsigned(dictionary
,
235 ficlInstructionUnlinkParen
);
238 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionExitParen
);
244 * Compiles a constant into the dictionary. Constants return their
245 * value when invoked. Expects a value on top of the parm stack.
248 ficlPrimitiveConstant(ficlVm
*vm
)
250 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
251 ficlString name
= ficlVmGetWord(vm
);
253 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
255 ficlDictionaryAppendConstantInstruction(dictionary
, name
,
256 ficlInstructionConstantParen
, ficlStackPopInteger(vm
->dataStack
));
260 ficlPrimitive2Constant(ficlVm
*vm
)
262 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
263 ficlString name
= ficlVmGetWord(vm
);
265 FICL_STACK_CHECK(vm
->dataStack
, 2, 0);
267 ficlDictionaryAppend2ConstantInstruction(dictionary
, name
,
268 ficlInstruction2ConstantParen
, ficlStackPop2Integer(vm
->dataStack
));
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
277 ficlPrimitiveDot(ficlVm
*vm
)
281 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
283 c
= ficlStackPop(vm
->dataStack
);
284 ficlLtoa((c
).i
, vm
->pad
, vm
->base
);
285 strcat(vm
->pad
, " ");
286 ficlVmTextOut(vm
, vm
->pad
);
290 ficlPrimitiveUDot(ficlVm
*vm
)
294 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
296 u
= ficlStackPopUnsigned(vm
->dataStack
);
297 ficlUltoa(u
, vm
->pad
, vm
->base
);
298 strcat(vm
->pad
, " ");
299 ficlVmTextOut(vm
, vm
->pad
);
303 ficlPrimitiveHexDot(ficlVm
*vm
)
307 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
309 u
= ficlStackPopUnsigned(vm
->dataStack
);
310 ficlUltoa(u
, vm
->pad
, 16);
311 strcat(vm
->pad
, " ");
312 ficlVmTextOut(vm
, vm
->pad
);
317 * Ficl ( c-string -- length )
319 * Returns the length of a C-style (zero-terminated) string.
324 ficlPrimitiveStrlen(ficlVm
*vm
)
326 char *address
= (char *)ficlStackPopPointer(vm
->dataStack
);
327 ficlStackPushInteger(vm
->dataStack
, strlen(address
));
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
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).
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).
357 ficlPrimitiveSprintf(ficlVm
*vm
)
359 int bufferLength
= ficlStackPopInteger(vm
->dataStack
);
360 char *buffer
= (char *)ficlStackPopPointer(vm
->dataStack
);
361 char *bufferStart
= buffer
;
363 int formatLength
= ficlStackPopInteger(vm
->dataStack
);
364 char *format
= (char *)ficlStackPopPointer(vm
->dataStack
);
365 char *formatStop
= format
+ formatLength
;
368 int unsignedInteger
= 0; /* false */
370 int append
= 1; /* true */
372 while (format
< formatStop
) {
379 if (*format
!= '%') {
381 actualLength
= desiredLength
= 1;
385 if (format
== formatStop
)
388 leadingZeroes
= (*format
== '0');
391 if (format
== formatStop
)
395 desiredLength
= isdigit((unsigned char)*format
);
397 desiredLength
= strtoul(format
, &format
, 10);
398 if (format
== formatStop
)
400 } else if (*format
== '*') {
402 ficlStackPopInteger(vm
->dataStack
);
405 if (format
== formatStop
)
413 ficlStackPopInteger(vm
->dataStack
);
415 ficlStackPopPointer(vm
->dataStack
);
423 unsignedInteger
= 1; /* true */
428 integer
= ficlStackPopInteger(vm
->dataStack
);
430 ficlUltoa(integer
, scratch
, base
);
432 ficlLtoa(integer
, scratch
, base
);
434 unsignedInteger
= 0; /* false */
436 actualLength
= strlen(scratch
);
450 desiredLength
= actualLength
;
451 if (desiredLength
> bufferLength
) {
452 append
= 0; /* false */
453 desiredLength
= bufferLength
;
455 while (desiredLength
> actualLength
) {
456 *buffer
++ = (char)((leadingZeroes
) ? '0' : ' ');
460 memcpy(buffer
, source
, actualLength
);
461 buffer
+= actualLength
;
462 bufferLength
-= actualLength
;
468 ficlStackPushPointer(vm
->dataStack
, bufferStart
);
469 ficlStackPushInteger(vm
->dataStack
, buffer
- bufferStart
);
470 ficlStackPushInteger(vm
->dataStack
, FICL_BOOL(!append
));
474 * d u p & f r i e n d s
477 ficlPrimitiveDepth(ficlVm
*vm
)
481 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
483 i
= ficlStackDepth(vm
->dataStack
);
484 ficlStackPushInteger(vm
->dataStack
, i
);
488 * e m i t & f r i e n d s
491 ficlPrimitiveEmit(ficlVm
*vm
)
496 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
498 i
= ficlStackPopInteger(vm
->dataStack
);
501 ficlVmTextOut(vm
, buffer
);
505 ficlPrimitiveCR(ficlVm
*vm
)
507 ficlVmTextOut(vm
, "\n");
511 ficlPrimitiveBackslash(ficlVm
*vm
)
513 char *trace
= ficlVmGetInBuf(vm
);
514 char *stop
= ficlVmGetInBufEnd(vm
);
517 while ((trace
!= stop
) && (c
!= '\r') && (c
!= '\n')) {
522 * Cope with DOS or UNIX-style EOLs -
523 * Check for /r, /n, /r/n, or /n/r end-of-line sequences,
524 * and point trace to next char. If EOL is \0, we're done.
529 if ((trace
!= stop
) && (c
!= *trace
) &&
530 ((*trace
== '\r') || (*trace
== '\n')))
534 ficlVmUpdateTib(vm
, trace
);
539 * Compilation: Perform the execution semantics given below.
540 * Execution: ( "ccc<paren>" -- )
541 * Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
542 * The number of characters in ccc may be zero to the number of characters
546 ficlPrimitiveParenthesis(ficlVm
*vm
)
548 ficlVmParseStringEx(vm
, ')', 0);
552 * F E T C H & S T O R E
558 * Compiles code for a conditional branch into the dictionary
559 * and pushes the branch patch address on the stack for later
560 * patching by ELSE or THEN/ENDIF.
563 ficlPrimitiveIfCoIm(ficlVm
*vm
)
565 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
567 ficlDictionaryAppendUnsigned(dictionary
,
568 ficlInstructionBranch0ParenWithCheck
);
569 markBranch(dictionary
, vm
, origTag
);
570 ficlDictionaryAppendUnsigned(dictionary
, 1);
576 * IMMEDIATE -- compiles an "else"...
577 * 1) FICL_VM_STATE_COMPILE a branch and a patch address;
578 * the address gets patched
579 * by "endif" to point past the "else" code.
580 * 2) Pop the the "if" patch address
581 * 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE
583 * 4) Push the "else" patch address. ("endif" patches this to jump past
587 ficlPrimitiveElseCoIm(ficlVm
*vm
)
591 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
593 /* (1) FICL_VM_STATE_COMPILE branch runtime */
594 ficlDictionaryAppendUnsigned(dictionary
,
595 ficlInstructionBranchParenWithCheck
);
597 matchControlTag(vm
, origTag
);
598 /* (2) pop "if" patch addr */
599 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
600 markBranch(dictionary
, vm
, origTag
); /* (4) push "else" patch addr */
602 /* (1) FICL_VM_STATE_COMPILE patch placeholder */
603 ficlDictionaryAppendUnsigned(dictionary
, 1);
604 offset
= dictionary
->here
- patchAddr
;
605 (*patchAddr
).i
= offset
; /* (3) Patch "if" */
612 ficlPrimitiveEndifCoIm(ficlVm
*vm
)
614 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
615 resolveForwardBranch(dictionary
, vm
, origTag
);
620 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
623 * At FICL_VM_STATE_COMPILE-time, a CASE-SYS (see DPANS94 6.2.0873) looks
626 * and an OF-SYS (see DPANS94 6.2.1950) looks like this:
627 * i*addr i caseTag addr ofTag
628 * The integer under caseTag is the count of fixup addresses that branch
632 ficlPrimitiveCaseCoIm(ficlVm
*vm
)
634 FICL_STACK_CHECK(vm
->dataStack
, 0, 2);
636 ficlStackPushUnsigned(vm
->dataStack
, 0);
637 markControlTag(vm
, caseTag
);
641 * e n d c a s eC o I m
642 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
645 ficlPrimitiveEndcaseCoIm(ficlVm
*vm
)
647 ficlUnsigned fixupCount
;
648 ficlDictionary
*dictionary
;
653 * if the last OF ended with FALLTHROUGH,
654 * just add the FALLTHROUGH fixup to the
657 if (ficlStackGetTop(vm
->dataStack
).p
== fallthroughTag
) {
658 matchControlTag(vm
, fallthroughTag
);
659 patchAddr
= ficlStackPopPointer(vm
->dataStack
);
660 matchControlTag(vm
, caseTag
);
661 fixupCount
= ficlStackPopUnsigned(vm
->dataStack
);
662 ficlStackPushPointer(vm
->dataStack
, patchAddr
);
663 ficlStackPushUnsigned(vm
->dataStack
, fixupCount
+ 1);
664 markControlTag(vm
, caseTag
);
667 matchControlTag(vm
, caseTag
);
669 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
671 fixupCount
= ficlStackPopUnsigned(vm
->dataStack
);
672 FICL_STACK_CHECK(vm
->dataStack
, fixupCount
, 0);
674 dictionary
= ficlVmGetDictionary(vm
);
676 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionDrop
);
678 while (fixupCount
--) {
679 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
680 offset
= dictionary
->here
- patchAddr
;
681 (*patchAddr
).i
= offset
;
687 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
690 ficlPrimitiveOfCoIm(ficlVm
*vm
)
692 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
693 ficlCell
*fallthroughFixup
= NULL
;
695 FICL_STACK_CHECK(vm
->dataStack
, 1, 3);
697 if (ficlStackGetTop(vm
->dataStack
).p
== fallthroughTag
) {
698 matchControlTag(vm
, fallthroughTag
);
699 fallthroughFixup
= ficlStackPopPointer(vm
->dataStack
);
702 matchControlTag(vm
, caseTag
);
704 markControlTag(vm
, caseTag
);
706 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionOfParen
);
707 markBranch(dictionary
, vm
, ofTag
);
708 ficlDictionaryAppendUnsigned(dictionary
, 2);
710 if (fallthroughFixup
!= NULL
) {
711 ficlInteger offset
= dictionary
->here
- fallthroughFixup
;
712 (*fallthroughFixup
).i
= offset
;
718 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
721 ficlPrimitiveEndofCoIm(ficlVm
*vm
)
724 ficlUnsigned fixupCount
;
726 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
728 FICL_STACK_CHECK(vm
->dataStack
, 4, 3);
730 /* ensure we're in an OF, */
731 matchControlTag(vm
, ofTag
);
733 /* grab the address of the branch location after the OF */
734 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
735 /* ensure we're also in a "case" */
736 matchControlTag(vm
, caseTag
);
737 /* grab the current number of ENDOF fixups */
738 fixupCount
= ficlStackPopUnsigned(vm
->dataStack
);
740 /* FICL_VM_STATE_COMPILE branch runtime */
741 ficlDictionaryAppendUnsigned(dictionary
,
742 ficlInstructionBranchParenWithCheck
);
745 * push a new ENDOF fixup, the updated count of ENDOF fixups,
748 ficlStackPushPointer(vm
->dataStack
, dictionary
->here
);
749 ficlStackPushUnsigned(vm
->dataStack
, fixupCount
+ 1);
750 markControlTag(vm
, caseTag
);
752 /* reserve space for the ENDOF fixup */
753 ficlDictionaryAppendUnsigned(dictionary
, 2);
755 /* and patch the original OF */
756 offset
= dictionary
->here
- patchAddr
;
757 (*patchAddr
).i
= offset
;
761 * f a l l t h r o u g h C o I m
762 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
765 ficlPrimitiveFallthroughCoIm(ficlVm
*vm
)
769 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
771 FICL_STACK_CHECK(vm
->dataStack
, 4, 3);
773 /* ensure we're in an OF, */
774 matchControlTag(vm
, ofTag
);
775 /* grab the address of the branch location after the OF */
776 patchAddr
= (ficlCell
*)ficlStackPopPointer(vm
->dataStack
);
777 /* ensure we're also in a "case" */
778 matchControlTag(vm
, caseTag
);
780 /* okay, here we go. put the case tag back. */
781 markControlTag(vm
, caseTag
);
783 /* FICL_VM_STATE_COMPILE branch runtime */
784 ficlDictionaryAppendUnsigned(dictionary
,
785 ficlInstructionBranchParenWithCheck
);
787 /* push a new FALLTHROUGH fixup and the fallthroughTag */
788 ficlStackPushPointer(vm
->dataStack
, dictionary
->here
);
789 markControlTag(vm
, fallthroughTag
);
791 /* reserve space for the FALLTHROUGH fixup */
792 ficlDictionaryAppendUnsigned(dictionary
, 2);
794 /* and patch the original OF */
795 offset
= dictionary
->here
- patchAddr
;
796 (*patchAddr
).i
= offset
;
801 * hash ( c-addr u -- code)
802 * calculates hashcode of specified string and leaves it on the stack
805 ficlPrimitiveHash(ficlVm
*vm
)
809 FICL_STRING_SET_LENGTH(s
, ficlStackPopUnsigned(vm
->dataStack
));
810 FICL_STRING_SET_POINTER(s
, ficlStackPopPointer(vm
->dataStack
));
811 ficlStackPushUnsigned(vm
->dataStack
, ficlHashCode(s
));
816 * This is the "user interface" of a Forth. It does the following:
817 * while there are words in the VM's Text Input Buffer
818 * Copy next word into the pad (ficlVmGetWord)
819 * Attempt to find the word in the dictionary (ficlDictionaryLookup)
820 * If successful, execute the word.
821 * Otherwise, attempt to convert the word to a number (isNumber)
822 * If successful, push the number onto the parameter stack.
823 * Otherwise, print an error message and exit loop...
826 * From the standard, section 3.4
827 * Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
828 * repeat the following steps until either the parse area is empty or an
829 * ambiguous condition exists:
830 * a) Skip leading spaces and parse a name (see 3.4.1);
833 ficlPrimitiveInterpret(ficlVm
*vm
)
839 FICL_VM_ASSERT(vm
, vm
);
841 system
= vm
->callback
.system
;
842 s
= ficlVmGetWord0(vm
);
845 * Get next word...if out of text, we're done.
848 ficlVmThrow(vm
, FICL_VM_STATUS_OUT_OF_TEXT
);
852 * Run the parse chain against the incoming token until somebody
853 * eats it. Otherwise emit an error message and give up.
855 for (i
= 0; i
< FICL_MAX_PARSE_STEPS
; i
++) {
856 ficlWord
*word
= system
->parseList
[i
];
861 if (word
->code
== ficlPrimitiveParseStepParen
) {
863 pStep
= (ficlParseStep
)(word
->param
->fn
);
867 ficlStackPushPointer(vm
->dataStack
,
868 FICL_STRING_GET_POINTER(s
));
869 ficlStackPushUnsigned(vm
->dataStack
,
870 FICL_STRING_GET_LENGTH(s
));
871 ficlVmExecuteXT(vm
, word
);
872 if (ficlStackPopInteger(vm
->dataStack
))
877 ficlVmThrowError(vm
, "%.*s not found", FICL_STRING_GET_LENGTH(s
),
878 FICL_STRING_GET_POINTER(s
));
879 /* back to inner interpreter */
883 * Surrogate precompiled parse step for ficlParseWord
884 * (this step is hard coded in FICL_VM_STATE_INTERPRET)
887 ficlPrimitiveLookup(ficlVm
*vm
)
890 FICL_STRING_SET_LENGTH(name
, ficlStackPopUnsigned(vm
->dataStack
));
891 FICL_STRING_SET_POINTER(name
, ficlStackPopPointer(vm
->dataStack
));
892 ficlStackPushInteger(vm
->dataStack
, ficlVmParseWord(vm
, name
));
896 * p a r e n P a r s e S t e p
897 * (parse-step) ( c-addr u -- flag )
898 * runtime for a precompiled parse step - pop a counted string off the
899 * stack, run the parse step against it, and push the result flag (FICL_TRUE
900 * if success, FICL_FALSE otherwise).
903 ficlPrimitiveParseStepParen(ficlVm
*vm
)
906 ficlWord
*word
= vm
->runningWord
;
907 ficlParseStep pStep
= (ficlParseStep
)(word
->param
->fn
);
909 FICL_STRING_SET_LENGTH(s
, ficlStackPopInteger(vm
->dataStack
));
910 FICL_STRING_SET_POINTER(s
, ficlStackPopPointer(vm
->dataStack
));
912 ficlStackPushInteger(vm
->dataStack
, (*pStep
)(vm
, s
));
916 ficlPrimitiveAddParseStep(ficlVm
*vm
)
919 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
921 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
923 pStep
= (ficlWord
*)(ficlStackPop(vm
->dataStack
).p
);
924 if ((pStep
!= NULL
) && ficlDictionaryIsAWord(dictionary
, pStep
))
925 ficlSystemAddParseStep(vm
->callback
.system
, pStep
);
931 * IMMEDIATE code for "literal". This function gets a value from the stack
932 * and compiles it into the dictionary preceded by the code for "(literal)".
936 ficlPrimitiveLiteralIm(ficlVm
*vm
)
938 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
941 value
= ficlStackPopInteger(vm
->dataStack
);
960 ficlDictionaryAppendUnsigned(dictionary
, value
);
980 ficlDictionaryAppendUnsigned(dictionary
,
981 ficlInstruction0
- value
);
985 ficlDictionaryAppendUnsigned(dictionary
,
986 ficlInstructionLiteralParen
);
987 ficlDictionaryAppendUnsigned(dictionary
, value
);
993 ficlPrimitive2LiteralIm(ficlVm
*vm
)
995 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
997 ficlDictionaryAppendUnsigned(dictionary
, ficlInstruction2LiteralParen
);
998 ficlDictionaryAppendCell(dictionary
, ficlStackPop(vm
->dataStack
));
999 ficlDictionaryAppendCell(dictionary
, ficlStackPop(vm
->dataStack
));
1004 * do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
1005 * Compiles code to initialize a loop: FICL_VM_STATE_COMPILE (do),
1006 * allot space to hold the "leave" address, push a branch
1007 * target address for the loop.
1008 * (do) -- runtime for "do"
1009 * pops index and limit from the p stack and moves them
1010 * to the r stack, then skips to the loop body.
1011 * loop -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
1013 * Compiles code for the test part of a loop:
1014 * FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and
1015 * copy "here" address to the "leave" address allotted by "do"
1016 * i,j,k -- FICL_VM_STATE_COMPILE ONLY
1017 * Runtime: Push loop indices on param stack (i is innermost loop...)
1018 * Note: each loop has three values on the return stack:
1019 * ( R: leave limit index )
1020 * "leave" is the absolute address of the next ficlCell after the loop
1021 * limit and index are the loop control variables.
1022 * leave -- FICL_VM_STATE_COMPILE ONLY
1023 * Runtime: pop the loop control variables, then pop the
1024 * "leave" address and jump (absolute) there.
1027 ficlPrimitiveDoCoIm(ficlVm
*vm
)
1029 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1031 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionDoParen
);
1033 * Allot space for a pointer to the end
1034 * of the loop - "leave" uses this...
1036 markBranch(dictionary
, vm
, leaveTag
);
1037 ficlDictionaryAppendUnsigned(dictionary
, 0);
1039 * Mark location of head of loop...
1041 markBranch(dictionary
, vm
, doTag
);
1045 ficlPrimitiveQDoCoIm(ficlVm
*vm
)
1047 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1049 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionQDoParen
);
1051 * Allot space for a pointer to the end
1052 * of the loop - "leave" uses this...
1054 markBranch(dictionary
, vm
, leaveTag
);
1055 ficlDictionaryAppendUnsigned(dictionary
, 0);
1057 * Mark location of head of loop...
1059 markBranch(dictionary
, vm
, doTag
);
1064 ficlPrimitiveLoopCoIm(ficlVm
*vm
)
1066 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1068 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionLoopParen
);
1069 resolveBackBranch(dictionary
, vm
, doTag
);
1070 resolveAbsBranch(dictionary
, vm
, leaveTag
);
1074 ficlPrimitivePlusLoopCoIm(ficlVm
*vm
)
1076 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1078 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionPlusLoopParen
);
1079 resolveBackBranch(dictionary
, vm
, doTag
);
1080 resolveAbsBranch(dictionary
, vm
, leaveTag
);
1087 ficlPrimitiveVariable(ficlVm
*vm
)
1089 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1090 ficlString name
= ficlVmGetWord(vm
);
1092 ficlDictionaryAppendWord(dictionary
, name
,
1093 (ficlPrimitive
)ficlInstructionVariableParen
, FICL_WORD_DEFAULT
);
1094 ficlVmDictionaryAllotCells(vm
, dictionary
, 1);
1098 ficlPrimitive2Variable(ficlVm
*vm
)
1100 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1101 ficlString name
= ficlVmGetWord(vm
);
1103 ficlDictionaryAppendWord(dictionary
, name
,
1104 (ficlPrimitive
)ficlInstructionVariableParen
, FICL_WORD_DEFAULT
);
1105 ficlVmDictionaryAllotCells(vm
, dictionary
, 2);
1109 * b a s e & f r i e n d s
1112 ficlPrimitiveBase(ficlVm
*vm
)
1116 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
1118 pBase
= (ficlCell
*)(&vm
->base
);
1120 ficlStackPush(vm
->dataStack
, c
);
1124 ficlPrimitiveDecimal(ficlVm
*vm
)
1131 ficlPrimitiveHex(ficlVm
*vm
)
1137 * a l l o t & f r i e n d s
1140 ficlPrimitiveAllot(ficlVm
*vm
)
1142 ficlDictionary
*dictionary
;
1145 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
1147 dictionary
= ficlVmGetDictionary(vm
);
1148 i
= ficlStackPopInteger(vm
->dataStack
);
1150 FICL_VM_DICTIONARY_CHECK(vm
, dictionary
, i
);
1152 ficlVmDictionaryAllot(vm
, dictionary
, i
);
1156 ficlPrimitiveHere(ficlVm
*vm
)
1158 ficlDictionary
*dictionary
;
1160 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
1162 dictionary
= ficlVmGetDictionary(vm
);
1163 ficlStackPushPointer(vm
->dataStack
, dictionary
->here
);
1168 * tick CORE ( "<spaces>name" -- xt )
1169 * Skip leading space delimiters. Parse name delimited by a space. Find
1170 * name and return xt, the execution token for name. An ambiguous condition
1171 * exists if name is not found.
1174 ficlPrimitiveTick(ficlVm
*vm
)
1176 ficlWord
*word
= NULL
;
1177 ficlString name
= ficlVmGetWord(vm
);
1179 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
1181 word
= ficlDictionaryLookup(ficlVmGetDictionary(vm
), name
);
1183 ficlVmThrowError(vm
, "%.*s not found",
1184 FICL_STRING_GET_LENGTH(name
),
1185 FICL_STRING_GET_POINTER(name
));
1186 ficlStackPushPointer(vm
->dataStack
, word
);
1190 ficlPrimitiveBracketTickCoIm(ficlVm
*vm
)
1192 ficlPrimitiveTick(vm
);
1193 ficlPrimitiveLiteralIm(vm
);
1198 * Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to
1199 * insert it into definitions created by the resulting word
1200 * (defers compilation, even of immediate words)
1203 ficlPrimitivePostponeCoIm(ficlVm
*vm
)
1205 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1207 ficlWord
*pComma
= ficlSystemLookup(vm
->callback
.system
, ",");
1210 FICL_VM_ASSERT(vm
, pComma
);
1212 ficlPrimitiveTick(vm
);
1213 word
= ficlStackGetTop(vm
->dataStack
).p
;
1214 if (ficlWordIsImmediate(word
)) {
1215 ficlDictionaryAppendCell(dictionary
,
1216 ficlStackPop(vm
->dataStack
));
1218 ficlPrimitiveLiteralIm(vm
);
1220 ficlDictionaryAppendCell(dictionary
, c
);
1226 * Pop an execution token (pointer to a word) off the stack and
1230 ficlPrimitiveExecute(ficlVm
*vm
)
1234 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
1236 word
= ficlStackPopPointer(vm
->dataStack
);
1237 ficlVmExecuteWord(vm
, word
);
1242 * Make the most recently compiled word IMMEDIATE -- it executes even
1243 * in FICL_VM_STATE_COMPILE state (most often used for control compiling words
1244 * such as IF, THEN, etc)
1247 ficlPrimitiveImmediate(ficlVm
*vm
)
1250 ficlDictionarySetImmediate(ficlVmGetDictionary(vm
));
1254 ficlPrimitiveCompileOnly(ficlVm
*vm
)
1257 ficlDictionarySetFlags(ficlVmGetDictionary(vm
), FICL_WORD_COMPILE_ONLY
);
1261 ficlPrimitiveSetObjectFlag(ficlVm
*vm
)
1264 ficlDictionarySetFlags(ficlVmGetDictionary(vm
), FICL_WORD_OBJECT
);
1268 ficlPrimitiveIsObject(ficlVm
*vm
)
1271 ficlWord
*word
= (ficlWord
*)ficlStackPopPointer(vm
->dataStack
);
1273 flag
= ((word
!= NULL
) && (word
->flags
& FICL_WORD_OBJECT
))?
1274 FICL_TRUE
: FICL_FALSE
;
1276 ficlStackPushInteger(vm
->dataStack
, flag
);
1280 ficlPrimitiveCountedStringQuoteIm(ficlVm
*vm
)
1282 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1284 if (vm
->state
== FICL_VM_STATE_INTERPRET
) {
1285 ficlCountedString
*counted
= (ficlCountedString
*)
1288 ficlVmGetString(vm
, counted
, '\"');
1289 ficlStackPushPointer(vm
->dataStack
, counted
);
1292 * move HERE past string so it doesn't get overwritten. --lch
1294 ficlVmDictionaryAllot(vm
, dictionary
,
1295 counted
->length
+ sizeof (ficlUnsigned8
));
1296 } else { /* FICL_VM_STATE_COMPILE state */
1297 ficlDictionaryAppendUnsigned(dictionary
,
1298 ficlInstructionCStringLiteralParen
);
1300 FICL_POINTER_TO_CELL(ficlVmGetString(vm
,
1301 (ficlCountedString
*)dictionary
->here
, '\"'));
1302 ficlDictionaryAlign(dictionary
);
1308 * IMMEDIATE word that compiles a string literal for later display
1309 * FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the
1311 * TIB to the dictionary. Backpatch the count byte and align the dictionary.
1314 ficlPrimitiveDotQuoteCoIm(ficlVm
*vm
)
1316 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1317 ficlWord
*pType
= ficlSystemLookup(vm
->callback
.system
, "type");
1320 FICL_VM_ASSERT(vm
, pType
);
1322 ficlDictionaryAppendUnsigned(dictionary
,
1323 ficlInstructionStringLiteralParen
);
1325 FICL_POINTER_TO_CELL(ficlVmGetString(vm
,
1326 (ficlCountedString
*)dictionary
->here
, '\"'));
1327 ficlDictionaryAlign(dictionary
);
1329 ficlDictionaryAppendCell(dictionary
, c
);
1333 ficlPrimitiveDotParen(ficlVm
*vm
)
1335 char *from
= ficlVmGetInBuf(vm
);
1336 char *stop
= ficlVmGetInBufEnd(vm
);
1341 * Note: the standard does not want leading spaces skipped.
1343 for (c
= *from
; (from
!= stop
) && (c
!= ')'); c
= *++from
)
1347 if ((from
!= stop
) && (c
== ')'))
1350 ficlVmTextOut(vm
, vm
->pad
);
1351 ficlVmUpdateTib(vm
, from
);
1357 * Interpretation: Interpretation semantics for this word are undefined.
1358 * Compilation: ( c-addr1 u -- )
1359 * Append the run-time semantics given below to the current definition.
1360 * Run-time: ( -- c-addr2 u )
1361 * Return c-addr2 u describing a string consisting of the characters
1362 * specified by c-addr1 u during compilation. A program shall not alter
1363 * the returned string.
1365 static void ficlPrimitiveSLiteralCoIm(ficlVm
*vm
)
1367 ficlDictionary
*dictionary
;
1370 ficlUnsigned length
;
1372 FICL_STACK_CHECK(vm
->dataStack
, 2, 0);
1374 dictionary
= ficlVmGetDictionary(vm
);
1375 length
= ficlStackPopUnsigned(vm
->dataStack
);
1376 from
= ficlStackPopPointer(vm
->dataStack
);
1378 ficlDictionaryAppendUnsigned(dictionary
,
1379 ficlInstructionStringLiteralParen
);
1380 to
= (char *)dictionary
->here
;
1381 *to
++ = (char)length
;
1383 for (; length
> 0; --length
) {
1388 dictionary
->here
= FICL_POINTER_TO_CELL(ficlAlignPointer(to
));
1393 * Return the address of the VM's state member (must be sized the
1394 * same as a ficlCell for this reason)
1396 static void ficlPrimitiveState(ficlVm
*vm
)
1398 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
1399 ficlStackPushPointer(vm
->dataStack
, &vm
->state
);
1403 * c r e a t e . . . d o e s >
1404 * Make a new word in the dictionary with the run-time effect of
1405 * a variable (push my address), but with extra space allotted
1406 * for use by does> .
1409 ficlPrimitiveCreate(ficlVm
*vm
)
1411 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1412 ficlString name
= ficlVmGetWord(vm
);
1414 ficlDictionaryAppendWord(dictionary
, name
,
1415 (ficlPrimitive
)ficlInstructionCreateParen
, FICL_WORD_DEFAULT
);
1416 ficlVmDictionaryAllotCells(vm
, dictionary
, 1);
1420 ficlPrimitiveDoesCoIm(ficlVm
*vm
)
1422 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1423 #if FICL_WANT_LOCALS
1424 if (vm
->callback
.system
->localsCount
> 0) {
1425 ficlDictionary
*locals
=
1426 ficlSystemGetLocals(vm
->callback
.system
);
1427 ficlDictionaryEmpty(locals
, locals
->forthWordlist
->size
);
1428 ficlDictionaryAppendUnsigned(dictionary
,
1429 ficlInstructionUnlinkParen
);
1432 vm
->callback
.system
->localsCount
= 0;
1436 ficlDictionaryAppendUnsigned(dictionary
, ficlInstructionDoesParen
);
1441 * to-body CORE ( xt -- a-addr )
1442 * a-addr is the data-field address corresponding to xt. An ambiguous
1443 * condition exists if xt is not for a word defined via CREATE.
1446 ficlPrimitiveToBody(ficlVm
*vm
)
1449 FICL_STACK_CHECK(vm
->dataStack
, 1, 1);
1451 word
= ficlStackPopPointer(vm
->dataStack
);
1452 ficlStackPushPointer(vm
->dataStack
, word
->param
+ 1);
1456 * from-body Ficl ( a-addr -- xt )
1457 * Reverse effect of >body
1460 ficlPrimitiveFromBody(ficlVm
*vm
)
1463 FICL_STACK_CHECK(vm
->dataStack
, 1, 1);
1465 ptr
= (char *)ficlStackPopPointer(vm
->dataStack
) - sizeof (ficlWord
);
1466 ficlStackPushPointer(vm
->dataStack
, ptr
);
1470 * >name Ficl ( xt -- c-addr u )
1471 * Push the address and length of a word's name given its address
1475 ficlPrimitiveToName(ficlVm
*vm
)
1479 FICL_STACK_CHECK(vm
->dataStack
, 1, 2);
1481 word
= ficlStackPopPointer(vm
->dataStack
);
1482 ficlStackPushPointer(vm
->dataStack
, word
->name
);
1483 ficlStackPushUnsigned(vm
->dataStack
, word
->length
);
1487 ficlPrimitiveLastWord(ficlVm
*vm
)
1489 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1490 ficlWord
*wp
= dictionary
->smudge
;
1493 FICL_VM_ASSERT(vm
, wp
);
1500 * l b r a c k e t e t c
1503 ficlPrimitiveLeftBracketCoIm(ficlVm
*vm
)
1505 vm
->state
= FICL_VM_STATE_INTERPRET
;
1509 ficlPrimitiveRightBracket(ficlVm
*vm
)
1511 vm
->state
= FICL_VM_STATE_COMPILE
;
1515 * p i c t u r e d n u m e r i c w o r d s
1517 * less-number-sign CORE ( -- )
1518 * Initialize the pictured numeric output conversion process.
1522 ficlPrimitiveLessNumberSign(ficlVm
*vm
)
1524 ficlCountedString
*counted
= FICL_POINTER_TO_COUNTED_STRING(vm
->pad
);
1525 counted
->length
= 0;
1529 * number-sign CORE ( ud1 -- ud2 )
1530 * Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
1531 * n. (n is the least-significant digit of ud1.) Convert n to external form
1532 * and add the resulting character to the beginning of the pictured numeric
1533 * output string. An ambiguous condition exists if # executes outside of a
1534 * <# #> delimited number conversion.
1537 ficlPrimitiveNumberSign(ficlVm
*vm
)
1539 ficlCountedString
*counted
;
1541 ficl2UnsignedQR uqr
;
1543 FICL_STACK_CHECK(vm
->dataStack
, 2, 2);
1545 counted
= FICL_POINTER_TO_COUNTED_STRING(vm
->pad
);
1546 u
= ficlStackPop2Unsigned(vm
->dataStack
);
1547 uqr
= ficl2UnsignedDivide(u
, (ficlUnsigned16
)(vm
->base
));
1548 counted
->text
[counted
->length
++] = ficlDigitToCharacter(uqr
.remainder
);
1549 ficlStackPush2Unsigned(vm
->dataStack
, uqr
.quotient
);
1553 * number-sign-greater CORE ( xd -- c-addr u )
1554 * Drop xd. Make the pictured numeric output string available as a character
1555 * string. c-addr and u specify the resulting character string. A program
1556 * may replace characters within the string.
1559 ficlPrimitiveNumberSignGreater(ficlVm
*vm
)
1561 ficlCountedString
*counted
;
1563 FICL_STACK_CHECK(vm
->dataStack
, 2, 2);
1565 counted
= FICL_POINTER_TO_COUNTED_STRING(vm
->pad
);
1566 counted
->text
[counted
->length
] = 0;
1567 ficlStringReverse(counted
->text
);
1568 ficlStackDrop(vm
->dataStack
, 2);
1569 ficlStackPushPointer(vm
->dataStack
, counted
->text
);
1570 ficlStackPushUnsigned(vm
->dataStack
, counted
->length
);
1574 * number-sign-s CORE ( ud1 -- ud2 )
1575 * Convert one digit of ud1 according to the rule for #. Continue conversion
1576 * until the quotient is zero. ud2 is zero. An ambiguous condition exists if
1577 * #S executes outside of a <# #> delimited number conversion.
1578 * TO DO: presently does not use ud1 hi ficlCell - use it!
1581 ficlPrimitiveNumberSignS(ficlVm
*vm
)
1583 ficlCountedString
*counted
;
1585 ficl2UnsignedQR uqr
;
1587 FICL_STACK_CHECK(vm
->dataStack
, 2, 2);
1589 counted
= FICL_POINTER_TO_COUNTED_STRING(vm
->pad
);
1590 u
= ficlStackPop2Unsigned(vm
->dataStack
);
1593 uqr
= ficl2UnsignedDivide(u
, (ficlUnsigned16
)(vm
->base
));
1594 counted
->text
[counted
->length
++] =
1595 ficlDigitToCharacter(uqr
.remainder
);
1597 } while (FICL_2UNSIGNED_NOT_ZERO(u
));
1599 ficlStackPush2Unsigned(vm
->dataStack
, u
);
1603 * HOLD CORE ( char -- )
1604 * Add char to the beginning of the pictured numeric output string.
1605 * An ambiguous condition exists if HOLD executes outside of a <# #>
1606 * delimited number conversion.
1609 ficlPrimitiveHold(ficlVm
*vm
)
1611 ficlCountedString
*counted
;
1614 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
1616 counted
= FICL_POINTER_TO_COUNTED_STRING(vm
->pad
);
1617 i
= ficlStackPopInteger(vm
->dataStack
);
1618 counted
->text
[counted
->length
++] = (char)i
;
1622 * SIGN CORE ( n -- )
1623 * If n is negative, add a minus sign to the beginning of the pictured
1624 * numeric output string. An ambiguous condition exists if SIGN
1625 * executes outside of a <# #> delimited number conversion.
1628 ficlPrimitiveSign(ficlVm
*vm
)
1630 ficlCountedString
*counted
;
1633 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
1635 counted
= FICL_POINTER_TO_COUNTED_STRING(vm
->pad
);
1636 i
= ficlStackPopInteger(vm
->dataStack
);
1638 counted
->text
[counted
->length
++] = '-';
1643 * to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
1644 * ud2 is the unsigned result of converting the characters within the
1645 * string specified by c-addr1 u1 into digits, using the number in BASE,
1646 * and adding each into ud1 after multiplying ud1 by the number in BASE.
1647 * Conversion continues left-to-right until a character that is not
1648 * convertible, including any + or -, is encountered or the string is
1649 * entirely converted. c-addr2 is the location of the first unconverted
1650 * character or the first character past the end of the string if the string
1651 * was entirely converted. u2 is the number of unconverted characters in the
1652 * string. An ambiguous condition exists if ud2 overflows during the
1656 ficlPrimitiveToNumber(ficlVm
*vm
)
1658 ficlUnsigned length
;
1660 ficl2Unsigned accumulator
;
1661 ficlUnsigned base
= vm
->base
;
1665 FICL_STACK_CHECK(vm
->dataStack
, 4, 4);
1667 length
= ficlStackPopUnsigned(vm
->dataStack
);
1668 trace
= (char *)ficlStackPopPointer(vm
->dataStack
);
1669 accumulator
= ficlStackPop2Unsigned(vm
->dataStack
);
1671 for (c
= *trace
; length
> 0; c
= *++trace
, length
--) {
1678 digit
= tolower(c
) - 'a' + 10;
1680 * Note: following test also catches chars between 9 and a
1681 * because 'digit' is unsigned!
1686 accumulator
= ficl2UnsignedMultiplyAccumulate(accumulator
,
1690 ficlStackPush2Unsigned(vm
->dataStack
, accumulator
);
1691 ficlStackPushPointer(vm
->dataStack
, trace
);
1692 ficlStackPushUnsigned(vm
->dataStack
, length
);
1696 * q u i t & a b o r t
1697 * quit CORE ( -- ) ( R: i*x -- )
1698 * Empty the return stack, store zero in SOURCE-ID if it is present, make
1699 * the user input device the input source, and enter interpretation state.
1700 * Do not display a message. Repeat the following:
1702 * Accept a line from the input source into the input buffer, set >IN to
1703 * zero, and FICL_VM_STATE_INTERPRET.
1704 * Display the implementation-defined system prompt if in
1705 * interpretation state, all processing has been completed, and no
1706 * ambiguous condition exists.
1709 ficlPrimitiveQuit(ficlVm
*vm
)
1711 ficlVmThrow(vm
, FICL_VM_STATUS_QUIT
);
1715 ficlPrimitiveAbort(ficlVm
*vm
)
1717 ficlVmThrow(vm
, FICL_VM_STATUS_ABORT
);
1722 * accept CORE ( c-addr +n1 -- +n2 )
1723 * Receive a string of at most +n1 characters. An ambiguous condition
1724 * exists if +n1 is zero or greater than 32,767. Display graphic characters
1725 * as they are received. A program that depends on the presence or absence
1726 * of non-graphic characters in the string has an environmental dependency.
1727 * The editing functions, if any, that the system performs in order to
1728 * construct the string are implementation-defined.
1730 * (Although the standard text doesn't say so, I assume that the intent
1731 * of 'accept' is to store the string at the address specified on
1734 * NOTE: getchar() is used there as its present both in loader and
1735 * userland; however, the more correct solution would be to set
1736 * terminal to raw mode for userland.
1739 ficlPrimitiveAccept(ficlVm
*vm
)
1744 ficlUnsigned length
= 0;
1746 FICL_STACK_CHECK(vm
->dataStack
, 2, 1);
1748 size
= ficlStackPopInteger(vm
->dataStack
);
1749 address
= ficlStackPopPointer(vm
->dataStack
);
1751 while (size
!= length
) {
1753 if (c
== '\n' || c
== '\r')
1755 address
[length
++] = c
;
1757 ficlStackPushInteger(vm
->dataStack
, length
);
1762 * 6.1.0705 ALIGN CORE ( -- )
1763 * If the data-space pointer is not aligned, reserve enough space to
1767 ficlPrimitiveAlign(ficlVm
*vm
)
1769 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1771 ficlDictionaryAlign(dictionary
);
1778 ficlPrimitiveAligned(ficlVm
*vm
)
1782 FICL_STACK_CHECK(vm
->dataStack
, 1, 1);
1784 addr
= ficlStackPopPointer(vm
->dataStack
);
1785 ficlStackPushPointer(vm
->dataStack
, ficlAlignPointer(addr
));
1789 * b e g i n & f r i e n d s
1790 * Indefinite loop control structures
1793 * : X ... BEGIN ... test UNTIL ;
1795 * : X ... BEGIN ... test WHILE ... REPEAT ;
1798 ficlPrimitiveBeginCoIm(ficlVm
*vm
)
1800 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1801 markBranch(dictionary
, vm
, destTag
);
1805 ficlPrimitiveUntilCoIm(ficlVm
*vm
)
1807 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1809 ficlDictionaryAppendUnsigned(dictionary
,
1810 ficlInstructionBranch0ParenWithCheck
);
1811 resolveBackBranch(dictionary
, vm
, destTag
);
1815 ficlPrimitiveWhileCoIm(ficlVm
*vm
)
1817 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1819 FICL_STACK_CHECK(vm
->dataStack
, 2, 5);
1821 ficlDictionaryAppendUnsigned(dictionary
,
1822 ficlInstructionBranch0ParenWithCheck
);
1823 markBranch(dictionary
, vm
, origTag
);
1825 /* equivalent to 2swap */
1826 ficlStackRoll(vm
->dataStack
, 3);
1827 ficlStackRoll(vm
->dataStack
, 3);
1829 ficlDictionaryAppendUnsigned(dictionary
, 1);
1833 ficlPrimitiveRepeatCoIm(ficlVm
*vm
)
1835 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1837 ficlDictionaryAppendUnsigned(dictionary
,
1838 ficlInstructionBranchParenWithCheck
);
1839 /* expect "begin" branch marker */
1840 resolveBackBranch(dictionary
, vm
, destTag
);
1841 /* expect "while" branch marker */
1842 resolveForwardBranch(dictionary
, vm
, origTag
);
1846 ficlPrimitiveAgainCoIm(ficlVm
*vm
)
1848 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
1850 ficlDictionaryAppendUnsigned(dictionary
,
1851 ficlInstructionBranchParenWithCheck
);
1852 /* expect "begin" branch marker */
1853 resolveBackBranch(dictionary
, vm
, destTag
);
1857 * c h a r & f r i e n d s
1858 * 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
1859 * Skip leading space delimiters. Parse name delimited by a space.
1860 * Put the value of its first character onto the stack.
1863 * Interpretation: Interpretation semantics for this word are undefined.
1864 * Compilation: ( "<spaces>name" -- )
1865 * Skip leading space delimiters. Parse name delimited by a space.
1866 * Append the run-time semantics given below to the current definition.
1867 * Run-time: ( -- char )
1868 * Place char, the value of the first character of name, on the stack.
1871 ficlPrimitiveChar(ficlVm
*vm
)
1875 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
1877 s
= ficlVmGetWord(vm
);
1878 ficlStackPushUnsigned(vm
->dataStack
, (ficlUnsigned
)(s
.text
[0]));
1882 ficlPrimitiveCharCoIm(ficlVm
*vm
)
1884 ficlPrimitiveChar(vm
);
1885 ficlPrimitiveLiteralIm(vm
);
1890 * char-plus CORE ( c-addr1 -- c-addr2 )
1891 * Add the size in address units of a character to c-addr1, giving c-addr2.
1894 ficlPrimitiveCharPlus(ficlVm
*vm
)
1898 FICL_STACK_CHECK(vm
->dataStack
, 1, 1);
1900 p
= ficlStackPopPointer(vm
->dataStack
);
1901 ficlStackPushPointer(vm
->dataStack
, p
+ 1);
1906 * chars CORE ( n1 -- n2 )
1907 * n2 is the size in address units of n1 characters.
1908 * For most processors, this function can be a no-op. To guarantee
1909 * portability, we'll multiply by sizeof (char).
1911 #if defined(_M_IX86)
1912 #pragma warning(disable: 4127)
1915 ficlPrimitiveChars(ficlVm
*vm
)
1917 if (sizeof (char) > 1) {
1920 FICL_STACK_CHECK(vm
->dataStack
, 1, 1);
1922 i
= ficlStackPopInteger(vm
->dataStack
);
1923 ficlStackPushInteger(vm
->dataStack
, i
* sizeof (char));
1925 /* otherwise no-op! */
1927 #if defined(_M_IX86)
1928 #pragma warning(default: 4127)
1933 * COUNT CORE ( c-addr1 -- c-addr2 u )
1934 * Return the character string specification for the counted string stored
1935 * at c-addr1. c-addr2 is the address of the first character after c-addr1.
1936 * u is the contents of the character at c-addr1, which is the length in
1937 * characters of the string at c-addr2.
1940 ficlPrimitiveCount(ficlVm
*vm
)
1942 ficlCountedString
*counted
;
1944 FICL_STACK_CHECK(vm
->dataStack
, 1, 2);
1946 counted
= ficlStackPopPointer(vm
->dataStack
);
1947 ficlStackPushPointer(vm
->dataStack
, counted
->text
);
1948 ficlStackPushUnsigned(vm
->dataStack
, counted
->length
);
1952 * e n v i r o n m e n t ?
1953 * environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE )
1954 * c-addr is the address of a character string and u is the string's
1955 * character count. u may have a value in the range from zero to an
1956 * implementation-defined maximum which shall not be less than 31. The
1957 * character string should contain a keyword from 3.2.6 Environmental
1958 * queries or the optional word sets to be checked for correspondence
1959 * with an attribute of the present environment. If the system treats the
1960 * attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag
1961 * is FICL_TRUE and the i*x returned is of the type specified in the table for
1962 * the attribute queried.
1965 ficlPrimitiveEnvironmentQ(ficlVm
*vm
)
1967 ficlDictionary
*environment
;
1971 FICL_STACK_CHECK(vm
->dataStack
, 2, 1);
1973 environment
= vm
->callback
.system
->environment
;
1974 name
.length
= ficlStackPopUnsigned(vm
->dataStack
);
1975 name
.text
= ficlStackPopPointer(vm
->dataStack
);
1977 word
= ficlDictionaryLookup(environment
, name
);
1980 ficlVmExecuteWord(vm
, word
);
1981 ficlStackPushInteger(vm
->dataStack
, FICL_TRUE
);
1983 ficlStackPushInteger(vm
->dataStack
, FICL_FALSE
);
1989 * EVALUATE CORE ( i*x c-addr u -- j*x )
1990 * Save the current input source specification. Store minus-one (-1) in
1991 * SOURCE-ID if it is present. Make the string described by c-addr and u
1992 * both the input source and input buffer, set >IN to zero, and
1993 * FICL_VM_STATE_INTERPRET.
1994 * When the parse area is empty, restore the prior input source
1995 * specification. Other stack effects are due to the words EVALUATEd.
1998 ficlPrimitiveEvaluate(ficlVm
*vm
)
2004 FICL_STACK_CHECK(vm
->dataStack
, 2, 0);
2006 FICL_STRING_SET_LENGTH(string
, ficlStackPopUnsigned(vm
->dataStack
));
2007 FICL_STRING_SET_POINTER(string
, ficlStackPopPointer(vm
->dataStack
));
2010 vm
->sourceId
.i
= -1;
2011 result
= ficlVmExecuteString(vm
, string
);
2013 if (result
!= FICL_VM_STATUS_OUT_OF_TEXT
)
2014 ficlVmThrow(vm
, result
);
2018 * s t r i n g q u o t e
2019 * Interpreting: get string delimited by a quote from the input stream,
2020 * copy to a scratch area, and put its count and address on the stack.
2021 * Compiling: FICL_VM_STATE_COMPILE code to push the address and count
2022 * of a string literal, FICL_VM_STATE_COMPILE the string from the input
2023 * stream, and align the dictionary pointer.
2026 ficlPrimitiveStringQuoteIm(ficlVm
*vm
)
2028 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
2030 if (vm
->state
== FICL_VM_STATE_INTERPRET
) {
2031 ficlCountedString
*counted
;
2032 counted
= (ficlCountedString
*)dictionary
->here
;
2033 ficlVmGetString(vm
, counted
, '\"');
2034 ficlStackPushPointer(vm
->dataStack
, counted
->text
);
2035 ficlStackPushUnsigned(vm
->dataStack
, counted
->length
);
2036 } else { /* FICL_VM_STATE_COMPILE state */
2037 ficlDictionaryAppendUnsigned(dictionary
,
2038 ficlInstructionStringLiteralParen
);
2039 dictionary
->here
= FICL_POINTER_TO_CELL(
2040 ficlVmGetString(vm
, (ficlCountedString
*)dictionary
->here
,
2042 ficlDictionaryAlign(dictionary
);
2048 * Pop count and char address from stack and print the designated string.
2051 ficlPrimitiveType(ficlVm
*vm
)
2053 ficlUnsigned length
;
2056 FICL_STACK_CHECK(vm
->dataStack
, 2, 0);
2058 length
= ficlStackPopUnsigned(vm
->dataStack
);
2059 s
= ficlStackPopPointer(vm
->dataStack
);
2061 if ((s
== NULL
) || (length
== 0))
2065 * Since we don't have an output primitive for a counted string
2066 * (oops), make sure the string is null terminated. If not, copy
2069 if (s
[length
] != 0) {
2070 char *here
= (char *)ficlVmGetDictionary(vm
)->here
;
2072 strncpy(here
, s
, length
);
2074 here
[length
] = '\0';
2078 ficlVmTextOut(vm
, s
);
2083 * word CORE ( char "<chars>ccc<char>" -- c-addr )
2084 * Skip leading delimiters. Parse characters ccc delimited by char. An
2085 * ambiguous condition exists if the length of the parsed string is greater
2086 * than the implementation-defined length of a counted string.
2088 * c-addr is the address of a transient region containing the parsed word
2089 * as a counted string. If the parse area was empty or contained no
2090 * characters other than the delimiter, the resulting string has a zero
2091 * length. A space, not included in the length, follows the string. A
2092 * program may replace characters within the string.
2093 * NOTE! Ficl also NULL-terminates the dest string.
2096 ficlPrimitiveWord(ficlVm
*vm
)
2098 ficlCountedString
*counted
;
2102 FICL_STACK_CHECK(vm
->dataStack
, 1, 1);
2104 counted
= (ficlCountedString
*)vm
->pad
;
2105 delim
= (char)ficlStackPopInteger(vm
->dataStack
);
2106 name
= ficlVmParseStringEx(vm
, delim
, 1);
2108 if (FICL_STRING_GET_LENGTH(name
) > FICL_PAD_SIZE
- 1)
2109 FICL_STRING_SET_LENGTH(name
, FICL_PAD_SIZE
- 1);
2111 counted
->length
= (ficlUnsigned8
)FICL_STRING_GET_LENGTH(name
);
2112 strncpy(counted
->text
, FICL_STRING_GET_POINTER(name
),
2113 FICL_STRING_GET_LENGTH(name
));
2116 * store an extra space at the end of the primitive...
2117 * why? dunno yet. Guy Carver did it.
2119 counted
->text
[counted
->length
] = ' ';
2120 counted
->text
[counted
->length
+ 1] = 0;
2122 ficlStackPushPointer(vm
->dataStack
, counted
);
2126 * p a r s e - w o r d
2127 * Ficl PARSE-WORD ( <spaces>name -- c-addr u )
2128 * Skip leading spaces and parse name delimited by a space. c-addr is the
2129 * address within the input buffer and u is the length of the selected
2130 * string. If the parse area is empty, the resulting string has a zero length.
2132 static void ficlPrimitiveParseNoCopy(ficlVm
*vm
)
2136 FICL_STACK_CHECK(vm
->dataStack
, 0, 2);
2138 s
= ficlVmGetWord0(vm
);
2139 ficlStackPushPointer(vm
->dataStack
, FICL_STRING_GET_POINTER(s
));
2140 ficlStackPushUnsigned(vm
->dataStack
, FICL_STRING_GET_LENGTH(s
));
2145 * CORE EXT ( char "ccc<char>" -- c-addr u )
2146 * Parse ccc delimited by the delimiter char.
2147 * c-addr is the address (within the input buffer) and u is the length of
2148 * the parsed string. If the parse area was empty, the resulting string has
2150 * NOTE! PARSE differs from WORD: it does not skip leading delimiters.
2153 ficlPrimitiveParse(ficlVm
*vm
)
2158 FICL_STACK_CHECK(vm
->dataStack
, 1, 2);
2160 delim
= (char)ficlStackPopInteger(vm
->dataStack
);
2162 s
= ficlVmParseStringEx(vm
, delim
, 0);
2163 ficlStackPushPointer(vm
->dataStack
, FICL_STRING_GET_POINTER(s
));
2164 ficlStackPushUnsigned(vm
->dataStack
, FICL_STRING_GET_LENGTH(s
));
2169 * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2170 * Find the definition named in the counted string at c-addr. If the
2171 * definition is not found, return c-addr and zero. If the definition is
2172 * found, return its execution token xt. If the definition is immediate,
2173 * also return one (1), otherwise also return minus-one (-1). For a given
2174 * string, the values returned by FIND while compiling may differ from
2175 * those returned while not compiling.
2178 do_find(ficlVm
*vm
, ficlString name
, void *returnForFailure
)
2182 word
= ficlDictionaryLookup(ficlVmGetDictionary(vm
), name
);
2184 ficlStackPushPointer(vm
->dataStack
, word
);
2185 ficlStackPushInteger(vm
->dataStack
,
2186 (ficlWordIsImmediate(word
) ? 1 : -1));
2188 ficlStackPushPointer(vm
->dataStack
, returnForFailure
);
2189 ficlStackPushUnsigned(vm
->dataStack
, 0);
2195 * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
2196 * Find the definition named in the counted string at c-addr. If the
2197 * definition is not found, return c-addr and zero. If the definition is
2198 * found, return its execution token xt. If the definition is immediate,
2199 * also return one (1), otherwise also return minus-one (-1). For a given
2200 * string, the values returned by FIND while compiling may differ from
2201 * those returned while not compiling.
2204 ficlPrimitiveCFind(ficlVm
*vm
)
2206 ficlCountedString
*counted
;
2209 FICL_STACK_CHECK(vm
->dataStack
, 1, 2);
2211 counted
= ficlStackPopPointer(vm
->dataStack
);
2212 FICL_STRING_SET_FROM_COUNTED_STRING(name
, *counted
);
2213 do_find(vm
, name
, counted
);
2218 * Ficl ( c-addr u -- 0 0 | xt 1 | xt -1 )
2219 * Like FIND, but takes "c-addr u" for the string.
2222 ficlPrimitiveSFind(ficlVm
*vm
)
2226 FICL_STACK_CHECK(vm
->dataStack
, 2, 2);
2228 name
.length
= ficlStackPopInteger(vm
->dataStack
);
2229 name
.text
= ficlStackPopPointer(vm
->dataStack
);
2231 do_find(vm
, name
, NULL
);
2238 ficlPrimitiveRecurseCoIm(ficlVm
*vm
)
2240 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
2244 c
.p
= dictionary
->smudge
;
2245 ficlDictionaryAppendCell(dictionary
, c
);
2250 * CORE ( -- c-addr u )
2251 * c-addr is the address of, and u is the number of characters in, the
2255 ficlPrimitiveSource(ficlVm
*vm
)
2257 FICL_STACK_CHECK(vm
->dataStack
, 0, 2);
2259 ficlStackPushPointer(vm
->dataStack
, vm
->tib
.text
);
2260 ficlStackPushInteger(vm
->dataStack
, ficlVmGetInBufLen(vm
));
2268 ficlPrimitiveVersion(ficlVm
*vm
)
2270 ficlVmTextOut(vm
, "Ficl version " FICL_VERSION
"\n");
2278 ficlPrimitiveToIn(ficlVm
*vm
)
2280 FICL_STACK_CHECK(vm
->dataStack
, 0, 1);
2282 ficlStackPushPointer(vm
->dataStack
, &vm
->tib
.index
);
2286 * c o l o n N o N a m e
2287 * CORE EXT ( C: -- colon-sys ) ( S: -- xt )
2288 * Create an unnamed colon definition and push its address.
2289 * Change state to FICL_VM_STATE_COMPILE.
2292 ficlPrimitiveColonNoName(ficlVm
*vm
)
2294 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
2298 FICL_STRING_SET_LENGTH(name
, 0);
2299 FICL_STRING_SET_POINTER(name
, NULL
);
2301 vm
->state
= FICL_VM_STATE_COMPILE
;
2302 word
= ficlDictionaryAppendWord(dictionary
, name
,
2303 (ficlPrimitive
)ficlInstructionColonParen
,
2304 FICL_WORD_DEFAULT
| FICL_WORD_SMUDGED
);
2306 ficlStackPushPointer(vm
->dataStack
, word
);
2307 markControlTag(vm
, colonTag
);
2311 * u s e r V a r i a b l e
2312 * user ( u -- ) "<spaces>name"
2313 * Get a name from the input stream and create a user variable
2314 * with the name and the index supplied. The run-time effect
2315 * of a user variable is to push the address of the indexed ficlCell
2316 * in the running vm's user array.
2318 * User variables are vm local cells. Each vm has an array of
2319 * FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
2320 * Ficl's user facility is implemented with two primitives,
2321 * "user" and "(user)", a variable ("nUser") (in softcore.c) that
2322 * holds the index of the next free user ficlCell, and a redefinition
2323 * (also in softcore) of "user" that defines a user word and increments
2328 ficlPrimitiveUser(ficlVm
*vm
)
2330 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
2331 ficlString name
= ficlVmGetWord(vm
);
2334 c
= ficlStackPop(vm
->dataStack
);
2335 if (c
.i
>= FICL_USER_CELLS
) {
2336 ficlVmThrowError(vm
, "Error - out of user space");
2339 ficlDictionaryAppendWord(dictionary
, name
,
2340 (ficlPrimitive
)ficlInstructionUserParen
, FICL_WORD_DEFAULT
);
2341 ficlDictionaryAppendCell(dictionary
, c
);
2345 #if FICL_WANT_LOCALS
2347 * Each local is recorded in a private locals dictionary as a
2348 * word that does doLocalIm at runtime. DoLocalIm compiles code
2349 * into the client definition to fetch the value of the
2350 * corresponding local variable from the return stack.
2351 * The private dictionary gets initialized at the end of each block
2352 * that uses locals (in ; and does> for example).
2355 ficlLocalParenIm(ficlVm
*vm
, int isDouble
, int isFloat
)
2357 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
2358 ficlInteger nLocal
= vm
->runningWord
->param
[0].i
;
2360 #if !FICL_WANT_FLOAT
2361 FICL_VM_ASSERT(vm
, !isFloat
);
2362 /* get rid of unused parameter warning */
2364 #endif /* FICL_WANT_FLOAT */
2366 if (vm
->state
== FICL_VM_STATE_INTERPRET
) {
2370 stack
= vm
->floatStack
;
2372 #endif /* FICL_WANT_FLOAT */
2373 stack
= vm
->dataStack
;
2375 ficlStackPush(stack
, vm
->returnStack
->frame
[nLocal
]);
2377 ficlStackPush(stack
, vm
->returnStack
->frame
[nLocal
+1]);
2379 ficlInstruction instruction
;
2380 ficlInteger appendLocalOffset
;
2384 (isDouble
) ? ficlInstructionGetF2LocalParen
:
2385 ficlInstructionGetFLocalParen
;
2386 appendLocalOffset
= FICL_TRUE
;
2388 #endif /* FICL_WANT_FLOAT */
2390 instruction
= (isDouble
) ? ficlInstructionGet2Local0
:
2391 ficlInstructionGetLocal0
;
2392 appendLocalOffset
= FICL_FALSE
;
2393 } else if ((nLocal
== 1) && !isDouble
) {
2394 instruction
= ficlInstructionGetLocal1
;
2395 appendLocalOffset
= FICL_FALSE
;
2398 (isDouble
) ? ficlInstructionGet2LocalParen
:
2399 ficlInstructionGetLocalParen
;
2400 appendLocalOffset
= FICL_TRUE
;
2403 ficlDictionaryAppendUnsigned(dictionary
, instruction
);
2404 if (appendLocalOffset
)
2405 ficlDictionaryAppendUnsigned(dictionary
, nLocal
);
2410 ficlPrimitiveDoLocalIm(ficlVm
*vm
)
2412 ficlLocalParenIm(vm
, 0, 0);
2416 ficlPrimitiveDo2LocalIm(ficlVm
*vm
)
2418 ficlLocalParenIm(vm
, 1, 0);
2423 ficlPrimitiveDoFLocalIm(ficlVm
*vm
)
2425 ficlLocalParenIm(vm
, 0, 1);
2429 ficlPrimitiveDoF2LocalIm(ficlVm
*vm
)
2431 ficlLocalParenIm(vm
, 1, 1);
2433 #endif /* FICL_WANT_FLOAT */
2436 * l o c a l P a r e n
2437 * paren-local-paren LOCAL
2438 * Interpretation: Interpretation semantics for this word are undefined.
2439 * Execution: ( c-addr u -- )
2440 * When executed during compilation, (LOCAL) passes a message to the
2441 * system that has one of two meanings. If u is non-zero,
2442 * the message identifies a new local whose definition name is given by
2443 * the string of characters identified by c-addr u. If u is zero,
2444 * the message is last local and c-addr has no significance.
2446 * The result of executing (LOCAL) during compilation of a definition is
2447 * to create a set of named local identifiers, each of which is
2448 * a definition name, that only have execution semantics within the scope
2449 * of that definition's source.
2451 * local Execution: ( -- x )
2453 * Push the local's value, x, onto the stack. The local's value is
2454 * initialized as described in 13.3.3 Processing locals and may be
2455 * changed by preceding the local's name with TO. An ambiguous condition
2456 * exists when local is executed while in interpretation state.
2459 ficlLocalParen(ficlVm
*vm
, int isDouble
, int isFloat
)
2461 ficlDictionary
*dictionary
;
2464 FICL_STACK_CHECK(vm
->dataStack
, 2, 0);
2466 dictionary
= ficlVmGetDictionary(vm
);
2467 FICL_STRING_SET_LENGTH(name
, ficlStackPopUnsigned(vm
->dataStack
));
2468 FICL_STRING_SET_POINTER(name
,
2469 (char *)ficlStackPopPointer(vm
->dataStack
));
2471 if (FICL_STRING_GET_LENGTH(name
) > 0) {
2473 * add a local to the **locals** dictionary and
2474 * update localsCount
2477 ficlInstruction instruction
;
2478 ficlDictionary
*locals
;
2480 locals
= ficlSystemGetLocals(vm
->callback
.system
);
2481 if (vm
->callback
.system
->localsCount
>= FICL_MAX_LOCALS
) {
2482 ficlVmThrowError(vm
, "Error: out of local space");
2485 #if !FICL_WANT_FLOAT
2486 FICL_VM_ASSERT(vm
, !isFloat
);
2487 /* get rid of unused parameter warning */
2489 #else /* FICL_WANT_FLOAT */
2492 code
= ficlPrimitiveDoF2LocalIm
;
2493 instruction
= ficlInstructionToF2LocalParen
;
2495 code
= ficlPrimitiveDoFLocalIm
;
2496 instruction
= ficlInstructionToFLocalParen
;
2499 #endif /* FICL_WANT_FLOAT */
2501 code
= ficlPrimitiveDo2LocalIm
;
2502 instruction
= ficlInstructionTo2LocalParen
;
2504 code
= ficlPrimitiveDoLocalIm
;
2505 instruction
= ficlInstructionToLocalParen
;
2508 ficlDictionaryAppendWord(locals
, name
, code
,
2509 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
2510 ficlDictionaryAppendUnsigned(locals
,
2511 vm
->callback
.system
->localsCount
);
2513 if (vm
->callback
.system
->localsCount
== 0) {
2515 * FICL_VM_STATE_COMPILE code to create a local
2518 ficlDictionaryAppendUnsigned(dictionary
,
2519 ficlInstructionLinkParen
);
2521 /* save location in dictionary for #locals */
2522 vm
->callback
.system
->localsFixup
= dictionary
->here
;
2523 ficlDictionaryAppendUnsigned(dictionary
,
2524 vm
->callback
.system
->localsCount
);
2527 ficlDictionaryAppendUnsigned(dictionary
, instruction
);
2528 ficlDictionaryAppendUnsigned(dictionary
,
2529 vm
->callback
.system
->localsCount
);
2531 vm
->callback
.system
->localsCount
+= (isDouble
) ? 2 : 1;
2532 } else if (vm
->callback
.system
->localsCount
> 0) {
2533 /* write localsCount to (link) param area in dictionary */
2534 *(ficlInteger
*)(vm
->callback
.system
->localsFixup
) =
2535 vm
->callback
.system
->localsCount
;
2540 ficlPrimitiveLocalParen(ficlVm
*vm
)
2542 ficlLocalParen(vm
, 0, 0);
2546 ficlPrimitive2LocalParen(ficlVm
*vm
)
2548 ficlLocalParen(vm
, 1, 0);
2550 #endif /* FICL_WANT_LOCALS */
2555 * Interpretation: ( x "<spaces>name" -- )
2556 * Skip leading spaces and parse name delimited by a space. Store x in
2557 * name. An ambiguous condition exists if name was not defined by VALUE.
2558 * NOTE: In Ficl, VALUE is an alias of CONSTANT
2561 ficlPrimitiveToValue(ficlVm
*vm
)
2563 ficlString name
= ficlVmGetWord(vm
);
2564 ficlDictionary
*dictionary
= ficlVmGetDictionary(vm
);
2566 ficlInstruction instruction
= 0;
2568 ficlInteger isDouble
;
2569 #if FICL_WANT_LOCALS
2571 ficlInteger appendLocalOffset
;
2572 ficlInteger isFloat
;
2573 #endif /* FICL_WANT_LOCALS */
2575 #if FICL_WANT_LOCALS
2576 if ((vm
->callback
.system
->localsCount
> 0) &&
2577 (vm
->state
== FICL_VM_STATE_COMPILE
)) {
2578 ficlDictionary
*locals
;
2580 locals
= ficlSystemGetLocals(vm
->callback
.system
);
2581 word
= ficlDictionaryLookup(locals
, name
);
2585 if (word
->code
== ficlPrimitiveDoLocalIm
) {
2586 instruction
= ficlInstructionToLocalParen
;
2587 isDouble
= isFloat
= FICL_FALSE
;
2588 } else if (word
->code
== ficlPrimitiveDo2LocalIm
) {
2589 instruction
= ficlInstructionTo2LocalParen
;
2590 isDouble
= FICL_TRUE
;
2591 isFloat
= FICL_FALSE
;
2594 else if (word
->code
== ficlPrimitiveDoFLocalIm
) {
2595 instruction
= ficlInstructionToFLocalParen
;
2596 isDouble
= FICL_FALSE
;
2597 isFloat
= FICL_TRUE
;
2598 } else if (word
->code
== ficlPrimitiveDoF2LocalIm
) {
2599 instruction
= ficlInstructionToF2LocalParen
;
2600 isDouble
= isFloat
= FICL_TRUE
;
2602 #endif /* FICL_WANT_FLOAT */
2604 ficlVmThrowError(vm
,
2605 "to %.*s : local is of unknown type",
2606 FICL_STRING_GET_LENGTH(name
),
2607 FICL_STRING_GET_POINTER(name
));
2611 nLocal
= word
->param
[0].i
;
2612 appendLocalOffset
= FICL_TRUE
;
2616 #endif /* FICL_WANT_FLOAT */
2619 (isDouble
) ? ficlInstructionTo2Local0
:
2620 ficlInstructionToLocal0
;
2621 appendLocalOffset
= FICL_FALSE
;
2622 } else if ((nLocal
== 1) && !isDouble
) {
2623 instruction
= ficlInstructionToLocal1
;
2624 appendLocalOffset
= FICL_FALSE
;
2628 #endif /* FICL_WANT_FLOAT */
2630 ficlDictionaryAppendUnsigned(dictionary
, instruction
);
2631 if (appendLocalOffset
)
2632 ficlDictionaryAppendUnsigned(dictionary
, nLocal
);
2637 #if FICL_WANT_LOCALS
2639 #endif /* FICL_WANT_LOCALS */
2640 word
= ficlDictionaryLookup(dictionary
, name
);
2642 ficlVmThrowError(vm
, "%.*s not found",
2643 FICL_STRING_GET_LENGTH(name
),
2644 FICL_STRING_GET_POINTER(name
));
2646 switch ((ficlInstruction
)word
->code
) {
2647 case ficlInstructionConstantParen
:
2648 instruction
= ficlInstructionStore
;
2649 stack
= vm
->dataStack
;
2650 isDouble
= FICL_FALSE
;
2652 case ficlInstruction2ConstantParen
:
2653 instruction
= ficlInstruction2Store
;
2654 stack
= vm
->dataStack
;
2655 isDouble
= FICL_TRUE
;
2658 case ficlInstructionFConstantParen
:
2659 instruction
= ficlInstructionFStore
;
2660 stack
= vm
->floatStack
;
2661 isDouble
= FICL_FALSE
;
2663 case ficlInstructionF2ConstantParen
:
2664 instruction
= ficlInstructionF2Store
;
2665 stack
= vm
->floatStack
;
2666 isDouble
= FICL_TRUE
;
2668 #endif /* FICL_WANT_FLOAT */
2670 ficlVmThrowError(vm
,
2671 "to %.*s : value/constant is of unknown type",
2672 FICL_STRING_GET_LENGTH(name
),
2673 FICL_STRING_GET_POINTER(name
));
2677 if (vm
->state
== FICL_VM_STATE_INTERPRET
) {
2678 word
->param
[0] = ficlStackPop(stack
);
2680 word
->param
[1] = ficlStackPop(stack
);
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
);
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.
2698 ficlPrimitiveFMSlashMod(ficlVm
*vm
)
2704 FICL_STACK_CHECK(vm
->dataStack
, 3, 2);
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
));
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.
2723 ficlPrimitiveSMSlashRem(ficlVm
*vm
)
2729 FICL_STACK_CHECK(vm
->dataStack
, 3, 2);
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
));
2740 ficlPrimitiveMod(ficlVm
*vm
)
2746 FICL_STACK_CHECK(vm
->dataStack
, 2, 1);
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
);
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.
2764 ficlPrimitiveUMSlashMod(ficlVm
*vm
)
2768 ficl2UnsignedQR uqr
;
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
));
2780 * m-star CORE ( n1 n2 -- d )
2781 * d is the signed product of n1 times n2.
2784 ficlPrimitiveMStar(ficlVm
*vm
)
2789 FICL_STACK_CHECK(vm
->dataStack
, 2, 2);
2791 n2
= ficlStackPopInteger(vm
->dataStack
);
2792 n1
= ficlStackPopInteger(vm
->dataStack
);
2794 d
= ficl2IntegerMultiply(n1
, n2
);
2795 ficlStackPush2Integer(vm
->dataStack
, d
);
2799 ficlPrimitiveUMStar(ficlVm
*vm
)
2804 FICL_STACK_CHECK(vm
->dataStack
, 2, 2);
2806 u2
= ficlStackPopUnsigned(vm
->dataStack
);
2807 u1
= ficlStackPopUnsigned(vm
->dataStack
);
2809 ud
= ficl2UnsignedMultiply(u1
, u2
);
2810 ficlStackPush2Unsigned(vm
->dataStack
, ud
);
2815 * DOUBLE ( d1 d2 d3 -- d2 d3 d1 )
2818 ficlPrimitive2Rot(ficlVm
*vm
)
2820 ficl2Integer d1
, d2
, d3
;
2821 FICL_STACK_CHECK(vm
->dataStack
, 6, 6);
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
);
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.
2838 ficlPrimitivePad(ficlVm
*vm
)
2840 ficlStackPushPointer(vm
->dataStack
, vm
->pad
);
2845 * CORE EXT, FILE ( -- 0 | -1 | fileid )
2846 * Identifies the input source as follows:
2848 * SOURCE-ID Input source
2849 * --------- ------------
2850 * fileid Text file fileid
2851 * -1 String (via EVALUATE)
2852 * 0 User input device
2855 ficlPrimitiveSourceID(ficlVm
*vm
)
2857 ficlStackPushInteger(vm
->dataStack
, vm
->sourceId
.i
);
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.
2874 ficlPrimitiveRefill(ficlVm
*vm
)
2876 ficlInteger ret
= (vm
->sourceId
.i
== -1) ? FICL_FALSE
: FICL_TRUE
;
2877 if (ret
&& (vm
->restart
== 0))
2878 ficlVmThrow(vm
, FICL_VM_STATUS_RESTART
);
2880 ficlStackPushInteger(vm
->dataStack
, ret
);
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,
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.
2898 * More comments can be found throughout catch's code.
2900 * Daniel C. Sobral Jan 09/1999
2901 * sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
2904 ficlPrimitiveCatch(ficlVm
*vm
)
2909 ficlStack dataStackCopy
;
2910 ficlStack returnStackCopy
;
2913 FICL_VM_ASSERT(vm
, vm
);
2914 FICL_VM_ASSERT(vm
, vm
->callback
.system
->exitInnerWord
);
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. :-)
2923 FICL_STACK_CHECK(vm
->dataStack
, 1, 0);
2925 word
= ficlStackPopPointer(vm
->dataStack
);
2928 * Save vm's state -- a catch will not back out environmental
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).
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
));
2946 vm
->exceptionHandler
= &vmState
;
2951 except
= setjmp(vmState
);
2955 * Setup condition - push poison pill so that the VM throws
2956 * VM_INNEREXIT if the XT terminates normally, then execute
2960 /* Open mouth, insert emetic */
2961 ficlVmPushIP(vm
, &(vm
->callback
.system
->exitInnerWord
));
2962 ficlVmExecuteWord(vm
, word
);
2963 ficlVmInnerLoop(vm
, 0);
2967 * Normal exit from XT - lose the poison pill,
2968 * restore old setjmp vector and push a zero.
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);
2979 * Some other exception got thrown - restore pre-existing VM state
2980 * and push the exception code
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
));
2990 ficlStackPushInteger(vm
->dataStack
, except
); /* Push error */
2998 * Throw -- From ANS Forth standard.
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.
3004 * Daniel C. Sobral Jan 09/1999
3007 ficlPrimitiveThrow(ficlVm
*vm
)
3011 except
= ficlStackPopInteger(vm
->dataStack
);
3014 ficlVmThrow(vm
, except
);
3022 ficlPrimitiveAllocate(ficlVm
*vm
)
3027 size
= ficlStackPopInteger(vm
->dataStack
);
3028 p
= ficlMalloc(size
);
3029 ficlStackPushPointer(vm
->dataStack
, p
);
3031 ficlStackPushInteger(vm
->dataStack
, 0);
3033 ficlStackPushInteger(vm
->dataStack
, 1);
3041 ficlPrimitiveFree(ficlVm
*vm
)
3045 p
= ficlStackPopPointer(vm
->dataStack
);
3047 ficlStackPushInteger(vm
->dataStack
, 0);
3055 ficlPrimitiveResize(ficlVm
*vm
)
3060 size
= ficlStackPopInteger(vm
->dataStack
);
3061 old
= ficlStackPopPointer(vm
->dataStack
);
3062 new = ficlRealloc(old
, size
);
3065 ficlStackPushPointer(vm
->dataStack
, new);
3066 ficlStackPushInteger(vm
->dataStack
, 0);
3068 ficlStackPushPointer(vm
->dataStack
, old
);
3069 ficlStackPushInteger(vm
->dataStack
, 1);
3074 * e x i t - i n n e r
3075 * Signals execXT that an inner loop has completed
3078 ficlPrimitiveExitInner(ficlVm
*vm
)
3080 ficlVmThrow(vm
, FICL_VM_STATUS_INNER_EXIT
);
3085 ficlPrimitiveName(ficlVm
*vm
)
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.
3096 ficlSystemCompileCore(ficlSystem
*system
)
3098 ficlWord
*interpret
;
3099 ficlDictionary
*dictionary
= ficlSystemGetDictionary(system
);
3100 ficlDictionary
*environment
= ficlSystemGetEnvironment(system
);
3102 FICL_SYSTEM_ASSERT(system
, dictionary
);
3103 FICL_SYSTEM_ASSERT(system
, environment
);
3105 #define FICL_TOKEN(token, description)
3106 #define FICL_INSTRUCTION_TOKEN(token, description, flags) \
3107 ficlDictionarySetInstruction(dictionary, description, token, flags);
3108 #include "ficltokens.h"
3110 #undef FICL_INSTRUCTION_TOKEN
3114 * see softcore.c for definitions of: abs bl space spaces abort"
3116 ficlDictionarySetPrimitive(dictionary
, "#", ficlPrimitiveNumberSign
,
3118 ficlDictionarySetPrimitive(dictionary
, "#>",
3119 ficlPrimitiveNumberSignGreater
, FICL_WORD_DEFAULT
);
3120 ficlDictionarySetPrimitive(dictionary
, "#s", ficlPrimitiveNumberSignS
,
3122 ficlDictionarySetPrimitive(dictionary
, "\'", ficlPrimitiveTick
,
3124 ficlDictionarySetPrimitive(dictionary
, "(", ficlPrimitiveParenthesis
,
3125 FICL_WORD_IMMEDIATE
);
3126 ficlDictionarySetPrimitive(dictionary
, "+loop",
3127 ficlPrimitivePlusLoopCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3128 ficlDictionarySetPrimitive(dictionary
, ".", ficlPrimitiveDot
,
3130 ficlDictionarySetPrimitive(dictionary
, ".\"",
3131 ficlPrimitiveDotQuoteCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3132 ficlDictionarySetPrimitive(dictionary
, ":", ficlPrimitiveColon
,
3134 ficlDictionarySetPrimitive(dictionary
, ";", ficlPrimitiveSemicolonCoIm
,
3135 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3136 ficlDictionarySetPrimitive(dictionary
, "<#",
3137 ficlPrimitiveLessNumberSign
, FICL_WORD_DEFAULT
);
3138 ficlDictionarySetPrimitive(dictionary
, ">body", ficlPrimitiveToBody
,
3140 ficlDictionarySetPrimitive(dictionary
, ">in", ficlPrimitiveToIn
,
3142 ficlDictionarySetPrimitive(dictionary
, ">number", ficlPrimitiveToNumber
,
3144 ficlDictionarySetPrimitive(dictionary
, "abort", ficlPrimitiveAbort
,
3146 ficlDictionarySetPrimitive(dictionary
, "accept", ficlPrimitiveAccept
,
3148 ficlDictionarySetPrimitive(dictionary
, "align", ficlPrimitiveAlign
,
3150 ficlDictionarySetPrimitive(dictionary
, "aligned", ficlPrimitiveAligned
,
3152 ficlDictionarySetPrimitive(dictionary
, "allot", ficlPrimitiveAllot
,
3154 ficlDictionarySetPrimitive(dictionary
, "base", ficlPrimitiveBase
,
3156 ficlDictionarySetPrimitive(dictionary
, "begin", ficlPrimitiveBeginCoIm
,
3157 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3158 ficlDictionarySetPrimitive(dictionary
, "case", ficlPrimitiveCaseCoIm
,
3159 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3160 ficlDictionarySetPrimitive(dictionary
, "char", ficlPrimitiveChar
,
3162 ficlDictionarySetPrimitive(dictionary
, "char+", ficlPrimitiveCharPlus
,
3164 ficlDictionarySetPrimitive(dictionary
, "chars", ficlPrimitiveChars
,
3166 ficlDictionarySetPrimitive(dictionary
, "constant",
3167 ficlPrimitiveConstant
, FICL_WORD_DEFAULT
);
3168 ficlDictionarySetPrimitive(dictionary
, "count", ficlPrimitiveCount
,
3170 ficlDictionarySetPrimitive(dictionary
, "cr", ficlPrimitiveCR
,
3172 ficlDictionarySetPrimitive(dictionary
, "create", ficlPrimitiveCreate
,
3174 ficlDictionarySetPrimitive(dictionary
, "decimal", ficlPrimitiveDecimal
,
3176 ficlDictionarySetPrimitive(dictionary
, "depth", ficlPrimitiveDepth
,
3178 ficlDictionarySetPrimitive(dictionary
, "do", ficlPrimitiveDoCoIm
,
3179 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3180 ficlDictionarySetPrimitive(dictionary
, "does>", ficlPrimitiveDoesCoIm
,
3181 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3182 ficlDictionarySetPrimitive(dictionary
, "else", ficlPrimitiveElseCoIm
,
3183 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3184 ficlDictionarySetPrimitive(dictionary
, "emit", ficlPrimitiveEmit
,
3186 ficlDictionarySetPrimitive(dictionary
, "endcase",
3187 ficlPrimitiveEndcaseCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3188 ficlDictionarySetPrimitive(dictionary
, "endof", ficlPrimitiveEndofCoIm
,
3189 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3190 ficlDictionarySetPrimitive(dictionary
, "environment?",
3191 ficlPrimitiveEnvironmentQ
, FICL_WORD_DEFAULT
);
3192 ficlDictionarySetPrimitive(dictionary
, "evaluate",
3193 ficlPrimitiveEvaluate
, FICL_WORD_DEFAULT
);
3194 ficlDictionarySetPrimitive(dictionary
, "execute", ficlPrimitiveExecute
,
3196 ficlDictionarySetPrimitive(dictionary
, "exit", ficlPrimitiveExitCoIm
,
3197 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3198 ficlDictionarySetPrimitive(dictionary
, "fallthrough",
3199 ficlPrimitiveFallthroughCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3200 ficlDictionarySetPrimitive(dictionary
, "find", ficlPrimitiveCFind
,
3202 ficlDictionarySetPrimitive(dictionary
, "fm/mod",
3203 ficlPrimitiveFMSlashMod
, FICL_WORD_DEFAULT
);
3204 ficlDictionarySetPrimitive(dictionary
, "here", ficlPrimitiveHere
,
3206 ficlDictionarySetPrimitive(dictionary
, "hold", ficlPrimitiveHold
,
3208 ficlDictionarySetPrimitive(dictionary
, "if", ficlPrimitiveIfCoIm
,
3209 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3210 ficlDictionarySetPrimitive(dictionary
, "immediate",
3211 ficlPrimitiveImmediate
, FICL_WORD_DEFAULT
);
3212 ficlDictionarySetPrimitive(dictionary
, "literal",
3213 ficlPrimitiveLiteralIm
, FICL_WORD_IMMEDIATE
);
3214 ficlDictionarySetPrimitive(dictionary
, "loop", ficlPrimitiveLoopCoIm
,
3215 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3216 ficlDictionarySetPrimitive(dictionary
, "m*", ficlPrimitiveMStar
,
3218 ficlDictionarySetPrimitive(dictionary
, "mod", ficlPrimitiveMod
,
3220 ficlDictionarySetPrimitive(dictionary
, "of", ficlPrimitiveOfCoIm
,
3221 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3222 ficlDictionarySetPrimitive(dictionary
, "postpone",
3223 ficlPrimitivePostponeCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3224 ficlDictionarySetPrimitive(dictionary
, "quit", ficlPrimitiveQuit
,
3226 ficlDictionarySetPrimitive(dictionary
, "recurse",
3227 ficlPrimitiveRecurseCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3228 ficlDictionarySetPrimitive(dictionary
, "repeat",
3229 ficlPrimitiveRepeatCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3230 ficlDictionarySetPrimitive(dictionary
, "s\"",
3231 ficlPrimitiveStringQuoteIm
, FICL_WORD_IMMEDIATE
);
3232 ficlDictionarySetPrimitive(dictionary
, "sign", ficlPrimitiveSign
,
3234 ficlDictionarySetPrimitive(dictionary
, "sm/rem",
3235 ficlPrimitiveSMSlashRem
, FICL_WORD_DEFAULT
);
3236 ficlDictionarySetPrimitive(dictionary
, "source", ficlPrimitiveSource
,
3238 ficlDictionarySetPrimitive(dictionary
, "state", ficlPrimitiveState
,
3240 ficlDictionarySetPrimitive(dictionary
, "then", ficlPrimitiveEndifCoIm
,
3241 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3242 ficlDictionarySetPrimitive(dictionary
, "type", ficlPrimitiveType
,
3244 ficlDictionarySetPrimitive(dictionary
, "u.", ficlPrimitiveUDot
,
3246 ficlDictionarySetPrimitive(dictionary
, "um*", ficlPrimitiveUMStar
,
3248 ficlDictionarySetPrimitive(dictionary
, "um/mod",
3249 ficlPrimitiveUMSlashMod
, FICL_WORD_DEFAULT
);
3250 ficlDictionarySetPrimitive(dictionary
, "until",
3251 ficlPrimitiveUntilCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3252 ficlDictionarySetPrimitive(dictionary
, "variable",
3253 ficlPrimitiveVariable
, FICL_WORD_DEFAULT
);
3254 ficlDictionarySetPrimitive(dictionary
, "while",
3255 ficlPrimitiveWhileCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3256 ficlDictionarySetPrimitive(dictionary
, "word", ficlPrimitiveWord
,
3258 ficlDictionarySetPrimitive(dictionary
, "[",
3259 ficlPrimitiveLeftBracketCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3260 ficlDictionarySetPrimitive(dictionary
, "[\']",
3261 ficlPrimitiveBracketTickCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3262 ficlDictionarySetPrimitive(dictionary
, "[char]", ficlPrimitiveCharCoIm
,
3263 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3264 ficlDictionarySetPrimitive(dictionary
, "]", ficlPrimitiveRightBracket
,
3267 * The Core Extensions word set...
3268 * see softcore.fr for other definitions
3271 ficlDictionarySetPrimitive(dictionary
, ".(", ficlPrimitiveDotParen
,
3272 FICL_WORD_IMMEDIATE
);
3273 /* ".r" is in softcore */
3274 ficlDictionarySetPrimitive(dictionary
, ":noname",
3275 ficlPrimitiveColonNoName
, FICL_WORD_DEFAULT
);
3276 ficlDictionarySetPrimitive(dictionary
, "?do", ficlPrimitiveQDoCoIm
,
3277 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3278 ficlDictionarySetPrimitive(dictionary
, "again", ficlPrimitiveAgainCoIm
,
3279 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3280 ficlDictionarySetPrimitive(dictionary
, "c\"",
3281 ficlPrimitiveCountedStringQuoteIm
, FICL_WORD_IMMEDIATE
);
3282 ficlDictionarySetPrimitive(dictionary
, "hex", ficlPrimitiveHex
,
3284 ficlDictionarySetPrimitive(dictionary
, "pad", ficlPrimitivePad
,
3286 ficlDictionarySetPrimitive(dictionary
, "parse", ficlPrimitiveParse
,
3290 * query restore-input save-input tib u.r u> unused
3291 * [FICL_VM_STATE_COMPILE]
3293 ficlDictionarySetPrimitive(dictionary
, "refill", ficlPrimitiveRefill
,
3295 ficlDictionarySetPrimitive(dictionary
, "source-id",
3296 ficlPrimitiveSourceID
, FICL_WORD_DEFAULT
);
3297 ficlDictionarySetPrimitive(dictionary
, "to", ficlPrimitiveToValue
,
3298 FICL_WORD_IMMEDIATE
);
3299 ficlDictionarySetPrimitive(dictionary
, "value", ficlPrimitiveConstant
,
3301 ficlDictionarySetPrimitive(dictionary
, "\\", ficlPrimitiveBackslash
,
3302 FICL_WORD_IMMEDIATE
);
3305 * Environment query values for the Core word set
3307 ficlDictionarySetConstant(environment
, "/counted-string",
3308 FICL_COUNTED_STRING_MAX
);
3309 ficlDictionarySetConstant(environment
, "/hold", FICL_PAD_SIZE
);
3310 ficlDictionarySetConstant(environment
, "/pad", FICL_PAD_SIZE
);
3311 ficlDictionarySetConstant(environment
, "address-unit-bits", 8);
3312 ficlDictionarySetConstant(environment
, "core", FICL_TRUE
);
3313 ficlDictionarySetConstant(environment
, "core-ext", FICL_FALSE
);
3314 ficlDictionarySetConstant(environment
, "floored", FICL_FALSE
);
3315 ficlDictionarySetConstant(environment
, "max-char", UCHAR_MAX
);
3316 ficlDictionarySetConstant(environment
, "max-n", LONG_MAX
);
3317 ficlDictionarySetConstant(environment
, "max-u", ULONG_MAX
);
3321 ficlInteger low
, high
;
3325 FICL_2INTEGER_SET(high
, low
, id
);
3326 ficlDictionarySet2Constant(environment
, "max-d", id
);
3328 FICL_2INTEGER_SET(high
, low
, id
);
3329 ficlDictionarySet2Constant(environment
, "max-ud", id
);
3332 ficlDictionarySetConstant(environment
, "return-stack-cells",
3333 FICL_DEFAULT_STACK_SIZE
);
3334 ficlDictionarySetConstant(environment
, "stack-cells",
3335 FICL_DEFAULT_STACK_SIZE
);
3338 * The optional Double-Number word set (partial)
3340 ficlDictionarySetPrimitive(dictionary
, "2constant",
3341 ficlPrimitive2Constant
, FICL_WORD_IMMEDIATE
);
3342 ficlDictionarySetPrimitive(dictionary
, "2literal",
3343 ficlPrimitive2LiteralIm
, FICL_WORD_IMMEDIATE
);
3344 ficlDictionarySetPrimitive(dictionary
, "2variable",
3345 ficlPrimitive2Variable
, FICL_WORD_IMMEDIATE
);
3347 * D+ D- D. D.R D0< D0= D2* D2/ in softcore
3348 * D< D= D>S DABS DMAX DMIN DNEGATE in softcore
3349 * m-star-slash is TODO
3356 ficlDictionarySetPrimitive(dictionary
, "2rot",
3357 ficlPrimitive2Rot
, FICL_WORD_DEFAULT
);
3358 ficlDictionarySetPrimitive(dictionary
, "2value",
3359 ficlPrimitive2Constant
, FICL_WORD_IMMEDIATE
);
3360 /* du< in softcore */
3362 * The optional Exception and Exception Extensions word set
3364 ficlDictionarySetPrimitive(dictionary
, "catch", ficlPrimitiveCatch
,
3366 ficlDictionarySetPrimitive(dictionary
, "throw", ficlPrimitiveThrow
,
3369 ficlDictionarySetConstant(environment
, "exception", FICL_TRUE
);
3370 ficlDictionarySetConstant(environment
, "exception-ext", FICL_TRUE
);
3373 * The optional Locals and Locals Extensions word set
3374 * see softcore.c for implementation of locals|
3376 #if FICL_WANT_LOCALS
3377 ficlDictionarySetPrimitive(dictionary
, "doLocal",
3378 ficlPrimitiveDoLocalIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3379 ficlDictionarySetPrimitive(dictionary
, "(local)",
3380 ficlPrimitiveLocalParen
, FICL_WORD_COMPILE_ONLY
);
3381 ficlDictionarySetPrimitive(dictionary
, "(2local)",
3382 ficlPrimitive2LocalParen
, FICL_WORD_COMPILE_ONLY
);
3384 ficlDictionarySetConstant(environment
, "locals", FICL_TRUE
);
3385 ficlDictionarySetConstant(environment
, "locals-ext", FICL_TRUE
);
3386 ficlDictionarySetConstant(environment
, "#locals", FICL_MAX_LOCALS
);
3390 * The optional Memory-Allocation word set
3393 ficlDictionarySetPrimitive(dictionary
, "allocate",
3394 ficlPrimitiveAllocate
, FICL_WORD_DEFAULT
);
3395 ficlDictionarySetPrimitive(dictionary
, "free", ficlPrimitiveFree
,
3397 ficlDictionarySetPrimitive(dictionary
, "resize", ficlPrimitiveResize
,
3400 ficlDictionarySetConstant(environment
, "memory-alloc", FICL_TRUE
);
3403 * The optional Search-Order word set
3405 ficlSystemCompileSearch(system
);
3408 * The optional Programming-Tools and Programming-Tools
3409 * Extensions word set
3411 ficlSystemCompileTools(system
);
3414 * The optional File-Access and File-Access Extensions word set
3417 ficlSystemCompileFile(system
);
3423 ficlDictionarySetPrimitive(dictionary
, ".ver", ficlPrimitiveVersion
,
3425 ficlDictionarySetPrimitive(dictionary
, ">name", ficlPrimitiveToName
,
3427 ficlDictionarySetPrimitive(dictionary
, "add-parse-step",
3428 ficlPrimitiveAddParseStep
, FICL_WORD_DEFAULT
);
3429 ficlDictionarySetPrimitive(dictionary
, "body>", ficlPrimitiveFromBody
,
3431 ficlDictionarySetPrimitive(dictionary
, "compile-only",
3432 ficlPrimitiveCompileOnly
, FICL_WORD_DEFAULT
);
3433 ficlDictionarySetPrimitive(dictionary
, "endif", ficlPrimitiveEndifCoIm
,
3434 FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3435 ficlDictionarySetPrimitive(dictionary
, "last-word",
3436 ficlPrimitiveLastWord
, FICL_WORD_DEFAULT
);
3437 ficlDictionarySetPrimitive(dictionary
, "hash", ficlPrimitiveHash
,
3439 ficlDictionarySetPrimitive(dictionary
, "objectify",
3440 ficlPrimitiveSetObjectFlag
, FICL_WORD_DEFAULT
);
3441 ficlDictionarySetPrimitive(dictionary
, "?object",
3442 ficlPrimitiveIsObject
, FICL_WORD_DEFAULT
);
3443 ficlDictionarySetPrimitive(dictionary
, "parse-word",
3444 ficlPrimitiveParseNoCopy
, FICL_WORD_DEFAULT
);
3445 ficlDictionarySetPrimitive(dictionary
, "sfind", ficlPrimitiveSFind
,
3447 ficlDictionarySetPrimitive(dictionary
, "sliteral",
3448 ficlPrimitiveSLiteralCoIm
, FICL_WORD_COMPILE_ONLY_IMMEDIATE
);
3449 ficlDictionarySetPrimitive(dictionary
, "sprintf", ficlPrimitiveSprintf
,
3451 ficlDictionarySetPrimitive(dictionary
, "strlen", ficlPrimitiveStrlen
,
3453 ficlDictionarySetPrimitive(dictionary
, "x.", ficlPrimitiveHexDot
,
3456 ficlDictionarySetPrimitive(dictionary
, "user", ficlPrimitiveUser
,
3461 * internal support words
3463 interpret
= ficlDictionarySetPrimitive(dictionary
, "interpret",
3464 ficlPrimitiveInterpret
, FICL_WORD_DEFAULT
);
3465 ficlDictionarySetPrimitive(dictionary
, "lookup", ficlPrimitiveLookup
,
3467 ficlDictionarySetPrimitive(dictionary
, "(parse-step)",
3468 ficlPrimitiveParseStepParen
, FICL_WORD_DEFAULT
);
3469 system
->exitInnerWord
= ficlDictionarySetPrimitive(dictionary
,
3470 "exit-inner", ficlPrimitiveExitInner
, FICL_WORD_DEFAULT
);
3473 * Set constants representing the internal instruction words
3474 * If you want all of 'em, turn that "#if 0" to "#if 1".
3475 * By default you only get the numbers (fi0, fiNeg1, etc).
3477 #define FICL_TOKEN(token, description) \
3478 ficlDictionarySetConstant(dictionary, #token, token);
3480 #define FICL_INSTRUCTION_TOKEN(token, description, flags) \
3481 ficlDictionarySetConstant(dictionary, #token, token);
3483 #define FICL_INSTRUCTION_TOKEN(token, description, flags)
3485 #include "ficltokens.h"
3487 #undef FICL_INSTRUCTION_TOKEN
3490 * Set up system's outer interpreter loop - maybe this should
3493 system
->interpreterLoop
[0] = interpret
;
3494 system
->interpreterLoop
[1] = (ficlWord
*)ficlInstructionBranchParen
;
3495 system
->interpreterLoop
[2] = (ficlWord
*)(void *)(-2);
3497 FICL_SYSTEM_ASSERT(system
,
3498 ficlDictionaryCellsAvailable(dictionary
) > 0);