?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge rev 1.26 from FreeBSD:
[dragonfly.git] / sys / boot / ficl / words.c
blob27e8887ae3a1266648278c993f94dad2fee129f4
1 /*******************************************************************
2 ** w o r d s . c
3 ** Forth Inspired Command Language
4 ** ANS Forth CORE word-set written in C
5 ** Author: John Sadler (john_sadler@alum.mit.edu)
6 ** Created: 19 July 1997
7 ** $Id: words.c,v 1.17 2001/12/05 07:21:34 jsadler Exp $
8 *******************************************************************/
9 /*
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
12 **
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
14 **
15 ** I am interested in hearing from anyone who uses ficl. If you have
16 ** a problem, a success story, a defect, an enhancement request, or
17 ** if you would like to contribute to the ficl release, please
18 ** contact me by email at the address above.
19 **
20 ** L I C E N S E and D I S C L A I M E R
21 **
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
24 ** are met:
25 ** 1. Redistributions of source code must retain the above copyright
26 ** notice, this list of conditions and the following disclaimer.
27 ** 2. Redistributions in binary form must reproduce the above copyright
28 ** notice, this list of conditions and the following disclaimer in the
29 ** documentation and/or other materials provided with the distribution.
30 **
31 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34 ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41 ** SUCH DAMAGE.
42 */
43
44 /*
45 * $FreeBSD: src/sys/boot/ficl/words.c,v 1.39 2002/12/30 21:18:06 schweikh Exp $
46 * $DragonFly: src/sys/boot/ficl/words.c,v 1.3 2003/11/10 06:08:33 dillon Exp $
47 */
48
49 #ifdef TESTMAIN
50 #include <stdlib.h>
51 #include <stdio.h>
52 #include <ctype.h>
53 #include <fcntl.h>
54 #else
55 #include <stand.h>
56 #endif
57 #include <string.h>
58 #include "ficl.h"
59 #include "math64.h"
60
61 static void colonParen(FICL_VM *pVM);
62 static void literalIm(FICL_VM *pVM);
63 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si);
64
65 /*
66 ** Control structure building words use these
67 ** strings' addresses as markers on the stack to
68 ** check for structure completion.
69 */
70 static char doTag[] = "do";
71 static char colonTag[] = "colon";
72 static char leaveTag[] = "leave";
73
74 static char destTag[] = "target";
75 static char origTag[] = "origin";
76
77 #if FICL_WANT_LOCALS
78 static void doLocalIm(FICL_VM *pVM);
79 static void do2LocalIm(FICL_VM *pVM);
80 #endif
81
82
83 /*
84 ** C O N T R O L S T R U C T U R E B U I L D E R S
85 **
86 ** Push current dict location for later branch resolution.
87 ** The location may be either a branch target or a patch address...
88 */
89 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
90 {
91 PUSHPTR(dp->here);
92 PUSHPTR(tag);
93 return;
94 }
95
96 static void markControlTag(FICL_VM *pVM, char *tag)
97 {
98 PUSHPTR(tag);
99 return;
100 }
101
102 static void matchControlTag(FICL_VM *pVM, char *tag)
103 {
104 char *cp;
105 #if FICL_ROBUST > 1
106 vmCheckStack(pVM, 1, 0);
107 #endif
108 cp = (char *)stackPopPtr(pVM->pStack);
109 /*
110 ** Changed the code below to compare the pointers first (by popular demand)
111 */
112 if ( (cp != tag) && strcmp(cp, tag) )
113 {
114 vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
115 }
116
117 return;
118 }
119
120 /*
121 ** Expect a branch target address on the param stack,
122 ** compile a literal offset from the current dict location
123 ** to the target address
124 */
125 static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
126 {
127 FICL_INT offset;
128 CELL *patchAddr;
129
130 matchControlTag(pVM, tag);
131
132 #if FICL_ROBUST > 1
133 vmCheckStack(pVM, 1, 0);
134 #endif
135 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
136 offset = patchAddr - dp->here;
137 dictAppendCell(dp, LVALUEtoCELL(offset));
138
139 return;
140 }
141
142
143 /*
144 ** Expect a branch patch address on the param stack,
145 ** compile a literal offset from the patch location
146 ** to the current dict location
147 */
148 static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
149 {
150 FICL_INT offset;
151 CELL *patchAddr;
152
153 matchControlTag(pVM, tag);
154
155 #if FICL_ROBUST > 1
156 vmCheckStack(pVM, 1, 0);
157 #endif
158 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
159 offset = dp->here - patchAddr;
160 *patchAddr = LVALUEtoCELL(offset);
161
162 return;
163 }
164
165 /*
166 ** Match the tag to the top of the stack. If success,
167 ** sopy "here" address into the cell whose address is next
168 ** on the stack. Used by do..leave..loop.
169 */
170 static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
171 {
172 CELL *patchAddr;
173 char *cp;
174
175 #if FICL_ROBUST > 1
176 vmCheckStack(pVM, 2, 0);
177 #endif
178 cp = stackPopPtr(pVM->pStack);
179 /*
180 ** Changed the comparison below to compare the pointers first (by popular demand)
181 */
182 if ((cp != tag) && strcmp(cp, tag))
183 {
184 vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
185 vmTextOut(pVM, tag, 1);
186 }
187
188 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
189 *patchAddr = LVALUEtoCELL(dp->here);
190
191 return;
192 }
193
194
195 /**************************************************************************
196 f i c l P a r s e N u m b e r
197 ** Attempts to convert the NULL terminated string in the VM's pad to
198 ** a number using the VM's current base. If successful, pushes the number
199 ** onto the param stack and returns TRUE. Otherwise, returns FALSE.
200 ** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
201 ** the standard for DOUBLE wordset.
202 **************************************************************************/
203
204 int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
205 {
206 FICL_INT accum = 0;
207 char isNeg = FALSE;
208 char hasDP = FALSE;
209 unsigned base = pVM->base;
210 char *cp = SI_PTR(si);
211 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
212 unsigned ch;
213 unsigned digit;
214
215 if (count > 1)
216 {
217 switch (*cp)
218 {
219 case '-':
220 cp++;
221 count--;
222 isNeg = TRUE;
223 break;
224 case '+':
225 cp++;
226 count--;
227 isNeg = FALSE;
228 break;
229 default:
230 break;
231 }
232 }
233
234 if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
235 {
236 hasDP = TRUE;
237 count--;
238 }
239
240 if (count == 0) /* detect "+", "-", ".", "+." etc */
241 return FALSE;
242
243 while ((count--) && ((ch = *cp++) != '\0'))
244 {
245 if (!isalnum(ch))
246 return FALSE;
247
248 digit = ch - '0';
249
250 if (digit > 9)
251 digit = tolower(ch) - 'a' + 10;
252
253 if (digit >= base)
254 return FALSE;
255
256 accum = accum * base + digit;
257 }
258
259 if (hasDP) /* simple (required) DOUBLE support */
260 PUSHINT(0);
261
262 if (isNeg)
263 accum = -accum;
264
265 PUSHINT(accum);
266 if (pVM->state == COMPILE)
267 literalIm(pVM);
268
269 return TRUE;
270 }
271
272
273 /**************************************************************************
274 a d d & f r i e n d s
275 **
276 **************************************************************************/
277
278 static void add(FICL_VM *pVM)
279 {
280 FICL_INT i;
281 #if FICL_ROBUST > 1
282 vmCheckStack(pVM, 2, 1);
283 #endif
284 i = stackPopINT(pVM->pStack);
285 i += stackGetTop(pVM->pStack).i;
286 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
287 return;
288 }
289
290 static void sub(FICL_VM *pVM)
291 {
292 FICL_INT i;
293 #if FICL_ROBUST > 1
294 vmCheckStack(pVM, 2, 1);
295 #endif
296 i = stackPopINT(pVM->pStack);
297 i = stackGetTop(pVM->pStack).i - i;
298 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
299 return;
300 }
301
302 static void mul(FICL_VM *pVM)
303 {
304 FICL_INT i;
305 #if FICL_ROBUST > 1
306 vmCheckStack(pVM, 2, 1);
307 #endif
308 i = stackPopINT(pVM->pStack);
309 i *= stackGetTop(pVM->pStack).i;
310 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
311 return;
312 }
313
314 static void negate(FICL_VM *pVM)
315 {
316 FICL_INT i;
317 #if FICL_ROBUST > 1
318 vmCheckStack(pVM, 1, 1);
319 #endif
320 i = -stackPopINT(pVM->pStack);
321 PUSHINT(i);
322 return;
323 }
324
325 static void ficlDiv(FICL_VM *pVM)
326 {
327 FICL_INT i;
328 #if FICL_ROBUST > 1
329 vmCheckStack(pVM, 2, 1);
330 #endif
331 i = stackPopINT(pVM->pStack);
332 i = stackGetTop(pVM->pStack).i / i;
333 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
334 return;
335 }
336
337 /*
338 ** slash-mod CORE ( n1 n2 -- n3 n4 )
339 ** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
340 ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
341 ** differ in sign, the implementation-defined result returned will be the
342 ** same as that returned by either the phrase
343 ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
344 ** NOTE: Ficl complies with the second phrase (symmetric division)
345 */
346 static void slashMod(FICL_VM *pVM)
347 {
348 DPINT n1;
349 FICL_INT n2;
350 INTQR qr;
351
352 #if FICL_ROBUST > 1
353 vmCheckStack(pVM, 2, 2);
354 #endif
355 n2 = stackPopINT(pVM->pStack);
356 n1.lo = stackPopINT(pVM->pStack);
357 i64Extend(n1);
358
359 qr = m64SymmetricDivI(n1, n2);
360 PUSHINT(qr.rem);
361 PUSHINT(qr.quot);
362 return;
363 }
364
365 static void onePlus(FICL_VM *pVM)
366 {
367 FICL_INT i;
368 #if FICL_ROBUST > 1
369 vmCheckStack(pVM, 1, 1);
370 #endif
371 i = stackGetTop(pVM->pStack).i;
372 i += 1;
373 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
374 return;
375 }
376
377 static void oneMinus(FICL_VM *pVM)
378 {
379 FICL_INT i;
380 #if FICL_ROBUST > 1
381 vmCheckStack(pVM, 1, 1);
382 #endif
383 i = stackGetTop(pVM->pStack).i;
384 i -= 1;
385 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
386 return;
387 }
388
389 static void twoMul(FICL_VM *pVM)
390 {
391 FICL_INT i;
392 #if FICL_ROBUST > 1
393 vmCheckStack(pVM, 1, 1);
394 #endif
395 i = stackGetTop(pVM->pStack).i;
396 i *= 2;
397 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
398 return;
399 }
400
401 static void twoDiv(FICL_VM *pVM)
402 {
403 FICL_INT i;
404 #if FICL_ROBUST > 1
405 vmCheckStack(pVM, 1, 1);
406 #endif
407 i = stackGetTop(pVM->pStack).i;
408 i >>= 1;
409 stackSetTop(pVM->pStack, LVALUEtoCELL(i));
410 return;
411 }
412
413 static void mulDiv(FICL_VM *pVM)
414 {
415 FICL_INT x, y, z;
416 DPINT prod;
417 #if FICL_ROBUST > 1
418 vmCheckStack(pVM, 3, 1);
419 #endif
420 z = stackPopINT(pVM->pStack);
421 y = stackPopINT(pVM->pStack);
422 x = stackPopINT(pVM->pStack);
423
424 prod = m64MulI(x,y);
425 x = m64SymmetricDivI(prod, z).quot;
426
427 PUSHINT(x);
428 return;
429 }
430
431
432 static void mulDivRem(FICL_VM *pVM)
433 {
434 FICL_INT x, y, z;
435 DPINT prod;
436 INTQR qr;
437 #if FICL_ROBUST > 1
438 vmCheckStack(pVM, 3, 2);
439 #endif
440 z = stackPopINT(pVM->pStack);
441 y = stackPopINT(pVM->pStack);
442 x = stackPopINT(pVM->pStack);
443
444 prod = m64MulI(x,y);
445 qr = m64SymmetricDivI(prod, z);
446
447 PUSHINT(qr.rem);
448 PUSHINT(qr.quot);
449 return;
450 }
451
452
453 /**************************************************************************
454 c o l o n d e f i n i t i o n s
455 ** Code to begin compiling a colon definition
456 ** This function sets the state to COMPILE, then creates a
457 ** new word whose name is the next word in the input stream
458 ** and whose code is colonParen.
459 **************************************************************************/
460
461 static void colon(FICL_VM *pVM)
462 {
463 FICL_DICT *dp = vmGetDict(pVM);
464 STRINGINFO si = vmGetWord(pVM);
465
466 dictCheckThreshold(dp);
467
468 pVM->state = COMPILE;
469 markControlTag(pVM, colonTag);
470 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
471 #if FICL_WANT_LOCALS
472 pVM->pSys->nLocals = 0;
473 #endif
474 return;
475 }
476
477
478 /**************************************************************************
479 c o l o n P a r e n
480 ** This is the code that executes a colon definition. It assumes that the
481 ** virtual machine is running a "next" loop (See the vm.c
482 ** for its implementation of member function vmExecute()). The colon
483 ** code simply copies the address of the first word in the list of words
484 ** to interpret into IP after saving its old value. When we return to the
485 ** "next" loop, the virtual machine will call the code for each word in
486 ** turn.
487 **
488 **************************************************************************/
489
490 static void colonParen(FICL_VM *pVM)
491 {
492 IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
493 vmPushIP(pVM, tempIP);
494
495 return;
496 }
497
498
499 /**************************************************************************
500 s e m i c o l o n C o I m
501 **
502 ** IMMEDIATE code for ";". This function sets the state to INTERPRET and
503 ** terminates a word under compilation by appending code for "(;)" to
504 ** the definition. TO DO: checks for leftover branch target tags on the
505 ** return stack and complains if any are found.
506 **************************************************************************/
507 static void semiParen(FICL_VM *pVM)
508 {
509 vmPopIP(pVM);
510 return;
511 }
512
513
514 static void semicolonCoIm(FICL_VM *pVM)
515 {
516 FICL_DICT *dp = vmGetDict(pVM);
517
518 assert(pVM->pSys->pSemiParen);
519 matchControlTag(pVM, colonTag);
520
521 #if FICL_WANT_LOCALS
522 assert(pVM->pSys->pUnLinkParen);
523 if (pVM->pSys->nLocals > 0)
524 {
525 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
526 dictEmpty(pLoc, pLoc->pForthWords->size);
527 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
528 }
529 pVM->pSys->nLocals = 0;
530 #endif
531
532 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
533 pVM->state = INTERPRET;
534 dictUnsmudge(dp);
535 return;
536 }
537
538
539 /**************************************************************************
540 e x i t
541 ** CORE
542 ** This function simply pops the previous instruction
543 ** pointer and returns to the "next" loop. Used for exiting from within
544 ** a definition. Note that exitParen is identical to semiParen - they
545 ** are in two different functions so that "see" can correctly identify
546 ** the end of a colon definition, even if it uses "exit".
547 **************************************************************************/
548 static void exitParen(FICL_VM *pVM)
549 {
550 vmPopIP(pVM);
551 return;
552 }
553
554 static void exitCoIm(FICL_VM *pVM)
555 {
556 FICL_DICT *dp = vmGetDict(pVM);
557 assert(pVM->pSys->pExitParen);
558 IGNORE(pVM);
559
560 #if FICL_WANT_LOCALS
561 if (pVM->pSys->nLocals > 0)
562 {
563 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
564 }
565 #endif
566 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
567 return;
568 }
569
570
571 /**************************************************************************
572 c o n s t a n t P a r e n
573 ** This is the run-time code for "constant". It simply returns the
574 ** contents of its word's first data cell.
575 **
576 **************************************************************************/
577
578 void constantParen(FICL_VM *pVM)
579 {
580 FICL_WORD *pFW = pVM->runningWord;
581 #if FICL_ROBUST > 1
582 vmCheckStack(pVM, 0, 1);
583 #endif
584 stackPush(pVM->pStack, pFW->param[0]);
585 return;
586 }
587
588 void twoConstParen(FICL_VM *pVM)
589 {
590 FICL_WORD *pFW = pVM->runningWord;
591 #if FICL_ROBUST > 1
592 vmCheckStack(pVM, 0, 2);
593 #endif
594 stackPush(pVM->pStack, pFW->param[0]); /* lo */
595 stackPush(pVM->pStack, pFW->param[1]); /* hi */
596 return;
597 }
598
599
600 /**************************************************************************
601 c o n s t a n t
602 ** IMMEDIATE
603 ** Compiles a constant into the dictionary. Constants return their
604 ** value when invoked. Expects a value on top of the parm stack.
605 **************************************************************************/
606
607 static void constant(FICL_VM *pVM)
608 {
609 FICL_DICT *dp = vmGetDict(pVM);
610 STRINGINFO si = vmGetWord(pVM);
611
612 #if FICL_ROBUST > 1
613 vmCheckStack(pVM, 1, 0);
614 #endif
615 dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
616 dictAppendCell(dp, stackPop(pVM->pStack));
617 return;
618 }
619
620
621 static void twoConstant(FICL_VM *pVM)
622 {
623 FICL_DICT *dp = vmGetDict(pVM);
624 STRINGINFO si = vmGetWord(pVM);
625 CELL c;
626
627 #if FICL_ROBUST > 1
628 vmCheckStack(pVM, 2, 0);
629 #endif
630 c = stackPop(pVM->pStack);
631 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
632 dictAppendCell(dp, stackPop(pVM->pStack));
633 dictAppendCell(dp, c);
634 return;
635 }
636
637
638 /**************************************************************************
639 d i s p l a y C e l l
640 ** Drop and print the contents of the cell at the top of the param
641 ** stack
642 **************************************************************************/
643
644 static void displayCell(FICL_VM *pVM)
645 {
646 CELL c;
647 #if FICL_ROBUST > 1
648 vmCheckStack(pVM, 1, 0);
649 #endif
650 c = stackPop(pVM->pStack);
651 ltoa((c).i, pVM->pad, pVM->base);
652 strcat(pVM->pad, " ");
653 vmTextOut(pVM, pVM->pad, 0);
654 return;
655 }
656
657 static void uDot(FICL_VM *pVM)
658 {
659 FICL_UNS u;
660 #if FICL_ROBUST > 1
661 vmCheckStack(pVM, 1, 0);
662 #endif
663 u = stackPopUNS(pVM->pStack);
664 ultoa(u, pVM->pad, pVM->base);
665 strcat(pVM->pad, " ");
666 vmTextOut(pVM, pVM->pad, 0);
667 return;
668 }
669
670
671 static void hexDot(FICL_VM *pVM)
672 {
673 FICL_UNS u;
674 #if FICL_ROBUST > 1
675 vmCheckStack(pVM, 1, 0);
676 #endif
677 u = stackPopUNS(pVM->pStack);
678 ultoa(u, pVM->pad, 16);
679 strcat(pVM->pad, " ");
680 vmTextOut(pVM, pVM->pad, 0);
681 return;
682 }
683
684
685 /**************************************************************************
686 s t r l e n
687 ** FICL ( c-string -- length )
688 **
689 ** Returns the length of a C-style (zero-terminated) string.
690 **
691 ** --lch
692 **/
693 static void ficlStrlen(FICL_VM *ficlVM)
694 {
695 char *address = (char *)stackPopPtr(ficlVM->pStack);
696 stackPushINT(ficlVM->pStack, strlen(address));
697 }
698
699
700 /**************************************************************************
701 s p r i n t f
702 ** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
703 ** Similar to the C sprintf() function. It formats into a buffer based on
704 ** a "format" string. Each character in the format string is copied verbatim
705 ** to the output buffer, until SPRINTF encounters a percent sign ("%").
706 ** SPRINTF then skips the percent sign, and examines the next character
707 ** (the "format character"). Here are the valid format characters:
708 ** s - read a C-ADDR U-LENGTH string from the stack and copy it to
709 ** the buffer
710 ** d - read a cell from the stack, format it as a string (base-10,
711 ** signed), and copy it to the buffer
712 ** x - same as d, except in base-16
713 ** u - same as d, but unsigned
714 ** % - output a literal percent-sign to the buffer
715 ** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
716 ** written, and a flag indicating whether or not it ran out of space while
717 ** writing to the output buffer (TRUE if it ran out of space).
718 **
719 ** If SPRINTF runs out of space in the buffer to store the formatted string,
720 ** it still continues parsing, in an effort to preserve your stack (otherwise
721 ** it might leave uneaten arguments behind).
722 **
723 ** --lch
724 **************************************************************************/
725 static void ficlSprintf(FICL_VM *pVM) /* */
726 {
727 int bufferLength = stackPopINT(pVM->pStack);
728 char *buffer = (char *)stackPopPtr(pVM->pStack);
729 char *bufferStart = buffer;
730
731 int formatLength = stackPopINT(pVM->pStack);
732 char *format = (char *)stackPopPtr(pVM->pStack);
733 char *formatStop = format + formatLength;
734
735 int base = 10;
736 int unsignedInteger = FALSE;
737
738 FICL_INT append = FICL_TRUE;
739
740 while (format < formatStop)
741 {
742 char scratch[64];
743 char *source;
744 int actualLength;
745 int desiredLength;
746 int leadingZeroes;
747
748
749 if (*format != '%')
750 {
751 source = format;
752 actualLength = desiredLength = 1;
753 leadingZeroes = 0;
754 }
755 else
756 {
757 format++;
758 if (format == formatStop)
759 break;
760
761 leadingZeroes = (*format == '0');
762 if (leadingZeroes)
763 {
764 format++;
765 if (format == formatStop)
766 break;
767 }
768
769 desiredLength = isdigit(*format);
770 if (desiredLength)
771 {
772 desiredLength = strtol(format, &format, 10);
773 if (format == formatStop)
774 break;
775 }
776 else if (*format == '*')
777 {
778 desiredLength = stackPopINT(pVM->pStack);
779 format++;
780 if (format == formatStop)
781 break;
782 }
783
784
785 switch (*format)
786 {
787 case 's':
788 case 'S':
789 {
790 actualLength = stackPopINT(pVM->pStack);
791 source = (char *)stackPopPtr(pVM->pStack);
792 break;
793 }
794 case 'x':
795 case 'X':
796 base = 16;
797 case 'u':
798 case 'U':
799 unsignedInteger = TRUE;
800 case 'd':
801 case 'D':
802 {
803 int integer = stackPopINT(pVM->pStack);
804 if (unsignedInteger)
805 ultoa(integer, scratch, base);
806 else
807 ltoa(integer, scratch, base);
808 base = 10;
809 unsignedInteger = FALSE;
810 source = scratch;
811 actualLength = strlen(scratch);
812 break;
813 }
814 case '%':
815 source = format;
816 actualLength = 1;
817 default:
818 continue;
819 }
820 }
821
822 if (append != FICL_FALSE)
823 {
824 if (!desiredLength)
825 desiredLength = actualLength;
826 if (desiredLength > bufferLength)
827 {
828 append = FICL_FALSE;
829 desiredLength = bufferLength;
830 }
831 while (desiredLength > actualLength)
832 {
833 *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
834 bufferLength--;
835 desiredLength--;
836 }
837 memcpy(buffer, source, actualLength);
838 buffer += actualLength;
839 bufferLength -= actualLength;
840 }
841
842 format++;
843 }
844
845 stackPushPtr(pVM->pStack, bufferStart);
846 stackPushINT(pVM->pStack, buffer - bufferStart);
847 stackPushINT(pVM->pStack, append);
848 }
849
850
851 /**************************************************************************
852 d u p & f r i e n d s
853 **
854 **************************************************************************/
855
856 static void depth(FICL_VM *pVM)
857 {
858 int i;
859 #if FICL_ROBUST > 1
860 vmCheckStack(pVM, 0, 1);
861 #endif
862 i = stackDepth(pVM->pStack);
863 PUSHINT(i);
864 return;
865 }
866
867
868 static void drop(FICL_VM *pVM)
869 {
870 #if FICL_ROBUST > 1
871 vmCheckStack(pVM, 1, 0);
872 #endif
873 stackDrop(pVM->pStack, 1);
874 return;
875 }
876
877
878 static void twoDrop(FICL_VM *pVM)
879 {
880 #if FICL_ROBUST > 1
881 vmCheckStack(pVM, 2, 0);
882 #endif
883 stackDrop(pVM->pStack, 2);
884 return;
885 }
886
887
888 static void dup(FICL_VM *pVM)
889 {
890 #if FICL_ROBUST > 1
891 vmCheckStack(pVM, 1, 2);
892 #endif
893 stackPick(pVM->pStack, 0);
894 return;
895 }
896
897
898 static void twoDup(FICL_VM *pVM)
899 {
900 #if FICL_ROBUST > 1
901 vmCheckStack(pVM, 2, 4);
902 #endif
903 stackPick(pVM->pStack, 1);
904 stackPick(pVM->pStack, 1);
905 return;
906 }
907
908
909 static void over(FICL_VM *pVM)
910 {
911 #if FICL_ROBUST > 1
912 vmCheckStack(pVM, 2, 3);
913 #endif
914 stackPick(pVM->pStack, 1);
915 return;
916 }
917
918 static void twoOver(FICL_VM *pVM)
919 {
920 #if FICL_ROBUST > 1
921 vmCheckStack(pVM, 4, 6);
922 #endif
923 stackPick(pVM->pStack, 3);
924 stackPick(pVM->pStack, 3);
925 return;
926 }
927
928
929 static void pick(FICL_VM *pVM)
930 {
931 CELL c = stackPop(pVM->pStack);
932 #if FICL_ROBUST > 1
933 vmCheckStack(pVM, c.i+1, c.i+2);
934 #endif
935 stackPick(pVM->pStack, c.i);
936 return;
937 }
938
939
940 static void questionDup(FICL_VM *pVM)
941 {
942 CELL c;
943 #if FICL_ROBUST > 1
944 vmCheckStack(pVM, 1, 2);
945 #endif
946 c = stackGetTop(pVM->pStack);
947
948 if (c.i != 0)
949 stackPick(pVM->pStack, 0);
950
951 return;
952 }
953
954
955 static void roll(FICL_VM *pVM)
956 {
957 int i = stackPop(pVM->pStack).i;
958 i = (i > 0) ? i : 0;
959 #if FICL_ROBUST > 1
960 vmCheckStack(pVM, i+1, i+1);
961 #endif
962 stackRoll(pVM->pStack, i);
963 return;
964 }
965
966
967 static void minusRoll(FICL_VM *pVM)
968 {
969 int i = stackPop(pVM->pStack).i;
970 i = (i > 0) ? i : 0;
971 #if FICL_ROBUST > 1
972 vmCheckStack(pVM, i+1, i+1);
973 #endif
974 stackRoll(pVM->pStack, -i);
975 return;
976 }
977
978
979 static void rot(FICL_VM *pVM)
980 {
981 #if FICL_ROBUST > 1
982 vmCheckStack(pVM, 3, 3);
983 #endif
984 stackRoll(pVM->pStack, 2);
985 return;
986 }
987
988
989 static void swap(FICL_VM *pVM)
990 {
991 #if FICL_ROBUST > 1
992 vmCheckStack(pVM, 2, 2);
993 #endif
994 stackRoll(pVM->pStack, 1);
995 return;
996 }
997
998
999 static void twoSwap(FICL_VM *pVM)
1000 {
1001 #if FICL_ROBUST > 1
1002 vmCheckStack(pVM, 4, 4);
1003 #endif
1004 stackRoll(pVM->pStack, 3);
1005 stackRoll(pVM->pStack, 3);
1006 return;
1007 }
1008
1009
1010 /**************************************************************************
1011 e m i t & f r i e n d s
1012 **
1013 **************************************************************************/
1014
1015 static void emit(FICL_VM *pVM)
1016 {
1017 char *cp = pVM->pad;
1018 int i;
1019
1020 #if FICL_ROBUST > 1
1021 vmCheckStack(pVM, 1, 0);
1022 #endif
1023 i = stackPopINT(pVM->pStack);
1024 cp[0] = (char)i;
1025 cp[1] = '\0';
1026 vmTextOut(pVM, cp, 0);
1027 return;
1028 }
1029
1030
1031 static void cr(FICL_VM *pVM)
1032 {
1033 vmTextOut(pVM, "", 1);
1034 return;
1035 }
1036
1037
1038 static void commentLine(FICL_VM *pVM)
1039 {
1040 char *cp = vmGetInBuf(pVM);
1041 char *pEnd = vmGetInBufEnd(pVM);
1042 char ch = *cp;
1043
1044 while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
1045 {
1046 ch = *++cp;
1047 }
1048
1049 /*
1050 ** Cope with DOS or UNIX-style EOLs -
1051 ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
1052 ** and point cp to next char. If EOL is \0, we're done.
1053 */
1054 if (cp != pEnd)
1055 {
1056 cp++;
1057
1058 if ( (cp != pEnd) && (ch != *cp)
1059 && ((*cp == '\r') || (*cp == '\n')) )
1060 cp++;
1061 }
1062
1063 vmUpdateTib(pVM, cp);
1064 return;
1065 }
1066
1067
1068 /*
1069 ** paren CORE
1070 ** Compilation: Perform the execution semantics given below.
1071 ** Execution: ( "ccc<paren>" -- )
1072 ** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
1073 ** The number of characters in ccc may be zero to the number of characters
1074 ** in the parse area.
1075 **
1076 */
1077 static void commentHang(FICL_VM *pVM)
1078 {
1079 vmParseStringEx(pVM, ')', 0);
1080 return;
1081 }
1082
1083
1084 /**************************************************************************
1085 F E T C H & S T O R E
1086 **
1087 **************************************************************************/
1088
1089 static void fetch(FICL_VM *pVM)
1090 {
1091 CELL *pCell;
1092 #if FICL_ROBUST > 1
1093 vmCheckStack(pVM, 1, 1);
1094 #endif
1095 pCell = (CELL *)stackPopPtr(pVM->pStack);
1096 stackPush(pVM->pStack, *pCell);
1097 return;
1098 }
1099
1100 /*
1101 ** two-fetch CORE ( a-addr -- x1 x2 )
1102 ** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
1103 ** x1 at the next consecutive cell. It is equivalent to the sequence
1104 ** DUP CELL+ @ SWAP @ .
1105 */
1106 static void twoFetch(FICL_VM *pVM)
1107 {
1108 CELL *pCell;
1109 #if FICL_ROBUST > 1
1110 vmCheckStack(pVM, 1, 2);
1111 #endif
1112 pCell = (CELL *)stackPopPtr(pVM->pStack);
1113 stackPush(pVM->pStack, *pCell++);
1114 stackPush(pVM->pStack, *pCell);
1115 swap(pVM);
1116 return;
1117 }
1118
1119 /*
1120 ** store CORE ( x a-addr -- )
1121 ** Store x at a-addr.
1122 */
1123 static void store(FICL_VM *pVM)
1124 {
1125 CELL *pCell;
1126 #if FICL_ROBUST > 1
1127 vmCheckStack(pVM, 2, 0);
1128 #endif
1129 pCell = (CELL *)stackPopPtr(pVM->pStack);
1130 *pCell = stackPop(pVM->pStack);
1131 }
1132
1133 /*
1134 ** two-store CORE ( x1 x2 a-addr -- )
1135 ** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
1136 ** next consecutive cell. It is equivalent to the sequence
1137 ** SWAP OVER ! CELL+ ! .
1138 */
1139 static void twoStore(FICL_VM *pVM)
1140 {
1141 CELL *pCell;
1142 #if FICL_ROBUST > 1
1143 vmCheckStack(pVM, 3, 0);
1144 #endif
1145 pCell = (CELL *)stackPopPtr(pVM->pStack);
1146 *pCell++ = stackPop(pVM->pStack);
1147 *pCell = stackPop(pVM->pStack);
1148 }
1149
1150 static void plusStore(FICL_VM *pVM)
1151 {
1152 CELL *pCell;
1153 #if FICL_ROBUST > 1
1154 vmCheckStack(pVM, 2, 0);
1155 #endif
1156 pCell = (CELL *)stackPopPtr(pVM->pStack);
1157 pCell->i += stackPop(pVM->pStack).i;
1158 }
1159
1160
1161 static void quadFetch(FICL_VM *pVM)
1162 {
1163 UNS32 *pw;
1164 #if FICL_ROBUST > 1
1165 vmCheckStack(pVM, 1, 1);
1166 #endif
1167 pw = (UNS32 *)stackPopPtr(pVM->pStack);
1168 PUSHUNS((FICL_UNS)*pw);
1169 return;
1170 }
1171
1172 static void quadStore(FICL_VM *pVM)
1173 {
1174 UNS32 *pw;
1175 #if FICL_ROBUST > 1
1176 vmCheckStack(pVM, 2, 0);
1177 #endif
1178 pw = (UNS32 *)stackPopPtr(pVM->pStack);
1179 *pw = (UNS32)(stackPop(pVM->pStack).u);
1180 }
1181
1182 static void wFetch(FICL_VM *pVM)
1183 {
1184 UNS16 *pw;
1185 #if FICL_ROBUST > 1
1186 vmCheckStack(pVM, 1, 1);
1187 #endif
1188 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1189 PUSHUNS((FICL_UNS)*pw);
1190 return;
1191 }
1192
1193 static void wStore(FICL_VM *pVM)
1194 {
1195 UNS16 *pw;
1196 #if FICL_ROBUST > 1
1197 vmCheckStack(pVM, 2, 0);
1198 #endif
1199 pw = (UNS16 *)stackPopPtr(pVM->pStack);
1200 *pw = (UNS16)(stackPop(pVM->pStack).u);
1201 }
1202
1203 static void cFetch(FICL_VM *pVM)
1204 {
1205 UNS8 *pc;
1206 #if FICL_ROBUST > 1
1207 vmCheckStack(pVM, 1, 1);
1208 #endif
1209 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1210 PUSHUNS((FICL_UNS)*pc);
1211 return;
1212 }
1213
1214 static void cStore(FICL_VM *pVM)
1215 {
1216 UNS8 *pc;
1217 #if FICL_ROBUST > 1
1218 vmCheckStack(pVM, 2, 0);
1219 #endif
1220 pc = (UNS8 *)stackPopPtr(pVM->pStack);
1221 *pc = (UNS8)(stackPop(pVM->pStack).u);
1222 }
1223
1224
1225 /**************************************************************************
1226 i f C o I m
1227 ** IMMEDIATE
1228 ** Compiles code for a conditional branch into the dictionary
1229 ** and pushes the branch patch address on the stack for later
1230 ** patching by ELSE or THEN/ENDIF.
1231 **************************************************************************/
1232
1233 static void ifCoIm(FICL_VM *pVM)
1234 {
1235 FICL_DICT *dp = vmGetDict(pVM);
1236
1237 assert(pVM->pSys->pIfParen);
1238
1239 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
1240 markBranch(dp, pVM, origTag);
1241 dictAppendUNS(dp, 1);
1242 return;
1243 }
1244
1245
1246 /**************************************************************************
1247 i f P a r e n
1248 ** Runtime code to do "if" or "until": pop a flag from the stack,
1249 ** fall through if true, branch if false. Probably ought to be
1250 ** called (not?branch) since it does "branch if false".
1251 **************************************************************************/
1252
1253 static void ifParen(FICL_VM *pVM)
1254 {
1255 FICL_UNS flag;
1256
1257 #if FICL_ROBUST > 1
1258 vmCheckStack(pVM, 1, 0);
1259 #endif
1260 flag = stackPopUNS(pVM->pStack);
1261
1262 if (flag)
1263 { /* fall through */
1264 vmBranchRelative(pVM, 1);
1265 }
1266 else
1267 { /* take branch (to else/endif/begin) */
1268 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1269 }
1270
1271 return;
1272 }
1273
1274
1275 /**************************************************************************
1276 e l s e C o I m
1277 **
1278 ** IMMEDIATE -- compiles an "else"...
1279 ** 1) Compile a branch and a patch address; the address gets patched
1280 ** by "endif" to point past the "else" code.
1281 ** 2) Pop the the "if" patch address
1282 ** 3) Patch the "if" branch to point to the current compile address.
1283 ** 4) Push the "else" patch address. ("endif" patches this to jump past
1284 ** the "else" code.
1285 **************************************************************************/
1286
1287 static void elseCoIm(FICL_VM *pVM)
1288 {
1289 CELL *patchAddr;
1290 FICL_INT offset;
1291 FICL_DICT *dp = vmGetDict(pVM);
1292
1293 assert(pVM->pSys->pBranchParen);
1294 /* (1) compile branch runtime */
1295 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1296 matchControlTag(pVM, origTag);
1297 patchAddr =
1298 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1299 markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
1300 dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
1301 offset = dp->here - patchAddr;
1302 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1303
1304 return;
1305 }
1306
1307
1308 /**************************************************************************
1309 b r a n c h P a r e n
1310 **
1311 ** Runtime for "(branch)" -- expects a literal offset in the next
1312 ** compilation address, and branches to that location.
1313 **************************************************************************/
1314
1315 static void branchParen(FICL_VM *pVM)
1316 {
1317 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1318 return;
1319 }
1320
1321
1322 /**************************************************************************
1323 e n d i f C o I m
1324 **
1325 **************************************************************************/
1326
1327 static void endifCoIm(FICL_VM *pVM)
1328 {
1329 FICL_DICT *dp = vmGetDict(pVM);
1330 resolveForwardBranch(dp, pVM, origTag);
1331 return;
1332 }
1333
1334
1335 /**************************************************************************
1336 h a s h
1337 ** hash ( c-addr u -- code)
1338 ** calculates hashcode of specified string and leaves it on the stack
1339 **************************************************************************/
1340
1341 static void hash(FICL_VM *pVM)
1342 {
1343 STRINGINFO si;
1344 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1345 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1346 PUSHUNS(hashHashCode(si));
1347 return;
1348 }
1349
1350
1351 /**************************************************************************
1352 i n t e r p r e t
1353 ** This is the "user interface" of a Forth. It does the following:
1354 ** while there are words in the VM's Text Input Buffer
1355 ** Copy next word into the pad (vmGetWord)
1356 ** Attempt to find the word in the dictionary (dictLookup)
1357 ** If successful, execute the word.
1358 ** Otherwise, attempt to convert the word to a number (isNumber)
1359 ** If successful, push the number onto the parameter stack.
1360 ** Otherwise, print an error message and exit loop...
1361 ** End Loop
1362 **
1363 ** From the standard, section 3.4
1364 ** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1365 ** repeat the following steps until either the parse area is empty or an
1366 ** ambiguous condition exists:
1367 ** a) Skip leading spaces and parse a name (see 3.4.1);
1368 **************************************************************************/
1369
1370 static void interpret(FICL_VM *pVM)
1371 {
1372 STRINGINFO si;
1373 int i;
1374 FICL_SYSTEM *pSys;
1375
1376 assert(pVM);
1377
1378 pSys = pVM->pSys;
1379 si = vmGetWord0(pVM);
1380
1381 /*
1382 ** Get next word...if out of text, we're done.
1383 */
1384 if (si.count == 0)
1385 {
1386 vmThrow(pVM, VM_OUTOFTEXT);
1387 }
1388
1389 /*
1390 ** Attempt to find the incoming token in the dictionary. If that fails...
1391 ** run the parse chain against the incoming token until somebody eats it.
1392 ** Otherwise emit an error message and give up.
1393 ** Although ficlParseWord could be part of the parse list, I've hard coded it
1394 ** in for robustness. ficlInitSystem adds the other default steps to the list.
1395 */
1396 if (ficlParseWord(pVM, si))
1397 return;
1398
1399 for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1400 {
1401 FICL_WORD *pFW = pSys->parseList[i];
1402
1403 if (pFW == NULL)
1404 break;
1405
1406 if (pFW->code == parseStepParen)
1407 {
1408 FICL_PARSE_STEP pStep;
1409 pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1410 if ((*pStep)(pVM, si))
1411 return;
1412 }
1413 else
1414 {
1415 stackPushPtr(pVM->pStack, SI_PTR(si));
1416 stackPushUNS(pVM->pStack, SI_COUNT(si));
1417 ficlExecXT(pVM, pFW);
1418 if (stackPopINT(pVM->pStack))
1419 return;
1420 }
1421 }
1422
1423 i = SI_COUNT(si);
1424 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1425
1426 return; /* back to inner interpreter */
1427 }
1428
1429
1430 /**************************************************************************
1431 f i c l P a r s e W o r d
1432 ** From the standard, section 3.4
1433 ** b) Search the dictionary name space (see 3.4.2). If a definition name
1434 ** matching the string is found:
1435 ** 1.if interpreting, perform the interpretation semantics of the definition
1436 ** (see 3.4.3.2), and continue at a);
1437 ** 2.if compiling, perform the compilation semantics of the definition
1438 ** (see 3.4.3.3), and continue at a).
1439 **
1440 ** c) If a definition name matching the string is not found, attempt to
1441 ** convert the string to a number (see 3.4.1.3). If successful:
1442 ** 1.if interpreting, place the number on the data stack, and continue at a);
1443 ** 2.if compiling, compile code that when executed will place the number on
1444 ** the stack (see 6.1.1780 LITERAL), and continue at a);
1445 **
1446 ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1447 **
1448 ** (jws 4/01) Modified to be a FICL_PARSE_STEP
1449 **************************************************************************/
1450 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1451 {
1452 FICL_DICT *dp = vmGetDict(pVM);
1453 FICL_WORD *tempFW;
1454
1455 #if FICL_ROBUST
1456 dictCheck(dp, pVM, 0);
1457 vmCheckStack(pVM, 0, 0);
1458 #endif
1459
1460 #if FICL_WANT_LOCALS
1461 if (pVM->pSys->nLocals > 0)
1462 {
1463 tempFW = ficlLookupLoc(pVM->pSys, si);
1464 }
1465 else
1466 #endif
1467 tempFW = dictLookup(dp, si);
1468
1469 if (pVM->state == INTERPRET)
1470 {
1471 if (tempFW != NULL)
1472 {
1473 if (wordIsCompileOnly(tempFW))
1474 {
1475 vmThrowErr(pVM, "Error: Compile only!");
1476 }
1477
1478 vmExecute(pVM, tempFW);
1479 return (int)FICL_TRUE;
1480 }
1481 }
1482
1483 else /* (pVM->state == COMPILE) */
1484 {
1485 if (tempFW != NULL)
1486 {
1487 if (wordIsImmediate(tempFW))
1488 {
1489 vmExecute(pVM, tempFW);
1490 }
1491 else
1492 {
1493 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1494 }
1495 return (int)FICL_TRUE;
1496 }
1497 }
1498
1499 return FICL_FALSE;
1500 }
1501
1502
1503 /*
1504 ** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
1505 ** INTERPRET)
1506 */
1507 static void lookup(FICL_VM *pVM)
1508 {
1509 STRINGINFO si;
1510 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1511 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1512 stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
1513 return;
1514 }
1515
1516
1517 /**************************************************************************
1518 p a r e n P a r s e S t e p
1519 ** (parse-step) ( c-addr u -- flag )
1520 ** runtime for a precompiled parse step - pop a counted string off the
1521 ** stack, run the parse step against it, and push the result flag (FICL_TRUE
1522 ** if success, FICL_FALSE otherwise).
1523 **************************************************************************/
1524
1525 void parseStepParen(FICL_VM *pVM)
1526 {
1527 STRINGINFO si;
1528 FICL_WORD *pFW = pVM->runningWord;
1529 FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1530
1531 SI_SETLEN(si, stackPopINT(pVM->pStack));
1532 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1533
1534 PUSHINT((*pStep)(pVM, si));
1535
1536 return;
1537 }
1538
1539
1540 static void addParseStep(FICL_VM *pVM)
1541 {
1542 FICL_WORD *pStep;
1543 FICL_DICT *pd = vmGetDict(pVM);
1544 #if FICL_ROBUST > 1
1545 vmCheckStack(pVM, 1, 0);
1546 #endif
1547 pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1548 if ((pStep != NULL) && isAFiclWord(pd, pStep))
1549 ficlAddParseStep(pVM->pSys, pStep);
1550 return;
1551 }
1552
1553
1554 /**************************************************************************
1555 l i t e r a l P a r e n
1556 **
1557 ** This is the runtime for (literal). It assumes that it is part of a colon
1558 ** definition, and that the next CELL contains a value to be pushed on the
1559 ** parameter stack at runtime. This code is compiled by "literal".
1560 **
1561 **************************************************************************/
1562
1563 static void literalParen(FICL_VM *pVM)
1564 {
1565 #if FICL_ROBUST > 1
1566 vmCheckStack(pVM, 0, 1);
1567 #endif
1568 PUSHINT(*(FICL_INT *)(pVM->ip));
1569 vmBranchRelative(pVM, 1);
1570 return;
1571 }
1572
1573 static void twoLitParen(FICL_VM *pVM)
1574 {
1575 #if FICL_ROBUST > 1
1576 vmCheckStack(pVM, 0, 2);
1577 #endif
1578 PUSHINT(*((FICL_INT *)(pVM->ip)+1));
1579 PUSHINT(*(FICL_INT *)(pVM->ip));
1580 vmBranchRelative(pVM, 2);
1581 return;
1582 }
1583
1584
1585 /**************************************************************************
1586 l i t e r a l I m
1587 **
1588 ** IMMEDIATE code for "literal". This function gets a value from the stack
1589 ** and compiles it into the dictionary preceded by the code for "(literal)".
1590 ** IMMEDIATE
1591 **************************************************************************/
1592
1593 static void literalIm(FICL_VM *pVM)
1594 {
1595 FICL_DICT *dp = vmGetDict(pVM);
1596 assert(pVM->pSys->pLitParen);
1597
1598 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
1599 dictAppendCell(dp, stackPop(pVM->pStack));
1600
1601 return;
1602 }
1603
1604
1605 static void twoLiteralIm(FICL_VM *pVM)
1606 {
1607 FICL_DICT *dp = vmGetDict(pVM);
1608 assert(pVM->pSys->pTwoLitParen);
1609
1610 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
1611 dictAppendCell(dp, stackPop(pVM->pStack));
1612 dictAppendCell(dp, stackPop(pVM->pStack));
1613
1614 return;
1615 }
1616
1617 /**************************************************************************
1618 l o g i c a n d c o m p a r i s o n s
1619 **
1620 **************************************************************************/
1621
1622 static void zeroEquals(FICL_VM *pVM)
1623 {
1624 CELL c;
1625 #if FICL_ROBUST > 1
1626 vmCheckStack(pVM, 1, 1);
1627 #endif
1628 c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
1629 stackPush(pVM->pStack, c);
1630 return;
1631 }
1632
1633 static void zeroLess(FICL_VM *pVM)
1634 {
1635 CELL c;
1636 #if FICL_ROBUST > 1
1637 vmCheckStack(pVM, 1, 1);
1638 #endif
1639 c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
1640 stackPush(pVM->pStack, c);
1641 return;
1642 }
1643
1644 static void zeroGreater(FICL_VM *pVM)
1645 {
1646 CELL c;
1647 #if FICL_ROBUST > 1
1648 vmCheckStack(pVM, 1, 1);
1649 #endif
1650 c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
1651 stackPush(pVM->pStack, c);
1652 return;
1653 }
1654
1655 static void isEqual(FICL_VM *pVM)
1656 {
1657 CELL x, y;
1658
1659 #if FICL_ROBUST > 1
1660 vmCheckStack(pVM, 2, 1);
1661 #endif
1662 x = stackPop(pVM->pStack);
1663 y = stackPop(pVM->pStack);
1664 PUSHINT(FICL_BOOL(x.i == y.i));
1665 return;
1666 }
1667
1668 static void isLess(FICL_VM *pVM)
1669 {
1670 CELL x, y;
1671 #if FICL_ROBUST > 1
1672 vmCheckStack(pVM, 2, 1);
1673 #endif
1674 y = stackPop(pVM->pStack);
1675 x = stackPop(pVM->pStack);
1676 PUSHINT(FICL_BOOL(x.i < y.i));
1677 return;
1678 }
1679
1680 static void uIsLess(FICL_VM *pVM)
1681 {
1682 FICL_UNS u1, u2;
1683 #if FICL_ROBUST > 1
1684 vmCheckStack(pVM, 2, 1);
1685 #endif
1686 u2 = stackPopUNS(pVM->pStack);
1687 u1 = stackPopUNS(pVM->pStack);
1688 PUSHINT(FICL_BOOL(u1 < u2));
1689 return;
1690 }
1691
1692 static void isGreater(FICL_VM *pVM)
1693 {
1694 CELL x, y;
1695 #if FICL_ROBUST > 1
1696 vmCheckStack(pVM, 2, 1);
1697 #endif
1698 y = stackPop(pVM->pStack);
1699 x = stackPop(pVM->pStack);
1700 PUSHINT(FICL_BOOL(x.i > y.i));
1701 return;
1702 }
1703
1704 static void bitwiseAnd(FICL_VM *pVM)
1705 {
1706 CELL x, y;
1707 #if FICL_ROBUST > 1
1708 vmCheckStack(pVM, 2, 1);
1709 #endif
1710 x = stackPop(pVM->pStack);
1711 y = stackPop(pVM->pStack);
1712 PUSHINT(x.i & y.i);
1713 return;
1714 }
1715
1716 static void bitwiseOr(FICL_VM *pVM)
1717 {
1718 CELL x, y;
1719 #if FICL_ROBUST > 1
1720 vmCheckStack(pVM, 2, 1);
1721 #endif
1722 x = stackPop(pVM->pStack);
1723 y = stackPop(pVM->pStack);
1724 PUSHINT(x.i | y.i);
1725 return;
1726 }
1727
1728 static void bitwiseXor(FICL_VM *pVM)
1729 {
1730 CELL x, y;
1731 #if FICL_ROBUST > 1
1732 vmCheckStack(pVM, 2, 1);
1733 #endif
1734 x = stackPop(pVM->pStack);
1735 y = stackPop(pVM->pStack);
1736 PUSHINT(x.i ^ y.i);
1737 return;
1738 }
1739
1740 static void bitwiseNot(FICL_VM *pVM)
1741 {
1742 CELL x;
1743 #if FICL_ROBUST > 1
1744 vmCheckStack(pVM, 1, 1);
1745 #endif
1746 x = stackPop(pVM->pStack);
1747 PUSHINT(~x.i);
1748 return;
1749 }
1750
1751
1752 /**************************************************************************
1753 D o / L o o p
1754 ** do -- IMMEDIATE COMPILE ONLY
1755 ** Compiles code to initialize a loop: compile (do),
1756 ** allot space to hold the "leave" address, push a branch
1757 ** target address for the loop.
1758 ** (do) -- runtime for "do"
1759 ** pops index and limit from the p stack and moves them
1760 ** to the r stack, then skips to the loop body.
1761 ** loop -- IMMEDIATE COMPILE ONLY
1762 ** +loop
1763 ** Compiles code for the test part of a loop:
1764 ** compile (loop), resolve forward branch from "do", and
1765 ** copy "here" address to the "leave" address allotted by "do"
1766 ** i,j,k -- COMPILE ONLY
1767 ** Runtime: Push loop indices on param stack (i is innermost loop...)
1768 ** Note: each loop has three values on the return stack:
1769 ** ( R: leave limit index )
1770 ** "leave" is the absolute address of the next cell after the loop
1771 ** limit and index are the loop control variables.
1772 ** leave -- COMPILE ONLY
1773 ** Runtime: pop the loop control variables, then pop the
1774 ** "leave" address and jump (absolute) there.
1775 **************************************************************************/
1776
1777 static void doCoIm(FICL_VM *pVM)
1778 {
1779 FICL_DICT *dp = vmGetDict(pVM);
1780
1781 assert(pVM->pSys->pDoParen);
1782
1783 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
1784 /*
1785 ** Allot space for a pointer to the end
1786 ** of the loop - "leave" uses this...
1787 */
1788 markBranch(dp, pVM, leaveTag);
1789 dictAppendUNS(dp, 0);
1790 /*
1791 ** Mark location of head of loop...
1792 */
1793 markBranch(dp, pVM, doTag);
1794
1795 return;
1796 }
1797
1798
1799 static void doParen(FICL_VM *pVM)
1800 {
1801 CELL index, limit;
1802 #if FICL_ROBUST > 1
1803 vmCheckStack(pVM, 2, 0);
1804 #endif
1805 index = stackPop(pVM->pStack);
1806 limit = stackPop(pVM->pStack);
1807
1808 /* copy "leave" target addr to stack */
1809 stackPushPtr(pVM->rStack, *(pVM->ip++));
1810 stackPush(pVM->rStack, limit);
1811 stackPush(pVM->rStack, index);
1812
1813 return;
1814 }
1815
1816
1817 static void qDoCoIm(FICL_VM *pVM)
1818 {
1819 FICL_DICT *dp = vmGetDict(pVM);
1820
1821 assert(pVM->pSys->pQDoParen);
1822
1823 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
1824 /*
1825 ** Allot space for a pointer to the end
1826 ** of the loop - "leave" uses this...
1827 */
1828 markBranch(dp, pVM, leaveTag);
1829 dictAppendUNS(dp, 0);
1830 /*
1831 ** Mark location of head of loop...
1832 */
1833 markBranch(dp, pVM, doTag);
1834
1835 return;
1836 }
1837
1838
1839 static void qDoParen(FICL_VM *pVM)
1840 {
1841 CELL index, limit;
1842 #if FICL_ROBUST > 1
1843 vmCheckStack(pVM, 2, 0);
1844 #endif
1845 index = stackPop(pVM->pStack);
1846 limit = stackPop(pVM->pStack);
1847
1848 /* copy "leave" target addr to stack */
1849 stackPushPtr(pVM->rStack, *(pVM->ip++));
1850
1851 if (limit.u == index.u)
1852 {
1853 vmPopIP(pVM);
1854 }
1855 else
1856 {
1857 stackPush(pVM->rStack, limit);
1858 stackPush(pVM->rStack, index);
1859 }
1860
1861 return;
1862 }
1863
1864
1865 /*
1866 ** Runtime code to break out of a do..loop construct
1867 ** Drop the loop control variables; the branch address
1868 ** past "loop" is next on the return stack.
1869 */
1870 static void leaveCo(FICL_VM *pVM)
1871 {
1872 /* almost unloop */
1873 stackDrop(pVM->rStack, 2);
1874 /* exit */
1875 vmPopIP(pVM);
1876 return;
1877 }
1878
1879
1880 static void unloopCo(FICL_VM *pVM)
1881 {
1882 stackDrop(pVM->rStack, 3);
1883 return;
1884 }
1885
1886
1887 static void loopCoIm(FICL_VM *pVM)
1888 {
1889 FICL_DICT *dp = vmGetDict(pVM);
1890
1891 assert(pVM->pSys->pLoopParen);
1892
1893 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
1894 resolveBackBranch(dp, pVM, doTag);
1895 resolveAbsBranch(dp, pVM, leaveTag);
1896 return;
1897 }
1898
1899
1900 static void plusLoopCoIm(FICL_VM *pVM)
1901 {
1902 FICL_DICT *dp = vmGetDict(pVM);
1903
1904 assert(pVM->pSys->pPLoopParen);
1905
1906 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
1907 resolveBackBranch(dp, pVM, doTag);
1908 resolveAbsBranch(dp, pVM, leaveTag);
1909 return;
1910 }
1911
1912
1913 static void loopParen(FICL_VM *pVM)
1914 {
1915 FICL_INT index = stackGetTop(pVM->rStack).i;
1916 FICL_INT limit = stackFetch(pVM->rStack, 1).i;
1917
1918 index++;
1919
1920 if (index >= limit)
1921 {
1922 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1923 vmBranchRelative(pVM, 1); /* fall through the loop */
1924 }
1925 else
1926 { /* update index, branch to loop head */
1927 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1928 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1929 }
1930
1931 return;
1932 }
1933
1934
1935 static void plusLoopParen(FICL_VM *pVM)
1936 {
1937 FICL_INT index,limit,increment;
1938 int flag;
1939
1940 #if FICL_ROBUST > 1
1941 vmCheckStack(pVM, 1, 0);
1942 #endif
1943
1944 index = stackGetTop(pVM->rStack).i;
1945 limit = stackFetch(pVM->rStack, 1).i;
1946 increment = POP().i;
1947
1948 index += increment;
1949
1950 if (increment < 0)
1951 flag = (index < limit);
1952 else
1953 flag = (index >= limit);
1954
1955 if (flag)
1956 {
1957 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1958 vmBranchRelative(pVM, 1); /* fall through the loop */
1959 }
1960 else
1961 { /* update index, branch to loop head */
1962 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1963 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1964 }
1965
1966 return;
1967 }
1968
1969
1970 static void loopICo(FICL_VM *pVM)
1971 {
1972 CELL index = stackGetTop(pVM->rStack);
1973 stackPush(pVM->pStack, index);
1974
1975 return;
1976 }
1977
1978
1979 static void loopJCo(FICL_VM *pVM)
1980 {
1981 CELL index = stackFetch(pVM->rStack, 3);
1982 stackPush(pVM->pStack, index);
1983
1984 return;
1985 }
1986
1987
1988 static void loopKCo(FICL_VM *pVM)
1989 {
1990 CELL index = stackFetch(pVM->rStack, 6);
1991 stackPush(pVM->pStack, index);
1992
1993 return;
1994 }
1995
1996
1997 /**************************************************************************
1998 r e t u r n s t a c k
1999 **
2000 **************************************************************************/
2001 static void toRStack(FICL_VM *pVM)
2002 {
2003 #if FICL_ROBUST > 1
2004 vmCheckStack(pVM, 1, 0);
2005 #endif
2006
2007 stackPush(pVM->rStack, POP());
2008 }
2009
2010 static void fromRStack(FICL_VM *pVM)
2011 {
2012 #if FICL_ROBUST > 1
2013 vmCheckStack(pVM, 0, 1);
2014 #endif
2015
2016 PUSH(stackPop(pVM->rStack));
2017 }
2018
2019 static void fetchRStack(FICL_VM *pVM)
2020 {
2021 #if FICL_ROBUST > 1
2022 vmCheckStack(pVM, 0, 1);
2023 #endif
2024
2025 PUSH(stackGetTop(pVM->rStack));
2026 }
2027
2028 static void twoToR(FICL_VM *pVM)
2029 {
2030 #if FICL_ROBUST > 1
2031 vmCheckStack(pVM, 2, 0);
2032 #endif
2033 stackRoll(pVM->pStack, 1);
2034 stackPush(pVM->rStack, stackPop(pVM->pStack));
2035 stackPush(pVM->rStack, stackPop(pVM->pStack));
2036 return;
2037 }
2038
2039 static void twoRFrom(FICL_VM *pVM)
2040 {
2041 #if FICL_ROBUST > 1
2042 vmCheckStack(pVM, 0, 2);
2043 #endif
2044 stackPush(pVM->pStack, stackPop(pVM->rStack));
2045 stackPush(pVM->pStack, stackPop(pVM->rStack));
2046 stackRoll(pVM->pStack, 1);
2047 return;
2048 }
2049
2050 static void twoRFetch(FICL_VM *pVM)
2051 {
2052 #if FICL_ROBUST > 1
2053 vmCheckStack(pVM, 0, 2);
2054 #endif
2055 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2056 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2057 return;
2058 }
2059
2060
2061 /**************************************************************************
2062 v a r i a b l e
2063 **
2064 **************************************************************************/
2065
2066 static void variableParen(FICL_VM *pVM)
2067 {
2068 FICL_WORD *fw;
2069 #if FICL_ROBUST > 1
2070 vmCheckStack(pVM, 0, 1);
2071 #endif
2072
2073 fw = pVM->runningWord;
2074 PUSHPTR(fw->param);
2075 }
2076
2077
2078 static void variable(FICL_VM *pVM)
2079 {
2080 FICL_DICT *dp = vmGetDict(pVM);
2081 STRINGINFO si = vmGetWord(pVM);
2082
2083 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2084 dictAllotCells(dp, 1);
2085 return;
2086 }
2087
2088
2089 static void twoVariable(FICL_VM *pVM)
2090 {
2091 FICL_DICT *dp = vmGetDict(pVM);
2092 STRINGINFO si = vmGetWord(pVM);
2093
2094 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2095 dictAllotCells(dp, 2);
2096 return;
2097 }
2098
2099
2100 /**************************************************************************
2101 b a s e & f r i e n d s
2102 **
2103 **************************************************************************/
2104
2105 static void base(FICL_VM *pVM)
2106 {
2107 CELL *pBase;
2108 #if FICL_ROBUST > 1
2109 vmCheckStack(pVM, 0, 1);
2110 #endif
2111
2112 pBase = (CELL *)(&pVM->base);
2113 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2114 return;
2115 }
2116
2117
2118 static void decimal(FICL_VM *pVM)
2119 {
2120 pVM->base = 10;
2121 return;
2122 }
2123
2124
2125 static void hex(FICL_VM *pVM)
2126 {
2127 pVM->base = 16;
2128 return;
2129 }
2130
2131
2132 /**************************************************************************
2133 a l l o t & f r i e n d s
2134 **
2135 **************************************************************************/
2136
2137 static void allot(FICL_VM *pVM)
2138 {
2139 FICL_DICT *dp;
2140 FICL_INT i;
2141 #if FICL_ROBUST > 1
2142 vmCheckStack(pVM, 1, 0);
2143 #endif
2144
2145 dp = vmGetDict(pVM);
2146 i = POPINT();
2147
2148 #if FICL_ROBUST
2149 dictCheck(dp, pVM, i);
2150 #endif
2151
2152 dictAllot(dp, i);
2153 return;
2154 }
2155
2156
2157 static void here(FICL_VM *pVM)
2158 {
2159 FICL_DICT *dp;
2160 #if FICL_ROBUST > 1
2161 vmCheckStack(pVM, 0, 1);
2162 #endif
2163
2164 dp = vmGetDict(pVM);
2165 PUSHPTR(dp->here);
2166 return;
2167 }
2168
2169 static void comma(FICL_VM *pVM)
2170 {
2171 FICL_DICT *dp;
2172 CELL c;
2173 #if FICL_ROBUST > 1
2174 vmCheckStack(pVM, 1, 0);
2175 #endif
2176
2177 dp = vmGetDict(pVM);
2178 c = POP();
2179 dictAppendCell(dp, c);
2180 return;
2181 }
2182
2183 static void cComma(FICL_VM *pVM)
2184 {
2185 FICL_DICT *dp;
2186 char c;
2187 #if FICL_ROBUST > 1
2188 vmCheckStack(pVM, 1, 0);
2189 #endif
2190
2191 dp = vmGetDict(pVM);
2192 c = (char)POPINT();
2193 dictAppendChar(dp, c);
2194 return;
2195 }
2196
2197 static void cells(FICL_VM *pVM)
2198 {
2199 FICL_INT i;
2200 #if FICL_ROBUST > 1
2201 vmCheckStack(pVM, 1, 1);
2202 #endif
2203
2204 i = POPINT();
2205 PUSHINT(i * (FICL_INT)sizeof (CELL));
2206 return;
2207 }
2208
2209 static void cellPlus(FICL_VM *pVM)
2210 {
2211 char *cp;
2212 #if FICL_ROBUST > 1
2213 vmCheckStack(pVM, 1, 1);
2214 #endif
2215
2216 cp = POPPTR();
2217 PUSHPTR(cp + sizeof (CELL));
2218 return;
2219 }
2220
2221
2222
2223 /**************************************************************************
2224 t i c k
2225 ** tick CORE ( "<spaces>name" -- xt )
2226 ** Skip leading space delimiters. Parse name delimited by a space. Find
2227 ** name and return xt, the execution token for name. An ambiguous condition
2228 ** exists if name is not found.
2229 **************************************************************************/
2230 void ficlTick(FICL_VM *pVM)
2231 {
2232 FICL_WORD *pFW = NULL;
2233 STRINGINFO si = vmGetWord(pVM);
2234 #if FICL_ROBUST > 1
2235 vmCheckStack(pVM, 0, 1);
2236 #endif
2237
2238 pFW = dictLookup(vmGetDict(pVM), si);
2239 if (!pFW)
2240 {
2241 int i = SI_COUNT(si);
2242 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2243 }
2244 PUSHPTR(pFW);
2245 return;
2246 }
2247
2248
2249 static void bracketTickCoIm(FICL_VM *pVM)
2250 {
2251 ficlTick(pVM);
2252 literalIm(pVM);
2253
2254 return;
2255 }
2256
2257
2258 /**************************************************************************
2259 p o s t p o n e
2260 ** Lookup the next word in the input stream and compile code to
2261 ** insert it into definitions created by the resulting word
2262 ** (defers compilation, even of immediate words)
2263 **************************************************************************/
2264
2265 static void postponeCoIm(FICL_VM *pVM)
2266 {
2267 FICL_DICT *dp = vmGetDict(pVM);
2268 FICL_WORD *pFW;
2269 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2270 assert(pComma);
2271
2272 ficlTick(pVM);
2273 pFW = stackGetTop(pVM->pStack).p;
2274 if (wordIsImmediate(pFW))
2275 {
2276 dictAppendCell(dp, stackPop(pVM->pStack));
2277 }
2278 else
2279 {
2280 literalIm(pVM);
2281 dictAppendCell(dp, LVALUEtoCELL(pComma));
2282 }
2283
2284 return;
2285 }
2286
2287
2288
2289 /**************************************************************************
2290 e x e c u t e
2291 ** Pop an execution token (pointer to a word) off the stack and
2292 ** run it
2293 **************************************************************************/
2294
2295 static void execute(FICL_VM *pVM)
2296 {
2297 FICL_WORD *pFW;
2298 #if FICL_ROBUST > 1
2299 vmCheckStack(pVM, 1, 0);
2300 #endif
2301
2302 pFW = stackPopPtr(pVM->pStack);
2303 vmExecute(pVM, pFW);
2304
2305 return;
2306 }
2307
2308
2309 /**************************************************************************
2310 i m m e d i a t e
2311 ** Make the most recently compiled word IMMEDIATE -- it executes even
2312 ** in compile state (most often used for control compiling words
2313 ** such as IF, THEN, etc)
2314 **************************************************************************/
2315
2316 static void immediate(FICL_VM *pVM)
2317 {
2318 IGNORE(pVM);
2319 dictSetImmediate(vmGetDict(pVM));
2320 return;
2321 }
2322
2323
2324 static void compileOnly(FICL_VM *pVM)
2325 {
2326 IGNORE(pVM);
2327 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2328 return;
2329 }
2330
2331
2332 static void setObjectFlag(FICL_VM *pVM)
2333 {
2334 IGNORE(pVM);
2335 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2336 return;
2337 }
2338
2339 static void isObject(FICL_VM *pVM)
2340 {
2341 int flag;
2342 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2343
2344 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2345 stackPushINT(pVM->pStack, flag);
2346 return;
2347 }
2348
2349 static void cstringLit(FICL_VM *pVM)
2350 {
2351 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2352
2353 char *cp = sp->text;
2354 cp += sp->count + 1;
2355 cp = alignPtr(cp);
2356 pVM->ip = (IPTYPE)(void *)cp;
2357
2358 stackPushPtr(pVM->pStack, sp);
2359 return;
2360 }
2361
2362
2363 static void cstringQuoteIm(FICL_VM *pVM)
2364 {
2365 FICL_DICT *dp = vmGetDict(pVM);
2366
2367 if (pVM->state == INTERPRET)
2368 {
2369 FICL_STRING *sp = (FICL_STRING *) dp->here;
2370 vmGetString(pVM, sp, '\"');
2371 stackPushPtr(pVM->pStack, sp);
2372 /* move HERE past string so it doesn't get overwritten. --lch */
2373 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2374 }
2375 else /* COMPILE state */
2376 {
2377 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2378 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2379 dictAlign(dp);
2380 }
2381
2382 return;
2383 }
2384
2385 /**************************************************************************
2386 d o t Q u o t e
2387 ** IMMEDIATE word that compiles a string literal for later display
2388 ** Compile stringLit, then copy the bytes of the string from the TIB
2389 ** to the dictionary. Backpatch the count byte and align the dictionary.
2390 **
2391 ** stringlit: Fetch the count from the dictionary, then push the address
2392 ** and count on the stack. Finally, update ip to point to the first
2393 ** aligned address after the string text.
2394 **************************************************************************/
2395
2396 static void stringLit(FICL_VM *pVM)
2397 {
2398 FICL_STRING *sp;
2399 FICL_COUNT count;
2400 char *cp;
2401 #if FICL_ROBUST > 1
2402 vmCheckStack(pVM, 0, 2);
2403 #endif
2404
2405 sp = (FICL_STRING *)(pVM->ip);
2406 count = sp->count;
2407 cp = sp->text;
2408 PUSHPTR(cp);
2409 PUSHUNS(count);
2410 cp += count + 1;
2411 cp = alignPtr(cp);
2412 pVM->ip = (IPTYPE)(void *)cp;
2413 }
2414
2415 static void dotQuoteCoIm(FICL_VM *pVM)
2416 {
2417 FICL_DICT *dp = vmGetDict(pVM);
2418 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2419 assert(pType);
2420 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2421 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2422 dictAlign(dp);
2423 dictAppendCell(dp, LVALUEtoCELL(pType));
2424 return;
2425 }
2426
2427
2428 static void dotParen(FICL_VM *pVM)
2429 {
2430 char *pSrc = vmGetInBuf(pVM);
2431 char *pEnd = vmGetInBufEnd(pVM);
2432 char *pDest = pVM->pad;
2433 char ch;
2434
2435 /*
2436 ** Note: the standard does not want leading spaces skipped (apparently)
2437 */
2438 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2439 *pDest++ = ch;
2440
2441 *pDest = '\0';
2442 if ((pEnd != pSrc) && (ch == ')'))
2443 pSrc++;
2444
2445 vmTextOut(pVM, pVM->pad, 0);
2446 vmUpdateTib(pVM, pSrc);
2447
2448 return;
2449 }
2450
2451
2452 /**************************************************************************
2453 s l i t e r a l
2454 ** STRING
2455 ** Interpretation: Interpretation semantics for this word are undefined.
2456 ** Compilation: ( c-addr1 u -- )
2457 ** Append the run-time semantics given below to the current definition.
2458 ** Run-time: ( -- c-addr2 u )
2459 ** Return c-addr2 u describing a string consisting of the characters
2460 ** specified by c-addr1 u during compilation. A program shall not alter
2461 ** the returned string.
2462 **************************************************************************/
2463 static void sLiteralCoIm(FICL_VM *pVM)
2464 {
2465 FICL_DICT *dp;
2466 char *cp, *cpDest;
2467 FICL_UNS u;
2468
2469 #if FICL_ROBUST > 1
2470 vmCheckStack(pVM, 2, 0);
2471 #endif
2472
2473 dp = vmGetDict(pVM);
2474 u = POPUNS();
2475 cp = POPPTR();
2476
2477 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2478 cpDest = (char *) dp->here;
2479 *cpDest++ = (char) u;
2480
2481 for (; u > 0; --u)
2482 {
2483 *cpDest++ = *cp++;
2484 }
2485
2486 *cpDest++ = 0;
2487 dp->here = PTRtoCELL alignPtr(cpDest);
2488 return;
2489 }
2490
2491
2492 /**************************************************************************
2493 s t a t e
2494 ** Return the address of the VM's state member (must be sized the
2495 ** same as a CELL for this reason)
2496 **************************************************************************/
2497 static void state(FICL_VM *pVM)
2498 {
2499 #if FICL_ROBUST > 1
2500 vmCheckStack(pVM, 0, 1);
2501 #endif
2502 PUSHPTR(&pVM->state);
2503 return;
2504 }
2505
2506
2507 /**************************************************************************
2508 c r e a t e . . . d o e s >
2509 ** Make a new word in the dictionary with the run-time effect of
2510 ** a variable (push my address), but with extra space allotted
2511 ** for use by does> .
2512 **************************************************************************/
2513
2514 static void createParen(FICL_VM *pVM)
2515 {
2516 CELL *pCell;
2517
2518 #if FICL_ROBUST > 1
2519 vmCheckStack(pVM, 0, 1);
2520 #endif
2521
2522 pCell = pVM->runningWord->param;
2523 PUSHPTR(pCell+1);
2524 return;
2525 }
2526
2527
2528 static void create(FICL_VM *pVM)
2529 {
2530 FICL_DICT *dp = vmGetDict(pVM);
2531 STRINGINFO si = vmGetWord(pVM);
2532
2533 dictCheckThreshold(dp);
2534
2535 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2536 dictAllotCells(dp, 1);
2537 return;
2538 }
2539
2540
2541 static void doDoes(FICL_VM *pVM)
2542 {
2543 CELL *pCell;
2544 IPTYPE tempIP;
2545 #if FICL_ROBUST > 1
2546 vmCheckStack(pVM, 0, 1);
2547 #endif
2548
2549 pCell = pVM->runningWord->param;
2550 tempIP = (IPTYPE)((*pCell).p);
2551 PUSHPTR(pCell+1);
2552 vmPushIP(pVM, tempIP);
2553 return;
2554 }
2555
2556
2557 static void doesParen(FICL_VM *pVM)
2558 {
2559 FICL_DICT *dp = vmGetDict(pVM);
2560 dp->smudge->code = doDoes;
2561 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2562 vmPopIP(pVM);
2563 return;
2564 }
2565
2566
2567 static void doesCoIm(FICL_VM *pVM)
2568 {
2569 FICL_DICT *dp = vmGetDict(pVM);
2570 #if FICL_WANT_LOCALS
2571 assert(pVM->pSys->pUnLinkParen);
2572 if (pVM->pSys->nLocals > 0)
2573 {
2574 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2575 dictEmpty(pLoc, pLoc->pForthWords->size);
2576 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2577 }
2578
2579 pVM->pSys->nLocals = 0;
2580 #endif
2581 IGNORE(pVM);
2582
2583 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2584 return;
2585 }
2586
2587
2588 /**************************************************************************
2589 t o b o d y
2590 ** to-body CORE ( xt -- a-addr )
2591 ** a-addr is the data-field address corresponding to xt. An ambiguous
2592 ** condition exists if xt is not for a word defined via CREATE.
2593 **************************************************************************/
2594 static void toBody(FICL_VM *pVM)
2595 {
2596 FICL_WORD *pFW;
2597 /*#$-GUY CHANGE: Added robustness.-$#*/
2598 #if FICL_ROBUST > 1
2599 vmCheckStack(pVM, 1, 1);
2600 #endif
2601
2602 pFW = POPPTR();
2603 PUSHPTR(pFW->param + 1);
2604 return;
2605 }
2606
2607
2608 /*
2609 ** from-body ficl ( a-addr -- xt )
2610 ** Reverse effect of >body
2611 */
2612 static void fromBody(FICL_VM *pVM)
2613 {
2614 char *ptr;
2615 #if FICL_ROBUST > 1
2616 vmCheckStack(pVM, 1, 1);
2617 #endif
2618
2619 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2620 PUSHPTR(ptr);
2621 return;
2622 }
2623
2624
2625 /*
2626 ** >name ficl ( xt -- c-addr u )
2627 ** Push the address and length of a word's name given its address
2628 ** xt.
2629 */
2630 static void toName(FICL_VM *pVM)
2631 {
2632 FICL_WORD *pFW;
2633 #if FICL_ROBUST > 1
2634 vmCheckStack(pVM, 1, 2);
2635 #endif
2636
2637 pFW = POPPTR();
2638 PUSHPTR(pFW->name);
2639 PUSHUNS(pFW->nName);
2640 return;
2641 }
2642
2643
2644 static void getLastWord(FICL_VM *pVM)
2645 {
2646 FICL_DICT *pDict = vmGetDict(pVM);
2647 FICL_WORD *wp = pDict->smudge;
2648 assert(wp);
2649 vmPush(pVM, LVALUEtoCELL(wp));
2650 return;
2651 }
2652
2653
2654 /**************************************************************************
2655 l b r a c k e t e t c
2656 **
2657 **************************************************************************/
2658
2659 static void lbracketCoIm(FICL_VM *pVM)
2660 {
2661 pVM->state = INTERPRET;
2662 return;
2663 }
2664
2665
2666 static void rbracket(FICL_VM *pVM)
2667 {
2668 pVM->state = COMPILE;
2669 return;
2670 }
2671
2672
2673 /**************************************************************************
2674 p i c t u r e d n u m e r i c w o r d s
2675 **
2676 ** less-number-sign CORE ( -- )
2677 ** Initialize the pictured numeric output conversion process.
2678 ** (clear the pad)
2679 **************************************************************************/
2680 static void lessNumberSign(FICL_VM *pVM)
2681 {
2682 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2683 sp->count = 0;
2684 return;
2685 }
2686
2687 /*
2688 ** number-sign CORE ( ud1 -- ud2 )
2689 ** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2690 ** n. (n is the least-significant digit of ud1.) Convert n to external form
2691 ** and add the resulting character to the beginning of the pictured numeric
2692 ** output string. An ambiguous condition exists if # executes outside of a
2693 ** <# #> delimited number conversion.
2694 */
2695 static void numberSign(FICL_VM *pVM)
2696 {
2697 FICL_STRING *sp;
2698 DPUNS u;
2699 UNS16 rem;
2700 #if FICL_ROBUST > 1
2701 vmCheckStack(pVM, 2, 2);
2702 #endif
2703
2704 sp = PTRtoSTRING pVM->pad;
2705 u = u64Pop(pVM->pStack);
2706 rem = m64UMod(&u, (UNS16)(pVM->base));
2707 sp->text[sp->count++] = digit_to_char(rem);
2708 u64Push(pVM->pStack, u);
2709 return;
2710 }
2711
2712 /*
2713 ** number-sign-greater CORE ( xd -- c-addr u )
2714 ** Drop xd. Make the pictured numeric output string available as a character
2715 ** string. c-addr and u specify the resulting character string. A program
2716 ** may replace characters within the string.
2717 */
2718 static void numberSignGreater(FICL_VM *pVM)
2719 {
2720 FICL_STRING *sp;
2721 #if FICL_ROBUST > 1
2722 vmCheckStack(pVM, 2, 2);
2723 #endif
2724
2725 sp = PTRtoSTRING pVM->pad;
2726 sp->text[sp->count] = 0;
2727 strrev(sp->text);
2728 DROP(2);
2729 PUSHPTR(sp->text);
2730 PUSHUNS(sp->count);
2731 return;
2732 }
2733
2734 /*
2735 ** number-sign-s CORE ( ud1 -- ud2 )
2736 ** Convert one digit of ud1 according to the rule for #. Continue conversion
2737 ** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2738 ** #S executes outside of a <# #> delimited number conversion.
2739 ** TO DO: presently does not use ud1 hi cell - use it!
2740 */
2741 static void numberSignS(FICL_VM *pVM)
2742 {
2743 FICL_STRING *sp;
2744 DPUNS u;
2745 UNS16 rem;
2746 #if FICL_ROBUST > 1
2747 vmCheckStack(pVM, 2, 2);
2748 #endif
2749
2750 sp = PTRtoSTRING pVM->pad;
2751 u = u64Pop(pVM->pStack);
2752
2753 do
2754 {
2755 rem = m64UMod(&u, (UNS16)(pVM->base));
2756 sp->text[sp->count++] = digit_to_char(rem);
2757 }
2758 while (u.hi || u.lo);
2759
2760 u64Push(pVM->pStack, u);
2761 return;
2762 }
2763
2764 /*
2765 ** HOLD CORE ( char -- )
2766 ** Add char to the beginning of the pictured numeric output string. An ambiguous
2767 ** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2768 */
2769 static void hold(FICL_VM *pVM)
2770 {
2771 FICL_STRING *sp;
2772 int i;
2773 #if FICL_ROBUST > 1
2774 vmCheckStack(pVM, 1, 0);
2775 #endif
2776
2777 sp = PTRtoSTRING pVM->pad;
2778 i = POPINT();
2779 sp->text[sp->count++] = (char) i;
2780 return;
2781 }
2782
2783 /*
2784 ** SIGN CORE ( n -- )
2785 ** If n is negative, add a minus sign to the beginning of the pictured
2786 ** numeric output string. An ambiguous condition exists if SIGN
2787 ** executes outside of a <# #> delimited number conversion.
2788 */
2789 static void sign(FICL_VM *pVM)
2790 {
2791 FICL_STRING *sp;
2792 int i;
2793 #if FICL_ROBUST > 1
2794 vmCheckStack(pVM, 1, 0);
2795 #endif
2796
2797 sp = PTRtoSTRING pVM->pad;
2798 i = POPINT();
2799 if (i < 0)
2800 sp->text[sp->count++] = '-';
2801 return;
2802 }
2803
2804
2805 /**************************************************************************
2806 t o N u m b e r
2807 ** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2808 ** ud2 is the unsigned result of converting the characters within the
2809 ** string specified by c-addr1 u1 into digits, using the number in BASE,
2810 ** and adding each into ud1 after multiplying ud1 by the number in BASE.
2811 ** Conversion continues left-to-right until a character that is not
2812 ** convertible, including any + or -, is encountered or the string is
2813 ** entirely converted. c-addr2 is the location of the first unconverted
2814 ** character or the first character past the end of the string if the string
2815 ** was entirely converted. u2 is the number of unconverted characters in the
2816 ** string. An ambiguous condition exists if ud2 overflows during the
2817 ** conversion.
2818 **************************************************************************/
2819 static void toNumber(FICL_VM *pVM)
2820 {
2821 FICL_UNS count;
2822 char *cp;
2823 DPUNS accum;
2824 FICL_UNS base = pVM->base;
2825 FICL_UNS ch;
2826 FICL_UNS digit;
2827
2828 #if FICL_ROBUST > 1
2829 vmCheckStack(pVM,4,4);
2830 #endif
2831
2832 count = POPUNS();
2833 cp = (char *)POPPTR();
2834 accum = u64Pop(pVM->pStack);
2835
2836 for (ch = *cp; count > 0; ch = *++cp, count--)
2837 {
2838 if (ch < '0')
2839 break;
2840
2841 digit = ch - '0';
2842
2843 if (digit > 9)
2844 digit = tolower(ch) - 'a' + 10;
2845 /*
2846 ** Note: following test also catches chars between 9 and a
2847 ** because 'digit' is unsigned!
2848 */
2849 if (digit >= base)
2850 break;
2851
2852 accum = m64Mac(accum, base, digit);
2853 }
2854
2855 u64Push(pVM->pStack, accum);
2856 PUSHPTR(cp);
2857 PUSHUNS(count);
2858
2859 return;
2860 }
2861
2862
2863
2864 /**************************************************************************
2865 q u i t & a b o r t
2866 ** quit CORE ( -- ) ( R: i*x -- )
2867 ** Empty the return stack, store zero in SOURCE-ID if it is present, make
2868 ** the user input device the input source, and enter interpretation state.
2869 ** Do not display a message. Repeat the following:
2870 **
2871 ** Accept a line from the input source into the input buffer, set >IN to
2872 ** zero, and interpret.
2873 ** Display the implementation-defined system prompt if in
2874 ** interpretation state, all processing has been completed, and no
2875 ** ambiguous condition exists.
2876 **************************************************************************/
2877
2878 static void quit(FICL_VM *pVM)
2879 {
2880 vmThrow(pVM, VM_QUIT);
2881 return;
2882 }
2883
2884
2885 static void ficlAbort(FICL_VM *pVM)
2886 {
2887 vmThrow(pVM, VM_ABORT);
2888 return;
2889 }
2890
2891
2892 /**************************************************************************
2893 a c c e p t
2894 ** accept CORE ( c-addr +n1 -- +n2 )
2895 ** Receive a string of at most +n1 characters. An ambiguous condition
2896 ** exists if +n1 is zero or greater than 32,767. Display graphic characters
2897 ** as they are received. A program that depends on the presence or absence
2898 ** of non-graphic characters in the string has an environmental dependency.
2899 ** The editing functions, if any, that the system performs in order to
2900 ** construct the string are implementation-defined.
2901 **
2902 ** (Although the standard text doesn't say so, I assume that the intent
2903 ** of 'accept' is to store the string at the address specified on
2904 ** the stack.)
2905 ** Implementation: if there's more text in the TIB, use it. Otherwise
2906 ** throw out for more text. Copy characters up to the max count into the
2907 ** address given, and return the number of actual characters copied.
2908 **
2909 ** Note (sobral) this may not be the behavior you'd expect if you're
2910 ** trying to get user input at load time!
2911 **************************************************************************/
2912 static void accept(FICL_VM *pVM)
2913 {
2914 FICL_UNS count, len;
2915 char *cp;
2916 char *pBuf, *pEnd;
2917
2918 #if FICL_ROBUST > 1
2919 vmCheckStack(pVM,2,1);
2920 #endif
2921
2922 pBuf = vmGetInBuf(pVM);
2923 pEnd = vmGetInBufEnd(pVM);
2924 len = pEnd - pBuf;
2925 if (len == 0)
2926 vmThrow(pVM, VM_RESTART);
2927
2928 /*
2929 ** Now we have something in the text buffer - use it
2930 */
2931 count = stackPopINT(pVM->pStack);
2932 cp = stackPopPtr(pVM->pStack);
2933
2934 len = (count < len) ? count : len;
2935 strncpy(cp, vmGetInBuf(pVM), len);
2936 pBuf += len;
2937 vmUpdateTib(pVM, pBuf);
2938 PUSHINT(len);
2939
2940 return;
2941 }
2942
2943
2944 /**************************************************************************
2945 a l i g n
2946 ** 6.1.0705 ALIGN CORE ( -- )
2947 ** If the data-space pointer is not aligned, reserve enough space to
2948 ** align it.
2949 **************************************************************************/
2950 static void align(FICL_VM *pVM)
2951 {
2952 FICL_DICT *dp = vmGetDict(pVM);
2953 IGNORE(pVM);
2954 dictAlign(dp);
2955 return;
2956 }
2957
2958
2959 /**************************************************************************
2960 a l i g n e d
2961 **
2962 **************************************************************************/
2963 static void aligned(FICL_VM *pVM)
2964 {
2965 void *addr;
2966 #if FICL_ROBUST > 1
2967 vmCheckStack(pVM,1,1);
2968 #endif
2969
2970 addr = POPPTR();
2971 PUSHPTR(alignPtr(addr));
2972 return;
2973 }
2974
2975
2976 /**************************************************************************
2977 b e g i n & f r i e n d s
2978 ** Indefinite loop control structures
2979 ** A.6.1.0760 BEGIN
2980 ** Typical use:
2981 ** : X ... BEGIN ... test UNTIL ;
2982 ** or
2983 ** : X ... BEGIN ... test WHILE ... REPEAT ;
2984 **************************************************************************/
2985 static void beginCoIm(FICL_VM *pVM)
2986 {
2987 FICL_DICT *dp = vmGetDict(pVM);
2988 markBranch(dp, pVM, destTag);
2989 return;
2990 }
2991
2992 static void untilCoIm(FICL_VM *pVM)
2993 {
2994 FICL_DICT *dp = vmGetDict(pVM);
2995
2996 assert(pVM->pSys->pIfParen);
2997
2998 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
2999 resolveBackBranch(dp, pVM, destTag);
3000 return;
3001 }
3002
3003 static void whileCoIm(FICL_VM *pVM)
3004 {
3005 FICL_DICT *dp = vmGetDict(pVM);
3006
3007 assert(pVM->pSys->pIfParen);
3008
3009 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
3010 markBranch(dp, pVM, origTag);
3011 twoSwap(pVM);
3012 dictAppendUNS(dp, 1);
3013 return;
3014 }
3015
3016 static void repeatCoIm(FICL_VM *pVM)
3017 {
3018 FICL_DICT *dp = vmGetDict(pVM);
3019
3020 assert(pVM->pSys->pBranchParen);
3021 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3022
3023 /* expect "begin" branch marker */
3024 resolveBackBranch(dp, pVM, destTag);
3025 /* expect "while" branch marker */
3026 resolveForwardBranch(dp, pVM, origTag);
3027 return;
3028 }
3029
3030
3031 static void againCoIm(FICL_VM *pVM)
3032 {
3033 FICL_DICT *dp = vmGetDict(pVM);
3034
3035 assert(pVM->pSys->pBranchParen);
3036 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3037
3038 /* expect "begin" branch marker */
3039 resolveBackBranch(dp, pVM, destTag);
3040 return;
3041 }
3042
3043
3044 /**************************************************************************
3045 c h a r & f r i e n d s
3046 ** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
3047 ** Skip leading space delimiters. Parse name delimited by a space.
3048 ** Put the value of its first character onto the stack.
3049 **
3050 ** bracket-char CORE
3051 ** Interpretation: Interpretation semantics for this word are undefined.
3052 ** Compilation: ( "<spaces>name" -- )
3053 ** Skip leading space delimiters. Parse name delimited by a space.
3054 ** Append the run-time semantics given below to the current definition.
3055 ** Run-time: ( -- char )
3056 ** Place char, the value of the first character of name, on the stack.
3057 **************************************************************************/
3058 static void ficlChar(FICL_VM *pVM)
3059 {
3060 STRINGINFO si;
3061 #if FICL_ROBUST > 1
3062 vmCheckStack(pVM,0,1);
3063 #endif
3064
3065 si = vmGetWord(pVM);
3066 PUSHUNS((FICL_UNS)(si.cp[0]));
3067 return;
3068 }
3069
3070 static void charCoIm(FICL_VM *pVM)
3071 {
3072 ficlChar(pVM);
3073 literalIm(pVM);
3074 return;
3075 }
3076
3077 /**************************************************************************
3078 c h a r P l u s
3079 ** char-plus CORE ( c-addr1 -- c-addr2 )
3080 ** Add the size in address units of a character to c-addr1, giving c-addr2.
3081 **************************************************************************/
3082 static void charPlus(FICL_VM *pVM)
3083 {
3084 char *cp;
3085 #if FICL_ROBUST > 1
3086 vmCheckStack(pVM,1,1);
3087 #endif
3088
3089 cp = POPPTR();
3090 PUSHPTR(cp + 1);
3091 return;
3092 }
3093
3094 /**************************************************************************
3095 c h a r s
3096 ** chars CORE ( n1 -- n2 )
3097 ** n2 is the size in address units of n1 characters.
3098 ** For most processors, this function can be a no-op. To guarantee
3099 ** portability, we'll multiply by sizeof (char).
3100 **************************************************************************/
3101 #if defined (_M_IX86)
3102 #pragma warning(disable: 4127)
3103 #endif
3104 static void ficlChars(FICL_VM *pVM)
3105 {
3106 if (sizeof (char) > 1)
3107 {
3108 FICL_INT i;
3109 #if FICL_ROBUST > 1
3110 vmCheckStack(pVM,1,1);
3111 #endif
3112 i = POPINT();
3113 PUSHINT(i * sizeof (char));
3114 }
3115 /* otherwise no-op! */
3116 return;
3117 }
3118 #if defined (_M_IX86)
3119 #pragma warning(default: 4127)
3120 #endif
3121
3122
3123 /**************************************************************************
3124 c o u n t
3125 ** COUNT CORE ( c-addr1 -- c-addr2 u )
3126 ** Return the character string specification for the counted string stored
3127 ** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3128 ** u is the contents of the character at c-addr1, which is the length in
3129 ** characters of the string at c-addr2.
3130 **************************************************************************/
3131 static void count(FICL_VM *pVM)
3132 {
3133 FICL_STRING *sp;
3134 #if FICL_ROBUST > 1
3135 vmCheckStack(pVM,1,2);
3136 #endif
3137
3138 sp = POPPTR();
3139 PUSHPTR(sp->text);
3140 PUSHUNS(sp->count);
3141 return;
3142 }
3143
3144 /**************************************************************************
3145 e n v i r o n m e n t ?
3146 ** environment-query CORE ( c-addr u -- false | i*x true )
3147 ** c-addr is the address of a character string and u is the string's
3148 ** character count. u may have a value in the range from zero to an
3149 ** implementation-defined maximum which shall not be less than 31. The
3150 ** character string should contain a keyword from 3.2.6 Environmental
3151 ** queries or the optional word sets to be checked for correspondence
3152 ** with an attribute of the present environment. If the system treats the
3153 ** attribute as unknown, the returned flag is false; otherwise, the flag
3154 ** is true and the i*x returned is of the type specified in the table for
3155 ** the attribute queried.
3156 **************************************************************************/
3157 static void environmentQ(FICL_VM *pVM)
3158 {
3159 FICL_DICT *envp;
3160 FICL_WORD *pFW;
3161 STRINGINFO si;
3162 #if FICL_ROBUST > 1
3163 vmCheckStack(pVM,2,1);
3164 #endif
3165
3166 envp = pVM->pSys->envp;
3167 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3168 si.cp = stackPopPtr(pVM->pStack);
3169
3170 pFW = dictLookup(envp, si);
3171
3172 if (pFW != NULL)
3173 {
3174 vmExecute(pVM, pFW);
3175 PUSHINT(FICL_TRUE);
3176 }
3177 else
3178 {
3179 PUSHINT(FICL_FALSE);
3180 }
3181 return;
3182 }
3183
3184 /**************************************************************************
3185 e v a l u a t e
3186 ** EVALUATE CORE ( i*x c-addr u -- j*x )
3187 ** Save the current input source specification. Store minus-one (-1) in
3188 ** SOURCE-ID if it is present. Make the string described by c-addr and u
3189 ** both the input source and input buffer, set >IN to zero, and interpret.
3190 ** When the parse area is empty, restore the prior input source
3191 ** specification. Other stack effects are due to the words EVALUATEd.
3192 **
3193 **************************************************************************/
3194 static void evaluate(FICL_VM *pVM)
3195 {
3196 FICL_UNS count;
3197 char *cp;
3198 CELL id;
3199 int result;
3200 #if FICL_ROBUST > 1
3201 vmCheckStack(pVM,2,0);
3202 #endif
3203
3204 count = POPUNS();
3205 cp = POPPTR();
3206
3207 IGNORE(count);
3208 id = pVM->sourceID;
3209 pVM->sourceID.i = -1;
3210 result = ficlExecC(pVM, cp, count);
3211 pVM->sourceID = id;
3212 if (result != VM_OUTOFTEXT)
3213 vmThrow(pVM, result);
3214
3215 return;
3216 }
3217
3218
3219 /**************************************************************************
3220 s t r i n g q u o t e
3221 ** Interpreting: get string delimited by a quote from the input stream,
3222 ** copy to a scratch area, and put its count and address on the stack.
3223 ** Compiling: compile code to push the address and count of a string
3224 ** literal, compile the string from the input stream, and align the dict
3225 ** pointer.
3226 **************************************************************************/
3227 static void stringQuoteIm(FICL_VM *pVM)
3228 {
3229 FICL_DICT *dp = vmGetDict(pVM);
3230
3231 if (pVM->state == INTERPRET)
3232 {
3233 FICL_STRING *sp = (FICL_STRING *) dp->here;
3234 vmGetString(pVM, sp, '\"');
3235 PUSHPTR(sp->text);
3236 PUSHUNS(sp->count);
3237 }
3238 else /* COMPILE state */
3239 {
3240 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3241 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3242 dictAlign(dp);
3243 }
3244
3245 return;
3246 }
3247
3248
3249 /**************************************************************************
3250 t y p e
3251 ** Pop count and char address from stack and print the designated string.
3252 **************************************************************************/
3253 static void type(FICL_VM *pVM)
3254 {
3255 FICL_UNS count = stackPopUNS(pVM->pStack);
3256 char *cp = stackPopPtr(pVM->pStack);
3257 char *pDest = (char *)ficlMalloc(count + 1);
3258
3259 /*
3260 ** Since we don't have an output primitive for a counted string
3261 ** (oops), make sure the string is null terminated. If not, copy
3262 ** and terminate it.
3263 */
3264 if (!pDest)
3265 vmThrowErr(pVM, "Error: out of memory");
3266
3267 strncpy(pDest, cp, count);
3268 pDest[count] = '\0';
3269
3270 vmTextOut(pVM, pDest, 0);
3271
3272 ficlFree(pDest);
3273 return;
3274 }
3275
3276 /**************************************************************************
3277 w o r d
3278 ** word CORE ( char "<chars>ccc<char>" -- c-addr )
3279 ** Skip leading delimiters. Parse characters ccc delimited by char. An
3280 ** ambiguous condition exists if the length of the parsed string is greater
3281 ** than the implementation-defined length of a counted string.
3282 **
3283 ** c-addr is the address of a transient region containing the parsed word
3284 ** as a counted string. If the parse area was empty or contained no
3285 ** characters other than the delimiter, the resulting string has a zero
3286 ** length. A space, not included in the length, follows the string. A
3287 ** program may replace characters within the string.
3288 ** NOTE! Ficl also NULL-terminates the dest string.
3289 **************************************************************************/
3290 static void ficlWord(FICL_VM *pVM)
3291 {
3292 FICL_STRING *sp;
3293 char delim;
3294 STRINGINFO si;
3295 #if FICL_ROBUST > 1
3296 vmCheckStack(pVM,1,1);
3297 #endif
3298
3299 sp = (FICL_STRING *)pVM->pad;
3300 delim = (char)POPINT();
3301 si = vmParseStringEx(pVM, delim, 1);
3302
3303 if (SI_COUNT(si) > nPAD-1)
3304 SI_SETLEN(si, nPAD-1);
3305
3306 sp->count = (FICL_COUNT)SI_COUNT(si);
3307 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3308 /*#$-GUY CHANGE: I added this.-$#*/
3309 sp->text[sp->count] = 0;
3310 strcat(sp->text, " ");
3311
3312 PUSHPTR(sp);
3313 return;
3314 }
3315
3316
3317 /**************************************************************************
3318 p a r s e - w o r d
3319 ** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3320 ** Skip leading spaces and parse name delimited by a space. c-addr is the
3321 ** address within the input buffer and u is the length of the selected
3322 ** string. If the parse area is empty, the resulting string has a zero length.
3323 **************************************************************************/
3324 static void parseNoCopy(FICL_VM *pVM)
3325 {
3326 STRINGINFO si;
3327 #if FICL_ROBUST > 1
3328 vmCheckStack(pVM,0,2);
3329 #endif
3330
3331 si = vmGetWord0(pVM);
3332 PUSHPTR(SI_PTR(si));
3333 PUSHUNS(SI_COUNT(si));
3334 return;
3335 }
3336
3337
3338 /**************************************************************************
3339 p a r s e
3340 ** CORE EXT ( char "ccc<char>" -- c-addr u )
3341 ** Parse ccc delimited by the delimiter char.
3342 ** c-addr is the address (within the input buffer) and u is the length of
3343 ** the parsed string. If the parse area was empty, the resulting string has
3344 ** a zero length.
3345 ** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3346 **************************************************************************/
3347 static void parse(FICL_VM *pVM)
3348 {
3349 STRINGINFO si;
3350 char delim;
3351
3352 #if FICL_ROBUST > 1
3353 vmCheckStack(pVM,1,2);
3354 #endif
3355
3356 delim = (char)POPINT();
3357
3358 si = vmParseStringEx(pVM, delim, 0);
3359 PUSHPTR(SI_PTR(si));
3360 PUSHUNS(SI_COUNT(si));
3361 return;
3362 }
3363
3364
3365 /**************************************************************************
3366 f i l l
3367 ** CORE ( c-addr u char -- )
3368 ** If u is greater than zero, store char in each of u consecutive
3369 ** characters of memory beginning at c-addr.
3370 **************************************************************************/
3371 static void fill(FICL_VM *pVM)
3372 {
3373 char ch;
3374 FICL_UNS u;
3375 char *cp;
3376 #if FICL_ROBUST > 1
3377 vmCheckStack(pVM,3,0);
3378 #endif
3379 ch = (char)POPINT();
3380 u = POPUNS();
3381 cp = (char *)POPPTR();
3382
3383 while (u > 0)
3384 {
3385 *cp++ = ch;
3386 u--;
3387 }
3388 return;
3389 }
3390
3391
3392 /**************************************************************************
3393 f i n d
3394 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3395 ** Find the definition named in the counted string at c-addr. If the
3396 ** definition is not found, return c-addr and zero. If the definition is
3397 ** found, return its execution token xt. If the definition is immediate,
3398 ** also return one (1), otherwise also return minus-one (-1). For a given
3399 ** string, the values returned by FIND while compiling may differ from
3400 ** those returned while not compiling.
3401 **************************************************************************/
3402 static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3403 {
3404 FICL_WORD *pFW;
3405
3406 pFW = dictLookup(vmGetDict(pVM), si);
3407 if (pFW)
3408 {
3409 PUSHPTR(pFW);
3410 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3411 }
3412 else
3413 {
3414 PUSHPTR(returnForFailure);
3415 PUSHUNS(0);
3416 }
3417 return;
3418 }
3419
3420
3421
3422 /**************************************************************************
3423 f i n d
3424 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3425 ** Find the definition named in the counted string at c-addr. If the
3426 ** definition is not found, return c-addr and zero. If the definition is
3427 ** found, return its execution token xt. If the definition is immediate,
3428 ** also return one (1), otherwise also return minus-one (-1). For a given
3429 ** string, the values returned by FIND while compiling may differ from
3430 ** those returned while not compiling.
3431 **************************************************************************/
3432 static void cFind(FICL_VM *pVM)
3433 {
3434 FICL_STRING *sp;
3435 STRINGINFO si;
3436
3437 #if FICL_ROBUST > 1
3438 vmCheckStack(pVM,1,2);
3439 #endif
3440 sp = POPPTR();
3441 SI_PFS(si, sp);
3442 do_find(pVM, si, sp);
3443 }
3444
3445
3446
3447 /**************************************************************************
3448 s f i n d
3449 ** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3450 ** Like FIND, but takes "c-addr u" for the string.
3451 **************************************************************************/
3452 static void sFind(FICL_VM *pVM)
3453 {
3454 STRINGINFO si;
3455
3456 #if FICL_ROBUST > 1
3457 vmCheckStack(pVM,2,2);
3458 #endif
3459
3460 si.count = stackPopINT(pVM->pStack);
3461 si.cp = stackPopPtr(pVM->pStack);
3462
3463 do_find(pVM, si, NULL);
3464 }
3465
3466
3467
3468 /**************************************************************************
3469 f m S l a s h M o d
3470 ** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3471 ** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3472 ** Input and output stack arguments are signed. An ambiguous condition
3473 ** exists if n1 is zero or if the quotient lies outside the range of a
3474 ** single-cell signed integer.
3475 **************************************************************************/
3476 static void fmSlashMod(FICL_VM *pVM)
3477 {
3478 DPINT d1;
3479 FICL_INT n1;
3480 INTQR qr;
3481 #if FICL_ROBUST > 1
3482 vmCheckStack(pVM,3,2);
3483 #endif
3484
3485 n1 = POPINT();
3486 d1 = i64Pop(pVM->pStack);
3487 qr = m64FlooredDivI(d1, n1);
3488 PUSHINT(qr.rem);
3489 PUSHINT(qr.quot);
3490 return;
3491 }
3492
3493
3494 /**************************************************************************
3495 s m S l a s h R e m
3496 ** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3497 ** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3498 ** Input and output stack arguments are signed. An ambiguous condition
3499 ** exists if n1 is zero or if the quotient lies outside the range of a
3500 ** single-cell signed integer.
3501 **************************************************************************/
3502 static void smSlashRem(FICL_VM *pVM)
3503 {
3504 DPINT d1;
3505 FICL_INT n1;
3506 INTQR qr;
3507 #if FICL_ROBUST > 1
3508 vmCheckStack(pVM,3,2);
3509 #endif
3510
3511 n1 = POPINT();
3512 d1 = i64Pop(pVM->pStack);
3513 qr = m64SymmetricDivI(d1, n1);
3514 PUSHINT(qr.rem);
3515 PUSHINT(qr.quot);
3516 return;
3517 }
3518
3519
3520 static void ficlMod(FICL_VM *pVM)
3521 {
3522 DPINT d1;
3523 FICL_INT n1;
3524 INTQR qr;
3525 #if FICL_ROBUST > 1
3526 vmCheckStack(pVM,2,1);
3527 #endif
3528
3529 n1 = POPINT();
3530 d1.lo = POPINT();
3531 i64Extend(d1);
3532 qr = m64SymmetricDivI(d1, n1);
3533 PUSHINT(qr.rem);
3534 return;
3535 }
3536
3537
3538 /**************************************************************************
3539 u m S l a s h M o d
3540 ** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3541 ** Divide ud by u1, giving the quotient u3 and the remainder u2.
3542 ** All values and arithmetic are unsigned. An ambiguous condition
3543 ** exists if u1 is zero or if the quotient lies outside the range of a
3544 ** single-cell unsigned integer.
3545 *************************************************************************/
3546 static void umSlashMod(FICL_VM *pVM)
3547 {
3548 DPUNS ud;
3549 FICL_UNS u1;
3550 UNSQR qr;
3551
3552 u1 = stackPopUNS(pVM->pStack);
3553 ud = u64Pop(pVM->pStack);
3554 qr = ficlLongDiv(ud, u1);
3555 PUSHUNS(qr.rem);
3556 PUSHUNS(qr.quot);
3557 return;
3558 }
3559
3560
3561 /**************************************************************************
3562 l s h i f t
3563 ** l-shift CORE ( x1 u -- x2 )
3564 ** Perform a logical left shift of u bit-places on x1, giving x2.
3565 ** Put zeroes into the least significant bits vacated by the shift.
3566 ** An ambiguous condition exists if u is greater than or equal to the
3567 ** number of bits in a cell.
3568 **
3569 ** r-shift CORE ( x1 u -- x2 )
3570 ** Perform a logical right shift of u bit-places on x1, giving x2.
3571 ** Put zeroes into the most significant bits vacated by the shift. An
3572 ** ambiguous condition exists if u is greater than or equal to the
3573 ** number of bits in a cell.
3574 **************************************************************************/
3575 static void lshift(FICL_VM *pVM)
3576 {
3577 FICL_UNS nBits;
3578 FICL_UNS x1;
3579 #if FICL_ROBUST > 1
3580 vmCheckStack(pVM,2,1);
3581 #endif
3582
3583 nBits = POPUNS();
3584 x1 = POPUNS();
3585 PUSHUNS(x1 << nBits);
3586 return;
3587 }
3588
3589
3590 static void rshift(FICL_VM *pVM)
3591 {
3592 FICL_UNS nBits;
3593 FICL_UNS x1;
3594 #if FICL_ROBUST > 1
3595 vmCheckStack(pVM,2,1);
3596 #endif
3597
3598 nBits = POPUNS();
3599 x1 = POPUNS();
3600
3601 PUSHUNS(x1 >> nBits);
3602 return;
3603 }
3604
3605
3606 /**************************************************************************
3607 m S t a r
3608 ** m-star CORE ( n1 n2 -- d )
3609 ** d is the signed product of n1 times n2.
3610 **************************************************************************/
3611 static void mStar(FICL_VM *pVM)
3612 {
3613 FICL_INT n2;
3614 FICL_INT n1;
3615 DPINT d;
3616 #if FICL_ROBUST > 1
3617 vmCheckStack(pVM,2,2);
3618 #endif
3619
3620 n2 = POPINT();
3621 n1 = POPINT();
3622
3623 d = m64MulI(n1, n2);
3624 i64Push(pVM->pStack, d);
3625 return;
3626 }
3627
3628
3629 static void umStar(FICL_VM *pVM)
3630 {
3631 FICL_UNS u2;
3632 FICL_UNS u1;
3633 DPUNS ud;
3634 #if FICL_ROBUST > 1
3635 vmCheckStack(pVM,2,2);
3636 #endif
3637
3638 u2 = POPUNS();
3639 u1 = POPUNS();
3640
3641 ud = ficlLongMul(u1, u2);
3642 u64Push(pVM->pStack, ud);
3643 return;
3644 }
3645
3646
3647 /**************************************************************************
3648 m a x & m i n
3649 **
3650 **************************************************************************/
3651 static void ficlMax(FICL_VM *pVM)
3652 {
3653 FICL_INT n2;
3654 FICL_INT n1;
3655 #if FICL_ROBUST > 1
3656 vmCheckStack(pVM,2,1);
3657 #endif
3658
3659 n2 = POPINT();
3660 n1 = POPINT();
3661
3662 PUSHINT((n1 > n2) ? n1 : n2);
3663 return;
3664 }
3665
3666 static void ficlMin(FICL_VM *pVM)
3667 {
3668 FICL_INT n2;
3669 FICL_INT n1;
3670 #if FICL_ROBUST > 1
3671 vmCheckStack(pVM,2,1);
3672 #endif
3673
3674 n2 = POPINT();
3675 n1 = POPINT();
3676
3677 PUSHINT((n1 < n2) ? n1 : n2);
3678 return;
3679 }
3680
3681
3682 /**************************************************************************
3683 m o v e
3684 ** CORE ( addr1 addr2 u -- )
3685 ** If u is greater than zero, copy the contents of u consecutive address
3686 ** units at addr1 to the u consecutive address units at addr2. After MOVE
3687 ** completes, the u consecutive address units at addr2 contain exactly
3688 ** what the u consecutive address units at addr1 contained before the move.
3689 ** NOTE! This implementation assumes that a char is the same size as
3690 ** an address unit.
3691 **************************************************************************/
3692 static void move(FICL_VM *pVM)
3693 {
3694 FICL_UNS u;
3695 char *addr2;
3696 char *addr1;
3697 #if FICL_ROBUST > 1
3698 vmCheckStack(pVM,3,0);
3699 #endif
3700
3701 u = POPUNS();
3702 addr2 = POPPTR();
3703 addr1 = POPPTR();
3704
3705 if (u == 0)
3706 return;
3707 /*
3708 ** Do the copy carefully, so as to be
3709 ** correct even if the two ranges overlap
3710 */
3711 if (addr1 >= addr2)
3712 {
3713 for (; u > 0; u--)
3714 *addr2++ = *addr1++;
3715 }
3716 else
3717 {
3718 addr2 += u-1;
3719 addr1 += u-1;
3720 for (; u > 0; u--)
3721 *addr2-- = *addr1--;
3722 }
3723
3724 return;
3725 }
3726
3727
3728 /**************************************************************************
3729 r e c u r s e
3730 **
3731 **************************************************************************/
3732 static void recurseCoIm(FICL_VM *pVM)
3733 {
3734 FICL_DICT *pDict = vmGetDict(pVM);
3735
3736 IGNORE(pVM);
3737 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3738 return;
3739 }
3740
3741
3742 /**************************************************************************
3743 s t o d
3744 ** s-to-d CORE ( n -- d )
3745 ** Convert the number n to the double-cell number d with the same
3746 ** numerical value.
3747 **************************************************************************/
3748 static void sToD(FICL_VM *pVM)
3749 {
3750 FICL_INT s;
3751 #if FICL_ROBUST > 1
3752 vmCheckStack(pVM,1,2);
3753 #endif
3754
3755 s = POPINT();
3756
3757 /* sign extend to 64 bits.. */
3758 PUSHINT(s);
3759 PUSHINT((s < 0) ? -1 : 0);
3760 return;
3761 }
3762
3763
3764 /**************************************************************************
3765 s o u r c e
3766 ** CORE ( -- c-addr u )
3767 ** c-addr is the address of, and u is the number of characters in, the
3768 ** input buffer.
3769 **************************************************************************/
3770 static void source(FICL_VM *pVM)
3771 {
3772 #if FICL_ROBUST > 1
3773 vmCheckStack(pVM,0,2);
3774 #endif
3775 PUSHPTR(pVM->tib.cp);
3776 PUSHINT(vmGetInBufLen(pVM));
3777 return;
3778 }
3779
3780
3781 /**************************************************************************
3782 v e r s i o n
3783 ** non-standard...
3784 **************************************************************************/
3785 static void ficlVersion(FICL_VM *pVM)
3786 {
3787 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3788 return;
3789 }
3790
3791
3792 /**************************************************************************
3793 t o I n
3794 ** to-in CORE
3795 **************************************************************************/
3796 static void toIn(FICL_VM *pVM)
3797 {
3798 #if FICL_ROBUST > 1
3799 vmCheckStack(pVM,0,1);
3800 #endif
3801 PUSHPTR(&pVM->tib.index);
3802 return;
3803 }
3804
3805
3806 /**************************************************************************
3807 c o l o n N o N a m e
3808 ** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
3809 ** Create an unnamed colon definition and push its address.
3810 ** Change state to compile.
3811 **************************************************************************/
3812 static void colonNoName(FICL_VM *pVM)
3813 {
3814 FICL_DICT *dp = vmGetDict(pVM);
3815 FICL_WORD *pFW;
3816 STRINGINFO si;
3817
3818 SI_SETLEN(si, 0);
3819 SI_SETPTR(si, NULL);
3820
3821 pVM->state = COMPILE;
3822 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3823 PUSHPTR(pFW);
3824 markControlTag(pVM, colonTag);
3825 return;
3826 }
3827
3828
3829 /**************************************************************************
3830 u s e r V a r i a b l e
3831 ** user ( u -- ) "<spaces>name"
3832 ** Get a name from the input stream and create a user variable
3833 ** with the name and the index supplied. The run-time effect
3834 ** of a user variable is to push the address of the indexed cell
3835 ** in the running vm's user array.
3836 **
3837 ** User variables are vm local cells. Each vm has an array of
3838 ** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3839 ** Ficl's user facility is implemented with two primitives,
3840 ** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3841 ** holds the index of the next free user cell, and a redefinition
3842 ** (also in softcore) of "user" that defines a user word and increments
3843 ** nUser.
3844 **************************************************************************/
3845 #if FICL_WANT_USER
3846 static void userParen(FICL_VM *pVM)
3847 {
3848 FICL_INT i = pVM->runningWord->param[0].i;
3849 PUSHPTR(&pVM->user[i]);
3850 return;
3851 }
3852
3853
3854 static void userVariable(FICL_VM *pVM)
3855 {
3856 FICL_DICT *dp = vmGetDict(pVM);
3857 STRINGINFO si = vmGetWord(pVM);
3858 CELL c;
3859
3860 c = stackPop(pVM->pStack);
3861 if (c.i >= FICL_USER_CELLS)
3862 {
3863 vmThrowErr(pVM, "Error - out of user space");
3864 }
3865
3866 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3867 dictAppendCell(dp, c);
3868 return;
3869 }
3870 #endif
3871
3872
3873 /**************************************************************************
3874 t o V a l u e
3875 ** CORE EXT
3876 ** Interpretation: ( x "<spaces>name" -- )
3877 ** Skip leading spaces and parse name delimited by a space. Store x in
3878 ** name. An ambiguous condition exists if name was not defined by VALUE.
3879 ** NOTE: In ficl, VALUE is an alias of CONSTANT
3880 **************************************************************************/
3881 static void toValue(FICL_VM *pVM)
3882 {
3883 STRINGINFO si = vmGetWord(pVM);
3884 FICL_DICT *dp = vmGetDict(pVM);
3885 FICL_WORD *pFW;
3886
3887 #if FICL_WANT_LOCALS
3888 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
3889 {
3890 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
3891 pFW = dictLookup(pLoc, si);
3892 if (pFW && (pFW->code == doLocalIm))
3893 {
3894 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
3895 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3896 return;
3897 }
3898 else if (pFW && pFW->code == do2LocalIm)
3899 {
3900 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
3901 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3902 return;
3903 }
3904 }
3905 #endif
3906
3907 assert(pVM->pSys->pStore);
3908
3909 pFW = dictLookup(dp, si);
3910 if (!pFW)
3911 {
3912 int i = SI_COUNT(si);
3913 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3914 }
3915
3916 if (pVM->state == INTERPRET)
3917 pFW->param[0] = stackPop(pVM->pStack);
3918 else /* compile code to store to word's param */
3919 {
3920 PUSHPTR(&pFW->param[0]);
3921 literalIm(pVM);
3922 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
3923 }
3924 return;
3925 }
3926
3927
3928 #if FICL_WANT_LOCALS
3929 /**************************************************************************
3930 l i n k P a r e n
3931 ** ( -- )
3932 ** Link a frame on the return stack, reserving nCells of space for
3933 ** locals - the value of nCells is the next cell in the instruction
3934 ** stream.
3935 **************************************************************************/
3936 static void linkParen(FICL_VM *pVM)
3937 {
3938 FICL_INT nLink = *(FICL_INT *)(pVM->ip);
3939 vmBranchRelative(pVM, 1);
3940 stackLink(pVM->rStack, nLink);
3941 return;
3942 }
3943
3944
3945 static void unlinkParen(FICL_VM *pVM)
3946 {
3947 stackUnlink(pVM->rStack);
3948 return;
3949 }
3950
3951
3952 /**************************************************************************
3953 d o L o c a l I m
3954 ** Immediate - cfa of a local while compiling - when executed, compiles
3955 ** code to fetch the value of a local given the local's index in the
3956 ** word's pfa
3957 **************************************************************************/
3958 static void getLocalParen(FICL_VM *pVM)
3959 {
3960 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3961 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3962 return;
3963 }
3964
3965
3966 static void toLocalParen(FICL_VM *pVM)
3967 {
3968 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3969 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3970 return;
3971 }
3972
3973
3974 static void getLocal0(FICL_VM *pVM)
3975 {
3976 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3977 return;
3978 }
3979
3980
3981 static void toLocal0(FICL_VM *pVM)
3982 {
3983 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3984 return;
3985 }
3986
3987
3988 static void getLocal1(FICL_VM *pVM)
3989 {
3990 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3991 return;
3992 }
3993
3994
3995 static void toLocal1(FICL_VM *pVM)
3996 {
3997 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
3998 return;
3999 }
4000
4001
4002 /*
4003 ** Each local is recorded in a private locals dictionary as a
4004 ** word that does doLocalIm at runtime. DoLocalIm compiles code
4005 ** into the client definition to fetch the value of the
4006 ** corresponding local variable from the return stack.
4007 ** The private dictionary gets initialized at the end of each block
4008 ** that uses locals (in ; and does> for example).
4009 */
4010 static void doLocalIm(FICL_VM *pVM)
4011 {
4012 FICL_DICT *pDict = vmGetDict(pVM);
4013 FICL_INT nLocal = pVM->runningWord->param[0].i;
4014
4015 if (pVM->state == INTERPRET)
4016 {
4017 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4018 }
4019 else
4020 {
4021
4022 if (nLocal == 0)
4023 {
4024 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
4025 }
4026 else if (nLocal == 1)
4027 {
4028 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
4029 }
4030 else
4031 {
4032 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
4033 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4034 }
4035 }
4036 return;
4037 }
4038
4039
4040 /**************************************************************************
4041 l o c a l P a r e n
4042 ** paren-local-paren LOCAL
4043 ** Interpretation: Interpretation semantics for this word are undefined.
4044 ** Execution: ( c-addr u -- )
4045 ** When executed during compilation, (LOCAL) passes a message to the
4046 ** system that has one of two meanings. If u is non-zero,
4047 ** the message identifies a new local whose definition name is given by
4048 ** the string of characters identified by c-addr u. If u is zero,
4049 ** the message is last local and c-addr has no significance.
4050 **
4051 ** The result of executing (LOCAL) during compilation of a definition is
4052 ** to create a set of named local identifiers, each of which is
4053 ** a definition name, that only have execution semantics within the scope
4054 ** of that definition's source.
4055 **
4056 ** local Execution: ( -- x )
4057 **
4058 ** Push the local's value, x, onto the stack. The local's value is
4059 ** initialized as described in 13.3.3 Processing locals and may be
4060 ** changed by preceding the local's name with TO. An ambiguous condition
4061 ** exists when local is executed while in interpretation state.
4062 **************************************************************************/
4063 static void localParen(FICL_VM *pVM)
4064 {
4065 FICL_DICT *pDict;
4066 STRINGINFO si;
4067 #if FICL_ROBUST > 1
4068 vmCheckStack(pVM,2,0);
4069 #endif
4070
4071 pDict = vmGetDict(pVM);
4072 SI_SETLEN(si, POPUNS());
4073 SI_SETPTR(si, (char *)POPPTR());
4074
4075 if (SI_COUNT(si) > 0)
4076 { /* add a local to the **locals** dict and update nLocals */
4077 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4078 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4079 {
4080 vmThrowErr(pVM, "Error: out of local space");
4081 }
4082
4083 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4084 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4085
4086 if (pVM->pSys->nLocals == 0)
4087 { /* compile code to create a local stack frame */
4088 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4089 /* save location in dictionary for #locals */
4090 pVM->pSys->pMarkLocals = pDict->here;
4091 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4092 /* compile code to initialize first local */
4093 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
4094 }
4095 else if (pVM->pSys->nLocals == 1)
4096 {
4097 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
4098 }
4099 else
4100 {
4101 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4102 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4103 }
4104
4105 (pVM->pSys->nLocals)++;
4106 }
4107 else if (pVM->pSys->nLocals > 0)
4108 { /* write nLocals to (link) param area in dictionary */
4109 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4110 }
4111
4112 return;
4113 }
4114
4115
4116 static void get2LocalParen(FICL_VM *pVM)
4117 {
4118 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4119 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4120 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4121 return;
4122 }
4123
4124
4125 static void do2LocalIm(FICL_VM *pVM)
4126 {
4127 FICL_DICT *pDict = vmGetDict(pVM);
4128 FICL_INT nLocal = pVM->runningWord->param[0].i;
4129
4130 if (pVM->state == INTERPRET)
4131 {
4132 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4133 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4134 }
4135 else
4136 {
4137 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
4138 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4139 }
4140 return;
4141 }
4142
4143
4144 static void to2LocalParen(FICL_VM *pVM)
4145 {
4146 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4147 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4148 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4149 return;
4150 }
4151
4152
4153 static void twoLocalParen(FICL_VM *pVM)
4154 {
4155 FICL_DICT *pDict = vmGetDict(pVM);
4156 STRINGINFO si;
4157 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4158 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4159
4160 if (SI_COUNT(si) > 0)
4161 { /* add a local to the **locals** dict and update nLocals */
4162 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4163 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4164 {
4165 vmThrowErr(pVM, "Error: out of local space");
4166 }
4167
4168 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4169 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4170
4171 if (pVM->pSys->nLocals == 0)
4172 { /* compile code to create a local stack frame */
4173 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4174 /* save location in dictionary for #locals */
4175 pVM->pSys->pMarkLocals = pDict->here;
4176 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4177 }
4178
4179 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4180 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4181
4182 pVM->pSys->nLocals += 2;
4183 }
4184 else if (pVM->pSys->nLocals > 0)
4185 { /* write nLocals to (link) param area in dictionary */
4186 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4187 }
4188
4189 return;
4190 }
4191
4192
4193 #endif
4194 /**************************************************************************
4195 c o m p a r e
4196 ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4197 ** Compare the string specified by c-addr1 u1 to the string specified by
4198 ** c-addr2 u2. The strings are compared, beginning at the given addresses,
4199 ** character by character, up to the length of the shorter string or until a
4200 ** difference is found. If the two strings are identical, n is zero. If the two
4201 ** strings are identical up to the length of the shorter string, n is minus-one
4202 ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4203 ** identical up to the length of the shorter string, n is minus-one (-1) if the
4204 ** first non-matching character in the string specified by c-addr1 u1 has a
4205 ** lesser numeric value than the corresponding character in the string specified
4206 ** by c-addr2 u2 and one (1) otherwise.
4207 **************************************************************************/
4208 static void compareInternal(FICL_VM *pVM, int caseInsensitive)
4209 {
4210 char *cp1, *cp2;
4211 FICL_UNS u1, u2, uMin;
4212 int n = 0;
4213
4214 vmCheckStack(pVM, 4, 1);
4215 u2 = stackPopUNS(pVM->pStack);
4216 cp2 = (char *)stackPopPtr(pVM->pStack);
4217 u1 = stackPopUNS(pVM->pStack);
4218 cp1 = (char *)stackPopPtr(pVM->pStack);
4219
4220 uMin = (u1 < u2)? u1 : u2;
4221 for ( ; (uMin > 0) && (n == 0); uMin--)
4222 {
4223 char c1 = *cp1++;
4224 char c2 = *cp2++;
4225 if (caseInsensitive)
4226 {
4227 c1 = (char)tolower(c1);
4228 c2 = (char)tolower(c2);
4229 }
4230 n = (int)(c1 - c2);
4231 }
4232
4233 if (n == 0)
4234 n = (int)(u1 - u2);
4235
4236 if (n < 0)
4237 n = -1;
4238 else if (n > 0)
4239 n = 1;
4240
4241 PUSHINT(n);
4242 return;
4243 }
4244
4245
4246 static void compareString(FICL_VM *pVM)
4247 {
4248 compareInternal(pVM, FALSE);
4249 }
4250
4251
4252 static void compareStringInsensitive(FICL_VM *pVM)
4253 {
4254 compareInternal(pVM, TRUE);
4255 }
4256
4257
4258 /**************************************************************************
4259 p a d
4260 ** CORE EXT ( -- c-addr )
4261 ** c-addr is the address of a transient region that can be used to hold
4262 ** data for intermediate processing.
4263 **************************************************************************/
4264 static void pad(FICL_VM *pVM)
4265 {
4266 stackPushPtr(pVM->pStack, pVM->pad);
4267 }
4268
4269
4270 /**************************************************************************
4271 s o u r c e - i d
4272 ** CORE EXT, FILE ( -- 0 | -1 | fileid )
4273 ** Identifies the input source as follows:
4274 **
4275 ** SOURCE-ID Input source
4276 ** --------- ------------
4277 ** fileid Text file fileid
4278 ** -1 String (via EVALUATE)
4279 ** 0 User input device
4280 **************************************************************************/
4281 static void sourceid(FICL_VM *pVM)
4282 {
4283 PUSHINT(pVM->sourceID.i);
4284 return;
4285 }
4286
4287
4288 /**************************************************************************
4289 r e f i l l
4290 ** CORE EXT ( -- flag )
4291 ** Attempt to fill the input buffer from the input source, returning a true
4292 ** flag if successful.
4293 ** When the input source is the user input device, attempt to receive input
4294 ** into the terminal input buffer. If successful, make the result the input
4295 ** buffer, set >IN to zero, and return true. Receipt of a line containing no
4296 ** characters is considered successful. If there is no input available from
4297 ** the current input source, return false.
4298 ** When the input source is a string from EVALUATE, return false and
4299 ** perform no other action.
4300 **************************************************************************/
4301 static void refill(FICL_VM *pVM)
4302 {
4303 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4304 if (ret && (pVM->fRestart == 0))
4305 vmThrow(pVM, VM_RESTART);
4306
4307 PUSHINT(ret);
4308 return;
4309 }
4310
4311
4312 /**************************************************************************
4313 freebsd exception handling words
4314 ** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4315 ** the word in ToS. If an exception happens, restore the state to what
4316 ** it was before, and pushes the exception value on the stack. If not,
4317 ** push zero.
4318 **
4319 ** Notice that Catch implements an inner interpreter. This is ugly,
4320 ** but given how ficl works, it cannot be helped. The problem is that
4321 ** colon definitions will be executed *after* the function returns,
4322 ** while "code" definitions will be executed immediately. I considered
4323 ** other solutions to this problem, but all of them shared the same
4324 ** basic problem (with added disadvantages): if ficl ever changes it's
4325 ** inner thread modus operandi, one would have to fix this word.
4326 **
4327 ** More comments can be found throughout catch's code.
4328 **
4329 ** Daniel C. Sobral Jan 09/1999
4330 ** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4331 **************************************************************************/
4332
4333 static void ficlCatch(FICL_VM *pVM)
4334 {
4335 int except;
4336 jmp_buf vmState;
4337 FICL_VM VM;
4338 FICL_STACK pStack;
4339 FICL_STACK rStack;
4340 FICL_WORD *pFW;
4341
4342 assert(pVM);
4343 assert(pVM->pSys->pExitInner);
4344
4345
4346 /*
4347 ** Get xt.
4348 ** We need this *before* we save the stack pointer, or
4349 ** we'll have to pop one element out of the stack after
4350 ** an exception. I prefer to get done with it up front. :-)
4351 */
4352 #if FICL_ROBUST > 1
4353 vmCheckStack(pVM, 1, 0);
4354 #endif
4355 pFW = stackPopPtr(pVM->pStack);
4356
4357 /*
4358 ** Save vm's state -- a catch will not back out environmental
4359 ** changes.
4360 **
4361 ** We are *not* saving dictionary state, since it is
4362 ** global instead of per vm, and we are not saving
4363 ** stack contents, since we are not required to (and,
4364 ** thus, it would be useless). We save pVM, and pVM
4365 ** "stacks" (a structure containing general information
4366 ** about it, including the current stack pointer).
4367 */
4368 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4369 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4370 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4371
4372 /*
4373 ** Give pVM a jmp_buf
4374 */
4375 pVM->pState = &vmState;
4376
4377 /*
4378 ** Safety net
4379 */
4380 except = setjmp(vmState);
4381
4382 switch (except)
4383 {
4384 /*
4385 ** Setup condition - push poison pill so that the VM throws
4386 ** VM_INNEREXIT if the XT terminates normally, then execute
4387 ** the XT
4388 */
4389 case 0:
4390 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4391 vmExecute(pVM, pFW);
4392 vmInnerLoop(pVM);
4393 break;
4394
4395 /*
4396 ** Normal exit from XT - lose the poison pill,
4397 ** restore old setjmp vector and push a zero.
4398 */
4399 case VM_INNEREXIT:
4400 vmPopIP(pVM); /* Gack - hurl poison pill */
4401 pVM->pState = VM.pState; /* Restore just the setjmp vector */
4402 PUSHINT(0); /* Push 0 -- everything is ok */
4403 break;
4404
4405 /*
4406 ** Some other exception got thrown - restore pre-existing VM state
4407 ** and push the exception code
4408 */
4409 default:
4410 /* Restore vm's state */
4411 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4412 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4413 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4414
4415 PUSHINT(except);/* Push error */
4416 break;
4417 }
4418 }
4419
4420 /**************************************************************************
4421 ** t h r o w
4422 ** EXCEPTION
4423 ** Throw -- From ANS Forth standard.
4424 **
4425 ** Throw takes the ToS and, if that's different from zero,
4426 ** returns to the last executed catch context. Further throws will
4427 ** unstack previously executed "catches", in LIFO mode.
4428 **
4429 ** Daniel C. Sobral Jan 09/1999
4430 **************************************************************************/
4431 static void ficlThrow(FICL_VM *pVM)
4432 {
4433 int except;
4434
4435 except = stackPopINT(pVM->pStack);
4436
4437 if (except)
4438 vmThrow(pVM, except);
4439 }
4440
4441
4442 /**************************************************************************
4443 ** a l l o c a t e
4444 ** MEMORY
4445 **************************************************************************/
4446 static void ansAllocate(FICL_VM *pVM)
4447 {
4448 size_t size;
4449 void *p;
4450
4451 size = stackPopINT(pVM->pStack);
4452 p = ficlMalloc(size);
4453 PUSHPTR(p);
4454 if (p)
4455 PUSHINT(0);
4456 else
4457 PUSHINT(1);
4458 }
4459
4460
4461 /**************************************************************************
4462 ** f r e e
4463 ** MEMORY
4464 **************************************************************************/
4465 static void ansFree(FICL_VM *pVM)
4466 {
4467 void *p;
4468
4469 p = stackPopPtr(pVM->pStack);
4470 ficlFree(p);
4471 PUSHINT(0);
4472 }
4473
4474
4475 /**************************************************************************
4476 ** r e s i z e
4477 ** MEMORY
4478 **************************************************************************/
4479 static void ansResize(FICL_VM *pVM)
4480 {
4481 size_t size;
4482 void *new, *old;
4483
4484 size = stackPopINT(pVM->pStack);
4485 old = stackPopPtr(pVM->pStack);
4486 new = ficlRealloc(old, size);
4487 if (new)
4488 {
4489 PUSHPTR(new);
4490 PUSHINT(0);
4491 }
4492 else
4493 {
4494 PUSHPTR(old);
4495 PUSHINT(1);
4496 }
4497 }
4498
4499
4500 /**************************************************************************
4501 ** e x i t - i n n e r
4502 ** Signals execXT that an inner loop has completed
4503 **************************************************************************/
4504 static void ficlExitInner(FICL_VM *pVM)
4505 {
4506 vmThrow(pVM, VM_INNEREXIT);
4507 }
4508
4509
4510 /**************************************************************************
4511 d n e g a t e
4512 ** DOUBLE ( d1 -- d2 )
4513 ** d2 is the negation of d1.
4514 **************************************************************************/
4515 static void dnegate(FICL_VM *pVM)
4516 {
4517 DPINT i = i64Pop(pVM->pStack);
4518 i = m64Negate(i);
4519 i64Push(pVM->pStack, i);
4520
4521 return;
4522 }
4523
4524
4525 #if 0
4526 /**************************************************************************
4527
4528 **
4529 **************************************************************************/
4530 static void funcname(FICL_VM *pVM)
4531 {
4532 IGNORE(pVM);
4533 return;
4534 }
4535
4536
4537 #endif
4538 /**************************************************************************
4539 f i c l W o r d C l a s s i f y
4540 ** This public function helps to classify word types for SEE
4541 ** and the deugger in tools.c. Given a pointer to a word, it returns
4542 ** a member of WOR
4543 **************************************************************************/
4544 WORDKIND ficlWordClassify(FICL_WORD *pFW)
4545 {
4546 typedef struct
4547 {
4548 WORDKIND kind;
4549 FICL_CODE code;
4550 } CODEtoKIND;
4551
4552 static CODEtoKIND codeMap[] =
4553 {
4554 {BRANCH, branchParen},
4555 {COLON, colonParen},
4556 {CONSTANT, constantParen},
4557 {CREATE, createParen},
4558 {DO, doParen},
4559 {DOES, doDoes},
4560 {IF, ifParen},
4561 {LITERAL, literalParen},
4562 {LOOP, loopParen},
4563 {PLOOP, plusLoopParen},
4564 {QDO, qDoParen},
4565 {CSTRINGLIT, cstringLit},
4566 {STRINGLIT, stringLit},
4567 #if FICL_WANT_USER
4568 {USER, userParen},
4569 #endif
4570 {VARIABLE, variableParen},
4571 };
4572
4573 #define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4574
4575 FICL_CODE code = pFW->code;
4576 int i;
4577
4578 for (i=0; i < nMAP; i++)
4579 {
4580 if (codeMap[i].code == code)
4581 return codeMap[i].kind;
4582 }
4583
4584 return PRIMITIVE;
4585 }
4586
4587
4588 /**************************************************************************
4589 f i c l C o m p i l e C o r e
4590 ** Builds the primitive wordset and the environment-query namespace.
4591 **************************************************************************/
4592
4593 void ficlCompileCore(FICL_SYSTEM *pSys)
4594 {
4595 FICL_DICT *dp = pSys->dp;
4596 assert (dp);
4597
4598
4599 /*
4600 ** CORE word set
4601 ** see softcore.c for definitions of: abs bl space spaces abort"
4602 */
4603 pSys->pStore =
4604 dictAppendWord(dp, "!", store, FW_DEFAULT);
4605 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4606 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4607 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4608 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4609 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4610 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4611 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4612 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4613 dictAppendWord(dp, "+", add, FW_DEFAULT);
4614 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4615 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4616 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4617 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4618 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4619 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4620 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4621 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4622 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4623 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4624 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4625 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4626 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4627 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4628 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4629 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4630 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4631 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4632 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4633 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4634 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4635 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4636 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4637 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4638 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4639 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4640 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4641 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4642 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4643 dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
4644 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4645 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4646 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4647 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4648 dictAppendWord(dp, "align", align, FW_DEFAULT);
4649 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4650 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4651 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4652 dictAppendWord(dp, "base", base, FW_DEFAULT);
4653 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4654 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4655 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4656 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4657 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4658 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4659 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4660 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4661 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4662 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4663 dictAppendWord(dp, "count", count, FW_DEFAULT);
4664 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4665 dictAppendWord(dp, "create", create, FW_DEFAULT);
4666 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4667 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4668 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4669 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4670 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4671 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4672 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4673 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4674 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4675 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4676 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4677 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4678 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4679 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4680 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4681 dictAppendWord(dp, "here", here, FW_DEFAULT);
4682 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4683 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4684 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4685 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4686 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4687 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4688 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4689 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4690 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4691 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4692 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4693 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4694 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4695 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4696 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4697 dictAppendWord(dp, "move", move, FW_DEFAULT);
4698 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4699 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4700 dictAppendWord(dp, "over", over, FW_DEFAULT);
4701 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4702 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4703 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
4704 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
4705 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4706 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4707 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4708 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4709 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4710 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4711 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4712 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4713 dictAppendWord(dp, "source", source, FW_DEFAULT);
4714 dictAppendWord(dp, "state", state, FW_DEFAULT);
4715 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4716 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4717 dictAppendWord(dp, "type", type, FW_DEFAULT);
4718 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4719 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4720 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4721 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4722 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4723 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4724 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4725 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4726 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4727 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4728 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4729 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
4730 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
4731 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
4732 /*
4733 ** CORE EXT word set...
4734 ** see softcore.fr for other definitions
4735 */
4736 /* "#tib" */
4737 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
4738 /* ".r" */
4739 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
4740 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
4741 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
4742 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
4743 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
4744 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
4745 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
4746 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
4747 /* case of endof endcase */
4748 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
4749 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
4750 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
4751 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
4752 /* query restore-input save-input tib u.r u> unused [compile] */
4753 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
4754 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
4755 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
4756 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
4757 dictAppendWord(dp, "value", constant, FW_DEFAULT);
4758 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
4759
4760
4761 /*
4762 ** Set CORE environment query values
4763 */
4764 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
4765 ficlSetEnv(pSys, "/hold", nPAD);
4766 ficlSetEnv(pSys, "/pad", nPAD);
4767 ficlSetEnv(pSys, "address-unit-bits", 8);
4768 ficlSetEnv(pSys, "core", FICL_TRUE);
4769 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
4770 ficlSetEnv(pSys, "floored", FICL_FALSE);
4771 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
4772 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
4773 ficlSetEnv(pSys, "max-n", 0x7fffffff);
4774 ficlSetEnv(pSys, "max-u", 0xffffffff);
4775 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
4776 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
4777 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
4778
4779 /*
4780 ** DOUBLE word set (partial)
4781 */
4782 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
4783 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
4784 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
4785 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
4786
4787
4788 /*
4789 ** EXCEPTION word set
4790 */
4791 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
4792 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
4793
4794 ficlSetEnv(pSys, "exception", FICL_TRUE);
4795 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
4796
4797 /*
4798 ** LOCAL and LOCAL EXT
4799 ** see softcore.c for implementation of locals|
4800 */
4801 #if FICL_WANT_LOCALS
4802 pSys->pLinkParen =
4803 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
4804 pSys->pUnLinkParen =
4805 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
4806 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
4807 pSys->pGetLocalParen =
4808 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
4809 pSys->pToLocalParen =
4810 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
4811 pSys->pGetLocal0 =
4812 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
4813 pSys->pToLocal0 =
4814 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
4815 pSys->pGetLocal1 =
4816 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
4817 pSys->pToLocal1 =
4818 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
4819 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
4820
4821 pSys->pGet2LocalParen =
4822 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4823 pSys->pTo2LocalParen =
4824 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
4825 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
4826
4827 ficlSetEnv(pSys, "locals", FICL_TRUE);
4828 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
4829 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
4830 #endif
4831
4832 /*
4833 ** Optional MEMORY-ALLOC word set
4834 */
4835
4836 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
4837 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
4838 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
4839
4840 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
4841
4842 /*
4843 ** optional SEARCH-ORDER word set
4844 */
4845 ficlCompileSearch(pSys);
4846
4847 /*
4848 ** TOOLS and TOOLS EXT
4849 */
4850 ficlCompileTools(pSys);
4851
4852 /*
4853 ** FILE and FILE EXT
4854 */
4855 #if FICL_WANT_FILE
4856 ficlCompileFile(pSys);
4857 #endif
4858
4859 /*
4860 ** Ficl extras
4861 */
4862 #if FICL_WANT_FLOAT
4863 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
4864 #endif
4865 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
4866 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
4867 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
4868 dictAppendWord(dp, "add-parse-step",
4869 addParseStep, FW_DEFAULT);
4870 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
4871 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
4872 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
4873 dictAppendWord(dp, "compile-only",
4874 compileOnly, FW_DEFAULT);
4875 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
4876 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
4877 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
4878 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
4879 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
4880 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
4881 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
4882 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
4883 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
4884 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
4885 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
4886 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
4887 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
4888 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
4889 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
4890 #if FICL_WANT_USER
4891 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
4892 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
4893 #endif
4894
4895 /*
4896 ** internal support words
4897 */
4898 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
4899 pSys->pExitParen =
4900 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
4901 pSys->pSemiParen =
4902 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
4903 pSys->pLitParen =
4904 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
4905 pSys->pTwoLitParen =
4906 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
4907 pSys->pStringLit =
4908 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
4909 pSys->pCStringLit =
4910 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
4911 pSys->pIfParen =
4912 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
4913 pSys->pBranchParen =
4914 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
4915 pSys->pDoParen =
4916 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
4917 pSys->pDoesParen =
4918 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
4919 pSys->pQDoParen =
4920 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
4921 pSys->pLoopParen =
4922 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
4923 pSys->pPLoopParen =
4924 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
4925 pSys->pInterpret =
4926 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
4927 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
4928 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
4929 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
4930 dictAppendWord(dp, "(parse-step)",
4931 parseStepParen, FW_DEFAULT);
4932 pSys->pExitInner =
4933 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
4934
4935 /*
4936 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
4937 */
4938 pSys->pInterp[0] = pSys->pInterpret;
4939 pSys->pInterp[1] = pSys->pBranchParen;
4940 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
4941
4942 assert(dictCellsAvail(dp) > 0);
4943
4944 return;
4945 }
4946
DragonFly BSD