FreeBSD/Linux Kernel Cross Reference
sys/boot/ficl/words.c
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: src/sys/boot/ficl/words.c,v 1.40 2007/03/23 22:26:01 jkim Exp $ */
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 */
90 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
91 {
92 PUSHPTR(dp->here);
93 PUSHPTR(tag);
94 return;
95 }
96
97 static void markControlTag(FICL_VM *pVM, char *tag)
98 {
99 PUSHPTR(tag);
100 return;
101 }
102
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 */
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 */
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 */
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
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 - '';
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
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
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
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
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
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 */
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
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
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
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
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
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
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
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
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 **************************************************************************/
508 static void semiParen(FICL_VM *pVM)
509 {
510 vmPopIP(pVM);
511 return;
512 }
513
514
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 **************************************************************************/
549 static void exitParen(FICL_VM *pVM)
550 {
551 vmPopIP(pVM);
552 return;
553 }
554
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
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
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
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
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
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
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
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 **/
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 **************************************************************************/
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 == '');
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) ? '' : ' ');
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
1032 static void cr(FICL_VM *pVM)
1033 {
1034 vmTextOut(pVM, "", 1);
1035 return;
1036 }
1037
1038
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 */
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
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 */
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 */
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 */
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
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
1162 static void quadFetch( |