Mercurial > vba-clojure

     1 /*

     2 ** $Id: ldebug.c,v 2.29.1.6 2008/05/08 16:56:26 roberto Exp $

     3 ** Debug Interface

     4 ** See Copyright Notice in lua.h

     5 */

     6 

     7 

     8 #include <stdarg.h>

     9 #include <stddef.h>

    10 #include <string.h>

    11 

    12 

    13 #define ldebug_c

    14 #define LUA_CORE

    15 

    16 #include "lua.h"

    17 

    18 #include "lapi.h"

    19 #include "lcode.h"

    20 #include "ldebug.h"

    21 #include "ldo.h"

    22 #include "lfunc.h"

    23 #include "lobject.h"

    24 #include "lopcodes.h"

    25 #include "lstate.h"

    26 #include "lstring.h"

    27 #include "ltable.h"

    28 #include "ltm.h"

    29 #include "lvm.h"

    30 

    31 

    32 

    33 static const char *getfuncname (lua_State *L, CallInfo *ci, const char **name);

    34 

    35 

    36 static int currentpc (lua_State *L, CallInfo *ci) {

    37   if (!isLua(ci)) return -1;  /* function is not a Lua function? */

    38   if (ci == L->ci)

    39     ci->savedpc = L->savedpc;

    40   return pcRel(ci->savedpc, ci_func(ci)->l.p);

    41 }

    42 

    43 

    44 static int currentline (lua_State *L, CallInfo *ci) {

    45   int pc = currentpc(L, ci);

    46   if (pc < 0)

    47     return -1;  /* only active lua functions have current-line information */

    48   else

    49     return getline(ci_func(ci)->l.p, pc);

    50 }

    51 

    52 

    53 /*

    54 ** this function can be called asynchronous (e.g. during a signal)

    55 */

    56 LUA_API int lua_sethook (lua_State *L, lua_Hook func, int mask, int count) {

    57   if (func == NULL || mask == 0) {  /* turn off hooks? */

    58     mask = 0;

    59     func = NULL;

    60   }

    61   L->hook = func;

    62   L->basehookcount = count;

    63   resethookcount(L);

    64   L->hookmask = cast_byte(mask);

    65   return 1;

    66 }

    67 

    68 

    69 LUA_API lua_Hook lua_gethook (lua_State *L) {

    70   return L->hook;

    71 }

    72 

    73 

    74 LUA_API int lua_gethookmask (lua_State *L) {

    75   return L->hookmask;

    76 }

    77 

    78 

    79 LUA_API int lua_gethookcount (lua_State *L) {

    80   return L->basehookcount;

    81 }

    82 

    83 

    84 LUA_API int lua_getstack (lua_State *L, int level, lua_Debug *ar) {

    85   int status;

    86   CallInfo *ci;

    87   lua_lock(L);

    88   for (ci = L->ci; level > 0 && ci > L->base_ci; ci--) {

    89     level--;

    90     if (f_isLua(ci))  /* Lua function? */

    91       level -= ci->tailcalls;  /* skip lost tail calls */

    92   }

    93   if (level == 0 && ci > L->base_ci) {  /* level found? */

    94     status = 1;

    95     ar->i_ci = cast_int(ci - L->base_ci);

    96   }

    97   else if (level < 0) {  /* level is of a lost tail call? */

    98     status = 1;

    99     ar->i_ci = 0;

   100   }

   101   else status = 0;  /* no such level */

   102   lua_unlock(L);

   103   return status;

   104 }

   105 

   106 

   107 static Proto *getluaproto (CallInfo *ci) {

   108   return (isLua(ci) ? ci_func(ci)->l.p : NULL);

   109 }

   110 

   111 

   112 static const char *findlocal (lua_State *L, CallInfo *ci, int n) {

   113   const char *name;

   114   Proto *fp = getluaproto(ci);

   115   if (fp && (name = luaF_getlocalname(fp, n, currentpc(L, ci))) != NULL)

   116     return name;  /* is a local variable in a Lua function */

   117   else {

   118     StkId limit = (ci == L->ci) ? L->top : (ci+1)->func;

   119     if (limit - ci->base >= n && n > 0)  /* is 'n' inside 'ci' stack? */

   120       return "(*temporary)";

   121     else

   122       return NULL;

   123   }

   124 }

   125 

   126 

   127 LUA_API const char *lua_getlocal (lua_State *L, const lua_Debug *ar, int n) {

   128   CallInfo *ci = L->base_ci + ar->i_ci;

   129   const char *name = findlocal(L, ci, n);

   130   lua_lock(L);

   131   if (name)

   132       luaA_pushobject(L, ci->base + (n - 1));

   133   lua_unlock(L);

   134   return name;

   135 }

   136 

   137 

   138 LUA_API const char *lua_setlocal (lua_State *L, const lua_Debug *ar, int n) {

   139   CallInfo *ci = L->base_ci + ar->i_ci;

   140   const char *name = findlocal(L, ci, n);

   141   lua_lock(L);

   142   if (name)

   143       setobjs2s(L, ci->base + (n - 1), L->top - 1);

   144   L->top--;  /* pop value */

   145   lua_unlock(L);

   146   return name;

   147 }

   148 

   149 

   150 static void funcinfo (lua_Debug *ar, Closure *cl) {

   151   if (cl->c.isC) {

   152     ar->source = "=[C]";

   153     ar->linedefined = -1;

   154     ar->lastlinedefined = -1;

   155     ar->what = "C";

   156   }

   157   else {

   158     ar->source = getstr(cl->l.p->source);

   159     ar->linedefined = cl->l.p->linedefined;

   160     ar->lastlinedefined = cl->l.p->lastlinedefined;

   161     ar->what = (ar->linedefined == 0) ? "main" : "Lua";

   162   }

   163   luaO_chunkid(ar->short_src, ar->source, LUA_IDSIZE);

   164 }

   165 

   166 

   167 static void info_tailcall (lua_Debug *ar) {

   168   ar->name = ar->namewhat = "";

   169   ar->what = "tail";

   170   ar->lastlinedefined = ar->linedefined = ar->currentline = -1;

   171   ar->source = "=(tail call)";

   172   luaO_chunkid(ar->short_src, ar->source, LUA_IDSIZE);

   173   ar->nups = 0;

   174 }

   175 

   176 

   177 static void collectvalidlines (lua_State *L, Closure *f) {

   178   if (f == NULL || f->c.isC) {

   179     setnilvalue(L->top);

   180   }

   181   else {

   182     Table *t = luaH_new(L, 0, 0);

   183     int *lineinfo = f->l.p->lineinfo;

   184     int i;

   185     for (i=0; i<f->l.p->sizelineinfo; i++)

   186       setbvalue(luaH_setnum(L, t, lineinfo[i]), 1);

   187     sethvalue(L, L->top, t); 

   188   }

   189   incr_top(L);

   190 }

   191 

   192 

   193 static int auxgetinfo (lua_State *L, const char *what, lua_Debug *ar,

   194                     Closure *f, CallInfo *ci) {

   195   int status = 1;

   196   if (f == NULL) {

   197     info_tailcall(ar);

   198     return status;

   199   }

   200   for (; *what; what++) {

   201     switch (*what) {

   202       case 'S': {

   203         funcinfo(ar, f);

   204         break;

   205       }

   206       case 'l': {

   207         ar->currentline = (ci) ? currentline(L, ci) : -1;

   208         break;

   209       }

   210       case 'u': {

   211         ar->nups = f->c.nupvalues;

   212         break;

   213       }

   214       case 'n': {

   215         ar->namewhat = (ci) ? getfuncname(L, ci, &ar->name) : NULL;

   216         if (ar->namewhat == NULL) {

   217           ar->namewhat = "";  /* not found */

   218           ar->name = NULL;

   219         }

   220         break;

   221       }

   222       case 'L':

   223       case 'f':  /* handled by lua_getinfo */

   224         break;

   225       default: status = 0;  /* invalid option */

   226     }

   227   }

   228   return status;

   229 }

   230 

   231 

   232 LUA_API int lua_getinfo (lua_State *L, const char *what, lua_Debug *ar) {

   233   int status;

   234   Closure *f = NULL;

   235   CallInfo *ci = NULL;

   236   lua_lock(L);

   237   if (*what == '>') {

   238     StkId func = L->top - 1;

   239     luai_apicheck(L, ttisfunction(func));

   240     what++;  /* skip the '>' */

   241     f = clvalue(func);

   242     L->top--;  /* pop function */

   243   }

   244   else if (ar->i_ci != 0) {  /* no tail call? */

   245     ci = L->base_ci + ar->i_ci;

   246     lua_assert(ttisfunction(ci->func));

   247     f = clvalue(ci->func);

   248   }

   249   status = auxgetinfo(L, what, ar, f, ci);

   250   if (strchr(what, 'f')) {

   251     if (f == NULL) setnilvalue(L->top);

   252     else setclvalue(L, L->top, f);

   253     incr_top(L);

   254   }

   255   if (strchr(what, 'L'))

   256     collectvalidlines(L, f);

   257   lua_unlock(L);

   258   return status;

   259 }

   260 

   261 

   262 /*

   263 ** {======================================================

   264 ** Symbolic Execution and code checker

   265 ** =======================================================

   266 */

   267 

   268 #define check(x)		if (!(x)) return 0;

   269 

   270 #define checkjump(pt,pc)	check(0 <= pc && pc < pt->sizecode)

   271 

   272 #define checkreg(pt,reg)	check((reg) < (pt)->maxstacksize)

   273 

   274 

   275 

   276 static int precheck (const Proto *pt) {

   277   check(pt->maxstacksize <= MAXSTACK);

   278   check(pt->numparams+(pt->is_vararg & VARARG_HASARG) <= pt->maxstacksize);

   279   check(!(pt->is_vararg & VARARG_NEEDSARG) ||

   280               (pt->is_vararg & VARARG_HASARG));

   281   check(pt->sizeupvalues <= pt->nups);

   282   check(pt->sizelineinfo == pt->sizecode || pt->sizelineinfo == 0);

   283   check(pt->sizecode > 0 && GET_OPCODE(pt->code[pt->sizecode-1]) == OP_RETURN);

   284   return 1;

   285 }

   286 

   287 

   288 #define checkopenop(pt,pc)	luaG_checkopenop((pt)->code[(pc)+1])

   289 

   290 int luaG_checkopenop (Instruction i) {

   291   switch (GET_OPCODE(i)) {

   292     case OP_CALL:

   293     case OP_TAILCALL:

   294     case OP_RETURN:

   295     case OP_SETLIST: {

   296       check(GETARG_B(i) == 0);

   297       return 1;

   298     }

   299     default: return 0;  /* invalid instruction after an open call */

   300   }

   301 }

   302 

   303 

   304 static int checkArgMode (const Proto *pt, int r, enum OpArgMask mode) {

   305   switch (mode) {

   306     case OpArgN: check(r == 0); break;

   307     case OpArgU: break;

   308     case OpArgR: checkreg(pt, r); break;

   309     case OpArgK:

   310       check(ISK(r) ? INDEXK(r) < pt->sizek : r < pt->maxstacksize);

   311       break;

   312   }

   313   return 1;

   314 }

   315 

   316 

   317 static Instruction symbexec (const Proto *pt, int lastpc, int reg) {

   318   int pc;

   319   int last;  /* stores position of last instruction that changed `reg' */

   320   last = pt->sizecode-1;  /* points to final return (a `neutral' instruction) */

   321   check(precheck(pt));

   322   for (pc = 0; pc < lastpc; pc++) {

   323     Instruction i = pt->code[pc];

   324     OpCode op = GET_OPCODE(i);

   325     int a = GETARG_A(i);

   326     int b = 0;

   327     int c = 0;

   328     check(op < NUM_OPCODES);

   329     checkreg(pt, a);

   330     switch (getOpMode(op)) {

   331       case iABC: {

   332         b = GETARG_B(i);

   333         c = GETARG_C(i);

   334         check(checkArgMode(pt, b, getBMode(op)));

   335         check(checkArgMode(pt, c, getCMode(op)));

   336         break;

   337       }

   338       case iABx: {

   339         b = GETARG_Bx(i);

   340         if (getBMode(op) == OpArgK) check(b < pt->sizek);

   341         break;

   342       }

   343       case iAsBx: {

   344         b = GETARG_sBx(i);

   345         if (getBMode(op) == OpArgR) {

   346           int dest = pc+1+b;

   347           check(0 <= dest && dest < pt->sizecode);

   348           if (dest > 0) {

   349             int j;

   350             /* check that it does not jump to a setlist count; this

   351                is tricky, because the count from a previous setlist may

   352                have the same value of an invalid setlist; so, we must

   353                go all the way back to the first of them (if any) */

   354             for (j = 0; j < dest; j++) {

   355               Instruction d = pt->code[dest-1-j];

   356               if (!(GET_OPCODE(d) == OP_SETLIST && GETARG_C(d) == 0)) break;

   357             }

   358             /* if 'j' is even, previous value is not a setlist (even if

   359                it looks like one) */

   360             check((j&1) == 0);

   361           }

   362         }

   363         break;

   364       }

   365     }

   366     if (testAMode(op)) {

   367       if (a == reg) last = pc;  /* change register `a' */

   368     }

   369     if (testTMode(op)) {

   370       check(pc+2 < pt->sizecode);  /* check skip */

   371       check(GET_OPCODE(pt->code[pc+1]) == OP_JMP);

   372     }

   373     switch (op) {

   374       case OP_LOADBOOL: {

   375         if (c == 1) {  /* does it jump? */

   376           check(pc+2 < pt->sizecode);  /* check its jump */

   377           check(GET_OPCODE(pt->code[pc+1]) != OP_SETLIST ||

   378                 GETARG_C(pt->code[pc+1]) != 0);

   379         }

   380         break;

   381       }

   382       case OP_LOADNIL: {

   383         if (a <= reg && reg <= b)

   384           last = pc;  /* set registers from `a' to `b' */

   385         break;

   386       }

   387       case OP_GETUPVAL:

   388       case OP_SETUPVAL: {

   389         check(b < pt->nups);

   390         break;

   391       }

   392       case OP_GETGLOBAL:

   393       case OP_SETGLOBAL: {

   394         check(ttisstring(&pt->k[b]));

   395         break;

   396       }

   397       case OP_SELF: {

   398         checkreg(pt, a+1);

   399         if (reg == a+1) last = pc;

   400         break;

   401       }

   402       case OP_CONCAT: {

   403         check(b < c);  /* at least two operands */

   404         break;

   405       }

   406       case OP_TFORLOOP: {

   407         check(c >= 1);  /* at least one result (control variable) */

   408         checkreg(pt, a+2+c);  /* space for results */

   409         if (reg >= a+2) last = pc;  /* affect all regs above its base */

   410         break;

   411       }

   412       case OP_FORLOOP:

   413       case OP_FORPREP:

   414         checkreg(pt, a+3);

   415         /* go through */

   416       case OP_JMP: {

   417         int dest = pc+1+b;

   418         /* not full check and jump is forward and do not skip `lastpc'? */

   419         if (reg != NO_REG && pc < dest && dest <= lastpc)

   420           pc += b;  /* do the jump */

   421         break;

   422       }

   423       case OP_CALL:

   424       case OP_TAILCALL: {

   425         if (b != 0) {

   426           checkreg(pt, a+b-1);

   427         }

   428         c--;  /* c = num. returns */

   429         if (c == LUA_MULTRET) {

   430           check(checkopenop(pt, pc));

   431         }

   432         else if (c != 0)

   433           checkreg(pt, a+c-1);

   434         if (reg >= a) last = pc;  /* affect all registers above base */

   435         break;

   436       }

   437       case OP_RETURN: {

   438         b--;  /* b = num. returns */

   439         if (b > 0) checkreg(pt, a+b-1);

   440         break;

   441       }

   442       case OP_SETLIST: {

   443         if (b > 0) checkreg(pt, a + b);

   444         if (c == 0) {

   445           pc++;

   446           check(pc < pt->sizecode - 1);

   447         }

   448         break;

   449       }

   450       case OP_CLOSURE: {

   451         int nup, j;

   452         check(b < pt->sizep);

   453         nup = pt->p[b]->nups;

   454         check(pc + nup < pt->sizecode);

   455         for (j = 1; j <= nup; j++) {

   456           OpCode op1 = GET_OPCODE(pt->code[pc + j]);

   457           check(op1 == OP_GETUPVAL || op1 == OP_MOVE);

   458         }

   459         if (reg != NO_REG)  /* tracing? */

   460           pc += nup;  /* do not 'execute' these pseudo-instructions */

   461         break;

   462       }

   463       case OP_VARARG: {

   464         check((pt->is_vararg & VARARG_ISVARARG) &&

   465              !(pt->is_vararg & VARARG_NEEDSARG));

   466         b--;

   467         if (b == LUA_MULTRET) check(checkopenop(pt, pc));

   468         checkreg(pt, a+b-1);

   469         break;

   470       }

   471       default: break;

   472     }

   473   }

   474   return pt->code[last];

   475 }

   476 

   477 #undef check

   478 #undef checkjump

   479 #undef checkreg

   480 

   481 /* }====================================================== */

   482 

   483 

   484 int luaG_checkcode (const Proto *pt) {

   485   return (symbexec(pt, pt->sizecode, NO_REG) != 0);

   486 }

   487 

   488 

   489 static const char *kname (Proto *p, int c) {

   490   if (ISK(c) && ttisstring(&p->k[INDEXK(c)]))

   491     return svalue(&p->k[INDEXK(c)]);

   492   else

   493     return "?";

   494 }

   495 

   496 

   497 static const char *getobjname (lua_State *L, CallInfo *ci, int stackpos,

   498                                const char **name) {

   499   if (isLua(ci)) {  /* a Lua function? */

   500     Proto *p = ci_func(ci)->l.p;

   501     int pc = currentpc(L, ci);

   502     Instruction i;

   503     *name = luaF_getlocalname(p, stackpos+1, pc);

   504     if (*name)  /* is a local? */

   505       return "local";

   506     i = symbexec(p, pc, stackpos);  /* try symbolic execution */

   507     lua_assert(pc != -1);

   508     switch (GET_OPCODE(i)) {

   509       case OP_GETGLOBAL: {

   510         int g = GETARG_Bx(i);  /* global index */

   511         lua_assert(ttisstring(&p->k[g]));

   512         *name = svalue(&p->k[g]);

   513         return "global";

   514       }

   515       case OP_MOVE: {

   516         int a = GETARG_A(i);

   517         int b = GETARG_B(i);  /* move from `b' to `a' */

   518         if (b < a)

   519           return getobjname(L, ci, b, name);  /* get name for `b' */

   520         break;

   521       }

   522       case OP_GETTABLE: {

   523         int k = GETARG_C(i);  /* key index */

   524         *name = kname(p, k);

   525         return "field";

   526       }

   527       case OP_GETUPVAL: {

   528         int u = GETARG_B(i);  /* upvalue index */

   529         *name = p->upvalues ? getstr(p->upvalues[u]) : "?";

   530         return "upvalue";

   531       }

   532       case OP_SELF: {

   533         int k = GETARG_C(i);  /* key index */

   534         *name = kname(p, k);

   535         return "method";

   536       }

   537       default: break;

   538     }

   539   }

   540   return NULL;  /* no useful name found */

   541 }

   542 

   543 

   544 static const char *getfuncname (lua_State *L, CallInfo *ci, const char **name) {

   545   Instruction i;

   546   if ((isLua(ci) && ci->tailcalls > 0) || !isLua(ci - 1))

   547     return NULL;  /* calling function is not Lua (or is unknown) */

   548   ci--;  /* calling function */

   549   i = ci_func(ci)->l.p->code[currentpc(L, ci)];

   550   if (GET_OPCODE(i) == OP_CALL || GET_OPCODE(i) == OP_TAILCALL ||

   551       GET_OPCODE(i) == OP_TFORLOOP)

   552     return getobjname(L, ci, GETARG_A(i), name);

   553   else

   554     return NULL;  /* no useful name can be found */

   555 }

   556 

   557 

   558 /* only ANSI way to check whether a pointer points to an array */

   559 static int isinstack (CallInfo *ci, const TValue *o) {

   560   StkId p;

   561   for (p = ci->base; p < ci->top; p++)

   562     if (o == p) return 1;

   563   return 0;

   564 }

   565 

   566 

   567 void luaG_typeerror (lua_State *L, const TValue *o, const char *op) {

   568   const char *name = NULL;

   569   const char *t = luaT_typenames[ttype(o)];

   570   const char *kind = (isinstack(L->ci, o)) ?

   571                          getobjname(L, L->ci, cast_int(o - L->base), &name) :

   572                          NULL;

   573   if (kind)

   574     luaG_runerror(L, "attempt to %s %s " LUA_QS " (a %s value)",

   575                 op, kind, name, t);

   576   else

   577     luaG_runerror(L, "attempt to %s a %s value", op, t);

   578 }

   579 

   580 

   581 void luaG_concaterror (lua_State *L, StkId p1, StkId p2) {

   582   if (ttisstring(p1) || ttisnumber(p1)) p1 = p2;

   583   lua_assert(!ttisstring(p1) && !ttisnumber(p1));

   584   luaG_typeerror(L, p1, "concatenate");

   585 }

   586 

   587 

   588 void luaG_aritherror (lua_State *L, const TValue *p1, const TValue *p2) {

   589   TValue temp;

   590   if (luaV_tonumber(p1, &temp) == NULL)

   591     p2 = p1;  /* first operand is wrong */

   592   luaG_typeerror(L, p2, "perform arithmetic on");

   593 }

   594 

   595 

   596 int luaG_ordererror (lua_State *L, const TValue *p1, const TValue *p2) {

   597   const char *t1 = luaT_typenames[ttype(p1)];

   598   const char *t2 = luaT_typenames[ttype(p2)];

   599   if (t1[2] == t2[2])

   600     luaG_runerror(L, "attempt to compare two %s values", t1);

   601   else

   602     luaG_runerror(L, "attempt to compare %s with %s", t1, t2);

   603   return 0;

   604 }

   605 

   606 

   607 static void addinfo (lua_State *L, const char *msg) {

   608   CallInfo *ci = L->ci;

   609   if (isLua(ci)) {  /* is Lua code? */

   610     char buff[LUA_IDSIZE];  /* add file:line information */

   611     int line = currentline(L, ci);

   612     luaO_chunkid(buff, getstr(getluaproto(ci)->source), LUA_IDSIZE);

   613     luaO_pushfstring(L, "%s:%d: %s", buff, line, msg);

   614   }

   615 }

   616 

   617 

   618 void luaG_errormsg (lua_State *L) {

   619   if (L->errfunc != 0) {  /* is there an error handling function? */

   620     StkId errfunc = restorestack(L, L->errfunc);

   621     if (!ttisfunction(errfunc)) luaD_throw(L, LUA_ERRERR);

   622     setobjs2s(L, L->top, L->top - 1);  /* move argument */

   623     setobjs2s(L, L->top - 1, errfunc);  /* push function */

   624     incr_top(L);

   625     luaD_call(L, L->top - 2, 1);  /* call it */

   626   }

   627   luaD_throw(L, LUA_ERRRUN);

   628 }

   629 

   630 

   631 void luaG_runerror (lua_State *L, const char *fmt, ...) {

   632   va_list argp;

   633   va_start(argp, fmt);

   634   addinfo(L, luaO_pushvfstring(L, fmt, argp));

   635   va_end(argp);

   636   luaG_errormsg(L);

   637 }

   638
author	Robert McIntyre <rlm@mit.edu>
date	Fri, 31 Aug 2012 08:50:32 -0500
parents	27763b933818
children