src/lvm.c

   1 /*
   2 ** $Id: lvm.c,v 1.58 1999/06/22 20:37:23 roberto Exp $
   3 ** Lua virtual machine
   4 ** See Copyright Notice in lua.h
   5 */
   6
   7
   8 #include <ctype.h>
   9 #include <limits.h>
  10 #include <stdio.h>
  11 #include <stdlib.h>
  12 #include <string.h>
  13
  14 #include "lauxlib.h"
  15 #include "ldo.h"
  16 #include "lfunc.h"
  17 #include "lgc.h"
  18 #include "lmem.h"
  19 #include "lobject.h"
  20 #include "lopcodes.h"
  21 #include "lstate.h"
  22 #include "lstring.h"
  23 #include "ltable.h"
  24 #include "ltm.h"
  25 #include "luadebug.h"
  26 #include "lvm.h"
  27
  28
  29 #ifdef OLD_ANSI
  30 #define strcoll(a,b)    strcmp(a,b)
  31 #endif
  32
  33
  34 #define highbyte(x)     ((x)<<8)
  35
  36
  37 /* Extra stack size to run a function: LUA_T_LINE(1), TM calls(2), ... */
  38 #define EXTRA_STACK     5
  39
  40
  41
  42 static TaggedString *strconc (TaggedString *l, TaggedString *r) {
  43   long nl = l->u.s.len;
  44   long nr = r->u.s.len;
  45   char *buffer = luaL_openspace(nl+nr);
  46   memcpy(buffer, l->str, nl);
  47   memcpy(buffer+nl, r->str, nr);
  48   return luaS_newlstr(buffer, nl+nr);
  49 }
  50
  51
  52 int luaV_tonumber (TObject *obj) {  /* LUA_NUMBER */
  53   if (ttype(obj) != LUA_T_STRING)
  54     return 1;
  55   else {
  56     double t;
  57     char *e = svalue(obj);
  58     int sig = 1;
  59     while (isspace((unsigned char)*e)) e++;
  60     if (*e == '-') {
  61       e++;
  62       sig = -1;
  63     }
  64     else if (*e == '+') e++;
  65     /* no digit before or after decimal point? */
  66     if (!isdigit((unsigned char)*e) && !isdigit((unsigned char)*(e+1)))
  67       return 2;
  68     t = luaO_str2d(e);
  69     if (t<0) return 2;
  70     nvalue(obj) = (real)t*sig;
  71     ttype(obj) = LUA_T_NUMBER;
  72     return 0;
  73   }
  74 }
  75
  76
  77 int luaV_tostring (TObject *obj) {  /* LUA_NUMBER */
  78   if (ttype(obj) != LUA_T_NUMBER)
  79     return 1;
  80   else {
  81     char s[32];  /* 16 digits, signal, point and \0  (+ some extra...) */
  82     sprintf(s, "%.16g", (double)nvalue(obj));
  83     tsvalue(obj) = luaS_new(s);
  84     ttype(obj) = LUA_T_STRING;
  85     return 0;
  86   }
  87 }
  88
  89
  90 void luaV_setn (Hash *t, int val) {
  91   TObject index, value;
  92   ttype(&index) = LUA_T_STRING; tsvalue(&index) = luaS_new("n");
  93   ttype(&value) = LUA_T_NUMBER; nvalue(&value) = val;
  94   luaH_set(t, &index, &value);
  95 }
  96
  97
  98 void luaV_closure (int nelems) {
  99   if (nelems > 0) {
 100     struct Stack *S = &L->stack;
 101     Closure *c = luaF_newclosure(nelems);
 102     c->consts[0] = *(S->top-1);
 103     memcpy(&c->consts[1], S->top-(nelems+1), nelems*sizeof(TObject));
 104     S->top -= nelems;
 105     ttype(S->top-1) = LUA_T_CLOSURE;
 106     (S->top-1)->value.cl = c;
 107   }
 108 }
 109
 110
 111 /*
 112 ** Function to index a table.
 113 ** Receives the table at top-2 and the index at top-1.
 114 */
 115 void luaV_gettable (void) {
 116   TObject *table = L->stack.top-2;
 117   TObject *im;
 118   if (ttype(table) != LUA_T_ARRAY) {  /* not a table, get gettable method */
 119     im = luaT_getimbyObj(table, IM_GETTABLE);
 120     if (ttype(im) == LUA_T_NIL)
 121       lua_error("indexed expression not a table");
 122   }
 123   else {  /* object is a table... */
 124     int tg = table->value.a->htag;
 125     im = luaT_getim(tg, IM_GETTABLE);
 126     if (ttype(im) == LUA_T_NIL) {  /* and does not have a "gettable" method */
 127       TObject *h = luaH_get(avalue(table), table+1);
 128       if (ttype(h) == LUA_T_NIL &&
 129           (ttype(im=luaT_getim(tg, IM_INDEX)) != LUA_T_NIL)) {
 130         /* result is nil and there is an "index" tag method */
 131         luaD_callTM(im, 2, 1);  /* calls it */
 132       }
 133       else {
 134         L->stack.top--;
 135         *table = *h;  /* "push" result into table position */
 136       }
 137       return;
 138     }
 139     /* else it has a "gettable" method, go through to next command */
 140   }
 141   /* object is not a table, or it has a "gettable" method */
 142   luaD_callTM(im, 2, 1);
 143 }
 144
 145
 146 /*
 147 ** Receives table at *t, index at *(t+1) and value at top.
 148 */
 149 void luaV_settable (TObject *t) {
 150   struct Stack *S = &L->stack;
 151   TObject *im;
 152   if (ttype(t) != LUA_T_ARRAY) {  /* not a table, get "settable" method */
 153     im = luaT_getimbyObj(t, IM_SETTABLE);
 154     if (ttype(im) == LUA_T_NIL)
 155       lua_error("indexed expression not a table");
 156   }
 157   else {  /* object is a table... */
 158     im = luaT_getim(avalue(t)->htag, IM_SETTABLE);
 159     if (ttype(im) == LUA_T_NIL) {  /* and does not have a "settable" method */
 160       luaH_set(avalue(t), t+1, S->top-1);
 161       S->top--;  /* pop value */
 162       return;
 163     }
 164     /* else it has a "settable" method, go through to next command */
 165   }
 166   /* object is not a table, or it has a "settable" method */
 167   /* prepare arguments and call the tag method */
 168   *(S->top+1) = *(L->stack.top-1);
 169   *(S->top) = *(t+1);
 170   *(S->top-1) = *t;
 171   S->top += 2;  /* WARNING: caller must assure stack space */
 172   luaD_callTM(im, 3, 0);
 173 }
 174
 175
 176 void luaV_rawsettable (TObject *t) {
 177   if (ttype(t) != LUA_T_ARRAY)
 178     lua_error("indexed expression not a table");
 179   else {
 180     struct Stack *S = &L->stack;
 181     luaH_set(avalue(t), t+1, S->top-1);
 182     S->top -= 3;
 183   }
 184 }
 185
 186
 187 void luaV_getglobal (TaggedString *ts) {
 188   /* WARNING: caller must assure stack space */
 189   /* only userdata, tables and nil can have getglobal tag methods */
 190   static char valid_getglobals[] = {1, 0, 0, 1, 0, 0, 1, 0};  /* ORDER LUA_T */
 191   TObject *value = &ts->u.s.globalval;
 192   if (valid_getglobals[-ttype(value)]) {
 193     TObject *im = luaT_getimbyObj(value, IM_GETGLOBAL);
 194     if (ttype(im) != LUA_T_NIL) {  /* is there a tag method? */
 195       struct Stack *S = &L->stack;
 196       ttype(S->top) = LUA_T_STRING;
 197       tsvalue(S->top) = ts;
 198       S->top++;
 199       *S->top++ = *value;
 200       luaD_callTM(im, 2, 1);
 201       return;
 202     }
 203     /* else no tag method: go through to default behavior */
 204   }
 205   *L->stack.top++ = *value;  /* default behavior */
 206 }
 207
 208
 209 void luaV_setglobal (TaggedString *ts) {
 210   TObject *oldvalue = &ts->u.s.globalval;
 211   TObject *im = luaT_getimbyObj(oldvalue, IM_SETGLOBAL);
 212   if (ttype(im) == LUA_T_NIL)  /* is there a tag method? */
 213     luaS_rawsetglobal(ts, --L->stack.top);
 214   else {
 215     /* WARNING: caller must assure stack space */
 216     struct Stack *S = &L->stack;
 217     TObject newvalue;
 218     newvalue = *(S->top-1);
 219     ttype(S->top-1) = LUA_T_STRING;
 220     tsvalue(S->top-1) = ts;
 221     *S->top++ = *oldvalue;
 222     *S->top++ = newvalue;
 223     luaD_callTM(im, 3, 0);
 224   }
 225 }
 226
 227
 228 static void call_binTM (IMS event, char *msg)
 229 {
 230   TObject *im = luaT_getimbyObj(L->stack.top-2, event);/* try first operand */
 231   if (ttype(im) == LUA_T_NIL) {
 232     im = luaT_getimbyObj(L->stack.top-1, event);  /* try second operand */
 233     if (ttype(im) == LUA_T_NIL) {
 234       im = luaT_getim(0, event);  /* try a 'global' i.m. */
 235       if (ttype(im) == LUA_T_NIL)
 236         lua_error(msg);
 237     }
 238   }
 239   lua_pushstring(luaT_eventname[event]);
 240   luaD_callTM(im, 3, 1);
 241 }
 242
 243
 244 static void call_arith (IMS event)
 245 {
 246   call_binTM(event, "unexpected type in arithmetic operation");
 247 }
 248
 249
 250 static int luaV_strcomp (char *l, long ll, char *r, long lr)
 251 {
 252   for (;;) {
 253     long temp = strcoll(l, r);
 254     if (temp != 0) return temp;
 255     /* strings are equal up to a '\0' */
 256     temp = strlen(l);  /* index of first '\0' in both strings */
 257     if (temp == ll)  /* l is finished? */
 258       return (temp == lr) ? 0 : -1;  /* l is equal or smaller than r */
 259     else if (temp == lr)  /* r is finished? */
 260       return 1;  /* l is greater than r (because l is not finished) */
 261     /* both strings longer than temp; go on comparing (after the '\0') */
 262     temp++;
 263     l += temp; ll -= temp; r += temp; lr -= temp;
 264   }
 265 }
 266
 267 void luaV_comparison (lua_Type ttype_less, lua_Type ttype_equal,
 268                       lua_Type ttype_great, IMS op) {
 269   struct Stack *S = &L->stack;
 270   TObject *l = S->top-2;
 271   TObject *r = S->top-1;
 272   real result;
 273   if (ttype(l) == LUA_T_NUMBER && ttype(r) == LUA_T_NUMBER)
 274     result = nvalue(l)-nvalue(r);
 275   else if (ttype(l) == LUA_T_STRING && ttype(r) == LUA_T_STRING)
 276     result = luaV_strcomp(svalue(l), tsvalue(l)->u.s.len,
 277                           svalue(r), tsvalue(r)->u.s.len);
 278   else {
 279     call_binTM(op, "unexpected type in comparison");
 280     return;
 281   }
 282   S->top--;
 283   nvalue(S->top-1) = 1;
 284   ttype(S->top-1) = (result < 0) ? ttype_less :
 285                                 (result == 0) ? ttype_equal : ttype_great;
 286 }
 287
 288
 289 void luaV_pack (StkId firstel, int nvararg, TObject *tab) {
 290   TObject *firstelem = L->stack.stack+firstel;
 291   int i;
 292   Hash *htab;
 293   if (nvararg < 0) nvararg = 0;
 294   htab = avalue(tab) = luaH_new(nvararg+1);  /* +1 for field 'n' */
 295   ttype(tab) = LUA_T_ARRAY;
 296   for (i=0; i<nvararg; i++)
 297     luaH_setint(htab, i+1, firstelem+i);
 298   luaV_setn(htab, nvararg);  /* store counter in field "n" */
 299 }
 300
 301
 302 static void adjust_varargs (StkId first_extra_arg)
 303 {
 304   TObject arg;
 305   luaV_pack(first_extra_arg,
 306        (L->stack.top-L->stack.stack)-first_extra_arg, &arg);
 307   luaD_adjusttop(first_extra_arg);
 308   *L->stack.top++ = arg;
 309 }
 310
 311
 312
 313 /*
 314 ** Execute the given opcode, until a RET. Parameters are between
 315 ** [stack+base,top). Returns n such that the the results are between
 316 ** [stack+n,top).
 317 */
 318 StkId luaV_execute (Closure *cl, TProtoFunc *tf, StkId base) {
 319   struct Stack *S = &L->stack;  /* to optimize */
 320   register Byte *pc = tf->code;
 321   TObject *consts = tf->consts;
 322   if (L->callhook)
 323     luaD_callHook(base, tf, 0);
 324   luaD_checkstack((*pc++)+EXTRA_STACK);
 325   if (*pc < ZEROVARARG)
 326     luaD_adjusttop(base+*(pc++));
 327   else {  /* varargs */
 328     luaC_checkGC();
 329     adjust_varargs(base+(*pc++)-ZEROVARARG);
 330   }
 331   for (;;) {
 332     register int aux = 0;
 333     switchentry:
 334     switch ((OpCode)*pc++) {
 335
 336       case ENDCODE:
 337         S->top = S->stack + base;
 338         goto ret;
 339
 340       case RETCODE:
 341         base += *pc++;
 342         goto ret;
 343
 344       case CALL: aux = *pc++;
 345         luaD_calln(*pc++, aux);
 346         break;
 347
 348       case TAILCALL: aux = *pc++;
 349         luaD_calln(*pc++, MULT_RET);
 350         base += aux;
 351         goto ret;
 352
 353       case PUSHNIL: aux = *pc++;
 354         do {
 355           ttype(S->top++) = LUA_T_NIL;
 356         } while (aux--);
 357         break;
 358
 359       case POP: aux = *pc++;
 360         S->top -= aux;
 361         break;
 362
 363       case PUSHNUMBERW: aux += highbyte(*pc++);
 364       case PUSHNUMBER:  aux += *pc++;
 365         ttype(S->top) = LUA_T_NUMBER;
 366         nvalue(S->top) = aux;
 367         S->top++;
 368         break;
 369
 370       case PUSHNUMBERNEGW: aux += highbyte(*pc++);
 371       case PUSHNUMBERNEG:  aux += *pc++;
 372         ttype(S->top) = LUA_T_NUMBER;
 373         nvalue(S->top) = -aux;
 374         S->top++;
 375         break;
 376
 377       case PUSHCONSTANTW: aux += highbyte(*pc++);
 378       case PUSHCONSTANT:  aux += *pc++;
 379         *S->top++ = consts[aux];
 380         break;
 381
 382       case PUSHUPVALUE: aux = *pc++;
 383         *S->top++ = cl->consts[aux+1];
 384         break;
 385
 386       case PUSHLOCAL: aux = *pc++;
 387         *S->top++ = *((S->stack+base) + aux);
 388         break;
 389
 390       case GETGLOBALW: aux += highbyte(*pc++);
 391       case GETGLOBAL:  aux += *pc++;
 392         luaV_getglobal(tsvalue(&consts[aux]));
 393         break;
 394
 395       case GETTABLE:
 396         luaV_gettable();
 397         break;
 398
 399       case GETDOTTEDW: aux += highbyte(*pc++);
 400       case GETDOTTED:  aux += *pc++;
 401         *S->top++ = consts[aux];
 402         luaV_gettable();
 403         break;
 404
 405       case PUSHSELFW: aux += highbyte(*pc++);
 406       case PUSHSELF:  aux += *pc++; {
 407         TObject receiver;
 408         receiver = *(S->top-1);
 409         *S->top++ = consts[aux];
 410         luaV_gettable();
 411         *S->top++ = receiver;
 412         break;
 413       }
 414
 415       case CREATEARRAYW: aux += highbyte(*pc++);
 416       case CREATEARRAY:  aux += *pc++;
 417         luaC_checkGC();
 418         avalue(S->top) = luaH_new(aux);
 419         ttype(S->top) = LUA_T_ARRAY;
 420         S->top++;
 421         break;
 422
 423       case SETLOCAL: aux = *pc++;
 424         *((S->stack+base) + aux) = *(--S->top);
 425         break;
 426
 427       case SETGLOBALW: aux += highbyte(*pc++);
 428       case SETGLOBAL:  aux += *pc++;
 429         luaV_setglobal(tsvalue(&consts[aux]));
 430         break;
 431
 432       case SETTABLEPOP:
 433         luaV_settable(S->top-3);
 434         S->top -= 2;  /* pop table and index */
 435         break;
 436
 437       case SETTABLE:
 438         luaV_settable(S->top-3-(*pc++));
 439         break;
 440
 441       case SETLISTW: aux += highbyte(*pc++);
 442       case SETLIST:  aux += *pc++; {
 443         int n = *(pc++);
 444         Hash *arr = avalue(S->top-n-1);
 445         aux *= LFIELDS_PER_FLUSH;
 446         for (; n; n--)
 447           luaH_setint(arr, n+aux, --S->top);
 448         break;
 449       }
 450
 451       case SETMAP:  aux = *pc++; {
 452         Hash *arr = avalue(S->top-(2*aux)-3);
 453         do {
 454           luaH_set(arr, S->top-2, S->top-1);
 455           S->top-=2;
 456         } while (aux--);
 457         break;
 458       }
 459
 460       case NEQOP: aux = 1;
 461       case EQOP: {
 462         int res = luaO_equalObj(S->top-2, S->top-1);
 463         if (aux) res = !res;
 464         S->top--;
 465         ttype(S->top-1) = res ? LUA_T_NUMBER : LUA_T_NIL;
 466         nvalue(S->top-1) = 1;
 467         break;
 468       }
 469
 470        case LTOP:
 471          luaV_comparison(LUA_T_NUMBER, LUA_T_NIL, LUA_T_NIL, IM_LT);
 472          break;
 473
 474       case LEOP:
 475         luaV_comparison(LUA_T_NUMBER, LUA_T_NUMBER, LUA_T_NIL, IM_LE);
 476         break;
 477
 478       case GTOP:
 479         luaV_comparison(LUA_T_NIL, LUA_T_NIL, LUA_T_NUMBER, IM_GT);
 480         break;
 481
 482       case GEOP:
 483         luaV_comparison(LUA_T_NIL, LUA_T_NUMBER, LUA_T_NUMBER, IM_GE);
 484         break;
 485
 486       case ADDOP: {
 487         TObject *l = S->top-2;
 488         TObject *r = S->top-1;
 489         if (tonumber(r) || tonumber(l))
 490           call_arith(IM_ADD);
 491         else {
 492           nvalue(l) += nvalue(r);
 493           --S->top;
 494         }
 495         break;
 496       }
 497
 498       case SUBOP: {
 499         TObject *l = S->top-2;
 500         TObject *r = S->top-1;
 501         if (tonumber(r) || tonumber(l))
 502           call_arith(IM_SUB);
 503         else {
 504           nvalue(l) -= nvalue(r);
 505           --S->top;
 506         }
 507         break;
 508       }
 509
 510       case MULTOP: {
 511         TObject *l = S->top-2;
 512         TObject *r = S->top-1;
 513         if (tonumber(r) || tonumber(l))
 514           call_arith(IM_MUL);
 515         else {
 516           nvalue(l) *= nvalue(r);
 517           --S->top;
 518         }
 519         break;
 520       }
 521
 522       case DIVOP: {
 523         TObject *l = S->top-2;
 524         TObject *r = S->top-1;
 525         if (tonumber(r) || tonumber(l))
 526           call_arith(IM_DIV);
 527         else {
 528           nvalue(l) /= nvalue(r);
 529           --S->top;
 530         }
 531         break;
 532       }
 533
 534       case POWOP:
 535         call_binTM(IM_POW, "undefined operation");
 536         break;
 537
 538       case CONCOP: {
 539         TObject *l = S->top-2;
 540         TObject *r = S->top-1;
 541         if (tostring(l) || tostring(r))
 542           call_binTM(IM_CONCAT, "unexpected type for concatenation");
 543         else {
 544           tsvalue(l) = strconc(tsvalue(l), tsvalue(r));
 545           --S->top;
 546         }
 547         luaC_checkGC();
 548         break;
 549       }
 550
 551       case MINUSOP:
 552         if (tonumber(S->top-1)) {
 553           ttype(S->top) = LUA_T_NIL;
 554           S->top++;
 555           call_arith(IM_UNM);
 556         }
 557         else
 558           nvalue(S->top-1) = - nvalue(S->top-1);
 559         break;
 560
 561       case NOTOP:
 562         ttype(S->top-1) =
 563            (ttype(S->top-1) == LUA_T_NIL) ? LUA_T_NUMBER : LUA_T_NIL;
 564         nvalue(S->top-1) = 1;
 565         break;
 566
 567       case ONTJMPW: aux += highbyte(*pc++);
 568       case ONTJMP:  aux += *pc++;
 569         if (ttype(S->top-1) != LUA_T_NIL) pc += aux;
 570         else S->top--;
 571         break;
 572
 573       case ONFJMPW: aux += highbyte(*pc++);
 574       case ONFJMP:  aux += *pc++;
 575         if (ttype(S->top-1) == LUA_T_NIL) pc += aux;
 576         else S->top--;
 577         break;
 578
 579       case JMPW: aux += highbyte(*pc++);
 580       case JMP:  aux += *pc++;
 581         pc += aux;
 582         break;
 583
 584       case IFFJMPW: aux += highbyte(*pc++);
 585       case IFFJMP:  aux += *pc++;
 586         if (ttype(--S->top) == LUA_T_NIL) pc += aux;
 587         break;
 588
 589       case IFTUPJMPW: aux += highbyte(*pc++);
 590       case IFTUPJMP:  aux += *pc++;
 591         if (ttype(--S->top) != LUA_T_NIL) pc -= aux;
 592         break;
 593
 594       case IFFUPJMPW: aux += highbyte(*pc++);
 595       case IFFUPJMP:  aux += *pc++;
 596         if (ttype(--S->top) == LUA_T_NIL) pc -= aux;
 597         break;
 598
 599       case CLOSUREW: aux += highbyte(*pc++);
 600       case CLOSURE:  aux += *pc++;
 601         *S->top++ = consts[aux];
 602         luaV_closure(*pc++);
 603         luaC_checkGC();
 604         break;
 605
 606       case SETLINEW: aux += highbyte(*pc++);
 607       case SETLINE:  aux += *pc++;
 608         if ((S->stack+base-1)->ttype != LUA_T_LINE) {
 609           /* open space for LINE value */
 610           luaD_openstack((S->top-S->stack)-base);
 611           base++;
 612           (S->stack+base-1)->ttype = LUA_T_LINE;
 613         }
 614         (S->stack+base-1)->value.i = aux;
 615         if (L->linehook)
 616           luaD_lineHook(aux);
 617         break;
 618
 619       case LONGARGW: aux += highbyte(*pc++);
 620       case LONGARG:  aux += *pc++;
 621         aux = highbyte(highbyte(aux));
 622         goto switchentry;  /* do not reset "aux" */
 623
 624       case CHECKSTACK: aux = *pc++;
 625         LUA_ASSERT((S->top-S->stack)-base == aux && S->last >= S->top,
 626                    "wrong stack size");
 627         break;
 628
 629     }
 630   } ret:
 631   if (L->callhook)
 632     luaD_callHook(0, NULL, 1);
 633   return base;
 634 }
 635