debugger.c

Branch :
Show log
Commit
Author : matthieu
Date : 2015-05-10 10:07:47
Hash : 99a72825
Message : Update to xedit 1.2.2
app/xedit/lisp/debugger.c
/*
 * Copyright (c) 2001 by The XFree86 Project, Inc.
 *
 * Permission is hereby granted, free of charge, to any person obtaining a
 * copy of this software and associated documentation files (the "Software"),
 * to deal in the Software without restriction, including without limitation
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 * and/or sell copies of the Software, and to permit persons to whom the
 * Software is furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *  
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 * SOFTWARE.
 *
 * Except as contained in this notice, the name of the XFree86 Project shall
 * not be used in advertising or otherwise to promote the sale, use or other
 * dealings in this Software without prior written authorization from the
 * XFree86 Project.
 *
 * Author: Paulo César Pereira de Andrade
 */

/* $XFree86: xc/programs/xedit/lisp/debugger.c,v 1.24tsi Exp $ */

#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

/*
 * Prototypes
 */
static char *format_integer(int);
static void LispDebuggerCommand(LispObj *obj);

/*
 * Initialization
 */
static struct {
    const char *name;
    int action;
} const 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 {
    const char *name;
    int subaction;
} const info_commands[] = {
    {"breakpoints",	DebuggerInfoBreakpoints},
    {"stack",		DebuggerInfoBacktrace},
    {"watchpoints",	DebuggerInfoBreakpoints},
};

static const 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 const 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";

/* Debugger variables layout (if you change it, update description):
 *
 * DBG
 *	is a macro for lisp__data.dbglist
 *	is a NIL terminated list
 *	every element is a list in the format (NOT NIL terminated):
 *	(list* NAM ARG ENV HED LEX)
 *	where
 *		NAM is an ATOM for the function/macro name
 *		    or NIL for lambda expressions
 *		ARG is NAM arguments (a LIST)
 *		ENV is the value of lisp__data.stack.base (a FIXNUM)
 *		LEN is the value of lisp__data.env.length (a FIXNUM)
 *		LEX is the value of lisp__data.env.lex (a FIXNUM)
 *	new elements are added to the beggining of the DBG list
 *
 * BRK
 *	is macro for lisp__data.brklist
 *	is a NIL terminated list
 *	every element is a list in the format (NIL terminated):
 *	(list NAM IDX TYP HIT VAR VAL FRM)
 *	where
 *		NAM is an ATOM for the name of the object at
 *		    wich the breakpoint was added
 *		IDX is a FIXNUM, the breakpoint number
 *		    must be stored, as breakpoints may be deleted
 *		TYP is a FIXNUM that must be an integer of enum LispBreakType
 *		HIT is a FIXNUM, with the number of times this breakpoint was
 *		    hitted.
 *		VAR variable to watch a SYMBOL	(not needed for breakpoints)
 *		VAL value of watched variable	(not needed for breakpoints)
 *		FRM frame where variable started being watched
 *						(not needed for breakpoints)
 *	new elements are added to the end of the list
 */

/*
 * Implementation
 */
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 not at a fresh line */
		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;
		/* update hits counter */
		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;
    }

    /* didn't return, check watchpoints */
    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) {
		/* the variable */
		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 debugger to stop */
		    force = 1;
		    if (obj == prev) {
			BRK = CDR(BRK);
			goto watch_again;
		    }
		    else
			RPLACD(prev, CDR(obj));
		    obj = prev;
		}
		else {
		    /* current value */
		    LispObj *cur = *(LispObj**)wat->data.opaque.data;
		    /* last value */
		    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');

			/* update current value */
			CAR(CDR(CDR(CDR(CDR(CDR(CAR(obj))))))) = cur;
			/* update hits counter */
			counter = FIXNUM_VALUE(CAR(CDR(CDR(CDR(CAR(obj))))));
			CAR(CDR(CDR(CDR(CAR(obj))))) = FIXNUM(counter + 1);
			/* force debugger to stop */
			force = 1;
		    }
		}
	    }
	}

	if (call == LispDebugCallWatch)
	    /* special call, just don't keep gc protected variables that may be
	     * using a lot of memory... */
	    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;
	}
	/* get command */
	ptr = line;
	while (*ptr && isspace(*ptr))
	    ++ptr;
	cmd = ptr;
	while (*ptr && !isspace(*ptr))
	    ++ptr;
	if (*ptr)
	    *ptr++ = '\0';

	if (*cmd) {	/* if *cmd is nul, then arg may be still set */
	    /* get argument(s) */
	    while (*ptr && isspace(*ptr))
		++ptr;
	    arg = ptr;
	    /* goto end of line */
	    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++) {
		const 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++) {
		    const 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)) {
			    /* breakpoint number */
			    LispFputc(Stdout, '#');
			    LispWriteObject(NIL, CAR(CDR(CAR(obj))));

			    /* number of hits */
			    LispFputc(Stdout, '\t');
			    LispWriteObject(NIL, CAR(CDR(CDR(CDR(CAR(obj))))));

			    /* breakpoint type */
			    LispFputc(Stdout, '\t');
			    switch ((int)FIXNUM_VALUE(CAR(CDR(CDR(CAR(obj)))))) {
				case LispDebugBreakFunction:
				    LispFputs(Stdout, "Function");
				    break;
				case LispDebugBreakVariable:
				    LispFputs(Stdout, "Variable");
				    break;
			    }

			    /* breakpoint object */
			    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();
		}
		/* don't need to restore environment */
		siglongjmp(lisp__data.jmp, 1);
		/*NOTREACHED*/
		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;

		/* make variable name uppercase, an 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;
		}

		/* variable is available at the current frame */
		sym = LispGetVarAddr(atom);

		/* find the lowest frame where the variable is visible */
		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)
			    /* got variable initial frame */
			    break;
		    }
		    vframe = i;
		    if (vframe != frame) {
			/* restore environment */
			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,					/* NAM */
			   CONS(FIXNUM(i),				/* IDX */
				CONS(FIXNUM(LispDebugBreakVariable),	/* TYP */
				     CONS(FIXNUM(0),			/* HIT */
					  CONS(OPAQUE(sym, 0),		/* VAR */
					       CONS(val,		/* VAL */
						    CONS(FIXNUM(vframe),/* FRM */
							      NIL)))))));

		/* add watchpoint */
		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:
	/* goto here with i as the new frame value, after error checking */
	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 /* DEBUGGER */
IABSD.fr/xenocara/app/xedit/lisp/debugger.c

Commit

IABSD.fr/xenocara /app/xedit/lisp/debugger.c
