- initial import of revision 374 from cnc
[apt.git] / lua / ldebug.c
1 /*
2 ** $Id: ldebug.c,v 1.150 2003/03/19 21:24:04 roberto Exp $
3 ** Debug Interface
4 ** See Copyright Notice in lua.h
5 */
6
7
8 #include <stdlib.h>
9 #include <string.h>
10
11 #define ldebug_c
12
13 #include "lua.h"
14
15 #include "lapi.h"
16 #include "lcode.h"
17 #include "ldebug.h"
18 #include "ldo.h"
19 #include "lfunc.h"
20 #include "lobject.h"
21 #include "lopcodes.h"
22 #include "lstate.h"
23 #include "lstring.h"
24 #include "ltable.h"
25 #include "ltm.h"
26 #include "lvm.h"
27
28
29
30 static const char *getfuncname (CallInfo *ci, const char **name);
31
32
33 #define isLua(ci)       (!((ci)->state & CI_C))
34
35
36 static int currentpc (CallInfo *ci) {
37   if (!isLua(ci)) return -1;  /* function is not a Lua function? */
38   if (ci->state & CI_HASFRAME)  /* function has a frame? */
39     ci->u.l.savedpc = *ci->u.l.pc;  /* use `pc' from there */
40   /* function's pc is saved */
41   return pcRel(ci->u.l.savedpc, ci_func(ci)->l.p);
42 }
43
44
45 static int currentline (CallInfo *ci) {
46   int pc = currentpc(ci);
47   if (pc < 0)
48     return -1;  /* only active lua functions have current-line information */
49   else
50     return getline(ci_func(ci)->l.p, pc);
51 }
52
53
54 void luaG_inithooks (lua_State *L) {
55   CallInfo *ci;
56   for (ci = L->ci; ci != L->base_ci; ci--)  /* update all `savedpc's */
57     currentpc(ci);
58   L->hookinit = 1;
59 }
60
61
62 /*
63 ** this function can be called asynchronous (e.g. during a signal)
64 */
65 LUA_API int lua_sethook (lua_State *L, lua_Hook func, int mask, int count) {
66   if (func == NULL || mask == 0) {  /* turn off hooks? */
67     mask = 0;
68     func = NULL;
69   }
70   L->hook = func;
71   L->basehookcount = count;
72   resethookcount(L);
73   L->hookmask = cast(lu_byte, mask);
74   L->hookinit = 0;
75   return 1;
76 }
77
78
79 LUA_API lua_Hook lua_gethook (lua_State *L) {
80   return L->hook;
81 }
82
83
84 LUA_API int lua_gethookmask (lua_State *L) {
85   return L->hookmask;
86 }
87
88
89 LUA_API int lua_gethookcount (lua_State *L) {
90   return L->basehookcount;
91 }
92
93
94 LUA_API int lua_getstack (lua_State *L, int level, lua_Debug *ar) {
95   int status;
96   CallInfo *ci;
97   lua_lock(L);
98   for (ci = L->ci; level > 0 && ci > L->base_ci; ci--) {
99     level--;
100     if (!(ci->state & CI_C))  /* Lua function? */
101       level -= ci->u.l.tailcalls;  /* skip lost tail calls */
102   }
103   if (level > 0 || ci == L->base_ci) status = 0;  /* there is no such level */
104   else if (level < 0) {  /* level is of a lost tail call */
105     status = 1;
106     ar->i_ci = 0;
107   }
108   else {
109     status = 1;
110     ar->i_ci = ci - L->base_ci;
111   }
112   lua_unlock(L);
113   return status;
114 }
115
116
117 static Proto *getluaproto (CallInfo *ci) {
118   return (isLua(ci) ? ci_func(ci)->l.p : NULL);
119 }
120
121
122 LUA_API const char *lua_getlocal (lua_State *L, const lua_Debug *ar, int n) {
123   const char *name;
124   CallInfo *ci;
125   Proto *fp;
126   lua_lock(L);
127   name = NULL;
128   ci = L->base_ci + ar->i_ci;
129   fp = getluaproto(ci);
130   if (fp) {  /* is a Lua function? */
131     name = luaF_getlocalname(fp, n, currentpc(ci));
132     if (name)
133       luaA_pushobject(L, ci->base+(n-1));  /* push value */
134   }
135   lua_unlock(L);
136   return name;
137 }
138
139
140 LUA_API const char *lua_setlocal (lua_State *L, const lua_Debug *ar, int n) {
141   const char *name;
142   CallInfo *ci;
143   Proto *fp;
144   lua_lock(L);
145   name = NULL;
146   ci = L->base_ci + ar->i_ci;
147   fp = getluaproto(ci);
148   L->top--;  /* pop new value */
149   if (fp) {  /* is a Lua function? */
150     name = luaF_getlocalname(fp, n, currentpc(ci));
151     if (!name || name[0] == '(')  /* `(' starts private locals */
152       name = NULL;
153     else
154       setobjs2s(ci->base+(n-1), L->top);
155   }
156   lua_unlock(L);
157   return name;
158 }
159
160
161 static void funcinfo (lua_Debug *ar, StkId func) {
162   Closure *cl = clvalue(func);
163   if (cl->c.isC) {
164     ar->source = "=[C]";
165     ar->linedefined = -1;
166     ar->what = "C";
167   }
168   else {
169     ar->source = getstr(cl->l.p->source);
170     ar->linedefined = cl->l.p->lineDefined;
171     ar->what = (ar->linedefined == 0) ? "main" : "Lua";
172   }
173   luaO_chunkid(ar->short_src, ar->source, LUA_IDSIZE);
174 }
175
176
177 static const char *travglobals (lua_State *L, const TObject *o) {
178   Table *g = hvalue(gt(L));
179   int i = sizenode(g);
180   while (i--) {
181     Node *n = gnode(g, i);
182     if (luaO_rawequalObj(o, gval(n)) && ttisstring(gkey(n)))
183       return getstr(tsvalue(gkey(n)));
184   }
185   return NULL;
186 }
187
188
189 static void info_tailcall (lua_State *L, lua_Debug *ar) {
190   ar->name = ar->namewhat = "";
191   ar->what = "tail";
192   ar->linedefined = ar->currentline = -1;
193   ar->source = "=(tail call)";
194   luaO_chunkid(ar->short_src, ar->source, LUA_IDSIZE);
195   ar->nups = 0;
196   setnilvalue(L->top);
197 }
198
199
200 static int auxgetinfo (lua_State *L, const char *what, lua_Debug *ar,
201                     StkId f, CallInfo *ci) {
202   int status = 1;
203   for (; *what; what++) {
204     switch (*what) {
205       case 'S': {
206         funcinfo(ar, f);
207         break;
208       }
209       case 'l': {
210         ar->currentline = (ci) ? currentline(ci) : -1;
211         break;
212       }
213       case 'u': {
214         ar->nups = clvalue(f)->c.nupvalues;
215         break;
216       }
217       case 'n': {
218         ar->namewhat = (ci) ? getfuncname(ci, &ar->name) : NULL;
219         if (ar->namewhat == NULL) {
220           /* try to find a global name */
221           if ((ar->name = travglobals(L, f)) != NULL)
222             ar->namewhat = "global";
223           else ar->namewhat = "";  /* not found */
224         }
225         break;
226       }
227       case 'f': {
228         setobj2s(L->top, f);
229         break;
230       }
231       default: status = 0;  /* invalid option */
232     }
233   }
234   return status;
235 }
236
237
238 LUA_API int lua_getinfo (lua_State *L, const char *what, lua_Debug *ar) {
239   int status = 1;
240   lua_lock(L);
241   if (*what == '>') {
242     StkId f = L->top - 1;
243     if (!ttisfunction(f))
244       luaG_runerror(L, "value for `lua_getinfo' is not a function");
245     status = auxgetinfo(L, what + 1, ar, f, NULL);
246     L->top--;  /* pop function */
247   }
248   else if (ar->i_ci != 0) {  /* no tail call? */
249     CallInfo *ci = L->base_ci + ar->i_ci;
250     lua_assert(ttisfunction(ci->base - 1));
251     status = auxgetinfo(L, what, ar, ci->base - 1, ci);
252   }
253   else
254     info_tailcall(L, ar);
255   if (strchr(what, 'f')) incr_top(L);
256   lua_unlock(L);
257   return status;
258 }
259
260
261 /*
262 ** {======================================================
263 ** Symbolic Execution and code checker
264 ** =======================================================
265 */
266
267 #define check(x)                if (!(x)) return 0;
268
269 #define checkjump(pt,pc)        check(0 <= pc && pc < pt->sizecode)
270
271 #define checkreg(pt,reg)        check((reg) < (pt)->maxstacksize)
272
273
274
275 static int precheck (const Proto *pt) {
276   check(pt->maxstacksize <= MAXSTACK);
277   check(pt->sizelineinfo == pt->sizecode || pt->sizelineinfo == 0);
278   lua_assert(pt->numparams+pt->is_vararg <= pt->maxstacksize);
279   check(GET_OPCODE(pt->code[pt->sizecode-1]) == OP_RETURN);
280   return 1;
281 }
282
283
284 static int checkopenop (const Proto *pt, int pc) {
285   Instruction i = pt->code[pc+1];
286   switch (GET_OPCODE(i)) {
287     case OP_CALL:
288     case OP_TAILCALL:
289     case OP_RETURN: {
290       check(GETARG_B(i) == 0);
291       return 1;
292     }
293     case OP_SETLISTO: return 1;
294     default: return 0;  /* invalid instruction after an open call */
295   }
296 }
297
298
299 static int checkRK (const Proto *pt, int r) {
300   return (r < pt->maxstacksize || (r >= MAXSTACK && r-MAXSTACK < pt->sizek));
301 }
302
303
304 static Instruction luaG_symbexec (const Proto *pt, int lastpc, int reg) {
305   int pc;
306   int last;  /* stores position of last instruction that changed `reg' */
307   last = pt->sizecode-1;  /* points to final return (a `neutral' instruction) */
308   check(precheck(pt));
309   for (pc = 0; pc < lastpc; pc++) {
310     const Instruction i = pt->code[pc];
311     OpCode op = GET_OPCODE(i);
312     int a = GETARG_A(i);
313     int b = 0;
314     int c = 0;
315     checkreg(pt, a);
316     switch (getOpMode(op)) {
317       case iABC: {
318         b = GETARG_B(i);
319         c = GETARG_C(i);
320         if (testOpMode(op, OpModeBreg)) {
321           checkreg(pt, b);
322         }
323         else if (testOpMode(op, OpModeBrk))
324           check(checkRK(pt, b));
325         if (testOpMode(op, OpModeCrk))
326           check(checkRK(pt, c));
327         break;
328       }
329       case iABx: {
330         b = GETARG_Bx(i);
331         if (testOpMode(op, OpModeK)) check(b < pt->sizek);
332         break;
333       }
334       case iAsBx: {
335         b = GETARG_sBx(i);
336         break;
337       }
338     }
339     if (testOpMode(op, OpModesetA)) {
340       if (a == reg) last = pc;  /* change register `a' */
341     }
342     if (testOpMode(op, OpModeT)) {
343       check(pc+2 < pt->sizecode);  /* check skip */
344       check(GET_OPCODE(pt->code[pc+1]) == OP_JMP);
345     }
346     switch (op) {
347       case OP_LOADBOOL: {
348         check(c == 0 || pc+2 < pt->sizecode);  /* check its jump */
349         break;
350       }
351       case OP_LOADNIL: {
352         if (a <= reg && reg <= b)
353           last = pc;  /* set registers from `a' to `b' */
354         break;
355       }
356       case OP_GETUPVAL:
357       case OP_SETUPVAL: {
358         check(b < pt->nups);
359         break;
360       }
361       case OP_GETGLOBAL:
362       case OP_SETGLOBAL: {
363         check(ttisstring(&pt->k[b]));
364         break;
365       }
366       case OP_SELF: {
367         checkreg(pt, a+1);
368         if (reg == a+1) last = pc;
369         break;
370       }
371       case OP_CONCAT: {
372         /* `c' is a register, and at least two operands */
373         check(c < MAXSTACK && b < c);
374         break;
375       }
376       case OP_TFORLOOP:
377         checkreg(pt, a+c+5);
378         if (reg >= a) last = pc;  /* affect all registers above base */
379         /* go through */
380       case OP_FORLOOP:
381         checkreg(pt, a+2);
382         /* go through */
383       case OP_JMP: {
384         int dest = pc+1+b;
385         check(0 <= dest && dest < pt->sizecode);
386         /* not full check and jump is forward and do not skip `lastpc'? */
387         if (reg != NO_REG && pc < dest && dest <= lastpc)
388           pc += b;  /* do the jump */
389         break;
390       }
391       case OP_CALL:
392       case OP_TAILCALL: {
393         if (b != 0) {
394           checkreg(pt, a+b-1);
395         }
396         c--;  /* c = num. returns */
397         if (c == LUA_MULTRET) {
398           check(checkopenop(pt, pc));
399         }
400         else if (c != 0)
401           checkreg(pt, a+c-1);
402         if (reg >= a) last = pc;  /* affect all registers above base */
403         break;
404       }
405       case OP_RETURN: {
406         b--;  /* b = num. returns */
407         if (b > 0) checkreg(pt, a+b-1);
408         break;
409       }
410       case OP_SETLIST: {
411         checkreg(pt, a + (b&(LFIELDS_PER_FLUSH-1)) + 1);
412         break;
413       }
414       case OP_CLOSURE: {
415         int nup;
416         check(b < pt->sizep);
417         nup = pt->p[b]->nups;
418         check(pc + nup < pt->sizecode);
419         for (; nup>0; nup--) {
420           OpCode op1 = GET_OPCODE(pt->code[pc+nup]);
421           check(op1 == OP_GETUPVAL || op1 == OP_MOVE);
422         }
423         break;
424       }
425       default: break;
426     }
427   }
428   return pt->code[last];
429 }
430
431 #undef check
432 #undef checkjump
433 #undef checkreg
434
435 /* }====================================================== */
436
437
438 int luaG_checkcode (const Proto *pt) {
439   return luaG_symbexec(pt, pt->sizecode, NO_REG);
440 }
441
442
443 static const char *kname (Proto *p, int c) {
444   c = c - MAXSTACK;
445   if (c >= 0 && ttisstring(&p->k[c]))
446     return svalue(&p->k[c]);
447   else
448     return "?";
449 }
450
451
452 static const char *getobjname (CallInfo *ci, int stackpos, const char **name) {
453   if (isLua(ci)) {  /* a Lua function? */
454     Proto *p = ci_func(ci)->l.p;
455     int pc = currentpc(ci);
456     Instruction i;
457     *name = luaF_getlocalname(p, stackpos+1, pc);
458     if (*name)  /* is a local? */
459       return "local";
460     i = luaG_symbexec(p, pc, stackpos);  /* try symbolic execution */
461     lua_assert(pc != -1);
462     switch (GET_OPCODE(i)) {
463       case OP_GETGLOBAL: {
464         int g = GETARG_Bx(i);  /* global index */
465         lua_assert(ttisstring(&p->k[g]));
466         *name = svalue(&p->k[g]);
467         return "global";
468       }
469       case OP_MOVE: {
470         int a = GETARG_A(i);
471         int b = GETARG_B(i);  /* move from `b' to `a' */
472         if (b < a)
473           return getobjname(ci, b, name);  /* get name for `b' */
474         break;
475       }
476       case OP_GETTABLE: {
477         int k = GETARG_C(i);  /* key index */
478         *name = kname(p, k);
479         return "field";
480       }
481       case OP_SELF: {
482         int k = GETARG_C(i);  /* key index */
483         *name = kname(p, k);
484         return "method";
485       }
486       default: break;
487     }
488   }
489   return NULL;  /* no useful name found */
490 }
491
492
493 static const char *getfuncname (CallInfo *ci, const char **name) {
494   Instruction i;
495   if ((isLua(ci) && ci->u.l.tailcalls > 0) || !isLua(ci - 1))
496     return NULL;  /* calling function is not Lua (or is unknown) */
497   ci--;  /* calling function */
498   i = ci_func(ci)->l.p->code[currentpc(ci)];
499   if (GET_OPCODE(i) == OP_CALL || GET_OPCODE(i) == OP_TAILCALL)
500     return getobjname(ci, GETARG_A(i), name);
501   else
502     return NULL;  /* no useful name can be found */
503 }
504
505
506 /* only ANSI way to check whether a pointer points to an array */
507 static int isinstack (CallInfo *ci, const TObject *o) {
508   StkId p;
509   for (p = ci->base; p < ci->top; p++)
510     if (o == p) return 1;
511   return 0;
512 }
513
514
515 void luaG_typeerror (lua_State *L, const TObject *o, const char *op) {
516   const char *name = NULL;
517   const char *t = luaT_typenames[ttype(o)];
518   const char *kind = (isinstack(L->ci, o)) ?
519                          getobjname(L->ci, o - L->base, &name) : NULL;
520   if (kind)
521     luaG_runerror(L, "attempt to %s %s `%s' (a %s value)",
522                 op, kind, name, t);
523   else
524     luaG_runerror(L, "attempt to %s a %s value", op, t);
525 }
526
527
528 void luaG_concaterror (lua_State *L, StkId p1, StkId p2) {
529   if (ttisstring(p1)) p1 = p2;
530   lua_assert(!ttisstring(p1));
531   luaG_typeerror(L, p1, "concatenate");
532 }
533
534
535 void luaG_aritherror (lua_State *L, const TObject *p1, const TObject *p2) {
536   TObject temp;
537   if (luaV_tonumber(p1, &temp) == NULL)
538     p2 = p1;  /* first operand is wrong */
539   luaG_typeerror(L, p2, "perform arithmetic on");
540 }
541
542
543 int luaG_ordererror (lua_State *L, const TObject *p1, const TObject *p2) {
544   const char *t1 = luaT_typenames[ttype(p1)];
545   const char *t2 = luaT_typenames[ttype(p2)];
546   if (t1[2] == t2[2])
547     luaG_runerror(L, "attempt to compare two %s values", t1);
548   else
549     luaG_runerror(L, "attempt to compare %s with %s", t1, t2);
550   return 0;
551 }
552
553
554 static void addinfo (lua_State *L, const char *msg) {
555   CallInfo *ci = L->ci;
556   if (isLua(ci)) {  /* is Lua code? */
557     char buff[LUA_IDSIZE];  /* add file:line information */
558     int line = currentline(ci);
559     luaO_chunkid(buff, getstr(getluaproto(ci)->source), LUA_IDSIZE);
560     luaO_pushfstring(L, "%s:%d: %s", buff, line, msg);
561   }
562 }
563
564
565 void luaG_errormsg (lua_State *L) {
566   if (L->errfunc != 0) {  /* is there an error handling function? */
567     StkId errfunc = restorestack(L, L->errfunc);
568     if (!ttisfunction(errfunc)) luaD_throw(L, LUA_ERRERR);
569     setobjs2s(L->top, L->top - 1);  /* move argument */
570     setobjs2s(L->top - 1, errfunc);  /* push function */
571     incr_top(L);
572     luaD_call(L, L->top - 2, 1);  /* call it */
573   }
574   luaD_throw(L, LUA_ERRRUN);
575 }
576
577
578 void luaG_runerror (lua_State *L, const char *fmt, ...) {
579   va_list argp;
580   va_start(argp, fmt);
581   addinfo(L, luaO_pushvfstring(L, fmt, argp));
582   va_end(argp);
583   luaG_errormsg(L);
584 }
585