1/*******************************************************************
2** v m . c
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*******************************************************************/
8/*
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
13** of the interp.
14*/
15/*
16** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
17** All rights reserved.
18**
19** Get the latest Ficl release at http://ficl.sourceforge.net
20**
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.
25**
26** L I C E N S E  and  D I S C L A I M E R
27**
28** Redistribution and use in source and binary forms, with or without
29** modification, are permitted provided that the following conditions
30** are met:
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.
36**
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
47** SUCH DAMAGE.
48*/
49
50
51#ifdef TESTMAIN
52#include <stdlib.h>
53#include <stdio.h>
54#include <ctype.h>
55#else
56#include <stand.h>
57#endif
58#include <stdarg.h>
59#include <string.h>
60#include "ficl.h"
61
62static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
63
64
65/**************************************************************************
66                        v m B r a n c h R e l a t i v e
67**
68**************************************************************************/
69void vmBranchRelative(FICL_VM *pVM, int offset)
70{
71    pVM->ip += offset;
72    return;
73}
74
75
76/**************************************************************************
77                        v m C r e a t e
78** Creates a virtual machine either from scratch (if pVM is NULL on entry)
79** or by resizing and reinitializing an existing VM to the specified stack
80** sizes.
81**************************************************************************/
82FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
83{
84    if (pVM == NULL)
85    {
86        pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
87        assert (pVM);
88        memset(pVM, 0, sizeof (FICL_VM));
89    }
90
91    if (pVM->pStack)
92        stackDelete(pVM->pStack);
93    pVM->pStack = stackCreate(nPStack);
94
95    if (pVM->rStack)
96        stackDelete(pVM->rStack);
97    pVM->rStack = stackCreate(nRStack);
98
99#if FICL_WANT_FLOAT
100    if (pVM->fStack)
101        stackDelete(pVM->fStack);
102    pVM->fStack = stackCreate(nPStack);
103#endif
104
105    pVM->textOut = ficlTextOut;
106
107    vmReset(pVM);
108    return pVM;
109}
110
111
112/**************************************************************************
113                        v m D e l e t e
114** Free all memory allocated to the specified VM and its subordinate
115** structures.
116**************************************************************************/
117void vmDelete (FICL_VM *pVM)
118{
119    if (pVM)
120    {
121        ficlFree(pVM->pStack);
122        ficlFree(pVM->rStack);
123#if FICL_WANT_FLOAT
124        ficlFree(pVM->fStack);
125#endif
126        ficlFree(pVM);
127    }
128
129    return;
130}
131
132
133/**************************************************************************
134                        v m E x e c u t e
135** Sets up the specified word to be run by the inner interpreter.
136** Executes the word's code part immediately, but in the case of
137** colon definition, the definition itself needs the inner interp
138** to complete. This does not happen until control reaches ficlExec
139**************************************************************************/
140void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
141{
142    pVM->runningWord = pWord;
143    pWord->code(pVM);
144    return;
145}
146
147
148/**************************************************************************
149                        v m I n n e r L o o p
150** the mysterious inner interpreter...
151** This loop is the address interpreter that makes colon definitions
152** work. Upon entry, it assumes that the IP points to an entry in
153** a definition (the body of a colon word). It runs one word at a time
154** until something does vmThrow. The catcher for this is expected to exist
155** in the calling code.
156** vmThrow gets you out of this loop with a longjmp()
157** Visual C++ 5 chokes on this loop in Release mode. Aargh.
158**************************************************************************/
159#if INLINE_INNER_LOOP == 0
160void vmInnerLoop(FICL_VM *pVM)
161{
162    M_INNER_LOOP(pVM);
163}
164#endif
165#if 0
166/*
167** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations,
168** as well as create does> : ; and various literals
169*/
170typedef enum
171{
172    PATCH = 0,
173    L0,
174    L1,
175    L2,
176    LMINUS1,
177    LMINUS2,
178    DROP,
179    SWAP,
180    DUP,
181    PICK,
182    ROLL,
183    FETCH,
184    STORE,
185    BRANCH,
186    CBRANCH,
187    LEAVE,
188    TO_R,
189    R_FROM,
190    EXIT;
191} OPCODE;
192
193typedef CELL *IPTYPE;
194
195void vmInnerLoop(FICL_VM *pVM)
196{
197    IPTYPE ip = pVM->ip;
198    FICL_STACK *pStack = pVM->pStack;
199
200    for (;;)
201    {
202        OPCODE o = (*ip++).i;
203        CELL c;
204        switch (o)
205        {
206        case L0:
207            stackPushINT(pStack, 0);
208            break;
209        case L1:
210            stackPushINT(pStack, 1);
211            break;
212        case L2:
213            stackPushINT(pStack, 2);
214            break;
215        case LMINUS1:
216            stackPushINT(pStack, -1);
217            break;
218        case LMINUS2:
219            stackPushINT(pStack, -2);
220            break;
221        case DROP:
222            stackDrop(pStack, 1);
223            break;
224        case SWAP:
225            stackRoll(pStack, 1);
226            break;
227        case DUP:
228            stackPick(pStack, 0);
229            break;
230        case PICK:
231            c = *ip++;
232            stackPick(pStack, c.i);
233            break;
234        case ROLL:
235            c = *ip++;
236            stackRoll(pStack, c.i);
237            break;
238        case EXIT:
239            return;
240        }
241    }
242
243    return;
244}
245#endif
246
247
248
249/**************************************************************************
250                        v m G e t D i c t
251** Returns the address dictionary for this VM's system
252**************************************************************************/
253FICL_DICT  *vmGetDict(FICL_VM *pVM)
254{
255	assert(pVM);
256	return pVM->pSys->dp;
257}
258
259
260/**************************************************************************
261                        v m G e t S t r i n g
262** Parses a string out of the VM input buffer and copies up to the first
263** FICL_STRING_MAX characters to the supplied destination buffer, a
264** FICL_STRING. The destination string is NULL terminated.
265**
266** Returns the address of the first unused character in the dest buffer.
267**************************************************************************/
268char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
269{
270    STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
271
272    if (SI_COUNT(si) > FICL_STRING_MAX)
273    {
274        SI_SETLEN(si, FICL_STRING_MAX);
275    }
276
277    strncpy(spDest->text, SI_PTR(si), SI_COUNT(si));
278    spDest->text[SI_COUNT(si)] = '\0';
279    spDest->count = (FICL_COUNT)SI_COUNT(si);
280
281    return spDest->text + SI_COUNT(si) + 1;
282}
283
284
285/**************************************************************************
286                        v m G e t W o r d
287** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
288** non-zero length.
289**************************************************************************/
290STRINGINFO vmGetWord(FICL_VM *pVM)
291{
292    STRINGINFO si = vmGetWord0(pVM);
293
294    if (SI_COUNT(si) == 0)
295    {
296        vmThrow(pVM, VM_RESTART);
297    }
298
299    return si;
300}
301
302
303/**************************************************************************
304                        v m G e t W o r d 0
305** Skip leading whitespace and parse a space delimited word from the tib.
306** Returns the start address and length of the word. Updates the tib
307** to reflect characters consumed, including the trailing delimiter.
308** If there's nothing of interest in the tib, returns zero. This function
309** does not use vmParseString because it uses isspace() rather than a
310** single  delimiter character.
311**************************************************************************/
312STRINGINFO vmGetWord0(FICL_VM *pVM)
313{
314    char *pSrc      = vmGetInBuf(pVM);
315    char *pEnd      = vmGetInBufEnd(pVM);
316    STRINGINFO si;
317    FICL_UNS count = 0;
318    char ch = 0;
319
320    pSrc = skipSpace(pSrc, pEnd);
321    SI_SETPTR(si, pSrc);
322
323/*
324    for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
325    {
326        count++;
327    }
328*/
329
330    /* Changed to make Purify happier.  --lch */
331    for (;;)
332    {
333        if (pEnd == pSrc)
334            break;
335        ch = *pSrc;
336        if (isspace(ch))
337            break;
338        count++;
339        pSrc++;
340    }
341
342    SI_SETLEN(si, count);
343
344    if ((pEnd != pSrc) && isspace(ch))    /* skip one trailing delimiter */
345        pSrc++;
346
347    vmUpdateTib(pVM, pSrc);
348
349    return si;
350}
351
352
353/**************************************************************************
354                        v m G e t W o r d T o P a d
355** Does vmGetWord and copies the result to the pad as a NULL terminated
356** string. Returns the length of the string. If the string is too long
357** to fit in the pad, it is truncated.
358**************************************************************************/
359int vmGetWordToPad(FICL_VM *pVM)
360{
361    STRINGINFO si;
362    char *cp = (char *)pVM->pad;
363    si = vmGetWord(pVM);
364
365    if (SI_COUNT(si) > nPAD)
366        SI_SETLEN(si, nPAD);
367
368    strncpy(cp, SI_PTR(si), SI_COUNT(si));
369    cp[SI_COUNT(si)] = '\0';
370    return (int)(SI_COUNT(si));
371}
372
373
374/**************************************************************************
375                        v m P a r s e S t r i n g
376** Parses a string out of the input buffer using the delimiter
377** specified. Skips leading delimiters, marks the start of the string,
378** and counts characters to the next delimiter it encounters. It then
379** updates the vm input buffer to consume all these chars, including the
380** trailing delimiter.
381** Returns the address and length of the parsed string, not including the
382** trailing delimiter.
383**************************************************************************/
384STRINGINFO vmParseString(FICL_VM *pVM, char delim)
385{
386    return vmParseStringEx(pVM, delim, 1);
387}
388
389STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
390{
391    STRINGINFO si;
392    char *pSrc      = vmGetInBuf(pVM);
393    char *pEnd      = vmGetInBufEnd(pVM);
394    char ch;
395
396    if (fSkipLeading)
397    {                       /* skip lead delimiters */
398        while ((pSrc != pEnd) && (*pSrc == delim))
399            pSrc++;
400    }
401
402    SI_SETPTR(si, pSrc);    /* mark start of text */
403
404    for (ch = *pSrc; (pSrc != pEnd)
405                  && (ch != delim)
406                  && (ch != '\r')
407                  && (ch != '\n'); ch = *++pSrc)
408    {
409        ;                   /* find next delimiter or end of line */
410    }
411
412                            /* set length of result */
413    SI_SETLEN(si, pSrc - SI_PTR(si));
414
415    if ((pSrc != pEnd) && (*pSrc == delim))     /* gobble trailing delimiter */
416        pSrc++;
417
418    vmUpdateTib(pVM, pSrc);
419    return si;
420}
421
422
423/**************************************************************************
424                        v m P o p
425**
426**************************************************************************/
427CELL vmPop(FICL_VM *pVM)
428{
429    return stackPop(pVM->pStack);
430}
431
432
433/**************************************************************************
434                        v m P u s h
435**
436**************************************************************************/
437void vmPush(FICL_VM *pVM, CELL c)
438{
439    stackPush(pVM->pStack, c);
440    return;
441}
442
443
444/**************************************************************************
445                        v m P o p I P
446**
447**************************************************************************/
448void vmPopIP(FICL_VM *pVM)
449{
450    pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
451    return;
452}
453
454
455/**************************************************************************
456                        v m P u s h I P
457**
458**************************************************************************/
459void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
460{
461    stackPushPtr(pVM->rStack, (void *)pVM->ip);
462    pVM->ip = newIP;
463    return;
464}
465
466
467/**************************************************************************
468                        v m P u s h T i b
469** Binds the specified input string to the VM and clears >IN (the index)
470**************************************************************************/
471void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib)
472{
473    if (pSaveTib)
474    {
475        *pSaveTib = pVM->tib;
476    }
477
478    pVM->tib.cp = text;
479    pVM->tib.end = text + nChars;
480    pVM->tib.index = 0;
481}
482
483
484void vmPopTib(FICL_VM *pVM, TIB *pTib)
485{
486    if (pTib)
487    {
488        pVM->tib = *pTib;
489    }
490    return;
491}
492
493
494/**************************************************************************
495                        v m Q u i t
496**
497**************************************************************************/
498void vmQuit(FICL_VM *pVM)
499{
500    stackReset(pVM->rStack);
501    pVM->fRestart    = 0;
502    pVM->ip          = NULL;
503    pVM->runningWord = NULL;
504    pVM->state       = INTERPRET;
505    pVM->tib.cp      = NULL;
506    pVM->tib.end     = NULL;
507    pVM->tib.index   = 0;
508    pVM->pad[0]      = '\0';
509    pVM->sourceID.i  = 0;
510    return;
511}
512
513
514/**************************************************************************
515                        v m R e s e t
516**
517**************************************************************************/
518void vmReset(FICL_VM *pVM)
519{
520    vmQuit(pVM);
521    stackReset(pVM->pStack);
522#if FICL_WANT_FLOAT
523    stackReset(pVM->fStack);
524#endif
525    pVM->base        = 10;
526    return;
527}
528
529
530/**************************************************************************
531                        v m S e t T e x t O u t
532** Binds the specified output callback to the vm. If you pass NULL,
533** binds the default output function (ficlTextOut)
534**************************************************************************/
535void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut)
536{
537    if (textOut)
538        pVM->textOut = textOut;
539    else
540        pVM->textOut = ficlTextOut;
541
542    return;
543}
544
545
546/**************************************************************************
547                        v m T e x t O u t
548** Feeds text to the vm's output callback
549**************************************************************************/
550void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
551{
552    assert(pVM);
553    assert(pVM->textOut);
554    (pVM->textOut)(pVM, text, fNewline);
555
556    return;
557}
558
559
560/**************************************************************************
561                        v m T h r o w
562**
563**************************************************************************/
564void vmThrow(FICL_VM *pVM, int except)
565{
566    if (pVM->pState)
567        longjmp(*(pVM->pState), except);
568}
569
570
571void vmThrowErr(FICL_VM *pVM, char *fmt, ...)
572{
573    va_list va;
574    va_start(va, fmt);
575    vsprintf(pVM->pad, fmt, va);
576    vmTextOut(pVM, pVM->pad, 1);
577    va_end(va);
578    longjmp(*(pVM->pState), VM_ERREXIT);
579}
580
581
582/**************************************************************************
583                        w o r d I s I m m e d i a t e
584**
585**************************************************************************/
586int wordIsImmediate(FICL_WORD *pFW)
587{
588    return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
589}
590
591
592/**************************************************************************
593                        w o r d I s C o m p i l e O n l y
594**
595**************************************************************************/
596int wordIsCompileOnly(FICL_WORD *pFW)
597{
598    return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
599}
600
601
602/**************************************************************************
603                        s t r r e v
604**
605**************************************************************************/
606char *strrev( char *string )
607{                               /* reverse a string in-place */
608    int i = strlen(string);
609    char *p1 = string;          /* first char of string */
610    char *p2 = string + i - 1;  /* last non-NULL char of string */
611    char c;
612
613    if (i > 1)
614    {
615        while (p1 < p2)
616        {
617            c = *p2;
618            *p2 = *p1;
619            *p1 = c;
620            p1++; p2--;
621        }
622    }
623
624    return string;
625}
626
627
628/**************************************************************************
629                        d i g i t _ t o _ c h a r
630**
631**************************************************************************/
632char digit_to_char(int value)
633{
634    return digits[value];
635}
636
637
638/**************************************************************************
639                        i s P o w e r O f T w o
640** Tests whether supplied argument is an integer power of 2 (2**n)
641** where 32 > n > 1, and returns n if so. Otherwise returns zero.
642**************************************************************************/
643int isPowerOfTwo(FICL_UNS u)
644{
645    int i = 1;
646    FICL_UNS t = 2;
647
648    for (; ((t <= u) && (t != 0)); i++, t <<= 1)
649    {
650        if (u == t)
651            return i;
652    }
653
654    return 0;
655}
656
657
658/**************************************************************************
659                        l t o a
660**
661**************************************************************************/
662char *ltoa( FICL_INT value, char *string, int radix )
663{                               /* convert long to string, any base */
664    char *cp = string;
665    int sign = ((radix == 10) && (value < 0));
666    int pwr;
667
668    assert(radix > 1);
669    assert(radix < 37);
670    assert(string);
671
672    pwr = isPowerOfTwo((FICL_UNS)radix);
673
674    if (sign)
675        value = -value;
676
677    if (value == 0)
678        *cp++ = '0';
679    else if (pwr != 0)
680    {
681        FICL_UNS v = (FICL_UNS) value;
682        FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
683        while (v)
684        {
685            *cp++ = digits[v & mask];
686            v >>= pwr;
687        }
688    }
689    else
690    {
691        UNSQR result;
692        DPUNS v;
693        v.hi = 0;
694        v.lo = (FICL_UNS)value;
695        while (v.lo)
696        {
697            result = ficlLongDiv(v, (FICL_UNS)radix);
698            *cp++ = digits[result.rem];
699            v.lo = result.quot;
700        }
701    }
702
703    if (sign)
704        *cp++ = '-';
705
706    *cp++ = '\0';
707
708    return strrev(string);
709}
710
711
712/**************************************************************************
713                        u l t o a
714**
715**************************************************************************/
716char *ultoa(FICL_UNS value, char *string, int radix )
717{                               /* convert long to string, any base */
718    char *cp = string;
719    DPUNS ud;
720    UNSQR result;
721
722    assert(radix > 1);
723    assert(radix < 37);
724    assert(string);
725
726    if (value == 0)
727        *cp++ = '0';
728    else
729    {
730        ud.hi = 0;
731        ud.lo = value;
732        result.quot = value;
733
734        while (ud.lo)
735        {
736            result = ficlLongDiv(ud, (FICL_UNS)radix);
737            ud.lo = result.quot;
738            *cp++ = digits[result.rem];
739        }
740    }
741
742    *cp++ = '\0';
743
744    return strrev(string);
745}
746
747
748/**************************************************************************
749                        c a s e F o l d
750** Case folds a NULL terminated string in place. All characters
751** get converted to lower case.
752**************************************************************************/
753char *caseFold(char *cp)
754{
755    char *oldCp = cp;
756
757    while (*cp)
758    {
759        if (isupper(*cp))
760            *cp = (char)tolower(*cp);
761        cp++;
762    }
763
764    return oldCp;
765}
766
767
768/**************************************************************************
769                        s t r i n c m p
770** (jws) simplified the code a bit in hopes of appeasing Purify
771**************************************************************************/
772int strincmp(char *cp1, char *cp2, FICL_UNS count)
773{
774    int i = 0;
775
776    for (; 0 < count; ++cp1, ++cp2, --count)
777    {
778        i = tolower(*cp1) - tolower(*cp2);
779        if (i != 0)
780            return i;
781        else if (*cp1 == '\0')
782            return 0;
783    }
784    return 0;
785}
786
787/**************************************************************************
788                        s k i p S p a c e
789** Given a string pointer, returns a pointer to the first non-space
790** char of the string, or to the NULL terminator if no such char found.
791** If the pointer reaches "end" first, stop there. Pass NULL to
792** suppress this behavior.
793**************************************************************************/
794char *skipSpace(char *cp, char *end)
795{
796    assert(cp);
797
798    while ((cp != end) && isspace(*cp))
799        cp++;
800
801    return cp;
802}
803
804
805