sys/boot/ficl/vm.c

   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 **
   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 /* $FreeBSD: src/sys/boot/ficl/vm.c,v 1.5.2.1 2000/07/06 23:51:45 obrien Exp $ */
  17
  18 #ifdef TESTMAIN
  19 #include <stdlib.h>
  20 #include <stdio.h>
  21 #include <ctype.h>
  22 #else
  23 #include <stand.h>
  24 #endif
  25 #include <stdarg.h>
  26 #include <string.h>
  27 #include "ficl.h"
  28
  29 static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  30
  31
  32 /**************************************************************************
  33                         v m B r a n c h R e l a t i v e
  34 **
  35 **************************************************************************/
  36 void vmBranchRelative(FICL_VM *pVM, int offset)
  37 {
  38     pVM->ip += offset;
  39     return;
  40 }
  41
  42
  43 /**************************************************************************
  44                         v m C r e a t e
  45 **
  46 **************************************************************************/
  47 FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
  48 {
  49     if (pVM == NULL)
  50     {
  51         pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
  52         assert (pVM);
  53         memset(pVM, 0, sizeof (FICL_VM));
  54     }
  55
  56     if (pVM->pStack)
  57         stackDelete(pVM->pStack);
  58     pVM->pStack = stackCreate(nPStack);
  59
  60     if (pVM->rStack)
  61         stackDelete(pVM->rStack);
  62     pVM->rStack = stackCreate(nRStack);
  63
  64     pVM->textOut = ficlTextOut;
  65
  66     vmReset(pVM);
  67     return pVM;
  68 }
  69
  70
  71 /**************************************************************************
  72                         v m D e l e t e
  73 **
  74 **************************************************************************/
  75 void vmDelete (FICL_VM *pVM)
  76 {
  77     if (pVM)
  78     {
  79         ficlFree(pVM->pStack);
  80         ficlFree(pVM->rStack);
  81         ficlFree(pVM);
  82     }
  83
  84     return;
  85 }
  86
  87
  88 /**************************************************************************
  89                         v m E x e c u t e
  90 ** Sets up the specified word to be run by the inner interpreter.
  91 ** Executes the word's code part immediately, but in the case of
  92 ** colon definition, the definition itself needs the inner interp
  93 ** to complete. This does not happen until control reaches ficlExec
  94 **************************************************************************/
  95 void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
  96 {
  97     pVM->runningWord = pWord;
  98     pWord->code(pVM);
  99     return;
 100 }
 101
 102
 103 /**************************************************************************
 104                         v m I n n e r L o o p
 105 ** the mysterious inner interpreter...
 106 ** This loop is the address interpreter that makes colon definitions
 107 ** work. Upon entry, it assumes that the IP points to an entry in
 108 ** a definition (the body of a colon word). It runs one word at a time
 109 ** until something does vmThrow. The catcher for this is expected to exist
 110 ** in the calling code.
 111 ** vmThrow gets you out of this loop with a longjmp()
 112 ** Visual C++ 5 chokes on this loop in Release mode. Aargh.
 113 **************************************************************************/
 114 #if INLINE_INNER_LOOP == 0
 115 void vmInnerLoop(FICL_VM *pVM)
 116 {
 117     M_INNER_LOOP(pVM);
 118 }
 119 #endif
 120
 121
 122 /**************************************************************************
 123                         v m G e t S t r i n g
 124 ** Parses a string out of the VM input buffer and copies up to the first
 125 ** FICL_STRING_MAX characters to the supplied destination buffer, a
 126 ** FICL_STRING. The destination string is NULL terminated.
 127 **
 128 ** Returns the address of the first unused character in the dest buffer.
 129 **************************************************************************/
 130 char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
 131 {
 132     STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
 133
 134     if (SI_COUNT(si) > FICL_STRING_MAX)
 135     {
 136         SI_SETLEN(si, FICL_STRING_MAX);
 137     }
 138
 139     strncpy(spDest->text, SI_PTR(si), SI_COUNT(si));
 140     spDest->text[SI_COUNT(si)] = '\0';
 141     spDest->count = (FICL_COUNT)SI_COUNT(si);
 142
 143     return spDest->text + SI_COUNT(si) + 1;
 144 }
 145
 146
 147 /**************************************************************************
 148                         v m G e t W o r d
 149 ** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
 150 ** non-zero length.
 151 **************************************************************************/
 152 STRINGINFO vmGetWord(FICL_VM *pVM)
 153 {
 154     STRINGINFO si = vmGetWord0(pVM);
 155
 156     if (SI_COUNT(si) == 0)
 157     {
 158         vmThrow(pVM, VM_RESTART);
 159     }
 160
 161     return si;
 162 }
 163
 164
 165 /**************************************************************************
 166                         v m G e t W o r d 0
 167 ** Skip leading whitespace and parse a space delimited word from the tib.
 168 ** Returns the start address and length of the word. Updates the tib
 169 ** to reflect characters consumed, including the trailing delimiter.
 170 ** If there's nothing of interest in the tib, returns zero. This function
 171 ** does not use vmParseString because it uses isspace() rather than a
 172 ** single  delimiter character.
 173 **************************************************************************/
 174 STRINGINFO vmGetWord0(FICL_VM *pVM)
 175 {
 176     char *pSrc      = vmGetInBuf(pVM);
 177     char *pEnd      = vmGetInBufEnd(pVM);
 178     STRINGINFO si;
 179     FICL_UNS count = 0;
 180     char ch;
 181
 182     pSrc = skipSpace(pSrc, pEnd);
 183     SI_SETPTR(si, pSrc);
 184
 185     for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
 186     {
 187         count++;
 188     }
 189
 190     SI_SETLEN(si, count);
 191
 192     if ((pEnd != pSrc) && isspace(ch))    /* skip one trailing delimiter */
 193         pSrc++;
 194
 195     vmUpdateTib(pVM, pSrc);
 196
 197     return si;
 198 }
 199
 200
 201 /**************************************************************************
 202                         v m G e t W o r d T o P a d
 203 ** Does vmGetWord0 and copies the result to the pad as a NULL terminated
 204 ** string. Returns the length of the string. If the string is too long
 205 ** to fit in the pad, it is truncated.
 206 **************************************************************************/
 207 int vmGetWordToPad(FICL_VM *pVM)
 208 {
 209     STRINGINFO si;
 210     char *cp = (char *)pVM->pad;
 211     si = vmGetWord0(pVM);
 212
 213     if (SI_COUNT(si) > nPAD)
 214         SI_SETLEN(si, nPAD);
 215
 216     strncpy(cp, SI_PTR(si), SI_COUNT(si));
 217     cp[SI_COUNT(si)] = '\0';
 218     return (int)(SI_COUNT(si));
 219 }
 220
 221
 222 /**************************************************************************
 223                         v m P a r s e S t r i n g
 224 ** Parses a string out of the input buffer using the delimiter
 225 ** specified. Skips leading delimiters, marks the start of the string,
 226 ** and counts characters to the next delimiter it encounters. It then
 227 ** updates the vm input buffer to consume all these chars, including the
 228 ** trailing delimiter.
 229 ** Returns the address and length of the parsed string, not including the
 230 ** trailing delimiter.
 231 **************************************************************************/
 232 STRINGINFO vmParseString(FICL_VM *pVM, char delim)
 233 {
 234         return vmParseStringEx(pVM, delim, 1);
 235 }
 236
 237 STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
 238 {
 239     STRINGINFO si;
 240     char *pSrc      = vmGetInBuf(pVM);
 241     char *pEnd      = vmGetInBufEnd(pVM);
 242     char ch;
 243
 244         if (fSkipLeading)
 245         {                       /* skip lead delimiters */
 246                 while ((pSrc != pEnd) && (*pSrc == delim))
 247                         pSrc++;
 248         }
 249
 250     SI_SETPTR(si, pSrc);    /* mark start of text */
 251
 252     for (ch = *pSrc; (pSrc != pEnd)
 253                   && (ch != delim)
 254                   && (ch != '\r')
 255                   && (ch != '\n'); ch = *++pSrc)
 256     {
 257         ;                   /* find next delimiter or end of line */
 258     }
 259
 260                             /* set length of result */
 261     SI_SETLEN(si, pSrc - SI_PTR(si));
 262
 263     if ((pSrc != pEnd) && (*pSrc == delim))     /* gobble trailing delimiter */
 264         pSrc++;
 265
 266     vmUpdateTib(pVM, pSrc);
 267     return si;
 268 }
 269
 270
 271 /**************************************************************************
 272                         v m P o p
 273 **
 274 **************************************************************************/
 275 CELL vmPop(FICL_VM *pVM)
 276 {
 277     return stackPop(pVM->pStack);
 278 }
 279
 280
 281 /**************************************************************************
 282                         v m P u s h
 283 **
 284 **************************************************************************/
 285 void vmPush(FICL_VM *pVM, CELL c)
 286 {
 287     stackPush(pVM->pStack, c);
 288     return;
 289 }
 290
 291
 292 /**************************************************************************
 293                         v m P o p I P
 294 **
 295 **************************************************************************/
 296 void vmPopIP(FICL_VM *pVM)
 297 {
 298     pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
 299     return;
 300 }
 301
 302
 303 /**************************************************************************
 304                         v m P u s h I P
 305 **
 306 **************************************************************************/
 307 void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
 308 {
 309     stackPushPtr(pVM->rStack, (void *)pVM->ip);
 310     pVM->ip = newIP;
 311     return;
 312 }
 313
 314
 315 /**************************************************************************
 316                         v m P u s h T i b
 317 ** Binds the specified input string to the VM and clears >IN (the index)
 318 **************************************************************************/
 319 void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib)
 320 {
 321     if (pSaveTib)
 322     {
 323         *pSaveTib = pVM->tib;
 324     }
 325
 326     pVM->tib.cp = text;
 327     pVM->tib.end = text + nChars;
 328     pVM->tib.index = 0;
 329 }
 330
 331
 332 void vmPopTib(FICL_VM *pVM, TIB *pTib)
 333 {
 334     if (pTib)
 335     {
 336         pVM->tib = *pTib;
 337     }
 338     return;
 339 }
 340
 341
 342 /**************************************************************************
 343                         v m Q u i t
 344 **
 345 **************************************************************************/
 346 void vmQuit(FICL_VM *pVM)
 347 {
 348     static FICL_WORD *pInterp = NULL;
 349     if (!pInterp)
 350         pInterp = ficlLookup("interpret");
 351     assert(pInterp);
 352
 353     stackReset(pVM->rStack);
 354     pVM->fRestart    = 0;
 355     pVM->ip          = &pInterp;
 356     pVM->runningWord = pInterp;
 357     pVM->state       = INTERPRET;
 358     pVM->tib.cp      = NULL;
 359     pVM->tib.end     = NULL;
 360     pVM->tib.index   = 0;
 361     pVM->pad[0]      = '\0';
 362     pVM->sourceID.i  = 0;
 363     return;
 364 }
 365
 366
 367 /**************************************************************************
 368                         v m R e s e t
 369 **
 370 **************************************************************************/
 371 void vmReset(FICL_VM *pVM)
 372 {
 373     vmQuit(pVM);
 374     stackReset(pVM->pStack);
 375     pVM->base        = 10;
 376     return;
 377 }
 378
 379
 380 /**************************************************************************
 381                         v m S e t T e x t O u t
 382 ** Binds the specified output callback to the vm. If you pass NULL,
 383 ** binds the default output function (ficlTextOut)
 384 **************************************************************************/
 385 void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut)
 386 {
 387     if (textOut)
 388         pVM->textOut = textOut;
 389     else
 390         pVM->textOut = ficlTextOut;
 391
 392     return;
 393 }
 394
 395
 396 /**************************************************************************
 397                         v m S t e p
 398 ** Single step the vm - equivalent to "step into" - used for debugging
 399 **************************************************************************/
 400 #if FICL_WANT_DEBUGGER
 401 void vmStep(FICL_VM *pVM)
 402 {
 403         M_VM_STEP(pVM);
 404 }
 405 #endif
 406
 407
 408 /**************************************************************************
 409                         v m T e x t O u t
 410 ** Feeds text to the vm's output callback
 411 **************************************************************************/
 412 void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
 413 {
 414     assert(pVM);
 415     assert(pVM->textOut);
 416     (pVM->textOut)(pVM, text, fNewline);
 417
 418     return;
 419 }
 420
 421
 422 /**************************************************************************
 423                         v m T h r o w
 424 **
 425 **************************************************************************/
 426 void vmThrow(FICL_VM *pVM, int except)
 427 {
 428     if (pVM->pState)
 429         longjmp(*(pVM->pState), except);
 430 }
 431
 432
 433 void vmThrowErr(FICL_VM *pVM, char *fmt, ...)
 434 {
 435     va_list va;
 436     va_start(va, fmt);
 437     vsprintf(pVM->pad, fmt, va);
 438     vmTextOut(pVM, pVM->pad, 1);
 439     va_end(va);
 440     longjmp(*(pVM->pState), VM_ERREXIT);
 441 }
 442
 443
 444 /**************************************************************************
 445                         w o r d I s I m m e d i a t e
 446 **
 447 **************************************************************************/
 448 int wordIsImmediate(FICL_WORD *pFW)
 449 {
 450     return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
 451 }
 452
 453
 454 /**************************************************************************
 455                         w o r d I s C o m p i l e O n l y
 456 **
 457 **************************************************************************/
 458 int wordIsCompileOnly(FICL_WORD *pFW)
 459 {
 460     return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
 461 }
 462
 463
 464 /**************************************************************************
 465                         s t r r e v
 466 **
 467 **************************************************************************/
 468 char *strrev( char *string )
 469 {                               /* reverse a string in-place */
 470     int i = strlen(string);
 471     char *p1 = string;          /* first char of string */
 472     char *p2 = string + i - 1;  /* last non-NULL char of string */
 473     char c;
 474
 475     if (i > 1)
 476     {
 477         while (p1 < p2)
 478         {
 479             c = *p2;
 480             *p2 = *p1;
 481             *p1 = c;
 482             p1++; p2--;
 483         }
 484     }
 485
 486     return string;
 487 }
 488
 489
 490 /**************************************************************************
 491                         d i g i t _ t o _ c h a r
 492 **
 493 **************************************************************************/
 494 char digit_to_char(int value)
 495 {
 496     return digits[value];
 497 }
 498
 499
 500 /**************************************************************************
 501                         i s P o w e r O f T w o
 502 ** Tests whether supplied argument is an integer power of 2 (2**n)
 503 ** where 32 > n > 1, and returns n if so. Otherwise returns zero.
 504 **************************************************************************/
 505 int isPowerOfTwo(FICL_UNS u)
 506 {
 507     int i = 1;
 508     FICL_UNS t = 2;
 509
 510     for (; ((t <= u) && (t != 0)); i++, t <<= 1)
 511     {
 512         if (u == t)
 513             return i;
 514     }
 515
 516     return 0;
 517 }
 518
 519
 520 /**************************************************************************
 521                         l t o a
 522 **
 523 **************************************************************************/
 524 char *ltoa( FICL_INT value, char *string, int radix )
 525 {                               /* convert long to string, any base */
 526     char *cp = string;
 527     int sign = ((radix == 10) && (value < 0));
 528     int pwr;
 529
 530     assert(radix > 1);
 531     assert(radix < 37);
 532     assert(string);
 533
 534     pwr = isPowerOfTwo((FICL_UNS)radix);
 535
 536     if (sign)
 537         value = -value;
 538
 539     if (value == 0)
 540         *cp++ = '0';
 541     else if (pwr != 0)
 542     {
 543         FICL_UNS v = (FICL_UNS) value;
 544         FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
 545         while (v)
 546         {
 547             *cp++ = digits[v & mask];
 548             v >>= pwr;
 549         }
 550     }
 551     else
 552     {
 553         UNSQR result;
 554         DPUNS v;
 555         v.hi = 0;
 556         v.lo = (FICL_UNS)value;
 557         while (v.lo)
 558         {
 559             result = ficlLongDiv(v, (FICL_UNS)radix);
 560             *cp++ = digits[result.rem];
 561             v.lo = result.quot;
 562         }
 563     }
 564
 565     if (sign)
 566         *cp++ = '-';
 567
 568     *cp++ = '\0';
 569
 570     return strrev(string);
 571 }
 572
 573
 574 /**************************************************************************
 575                         u l t o a
 576 **
 577 **************************************************************************/
 578 char *ultoa(FICL_UNS value, char *string, int radix )
 579 {                               /* convert long to string, any base */
 580     char *cp = string;
 581     DPUNS ud;
 582     UNSQR result;
 583
 584     assert(radix > 1);
 585     assert(radix < 37);
 586     assert(string);
 587
 588     if (value == 0)
 589         *cp++ = '0';
 590     else
 591     {
 592         ud.hi = 0;
 593         ud.lo = value;
 594         result.quot = value;
 595
 596         while (ud.lo)
 597         {
 598             result = ficlLongDiv(ud, (FICL_UNS)radix);
 599             ud.lo = result.quot;
 600             *cp++ = digits[result.rem];
 601         }
 602     }
 603
 604     *cp++ = '\0';
 605
 606     return strrev(string);
 607 }
 608
 609
 610 /**************************************************************************
 611                         c a s e F o l d
 612 ** Case folds a NULL terminated string in place. All characters
 613 ** get converted to lower case.
 614 **************************************************************************/
 615 char *caseFold(char *cp)
 616 {
 617     char *oldCp = cp;
 618
 619     while (*cp)
 620     {
 621         if (isupper(*cp))
 622             *cp = (char)tolower(*cp);
 623         cp++;
 624     }
 625
 626     return oldCp;
 627 }
 628
 629
 630 /**************************************************************************
 631                         s t r i n c m p
 632 **
 633 **************************************************************************/
 634 int strincmp(char *cp1, char *cp2, FICL_COUNT count)
 635 {
 636     int i = 0;
 637     char c1, c2;
 638
 639     for (c1 = *cp1, c2 = *cp2;
 640         ((i == 0) && count && c1 && c2);
 641         c1 = *++cp1, c2 = *++cp2, count--)
 642     {
 643         i = tolower(c1) - tolower(c2);
 644     }
 645
 646     return i;
 647 }
 648
 649
 650
 651 /**************************************************************************
 652                         s k i p S p a c e
 653 ** Given a string pointer, returns a pointer to the first non-space
 654 ** char of the string, or to the NULL terminator if no such char found.
 655 ** If the pointer reaches "end" first, stop there. Pass NULL to
 656 ** suppress this behavior.
 657 **************************************************************************/
 658 char *skipSpace(char *cp, char *end)
 659 {
 660     assert(cp);
 661
 662     while ((cp != end) && isspace(*cp))
 663         cp++;
 664
 665     return cp;
 666 }
 667
 668