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