#include <ctype.h>
#include "lisp/io.h"
#include "lisp/debugger.h"
#include "lisp/write.h"
#ifdef DEBUGGER
#define DebuggerHelp 0
#define DebuggerAbort 1
#define DebuggerBacktrace 2
#define DebuggerContinue 3
#define DebuggerFinish 4
#define DebuggerFrame 5
#define DebuggerNext 6
#define DebuggerPrint 7
#define DebuggerStep 8
#define DebuggerBreak 9
#define DebuggerDelete 10
#define DebuggerDown 11
#define DebuggerUp 12
#define DebuggerInfo 13
#define DebuggerWatch 14
#define DebuggerInfoBreakpoints 0
#define DebuggerInfoBacktrace 1
static char *format_integer(int);
static void LispDebuggerCommand(LispObj *obj);
static struct {
char *name;
int action;
} commands[] = {
{"help", DebuggerHelp},
{"abort", DebuggerAbort},
{"backtrace", DebuggerBacktrace},
{"b", DebuggerBreak},
{"break", DebuggerBreak},
{"bt", DebuggerBacktrace},
{"continue", DebuggerContinue},
{"d", DebuggerDelete},
{"delete", DebuggerDelete},
{"down", DebuggerDown},
{"finish", DebuggerFinish},
{"frame", DebuggerFrame},
{"info", DebuggerInfo},
{"n", DebuggerNext},
{"next", DebuggerNext},
{"print", DebuggerPrint},
{"run", DebuggerContinue},
{"s", DebuggerStep},
{"step", DebuggerStep},
{"up", DebuggerUp},
{"watch", DebuggerWatch},
};
static struct {
char *name;
int subaction;
} info_commands[] = {
{"breakpoints", DebuggerInfoBreakpoints},
{"stack", DebuggerInfoBacktrace},
{"watchpoints", DebuggerInfoBreakpoints},
};
static char debugger_help[] =
"Available commands are:\n\
\n\
help - This message.\n\
abort - Abort the current execution, and return to toplevel.\n\
backtrace, bt - Print backtrace.\n\
b, break - Set breakpoint at function name argument.\n\
continue - Continue execution.\n\
d, delete - Delete breakpoint(s), all breakpoint if no arguments given.\n\
down - Set environment to frame called by the current one.\n\
finish - Executes until current form is finished.\n\
frame - Set environment to selected frame.\n\
info - Prints information about the debugger state.\n\
n, next - Evaluate next form.\n\
print - Print value of variable name argument.\n\
run - Continue execution.\n\
s, step - Evaluate next form, stopping on any subforms.\n\
up - Set environment to frame that called the current one.\n\
\n\
Commands may be abbreviated.\n";
static char debugger_info_help[] =
"Available subcommands are:\n\
\n\
breakpoints - List and prints status of breakpoints, and watchpoints.\n\
stack - Backtrace of stack.\n\
watchpoints - List and prints status of watchpoints, and breakpoints.\n\
\n\
Subcommands may be abbreviated.\n";
void
LispDebugger(LispDebugCall call, LispObj *name, LispObj *arg)
{
int force = 0;
LispObj *obj, *prev;
switch (call) {
case LispDebugCallBegin:
++lisp__data.debug_level;
GCDisable();
DBG = CONS(CONS(name, CONS(arg, CONS(FIXNUM(lisp__data.stack.base),
CONS(FIXNUM(lisp__data.env.length),
FIXNUM(lisp__data.env.lex))))), DBG);
GCEnable();
for (obj = BRK; obj != NIL; obj = CDR(obj))
if (ATOMID(CAR(CAR(obj))) == ATOMID(name) &&
FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj))))) ==
LispDebugBreakFunction)
break;
if (obj != NIL) {
long counter;
if (LispGetColumn(NIL))
LispFputc(Stdout, '\n');
LispFputs(Stdout, "BREAK #");
LispWriteObject(NIL, CAR(CDR(CAR(obj))));
LispFputs(Stdout, "> (");
LispWriteObject(NIL, CAR(CAR(DBG)));
LispFputc(Stdout, ' ');
LispWriteObject(NIL, CAR(CDR(CAR(DBG))));
LispFputs(Stdout, ")\n");
force = 1;
counter = FIXNUM_VALUE(CAR(CDR(CDR(CDR(CAR(obj))))));
CAR(CDR(CDR(CDR(CAR(obj))))) FIXNUM(counter + 1);
}
break;
case LispDebugCallEnd:
DBG = CDR(DBG);
if (lisp__data.debug_level < lisp__data.debug_step)
lisp__data.debug_step = lisp__data.debug_level;
--lisp__data.debug_level;
break;
case LispDebugCallFatal:
LispDebuggerCommand(NIL);
return;
case LispDebugCallWatch:
break;
}
if (call == LispDebugCallEnd || call == LispDebugCallWatch) {
watch_again:
for (prev = obj = BRK; obj != NIL; prev = obj, obj = CDR(obj)) {
if (FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj))))) ==
LispDebugBreakVariable) {
LispObj *wat = CAR(CDR(CDR(CDR(CDR(CAR(obj))))));
void *sym = LispGetVarAddr(CAAR(obj));
LispObj *frm = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(obj))))))));
if ((sym == NULL && lisp__data.debug_level <= 0) ||
(sym != wat->data.opaque.data &&
FIXNUM_VALUE(frm) > lisp__data.debug_level)) {
LispFputs(Stdout, "WATCH #");
LispFputs(Stdout, format_integer(FIXNUM_VALUE(CAR(CDR(CAR(obj))))));
LispFputs(Stdout, "> ");
LispFputs(Stdout, STRPTR(CAR(CAR(obj))));
LispFputs(Stdout, " deleted. Variable does not exist anymore.\n");
force = 1;
if (obj == prev) {
BRK = CDR(BRK);
goto watch_again;
}
else
RPLACD(prev, CDR(obj));
obj = prev;
}
else {
LispObj *cur = *(LispObj**)wat->data.opaque.data;
LispObj *val = CAR(CDR(CDR(CDR(CDR(CDR(CAR(obj)))))));
if (XEQUAL(val, cur) == NIL) {
long counter;
LispFputs(Stdout, "WATCH #");
LispFputs(Stdout, format_integer(FIXNUM_VALUE(CAR(CDR(CAR(obj))))));
LispFputs(Stdout, "> ");
LispFputs(Stdout, STRPTR(CAR(CAR(obj))));
LispFputc(Stdout, '\n');
LispFputs(Stdout, "OLD: ");
LispWriteObject(NIL, val);
LispFputs(Stdout, "\nNEW: ");
LispWriteObject(NIL, cur);
LispFputc(Stdout, '\n');
CAR(CDR(CDR(CDR(CDR(CDR(CAR(obj))))))) = cur;
counter = FIXNUM_VALUE(CAR(CDR(CDR(CDR(CAR(obj))))));
CAR(CDR(CDR(CDR(CAR(obj))))) = FIXNUM(counter + 1);
force = 1;
}
}
}
}
if (call == LispDebugCallWatch)
return;
}
switch (lisp__data.debug) {
case LispDebugUnspec:
LispDebuggerCommand(NIL);
goto debugger_done;
case LispDebugRun:
if (force)
LispDebuggerCommand(NIL);
goto debugger_done;
case LispDebugFinish:
if (!force &&
(call != LispDebugCallEnd ||
lisp__data.debug_level != lisp__data.debug_step))
goto debugger_done;
break;
case LispDebugNext:
if (call == LispDebugCallBegin) {
if (!force && lisp__data.debug_level != lisp__data.debug_step)
goto debugger_done;
}
else if (call == LispDebugCallEnd) {
if (!force && lisp__data.debug_level >= lisp__data.debug_step)
goto debugger_done;
}
break;
case LispDebugStep:
break;
}
if (call == LispDebugCallBegin) {
LispFputc(Stdout, '#');
LispFputs(Stdout, format_integer(lisp__data.debug_level));
LispFputs(Stdout, "> (");
LispWriteObject(NIL, CAR(CAR(DBG)));
LispFputc(Stdout, ' ');
LispWriteObject(NIL, CAR(CDR(CAR(DBG))));
LispFputs(Stdout, ")\n");
LispDebuggerCommand(NIL);
}
else if (call == LispDebugCallEnd) {
LispFputc(Stdout, '#');
LispFputs(Stdout, format_integer(lisp__data.debug_level + 1));
LispFputs(Stdout, "= ");
LispWriteObject(NIL, arg);
LispFputc(Stdout, '\n');
LispDebuggerCommand(NIL);
}
else if (force)
LispDebuggerCommand(arg);
debugger_done:
return;
}
static void
LispDebuggerCommand(LispObj *args)
{
LispObj *obj, *frm, *curframe;
int i = 0, frame, matches, action = -1, subaction = 0;
char *cmd, *arg, *ptr, line[256];
int envbase = lisp__data.stack.base,
envlen = lisp__data.env.length,
envlex = lisp__data.env.lex;
frame = lisp__data.debug_level;
curframe = CAR(DBG);
line[0] = '\0';
arg = line;
for (;;) {
LispFputs(Stdout, DBGPROMPT);
LispFflush(Stdout);
if (LispFgets(Stdin, line, sizeof(line)) == NULL) {
LispFputc(Stdout, '\n');
return;
}
ptr = line;
while (*ptr && isspace(*ptr))
++ptr;
cmd = ptr;
while (*ptr && !isspace(*ptr))
++ptr;
if (*ptr)
*ptr++ = '\0';
if (*cmd) {
while (*ptr && isspace(*ptr))
++ptr;
arg = ptr;
if (*ptr) {
while (*ptr)
++ptr;
--ptr;
while (*ptr && isspace(*ptr))
--ptr;
if (*ptr)
*++ptr = '\0';
}
}
if (*cmd == '\0') {
if (action < 0) {
if (lisp__data.debug == LispDebugFinish)
action = DebuggerFinish;
else if (lisp__data.debug == LispDebugNext)
action = DebuggerNext;
else if (lisp__data.debug == LispDebugStep)
action = DebuggerStep;
else if (lisp__data.debug == LispDebugRun)
action = DebuggerContinue;
else
continue;
}
}
else {
for (i = matches = 0; i < sizeof(commands) / sizeof(commands[0]);
i++) {
char *str = commands[i].name;
ptr = cmd;
while (*ptr && *ptr == *str) {
++ptr;
++str;
}
if (*ptr == '\0') {
action = commands[i].action;
if (*str == '\0') {
matches = 1;
break;
}
++matches;
}
}
if (matches == 0) {
LispFputs(Stdout, "* Command unknown: ");
LispFputs(Stdout, cmd);
LispFputs(Stdout, ". Type help for help.\n");
continue;
}
else if (matches > 1) {
LispFputs(Stdout, "* Command is ambiguous: ");
LispFputs(Stdout, cmd);
LispFputs(Stdout, ". Type help for help.\n");
continue;
}
}
switch (action) {
case DebuggerHelp:
LispFputs(Stdout, debugger_help);
break;
case DebuggerInfo:
if (*arg == '\0') {
LispFputs(Stdout, debugger_info_help);
break;
}
for (i = matches = 0;
i < sizeof(info_commands) / sizeof(info_commands[0]);
i++) {
char *str = info_commands[i].name;
ptr = arg;
while (*ptr && *ptr == *str) {
++ptr;
++str;
}
if (*ptr == '\0') {
subaction = info_commands[i].subaction;
if (*str == '\0') {
matches = 1;
break;
}
++matches;
}
}
if (matches == 0) {
LispFputs(Stdout, "* Command unknown: ");
LispFputs(Stdout, arg);
LispFputs(Stdout, ". Type info for help.\n");
continue;
}
else if (matches > 1) {
LispFputs(Stdout, "* Command is ambiguous: ");
LispFputs(Stdout, arg);
LispFputs(Stdout, ". Type info for help.\n");
continue;
}
switch (subaction) {
case DebuggerInfoBreakpoints:
LispFputs(Stdout, "Num\tHits\tType\t\tWhat\n");
for (obj = BRK; obj != NIL; obj = CDR(obj)) {
LispFputc(Stdout, '#');
LispWriteObject(NIL, CAR(CDR(CAR(obj))));
LispFputc(Stdout, '\t');
LispWriteObject(NIL, CAR(CDR(CDR(CDR(CAR(obj))))));
LispFputc(Stdout, '\t');
switch ((int)FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj)))))) {
case LispDebugBreakFunction:
LispFputs(Stdout, "Function");
break;
case LispDebugBreakVariable:
LispFputs(Stdout, "Variable");
break;
}
LispFputc(Stdout, '\t');
LispWriteObject(NIL, CAR(CAR(obj)));
LispFputc(Stdout, '\n');
}
break;
case DebuggerInfoBacktrace:
goto debugger_print_backtrace;
}
break;
case DebuggerAbort:
while (lisp__data.mem.level) {
--lisp__data.mem.level;
if (lisp__data.mem.mem[lisp__data.mem.level])
free(lisp__data.mem.mem[lisp__data.mem.level]);
}
lisp__data.mem.index = 0;
LispTopLevel();
if (!lisp__data.running) {
LispMessage("*** Fatal: nowhere to longjmp.");
abort();
}
siglongjmp(lisp__data.jmp, 1);
break;
case DebuggerBreak:
for (ptr = arg; *ptr; ptr++) {
if (isspace(*ptr))
break;
else
*ptr = toupper(*ptr);
}
if (!*arg || *ptr || strchr(arg, '(') || strchr(arg, '(') ||
strchr(arg, ';')) {
LispFputs(Stdout, "* Bad function name '");
LispFputs(Stdout, arg);
LispFputs(Stdout, "' specified.\n");
}
else {
for (obj = frm = BRK; obj != NIL; frm = obj, obj = CDR(obj))
;
i = lisp__data.debug_break;
++lisp__data.debug_break;
GCDisable();
obj = CONS(ATOM(arg),
CONS(FIXNUM(i),
CONS(FIXNUM(LispDebugBreakFunction),
CONS(FIXNUM(0), NIL))));
if (BRK == NIL)
BRK = CONS(obj, NIL);
else
RPLACD(frm, CONS(obj, NIL));
GCEnable();
}
break;
case DebuggerWatch: {
void *sym;
int vframe;
LispObj *val, *atom;
ptr = arg;
while (*ptr) {
*ptr = toupper(*ptr);
++ptr;
}
atom = ATOM(arg);
val = LispGetVar(atom);
if (val == NULL) {
LispFputs(Stdout, "* No variable named '");
LispFputs(Stdout, arg);
LispFputs(Stdout, "' in the selected frame.\n");
break;
}
sym = LispGetVarAddr(atom);
vframe = 0;
if (frame > 0) {
for (; vframe < frame; vframe++) {
for (frm = DBG, i = lisp__data.debug_level; i > vframe;
frm = CDR(frm), i--)
;
obj = CAR(frm);
lisp__data.stack.base = FIXNUM_VALUE(CAR(CDR(CDR(obj))));
lisp__data.env.length = FIXNUM_VALUE(CAR(CDR(CDR(CDR(obj)))));
lisp__data.env.lex = FIXNUM_VALUE(CDR(CDR(CDR(CDR(obj)))));
if (LispGetVarAddr(atom) == sym)
break;
}
vframe = i;
if (vframe != frame) {
for (frm = DBG, i = lisp__data.debug_level; i > frame;
frm = CDR(frm), i--)
;
obj = CAR(frm);
lisp__data.stack.base = FIXNUM_VALUE(CAR(CDR(CDR(obj))));
lisp__data.env.length = FIXNUM_VALUE(CAR(CDR(CDR(CDR(obj)))));
lisp__data.env.lex = FIXNUM_VALUE(CDR(CDR(CDR(CDR(obj)))));
}
}
i = lisp__data.debug_break;
++lisp__data.debug_break;
for (obj = frm = BRK; obj != NIL; frm = obj, obj = CDR(obj))
;
GCDisable();
obj = CONS(atom,
CONS(FIXNUM(i),
CONS(FIXNUM(LispDebugBreakVariable),
CONS(FIXNUM(0),
CONS(OPAQUE(sym, 0),
CONS(val,
CONS(FIXNUM(vframe),
NIL)))))));
if (BRK == NIL)
BRK = CONS(obj, NIL);
else
RPLACD(frm, CONS(obj, NIL));
GCEnable();
} break;
case DebuggerDelete:
if (*arg == 0) {
int confirm = 0;
for (;;) {
int ch;
LispFputs(Stdout, "* Delete all breakpoints? (y or n) ");
LispFflush(Stdout);
if ((ch = LispFgetc(Stdin)) == '\n')
continue;
while ((i = LispFgetc(Stdin)) != '\n' && i != EOF)
;
if (tolower(ch) == 'n')
break;
else if (tolower(ch) == 'y') {
confirm = 1;
break;
}
}
if (confirm)
BRK = NIL;
}
else {
for (ptr = arg; *ptr;) {
while (*ptr && isdigit(*ptr))
++ptr;
if (*ptr && !isspace(*ptr)) {
*ptr = '\0';
LispFputs(Stdout, "* Bad breakpoint number '");
LispFputs(Stdout, arg);
LispFputs(Stdout, "' specified.\n");
break;
}
i = atoi(arg);
for (obj = frm = BRK; frm != NIL;
obj = frm, frm = CDR(frm))
if (FIXNUM_VALUE(CAR(CDR(CAR(frm)))) == i)
break;
if (frm == NIL) {
LispFputs(Stdout, "* No breakpoint number ");
LispFputs(Stdout, arg);
LispFputs(Stdout, " available.\n");
break;
}
if (obj == frm)
BRK = CDR(BRK);
else
RPLACD(obj, CDR(frm));
while (*ptr && isspace(*ptr))
++ptr;
arg = ptr;
}
}
break;
case DebuggerFrame:
i = -1;
ptr = arg;
if (*ptr) {
i = 0;
while (*ptr && isdigit(*ptr)) {
i *= 10;
i += *ptr - '0';
++ptr;
}
if (*ptr) {
LispFputs(Stdout, "* Frame identifier must "
"be a positive number.\n");
break;
}
}
else
goto debugger_print_frame;
if (i >= 0 && i <= lisp__data.debug_level)
goto debugger_new_frame;
LispFputs(Stdout, "* No such frame ");
LispFputs(Stdout, format_integer(i));
LispFputs(Stdout, ".\n");
break;
case DebuggerDown:
if (frame + 1 > lisp__data.debug_level) {
LispFputs(Stdout, "* Cannot go down.\n");
break;
}
i = frame + 1;
goto debugger_new_frame;
break;
case DebuggerUp:
if (frame == 0) {
LispFputs(Stdout, "* Cannot go up.\n");
break;
}
i = frame - 1;
goto debugger_new_frame;
break;
case DebuggerPrint:
ptr = arg;
while (*ptr) {
*ptr = toupper(*ptr);
++ptr;
}
obj = LispGetVar(ATOM(arg));
if (obj != NULL) {
LispWriteObject(NIL, obj);
LispFputc(Stdout, '\n');
}
else {
LispFputs(Stdout, "* No variable named '");
LispFputs(Stdout, arg);
LispFputs(Stdout, "' in the selected frame.\n");
}
break;
case DebuggerBacktrace:
debugger_print_backtrace:
if (DBG == NIL) {
LispFputs(Stdout, "* No stack.\n");
break;
}
DBG = LispReverse(DBG);
for (obj = DBG, i = 0; obj != NIL; obj = CDR(obj), i++) {
frm = CAR(obj);
LispFputc(Stdout, '#');
LispFputs(Stdout, format_integer(i));
LispFputs(Stdout, "> (");
LispWriteObject(NIL, CAR(frm));
LispFputc(Stdout, ' ');
LispWriteObject(NIL, CAR(CDR(frm)));
LispFputs(Stdout, ")\n");
}
DBG = LispReverse(DBG);
break;
case DebuggerContinue:
lisp__data.debug = LispDebugRun;
goto debugger_command_done;
case DebuggerFinish:
if (lisp__data.debug != LispDebugFinish) {
lisp__data.debug_step = lisp__data.debug_level - 2;
lisp__data.debug = LispDebugFinish;
}
else
lisp__data.debug_step = lisp__data.debug_level - 1;
goto debugger_command_done;
case DebuggerNext:
if (lisp__data.debug != LispDebugNext) {
lisp__data.debug = LispDebugNext;
lisp__data.debug_step = lisp__data.debug_level + 1;
}
goto debugger_command_done;
case DebuggerStep:
lisp__data.debug = LispDebugStep;
goto debugger_command_done;
}
continue;
debugger_new_frame:
if (i != frame) {
frame = i;
for (frm = DBG, i = lisp__data.debug_level;
i > frame; frm = CDR(frm), i--)
;
curframe = CAR(frm);
lisp__data.stack.base = FIXNUM_VALUE(CAR(CDR(CDR(curframe))));
lisp__data.env.length = FIXNUM_VALUE(CAR(CDR(CDR(CDR(curframe)))));
lisp__data.env.lex = FIXNUM_VALUE(CDR(CDR(CDR(CDR(curframe)))));
}
debugger_print_frame:
LispFputc(Stdout, '#');
LispFputs(Stdout, format_integer(frame));
LispFputs(Stdout, "> (");
LispWriteObject(NIL, CAR(curframe));
LispFputc(Stdout, ' ');
LispWriteObject(NIL, CAR(CDR(curframe)));
LispFputs(Stdout, ")\n");
}
debugger_command_done:
lisp__data.stack.base = envbase;
lisp__data.env.length = envlen;
lisp__data.env.lex = envlex;
}
static char *
format_integer(int integer)
{
static char buffer[16];
sprintf(buffer, "%d", integer);
return (buffer);
}
#endif