src/opcode.c

   1 /*
   2 ** opcode.c
   3 ** TecCGraf - PUC-Rio
   4 */
   5
   6 char *rcs_opcode="$Id: opcode.c,v 4.15 1997/06/26 21:40:57 roberto Exp $";
   7
   8 #include <setjmp.h>
   9 #include <stdio.h>
  10 #include <string.h>
  11 #include <stdlib.h>
  12
  13 #include "luadebug.h"
  14 #include "luamem.h"
  15 #include "opcode.h"
  16 #include "hash.h"
  17 #include "inout.h"
  18 #include "table.h"
  19 #include "lua.h"
  20 #include "fallback.h"
  21 #include "auxlib.h"
  22 #include "lex.h"
  23
  24 #define tonumber(o) ((ttype(o) != LUA_T_NUMBER) && (lua_tonumber(o) != 0))
  25 #define tostring(o) ((ttype(o) != LUA_T_STRING) && (lua_tostring(o) != 0))
  26
  27
  28 #define STACK_SIZE      128
  29
  30 #ifndef STACK_LIMIT
  31 #define STACK_LIMIT     6000
  32 #endif
  33
  34 typedef int StkId;  /* index to stack elements */
  35
  36 static TObject initial_stack;
  37
  38 static TObject *stackLimit = &initial_stack+1;
  39 static TObject *stack = &initial_stack;
  40 static TObject *top = &initial_stack;
  41
  42
  43 /* macros to convert from lua_Object to (TObject *) and back */
  44
  45 #define Address(lo)     ((lo)+stack-1)
  46 #define Ref(st)         ((st)-stack+1)
  47
  48
  49 /* macro to increment stack top. There must be always an empty slot in
  50 *  the stack
  51 */
  52 #define incr_top        if (++top >= stackLimit) growstack()
  53
  54 struct C_Lua_Stack {
  55   StkId base;  /* when Lua calls C or C calls Lua, points to */
  56                /* the first slot after the last parameter. */
  57   StkId lua2C; /* points to first element of "array" lua2C */
  58   int num;     /* size of "array" lua2C */
  59 };
  60
  61 static struct C_Lua_Stack CLS_current = {0, 0, 0};
  62
  63 static  jmp_buf *errorJmp = NULL; /* current error recover point */
  64
  65
  66 /* Hooks */
  67 lua_LHFunction lua_linehook = NULL;
  68 lua_CHFunction lua_callhook = NULL;
  69
  70
  71 static StkId lua_execute (Byte *pc, StkId base);
  72 static void do_call (StkId base, int nResults);
  73
  74
  75
  76 TObject *luaI_Address (lua_Object o)
  77 {
  78   return Address(o);
  79 }
  80
  81
  82 /*
  83 ** Init stack
  84 */
  85 static void lua_initstack (void)
  86 {
  87  Long maxstack = STACK_SIZE;
  88  stack = newvector(maxstack, TObject);
  89  stackLimit = stack+maxstack;
  90  top = stack;
  91  *(top++) = initial_stack;
  92 }
  93
  94
  95 /*
  96 ** Check stack overflow and, if necessary, realloc vector
  97 */
  98 #define lua_checkstack(nt)  if ((nt) >= stackLimit) growstack()
  99
 100 static void growstack (void)
 101 {
 102  if (stack == &initial_stack)
 103    lua_initstack();
 104  else
 105  {
 106   static int limit = STACK_LIMIT;
 107   StkId t = top-stack;
 108   Long stacksize = stackLimit - stack;
 109   stacksize = growvector(&stack, stacksize, TObject, stackEM, limit+100);
 110   stackLimit = stack+stacksize;
 111   top = stack + t;
 112   if (stacksize >= limit)
 113   {
 114     limit = stacksize;
 115     lua_error(stackEM);
 116   }
 117  }
 118 }
 119
 120
 121 /*
 122 ** Concatenate two given strings. Return the new string pointer.
 123 */
 124 static char *lua_strconc (char *l, char *r)
 125 {
 126   size_t nl = strlen(l);
 127   char *buffer = luaI_buffer(nl+strlen(r)+1);
 128   strcpy(buffer, l);
 129   strcpy(buffer+nl, r);
 130   return buffer;
 131 }
 132
 133
 134 /*
 135 ** Convert, if possible, to a number object.
 136 ** Return 0 if success, not 0 if error.
 137 */
 138 static int lua_tonumber (TObject *obj)
 139 {
 140  float t;
 141  char c;
 142  if (ttype(obj) != LUA_T_STRING)
 143    return 1;
 144  else if (sscanf(svalue(obj), "%f %c",&t, &c) == 1)
 145  {
 146    nvalue(obj) = t;
 147    ttype(obj) = LUA_T_NUMBER;
 148    return 0;
 149  }
 150  else
 151    return 2;
 152 }
 153
 154
 155 /*
 156 ** Convert, if possible, to a string ttype
 157 ** Return 0 in success or not 0 on error.
 158 */
 159 static int lua_tostring (TObject *obj)
 160 {
 161   if (ttype(obj) != LUA_T_NUMBER)
 162     return 1;
 163   else {
 164     char s[60];
 165     real f = nvalue(obj);
 166     int i;
 167     if ((real)(-MAX_INT) <= f && f <= (real)MAX_INT && (real)(i=(int)f) == f)
 168       sprintf (s, "%d", i);
 169     else
 170       sprintf (s, "%g", nvalue(obj));
 171     tsvalue(obj) = lua_createstring(s);
 172     ttype(obj) = LUA_T_STRING;
 173     return 0;
 174   }
 175 }
 176
 177
 178 /*
 179 ** Adjust stack. Set top to the given value, pushing NILs if needed.
 180 */
 181 static void adjust_top_aux (StkId newtop)
 182 {
 183   TObject *nt;
 184   lua_checkstack(stack+newtop);
 185   nt = stack+newtop;  /* warning: previous call may change stack */
 186   while (top < nt) ttype(top++) = LUA_T_NIL;
 187 }
 188
 189
 190 #define adjust_top(newtop)  { if (newtop <= top-stack) \
 191                                  top = stack+newtop; \
 192                               else adjust_top_aux(newtop); }
 193
 194 #define adjustC(nParams)        adjust_top(CLS_current.base+nParams)
 195
 196
 197 static void checkCparams (int nParams)
 198 {
 199   if (top-stack < CLS_current.base+nParams)
 200     lua_error("API error - wrong number of arguments in C2lua stack");
 201 }
 202
 203
 204 /*
 205 ** Open a hole below "nelems" from the top.
 206 */
 207 static void open_stack (int nelems)
 208 {
 209   int i;
 210   for (i=0; i<nelems; i++)
 211     *(top-i) = *(top-i-1);
 212   incr_top;
 213 }
 214
 215
 216 static lua_Object put_luaObject (TObject *o)
 217 {
 218   open_stack((top-stack)-CLS_current.base);
 219   stack[CLS_current.base++] = *o;
 220   return CLS_current.base;  /* this is +1 real position (see Ref) */
 221 }
 222
 223
 224 static lua_Object put_luaObjectonTop (void)
 225 {
 226   open_stack((top-stack)-CLS_current.base);
 227   stack[CLS_current.base++] = *(--top);
 228   return CLS_current.base;  /* this is +1 real position (see Ref) */
 229 }
 230
 231
 232 lua_Object lua_pop (void)
 233 {
 234   checkCparams(1);
 235   return put_luaObjectonTop();
 236 }
 237
 238
 239
 240 /*
 241 ** call Line hook
 242 */
 243 static void lineHook (int line)
 244 {
 245   struct C_Lua_Stack oldCLS = CLS_current;
 246   StkId old_top = CLS_current.lua2C = CLS_current.base = top-stack;
 247   CLS_current.num = 0;
 248   (*lua_linehook)(line);
 249   top = stack+old_top;
 250   CLS_current = oldCLS;
 251 }
 252
 253
 254 /*
 255 ** Call hook
 256 ** The function being called is in [stack+base-1]
 257 */
 258 static void callHook (StkId base, lua_Type type, int isreturn)
 259 {
 260   struct C_Lua_Stack oldCLS = CLS_current;
 261   StkId old_top = CLS_current.lua2C = CLS_current.base = top-stack;
 262   CLS_current.num = 0;
 263   if (isreturn)
 264     (*lua_callhook)(LUA_NOOBJECT, "(return)", 0);
 265   else
 266   {
 267     TObject *f = stack+base-1;
 268     if (type == LUA_T_MARK)
 269       (*lua_callhook)(Ref(f), f->value.tf->fileName, f->value.tf->lineDefined);
 270     else
 271       (*lua_callhook)(Ref(f), "(C)", -1);
 272   }
 273   top = stack+old_top;
 274   CLS_current = oldCLS;
 275 }
 276
 277
 278 /*
 279 ** Call a C function. CLS_current.base will point to the top of the stack,
 280 ** and CLS_current.num is the number of parameters. Returns an index
 281 ** to the first result from C.
 282 */
 283 static StkId callC (lua_CFunction func, StkId base)
 284 {
 285   struct C_Lua_Stack oldCLS = CLS_current;
 286   StkId firstResult;
 287   CLS_current.num = (top-stack) - base;
 288   /* incorporate parameters on the stack */
 289   CLS_current.lua2C = base;
 290   CLS_current.base = base+CLS_current.num;  /* == top-stack */
 291   if (lua_callhook)
 292     callHook(base, LUA_T_CMARK, 0);
 293   (*func)();
 294   if (lua_callhook)  /* func may have changed lua_callhook */
 295     callHook(base, LUA_T_CMARK, 1);
 296   firstResult = CLS_current.base;
 297   CLS_current = oldCLS;
 298   return firstResult;
 299 }
 300
 301 static void callIM (TObject *f, int nParams, int nResults)
 302 {
 303   open_stack(nParams);
 304   *(top-nParams-1) = *f;
 305   do_call((top-stack)-nParams, nResults);
 306 }
 307
 308
 309 /*
 310 ** Call a function (C or Lua). The parameters must be on the stack,
 311 ** between [stack+base,top). The function to be called is at stack+base-1.
 312 ** When returns, the results are on the stack, between [stack+base-1,top).
 313 ** The number of results is nResults, unless nResults=MULT_RET.
 314 */
 315 static void do_call (StkId base, int nResults)
 316 {
 317   StkId firstResult;
 318   TObject *func = stack+base-1;
 319   int i;
 320   if (ttype(func) == LUA_T_CFUNCTION) {
 321     ttype(func) = LUA_T_CMARK;
 322     firstResult = callC(fvalue(func), base);
 323   }
 324   else if (ttype(func) == LUA_T_FUNCTION) {
 325     ttype(func) = LUA_T_MARK;
 326     firstResult = lua_execute(func->value.tf->code, base);
 327   }
 328   else { /* func is not a function */
 329     /* Check the tag method for invalid functions */
 330     TObject *im = luaI_getimbyObj(func, IM_FUNCTION);
 331     if (ttype(im) == LUA_T_NIL)
 332       lua_error("call expression not a function");
 333     open_stack((top-stack)-(base-1));
 334     stack[base-1] = *im;
 335     do_call(base, nResults);
 336     return;
 337   }
 338   /* adjust the number of results */
 339   if (nResults != MULT_RET)
 340     adjust_top(firstResult+nResults);
 341   /* move results to base-1 (to erase parameters and function) */
 342   base--;
 343   nResults = top - (stack+firstResult);  /* actual number of results */
 344   for (i=0; i<nResults; i++)
 345     *(stack+base+i) = *(stack+firstResult+i);
 346   top -= firstResult-base;
 347 }
 348
 349
 350 /*
 351 ** Function to index a table. Receives the table at top-2 and the index
 352 ** at top-1.
 353 */
 354 static void pushsubscript (void)
 355 {
 356   TObject *im;
 357   if (ttype(top-2) != LUA_T_ARRAY)  /* not a table, get "gettable" method */
 358     im = luaI_getimbyObj(top-2, IM_GETTABLE);
 359   else {  /* object is a table... */
 360     int tg = (top-2)->value.a->htag;
 361     im = luaI_getim(tg, IM_GETTABLE);
 362     if (ttype(im) == LUA_T_NIL) {  /* and does not have a "gettable" method */
 363       TObject *h = lua_hashget(avalue(top-2), top-1);
 364       if (h != NULL && ttype(h) != LUA_T_NIL) {
 365         --top;
 366         *(top-1) = *h;
 367       }
 368       else if (ttype(im=luaI_getim(tg, IM_INDEX)) != LUA_T_NIL)
 369         callIM(im, 2, 1);
 370       else {
 371         --top;
 372         ttype(top-1) = LUA_T_NIL;
 373       }
 374       return;
 375     }
 376     /* else it has a "gettable" method, go through to next command */
 377   }
 378   /* object is not a table, or it has a "gettable" method */
 379   if (ttype(im) != LUA_T_NIL)
 380     callIM(im, 2, 1);
 381   else
 382     lua_error("indexed expression not a table");
 383 }
 384
 385
 386 lua_Object lua_rawgettable (void)
 387 {
 388   checkCparams(2);
 389   if (ttype(top-2) != LUA_T_ARRAY)
 390     lua_error("indexed expression not a table in raw gettable");
 391   else {
 392     TObject *h = lua_hashget(avalue(top-2), top-1);
 393     --top;
 394     if (h != NULL)
 395       *(top-1) = *h;
 396     else
 397       ttype(top-1) = LUA_T_NIL;
 398   }
 399   return put_luaObjectonTop();
 400 }
 401
 402
 403 /*
 404 ** Function to store indexed based on values at the top
 405 ** mode = 0: raw store (without internal methods)
 406 ** mode = 1: normal store (with internal methods)
 407 ** mode = 2: "deep stack" store (with internal methods)
 408 */
 409 static void storesubscript (TObject *t, int mode)
 410 {
 411   TObject *im = (mode == 0) ? NULL : luaI_getimbyObj(t, IM_SETTABLE);
 412   if (ttype(t) == LUA_T_ARRAY && (im == NULL || ttype(im) == LUA_T_NIL)) {
 413     TObject *h = lua_hashdefine(avalue(t), t+1);
 414     *h = *(top-1);
 415     top -= (mode == 2) ? 1 : 3;
 416   }
 417   else {  /* object is not a table, and/or has a specific "settable" method */
 418     if (im && ttype(im) != LUA_T_NIL) {
 419       if (mode == 2) {
 420         lua_checkstack(top+2);
 421         *(top+1) = *(top-1);
 422         *(top) = *(t+1);
 423         *(top-1) = *t;
 424         top += 2;
 425       }
 426       callIM(im, 3, 0);
 427     }
 428     else
 429       lua_error("indexed expression not a table");
 430   }
 431 }
 432
 433
 434 static void getglobal (Word n)
 435 {
 436   TObject *value = &lua_table[n].object;
 437   TObject *im = luaI_getimbyObj(value, IM_GETGLOBAL);
 438   if (ttype(im) == LUA_T_NIL) {  /* default behavior */
 439     *top = *value;
 440     incr_top;
 441   }
 442   else {
 443     ttype(top) = LUA_T_STRING;
 444     tsvalue(top) = lua_table[n].varname;
 445     incr_top;
 446     *top = *value;
 447     incr_top;
 448     callIM(im, 2, 1);
 449     }
 450 }
 451
 452 /*
 453 ** Traverse all objects on stack
 454 */
 455 void lua_travstack (int (*fn)(TObject *))
 456 {
 457   StkId i;
 458   for (i = (top-1)-stack; i>=0; i--)
 459     fn (stack+i);
 460 }
 461
 462
 463 /*
 464 ** Error messages and debug functions
 465 */
 466
 467 static void lua_message (char *s)
 468 {
 469   TObject *im = luaI_geterrorim();
 470   if (ttype(im) != LUA_T_NIL) {
 471     lua_pushstring(s);
 472     callIM(im, 1, 0);
 473   }
 474 }
 475
 476 /*
 477 ** Reports an error, and jumps up to the available recover label
 478 */
 479 void lua_error (char *s)
 480 {
 481   if (s) lua_message(s);
 482   if (errorJmp)
 483     longjmp(*errorJmp, 1);
 484   else
 485   {
 486     fprintf (stderr, "lua: exit(1). Unable to recover\n");
 487     exit(1);
 488   }
 489 }
 490
 491
 492 lua_Function lua_stackedfunction (int level)
 493 {
 494   StkId i;
 495   for (i = (top-1)-stack; i>=0; i--)
 496     if (stack[i].ttype == LUA_T_MARK || stack[i].ttype == LUA_T_CMARK)
 497       if (level-- == 0)
 498         return Ref(stack+i);
 499   return LUA_NOOBJECT;
 500 }
 501
 502
 503 int lua_currentline (lua_Function func)
 504 {
 505   TObject *f = Address(func);
 506   return (f+1 < top && (f+1)->ttype == LUA_T_LINE) ? (f+1)->value.i : -1;
 507 }
 508
 509
 510 lua_Object lua_getlocal (lua_Function func, int local_number, char **name)
 511 {
 512   TObject *f = luaI_Address(func);
 513   *name = luaI_getlocalname(f->value.tf, local_number, lua_currentline(func));
 514   if (*name)
 515   {
 516     /* if "*name", there must be a LUA_T_LINE */
 517     /* therefore, f+2 points to function base */
 518     return Ref((f+2)+(local_number-1));
 519   }
 520   else
 521     return LUA_NOOBJECT;
 522 }
 523
 524 int lua_setlocal (lua_Function func, int local_number)
 525 {
 526   TObject *f = Address(func);
 527   char *name = luaI_getlocalname(f->value.tf, local_number, lua_currentline(func));
 528   checkCparams(1);
 529   --top;
 530   if (name)
 531   {
 532     /* if "name", there must be a LUA_T_LINE */
 533     /* therefore, f+2 points to function base */
 534     *((f+2)+(local_number-1)) = *top;
 535     return 1;
 536   }
 537   else
 538     return 0;
 539 }
 540
 541 /*
 542 ** Call the function at CLS_current.base, and incorporate results on
 543 ** the Lua2C structure.
 544 */
 545 static void do_callinc (int nResults)
 546 {
 547   StkId base = CLS_current.base;
 548   do_call(base+1, nResults);
 549   CLS_current.lua2C = base;  /* position of the new results */
 550   CLS_current.num = (top-stack) - base;  /* number of results */
 551   CLS_current.base = base + CLS_current.num;  /* incorporate results on stack */
 552 }
 553
 554
 555 static void do_unprotectedrun (lua_CFunction f, int nParams, int nResults)
 556 {
 557   StkId base = (top-stack)-nParams;
 558   open_stack(nParams);
 559   stack[base].ttype = LUA_T_CFUNCTION;
 560   stack[base].value.f = f;
 561   do_call(base+1, nResults);
 562 }
 563
 564
 565 /*
 566 ** Execute a protected call. Assumes that function is at CLS_current.base and
 567 ** parameters are on top of it. Leave nResults on the stack.
 568 */
 569 static int do_protectedrun (int nResults)
 570 {
 571   jmp_buf myErrorJmp;
 572   int status;
 573   struct C_Lua_Stack oldCLS = CLS_current;
 574   jmp_buf *oldErr = errorJmp;
 575   errorJmp = &myErrorJmp;
 576   if (setjmp(myErrorJmp) == 0) {
 577     do_callinc(nResults);
 578     status = 0;
 579   }
 580   else { /* an error occurred: restore CLS_current and top */
 581     CLS_current = oldCLS;
 582     top = stack+CLS_current.base;
 583     status = 1;
 584   }
 585   errorJmp = oldErr;
 586   return status;
 587 }
 588
 589 int luaI_dorun (TFunc *tf)
 590 {
 591   int status;
 592   adjustC(1);  /* one slot for the pseudo-function */
 593   stack[CLS_current.base].ttype = LUA_T_FUNCTION;
 594   stack[CLS_current.base].value.tf = tf;
 595   status = do_protectedrun(MULT_RET);
 596   return status;
 597 }
 598
 599
 600 int lua_domain (void)
 601 {
 602   TFunc tf;
 603   int status;
 604   jmp_buf myErrorJmp;
 605   jmp_buf *oldErr = errorJmp;
 606   errorJmp = &myErrorJmp;
 607   luaI_initTFunc(&tf);
 608   if (setjmp(myErrorJmp) == 0) {
 609     lua_parse(&tf);
 610     status = 0;
 611   }
 612   else {
 613     adjustC(0);  /* erase extra slot */
 614     status = 1;
 615   }
 616   if (status == 0)
 617     status = luaI_dorun(&tf);
 618   errorJmp = oldErr;
 619   luaI_free(tf.code);
 620   return status;
 621 }
 622
 623 /*
 624 ** Execute the given lua function. Return 0 on success or 1 on error.
 625 */
 626 int lua_callfunction (lua_Object function)
 627 {
 628   if (function == LUA_NOOBJECT)
 629     return 1;
 630   else
 631   {
 632     open_stack((top-stack)-CLS_current.base);
 633     stack[CLS_current.base] = *Address(function);
 634     return do_protectedrun (MULT_RET);
 635   }
 636 }
 637
 638
 639 lua_Object lua_gettagmethod (int tag, char *event)
 640 {
 641   lua_pushnumber(tag);
 642   lua_pushstring(event);
 643   do_unprotectedrun(luaI_gettagmethod, 2, 1);
 644   return put_luaObjectonTop();
 645 }
 646
 647 lua_Object lua_settagmethod (int tag, char *event)
 648 {
 649   TObject newmethod;
 650   checkCparams(1);
 651   newmethod = *(--top);
 652   lua_pushnumber(tag);
 653   lua_pushstring(event);
 654   *top = newmethod;  incr_top;
 655   do_unprotectedrun(luaI_settagmethod, 3, 1);
 656   return put_luaObjectonTop();
 657 }
 658
 659 lua_Object lua_seterrormethod (void)
 660 {
 661   checkCparams(1);
 662   do_unprotectedrun(luaI_seterrormethod, 1, 1);
 663   return put_luaObjectonTop();
 664 }
 665
 666
 667 /*
 668 ** API: receives on the stack the table and the index.
 669 ** returns the value.
 670 */
 671 lua_Object lua_gettable (void)
 672 {
 673   checkCparams(2);
 674   pushsubscript();
 675   return put_luaObjectonTop();
 676 }
 677
 678
 679 #define MAX_C_BLOCKS 10
 680
 681 static int numCblocks = 0;
 682 static struct C_Lua_Stack Cblocks[MAX_C_BLOCKS];
 683
 684 /*
 685 ** API: starts a new block
 686 */
 687 void lua_beginblock (void)
 688 {
 689   if (numCblocks >= MAX_C_BLOCKS)
 690     lua_error("`lua_beginblock': too many nested blocks");
 691   Cblocks[numCblocks] = CLS_current;
 692   numCblocks++;
 693 }
 694
 695 /*
 696 ** API: ends a block
 697 */
 698 void lua_endblock (void)
 699 {
 700   --numCblocks;
 701   CLS_current = Cblocks[numCblocks];
 702   adjustC(0);
 703 }
 704
 705 void lua_settag (int tag)
 706 {
 707   checkCparams(1);
 708   luaI_settag(tag, --top);
 709 }
 710
 711 /*
 712 ** API: receives on the stack the table, the index, and the new value.
 713 */
 714 void lua_settable (void)
 715 {
 716   checkCparams(3);
 717   storesubscript(top-3, 1);
 718 }
 719
 720 void lua_rawsettable (void)
 721 {
 722   checkCparams(3);
 723   storesubscript(top-3, 0);
 724 }
 725
 726 /*
 727 ** API: creates a new table
 728 */
 729 lua_Object lua_createtable (void)
 730 {
 731   TObject o;
 732   avalue(&o) = lua_createarray(0);
 733   ttype(&o) = LUA_T_ARRAY;
 734   return put_luaObject(&o);
 735 }
 736
 737 /*
 738 ** Get a parameter, returning the object handle or LUA_NOOBJECT on error.
 739 ** 'number' must be 1 to get the first parameter.
 740 */
 741 lua_Object lua_lua2C (int number)
 742 {
 743   if (number <= 0 || number > CLS_current.num) return LUA_NOOBJECT;
 744   /* Ref(stack+(CLS_current.lua2C+number-1)) ==
 745      stack+(CLS_current.lua2C+number-1)-stack+1 == */
 746   return CLS_current.lua2C+number;
 747 }
 748
 749 int lua_isnil (lua_Object o)
 750 {
 751   return (o!= LUA_NOOBJECT) && (ttype(Address(o)) == LUA_T_NIL);
 752 }
 753
 754 int lua_istable (lua_Object o)
 755 {
 756   return (o!= LUA_NOOBJECT) && (ttype(Address(o)) == LUA_T_ARRAY);
 757 }
 758
 759 int lua_isuserdata (lua_Object o)
 760 {
 761   return (o!= LUA_NOOBJECT) && (ttype(Address(o)) == LUA_T_USERDATA);
 762 }
 763
 764 int lua_iscfunction (lua_Object o)
 765 {
 766   int t = lua_tag(o);
 767   return (t == LUA_T_CMARK) || (t == LUA_T_CFUNCTION);
 768 }
 769
 770 int lua_isnumber (lua_Object o)
 771 {
 772   return (o!= LUA_NOOBJECT) && (tonumber(Address(o)) == 0);
 773 }
 774
 775 int lua_isstring (lua_Object o)
 776 {
 777   int t = lua_tag(o);
 778   return (t == LUA_T_STRING) || (t == LUA_T_NUMBER);
 779 }
 780
 781 int lua_isfunction (lua_Object o)
 782 {
 783   int t = lua_tag(o);
 784   return (t == LUA_T_FUNCTION) || (t == LUA_T_CFUNCTION) ||
 785          (t == LUA_T_MARK) || (t == LUA_T_CMARK);
 786 }
 787
 788 /*
 789 ** Given an object handle, return its number value. On error, return 0.0.
 790 */
 791 real lua_getnumber (lua_Object object)
 792 {
 793  if (object == LUA_NOOBJECT) return 0.0;
 794  if (tonumber (Address(object))) return 0.0;
 795  else return (nvalue(Address(object)));
 796 }
 797
 798 /*
 799 ** Given an object handle, return its string pointer. On error, return NULL.
 800 */
 801 char *lua_getstring (lua_Object object)
 802 {
 803   if (object == LUA_NOOBJECT || tostring (Address(object)))
 804     return NULL;
 805   else return (svalue(Address(object)));
 806 }
 807
 808
 809 void *lua_getuserdata (lua_Object object)
 810 {
 811   if (object == LUA_NOOBJECT || ttype(Address(object)) != LUA_T_USERDATA)
 812     return NULL;
 813   else return tsvalue(Address(object))->u.v;
 814 }
 815
 816
 817 /*
 818 ** Given an object handle, return its cfuntion pointer. On error, return NULL.
 819 */
 820 lua_CFunction lua_getcfunction (lua_Object object)
 821 {
 822  if (object == LUA_NOOBJECT || ((ttype(Address(object)) != LUA_T_CFUNCTION) &&
 823                                 (ttype(Address(object)) != LUA_T_CMARK)))
 824    return NULL;
 825  else return (fvalue(Address(object)));
 826 }
 827
 828
 829 lua_Object lua_getref (int ref)
 830 {
 831   TObject *o = luaI_getref(ref);
 832   if (o == NULL)
 833     return LUA_NOOBJECT;
 834   return put_luaObject(o);
 835 }
 836
 837
 838 int lua_ref (int lock)
 839 {
 840   checkCparams(1);
 841   return luaI_ref(--top, lock);
 842 }
 843
 844
 845
 846 /*
 847 ** Get a global object.
 848 */
 849 lua_Object lua_getglobal (char *name)
 850 {
 851   getglobal(luaI_findsymbolbyname(name));
 852   return put_luaObjectonTop();
 853 }
 854
 855
 856 lua_Object lua_rawgetglobal (char *name)
 857 {
 858   return put_luaObject(&lua_table[luaI_findsymbolbyname(name)].object);
 859 }
 860
 861
 862 /*
 863 ** Store top of the stack at a global variable array field.
 864 */
 865 static void setglobal (Word n)
 866 {
 867   TObject *oldvalue = &lua_table[n].object;
 868   TObject *im = luaI_getimbyObj(oldvalue, IM_SETGLOBAL);
 869   if (ttype(im) == LUA_T_NIL)  /* default behavior */
 870     s_object(n) = *(--top);
 871   else {
 872     TObject newvalue = *(top-1);
 873     ttype(top-1) = LUA_T_STRING;
 874     tsvalue(top-1) = lua_table[n].varname;
 875     *top = *oldvalue;
 876     incr_top;
 877     *top = newvalue;
 878     incr_top;
 879     callIM(im, 3, 0);
 880   }
 881 }
 882
 883
 884 void lua_setglobal (char *name)
 885 {
 886   checkCparams(1);
 887   setglobal(luaI_findsymbolbyname(name));
 888 }
 889
 890 void lua_rawsetglobal (char *name)
 891 {
 892   Word n = luaI_findsymbolbyname(name);
 893   checkCparams(1);
 894   s_object(n) = *(--top);
 895 }
 896
 897 /*
 898 ** Push a nil object
 899 */
 900 void lua_pushnil (void)
 901 {
 902   ttype(top) = LUA_T_NIL;
 903   incr_top;
 904 }
 905
 906 /*
 907 ** Push an object (ttype=number) to stack.
 908 */
 909 void lua_pushnumber (real n)
 910 {
 911  ttype(top) = LUA_T_NUMBER; nvalue(top) = n;
 912  incr_top;
 913 }
 914
 915 /*
 916 ** Push an object (ttype=string) to stack.
 917 */
 918 void lua_pushstring (char *s)
 919 {
 920   if (s == NULL)
 921     ttype(top) = LUA_T_NIL;
 922   else
 923   {
 924     tsvalue(top) = lua_createstring(s);
 925     ttype(top) = LUA_T_STRING;
 926   }
 927   incr_top;
 928 }
 929
 930
 931 /*
 932 ** Push an object (ttype=cfunction) to stack.
 933 */
 934 void lua_pushcfunction (lua_CFunction fn)
 935 {
 936  ttype(top) = LUA_T_CFUNCTION; fvalue(top) = fn;
 937  incr_top;
 938 }
 939
 940
 941
 942 void lua_pushusertag (void *u, int tag)
 943 {
 944   if (tag < 0 && tag != LUA_ANYTAG)
 945     luaI_realtag(tag);  /* error if tag is not valid */
 946   tsvalue(top) = luaI_createudata(u, tag);
 947   ttype(top) = LUA_T_USERDATA;
 948   incr_top;
 949 }
 950
 951 /*
 952 ** Push an object on the stack.
 953 */
 954 void luaI_pushobject (TObject *o)
 955 {
 956  *top = *o;
 957  incr_top;
 958 }
 959
 960 /*
 961 ** Push a lua_Object on stack.
 962 */
 963 void lua_pushobject (lua_Object o)
 964 {
 965   if (o == LUA_NOOBJECT)
 966     lua_error("API error - attempt to push a NOOBJECT");
 967   *top = *Address(o);
 968   if (ttype(top) == LUA_T_MARK) ttype(top) = LUA_T_FUNCTION;
 969   else if (ttype(top) == LUA_T_CMARK) ttype(top) = LUA_T_CFUNCTION;
 970   incr_top;
 971 }
 972
 973 int lua_tag (lua_Object lo)
 974 {
 975   if (lo == LUA_NOOBJECT) return LUA_T_NIL;
 976   else {
 977     TObject *o = Address(lo);
 978     lua_Type t = ttype(o);
 979     if (t == LUA_T_USERDATA)
 980       return o->value.ts->tag;
 981     else if (t == LUA_T_ARRAY)
 982       return o->value.a->htag;
 983     else return t;
 984   }
 985 }
 986
 987
 988 void luaI_gcIM (TObject *o)
 989 {
 990   TObject *im = luaI_getimbyObj(o, IM_GC);
 991   if (ttype(im) != LUA_T_NIL) {
 992     *top = *o;
 993     incr_top;
 994     callIM(im, 1, 0);
 995   }
 996 }
 997
 998
 999 static void call_binTM (IMS event, char *msg)
