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 #ifdef TESTMAIN
46 #include <stdlib.h>
47 #include <stdio.h>
48 #include <ctype.h>
49 #include <fcntl.h>
50 #else
51 #include <stand.h>
52 #endif
53 #include <string.h>
54 #include "ficl.h"
55 #include "math64.h"
56
57 static void colonParen(FICL_VM *pVM);
58 static void literalIm(FICL_VM *pVM);
59 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si);
60
61 /*
62 ** Control structure building words use these
63 ** strings' addresses as markers on the stack to
64 ** check for structure completion.
65 */
66 static char doTag[] = "do";
67 static char colonTag[] = "colon";
68 static char leaveTag[] = "leave";
69
70 static char destTag[] = "target";
71 static char origTag[] = "origin";
72
73 static char caseTag[] = "case";
74 static char ofTag[] = "of";
75 static char fallthroughTag[] = "fallthrough";
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 */
markBranch(FICL_DICT * dp,FICL_VM * pVM,char * tag)89 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
90 {
91 PUSHPTR(dp->here);
92 PUSHPTR(tag);
93 return;
94 }
95
markControlTag(FICL_VM * pVM,char * tag)96 static void markControlTag(FICL_VM *pVM, char *tag)
97 {
98 PUSHPTR(tag);
99 return;
100 }
101
matchControlTag(FICL_VM * pVM,char * tag)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 */
resolveBackBranch(FICL_DICT * dp,FICL_VM * pVM,char * tag)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 */
resolveForwardBranch(FICL_DICT * dp,FICL_VM * pVM,char * tag)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 */
resolveAbsBranch(FICL_DICT * dp,FICL_VM * pVM,char * tag)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
ficlParseNumber(FICL_VM * pVM,STRINGINFO si)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
add(FICL_VM * pVM)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
sub(FICL_VM * pVM)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
mul(FICL_VM * pVM)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
negate(FICL_VM * pVM)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
ficlDiv(FICL_VM * pVM)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 */
slashMod(FICL_VM * pVM)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
onePlus(FICL_VM * pVM)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
oneMinus(FICL_VM * pVM)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
twoMul(FICL_VM * pVM)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
twoDiv(FICL_VM * pVM)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
mulDiv(FICL_VM * pVM)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
mulDivRem(FICL_VM * pVM)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
colon(FICL_VM * pVM)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
colonParen(FICL_VM * pVM)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 **************************************************************************/
semiParen(FICL_VM * pVM)507 static void semiParen(FICL_VM *pVM)
508 {
509 vmPopIP(pVM);
510 return;
511 }
512
513
semicolonCoIm(FICL_VM * pVM)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 **************************************************************************/
exitParen(FICL_VM * pVM)548 static void exitParen(FICL_VM *pVM)
549 {
550 vmPopIP(pVM);
551 return;
552 }
553
exitCoIm(FICL_VM * pVM)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
constantParen(FICL_VM * pVM)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
twoConstParen(FICL_VM * pVM)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
constant(FICL_VM * pVM)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
twoConstant(FICL_VM * pVM)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
displayCell(FICL_VM * pVM)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
uDot(FICL_VM * pVM)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
hexDot(FICL_VM * pVM)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 **/
ficlStrlen(FICL_VM * ficlVM)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 **************************************************************************/
ficlSprintf(FICL_VM * pVM)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
depth(FICL_VM * pVM)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
drop(FICL_VM * pVM)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
twoDrop(FICL_VM * pVM)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
dup(FICL_VM * pVM)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
twoDup(FICL_VM * pVM)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
over(FICL_VM * pVM)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
twoOver(FICL_VM * pVM)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
pick(FICL_VM * pVM)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
questionDup(FICL_VM * pVM)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
roll(FICL_VM * pVM)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
minusRoll(FICL_VM * pVM)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
rot(FICL_VM * pVM)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
swap(FICL_VM * pVM)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
twoSwap(FICL_VM * pVM)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
emit(FICL_VM * pVM)1015 static void emit(FICL_VM *pVM)
1016 {
1017 char cp[2];
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
cr(FICL_VM * pVM)1031 static void cr(FICL_VM *pVM)
1032 {
1033 vmTextOut(pVM, "", 1);
1034 return;
1035 }
1036
1037
commentLine(FICL_VM * pVM)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 */
commentHang(FICL_VM * pVM)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
fetch(FICL_VM * pVM)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 */
twoFetch(FICL_VM * pVM)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 */
store(FICL_VM * pVM)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 */
twoStore(FICL_VM * pVM)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
plusStore(FICL_VM * pVM)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
quadFetch(FICL_VM * pVM)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
quadStore(FICL_VM * pVM)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
wFetch(FICL_VM * pVM)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
wStore(FICL_VM * pVM)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
cFetch(FICL_VM * pVM)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
cStore(FICL_VM * pVM)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 b r a n c h P a r e n
1227 **
1228 ** Runtime for "(branch)" -- expects a literal offset in the next
1229 ** compilation address, and branches to that location.
1230 **************************************************************************/
1231
branchParen(FICL_VM * pVM)1232 static void branchParen(FICL_VM *pVM)
1233 {
1234 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1235 return;
1236 }
1237
1238
1239 /**************************************************************************
1240 b r a n c h 0
1241 ** Runtime code for "(branch0)"; pop a flag from the stack,
1242 ** branch if 0. fall through otherwise. The heart of "if" and "until".
1243 **************************************************************************/
1244
branch0(FICL_VM * pVM)1245 static void branch0(FICL_VM *pVM)
1246 {
1247 FICL_UNS flag;
1248
1249 #if FICL_ROBUST > 1
1250 vmCheckStack(pVM, 1, 0);
1251 #endif
1252 flag = stackPopUNS(pVM->pStack);
1253
1254 if (flag)
1255 { /* fall through */
1256 vmBranchRelative(pVM, 1);
1257 }
1258 else
1259 { /* take branch (to else/endif/begin) */
1260 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
1261 }
1262
1263 return;
1264 }
1265
1266
1267 /**************************************************************************
1268 i f C o I m
1269 ** IMMEDIATE COMPILE-ONLY
1270 ** Compiles code for a conditional branch into the dictionary
1271 ** and pushes the branch patch address on the stack for later
1272 ** patching by ELSE or THEN/ENDIF.
1273 **************************************************************************/
1274
ifCoIm(FICL_VM * pVM)1275 static void ifCoIm(FICL_VM *pVM)
1276 {
1277 FICL_DICT *dp = vmGetDict(pVM);
1278
1279 assert(pVM->pSys->pBranch0);
1280
1281 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
1282 markBranch(dp, pVM, origTag);
1283 dictAppendUNS(dp, 1);
1284 return;
1285 }
1286
1287
1288 /**************************************************************************
1289 e l s e C o I m
1290 **
1291 ** IMMEDIATE COMPILE-ONLY
1292 ** compiles an "else"...
1293 ** 1) Compile a branch and a patch address; the address gets patched
1294 ** by "endif" to point past the "else" code.
1295 ** 2) Pop the "if" patch address
1296 ** 3) Patch the "if" branch to point to the current compile address.
1297 ** 4) Push the "else" patch address. ("endif" patches this to jump past
1298 ** the "else" code.
1299 **************************************************************************/
1300
elseCoIm(FICL_VM * pVM)1301 static void elseCoIm(FICL_VM *pVM)
1302 {
1303 CELL *patchAddr;
1304 FICL_INT offset;
1305 FICL_DICT *dp = vmGetDict(pVM);
1306
1307 assert(pVM->pSys->pBranchParen);
1308 /* (1) compile branch runtime */
1309 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1310 matchControlTag(pVM, origTag);
1311 patchAddr =
1312 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
1313 markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
1314 dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
1315 offset = dp->here - patchAddr;
1316 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
1317
1318 return;
1319 }
1320
1321
1322 /**************************************************************************
1323 e n d i f C o I m
1324 ** IMMEDIATE COMPILE-ONLY
1325 **************************************************************************/
1326
endifCoIm(FICL_VM * pVM)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 c a s e C o I m
1337 ** IMMEDIATE COMPILE-ONLY
1338 **
1339 **
1340 ** At compile-time, a CASE-SYS (see DPANS94 6.2.0873) looks like this:
1341 ** i*addr i caseTag
1342 ** and an OF-SYS (see DPANS94 6.2.1950) looks like this:
1343 ** i*addr i caseTag addr ofTag
1344 ** The integer under caseTag is the count of fixup addresses that branch
1345 ** to ENDCASE.
1346 **************************************************************************/
1347
caseCoIm(FICL_VM * pVM)1348 static void caseCoIm(FICL_VM *pVM)
1349 {
1350 #if FICL_ROBUST > 1
1351 vmCheckStack(pVM, 0, 2);
1352 #endif
1353
1354 PUSHUNS(0);
1355 markControlTag(pVM, caseTag);
1356 return;
1357 }
1358
1359
1360 /**************************************************************************
1361 e n d c a s eC o I m
1362 ** IMMEDIATE COMPILE-ONLY
1363 **************************************************************************/
1364
endcaseCoIm(FICL_VM * pVM)1365 static void endcaseCoIm(FICL_VM *pVM)
1366 {
1367 FICL_UNS fixupCount;
1368 FICL_DICT *dp;
1369 CELL *patchAddr;
1370 FICL_INT offset;
1371
1372 assert(pVM->pSys->pDrop);
1373
1374 /*
1375 ** if the last OF ended with FALLTHROUGH,
1376 ** just add the FALLTHROUGH fixup to the
1377 ** ENDOF fixups
1378 */
1379 if (stackGetTop(pVM->pStack).p == fallthroughTag)
1380 {
1381 matchControlTag(pVM, fallthroughTag);
1382 patchAddr = POPPTR();
1383 matchControlTag(pVM, caseTag);
1384 fixupCount = POPUNS();
1385 PUSHPTR(patchAddr);
1386 PUSHUNS(fixupCount + 1);
1387 markControlTag(pVM, caseTag);
1388 }
1389
1390 matchControlTag(pVM, caseTag);
1391
1392 #if FICL_ROBUST > 1
1393 vmCheckStack(pVM, 1, 0);
1394 #endif
1395 fixupCount = POPUNS();
1396 #if FICL_ROBUST > 1
1397 vmCheckStack(pVM, fixupCount, 0);
1398 #endif
1399
1400 dp = vmGetDict(pVM);
1401
1402 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop));
1403
1404 while (fixupCount--)
1405 {
1406 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1407 offset = dp->here - patchAddr;
1408 *patchAddr = LVALUEtoCELL(offset);
1409 }
1410 return;
1411 }
1412
1413
ofParen(FICL_VM * pVM)1414 static void ofParen(FICL_VM *pVM)
1415 {
1416 FICL_UNS a, b;
1417
1418 #if FICL_ROBUST > 1
1419 vmCheckStack(pVM, 2, 1);
1420 #endif
1421
1422 a = POPUNS();
1423 b = stackGetTop(pVM->pStack).u;
1424
1425 if (a == b)
1426 { /* fall through */
1427 stackDrop(pVM->pStack, 1);
1428 vmBranchRelative(pVM, 1);
1429 }
1430 else
1431 { /* take branch to next of or endswitch */
1432 vmBranchRelative(pVM, *(int *)(pVM->ip));
1433 }
1434
1435 return;
1436 }
1437
1438
1439 /**************************************************************************
1440 o f C o I m
1441 ** IMMEDIATE COMPILE-ONLY
1442 **************************************************************************/
1443
ofCoIm(FICL_VM * pVM)1444 static void ofCoIm(FICL_VM *pVM)
1445 {
1446 FICL_DICT *dp = vmGetDict(pVM);
1447 CELL *fallthroughFixup = NULL;
1448
1449 assert(pVM->pSys->pBranch0);
1450
1451 #if FICL_ROBUST > 1
1452 vmCheckStack(pVM, 1, 3);
1453 #endif
1454
1455 if (stackGetTop(pVM->pStack).p == fallthroughTag)
1456 {
1457 matchControlTag(pVM, fallthroughTag);
1458 fallthroughFixup = POPPTR();
1459 }
1460
1461 matchControlTag(pVM, caseTag);
1462
1463 markControlTag(pVM, caseTag);
1464
1465 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen));
1466 markBranch(dp, pVM, ofTag);
1467 dictAppendUNS(dp, 2);
1468
1469 if (fallthroughFixup != NULL)
1470 {
1471 FICL_INT offset = dp->here - fallthroughFixup;
1472 *fallthroughFixup = LVALUEtoCELL(offset);
1473 }
1474
1475 return;
1476 }
1477
1478
1479 /**************************************************************************
1480 e n d o f C o I m
1481 ** IMMEDIATE COMPILE-ONLY
1482 **************************************************************************/
1483
endofCoIm(FICL_VM * pVM)1484 static void endofCoIm(FICL_VM *pVM)
1485 {
1486 CELL *patchAddr;
1487 FICL_UNS fixupCount;
1488 FICL_INT offset;
1489 FICL_DICT *dp = vmGetDict(pVM);
1490
1491 #if FICL_ROBUST > 1
1492 vmCheckStack(pVM, 4, 3);
1493 #endif
1494
1495 assert(pVM->pSys->pBranchParen);
1496
1497 /* ensure we're in an OF, */
1498 matchControlTag(pVM, ofTag);
1499 /* grab the address of the branch location after the OF */
1500 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1501 /* ensure we're also in a "case" */
1502 matchControlTag(pVM, caseTag);
1503 /* grab the current number of ENDOF fixups */
1504 fixupCount = POPUNS();
1505
1506 /* compile branch runtime */
1507 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1508
1509 /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */
1510 PUSHPTR(dp->here);
1511 PUSHUNS(fixupCount + 1);
1512 markControlTag(pVM, caseTag);
1513
1514 /* reserve space for the ENDOF fixup */
1515 dictAppendUNS(dp, 2);
1516
1517 /* and patch the original OF */
1518 offset = dp->here - patchAddr;
1519 *patchAddr = LVALUEtoCELL(offset);
1520 }
1521
1522
1523 /**************************************************************************
1524 f a l l t h r o u g h C o I m
1525 ** IMMEDIATE COMPILE-ONLY
1526 **************************************************************************/
1527
fallthroughCoIm(FICL_VM * pVM)1528 static void fallthroughCoIm(FICL_VM *pVM)
1529 {
1530 CELL *patchAddr;
1531 FICL_INT offset;
1532 FICL_DICT *dp = vmGetDict(pVM);
1533
1534 #if FICL_ROBUST > 1
1535 vmCheckStack(pVM, 4, 3);
1536 #endif
1537
1538 /* ensure we're in an OF, */
1539 matchControlTag(pVM, ofTag);
1540 /* grab the address of the branch location after the OF */
1541 patchAddr = (CELL *)stackPopPtr(pVM->pStack);
1542 /* ensure we're also in a "case" */
1543 matchControlTag(pVM, caseTag);
1544
1545 /* okay, here we go. put the case tag back. */
1546 markControlTag(pVM, caseTag);
1547
1548 /* compile branch runtime */
1549 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
1550
1551 /* push a new FALLTHROUGH fixup and the fallthroughTag */
1552 PUSHPTR(dp->here);
1553 markControlTag(pVM, fallthroughTag);
1554
1555 /* reserve space for the FALLTHROUGH fixup */
1556 dictAppendUNS(dp, 2);
1557
1558 /* and patch the original OF */
1559 offset = dp->here - patchAddr;
1560 *patchAddr = LVALUEtoCELL(offset);
1561 }
1562
1563 /**************************************************************************
1564 h a s h
1565 ** hash ( c-addr u -- code)
1566 ** calculates hashcode of specified string and leaves it on the stack
1567 **************************************************************************/
1568
hash(FICL_VM * pVM)1569 static void hash(FICL_VM *pVM)
1570 {
1571 STRINGINFO si;
1572 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1573 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1574 PUSHUNS(hashHashCode(si));
1575 return;
1576 }
1577
1578
1579 /**************************************************************************
1580 i n t e r p r e t
1581 ** This is the "user interface" of a Forth. It does the following:
1582 ** while there are words in the VM's Text Input Buffer
1583 ** Copy next word into the pad (vmGetWord)
1584 ** Attempt to find the word in the dictionary (dictLookup)
1585 ** If successful, execute the word.
1586 ** Otherwise, attempt to convert the word to a number (isNumber)
1587 ** If successful, push the number onto the parameter stack.
1588 ** Otherwise, print an error message and exit loop...
1589 ** End Loop
1590 **
1591 ** From the standard, section 3.4
1592 ** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1593 ** repeat the following steps until either the parse area is empty or an
1594 ** ambiguous condition exists:
1595 ** a) Skip leading spaces and parse a name (see 3.4.1);
1596 **************************************************************************/
1597
interpret(FICL_VM * pVM)1598 static void interpret(FICL_VM *pVM)
1599 {
1600 STRINGINFO si;
1601 int i;
1602 FICL_SYSTEM *pSys;
1603
1604 assert(pVM);
1605
1606 pSys = pVM->pSys;
1607 si = vmGetWord0(pVM);
1608
1609 /*
1610 ** Get next word...if out of text, we're done.
1611 */
1612 if (si.count == 0)
1613 {
1614 vmThrow(pVM, VM_OUTOFTEXT);
1615 }
1616
1617 /*
1618 ** Attempt to find the incoming token in the dictionary. If that fails...
1619 ** run the parse chain against the incoming token until somebody eats it.
1620 ** Otherwise emit an error message and give up.
1621 ** Although ficlParseWord could be part of the parse list, I've hard coded it
1622 ** in for robustness. ficlInitSystem adds the other default steps to the list.
1623 */
1624 if (ficlParseWord(pVM, si))
1625 return;
1626
1627 for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
1628 {
1629 FICL_WORD *pFW = pSys->parseList[i];
1630
1631 if (pFW == NULL)
1632 break;
1633
1634 if (pFW->code == parseStepParen)
1635 {
1636 FICL_PARSE_STEP pStep;
1637 pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1638 if ((*pStep)(pVM, si))
1639 return;
1640 }
1641 else
1642 {
1643 stackPushPtr(pVM->pStack, SI_PTR(si));
1644 stackPushUNS(pVM->pStack, SI_COUNT(si));
1645 ficlExecXT(pVM, pFW);
1646 if (stackPopINT(pVM->pStack))
1647 return;
1648 }
1649 }
1650
1651 i = SI_COUNT(si);
1652 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1653
1654 return; /* back to inner interpreter */
1655 }
1656
1657
1658 /**************************************************************************
1659 f i c l P a r s e W o r d
1660 ** From the standard, section 3.4
1661 ** b) Search the dictionary name space (see 3.4.2). If a definition name
1662 ** matching the string is found:
1663 ** 1.if interpreting, perform the interpretation semantics of the definition
1664 ** (see 3.4.3.2), and continue at a);
1665 ** 2.if compiling, perform the compilation semantics of the definition
1666 ** (see 3.4.3.3), and continue at a).
1667 **
1668 ** c) If a definition name matching the string is not found, attempt to
1669 ** convert the string to a number (see 3.4.1.3). If successful:
1670 ** 1.if interpreting, place the number on the data stack, and continue at a);
1671 ** 2.if compiling, compile code that when executed will place the number on
1672 ** the stack (see 6.1.1780 LITERAL), and continue at a);
1673 **
1674 ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1675 **
1676 ** (jws 4/01) Modified to be a FICL_PARSE_STEP
1677 **************************************************************************/
ficlParseWord(FICL_VM * pVM,STRINGINFO si)1678 static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
1679 {
1680 FICL_DICT *dp = vmGetDict(pVM);
1681 FICL_WORD *tempFW;
1682
1683 #if FICL_ROBUST
1684 dictCheck(dp, pVM, 0);
1685 vmCheckStack(pVM, 0, 0);
1686 #endif
1687
1688 #if FICL_WANT_LOCALS
1689 if (pVM->pSys->nLocals > 0)
1690 {
1691 tempFW = ficlLookupLoc(pVM->pSys, si);
1692 }
1693 else
1694 #endif
1695 tempFW = dictLookup(dp, si);
1696
1697 if (pVM->state == INTERPRET)
1698 {
1699 if (tempFW != NULL)
1700 {
1701 if (wordIsCompileOnly(tempFW))
1702 {
1703 vmThrowErr(pVM, "Error: Compile only!");
1704 }
1705
1706 vmExecute(pVM, tempFW);
1707 return (int)FICL_TRUE;
1708 }
1709 }
1710
1711 else /* (pVM->state == COMPILE) */
1712 {
1713 if (tempFW != NULL)
1714 {
1715 if (wordIsImmediate(tempFW))
1716 {
1717 vmExecute(pVM, tempFW);
1718 }
1719 else
1720 {
1721 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1722 }
1723 return (int)FICL_TRUE;
1724 }
1725 }
1726
1727 return FICL_FALSE;
1728 }
1729
1730
1731 /*
1732 ** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
1733 ** INTERPRET)
1734 */
lookup(FICL_VM * pVM)1735 static void lookup(FICL_VM *pVM)
1736 {
1737 STRINGINFO si;
1738 SI_SETLEN(si, stackPopUNS(pVM->pStack));
1739 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1740 stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
1741 return;
1742 }
1743
1744
1745 /**************************************************************************
1746 p a r e n P a r s e S t e p
1747 ** (parse-step) ( c-addr u -- flag )
1748 ** runtime for a precompiled parse step - pop a counted string off the
1749 ** stack, run the parse step against it, and push the result flag (FICL_TRUE
1750 ** if success, FICL_FALSE otherwise).
1751 **************************************************************************/
1752
parseStepParen(FICL_VM * pVM)1753 void parseStepParen(FICL_VM *pVM)
1754 {
1755 STRINGINFO si;
1756 FICL_WORD *pFW = pVM->runningWord;
1757 FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
1758
1759 SI_SETLEN(si, stackPopINT(pVM->pStack));
1760 SI_SETPTR(si, stackPopPtr(pVM->pStack));
1761
1762 PUSHINT((*pStep)(pVM, si));
1763
1764 return;
1765 }
1766
1767
addParseStep(FICL_VM * pVM)1768 static void addParseStep(FICL_VM *pVM)
1769 {
1770 FICL_WORD *pStep;
1771 FICL_DICT *pd = vmGetDict(pVM);
1772 #if FICL_ROBUST > 1
1773 vmCheckStack(pVM, 1, 0);
1774 #endif
1775 pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
1776 if ((pStep != NULL) && isAFiclWord(pd, pStep))
1777 ficlAddParseStep(pVM->pSys, pStep);
1778 return;
1779 }
1780
1781
1782 /**************************************************************************
1783 l i t e r a l P a r e n
1784 **
1785 ** This is the runtime for (literal). It assumes that it is part of a colon
1786 ** definition, and that the next CELL contains a value to be pushed on the
1787 ** parameter stack at runtime. This code is compiled by "literal".
1788 **
1789 **************************************************************************/
1790
literalParen(FICL_VM * pVM)1791 static void literalParen(FICL_VM *pVM)
1792 {
1793 #if FICL_ROBUST > 1
1794 vmCheckStack(pVM, 0, 1);
1795 #endif
1796 PUSHINT(*(FICL_INT *)(pVM->ip));
1797 vmBranchRelative(pVM, 1);
1798 return;
1799 }
1800
twoLitParen(FICL_VM * pVM)1801 static void twoLitParen(FICL_VM *pVM)
1802 {
1803 #if FICL_ROBUST > 1
1804 vmCheckStack(pVM, 0, 2);
1805 #endif
1806 PUSHINT(*((FICL_INT *)(pVM->ip)+1));
1807 PUSHINT(*(FICL_INT *)(pVM->ip));
1808 vmBranchRelative(pVM, 2);
1809 return;
1810 }
1811
1812
1813 /**************************************************************************
1814 l i t e r a l I m
1815 **
1816 ** IMMEDIATE code for "literal". This function gets a value from the stack
1817 ** and compiles it into the dictionary preceded by the code for "(literal)".
1818 ** IMMEDIATE
1819 **************************************************************************/
1820
literalIm(FICL_VM * pVM)1821 static void literalIm(FICL_VM *pVM)
1822 {
1823 FICL_DICT *dp = vmGetDict(pVM);
1824 assert(pVM->pSys->pLitParen);
1825
1826 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
1827 dictAppendCell(dp, stackPop(pVM->pStack));
1828
1829 return;
1830 }
1831
1832
twoLiteralIm(FICL_VM * pVM)1833 static void twoLiteralIm(FICL_VM *pVM)
1834 {
1835 FICL_DICT *dp = vmGetDict(pVM);
1836 assert(pVM->pSys->pTwoLitParen);
1837
1838 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
1839 dictAppendCell(dp, stackPop(pVM->pStack));
1840 dictAppendCell(dp, stackPop(pVM->pStack));
1841
1842 return;
1843 }
1844
1845 /**************************************************************************
1846 l o g i c a n d c o m p a r i s o n s
1847 **
1848 **************************************************************************/
1849
zeroEquals(FICL_VM * pVM)1850 static void zeroEquals(FICL_VM *pVM)
1851 {
1852 CELL c;
1853 #if FICL_ROBUST > 1
1854 vmCheckStack(pVM, 1, 1);
1855 #endif
1856 c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
1857 stackPush(pVM->pStack, c);
1858 return;
1859 }
1860
zeroLess(FICL_VM * pVM)1861 static void zeroLess(FICL_VM *pVM)
1862 {
1863 CELL c;
1864 #if FICL_ROBUST > 1
1865 vmCheckStack(pVM, 1, 1);
1866 #endif
1867 c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
1868 stackPush(pVM->pStack, c);
1869 return;
1870 }
1871
zeroGreater(FICL_VM * pVM)1872 static void zeroGreater(FICL_VM *pVM)
1873 {
1874 CELL c;
1875 #if FICL_ROBUST > 1
1876 vmCheckStack(pVM, 1, 1);
1877 #endif
1878 c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
1879 stackPush(pVM->pStack, c);
1880 return;
1881 }
1882
isEqual(FICL_VM * pVM)1883 static void isEqual(FICL_VM *pVM)
1884 {
1885 CELL x, y;
1886
1887 #if FICL_ROBUST > 1
1888 vmCheckStack(pVM, 2, 1);
1889 #endif
1890 x = stackPop(pVM->pStack);
1891 y = stackPop(pVM->pStack);
1892 PUSHINT(FICL_BOOL(x.i == y.i));
1893 return;
1894 }
1895
isLess(FICL_VM * pVM)1896 static void isLess(FICL_VM *pVM)
1897 {
1898 CELL x, y;
1899 #if FICL_ROBUST > 1
1900 vmCheckStack(pVM, 2, 1);
1901 #endif
1902 y = stackPop(pVM->pStack);
1903 x = stackPop(pVM->pStack);
1904 PUSHINT(FICL_BOOL(x.i < y.i));
1905 return;
1906 }
1907
uIsLess(FICL_VM * pVM)1908 static void uIsLess(FICL_VM *pVM)
1909 {
1910 FICL_UNS u1, u2;
1911 #if FICL_ROBUST > 1
1912 vmCheckStack(pVM, 2, 1);
1913 #endif
1914 u2 = stackPopUNS(pVM->pStack);
1915 u1 = stackPopUNS(pVM->pStack);
1916 PUSHINT(FICL_BOOL(u1 < u2));
1917 return;
1918 }
1919
isGreater(FICL_VM * pVM)1920 static void isGreater(FICL_VM *pVM)
1921 {
1922 CELL x, y;
1923 #if FICL_ROBUST > 1
1924 vmCheckStack(pVM, 2, 1);
1925 #endif
1926 y = stackPop(pVM->pStack);
1927 x = stackPop(pVM->pStack);
1928 PUSHINT(FICL_BOOL(x.i > y.i));
1929 return;
1930 }
1931
uIsGreater(FICL_VM * pVM)1932 static void uIsGreater(FICL_VM *pVM)
1933 {
1934 FICL_UNS u1, u2;
1935 #if FICL_ROBUST > 1
1936 vmCheckStack(pVM, 2, 1);
1937 #endif
1938 u2 = stackPopUNS(pVM->pStack);
1939 u1 = stackPopUNS(pVM->pStack);
1940 PUSHINT(FICL_BOOL(u1 > u2));
1941 return;
1942 }
1943
bitwiseAnd(FICL_VM * pVM)1944 static void bitwiseAnd(FICL_VM *pVM)
1945 {
1946 CELL x, y;
1947 #if FICL_ROBUST > 1
1948 vmCheckStack(pVM, 2, 1);
1949 #endif
1950 x = stackPop(pVM->pStack);
1951 y = stackPop(pVM->pStack);
1952 PUSHINT(x.i & y.i);
1953 return;
1954 }
1955
bitwiseOr(FICL_VM * pVM)1956 static void bitwiseOr(FICL_VM *pVM)
1957 {
1958 CELL x, y;
1959 #if FICL_ROBUST > 1
1960 vmCheckStack(pVM, 2, 1);
1961 #endif
1962 x = stackPop(pVM->pStack);
1963 y = stackPop(pVM->pStack);
1964 PUSHINT(x.i | y.i);
1965 return;
1966 }
1967
bitwiseXor(FICL_VM * pVM)1968 static void bitwiseXor(FICL_VM *pVM)
1969 {
1970 CELL x, y;
1971 #if FICL_ROBUST > 1
1972 vmCheckStack(pVM, 2, 1);
1973 #endif
1974 x = stackPop(pVM->pStack);
1975 y = stackPop(pVM->pStack);
1976 PUSHINT(x.i ^ y.i);
1977 return;
1978 }
1979
bitwiseNot(FICL_VM * pVM)1980 static void bitwiseNot(FICL_VM *pVM)
1981 {
1982 CELL x;
1983 #if FICL_ROBUST > 1
1984 vmCheckStack(pVM, 1, 1);
1985 #endif
1986 x = stackPop(pVM->pStack);
1987 PUSHINT(~x.i);
1988 return;
1989 }
1990
1991
1992 /**************************************************************************
1993 D o / L o o p
1994 ** do -- IMMEDIATE COMPILE ONLY
1995 ** Compiles code to initialize a loop: compile (do),
1996 ** allot space to hold the "leave" address, push a branch
1997 ** target address for the loop.
1998 ** (do) -- runtime for "do"
1999 ** pops index and limit from the p stack and moves them
2000 ** to the r stack, then skips to the loop body.
2001 ** loop -- IMMEDIATE COMPILE ONLY
2002 ** +loop
2003 ** Compiles code for the test part of a loop:
2004 ** compile (loop), resolve forward branch from "do", and
2005 ** copy "here" address to the "leave" address allotted by "do"
2006 ** i,j,k -- COMPILE ONLY
2007 ** Runtime: Push loop indices on param stack (i is innermost loop...)
2008 ** Note: each loop has three values on the return stack:
2009 ** ( R: leave limit index )
2010 ** "leave" is the absolute address of the next cell after the loop
2011 ** limit and index are the loop control variables.
2012 ** leave -- COMPILE ONLY
2013 ** Runtime: pop the loop control variables, then pop the
2014 ** "leave" address and jump (absolute) there.
2015 **************************************************************************/
2016
doCoIm(FICL_VM * pVM)2017 static void doCoIm(FICL_VM *pVM)
2018 {
2019 FICL_DICT *dp = vmGetDict(pVM);
2020
2021 assert(pVM->pSys->pDoParen);
2022
2023 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
2024 /*
2025 ** Allot space for a pointer to the end
2026 ** of the loop - "leave" uses this...
2027 */
2028 markBranch(dp, pVM, leaveTag);
2029 dictAppendUNS(dp, 0);
2030 /*
2031 ** Mark location of head of loop...
2032 */
2033 markBranch(dp, pVM, doTag);
2034
2035 return;
2036 }
2037
2038
doParen(FICL_VM * pVM)2039 static void doParen(FICL_VM *pVM)
2040 {
2041 CELL index, limit;
2042 #if FICL_ROBUST > 1
2043 vmCheckStack(pVM, 2, 0);
2044 #endif
2045 index = stackPop(pVM->pStack);
2046 limit = stackPop(pVM->pStack);
2047
2048 /* copy "leave" target addr to stack */
2049 stackPushPtr(pVM->rStack, *(pVM->ip++));
2050 stackPush(pVM->rStack, limit);
2051 stackPush(pVM->rStack, index);
2052
2053 return;
2054 }
2055
2056
qDoCoIm(FICL_VM * pVM)2057 static void qDoCoIm(FICL_VM *pVM)
2058 {
2059 FICL_DICT *dp = vmGetDict(pVM);
2060
2061 assert(pVM->pSys->pQDoParen);
2062
2063 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
2064 /*
2065 ** Allot space for a pointer to the end
2066 ** of the loop - "leave" uses this...
2067 */
2068 markBranch(dp, pVM, leaveTag);
2069 dictAppendUNS(dp, 0);
2070 /*
2071 ** Mark location of head of loop...
2072 */
2073 markBranch(dp, pVM, doTag);
2074
2075 return;
2076 }
2077
2078
qDoParen(FICL_VM * pVM)2079 static void qDoParen(FICL_VM *pVM)
2080 {
2081 CELL index, limit;
2082 #if FICL_ROBUST > 1
2083 vmCheckStack(pVM, 2, 0);
2084 #endif
2085 index = stackPop(pVM->pStack);
2086 limit = stackPop(pVM->pStack);
2087
2088 /* copy "leave" target addr to stack */
2089 stackPushPtr(pVM->rStack, *(pVM->ip++));
2090
2091 if (limit.u == index.u)
2092 {
2093 vmPopIP(pVM);
2094 }
2095 else
2096 {
2097 stackPush(pVM->rStack, limit);
2098 stackPush(pVM->rStack, index);
2099 }
2100
2101 return;
2102 }
2103
2104
2105 /*
2106 ** Runtime code to break out of a do..loop construct
2107 ** Drop the loop control variables; the branch address
2108 ** past "loop" is next on the return stack.
2109 */
leaveCo(FICL_VM * pVM)2110 static void leaveCo(FICL_VM *pVM)
2111 {
2112 /* almost unloop */
2113 stackDrop(pVM->rStack, 2);
2114 /* exit */
2115 vmPopIP(pVM);
2116 return;
2117 }
2118
2119
unloopCo(FICL_VM * pVM)2120 static void unloopCo(FICL_VM *pVM)
2121 {
2122 stackDrop(pVM->rStack, 3);
2123 return;
2124 }
2125
2126
loopCoIm(FICL_VM * pVM)2127 static void loopCoIm(FICL_VM *pVM)
2128 {
2129 FICL_DICT *dp = vmGetDict(pVM);
2130
2131 assert(pVM->pSys->pLoopParen);
2132
2133 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
2134 resolveBackBranch(dp, pVM, doTag);
2135 resolveAbsBranch(dp, pVM, leaveTag);
2136 return;
2137 }
2138
2139
plusLoopCoIm(FICL_VM * pVM)2140 static void plusLoopCoIm(FICL_VM *pVM)
2141 {
2142 FICL_DICT *dp = vmGetDict(pVM);
2143
2144 assert(pVM->pSys->pPLoopParen);
2145
2146 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
2147 resolveBackBranch(dp, pVM, doTag);
2148 resolveAbsBranch(dp, pVM, leaveTag);
2149 return;
2150 }
2151
2152
loopParen(FICL_VM * pVM)2153 static void loopParen(FICL_VM *pVM)
2154 {
2155 FICL_INT index = stackGetTop(pVM->rStack).i;
2156 FICL_INT limit = stackFetch(pVM->rStack, 1).i;
2157
2158 index++;
2159
2160 if (index >= limit)
2161 {
2162 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
2163 vmBranchRelative(pVM, 1); /* fall through the loop */
2164 }
2165 else
2166 { /* update index, branch to loop head */
2167 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
2168 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
2169 }
2170
2171 return;
2172 }
2173
2174
plusLoopParen(FICL_VM * pVM)2175 static void plusLoopParen(FICL_VM *pVM)
2176 {
2177 FICL_INT index,limit,increment;
2178 int flag;
2179
2180 #if FICL_ROBUST > 1
2181 vmCheckStack(pVM, 1, 0);
2182 #endif
2183
2184 index = stackGetTop(pVM->rStack).i;
2185 limit = stackFetch(pVM->rStack, 1).i;
2186 increment = POP().i;
2187
2188 index += increment;
2189
2190 if (increment < 0)
2191 flag = (index < limit);
2192 else
2193 flag = (index >= limit);
2194
2195 if (flag)
2196 {
2197 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
2198 vmBranchRelative(pVM, 1); /* fall through the loop */
2199 }
2200 else
2201 { /* update index, branch to loop head */
2202 stackSetTop(pVM->rStack, LVALUEtoCELL(index));
2203 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
2204 }
2205
2206 return;
2207 }
2208
2209
loopICo(FICL_VM * pVM)2210 static void loopICo(FICL_VM *pVM)
2211 {
2212 CELL index = stackGetTop(pVM->rStack);
2213 stackPush(pVM->pStack, index);
2214
2215 return;
2216 }
2217
2218
loopJCo(FICL_VM * pVM)2219 static void loopJCo(FICL_VM *pVM)
2220 {
2221 CELL index = stackFetch(pVM->rStack, 3);
2222 stackPush(pVM->pStack, index);
2223
2224 return;
2225 }
2226
2227
loopKCo(FICL_VM * pVM)2228 static void loopKCo(FICL_VM *pVM)
2229 {
2230 CELL index = stackFetch(pVM->rStack, 6);
2231 stackPush(pVM->pStack, index);
2232
2233 return;
2234 }
2235
2236
2237 /**************************************************************************
2238 r e t u r n s t a c k
2239 **
2240 **************************************************************************/
toRStack(FICL_VM * pVM)2241 static void toRStack(FICL_VM *pVM)
2242 {
2243 #if FICL_ROBUST > 1
2244 vmCheckStack(pVM, 1, 0);
2245 #endif
2246
2247 stackPush(pVM->rStack, POP());
2248 }
2249
fromRStack(FICL_VM * pVM)2250 static void fromRStack(FICL_VM *pVM)
2251 {
2252 #if FICL_ROBUST > 1
2253 vmCheckStack(pVM, 0, 1);
2254 #endif
2255
2256 PUSH(stackPop(pVM->rStack));
2257 }
2258
fetchRStack(FICL_VM * pVM)2259 static void fetchRStack(FICL_VM *pVM)
2260 {
2261 #if FICL_ROBUST > 1
2262 vmCheckStack(pVM, 0, 1);
2263 #endif
2264
2265 PUSH(stackGetTop(pVM->rStack));
2266 }
2267
twoToR(FICL_VM * pVM)2268 static void twoToR(FICL_VM *pVM)
2269 {
2270 #if FICL_ROBUST > 1
2271 vmCheckStack(pVM, 2, 0);
2272 #endif
2273 stackRoll(pVM->pStack, 1);
2274 stackPush(pVM->rStack, stackPop(pVM->pStack));
2275 stackPush(pVM->rStack, stackPop(pVM->pStack));
2276 return;
2277 }
2278
twoRFrom(FICL_VM * pVM)2279 static void twoRFrom(FICL_VM *pVM)
2280 {
2281 #if FICL_ROBUST > 1
2282 vmCheckStack(pVM, 0, 2);
2283 #endif
2284 stackPush(pVM->pStack, stackPop(pVM->rStack));
2285 stackPush(pVM->pStack, stackPop(pVM->rStack));
2286 stackRoll(pVM->pStack, 1);
2287 return;
2288 }
2289
twoRFetch(FICL_VM * pVM)2290 static void twoRFetch(FICL_VM *pVM)
2291 {
2292 #if FICL_ROBUST > 1
2293 vmCheckStack(pVM, 0, 2);
2294 #endif
2295 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
2296 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
2297 return;
2298 }
2299
2300
2301 /**************************************************************************
2302 v a r i a b l e
2303 **
2304 **************************************************************************/
2305
variableParen(FICL_VM * pVM)2306 static void variableParen(FICL_VM *pVM)
2307 {
2308 FICL_WORD *fw;
2309 #if FICL_ROBUST > 1
2310 vmCheckStack(pVM, 0, 1);
2311 #endif
2312
2313 fw = pVM->runningWord;
2314 PUSHPTR(fw->param);
2315 }
2316
2317
variable(FICL_VM * pVM)2318 static void variable(FICL_VM *pVM)
2319 {
2320 FICL_DICT *dp = vmGetDict(pVM);
2321 STRINGINFO si = vmGetWord(pVM);
2322
2323 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2324 dictAllotCells(dp, 1);
2325 return;
2326 }
2327
2328
twoVariable(FICL_VM * pVM)2329 static void twoVariable(FICL_VM *pVM)
2330 {
2331 FICL_DICT *dp = vmGetDict(pVM);
2332 STRINGINFO si = vmGetWord(pVM);
2333
2334 dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
2335 dictAllotCells(dp, 2);
2336 return;
2337 }
2338
2339
2340 /**************************************************************************
2341 b a s e & f r i e n d s
2342 **
2343 **************************************************************************/
2344
base(FICL_VM * pVM)2345 static void base(FICL_VM *pVM)
2346 {
2347 CELL *pBase;
2348 #if FICL_ROBUST > 1
2349 vmCheckStack(pVM, 0, 1);
2350 #endif
2351
2352 pBase = (CELL *)(&pVM->base);
2353 stackPush(pVM->pStack, LVALUEtoCELL(pBase));
2354 return;
2355 }
2356
2357
decimal(FICL_VM * pVM)2358 static void decimal(FICL_VM *pVM)
2359 {
2360 pVM->base = 10;
2361 return;
2362 }
2363
2364
hex(FICL_VM * pVM)2365 static void hex(FICL_VM *pVM)
2366 {
2367 pVM->base = 16;
2368 return;
2369 }
2370
2371
2372 /**************************************************************************
2373 a l l o t & f r i e n d s
2374 **
2375 **************************************************************************/
2376
allot(FICL_VM * pVM)2377 static void allot(FICL_VM *pVM)
2378 {
2379 FICL_DICT *dp;
2380 FICL_INT i;
2381 #if FICL_ROBUST > 1
2382 vmCheckStack(pVM, 1, 0);
2383 #endif
2384
2385 dp = vmGetDict(pVM);
2386 i = POPINT();
2387
2388 #if FICL_ROBUST
2389 dictCheck(dp, pVM, i);
2390 #endif
2391
2392 dictAllot(dp, i);
2393 return;
2394 }
2395
2396
here(FICL_VM * pVM)2397 static void here(FICL_VM *pVM)
2398 {
2399 FICL_DICT *dp;
2400 #if FICL_ROBUST > 1
2401 vmCheckStack(pVM, 0, 1);
2402 #endif
2403
2404 dp = vmGetDict(pVM);
2405 PUSHPTR(dp->here);
2406 return;
2407 }
2408
comma(FICL_VM * pVM)2409 static void comma(FICL_VM *pVM)
2410 {
2411 FICL_DICT *dp;
2412 CELL c;
2413 #if FICL_ROBUST > 1
2414 vmCheckStack(pVM, 1, 0);
2415 #endif
2416
2417 dp = vmGetDict(pVM);
2418 c = POP();
2419 dictAppendCell(dp, c);
2420 return;
2421 }
2422
cComma(FICL_VM * pVM)2423 static void cComma(FICL_VM *pVM)
2424 {
2425 FICL_DICT *dp;
2426 char c;
2427 #if FICL_ROBUST > 1
2428 vmCheckStack(pVM, 1, 0);
2429 #endif
2430
2431 dp = vmGetDict(pVM);
2432 c = (char)POPINT();
2433 dictAppendChar(dp, c);
2434 return;
2435 }
2436
cells(FICL_VM * pVM)2437 static void cells(FICL_VM *pVM)
2438 {
2439 FICL_INT i;
2440 #if FICL_ROBUST > 1
2441 vmCheckStack(pVM, 1, 1);
2442 #endif
2443
2444 i = POPINT();
2445 PUSHINT(i * (FICL_INT)sizeof (CELL));
2446 return;
2447 }
2448
cellPlus(FICL_VM * pVM)2449 static void cellPlus(FICL_VM *pVM)
2450 {
2451 char *cp;
2452 #if FICL_ROBUST > 1
2453 vmCheckStack(pVM, 1, 1);
2454 #endif
2455
2456 cp = POPPTR();
2457 PUSHPTR(cp + sizeof (CELL));
2458 return;
2459 }
2460
2461
2462
2463 /**************************************************************************
2464 t i c k
2465 ** tick CORE ( "<spaces>name" -- xt )
2466 ** Skip leading space delimiters. Parse name delimited by a space. Find
2467 ** name and return xt, the execution token for name. An ambiguous condition
2468 ** exists if name is not found.
2469 **************************************************************************/
ficlTick(FICL_VM * pVM)2470 void ficlTick(FICL_VM *pVM)
2471 {
2472 FICL_WORD *pFW = NULL;
2473 STRINGINFO si = vmGetWord(pVM);
2474 #if FICL_ROBUST > 1
2475 vmCheckStack(pVM, 0, 1);
2476 #endif
2477
2478 pFW = dictLookup(vmGetDict(pVM), si);
2479 if (!pFW)
2480 {
2481 int i = SI_COUNT(si);
2482 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2483 }
2484 PUSHPTR(pFW);
2485 return;
2486 }
2487
2488
bracketTickCoIm(FICL_VM * pVM)2489 static void bracketTickCoIm(FICL_VM *pVM)
2490 {
2491 ficlTick(pVM);
2492 literalIm(pVM);
2493
2494 return;
2495 }
2496
2497
2498 /**************************************************************************
2499 p o s t p o n e
2500 ** Lookup the next word in the input stream and compile code to
2501 ** insert it into definitions created by the resulting word
2502 ** (defers compilation, even of immediate words)
2503 **************************************************************************/
2504
postponeCoIm(FICL_VM * pVM)2505 static void postponeCoIm(FICL_VM *pVM)
2506 {
2507 FICL_DICT *dp = vmGetDict(pVM);
2508 FICL_WORD *pFW;
2509 FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
2510 assert(pComma);
2511
2512 ficlTick(pVM);
2513 pFW = stackGetTop(pVM->pStack).p;
2514 if (wordIsImmediate(pFW))
2515 {
2516 dictAppendCell(dp, stackPop(pVM->pStack));
2517 }
2518 else
2519 {
2520 literalIm(pVM);
2521 dictAppendCell(dp, LVALUEtoCELL(pComma));
2522 }
2523
2524 return;
2525 }
2526
2527
2528
2529 /**************************************************************************
2530 e x e c u t e
2531 ** Pop an execution token (pointer to a word) off the stack and
2532 ** run it
2533 **************************************************************************/
2534
execute(FICL_VM * pVM)2535 static void execute(FICL_VM *pVM)
2536 {
2537 FICL_WORD *pFW;
2538 #if FICL_ROBUST > 1
2539 vmCheckStack(pVM, 1, 0);
2540 #endif
2541
2542 pFW = stackPopPtr(pVM->pStack);
2543 vmExecute(pVM, pFW);
2544
2545 return;
2546 }
2547
2548
2549 /**************************************************************************
2550 i m m e d i a t e
2551 ** Make the most recently compiled word IMMEDIATE -- it executes even
2552 ** in compile state (most often used for control compiling words
2553 ** such as IF, THEN, etc)
2554 **************************************************************************/
2555
immediate(FICL_VM * pVM)2556 static void immediate(FICL_VM *pVM)
2557 {
2558 IGNORE(pVM);
2559 dictSetImmediate(vmGetDict(pVM));
2560 return;
2561 }
2562
2563
compileOnly(FICL_VM * pVM)2564 static void compileOnly(FICL_VM *pVM)
2565 {
2566 IGNORE(pVM);
2567 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
2568 return;
2569 }
2570
2571
setObjectFlag(FICL_VM * pVM)2572 static void setObjectFlag(FICL_VM *pVM)
2573 {
2574 IGNORE(pVM);
2575 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
2576 return;
2577 }
2578
isObject(FICL_VM * pVM)2579 static void isObject(FICL_VM *pVM)
2580 {
2581 FICL_INT flag;
2582 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
2583
2584 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
2585 stackPushINT(pVM->pStack, flag);
2586 return;
2587 }
2588
cstringLit(FICL_VM * pVM)2589 static void cstringLit(FICL_VM *pVM)
2590 {
2591 FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2592
2593 char *cp = sp->text;
2594 cp += sp->count + 1;
2595 cp = alignPtr(cp);
2596 pVM->ip = (IPTYPE)(void *)cp;
2597
2598 stackPushPtr(pVM->pStack, sp);
2599 return;
2600 }
2601
2602
cstringQuoteIm(FICL_VM * pVM)2603 static void cstringQuoteIm(FICL_VM *pVM)
2604 {
2605 FICL_DICT *dp = vmGetDict(pVM);
2606
2607 if (pVM->state == INTERPRET)
2608 {
2609 FICL_STRING *sp = (FICL_STRING *) dp->here;
2610 vmGetString(pVM, sp, '\"');
2611 stackPushPtr(pVM->pStack, sp);
2612 /* move HERE past string so it doesn't get overwritten. --lch */
2613 dictAllot(dp, sp->count + sizeof(FICL_COUNT));
2614 }
2615 else /* COMPILE state */
2616 {
2617 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
2618 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2619 dictAlign(dp);
2620 }
2621
2622 return;
2623 }
2624
2625 /**************************************************************************
2626 d o t Q u o t e
2627 ** IMMEDIATE word that compiles a string literal for later display
2628 ** Compile stringLit, then copy the bytes of the string from the TIB
2629 ** to the dictionary. Backpatch the count byte and align the dictionary.
2630 **
2631 ** stringlit: Fetch the count from the dictionary, then push the address
2632 ** and count on the stack. Finally, update ip to point to the first
2633 ** aligned address after the string text.
2634 **************************************************************************/
2635
stringLit(FICL_VM * pVM)2636 static void stringLit(FICL_VM *pVM)
2637 {
2638 FICL_STRING *sp;
2639 FICL_COUNT count;
2640 char *cp;
2641 #if FICL_ROBUST > 1
2642 vmCheckStack(pVM, 0, 2);
2643 #endif
2644
2645 sp = (FICL_STRING *)(pVM->ip);
2646 count = sp->count;
2647 cp = sp->text;
2648 PUSHPTR(cp);
2649 PUSHUNS(count);
2650 cp += count + 1;
2651 cp = alignPtr(cp);
2652 pVM->ip = (IPTYPE)(void *)cp;
2653 }
2654
dotQuoteCoIm(FICL_VM * pVM)2655 static void dotQuoteCoIm(FICL_VM *pVM)
2656 {
2657 FICL_DICT *dp = vmGetDict(pVM);
2658 FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
2659 assert(pType);
2660 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2661 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2662 dictAlign(dp);
2663 dictAppendCell(dp, LVALUEtoCELL(pType));
2664 return;
2665 }
2666
2667
dotParen(FICL_VM * pVM)2668 static void dotParen(FICL_VM *pVM)
2669 {
2670 char *pSrc = vmGetInBuf(pVM);
2671 char *pEnd = vmGetInBufEnd(pVM);
2672 char *pDest = pVM->pad;
2673 char ch;
2674
2675 /*
2676 ** Note: the standard does not want leading spaces skipped (apparently)
2677 */
2678 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2679 *pDest++ = ch;
2680
2681 *pDest = '\0';
2682 if ((pEnd != pSrc) && (ch == ')'))
2683 pSrc++;
2684
2685 vmTextOut(pVM, pVM->pad, 0);
2686 vmUpdateTib(pVM, pSrc);
2687
2688 return;
2689 }
2690
2691
2692 /**************************************************************************
2693 s l i t e r a l
2694 ** STRING
2695 ** Interpretation: Interpretation semantics for this word are undefined.
2696 ** Compilation: ( c-addr1 u -- )
2697 ** Append the run-time semantics given below to the current definition.
2698 ** Run-time: ( -- c-addr2 u )
2699 ** Return c-addr2 u describing a string consisting of the characters
2700 ** specified by c-addr1 u during compilation. A program shall not alter
2701 ** the returned string.
2702 **************************************************************************/
sLiteralCoIm(FICL_VM * pVM)2703 static void sLiteralCoIm(FICL_VM *pVM)
2704 {
2705 FICL_DICT *dp;
2706 char *cp, *cpDest;
2707 FICL_UNS u;
2708
2709 #if FICL_ROBUST > 1
2710 vmCheckStack(pVM, 2, 0);
2711 #endif
2712
2713 dp = vmGetDict(pVM);
2714 u = POPUNS();
2715 cp = POPPTR();
2716
2717 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
2718 cpDest = (char *) dp->here;
2719 *cpDest++ = (char) u;
2720
2721 for (; u > 0; --u)
2722 {
2723 *cpDest++ = *cp++;
2724 }
2725
2726 *cpDest++ = 0;
2727 dp->here = PTRtoCELL alignPtr(cpDest);
2728 return;
2729 }
2730
2731
2732 /**************************************************************************
2733 s t a t e
2734 ** Return the address of the VM's state member (must be sized the
2735 ** same as a CELL for this reason)
2736 **************************************************************************/
state(FICL_VM * pVM)2737 static void state(FICL_VM *pVM)
2738 {
2739 #if FICL_ROBUST > 1
2740 vmCheckStack(pVM, 0, 1);
2741 #endif
2742 PUSHPTR(&pVM->state);
2743 return;
2744 }
2745
2746
2747 /**************************************************************************
2748 c r e a t e . . . d o e s >
2749 ** Make a new word in the dictionary with the run-time effect of
2750 ** a variable (push my address), but with extra space allotted
2751 ** for use by does> .
2752 **************************************************************************/
2753
createParen(FICL_VM * pVM)2754 static void createParen(FICL_VM *pVM)
2755 {
2756 CELL *pCell;
2757
2758 #if FICL_ROBUST > 1
2759 vmCheckStack(pVM, 0, 1);
2760 #endif
2761
2762 pCell = pVM->runningWord->param;
2763 PUSHPTR(pCell+1);
2764 return;
2765 }
2766
2767
create(FICL_VM * pVM)2768 static void create(FICL_VM *pVM)
2769 {
2770 FICL_DICT *dp = vmGetDict(pVM);
2771 STRINGINFO si = vmGetWord(pVM);
2772
2773 dictCheckThreshold(dp);
2774
2775 dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2776 dictAllotCells(dp, 1);
2777 return;
2778 }
2779
2780
doDoes(FICL_VM * pVM)2781 static void doDoes(FICL_VM *pVM)
2782 {
2783 CELL *pCell;
2784 IPTYPE tempIP;
2785 #if FICL_ROBUST > 1
2786 vmCheckStack(pVM, 0, 1);
2787 #endif
2788
2789 pCell = pVM->runningWord->param;
2790 tempIP = (IPTYPE)((*pCell).p);
2791 PUSHPTR(pCell+1);
2792 vmPushIP(pVM, tempIP);
2793 return;
2794 }
2795
2796
doesParen(FICL_VM * pVM)2797 static void doesParen(FICL_VM *pVM)
2798 {
2799 FICL_DICT *dp = vmGetDict(pVM);
2800 dp->smudge->code = doDoes;
2801 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2802 vmPopIP(pVM);
2803 return;
2804 }
2805
2806
doesCoIm(FICL_VM * pVM)2807 static void doesCoIm(FICL_VM *pVM)
2808 {
2809 FICL_DICT *dp = vmGetDict(pVM);
2810 #if FICL_WANT_LOCALS
2811 assert(pVM->pSys->pUnLinkParen);
2812 if (pVM->pSys->nLocals > 0)
2813 {
2814 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
2815 dictEmpty(pLoc, pLoc->pForthWords->size);
2816 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
2817 }
2818
2819 pVM->pSys->nLocals = 0;
2820 #endif
2821 IGNORE(pVM);
2822
2823 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
2824 return;
2825 }
2826
2827
2828 /**************************************************************************
2829 t o b o d y
2830 ** to-body CORE ( xt -- a-addr )
2831 ** a-addr is the data-field address corresponding to xt. An ambiguous
2832 ** condition exists if xt is not for a word defined via CREATE.
2833 **************************************************************************/
toBody(FICL_VM * pVM)2834 static void toBody(FICL_VM *pVM)
2835 {
2836 FICL_WORD *pFW;
2837 /*#$-GUY CHANGE: Added robustness.-$#*/
2838 #if FICL_ROBUST > 1
2839 vmCheckStack(pVM, 1, 1);
2840 #endif
2841
2842 pFW = POPPTR();
2843 PUSHPTR(pFW->param + 1);
2844 return;
2845 }
2846
2847
2848 /*
2849 ** from-body ficl ( a-addr -- xt )
2850 ** Reverse effect of >body
2851 */
fromBody(FICL_VM * pVM)2852 static void fromBody(FICL_VM *pVM)
2853 {
2854 char *ptr;
2855 #if FICL_ROBUST > 1
2856 vmCheckStack(pVM, 1, 1);
2857 #endif
2858
2859 ptr = (char *)POPPTR() - sizeof (FICL_WORD);
2860 PUSHPTR(ptr);
2861 return;
2862 }
2863
2864
2865 /*
2866 ** >name ficl ( xt -- c-addr u )
2867 ** Push the address and length of a word's name given its address
2868 ** xt.
2869 */
toName(FICL_VM * pVM)2870 static void toName(FICL_VM *pVM)
2871 {
2872 FICL_WORD *pFW;
2873 #if FICL_ROBUST > 1
2874 vmCheckStack(pVM, 1, 2);
2875 #endif
2876
2877 pFW = POPPTR();
2878 PUSHPTR(pFW->name);
2879 PUSHUNS(pFW->nName);
2880 return;
2881 }
2882
2883
getLastWord(FICL_VM * pVM)2884 static void getLastWord(FICL_VM *pVM)
2885 {
2886 FICL_DICT *pDict = vmGetDict(pVM);
2887 FICL_WORD *wp = pDict->smudge;
2888 assert(wp);
2889 vmPush(pVM, LVALUEtoCELL(wp));
2890 return;
2891 }
2892
2893
2894 /**************************************************************************
2895 l b r a c k e t e t c
2896 **
2897 **************************************************************************/
2898
lbracketCoIm(FICL_VM * pVM)2899 static void lbracketCoIm(FICL_VM *pVM)
2900 {
2901 pVM->state = INTERPRET;
2902 return;
2903 }
2904
2905
rbracket(FICL_VM * pVM)2906 static void rbracket(FICL_VM *pVM)
2907 {
2908 pVM->state = COMPILE;
2909 return;
2910 }
2911
2912
2913 /**************************************************************************
2914 p i c t u r e d n u m e r i c w o r d s
2915 **
2916 ** less-number-sign CORE ( -- )
2917 ** Initialize the pictured numeric output conversion process.
2918 ** (clear the pad)
2919 **************************************************************************/
lessNumberSign(FICL_VM * pVM)2920 static void lessNumberSign(FICL_VM *pVM)
2921 {
2922 FICL_STRING *sp = PTRtoSTRING pVM->pad;
2923 sp->count = 0;
2924 return;
2925 }
2926
2927 /*
2928 ** number-sign CORE ( ud1 -- ud2 )
2929 ** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2930 ** n. (n is the least-significant digit of ud1.) Convert n to external form
2931 ** and add the resulting character to the beginning of the pictured numeric
2932 ** output string. An ambiguous condition exists if # executes outside of a
2933 ** <# #> delimited number conversion.
2934 */
numberSign(FICL_VM * pVM)2935 static void numberSign(FICL_VM *pVM)
2936 {
2937 FICL_STRING *sp;
2938 DPUNS u;
2939 UNS16 rem;
2940 #if FICL_ROBUST > 1
2941 vmCheckStack(pVM, 2, 2);
2942 #endif
2943
2944 sp = PTRtoSTRING pVM->pad;
2945 u = u64Pop(pVM->pStack);
2946 rem = m64UMod(&u, (UNS16)(pVM->base));
2947 sp->text[sp->count++] = digit_to_char(rem);
2948 u64Push(pVM->pStack, u);
2949 return;
2950 }
2951
2952 /*
2953 ** number-sign-greater CORE ( xd -- c-addr u )
2954 ** Drop xd. Make the pictured numeric output string available as a character
2955 ** string. c-addr and u specify the resulting character string. A program
2956 ** may replace characters within the string.
2957 */
numberSignGreater(FICL_VM * pVM)2958 static void numberSignGreater(FICL_VM *pVM)
2959 {
2960 FICL_STRING *sp;
2961 #if FICL_ROBUST > 1
2962 vmCheckStack(pVM, 2, 2);
2963 #endif
2964
2965 sp = PTRtoSTRING pVM->pad;
2966 sp->text[sp->count] = 0;
2967 strrev(sp->text);
2968 DROP(2);
2969 PUSHPTR(sp->text);
2970 PUSHUNS(sp->count);
2971 return;
2972 }
2973
2974 /*
2975 ** number-sign-s CORE ( ud1 -- ud2 )
2976 ** Convert one digit of ud1 according to the rule for #. Continue conversion
2977 ** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2978 ** #S executes outside of a <# #> delimited number conversion.
2979 ** TO DO: presently does not use ud1 hi cell - use it!
2980 */
numberSignS(FICL_VM * pVM)2981 static void numberSignS(FICL_VM *pVM)
2982 {
2983 FICL_STRING *sp;
2984 DPUNS u;
2985 UNS16 rem;
2986 #if FICL_ROBUST > 1
2987 vmCheckStack(pVM, 2, 2);
2988 #endif
2989
2990 sp = PTRtoSTRING pVM->pad;
2991 u = u64Pop(pVM->pStack);
2992
2993 do
2994 {
2995 rem = m64UMod(&u, (UNS16)(pVM->base));
2996 sp->text[sp->count++] = digit_to_char(rem);
2997 }
2998 while (u.hi || u.lo);
2999
3000 u64Push(pVM->pStack, u);
3001 return;
3002 }
3003
3004 /*
3005 ** HOLD CORE ( char -- )
3006 ** Add char to the beginning of the pictured numeric output string. An ambiguous
3007 ** condition exists if HOLD executes outside of a <# #> delimited number conversion.
3008 */
hold(FICL_VM * pVM)3009 static void hold(FICL_VM *pVM)
3010 {
3011 FICL_STRING *sp;
3012 int i;
3013 #if FICL_ROBUST > 1
3014 vmCheckStack(pVM, 1, 0);
3015 #endif
3016
3017 sp = PTRtoSTRING pVM->pad;
3018 i = POPINT();
3019 sp->text[sp->count++] = (char) i;
3020 return;
3021 }
3022
3023 /*
3024 ** SIGN CORE ( n -- )
3025 ** If n is negative, add a minus sign to the beginning of the pictured
3026 ** numeric output string. An ambiguous condition exists if SIGN
3027 ** executes outside of a <# #> delimited number conversion.
3028 */
sign(FICL_VM * pVM)3029 static void sign(FICL_VM *pVM)
3030 {
3031 FICL_STRING *sp;
3032 int i;
3033 #if FICL_ROBUST > 1
3034 vmCheckStack(pVM, 1, 0);
3035 #endif
3036
3037 sp = PTRtoSTRING pVM->pad;
3038 i = POPINT();
3039 if (i < 0)
3040 sp->text[sp->count++] = '-';
3041 return;
3042 }
3043
3044
3045 /**************************************************************************
3046 t o N u m b e r
3047 ** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
3048 ** ud2 is the unsigned result of converting the characters within the
3049 ** string specified by c-addr1 u1 into digits, using the number in BASE,
3050 ** and adding each into ud1 after multiplying ud1 by the number in BASE.
3051 ** Conversion continues left-to-right until a character that is not
3052 ** convertible, including any + or -, is encountered or the string is
3053 ** entirely converted. c-addr2 is the location of the first unconverted
3054 ** character or the first character past the end of the string if the string
3055 ** was entirely converted. u2 is the number of unconverted characters in the
3056 ** string. An ambiguous condition exists if ud2 overflows during the
3057 ** conversion.
3058 **************************************************************************/
toNumber(FICL_VM * pVM)3059 static void toNumber(FICL_VM *pVM)
3060 {
3061 FICL_UNS count;
3062 char *cp;
3063 DPUNS accum;
3064 FICL_UNS base = pVM->base;
3065 FICL_UNS ch;
3066 FICL_UNS digit;
3067
3068 #if FICL_ROBUST > 1
3069 vmCheckStack(pVM,4,4);
3070 #endif
3071
3072 count = POPUNS();
3073 cp = (char *)POPPTR();
3074 accum = u64Pop(pVM->pStack);
3075
3076 for (ch = *cp; count > 0; ch = *++cp, count--)
3077 {
3078 if (ch < '0')
3079 break;
3080
3081 digit = ch - '0';
3082
3083 if (digit > 9)
3084 digit = tolower(ch) - 'a' + 10;
3085 /*
3086 ** Note: following test also catches chars between 9 and a
3087 ** because 'digit' is unsigned!
3088 */
3089 if (digit >= base)
3090 break;
3091
3092 accum = m64Mac(accum, base, digit);
3093 }
3094
3095 u64Push(pVM->pStack, accum);
3096 PUSHPTR(cp);
3097 PUSHUNS(count);
3098
3099 return;
3100 }
3101
3102
3103
3104 /**************************************************************************
3105 q u i t & a b o r t
3106 ** quit CORE ( -- ) ( R: i*x -- )
3107 ** Empty the return stack, store zero in SOURCE-ID if it is present, make
3108 ** the user input device the input source, and enter interpretation state.
3109 ** Do not display a message. Repeat the following:
3110 **
3111 ** Accept a line from the input source into the input buffer, set >IN to
3112 ** zero, and interpret.
3113 ** Display the implementation-defined system prompt if in
3114 ** interpretation state, all processing has been completed, and no
3115 ** ambiguous condition exists.
3116 **************************************************************************/
3117
quit(FICL_VM * pVM)3118 static void quit(FICL_VM *pVM)
3119 {
3120 vmThrow(pVM, VM_QUIT);
3121 return;
3122 }
3123
3124
ficlAbort(FICL_VM * pVM)3125 static void ficlAbort(FICL_VM *pVM)
3126 {
3127 vmThrow(pVM, VM_ABORT);
3128 return;
3129 }
3130
3131
3132 /**************************************************************************
3133 a c c e p t
3134 ** accept CORE ( c-addr +n1 -- +n2 )
3135 ** Receive a string of at most +n1 characters. An ambiguous condition
3136 ** exists if +n1 is zero or greater than 32,767. Display graphic characters
3137 ** as they are received. A program that depends on the presence or absence
3138 ** of non-graphic characters in the string has an environmental dependency.
3139 ** The editing functions, if any, that the system performs in order to
3140 ** construct the string are implementation-defined.
3141 **
3142 ** (Although the standard text doesn't say so, I assume that the intent
3143 ** of 'accept' is to store the string at the address specified on
3144 ** the stack.)
3145 ** Implementation: if there's more text in the TIB, use it. Otherwise
3146 ** throw out for more text. Copy characters up to the max count into the
3147 ** address given, and return the number of actual characters copied.
3148 **
3149 ** Note (sobral) this may not be the behavior you'd expect if you're
3150 ** trying to get user input at load time!
3151 **************************************************************************/
accept(FICL_VM * pVM)3152 static void accept(FICL_VM *pVM)
3153 {
3154 FICL_UNS count, len;
3155 char *cp;
3156 char *pBuf, *pEnd;
3157
3158 #if FICL_ROBUST > 1
3159 vmCheckStack(pVM,2,1);
3160 #endif
3161
3162 pBuf = vmGetInBuf(pVM);
3163 pEnd = vmGetInBufEnd(pVM);
3164 len = pEnd - pBuf;
3165 if (len == 0)
3166 vmThrow(pVM, VM_RESTART);
3167
3168 /*
3169 ** Now we have something in the text buffer - use it
3170 */
3171 count = stackPopINT(pVM->pStack);
3172 cp = stackPopPtr(pVM->pStack);
3173
3174 len = (count < len) ? count : len;
3175 strncpy(cp, vmGetInBuf(pVM), len);
3176 pBuf += len;
3177 vmUpdateTib(pVM, pBuf);
3178 PUSHINT(len);
3179
3180 return;
3181 }
3182
3183
3184 /**************************************************************************
3185 a l i g n
3186 ** 6.1.0705 ALIGN CORE ( -- )
3187 ** If the data-space pointer is not aligned, reserve enough space to
3188 ** align it.
3189 **************************************************************************/
align(FICL_VM * pVM)3190 static void align(FICL_VM *pVM)
3191 {
3192 FICL_DICT *dp = vmGetDict(pVM);
3193 IGNORE(pVM);
3194 dictAlign(dp);
3195 return;
3196 }
3197
3198
3199 /**************************************************************************
3200 a l i g n e d
3201 **
3202 **************************************************************************/
aligned(FICL_VM * pVM)3203 static void aligned(FICL_VM *pVM)
3204 {
3205 void *addr;
3206 #if FICL_ROBUST > 1
3207 vmCheckStack(pVM,1,1);
3208 #endif
3209
3210 addr = POPPTR();
3211 PUSHPTR(alignPtr(addr));
3212 return;
3213 }
3214
3215
3216 /**************************************************************************
3217 b e g i n & f r i e n d s
3218 ** Indefinite loop control structures
3219 ** A.6.1.0760 BEGIN
3220 ** Typical use:
3221 ** : X ... BEGIN ... test UNTIL ;
3222 ** or
3223 ** : X ... BEGIN ... test WHILE ... REPEAT ;
3224 **************************************************************************/
beginCoIm(FICL_VM * pVM)3225 static void beginCoIm(FICL_VM *pVM)
3226 {
3227 FICL_DICT *dp = vmGetDict(pVM);
3228 markBranch(dp, pVM, destTag);
3229 return;
3230 }
3231
untilCoIm(FICL_VM * pVM)3232 static void untilCoIm(FICL_VM *pVM)
3233 {
3234 FICL_DICT *dp = vmGetDict(pVM);
3235
3236 assert(pVM->pSys->pBranch0);
3237
3238 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
3239 resolveBackBranch(dp, pVM, destTag);
3240 return;
3241 }
3242
whileCoIm(FICL_VM * pVM)3243 static void whileCoIm(FICL_VM *pVM)
3244 {
3245 FICL_DICT *dp = vmGetDict(pVM);
3246
3247 assert(pVM->pSys->pBranch0);
3248
3249 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
3250 markBranch(dp, pVM, origTag);
3251 twoSwap(pVM);
3252 dictAppendUNS(dp, 1);
3253 return;
3254 }
3255
repeatCoIm(FICL_VM * pVM)3256 static void repeatCoIm(FICL_VM *pVM)
3257 {
3258 FICL_DICT *dp = vmGetDict(pVM);
3259
3260 assert(pVM->pSys->pBranchParen);
3261 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3262
3263 /* expect "begin" branch marker */
3264 resolveBackBranch(dp, pVM, destTag);
3265 /* expect "while" branch marker */
3266 resolveForwardBranch(dp, pVM, origTag);
3267 return;
3268 }
3269
3270
againCoIm(FICL_VM * pVM)3271 static void againCoIm(FICL_VM *pVM)
3272 {
3273 FICL_DICT *dp = vmGetDict(pVM);
3274
3275 assert(pVM->pSys->pBranchParen);
3276 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
3277
3278 /* expect "begin" branch marker */
3279 resolveBackBranch(dp, pVM, destTag);
3280 return;
3281 }
3282
3283
3284 /**************************************************************************
3285 c h a r & f r i e n d s
3286 ** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
3287 ** Skip leading space delimiters. Parse name delimited by a space.
3288 ** Put the value of its first character onto the stack.
3289 **
3290 ** bracket-char CORE
3291 ** Interpretation: Interpretation semantics for this word are undefined.
3292 ** Compilation: ( "<spaces>name" -- )
3293 ** Skip leading space delimiters. Parse name delimited by a space.
3294 ** Append the run-time semantics given below to the current definition.
3295 ** Run-time: ( -- char )
3296 ** Place char, the value of the first character of name, on the stack.
3297 **************************************************************************/
ficlChar(FICL_VM * pVM)3298 static void ficlChar(FICL_VM *pVM)
3299 {
3300 STRINGINFO si;
3301 #if FICL_ROBUST > 1
3302 vmCheckStack(pVM,0,1);
3303 #endif
3304
3305 si = vmGetWord(pVM);
3306 PUSHUNS((FICL_UNS)(si.cp[0]));
3307 return;
3308 }
3309
charCoIm(FICL_VM * pVM)3310 static void charCoIm(FICL_VM *pVM)
3311 {
3312 ficlChar(pVM);
3313 literalIm(pVM);
3314 return;
3315 }
3316
3317 /**************************************************************************
3318 c h a r P l u s
3319 ** char-plus CORE ( c-addr1 -- c-addr2 )
3320 ** Add the size in address units of a character to c-addr1, giving c-addr2.
3321 **************************************************************************/
charPlus(FICL_VM * pVM)3322 static void charPlus(FICL_VM *pVM)
3323 {
3324 char *cp;
3325 #if FICL_ROBUST > 1
3326 vmCheckStack(pVM,1,1);
3327 #endif
3328
3329 cp = POPPTR();
3330 PUSHPTR(cp + 1);
3331 return;
3332 }
3333
3334 /**************************************************************************
3335 c h a r s
3336 ** chars CORE ( n1 -- n2 )
3337 ** n2 is the size in address units of n1 characters.
3338 ** For most processors, this function can be a no-op. To guarantee
3339 ** portability, we'll multiply by sizeof (char).
3340 **************************************************************************/
3341 #if defined (_M_IX86)
3342 #pragma warning(disable: 4127)
3343 #endif
ficlChars(FICL_VM * pVM)3344 static void ficlChars(FICL_VM *pVM)
3345 {
3346 if (sizeof (char) > 1)
3347 {
3348 FICL_INT i;
3349 #if FICL_ROBUST > 1
3350 vmCheckStack(pVM,1,1);
3351 #endif
3352 i = POPINT();
3353 PUSHINT(i * sizeof (char));
3354 }
3355 /* otherwise no-op! */
3356 return;
3357 }
3358 #if defined (_M_IX86)
3359 #pragma warning(default: 4127)
3360 #endif
3361
3362
3363 /**************************************************************************
3364 c o u n t
3365 ** COUNT CORE ( c-addr1 -- c-addr2 u )
3366 ** Return the character string specification for the counted string stored
3367 ** at c-addr1. c-addr2 is the address of the first character after c-addr1.
3368 ** u is the contents of the character at c-addr1, which is the length in
3369 ** characters of the string at c-addr2.
3370 **************************************************************************/
count(FICL_VM * pVM)3371 static void count(FICL_VM *pVM)
3372 {
3373 FICL_STRING *sp;
3374 #if FICL_ROBUST > 1
3375 vmCheckStack(pVM,1,2);
3376 #endif
3377
3378 sp = POPPTR();
3379 PUSHPTR(sp->text);
3380 PUSHUNS(sp->count);
3381 return;
3382 }
3383
3384 /**************************************************************************
3385 e n v i r o n m e n t ?
3386 ** environment-query CORE ( c-addr u -- false | i*x true )
3387 ** c-addr is the address of a character string and u is the string's
3388 ** character count. u may have a value in the range from zero to an
3389 ** implementation-defined maximum which shall not be less than 31. The
3390 ** character string should contain a keyword from 3.2.6 Environmental
3391 ** queries or the optional word sets to be checked for correspondence
3392 ** with an attribute of the present environment. If the system treats the
3393 ** attribute as unknown, the returned flag is false; otherwise, the flag
3394 ** is true and the i*x returned is of the type specified in the table for
3395 ** the attribute queried.
3396 **************************************************************************/
environmentQ(FICL_VM * pVM)3397 static void environmentQ(FICL_VM *pVM)
3398 {
3399 FICL_DICT *envp;
3400 FICL_WORD *pFW;
3401 STRINGINFO si;
3402 #if FICL_ROBUST > 1
3403 vmCheckStack(pVM,2,1);
3404 #endif
3405
3406 envp = pVM->pSys->envp;
3407 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
3408 si.cp = stackPopPtr(pVM->pStack);
3409
3410 pFW = dictLookup(envp, si);
3411
3412 if (pFW != NULL)
3413 {
3414 vmExecute(pVM, pFW);
3415 PUSHINT(FICL_TRUE);
3416 }
3417 else
3418 {
3419 PUSHINT(FICL_FALSE);
3420 }
3421 return;
3422 }
3423
3424 /**************************************************************************
3425 e v a l u a t e
3426 ** EVALUATE CORE ( i*x c-addr u -- j*x )
3427 ** Save the current input source specification. Store minus-one (-1) in
3428 ** SOURCE-ID if it is present. Make the string described by c-addr and u
3429 ** both the input source and input buffer, set >IN to zero, and interpret.
3430 ** When the parse area is empty, restore the prior input source
3431 ** specification. Other stack effects are due to the words EVALUATEd.
3432 **
3433 **************************************************************************/
evaluate(FICL_VM * pVM)3434 static void evaluate(FICL_VM *pVM)
3435 {
3436 FICL_UNS count;
3437 char *cp;
3438 CELL id;
3439 int result;
3440 #if FICL_ROBUST > 1
3441 vmCheckStack(pVM,2,0);
3442 #endif
3443
3444 count = POPUNS();
3445 cp = POPPTR();
3446
3447 IGNORE(count);
3448 id = pVM->sourceID;
3449 pVM->sourceID.i = -1;
3450 result = ficlExecC(pVM, cp, count);
3451 pVM->sourceID = id;
3452 if (result != VM_OUTOFTEXT)
3453 vmThrow(pVM, result);
3454
3455 return;
3456 }
3457
3458
3459 /**************************************************************************
3460 s t r i n g q u o t e
3461 ** Interpreting: get string delimited by a quote from the input stream,
3462 ** copy to a scratch area, and put its count and address on the stack.
3463 ** Compiling: compile code to push the address and count of a string
3464 ** literal, compile the string from the input stream, and align the dict
3465 ** pointer.
3466 **************************************************************************/
stringQuoteIm(FICL_VM * pVM)3467 static void stringQuoteIm(FICL_VM *pVM)
3468 {
3469 FICL_DICT *dp = vmGetDict(pVM);
3470
3471 if (pVM->state == INTERPRET)
3472 {
3473 FICL_STRING *sp = (FICL_STRING *) dp->here;
3474 vmGetString(pVM, sp, '\"');
3475 PUSHPTR(sp->text);
3476 PUSHUNS(sp->count);
3477 }
3478 else /* COMPILE state */
3479 {
3480 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
3481 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
3482 dictAlign(dp);
3483 }
3484
3485 return;
3486 }
3487
3488
3489 /**************************************************************************
3490 t y p e
3491 ** Pop count and char address from stack and print the designated string.
3492 **************************************************************************/
type(FICL_VM * pVM)3493 static void type(FICL_VM *pVM)
3494 {
3495 FICL_UNS count = stackPopUNS(pVM->pStack);
3496 char *cp = stackPopPtr(pVM->pStack);
3497 char *pDest = (char *)ficlMalloc(count + 1);
3498
3499 /*
3500 ** Since we don't have an output primitive for a counted string
3501 ** (oops), make sure the string is null terminated. If not, copy
3502 ** and terminate it.
3503 */
3504 if (!pDest)
3505 vmThrowErr(pVM, "Error: out of memory");
3506
3507 strncpy(pDest, cp, count);
3508 pDest[count] = '\0';
3509
3510 vmTextOut(pVM, pDest, 0);
3511
3512 ficlFree(pDest);
3513 return;
3514 }
3515
3516 /**************************************************************************
3517 w o r d
3518 ** word CORE ( char "<chars>ccc<char>" -- c-addr )
3519 ** Skip leading delimiters. Parse characters ccc delimited by char. An
3520 ** ambiguous condition exists if the length of the parsed string is greater
3521 ** than the implementation-defined length of a counted string.
3522 **
3523 ** c-addr is the address of a transient region containing the parsed word
3524 ** as a counted string. If the parse area was empty or contained no
3525 ** characters other than the delimiter, the resulting string has a zero
3526 ** length. A space, not included in the length, follows the string. A
3527 ** program may replace characters within the string.
3528 ** NOTE! Ficl also NULL-terminates the dest string.
3529 **************************************************************************/
ficlWord(FICL_VM * pVM)3530 static void ficlWord(FICL_VM *pVM)
3531 {
3532 FICL_STRING *sp;
3533 char delim;
3534 STRINGINFO si;
3535 #if FICL_ROBUST > 1
3536 vmCheckStack(pVM,1,1);
3537 #endif
3538
3539 sp = (FICL_STRING *)pVM->pad;
3540 delim = (char)POPINT();
3541 si = vmParseStringEx(pVM, delim, 1);
3542
3543 if (SI_COUNT(si) > nPAD-1)
3544 SI_SETLEN(si, nPAD-1);
3545
3546 sp->count = (FICL_COUNT)SI_COUNT(si);
3547 strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
3548 /*#$-GUY CHANGE: I added this.-$#*/
3549 sp->text[sp->count] = 0;
3550 strcat(sp->text, " ");
3551
3552 PUSHPTR(sp);
3553 return;
3554 }
3555
3556
3557 /**************************************************************************
3558 p a r s e - w o r d
3559 ** ficl PARSE-WORD ( <spaces>name -- c-addr u )
3560 ** Skip leading spaces and parse name delimited by a space. c-addr is the
3561 ** address within the input buffer and u is the length of the selected
3562 ** string. If the parse area is empty, the resulting string has a zero length.
3563 **************************************************************************/
parseNoCopy(FICL_VM * pVM)3564 static void parseNoCopy(FICL_VM *pVM)
3565 {
3566 STRINGINFO si;
3567 #if FICL_ROBUST > 1
3568 vmCheckStack(pVM,0,2);
3569 #endif
3570
3571 si = vmGetWord0(pVM);
3572 PUSHPTR(SI_PTR(si));
3573 PUSHUNS(SI_COUNT(si));
3574 return;
3575 }
3576
3577
3578 /**************************************************************************
3579 p a r s e
3580 ** CORE EXT ( char "ccc<char>" -- c-addr u )
3581 ** Parse ccc delimited by the delimiter char.
3582 ** c-addr is the address (within the input buffer) and u is the length of
3583 ** the parsed string. If the parse area was empty, the resulting string has
3584 ** a zero length.
3585 ** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
3586 **************************************************************************/
parse(FICL_VM * pVM)3587 static void parse(FICL_VM *pVM)
3588 {
3589 STRINGINFO si;
3590 char delim;
3591
3592 #if FICL_ROBUST > 1
3593 vmCheckStack(pVM,1,2);
3594 #endif
3595
3596 delim = (char)POPINT();
3597
3598 si = vmParseStringEx(pVM, delim, 0);
3599 PUSHPTR(SI_PTR(si));
3600 PUSHUNS(SI_COUNT(si));
3601 return;
3602 }
3603
3604
3605 /**************************************************************************
3606 f i l l
3607 ** CORE ( c-addr u char -- )
3608 ** If u is greater than zero, store char in each of u consecutive
3609 ** characters of memory beginning at c-addr.
3610 **************************************************************************/
fill(FICL_VM * pVM)3611 static void fill(FICL_VM *pVM)
3612 {
3613 char ch;
3614 FICL_UNS u;
3615 char *cp;
3616 #if FICL_ROBUST > 1
3617 vmCheckStack(pVM,3,0);
3618 #endif
3619 ch = (char)POPINT();
3620 u = POPUNS();
3621 cp = (char *)POPPTR();
3622
3623 while (u > 0)
3624 {
3625 *cp++ = ch;
3626 u--;
3627 }
3628 return;
3629 }
3630
3631
3632 /**************************************************************************
3633 f i n d
3634 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3635 ** Find the definition named in the counted string at c-addr. If the
3636 ** definition is not found, return c-addr and zero. If the definition is
3637 ** found, return its execution token xt. If the definition is immediate,
3638 ** also return one (1), otherwise also return minus-one (-1). For a given
3639 ** string, the values returned by FIND while compiling may differ from
3640 ** those returned while not compiling.
3641 **************************************************************************/
do_find(FICL_VM * pVM,STRINGINFO si,void * returnForFailure)3642 static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
3643 {
3644 FICL_WORD *pFW;
3645
3646 pFW = dictLookup(vmGetDict(pVM), si);
3647 if (pFW)
3648 {
3649 PUSHPTR(pFW);
3650 PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
3651 }
3652 else
3653 {
3654 PUSHPTR(returnForFailure);
3655 PUSHUNS(0);
3656 }
3657 return;
3658 }
3659
3660
3661
3662 /**************************************************************************
3663 f i n d
3664 ** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
3665 ** Find the definition named in the counted string at c-addr. If the
3666 ** definition is not found, return c-addr and zero. If the definition is
3667 ** found, return its execution token xt. If the definition is immediate,
3668 ** also return one (1), otherwise also return minus-one (-1). For a given
3669 ** string, the values returned by FIND while compiling may differ from
3670 ** those returned while not compiling.
3671 **************************************************************************/
cFind(FICL_VM * pVM)3672 static void cFind(FICL_VM *pVM)
3673 {
3674 FICL_STRING *sp;
3675 STRINGINFO si;
3676
3677 #if FICL_ROBUST > 1
3678 vmCheckStack(pVM,1,2);
3679 #endif
3680 sp = POPPTR();
3681 SI_PFS(si, sp);
3682 do_find(pVM, si, sp);
3683 }
3684
3685
3686
3687 /**************************************************************************
3688 s f i n d
3689 ** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
3690 ** Like FIND, but takes "c-addr u" for the string.
3691 **************************************************************************/
sFind(FICL_VM * pVM)3692 static void sFind(FICL_VM *pVM)
3693 {
3694 STRINGINFO si;
3695
3696 #if FICL_ROBUST > 1
3697 vmCheckStack(pVM,2,2);
3698 #endif
3699
3700 si.count = stackPopINT(pVM->pStack);
3701 si.cp = stackPopPtr(pVM->pStack);
3702
3703 do_find(pVM, si, NULL);
3704 }
3705
3706
3707
3708 /**************************************************************************
3709 f m S l a s h M o d
3710 ** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3711 ** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3712 ** Input and output stack arguments are signed. An ambiguous condition
3713 ** exists if n1 is zero or if the quotient lies outside the range of a
3714 ** single-cell signed integer.
3715 **************************************************************************/
fmSlashMod(FICL_VM * pVM)3716 static void fmSlashMod(FICL_VM *pVM)
3717 {
3718 DPINT d1;
3719 FICL_INT n1;
3720 INTQR qr;
3721 #if FICL_ROBUST > 1
3722 vmCheckStack(pVM,3,2);
3723 #endif
3724
3725 n1 = POPINT();
3726 d1 = i64Pop(pVM->pStack);
3727 qr = m64FlooredDivI(d1, n1);
3728 PUSHINT(qr.rem);
3729 PUSHINT(qr.quot);
3730 return;
3731 }
3732
3733
3734 /**************************************************************************
3735 s m S l a s h R e m
3736 ** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3737 ** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3738 ** Input and output stack arguments are signed. An ambiguous condition
3739 ** exists if n1 is zero or if the quotient lies outside the range of a
3740 ** single-cell signed integer.
3741 **************************************************************************/
smSlashRem(FICL_VM * pVM)3742 static void smSlashRem(FICL_VM *pVM)
3743 {
3744 DPINT d1;
3745 FICL_INT n1;
3746 INTQR qr;
3747 #if FICL_ROBUST > 1
3748 vmCheckStack(pVM,3,2);
3749 #endif
3750
3751 n1 = POPINT();
3752 d1 = i64Pop(pVM->pStack);
3753 qr = m64SymmetricDivI(d1, n1);
3754 PUSHINT(qr.rem);
3755 PUSHINT(qr.quot);
3756 return;
3757 }
3758
3759
ficlMod(FICL_VM * pVM)3760 static void ficlMod(FICL_VM *pVM)
3761 {
3762 DPINT d1;
3763 FICL_INT n1;
3764 INTQR qr;
3765 #if FICL_ROBUST > 1
3766 vmCheckStack(pVM,2,1);
3767 #endif
3768
3769 n1 = POPINT();
3770 d1.lo = POPINT();
3771 i64Extend(d1);
3772 qr = m64SymmetricDivI(d1, n1);
3773 PUSHINT(qr.rem);
3774 return;
3775 }
3776
3777
3778 /**************************************************************************
3779 u m S l a s h M o d
3780 ** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3781 ** Divide ud by u1, giving the quotient u3 and the remainder u2.
3782 ** All values and arithmetic are unsigned. An ambiguous condition
3783 ** exists if u1 is zero or if the quotient lies outside the range of a
3784 ** single-cell unsigned integer.
3785 *************************************************************************/
umSlashMod(FICL_VM * pVM)3786 static void umSlashMod(FICL_VM *pVM)
3787 {
3788 DPUNS ud;
3789 FICL_UNS u1;
3790 UNSQR qr;
3791
3792 u1 = stackPopUNS(pVM->pStack);
3793 ud = u64Pop(pVM->pStack);
3794 qr = ficlLongDiv(ud, u1);
3795 PUSHUNS(qr.rem);
3796 PUSHUNS(qr.quot);
3797 return;
3798 }
3799
3800
3801 /**************************************************************************
3802 l s h i f t
3803 ** l-shift CORE ( x1 u -- x2 )
3804 ** Perform a logical left shift of u bit-places on x1, giving x2.
3805 ** Put zeroes into the least significant bits vacated by the shift.
3806 ** An ambiguous condition exists if u is greater than or equal to the
3807 ** number of bits in a cell.
3808 **
3809 ** r-shift CORE ( x1 u -- x2 )
3810 ** Perform a logical right shift of u bit-places on x1, giving x2.
3811 ** Put zeroes into the most significant bits vacated by the shift. An
3812 ** ambiguous condition exists if u is greater than or equal to the
3813 ** number of bits in a cell.
3814 **************************************************************************/
lshift(FICL_VM * pVM)3815 static void lshift(FICL_VM *pVM)
3816 {
3817 FICL_UNS nBits;
3818 FICL_UNS x1;
3819 #if FICL_ROBUST > 1
3820 vmCheckStack(pVM,2,1);
3821 #endif
3822
3823 nBits = POPUNS();
3824 x1 = POPUNS();
3825 PUSHUNS(x1 << nBits);
3826 return;
3827 }
3828
3829
rshift(FICL_VM * pVM)3830 static void rshift(FICL_VM *pVM)
3831 {
3832 FICL_UNS nBits;
3833 FICL_UNS x1;
3834 #if FICL_ROBUST > 1
3835 vmCheckStack(pVM,2,1);
3836 #endif
3837
3838 nBits = POPUNS();
3839 x1 = POPUNS();
3840
3841 PUSHUNS(x1 >> nBits);
3842 return;
3843 }
3844
3845
3846 /**************************************************************************
3847 m S t a r
3848 ** m-star CORE ( n1 n2 -- d )
3849 ** d is the signed product of n1 times n2.
3850 **************************************************************************/
mStar(FICL_VM * pVM)3851 static void mStar(FICL_VM *pVM)
3852 {
3853 FICL_INT n2;
3854 FICL_INT n1;
3855 DPINT d;
3856 #if FICL_ROBUST > 1
3857 vmCheckStack(pVM,2,2);
3858 #endif
3859
3860 n2 = POPINT();
3861 n1 = POPINT();
3862
3863 d = m64MulI(n1, n2);
3864 i64Push(pVM->pStack, d);
3865 return;
3866 }
3867
3868
umStar(FICL_VM * pVM)3869 static void umStar(FICL_VM *pVM)
3870 {
3871 FICL_UNS u2;
3872 FICL_UNS u1;
3873 DPUNS ud;
3874 #if FICL_ROBUST > 1
3875 vmCheckStack(pVM,2,2);
3876 #endif
3877
3878 u2 = POPUNS();
3879 u1 = POPUNS();
3880
3881 ud = ficlLongMul(u1, u2);
3882 u64Push(pVM->pStack, ud);
3883 return;
3884 }
3885
3886
3887 /**************************************************************************
3888 m a x & m i n
3889 **
3890 **************************************************************************/
ficlMax(FICL_VM * pVM)3891 static void ficlMax(FICL_VM *pVM)
3892 {
3893 FICL_INT n2;
3894 FICL_INT n1;
3895 #if FICL_ROBUST > 1
3896 vmCheckStack(pVM,2,1);
3897 #endif
3898
3899 n2 = POPINT();
3900 n1 = POPINT();
3901
3902 PUSHINT((n1 > n2) ? n1 : n2);
3903 return;
3904 }
3905
ficlMin(FICL_VM * pVM)3906 static void ficlMin(FICL_VM *pVM)
3907 {
3908 FICL_INT n2;
3909 FICL_INT n1;
3910 #if FICL_ROBUST > 1
3911 vmCheckStack(pVM,2,1);
3912 #endif
3913
3914 n2 = POPINT();
3915 n1 = POPINT();
3916
3917 PUSHINT((n1 < n2) ? n1 : n2);
3918 return;
3919 }
3920
3921
3922 /**************************************************************************
3923 m o v e
3924 ** CORE ( addr1 addr2 u -- )
3925 ** If u is greater than zero, copy the contents of u consecutive address
3926 ** units at addr1 to the u consecutive address units at addr2. After MOVE
3927 ** completes, the u consecutive address units at addr2 contain exactly
3928 ** what the u consecutive address units at addr1 contained before the move.
3929 ** NOTE! This implementation assumes that a char is the same size as
3930 ** an address unit.
3931 **************************************************************************/
move(FICL_VM * pVM)3932 static void move(FICL_VM *pVM)
3933 {
3934 FICL_UNS u;
3935 char *addr2;
3936 char *addr1;
3937 #if FICL_ROBUST > 1
3938 vmCheckStack(pVM,3,0);
3939 #endif
3940
3941 u = POPUNS();
3942 addr2 = POPPTR();
3943 addr1 = POPPTR();
3944
3945 if (u == 0)
3946 return;
3947 /*
3948 ** Do the copy carefully, so as to be
3949 ** correct even if the two ranges overlap
3950 */
3951 if (addr1 >= addr2)
3952 {
3953 for (; u > 0; u--)
3954 *addr2++ = *addr1++;
3955 }
3956 else
3957 {
3958 addr2 += u-1;
3959 addr1 += u-1;
3960 for (; u > 0; u--)
3961 *addr2-- = *addr1--;
3962 }
3963
3964 return;
3965 }
3966
3967
3968 /**************************************************************************
3969 r e c u r s e
3970 **
3971 **************************************************************************/
recurseCoIm(FICL_VM * pVM)3972 static void recurseCoIm(FICL_VM *pVM)
3973 {
3974 FICL_DICT *pDict = vmGetDict(pVM);
3975
3976 IGNORE(pVM);
3977 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3978 return;
3979 }
3980
3981
3982 /**************************************************************************
3983 s t o d
3984 ** s-to-d CORE ( n -- d )
3985 ** Convert the number n to the double-cell number d with the same
3986 ** numerical value.
3987 **************************************************************************/
sToD(FICL_VM * pVM)3988 static void sToD(FICL_VM *pVM)
3989 {
3990 FICL_INT s;
3991 #if FICL_ROBUST > 1
3992 vmCheckStack(pVM,1,2);
3993 #endif
3994
3995 s = POPINT();
3996
3997 /* sign extend to 64 bits.. */
3998 PUSHINT(s);
3999 PUSHINT((s < 0) ? -1 : 0);
4000 return;
4001 }
4002
4003
4004 /**************************************************************************
4005 s o u r c e
4006 ** CORE ( -- c-addr u )
4007 ** c-addr is the address of, and u is the number of characters in, the
4008 ** input buffer.
4009 **************************************************************************/
source(FICL_VM * pVM)4010 static void source(FICL_VM *pVM)
4011 {
4012 #if FICL_ROBUST > 1
4013 vmCheckStack(pVM,0,2);
4014 #endif
4015 PUSHPTR(pVM->tib.cp);
4016 PUSHINT(vmGetInBufLen(pVM));
4017 return;
4018 }
4019
4020
4021 /**************************************************************************
4022 v e r s i o n
4023 ** non-standard...
4024 **************************************************************************/
ficlVersion(FICL_VM * pVM)4025 static void ficlVersion(FICL_VM *pVM)
4026 {
4027 vmTextOut(pVM, "ficl Version " FICL_VER, 1);
4028 return;
4029 }
4030
4031
4032 /**************************************************************************
4033 t o I n
4034 ** to-in CORE
4035 **************************************************************************/
toIn(FICL_VM * pVM)4036 static void toIn(FICL_VM *pVM)
4037 {
4038 #if FICL_ROBUST > 1
4039 vmCheckStack(pVM,0,1);
4040 #endif
4041 PUSHPTR(&pVM->tib.index);
4042 return;
4043 }
4044
4045
4046 /**************************************************************************
4047 c o l o n N o N a m e
4048 ** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
4049 ** Create an unnamed colon definition and push its address.
4050 ** Change state to compile.
4051 **************************************************************************/
colonNoName(FICL_VM * pVM)4052 static void colonNoName(FICL_VM *pVM)
4053 {
4054 FICL_DICT *dp = vmGetDict(pVM);
4055 FICL_WORD *pFW;
4056 STRINGINFO si;
4057
4058 SI_SETLEN(si, 0);
4059 SI_SETPTR(si, NULL);
4060
4061 pVM->state = COMPILE;
4062 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
4063 PUSHPTR(pFW);
4064 markControlTag(pVM, colonTag);
4065 return;
4066 }
4067
4068
4069 /**************************************************************************
4070 u s e r V a r i a b l e
4071 ** user ( u -- ) "<spaces>name"
4072 ** Get a name from the input stream and create a user variable
4073 ** with the name and the index supplied. The run-time effect
4074 ** of a user variable is to push the address of the indexed cell
4075 ** in the running vm's user array.
4076 **
4077 ** User variables are vm local cells. Each vm has an array of
4078 ** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
4079 ** Ficl's user facility is implemented with two primitives,
4080 ** "user" and "(user)", a variable ("nUser") (in softcore.c) that
4081 ** holds the index of the next free user cell, and a redefinition
4082 ** (also in softcore) of "user" that defines a user word and increments
4083 ** nUser.
4084 **************************************************************************/
4085 #if FICL_WANT_USER
userParen(FICL_VM * pVM)4086 static void userParen(FICL_VM *pVM)
4087 {
4088 FICL_INT i = pVM->runningWord->param[0].i;
4089 PUSHPTR(&pVM->user[i]);
4090 return;
4091 }
4092
4093
userVariable(FICL_VM * pVM)4094 static void userVariable(FICL_VM *pVM)
4095 {
4096 FICL_DICT *dp = vmGetDict(pVM);
4097 STRINGINFO si = vmGetWord(pVM);
4098 CELL c;
4099
4100 c = stackPop(pVM->pStack);
4101 if (c.i >= FICL_USER_CELLS)
4102 {
4103 vmThrowErr(pVM, "Error - out of user space");
4104 }
4105
4106 dictAppendWord2(dp, si, userParen, FW_DEFAULT);
4107 dictAppendCell(dp, c);
4108 return;
4109 }
4110 #endif
4111
4112
4113 /**************************************************************************
4114 t o V a l u e
4115 ** CORE EXT
4116 ** Interpretation: ( x "<spaces>name" -- )
4117 ** Skip leading spaces and parse name delimited by a space. Store x in
4118 ** name. An ambiguous condition exists if name was not defined by VALUE.
4119 ** NOTE: In ficl, VALUE is an alias of CONSTANT
4120 **************************************************************************/
toValue(FICL_VM * pVM)4121 static void toValue(FICL_VM *pVM)
4122 {
4123 STRINGINFO si = vmGetWord(pVM);
4124 FICL_DICT *dp = vmGetDict(pVM);
4125 FICL_WORD *pFW;
4126
4127 #if FICL_WANT_LOCALS
4128 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
4129 {
4130 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4131 pFW = dictLookup(pLoc, si);
4132 if (pFW && (pFW->code == doLocalIm))
4133 {
4134 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4135 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
4136 return;
4137 }
4138 else if (pFW && pFW->code == do2LocalIm)
4139 {
4140 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4141 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
4142 return;
4143 }
4144 }
4145 #endif
4146
4147 assert(pVM->pSys->pStore);
4148
4149 pFW = dictLookup(dp, si);
4150 if (!pFW)
4151 {
4152 int i = SI_COUNT(si);
4153 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
4154 }
4155
4156 if (pVM->state == INTERPRET)
4157 pFW->param[0] = stackPop(pVM->pStack);
4158 else /* compile code to store to word's param */
4159 {
4160 PUSHPTR(&pFW->param[0]);
4161 literalIm(pVM);
4162 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
4163 }
4164 return;
4165 }
4166
4167
4168 #if FICL_WANT_LOCALS
4169 /**************************************************************************
4170 l i n k P a r e n
4171 ** ( -- )
4172 ** Link a frame on the return stack, reserving nCells of space for
4173 ** locals - the value of nCells is the next cell in the instruction
4174 ** stream.
4175 **************************************************************************/
linkParen(FICL_VM * pVM)4176 static void linkParen(FICL_VM *pVM)
4177 {
4178 FICL_INT nLink = *(FICL_INT *)(pVM->ip);
4179 vmBranchRelative(pVM, 1);
4180 stackLink(pVM->rStack, nLink);
4181 return;
4182 }
4183
4184
unlinkParen(FICL_VM * pVM)4185 static void unlinkParen(FICL_VM *pVM)
4186 {
4187 stackUnlink(pVM->rStack);
4188 return;
4189 }
4190
4191
4192 /**************************************************************************
4193 d o L o c a l I m
4194 ** Immediate - cfa of a local while compiling - when executed, compiles
4195 ** code to fetch the value of a local given the local's index in the
4196 ** word's pfa
4197 **************************************************************************/
getLocalParen(FICL_VM * pVM)4198 static void getLocalParen(FICL_VM *pVM)
4199 {
4200 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4201 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4202 return;
4203 }
4204
4205
toLocalParen(FICL_VM * pVM)4206 static void toLocalParen(FICL_VM *pVM)
4207 {
4208 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4209 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4210 return;
4211 }
4212
4213
getLocal0(FICL_VM * pVM)4214 static void getLocal0(FICL_VM *pVM)
4215 {
4216 stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
4217 return;
4218 }
4219
4220
toLocal0(FICL_VM * pVM)4221 static void toLocal0(FICL_VM *pVM)
4222 {
4223 pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
4224 return;
4225 }
4226
4227
getLocal1(FICL_VM * pVM)4228 static void getLocal1(FICL_VM *pVM)
4229 {
4230 stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
4231 return;
4232 }
4233
4234
toLocal1(FICL_VM * pVM)4235 static void toLocal1(FICL_VM *pVM)
4236 {
4237 pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
4238 return;
4239 }
4240
4241
4242 /*
4243 ** Each local is recorded in a private locals dictionary as a
4244 ** word that does doLocalIm at runtime. DoLocalIm compiles code
4245 ** into the client definition to fetch the value of the
4246 ** corresponding local variable from the return stack.
4247 ** The private dictionary gets initialized at the end of each block
4248 ** that uses locals (in ; and does> for example).
4249 */
doLocalIm(FICL_VM * pVM)4250 static void doLocalIm(FICL_VM *pVM)
4251 {
4252 FICL_DICT *pDict = vmGetDict(pVM);
4253 FICL_INT nLocal = pVM->runningWord->param[0].i;
4254
4255 if (pVM->state == INTERPRET)
4256 {
4257 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4258 }
4259 else
4260 {
4261
4262 if (nLocal == 0)
4263 {
4264 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
4265 }
4266 else if (nLocal == 1)
4267 {
4268 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
4269 }
4270 else
4271 {
4272 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
4273 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4274 }
4275 }
4276 return;
4277 }
4278
4279
4280 /**************************************************************************
4281 l o c a l P a r e n
4282 ** paren-local-paren LOCAL
4283 ** Interpretation: Interpretation semantics for this word are undefined.
4284 ** Execution: ( c-addr u -- )
4285 ** When executed during compilation, (LOCAL) passes a message to the
4286 ** system that has one of two meanings. If u is non-zero,
4287 ** the message identifies a new local whose definition name is given by
4288 ** the string of characters identified by c-addr u. If u is zero,
4289 ** the message is last local and c-addr has no significance.
4290 **
4291 ** The result of executing (LOCAL) during compilation of a definition is
4292 ** to create a set of named local identifiers, each of which is
4293 ** a definition name, that only have execution semantics within the scope
4294 ** of that definition's source.
4295 **
4296 ** local Execution: ( -- x )
4297 **
4298 ** Push the local's value, x, onto the stack. The local's value is
4299 ** initialized as described in 13.3.3 Processing locals and may be
4300 ** changed by preceding the local's name with TO. An ambiguous condition
4301 ** exists when local is executed while in interpretation state.
4302 **************************************************************************/
localParen(FICL_VM * pVM)4303 static void localParen(FICL_VM *pVM)
4304 {
4305 FICL_DICT *pDict;
4306 STRINGINFO si;
4307 #if FICL_ROBUST > 1
4308 vmCheckStack(pVM,2,0);
4309 #endif
4310
4311 pDict = vmGetDict(pVM);
4312 SI_SETLEN(si, POPUNS());
4313 SI_SETPTR(si, (char *)POPPTR());
4314
4315 if (SI_COUNT(si) > 0)
4316 { /* add a local to the **locals** dict and update nLocals */
4317 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4318 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4319 {
4320 vmThrowErr(pVM, "Error: out of local space");
4321 }
4322
4323 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
4324 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4325
4326 if (pVM->pSys->nLocals == 0)
4327 { /* compile code to create a local stack frame */
4328 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4329 /* save location in dictionary for #locals */
4330 pVM->pSys->pMarkLocals = pDict->here;
4331 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4332 /* compile code to initialize first local */
4333 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
4334 }
4335 else if (pVM->pSys->nLocals == 1)
4336 {
4337 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
4338 }
4339 else
4340 {
4341 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
4342 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4343 }
4344
4345 (pVM->pSys->nLocals)++;
4346 }
4347 else if (pVM->pSys->nLocals > 0)
4348 { /* write nLocals to (link) param area in dictionary */
4349 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4350 }
4351
4352 return;
4353 }
4354
4355
get2LocalParen(FICL_VM * pVM)4356 static void get2LocalParen(FICL_VM *pVM)
4357 {
4358 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4359 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4360 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4361 return;
4362 }
4363
4364
do2LocalIm(FICL_VM * pVM)4365 static void do2LocalIm(FICL_VM *pVM)
4366 {
4367 FICL_DICT *pDict = vmGetDict(pVM);
4368 FICL_INT nLocal = pVM->runningWord->param[0].i;
4369
4370 if (pVM->state == INTERPRET)
4371 {
4372 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
4373 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
4374 }
4375 else
4376 {
4377 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
4378 dictAppendCell(pDict, LVALUEtoCELL(nLocal));
4379 }
4380 return;
4381 }
4382
4383
to2LocalParen(FICL_VM * pVM)4384 static void to2LocalParen(FICL_VM *pVM)
4385 {
4386 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
4387 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
4388 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
4389 return;
4390 }
4391
4392
twoLocalParen(FICL_VM * pVM)4393 static void twoLocalParen(FICL_VM *pVM)
4394 {
4395 FICL_DICT *pDict = vmGetDict(pVM);
4396 STRINGINFO si;
4397 SI_SETLEN(si, stackPopUNS(pVM->pStack));
4398 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
4399
4400 if (SI_COUNT(si) > 0)
4401 { /* add a local to the **locals** dict and update nLocals */
4402 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
4403 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
4404 {
4405 vmThrowErr(pVM, "Error: out of local space");
4406 }
4407
4408 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
4409 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
4410
4411 if (pVM->pSys->nLocals == 0)
4412 { /* compile code to create a local stack frame */
4413 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
4414 /* save location in dictionary for #locals */
4415 pVM->pSys->pMarkLocals = pDict->here;
4416 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4417 }
4418
4419 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
4420 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
4421
4422 pVM->pSys->nLocals += 2;
4423 }
4424 else if (pVM->pSys->nLocals > 0)
4425 { /* write nLocals to (link) param area in dictionary */
4426 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
4427 }
4428
4429 return;
4430 }
4431
4432
4433 #endif
4434 /**************************************************************************
4435 c o m p a r e
4436 ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4437 ** Compare the string specified by c-addr1 u1 to the string specified by
4438 ** c-addr2 u2. The strings are compared, beginning at the given addresses,
4439 ** character by character, up to the length of the shorter string or until a
4440 ** difference is found. If the two strings are identical, n is zero. If the two
4441 ** strings are identical up to the length of the shorter string, n is minus-one
4442 ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4443 ** identical up to the length of the shorter string, n is minus-one (-1) if the
4444 ** first non-matching character in the string specified by c-addr1 u1 has a
4445 ** lesser numeric value than the corresponding character in the string specified
4446 ** by c-addr2 u2 and one (1) otherwise.
4447 **************************************************************************/
compareInternal(FICL_VM * pVM,int caseInsensitive)4448 static void compareInternal(FICL_VM *pVM, int caseInsensitive)
4449 {
4450 char *cp1, *cp2;
4451 FICL_UNS u1, u2, uMin;
4452 int n = 0;
4453
4454 vmCheckStack(pVM, 4, 1);
4455 u2 = stackPopUNS(pVM->pStack);
4456 cp2 = (char *)stackPopPtr(pVM->pStack);
4457 u1 = stackPopUNS(pVM->pStack);
4458 cp1 = (char *)stackPopPtr(pVM->pStack);
4459
4460 uMin = (u1 < u2)? u1 : u2;
4461 for ( ; (uMin > 0) && (n == 0); uMin--)
4462 {
4463 char c1 = *cp1++;
4464 char c2 = *cp2++;
4465 if (caseInsensitive)
4466 {
4467 c1 = (char)tolower(c1);
4468 c2 = (char)tolower(c2);
4469 }
4470 n = (int)(c1 - c2);
4471 }
4472
4473 if (n == 0)
4474 n = (int)(u1 - u2);
4475
4476 if (n < 0)
4477 n = -1;
4478 else if (n > 0)
4479 n = 1;
4480
4481 PUSHINT(n);
4482 return;
4483 }
4484
4485
compareString(FICL_VM * pVM)4486 static void compareString(FICL_VM *pVM)
4487 {
4488 compareInternal(pVM, FALSE);
4489 }
4490
4491
compareStringInsensitive(FICL_VM * pVM)4492 static void compareStringInsensitive(FICL_VM *pVM)
4493 {
4494 compareInternal(pVM, TRUE);
4495 }
4496
4497
4498 /**************************************************************************
4499 p a d
4500 ** CORE EXT ( -- c-addr )
4501 ** c-addr is the address of a transient region that can be used to hold
4502 ** data for intermediate processing.
4503 **************************************************************************/
pad(FICL_VM * pVM)4504 static void pad(FICL_VM *pVM)
4505 {
4506 stackPushPtr(pVM->pStack, pVM->pad);
4507 }
4508
4509
4510 /**************************************************************************
4511 s o u r c e - i d
4512 ** CORE EXT, FILE ( -- 0 | -1 | fileid )
4513 ** Identifies the input source as follows:
4514 **
4515 ** SOURCE-ID Input source
4516 ** --------- ------------
4517 ** fileid Text file fileid
4518 ** -1 String (via EVALUATE)
4519 ** 0 User input device
4520 **************************************************************************/
sourceid(FICL_VM * pVM)4521 static void sourceid(FICL_VM *pVM)
4522 {
4523 PUSHINT(pVM->sourceID.i);
4524 return;
4525 }
4526
4527
4528 /**************************************************************************
4529 r e f i l l
4530 ** CORE EXT ( -- flag )
4531 ** Attempt to fill the input buffer from the input source, returning a true
4532 ** flag if successful.
4533 ** When the input source is the user input device, attempt to receive input
4534 ** into the terminal input buffer. If successful, make the result the input
4535 ** buffer, set >IN to zero, and return true. Receipt of a line containing no
4536 ** characters is considered successful. If there is no input available from
4537 ** the current input source, return false.
4538 ** When the input source is a string from EVALUATE, return false and
4539 ** perform no other action.
4540 **************************************************************************/
refill(FICL_VM * pVM)4541 static void refill(FICL_VM *pVM)
4542 {
4543 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4544 if (ret && (pVM->fRestart == 0))
4545 vmThrow(pVM, VM_RESTART);
4546
4547 PUSHINT(ret);
4548 return;
4549 }
4550
4551
4552 /**************************************************************************
4553 freebsd exception handling words
4554 ** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4555 ** the word in ToS. If an exception happens, restore the state to what
4556 ** it was before, and pushes the exception value on the stack. If not,
4557 ** push zero.
4558 **
4559 ** Notice that Catch implements an inner interpreter. This is ugly,
4560 ** but given how ficl works, it cannot be helped. The problem is that
4561 ** colon definitions will be executed *after* the function returns,
4562 ** while "code" definitions will be executed immediately. I considered
4563 ** other solutions to this problem, but all of them shared the same
4564 ** basic problem (with added disadvantages): if ficl ever changes it's
4565 ** inner thread modus operandi, one would have to fix this word.
4566 **
4567 ** More comments can be found throughout catch's code.
4568 **
4569 ** Daniel C. Sobral Jan 09/1999
4570 ** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4571 **************************************************************************/
4572
ficlCatch(FICL_VM * pVM)4573 static void ficlCatch(FICL_VM *pVM)
4574 {
4575 int except;
4576 jmp_buf vmState;
4577 FICL_VM VM;
4578 FICL_STACK pStack;
4579 FICL_STACK rStack;
4580 FICL_WORD *pFW;
4581
4582 assert(pVM);
4583 assert(pVM->pSys->pExitInner);
4584
4585
4586 /*
4587 ** Get xt.
4588 ** We need this *before* we save the stack pointer, or
4589 ** we'll have to pop one element out of the stack after
4590 ** an exception. I prefer to get done with it up front. :-)
4591 */
4592 #if FICL_ROBUST > 1
4593 vmCheckStack(pVM, 1, 0);
4594 #endif
4595 pFW = stackPopPtr(pVM->pStack);
4596
4597 /*
4598 ** Save vm's state -- a catch will not back out environmental
4599 ** changes.
4600 **
4601 ** We are *not* saving dictionary state, since it is
4602 ** global instead of per vm, and we are not saving
4603 ** stack contents, since we are not required to (and,
4604 ** thus, it would be useless). We save pVM, and pVM
4605 ** "stacks" (a structure containing general information
4606 ** about it, including the current stack pointer).
4607 */
4608 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4609 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4610 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4611
4612 /*
4613 ** Give pVM a jmp_buf
4614 */
4615 pVM->pState = &vmState;
4616
4617 /*
4618 ** Safety net
4619 */
4620 except = setjmp(vmState);
4621
4622 switch (except)
4623 {
4624 /*
4625 ** Setup condition - push poison pill so that the VM throws
4626 ** VM_INNEREXIT if the XT terminates normally, then execute
4627 ** the XT
4628 */
4629 case 0:
4630 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
4631 vmExecute(pVM, pFW);
4632 vmInnerLoop(pVM);
4633 break;
4634
4635 /*
4636 ** Normal exit from XT - lose the poison pill,
4637 ** restore old setjmp vector and push a zero.
4638 */
4639 case VM_INNEREXIT:
4640 vmPopIP(pVM); /* Gack - hurl poison pill */
4641 pVM->pState = VM.pState; /* Restore just the setjmp vector */
4642 PUSHINT(0); /* Push 0 -- everything is ok */
4643 break;
4644
4645 /*
4646 ** Some other exception got thrown - restore pre-existing VM state
4647 ** and push the exception code
4648 */
4649 default:
4650 /* Restore vm's state */
4651 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4652 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4653 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4654
4655 PUSHINT(except);/* Push error */
4656 break;
4657 }
4658 }
4659
4660 /**************************************************************************
4661 ** t h r o w
4662 ** EXCEPTION
4663 ** Throw -- From ANS Forth standard.
4664 **
4665 ** Throw takes the ToS and, if that's different from zero,
4666 ** returns to the last executed catch context. Further throws will
4667 ** unstack previously executed "catches", in LIFO mode.
4668 **
4669 ** Daniel C. Sobral Jan 09/1999
4670 **************************************************************************/
ficlThrow(FICL_VM * pVM)4671 static void ficlThrow(FICL_VM *pVM)
4672 {
4673 int except;
4674
4675 except = stackPopINT(pVM->pStack);
4676
4677 if (except)
4678 vmThrow(pVM, except);
4679 }
4680
4681
4682 /**************************************************************************
4683 ** a l l o c a t e
4684 ** MEMORY
4685 **************************************************************************/
ansAllocate(FICL_VM * pVM)4686 static void ansAllocate(FICL_VM *pVM)
4687 {
4688 size_t size;
4689 void *p;
4690
4691 size = stackPopINT(pVM->pStack);
4692 p = ficlMalloc(size);
4693 PUSHPTR(p);
4694 if (p)
4695 PUSHINT(0);
4696 else
4697 PUSHINT(1);
4698 }
4699
4700
4701 /**************************************************************************
4702 ** f r e e
4703 ** MEMORY
4704 **************************************************************************/
ansFree(FICL_VM * pVM)4705 static void ansFree(FICL_VM *pVM)
4706 {
4707 void *p;
4708
4709 p = stackPopPtr(pVM->pStack);
4710 ficlFree(p);
4711 PUSHINT(0);
4712 }
4713
4714
4715 /**************************************************************************
4716 ** r e s i z e
4717 ** MEMORY
4718 **************************************************************************/
ansResize(FICL_VM * pVM)4719 static void ansResize(FICL_VM *pVM)
4720 {
4721 size_t size;
4722 void *new, *old;
4723
4724 size = stackPopINT(pVM->pStack);
4725 old = stackPopPtr(pVM->pStack);
4726 new = ficlRealloc(old, size);
4727 if (new)
4728 {
4729 PUSHPTR(new);
4730 PUSHINT(0);
4731 }
4732 else
4733 {
4734 PUSHPTR(old);
4735 PUSHINT(1);
4736 }
4737 }
4738
4739
4740 /**************************************************************************
4741 ** e x i t - i n n e r
4742 ** Signals execXT that an inner loop has completed
4743 **************************************************************************/
ficlExitInner(FICL_VM * pVM)4744 static void ficlExitInner(FICL_VM *pVM)
4745 {
4746 vmThrow(pVM, VM_INNEREXIT);
4747 }
4748
4749
4750 /**************************************************************************
4751 d n e g a t e
4752 ** DOUBLE ( d1 -- d2 )
4753 ** d2 is the negation of d1.
4754 **************************************************************************/
dnegate(FICL_VM * pVM)4755 static void dnegate(FICL_VM *pVM)
4756 {
4757 DPINT i = i64Pop(pVM->pStack);
4758 i = m64Negate(i);
4759 i64Push(pVM->pStack, i);
4760
4761 return;
4762 }
4763
4764
4765 #if 0
4766 /**************************************************************************
4767
4768 **
4769 **************************************************************************/
4770 static void funcname(FICL_VM *pVM)
4771 {
4772 IGNORE(pVM);
4773 return;
4774 }
4775
4776
4777 #endif
4778 /**************************************************************************
4779 f i c l W o r d C l a s s i f y
4780 ** This public function helps to classify word types for SEE
4781 ** and the deugger in tools.c. Given a pointer to a word, it returns
4782 ** a member of WOR
4783 **************************************************************************/
ficlWordClassify(FICL_WORD * pFW)4784 WORDKIND ficlWordClassify(FICL_WORD *pFW)
4785 {
4786 typedef struct
4787 {
4788 WORDKIND kind;
4789 FICL_CODE code;
4790 } CODEtoKIND;
4791
4792 static CODEtoKIND codeMap[] =
4793 {
4794 {BRANCH, branchParen},
4795 {COLON, colonParen},
4796 {CONSTANT, constantParen},
4797 {CREATE, createParen},
4798 {DO, doParen},
4799 {DOES, doDoes},
4800 {IF, branch0},
4801 {LITERAL, literalParen},
4802 {LOOP, loopParen},
4803 {OF, ofParen},
4804 {PLOOP, plusLoopParen},
4805 {QDO, qDoParen},
4806 {CSTRINGLIT, cstringLit},
4807 {STRINGLIT, stringLit},
4808 #if FICL_WANT_USER
4809 {USER, userParen},
4810 #endif
4811 {VARIABLE, variableParen},
4812 };
4813
4814 #define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
4815
4816 FICL_CODE code = pFW->code;
4817 int i;
4818
4819 for (i=0; i < nMAP; i++)
4820 {
4821 if (codeMap[i].code == code)
4822 return codeMap[i].kind;
4823 }
4824
4825 return PRIMITIVE;
4826 }
4827
4828
4829 #ifdef TESTMAIN
4830 /**************************************************************************
4831 ** r a n d o m
4832 ** FICL-specific
4833 **************************************************************************/
ficlRandom(FICL_VM * pVM)4834 static void ficlRandom(FICL_VM *pVM)
4835 {
4836 PUSHUNS(random());
4837 }
4838
4839
4840 /**************************************************************************
4841 ** s e e d - r a n d o m
4842 ** FICL-specific
4843 **************************************************************************/
ficlSeedRandom(FICL_VM * pVM)4844 static void ficlSeedRandom(FICL_VM *pVM)
4845 {
4846 srandom(POPUNS());
4847 }
4848 #endif
4849
4850
4851 /**************************************************************************
4852 f i c l C o m p i l e C o r e
4853 ** Builds the primitive wordset and the environment-query namespace.
4854 **************************************************************************/
4855
ficlCompileCore(FICL_SYSTEM * pSys)4856 void ficlCompileCore(FICL_SYSTEM *pSys)
4857 {
4858 FICL_DICT *dp = pSys->dp;
4859 assert (dp);
4860
4861
4862 /*
4863 ** CORE word set
4864 ** see softcore.c for definitions of: abs bl space spaces abort"
4865 */
4866 pSys->pStore =
4867 dictAppendWord(dp, "!", store, FW_DEFAULT);
4868 dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
4869 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
4870 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
4871 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
4872 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
4873 dictAppendWord(dp, "*", mul, FW_DEFAULT);
4874 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
4875 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
4876 dictAppendWord(dp, "+", add, FW_DEFAULT);
4877 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
4878 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
4879 dictAppendWord(dp, ",", comma, FW_DEFAULT);
4880 dictAppendWord(dp, "-", sub, FW_DEFAULT);
4881 dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
4882 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
4883 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
4884 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
4885 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
4886 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
4887 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
4888 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
4889 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
4890 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
4891 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
4892 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
4893 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
4894 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
4895 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
4896 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
4897 dictAppendWord(dp, ":", colon, FW_DEFAULT);
4898 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
4899 dictAppendWord(dp, "<", isLess, FW_DEFAULT);
4900 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
4901 dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
4902 dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
4903 dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
4904 dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
4905 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
4906 dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
4907 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
4908 dictAppendWord(dp, "@", fetch, FW_DEFAULT);
4909 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
4910 dictAppendWord(dp, "accept", accept, FW_DEFAULT);
4911 dictAppendWord(dp, "align", align, FW_DEFAULT);
4912 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
4913 dictAppendWord(dp, "allot", allot, FW_DEFAULT);
4914 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
4915 dictAppendWord(dp, "base", base, FW_DEFAULT);
4916 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
4917 dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
4918 dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
4919 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
4920 dictAppendWord(dp, "case", caseCoIm, FW_COMPIMMED);
4921 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
4922 dictAppendWord(dp, "cells", cells, FW_DEFAULT);
4923 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
4924 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
4925 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
4926 dictAppendWord(dp, "constant", constant, FW_DEFAULT);
4927 dictAppendWord(dp, "count", count, FW_DEFAULT);
4928 dictAppendWord(dp, "cr", cr, FW_DEFAULT);
4929 dictAppendWord(dp, "create", create, FW_DEFAULT);
4930 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
4931 dictAppendWord(dp, "depth", depth, FW_DEFAULT);
4932 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
4933 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
4934 pSys->pDrop =
4935 dictAppendWord(dp, "drop", drop, FW_DEFAULT);
4936 dictAppendWord(dp, "dup", dup, FW_DEFAULT);
4937 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
4938 dictAppendWord(dp, "emit", emit, FW_DEFAULT);
4939 dictAppendWord(dp, "endcase", endcaseCoIm, FW_COMPIMMED);
4940 dictAppendWord(dp, "endof", endofCoIm, FW_COMPIMMED);
4941 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4942 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
4943 dictAppendWord(dp, "execute", execute, FW_DEFAULT);
4944 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
4945 dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED);
4946 dictAppendWord(dp, "fill", fill, FW_DEFAULT);
4947 dictAppendWord(dp, "find", cFind, FW_DEFAULT);
4948 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
4949 dictAppendWord(dp, "here", here, FW_DEFAULT);
4950 dictAppendWord(dp, "hold", hold, FW_DEFAULT);
4951 dictAppendWord(dp, "i", loopICo, FW_COMPILE);
4952 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
4953 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
4954 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
4955 dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
4956 dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
4957 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
4958 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
4959 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
4960 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
4961 dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
4962 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
4963 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
4964 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
4965 dictAppendWord(dp, "move", move, FW_DEFAULT);
4966 dictAppendWord(dp, "negate", negate, FW_DEFAULT);
4967 dictAppendWord(dp, "of", ofCoIm, FW_COMPIMMED);
4968 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
4969 dictAppendWord(dp, "over", over, FW_DEFAULT);
4970 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
4971 dictAppendWord(dp, "quit", quit, FW_DEFAULT);
4972 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
4973 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
4974 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
4975 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
4976 dictAppendWord(dp, "rot", rot, FW_DEFAULT);
4977 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
4978 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
4979 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
4980 dictAppendWord(dp, "sign", sign, FW_DEFAULT);
4981 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
4982 dictAppendWord(dp, "source", source, FW_DEFAULT);
4983 dictAppendWord(dp, "state", state, FW_DEFAULT);
4984 dictAppendWord(dp, "swap", swap, FW_DEFAULT);
4985 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
4986 dictAppendWord(dp, "type", type, FW_DEFAULT);
4987 dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
4988 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
4989 dictAppendWord(dp, "u>", uIsGreater, FW_DEFAULT);
4990 dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
4991 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
4992 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
4993 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
4994 dictAppendWord(dp, "variable", variable, FW_DEFAULT);
4995 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
4996 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
4997 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
4998 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
4999 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
5000 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
5001 dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
5002 /*
5003 ** CORE EXT word set...
5004 ** see softcore.fr for other definitions
5005 */
5006 /* "#tib" */
5007 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
5008 /* ".r" */
5009 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
5010 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
5011 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
5012 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
5013 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
5014 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
5015 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
5016 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
5017 dictAppendWord(dp, "hex", hex, FW_DEFAULT);
5018 dictAppendWord(dp, "pad", pad, FW_DEFAULT);
5019 dictAppendWord(dp, "parse", parse, FW_DEFAULT);
5020 dictAppendWord(dp, "pick", pick, FW_DEFAULT);
5021 /* query restore-input save-input tib u.r u> unused [compile] */
5022 dictAppendWord(dp, "roll", roll, FW_DEFAULT);
5023 dictAppendWord(dp, "refill", refill, FW_DEFAULT);
5024 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
5025 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
5026 dictAppendWord(dp, "value", constant, FW_DEFAULT);
5027 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
5028
5029
5030 /*
5031 ** Set CORE environment query values
5032 */
5033 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
5034 ficlSetEnv(pSys, "/hold", nPAD);
5035 ficlSetEnv(pSys, "/pad", nPAD);
5036 ficlSetEnv(pSys, "address-unit-bits", 8);
5037 ficlSetEnv(pSys, "core", FICL_TRUE);
5038 ficlSetEnv(pSys, "core-ext", FICL_FALSE);
5039 ficlSetEnv(pSys, "floored", FICL_FALSE);
5040 ficlSetEnv(pSys, "max-char", UCHAR_MAX);
5041 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
5042 ficlSetEnv(pSys, "max-n", 0x7fffffff);
5043 ficlSetEnv(pSys, "max-u", 0xffffffff);
5044 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
5045 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
5046 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
5047
5048 /*
5049 ** DOUBLE word set (partial)
5050 */
5051 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
5052 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
5053 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
5054 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
5055
5056
5057 /*
5058 ** EXCEPTION word set
5059 */
5060 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
5061 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
5062
5063 ficlSetEnv(pSys, "exception", FICL_TRUE);
5064 ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
5065
5066 /*
5067 ** LOCAL and LOCAL EXT
5068 ** see softcore.c for implementation of locals|
5069 */
5070 #if FICL_WANT_LOCALS
5071 pSys->pLinkParen =
5072 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
5073 pSys->pUnLinkParen =
5074 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
5075 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
5076 pSys->pGetLocalParen =
5077 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
5078 pSys->pToLocalParen =
5079 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
5080 pSys->pGetLocal0 =
5081 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
5082 pSys->pToLocal0 =
5083 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
5084 pSys->pGetLocal1 =
5085 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
5086 pSys->pToLocal1 =
5087 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
5088 dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
5089
5090 pSys->pGet2LocalParen =
5091 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
5092 pSys->pTo2LocalParen =
5093 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
5094 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
5095
5096 ficlSetEnv(pSys, "locals", FICL_TRUE);
5097 ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
5098 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
5099 #endif
5100
5101 /*
5102 ** Optional MEMORY-ALLOC word set
5103 */
5104
5105 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
5106 dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
5107 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
5108
5109 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
5110
5111 /*
5112 ** optional SEARCH-ORDER word set
5113 */
5114 ficlCompileSearch(pSys);
5115
5116 /*
5117 ** TOOLS and TOOLS EXT
5118 */
5119 ficlCompileTools(pSys);
5120
5121 /*
5122 ** FILE and FILE EXT
5123 */
5124 #if FICL_WANT_FILE
5125 ficlCompileFile(pSys);
5126 #endif
5127
5128 /*
5129 ** Ficl extras
5130 */
5131 #if FICL_WANT_FLOAT
5132 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
5133 #endif
5134 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
5135 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
5136 dictAppendWord(dp, ">name", toName, FW_DEFAULT);
5137 dictAppendWord(dp, "add-parse-step",
5138 addParseStep, FW_DEFAULT);
5139 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
5140 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
5141 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
5142 dictAppendWord(dp, "compile-only",
5143 compileOnly, FW_DEFAULT);
5144 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
5145 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
5146 dictAppendWord(dp, "hash", hash, FW_DEFAULT);
5147 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
5148 dictAppendWord(dp, "?object", isObject, FW_DEFAULT);
5149 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
5150 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
5151 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
5152 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
5153 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
5154 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
5155 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
5156 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
5157 dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
5158 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
5159 #if FICL_WANT_USER
5160 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
5161 dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
5162 #endif
5163 #ifdef TESTMAIN
5164 dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT);
5165 dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT);
5166 #endif
5167
5168 /*
5169 ** internal support words
5170 */
5171 dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
5172 pSys->pExitParen =
5173 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
5174 pSys->pSemiParen =
5175 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
5176 pSys->pLitParen =
5177 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
5178 pSys->pTwoLitParen =
5179 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
5180 pSys->pStringLit =
5181 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
5182 pSys->pCStringLit =
5183 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
5184 pSys->pBranch0 =
5185 dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE);
5186 pSys->pBranchParen =
5187 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
5188 pSys->pDoParen =
5189 dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
5190 pSys->pDoesParen =
5191 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
5192 pSys->pQDoParen =
5193 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
5194 pSys->pLoopParen =
5195 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
5196 pSys->pPLoopParen =
5197 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
5198 pSys->pInterpret =
5199 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
5200 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
5201 pSys->pOfParen =
5202 dictAppendWord(dp, "(of)", ofParen, FW_DEFAULT);
5203 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
5204 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
5205 dictAppendWord(dp, "(parse-step)",
5206 parseStepParen, FW_DEFAULT);
5207 pSys->pExitInner =
5208 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
5209
5210 /*
5211 ** Set up system's outer interpreter loop - maybe this should be in initSystem?
5212 */
5213 pSys->pInterp[0] = pSys->pInterpret;
5214 pSys->pInterp[1] = pSys->pBranchParen;
5215 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
5216
5217 assert(dictCellsAvail(dp) > 0);
5218
5219 return;
5220 }
5221