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