1000 {
1001   TObject *im = luaI_getimbyObj(top-2, event);  /* try first operand */
1002   if (ttype(im) == LUA_T_NIL) {
1003     im = luaI_getimbyObj(top-1, event);  /* try second operand */
1004     if (ttype(im) == LUA_T_NIL) {
1005       im = luaI_getim(0, event);  /* try a 'global' i.m. */
1006       if (ttype(im) == LUA_T_NIL)
1007         lua_error(msg);
1008     }
1009   }
1010   lua_pushstring(luaI_eventname[event]);
1011   callIM(im, 3, 1);
1012 }
1013
1014
1015 static void call_arith (IMS event)
1016 {
1017   call_binTM(event, "unexpected type at arithmetic operation");
1018 }
1019
1020
1021 static void comparison (lua_Type ttype_less, lua_Type ttype_equal,
1022                         lua_Type ttype_great, IMS op)
1023 {
1024   TObject *l = top-2;
1025   TObject *r = top-1;
1026   int result;
1027   if (ttype(l) == LUA_T_NUMBER && ttype(r) == LUA_T_NUMBER)
1028     result = (nvalue(l) < nvalue(r)) ? -1 : (nvalue(l) == nvalue(r)) ? 0 : 1;
1029   else if (ttype(l) == LUA_T_STRING && ttype(r) == LUA_T_STRING)
1030     result = strcmp(svalue(l), svalue(r));
1031   else {
1032     call_binTM(op, "unexpected type at comparison");
1033     return;
1034   }
1035   top--;
1036   nvalue(top-1) = 1;
1037   ttype(top-1) = (result < 0) ? ttype_less :
1038                                 (result == 0) ? ttype_equal : ttype_great;
1039 }
1040
1041
1042 static void adjust_varargs (StkId first_extra_arg)
1043 {
1044   TObject arg;
1045   TObject *firstelem = stack+first_extra_arg;
1046   int nvararg = top-firstelem;
1047   int i;
1048   if (nvararg < 0) nvararg = 0;
1049   avalue(&arg)  = lua_createarray(nvararg+1);  /* +1 for field 'n' */
1050   ttype(&arg) = LUA_T_ARRAY;
1051   for (i=0; i<nvararg; i++) {
1052     TObject index;
1053     ttype(&index) = LUA_T_NUMBER;
1054     nvalue(&index) = i+1;
1055     *(lua_hashdefine(avalue(&arg), &index)) = *(firstelem+i);
1056   }
1057   /* store counter in field "n" */ {
1058     TObject index, extra;
1059     ttype(&index) = LUA_T_STRING;
1060     tsvalue(&index) = lua_createstring("n");
1061     ttype(&extra) = LUA_T_NUMBER;
1062     nvalue(&extra) = nvararg;
1063     *(lua_hashdefine(avalue(&arg), &index)) = extra;
1064   }
1065   adjust_top(first_extra_arg);
1066   *top = arg; incr_top;
1067 }
1068
1069
1070
1071 /*
1072 ** Execute the given opcode, until a RET. Parameters are between
1073 ** [stack+base,top). Returns n such that the the results are between
1074 ** [stack+n,top).
1075 */
1076 static StkId lua_execute (Byte *pc, StkId base)
1077 {
1078   if (lua_callhook)
1079     callHook (base, LUA_T_MARK, 0);
1080  while (1)
1081  {
1082   OpCode opcode;
1083   switch (opcode = (OpCode)*pc++)
1084   {
1085    case PUSHNIL: ttype(top) = LUA_T_NIL; incr_top; break;
1086
1087    case PUSH0: case PUSH1: case PUSH2:
1088      ttype(top) = LUA_T_NUMBER;
1089      nvalue(top) = opcode-PUSH0;
1090      incr_top;
1091      break;
1092
1093    case PUSHBYTE:
1094      ttype(top) = LUA_T_NUMBER; nvalue(top) = *pc++; incr_top; break;
1095
1096    case PUSHWORD:
1097    {
1098     Word w;
1099     get_word(w,pc);
1100     ttype(top) = LUA_T_NUMBER; nvalue(top) = w;
1101     incr_top;
1102    }
1103    break;
1104
1105    case PUSHFLOAT:
1106    {
1107     real num;
1108     get_float(num,pc);
1109     ttype(top) = LUA_T_NUMBER; nvalue(top) = num;
1110     incr_top;
1111    }
1112    break;
1113
1114    case PUSHSTRING:
1115    {
1116     Word w;
1117     get_word(w,pc);
1118     ttype(top) = LUA_T_STRING; tsvalue(top) = lua_constant[w];
1119     incr_top;
1120    }
1121    break;
1122
1123    case PUSHFUNCTION:
1124    {
1125     TFunc *f;
1126     get_code(f,pc);
1127     luaI_insertfunction(f);  /* may take part in GC */
1128     top->ttype = LUA_T_FUNCTION;
1129     top->value.tf = f;
1130     incr_top;
1131    }
1132    break;
1133
1134    case PUSHLOCAL0: case PUSHLOCAL1: case PUSHLOCAL2:
1135    case PUSHLOCAL3: case PUSHLOCAL4: case PUSHLOCAL5:
1136    case PUSHLOCAL6: case PUSHLOCAL7: case PUSHLOCAL8:
1137    case PUSHLOCAL9:
1138      *top = *((stack+base) + (int)(opcode-PUSHLOCAL0)); incr_top; break;
1139
1140    case PUSHLOCAL: *top = *((stack+base) + (*pc++)); incr_top; break;
1141
1142    case PUSHGLOBAL:
1143    {
1144     Word w;
1145     get_word(w,pc);
1146     getglobal(w);
1147    }
1148    break;
1149
1150    case PUSHINDEXED:
1151     pushsubscript();
1152     break;
1153
1154    case PUSHSELF:
1155    {
1156      TObject receiver = *(top-1);
1157      Word w;
1158      get_word(w,pc);
1159      ttype(top) = LUA_T_STRING; tsvalue(top) = lua_constant[w];
1160      incr_top;
1161      pushsubscript();
1162      *top = receiver;
1163      incr_top;
1164      break;
1165    }
1166
1167    case STORELOCAL0: case STORELOCAL1: case STORELOCAL2:
1168    case STORELOCAL3: case STORELOCAL4: case STORELOCAL5:
1169    case STORELOCAL6: case STORELOCAL7: case STORELOCAL8:
1170    case STORELOCAL9:
1171      *((stack+base) + (int)(opcode-STORELOCAL0)) = *(--top);
1172      break;
1173
1174    case STORELOCAL: *((stack+base) + (*pc++)) = *(--top); break;
1175
1176    case STOREGLOBAL:
1177    {
1178     Word w;
1179     get_word(w,pc);
1180     setglobal(w);
1181    }
1182    break;
1183
1184    case STOREINDEXED0:
1185     storesubscript(top-3, 1);
1186     break;
1187
1188    case STOREINDEXED: {
1189      int n = *pc++;
1190      storesubscript(top-3-n, 2);
1191      break;
1192    }
1193
1194    case STORELIST0:
1195    case STORELIST:
1196    {
1197     int m, n;
1198     TObject *arr;
1199     if (opcode == STORELIST0) m = 0;
1200     else m = *(pc++) * FIELDS_PER_FLUSH;
1201     n = *(pc++);
1202     arr = top-n-1;
1203     while (n)
1204     {
1205      ttype(top) = LUA_T_NUMBER; nvalue(top) = n+m;
1206      *(lua_hashdefine (avalue(arr), top)) = *(top-1);
1207      top--;
1208      n--;
1209     }
1210    }
1211    break;
1212
1213    case STORERECORD:  /* opcode obsolete: supersed by STOREMAP */
1214    {
1215     int n = *(pc++);
1216     TObject *arr = top-n-1;
1217     while (n)
1218     {
1219      Word w;
1220      get_word(w,pc);
1221      ttype(top) = LUA_T_STRING; tsvalue(top) = lua_constant[w];
1222      *(lua_hashdefine (avalue(arr), top)) = *(top-1);
1223      top--;
1224      n--;
1225     }
1226    }
1227    break;
1228
1229    case STOREMAP: {
1230      int n = *(pc++);
1231      TObject *arr = top-(2*n)-1;
1232      while (n--) {
1233        *(lua_hashdefine (avalue(arr), top-2)) = *(top-1);
1234        top-=2;
1235      }
1236    }
1237    break;
1238
1239    case ADJUST0:
1240      adjust_top(base);
1241      break;
1242
1243    case ADJUST: {
1244      StkId newtop = base + *(pc++);
1245      adjust_top(newtop);
1246      break;
1247    }
1248
1249    case VARARGS:
1250      adjust_varargs(base + *(pc++));
1251      break;
1252
1253    case CREATEARRAY:
1254    {
1255     Word size;
1256     get_word(size,pc);
1257     avalue(top) = lua_createarray(size);
1258     ttype(top) = LUA_T_ARRAY;
1259     incr_top;
1260    }
1261    break;
1262
1263    case EQOP:
1264    {
1265     int res = lua_equalObj(top-2, top-1);
1266     --top;
1267     ttype(top-1) = res ? LUA_T_NUMBER : LUA_T_NIL;
1268     nvalue(top-1) = 1;
1269    }
1270    break;
1271
1272     case LTOP:
1273       comparison(LUA_T_NUMBER, LUA_T_NIL, LUA_T_NIL, IM_LT);
1274       break;
1275
1276    case LEOP:
1277       comparison(LUA_T_NUMBER, LUA_T_NUMBER, LUA_T_NIL, IM_LE);
1278       break;
1279
1280    case GTOP:
1281       comparison(LUA_T_NIL, LUA_T_NIL, LUA_T_NUMBER, IM_GT);
1282       break;
1283
1284    case GEOP:
1285       comparison(LUA_T_NIL, LUA_T_NUMBER, LUA_T_NUMBER, IM_GE);
1286       break;
1287
1288    case ADDOP:
1289    {
1290     TObject *l = top-2;
1291     TObject *r = top-1;
1292     if (tonumber(r) || tonumber(l))
1293       call_arith(IM_ADD);
1294     else
1295     {
1296       nvalue(l) += nvalue(r);
1297       --top;
1298     }
1299    }
1300    break;
1301
1302    case SUBOP:
1303    {
1304     TObject *l = top-2;
1305     TObject *r = top-1;
1306     if (tonumber(r) || tonumber(l))
1307       call_arith(IM_SUB);
1308     else
1309     {
1310       nvalue(l) -= nvalue(r);
1311       --top;
1312     }
1313    }
1314    break;
1315
1316    case MULTOP:
1317    {
1318     TObject *l = top-2;
1319     TObject *r = top-1;
1320     if (tonumber(r) || tonumber(l))
1321       call_arith(IM_MUL);
1322     else
1323     {
1324       nvalue(l) *= nvalue(r);
1325       --top;
1326     }
1327    }
1328    break;
1329
1330    case DIVOP:
1331    {
1332     TObject *l = top-2;
1333     TObject *r = top-1;
1334     if (tonumber(r) || tonumber(l))
1335       call_arith(IM_DIV);
1336     else
1337     {
1338       nvalue(l) /= nvalue(r);
1339       --top;
1340     }
1341    }
1342    break;
1343
1344    case POWOP:
1345     call_arith(IM_POW);
1346     break;
1347
1348    case CONCOP: {
1349      TObject *l = top-2;
1350      TObject *r = top-1;
1351      if (tostring(l) || tostring(r))
1352        call_binTM(IM_CONCAT, "unexpected type for concatenation");
1353      else {
1354        tsvalue(l) = lua_createstring(lua_strconc(svalue(l),svalue(r)));
1355        --top;
1356      }
1357    }
1358    break;
1359
1360    case MINUSOP:
1361     if (tonumber(top-1))
1362     {
1363       ttype(top) = LUA_T_NIL;
1364       incr_top;
1365       call_arith(IM_UNM);
1366     }
1367     else
1368       nvalue(top-1) = - nvalue(top-1);
1369    break;
1370
1371    case NOTOP:
1372     ttype(top-1) = (ttype(top-1) == LUA_T_NIL) ? LUA_T_NUMBER : LUA_T_NIL;
1373     nvalue(top-1) = 1;
1374    break;
1375
1376    case ONTJMP:
1377    {
1378     Word w;
1379     get_word(w,pc);
1380     if (ttype(top-1) != LUA_T_NIL) pc += w;
1381    }
1382    break;
1383
1384    case ONFJMP:
1385    {
1386     Word w;
1387     get_word(w,pc);
1388     if (ttype(top-1) == LUA_T_NIL) pc += w;
1389    }
1390    break;
1391
1392    case JMP:
1393    {
1394     Word w;
1395     get_word(w,pc);
1396     pc += w;
1397    }
1398    break;
1399
1400    case UPJMP:
1401    {
1402     Word w;
1403     get_word(w,pc);
1404     pc -= w;
1405    }
1406    break;
1407
1408    case IFFJMP:
1409    {
1410     Word w;
1411     get_word(w,pc);
1412     top--;
1413     if (ttype(top) == LUA_T_NIL) pc += w;
1414    }
1415    break;
1416
1417    case IFFUPJMP:
1418    {
1419     Word w;
1420     get_word(w,pc);
1421     top--;
1422     if (ttype(top) == LUA_T_NIL) pc -= w;
1423    }
1424    break;
1425
1426    case POP: --top; break;
1427
1428    case CALLFUNC:
1429    {
1430      int nParams = *(pc++);
1431      int nResults = *(pc++);
1432      StkId newBase = (top-stack)-nParams;
1433      do_call(newBase, nResults);
1434    }
1435    break;
1436
1437    case RETCODE0:
1438    case RETCODE:
1439      if (lua_callhook)
1440        callHook (base, LUA_T_MARK, 1);
1441      return (base + ((opcode==RETCODE0) ? 0 : *pc));
1442
1443    case SETLINE:
1444    {
1445     Word line;
1446     get_word(line,pc);
1447     if ((stack+base-1)->ttype != LUA_T_LINE)
1448     {
1449       /* open space for LINE value */
1450       open_stack((top-stack)-base);
1451       base++;
1452       (stack+base-1)->ttype = LUA_T_LINE;
1453     }
1454     (stack+base-1)->value.i = line;
1455     if (lua_linehook)
1456       lineHook (line);
1457     break;
1458    }
1459
1460    default:
1461     lua_error ("internal error - opcode doesn't match");
1462   }
1463  }
1464 }
1465
1466
1467 #if COMPAT2_5
1468 /*
1469 ** API: set a function as a fallback
1470 */
1471 lua_Object lua_setfallback (char *name, lua_CFunction fallback)
1472 {
1473   lua_pushstring(name);
1474   lua_pushcfunction(fallback);
1475   do_unprotectedrun(luaI_setfallback, 2, 1);
1476   return put_luaObjectonTop();
1477 }
1478 #endif