1 /*******************************************************************
3 ** Forth Inspired Command Language - virtual machine methods
4 ** Author: John Sadler (john_sadler@alum.mit.edu)
5 ** Created: 19 July 1997
6 ** $Id: vm.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $
7 *******************************************************************/
9 ** This file implements the virtual machine of FICL. Each virtual
10 ** machine retains the state of an interpreter. A virtual machine
11 ** owns a pair of stacks for parameters and return addresses, as
12 ** well as a pile of state variables and the two dedicated registers
16 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
17 ** All rights reserved.
19 ** Get the latest Ficl release at http://ficl.sourceforge.net
21 ** I am interested in hearing from anyone who uses ficl. If you have
22 ** a problem, a success story, a defect, an enhancement request, or
23 ** if you would like to contribute to the ficl release, please
24 ** contact me by email at the address above.
26 ** L I C E N S E and D I S C L A I M E R
28 ** Redistribution and use in source and binary forms, with or without
29 ** modification, are permitted provided that the following conditions
31 ** 1. Redistributions of source code must retain the above copyright
32 ** notice, this list of conditions and the following disclaimer.
33 ** 2. Redistributions in binary form must reproduce the above copyright
34 ** notice, this list of conditions and the following disclaimer in the
35 ** documentation and/or other materials provided with the distribution.
37 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
38 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
39 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
40 ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
41 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
42 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
43 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
44 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
45 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
46 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
51 * $FreeBSD: src/sys/boot/ficl/vm.c,v 1.10 2007/03/23 22:26:01 jkim Exp $
52 * $DragonFly: src/sys/boot/ficl/vm.c,v 1.7 2008/03/29 23:31:07 swildner Exp $
66 static char digits
[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
69 /**************************************************************************
70 v m B r a n c h R e l a t i v e
72 **************************************************************************/
73 void vmBranchRelative(FICL_VM
*pVM
, int offset
)
80 /**************************************************************************
82 ** Creates a virtual machine either from scratch (if pVM is NULL on entry)
83 ** or by resizing and reinitializing an existing VM to the specified stack
85 **************************************************************************/
86 FICL_VM
*vmCreate(FICL_VM
*pVM
, unsigned nPStack
, unsigned nRStack
)
90 pVM
= (FICL_VM
*)ficlMalloc(sizeof (FICL_VM
));
92 memset(pVM
, 0, sizeof (FICL_VM
));
96 stackDelete(pVM
->pStack
);
97 pVM
->pStack
= stackCreate(nPStack
);
100 stackDelete(pVM
->rStack
);
101 pVM
->rStack
= stackCreate(nRStack
);
105 stackDelete(pVM
->fStack
);
106 pVM
->fStack
= stackCreate(nPStack
);
109 pVM
->textOut
= ficlTextOut
;
116 /**************************************************************************
118 ** Free all memory allocated to the specified VM and its subordinate
120 **************************************************************************/
121 void vmDelete (FICL_VM
*pVM
)
125 ficlFree(pVM
->pStack
);
126 ficlFree(pVM
->rStack
);
128 ficlFree(pVM
->fStack
);
137 /**************************************************************************
139 ** Sets up the specified word to be run by the inner interpreter.
140 ** Executes the word's code part immediately, but in the case of
141 ** colon definition, the definition itself needs the inner interp
142 ** to complete. This does not happen until control reaches ficlExec
143 **************************************************************************/
144 void vmExecute(FICL_VM
*pVM
, FICL_WORD
*pWord
)
146 pVM
->runningWord
= pWord
;
152 /**************************************************************************
153 v m I n n e r L o o p
154 ** the mysterious inner interpreter...
155 ** This loop is the address interpreter that makes colon definitions
156 ** work. Upon entry, it assumes that the IP points to an entry in
157 ** a definition (the body of a colon word). It runs one word at a time
158 ** until something does vmThrow. The catcher for this is expected to exist
159 ** in the calling code.
160 ** vmThrow gets you out of this loop with a longjmp()
161 ** Visual C++ 5 chokes on this loop in Release mode. Aargh.
162 **************************************************************************/
163 #if INLINE_INNER_LOOP == 0
164 void vmInnerLoop(FICL_VM
*pVM
)
171 ** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations,
172 ** as well as create does> : ; and various literals
197 typedef CELL
*IPTYPE
;
199 void vmInnerLoop(FICL_VM
*pVM
)
202 FICL_STACK
*pStack
= pVM
->pStack
;
206 OPCODE o
= (*ip
++).i
;
211 stackPushINT(pStack
, 0);
214 stackPushINT(pStack
, 1);
217 stackPushINT(pStack
, 2);
220 stackPushINT(pStack
, -1);
223 stackPushINT(pStack
, -2);
226 stackDrop(pStack
, 1);
229 stackRoll(pStack
, 1);
232 stackPick(pStack
, 0);
236 stackPick(pStack
, c
.i
);
240 stackRoll(pStack
, c
.i
);
253 /**************************************************************************
255 ** Returns the address dictionary for this VM's system
256 **************************************************************************/
257 FICL_DICT
*vmGetDict(FICL_VM
*pVM
)
260 return pVM
->pSys
->dp
;
264 /**************************************************************************
265 v m G e t S t r i n g
266 ** Parses a string out of the VM input buffer and copies up to the first
267 ** FICL_STRING_MAX characters to the supplied destination buffer, a
268 ** FICL_STRING. The destination string is NULL terminated.
270 ** Returns the address of the first unused character in the dest buffer.
271 **************************************************************************/
272 char *vmGetString(FICL_VM
*pVM
, FICL_STRING
*spDest
, char delimiter
)
274 STRINGINFO si
= vmParseStringEx(pVM
, delimiter
, 0);
276 if (SI_COUNT(si
) > FICL_STRING_MAX
)
278 SI_SETLEN(si
, FICL_STRING_MAX
);
281 strncpy(spDest
->text
, SI_PTR(si
), SI_COUNT(si
));
282 spDest
->text
[SI_COUNT(si
)] = '\0';
283 spDest
->count
= (FICL_COUNT
)SI_COUNT(si
);
285 return spDest
->text
+ SI_COUNT(si
) + 1;
289 /**************************************************************************
291 ** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
293 **************************************************************************/
294 STRINGINFO
vmGetWord(FICL_VM
*pVM
)
296 STRINGINFO si
= vmGetWord0(pVM
);
298 if (SI_COUNT(si
) == 0)
300 vmThrow(pVM
, VM_RESTART
);
307 /**************************************************************************
309 ** Skip leading whitespace and parse a space delimited word from the tib.
310 ** Returns the start address and length of the word. Updates the tib
311 ** to reflect characters consumed, including the trailing delimiter.
312 ** If there's nothing of interest in the tib, returns zero. This function
313 ** does not use vmParseString because it uses isspace() rather than a
314 ** single delimiter character.
315 **************************************************************************/
316 STRINGINFO
vmGetWord0(FICL_VM
*pVM
)
318 char *pSrc
= vmGetInBuf(pVM
);
319 char *pEnd
= vmGetInBufEnd(pVM
);
324 pSrc
= skipSpace(pSrc
, pEnd
);
328 for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
334 /* Changed to make Purify happier. --lch */
346 SI_SETLEN(si
, count
);
348 if ((pEnd
!= pSrc
) && isspace(ch
)) /* skip one trailing delimiter */
351 vmUpdateTib(pVM
, pSrc
);
357 /**************************************************************************
358 v m G e t W o r d T o P a d
359 ** Does vmGetWord and copies the result to the pad as a NULL terminated
360 ** string. Returns the length of the string. If the string is too long
361 ** to fit in the pad, it is truncated.
362 **************************************************************************/
363 int vmGetWordToPad(FICL_VM
*pVM
)
366 char *cp
= (char *)pVM
->pad
;
369 if (SI_COUNT(si
) > nPAD
)
372 strncpy(cp
, SI_PTR(si
), SI_COUNT(si
));
373 cp
[SI_COUNT(si
)] = '\0';
374 return (int)(SI_COUNT(si
));
378 /**************************************************************************
379 v m P a r s e S t r i n g
380 ** Parses a string out of the input buffer using the delimiter
381 ** specified. Skips leading delimiters, marks the start of the string,
382 ** and counts characters to the next delimiter it encounters. It then
383 ** updates the vm input buffer to consume all these chars, including the
384 ** trailing delimiter.
385 ** Returns the address and length of the parsed string, not including the
386 ** trailing delimiter.
387 **************************************************************************/
388 STRINGINFO
vmParseString(FICL_VM
*pVM
, char delim
)
390 return vmParseStringEx(pVM
, delim
, 1);
393 STRINGINFO
vmParseStringEx(FICL_VM
*pVM
, char delim
, char fSkipLeading
)
396 char *pSrc
= vmGetInBuf(pVM
);
397 char *pEnd
= vmGetInBufEnd(pVM
);
401 { /* skip lead delimiters */
402 while ((pSrc
!= pEnd
) && (*pSrc
== delim
))
406 SI_SETPTR(si
, pSrc
); /* mark start of text */
408 for (ch
= *pSrc
; (pSrc
!= pEnd
)
411 && (ch
!= '\n'); ch
= *++pSrc
)
413 ; /* find next delimiter or end of line */
416 /* set length of result */
417 SI_SETLEN(si
, pSrc
- SI_PTR(si
));
419 if ((pSrc
!= pEnd
) && (*pSrc
== delim
)) /* gobble trailing delimiter */
422 vmUpdateTib(pVM
, pSrc
);
427 /**************************************************************************
430 **************************************************************************/
431 CELL
vmPop(FICL_VM
*pVM
)
433 return stackPop(pVM
->pStack
);
437 /**************************************************************************
440 **************************************************************************/
441 void vmPush(FICL_VM
*pVM
, CELL c
)
443 stackPush(pVM
->pStack
, c
);
448 /**************************************************************************
451 **************************************************************************/
452 void vmPopIP(FICL_VM
*pVM
)
454 pVM
->ip
= (IPTYPE
)(stackPopPtr(pVM
->rStack
));
459 /**************************************************************************
462 **************************************************************************/
463 void vmPushIP(FICL_VM
*pVM
, IPTYPE newIP
)
465 stackPushPtr(pVM
->rStack
, (void *)pVM
->ip
);
471 /**************************************************************************
473 ** Binds the specified input string to the VM and clears >IN (the index)
474 **************************************************************************/
475 void vmPushTib(FICL_VM
*pVM
, char *text
, FICL_INT nChars
, TIB
*pSaveTib
)
479 *pSaveTib
= pVM
->tib
;
483 pVM
->tib
.end
= text
+ nChars
;
488 void vmPopTib(FICL_VM
*pVM
, TIB
*pTib
)
498 /**************************************************************************
501 **************************************************************************/
502 void vmQuit(FICL_VM
*pVM
)
504 stackReset(pVM
->rStack
);
507 pVM
->runningWord
= NULL
;
508 pVM
->state
= INTERPRET
;
518 /**************************************************************************
521 **************************************************************************/
522 void vmReset(FICL_VM
*pVM
)
525 stackReset(pVM
->pStack
);
527 stackReset(pVM
->fStack
);
534 /**************************************************************************
535 v m S e t T e x t O u t
536 ** Binds the specified output callback to the vm. If you pass NULL,
537 ** binds the default output function (ficlTextOut)
538 **************************************************************************/
539 void vmSetTextOut(FICL_VM
*pVM
, OUTFUNC textOut
)
542 pVM
->textOut
= textOut
;
544 pVM
->textOut
= ficlTextOut
;
550 /**************************************************************************
552 ** Feeds text to the vm's output callback
553 **************************************************************************/
554 void vmTextOut(FICL_VM
*pVM
, char *text
, int fNewline
)
557 assert(pVM
->textOut
);
558 (pVM
->textOut
)(pVM
, text
, fNewline
);
564 /**************************************************************************
567 **************************************************************************/
568 void vmThrow(FICL_VM
*pVM
, int except
)
571 longjmp(*(pVM
->pState
), except
);
575 void vmThrowErr(FICL_VM
*pVM
, char *fmt
, ...)
579 vsprintf(pVM
->pad
, fmt
, va
);
580 vmTextOut(pVM
, pVM
->pad
, 1);
582 longjmp(*(pVM
->pState
), VM_ERREXIT
);
586 /**************************************************************************
587 w o r d I s I m m e d i a t e
589 **************************************************************************/
590 int wordIsImmediate(FICL_WORD
*pFW
)
592 return ((pFW
!= NULL
) && (pFW
->flags
& FW_IMMEDIATE
));
596 /**************************************************************************
597 w o r d I s C o m p i l e O n l y
599 **************************************************************************/
600 int wordIsCompileOnly(FICL_WORD
*pFW
)
602 return ((pFW
!= NULL
) && (pFW
->flags
& FW_COMPILE
));
606 /**************************************************************************
609 **************************************************************************/
610 char *strrev( char *string
)
611 { /* reverse a string in-place */
612 int i
= strlen(string
);
613 char *p1
= string
; /* first char of string */
614 char *p2
= string
+ i
- 1; /* last non-NULL char of string */
632 /**************************************************************************
633 d i g i t _ t o _ c h a r
635 **************************************************************************/
636 char digit_to_char(int value
)
638 return digits
[value
];
642 /**************************************************************************
643 i s P o w e r O f T w o
644 ** Tests whether supplied argument is an integer power of 2 (2**n)
645 ** where 32 > n > 1, and returns n if so. Otherwise returns zero.
646 **************************************************************************/
647 int isPowerOfTwo(FICL_UNS u
)
652 for (; ((t
<= u
) && (t
!= 0)); i
++, t
<<= 1)
662 /**************************************************************************
665 **************************************************************************/
666 char *ltoa( FICL_INT value
, char *string
, int radix
)
667 { /* convert long to string, any base */
669 int sign
= ((radix
== 10) && (value
< 0));
676 pwr
= isPowerOfTwo((FICL_UNS
)radix
);
685 FICL_UNS v
= (FICL_UNS
) value
;
686 FICL_UNS mask
= (FICL_UNS
) ~(-1 << pwr
);
689 *cp
++ = digits
[v
& mask
];
698 v
.lo
= (FICL_UNS
)value
;
701 result
= ficlLongDiv(v
, (FICL_UNS
)radix
);
702 *cp
++ = digits
[result
.rem
];
712 return strrev(string
);
716 /**************************************************************************
719 **************************************************************************/
720 char *ultoa(FICL_UNS value
, char *string
, int radix
)
721 { /* convert long to string, any base */
740 result
= ficlLongDiv(ud
, (FICL_UNS
)radix
);
742 *cp
++ = digits
[result
.rem
];
748 return strrev(string
);
752 /**************************************************************************
754 ** Case folds a NULL terminated string in place. All characters
755 ** get converted to lower case.
756 **************************************************************************/
757 char *caseFold(char *cp
)
764 *cp
= (char)tolower(*cp
);
772 /**************************************************************************
774 ** (jws) simplified the code a bit in hopes of appeasing Purify
775 **************************************************************************/
776 int strincmp(char *cp1
, char *cp2
, FICL_UNS count
)
780 for (; 0 < count
; ++cp1
, ++cp2
, --count
)
782 i
= tolower(*cp1
) - tolower(*cp2
);
785 else if (*cp1
== '\0')
791 /**************************************************************************
793 ** Given a string pointer, returns a pointer to the first non-space
794 ** char of the string, or to the NULL terminator if no such char found.
795 ** If the pointer reaches "end" first, stop there. Pass NULL to
796 ** suppress this behavior.
797 **************************************************************************/
798 char *skipSpace(char *cp
, char *end
)
802 while ((cp
!= end
) && isspace(*cp
))