187 lines
3.4 KiB
C
187 lines
3.4 KiB
C
/*************************************************************************
|
|
*
|
|
* lispTrace.c --
|
|
*
|
|
* This module manipulates the stack trace information used for
|
|
* error reporting.
|
|
*
|
|
* (c) 1996 California Institute of Technology
|
|
* Department of Computer Science
|
|
* Pasadena, CA 91125.
|
|
*
|
|
* Permission to use, copy, modify, and distribute this software
|
|
* and its documentation for any purpose and without fee is hereby
|
|
* granted, provided that the above copyright notice appear in all
|
|
* copies. The California Institute of Technology makes no representations
|
|
* about the suitability of this software for any purpose. It is
|
|
* provided "as is" without express or implied warranty. Export of this
|
|
* software outside of the United States of America may require an
|
|
* export license.
|
|
*
|
|
* $Header$
|
|
*
|
|
*************************************************************************/
|
|
|
|
|
|
#include <stdio.h>
|
|
#include "lisp/lisp.h"
|
|
#include "lispInt.h"
|
|
#include "textio/textio.h"
|
|
#include "utils/malloc.h"
|
|
|
|
|
|
typedef struct stack {
|
|
struct stack *n;
|
|
char *s;
|
|
struct stack *next;
|
|
} TRACE;
|
|
|
|
static TRACE *current = NULL;
|
|
|
|
static TRACE *freeQ = NULL;
|
|
|
|
static
|
|
TRACE *
|
|
StackNew ()
|
|
{
|
|
TRACE *t;
|
|
if (freeQ) {
|
|
t = freeQ;
|
|
freeQ = freeQ->n;
|
|
}
|
|
else {
|
|
t = (TRACE *) mallocMagic((unsigned) (sizeof(TRACE)));
|
|
}
|
|
t->n = NULL;
|
|
return t;
|
|
}
|
|
|
|
static
|
|
void
|
|
StackFree (t)
|
|
TRACE *t;
|
|
{
|
|
t->n = freeQ;
|
|
freeQ = t;
|
|
}
|
|
|
|
|
|
/*------------------------------------------------------------------------
|
|
*
|
|
* LispStackPush --
|
|
*
|
|
* Push a name onto the call stack.
|
|
*
|
|
* Results:
|
|
* none.
|
|
*
|
|
* Side effects:
|
|
* None.
|
|
*
|
|
*------------------------------------------------------------------------
|
|
*/
|
|
|
|
void
|
|
LispStackPush (name)
|
|
char *name;
|
|
{
|
|
TRACE *t;
|
|
t = StackNew();
|
|
t->s = name;
|
|
t->next = current;
|
|
current = t;
|
|
}
|
|
|
|
|
|
/*------------------------------------------------------------------------
|
|
*
|
|
* LispStackPop --
|
|
*
|
|
* Pop a frame off the evaluation stack.
|
|
*
|
|
* Results:
|
|
* none.
|
|
*
|
|
* Side effects:
|
|
* None.
|
|
*
|
|
*------------------------------------------------------------------------
|
|
*/
|
|
|
|
void
|
|
LispStackPop ()
|
|
{
|
|
TRACE *t;
|
|
t = current;
|
|
if (!current)
|
|
TxError ("Internal error!\n");
|
|
else {
|
|
current = current->next;
|
|
StackFree (t);
|
|
}
|
|
}
|
|
|
|
|
|
/*------------------------------------------------------------------------
|
|
*
|
|
* LispStackDisplay --
|
|
*
|
|
* Display call stack.
|
|
*
|
|
* Results:
|
|
* none.
|
|
*
|
|
* Side effects:
|
|
* text appears in window.
|
|
*
|
|
*------------------------------------------------------------------------
|
|
*/
|
|
|
|
void
|
|
LispStackDisplay ()
|
|
{
|
|
extern Sexp *LispMainFrame;
|
|
LispObj *l;
|
|
TRACE *t = current;
|
|
int i = 0;
|
|
int depth;
|
|
l = LispFrameLookup (LispNewString ("scm-stack-display-depth"),
|
|
LispMainFrame);
|
|
if (l && LTYPE(l) == S_INT)
|
|
depth = LINTEGER(l);
|
|
else
|
|
depth = 5;
|
|
if (depth > 0)
|
|
TxPrintf ("Stack trace:\n");
|
|
while (t && i < depth) {
|
|
i++;
|
|
TxPrintf ("\tcalled from: %s\n", t->s);
|
|
t = t->next;
|
|
}
|
|
if (i < depth)
|
|
TxPrintf ("\tcalled from: -top-level-\n");
|
|
}
|
|
|
|
|
|
/*------------------------------------------------------------------------
|
|
*
|
|
* LispStackClear --
|
|
*
|
|
* Clear the call stack.
|
|
*
|
|
* Results:
|
|
* none.
|
|
*
|
|
* Side effects:
|
|
* none.
|
|
*
|
|
*------------------------------------------------------------------------
|
|
*/
|
|
|
|
void
|
|
LispStackClear ()
|
|
{
|
|
while (current)
|
|
LispStackPop ();
|
|
}
|