/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/*****************************************************************************\
* *
* kldebug.c *
* collection of misc debug routines for klone, only callable when compiled *
* with -DDEBUG. Useful to be called under a C debugger (dbx, gdb, duel...) *
* *
\*****************************************************************************/
/* Functions available under a debugger:
*
*-----------------------------------------------------------------------------
* Functions running the klone engine:
* (will perturbate the malloc count and GC state)
*
* PO(obj) - print object
* calls the klone engine to print the object
* gdb: p PO(0x567bc)
* POR(obj) - print object readably
* same, but *print-readably* set
* gdb: p POR(0x567bc)
* POT(obj) - print object type
* prints the type of object
* KL(string) - execute klone text
* executes the klone string. Returns the last value.
* gdb: p KL("(load 'foo)")
* BT() - normal stack dump, just like in klone
* PSF(n) - print all stack frames verbosely
* (n=0) print top
* (n=-1) print whole, repeatedly
* (n=-N) print whole but only N frames from top
* (n=N) print from stack number N
*
*-----------------------------------------------------------------------------
* Pure C Functions (dont malloc and dont exercise the klone engine)
* P(obj) - prints object
* prints an extended description of the object *VERY USEFUL!!!
* can/should be extended to print nicely application-added types
* (see the P_app function)
* format:
* <adress> (type)r:<refcount><z=is_in_zrt> attributs....
* attributes:
* <name> for the name of atoms
* NAMED:, which is an atom having obj as value
* VAL: for the value of atoms
* NUM: value of numbers
* STRING: value of strings
* SIZE: size of lists, elements are listed oneper line underneath
* PN(string) - print named
* calls P of value of atom named string
* PS(n) - print stack
* like PSF, but dont run klone
* TN(type) - type name
* returns the C string of teh name of the type, or a message if it is not
* a type
* NO(obj) - name of
* prints the atoms having obj as value
* PT(obj) - Pointing To
* scans all possible places that can point to KlOs, and print what is
* pointing to obj, and prints discrepancies in ref count.
* Scans the whole malloc space, the stack, the symbol table, and
* application can add their scans (KlDoExtendedcheck and PT_app_malloc)
* and their types (PT_Aux_app)
*
* Valid(obj) - why isn't it a valid object???
* returns a string explaining the reason
*
* -----------------------------------------------------------------------------
* Functions to call in C code to trigger a stop in the debugger
*
* stop_if_in_dbx(string) - stops if under debugger
* with string being a comment. Ignored if not under a debugger
* KlCBreak - stops if under debugger
* (cbreak [non-evaluated-tag] [condition] [value])
* klone-callable of the above, with conditional stop
*
* -----------------------------------------------------------------------------
* Tracing:
*
* the klone active value "trace-all" and KlSetTrace C function triggers a brute
* force tracing that is obsolete but may be useful in difficult situations,
* where the klone kernel may be damaged
*/
/******************** definitions. this module is only compiled with -DDEBUG */
#include <stdio.h>
#include <sys/types.h>
#include <sys/file.h>
#include <sys/times.h>
#include <signal.h>
#include <sys/stat.h>
#ifdef SYSV
#include <unistd.h>
#endif
#include "EXTERN.h"
#include "klone.h"
#ifdef SYSV_STRINGS
#include <string.h>
#else
#include <strings.h>
#endif
#include <pwd.h>
#include "kl_atom.h"
#include "kl_coll.h"
#include "kl_list.h"
#include "kl_func.h"
#include "kl_number.h"
#include "kl_string.h"
#include "kl_hash.h"
#include "kl_stream.h"
#include "kl_struct.h"
#ifdef STATS
extern KlO zrtstats();
extern KlO KlCfstats();
#endif /* STATS */
#ifdef MALLOCDEBUG0
#define MALLOCDEBUG
#endif
#ifdef MALLOCDEBUG
extern KlO KlMDCheckKl();
#endif
#ifndef USE_STANDARD_MALLOC
extern char *KlMallocZoneBegin, *KlMallocZoneEnd;
#endif
DECLARE_strchr;
DECLARE_strrchr;
#ifdef DEBUG
KlO P();
/***************************************************************** functions */
KlSendIsValid(message, object)
int message;
KlO object;
{
static int count;
count++;
if (!object)
stop_if_in_dbx("NULL object!");
if (!KlObjectIsValid(object)) {
KlError1s(KlE_NON_KlO, KlSelectors[message].name);
if (!object->type[message])
stop_if_in_dbx("NULL method on object!");
}
}
/* "explanation" verbose function
* this is never called from klone, but you may want to call it from a
* debugger to see why KlObjectIsValid failed...
*/
char *
Valid(obj)
KlO obj;
{
KlType t;
if (!obj)
return "nil obj";
#ifdef DO_NOT_REDEFINE_MALLOC
# ifndef USE_STANDARD_MALLOC
else if (!KlOIsInMallocSpace(obj))
return "not in malloc space";
# endif /* !USE_STANDARD_MALLOC */
#else /* !DO_NOT_REDEFINE_MALLOC */
# ifndef USE_STANDARD_MALLOC
else if (((char *) obj) < KlMallocZoneBegin)
return "lower than malloc begin";
else if (((char *) obj) >= KlMallocZoneEnd)
return "higher than malloc end";
# endif /* !USE_STANDARD_MALLOC */
#endif /* DO_NOT_REDEFINE_MALLOC */
#ifndef USE_STANDARD_MALLOC
else if (*((void **) obj) == KlFREED_MAGIC_PTR)
return "already freed";
else if (*((void **) obj) == KlUNINIT_MAGIC_PTR)
return "allocated but not initialized";
#endif /* !USE_STANDARD_MALLOC */
else if ((t = obj->type) == 0)
return "type field is NULL";
#ifdef DO_NOT_REDEFINE_MALLOC
# ifndef USE_STANDARD_MALLOC
else if (!KlOIsInMallocSpace(t))
return "type not in malloc space";
# endif /* !USE_STANDARD_MALLOC */
#else /* !DO_NOT_REDEFINE_MALLOC */
#ifndef USE_STANDARD_MALLOC
else if (((char *) t) < KlMallocZoneBegin)
return "type lower than malloc begin";
else if (((char *) t) >= KlMallocZoneEnd)
return "type higher than malloc end";
# endif /* !USE_STANDARD_MALLOC */
#endif /* DO_NOT_REDEFINE_MALLOC */
#ifndef USE_STANDARD_MALLOC
else if (*((void **) t) == KlFREED_MAGIC_PTR)
return "type already freed";
else if (*((void **) t) == KlUNINIT_MAGIC_PTR)
return "type allocated but not initialized";
#endif /* !USE_STANDARD_MALLOC */
else if (KlTypeTypeGet(t) != KlTypeType)
return "type is not a klone type";
else
return "OK";
}
/*****************************************************************************\
* C Debugging (with gdb, dbx...) *
\*****************************************************************************/
/*ARGSUSED*/
stop_if_in_dbx(why)
char *why;
{
} /* used in dbx */
/* cbreak function
* will trigger a break under a C debugger (gdb, dbx), when the klone function
* (cbreak [non-evaluated-tag] [condition] [value]) is evaluated in klone
* cbreak will return first arg
*/
/*ARGSUSED*/
KlCBreakPoint(tag, value)
char *tag;
KlO value;
{}
#ifndef __INSIGHT__
_Insight_trap_error() {}
#endif
KlO
KlCBreak(argc, argv)
int argc;
KlString *argv;
{
KlO result;
char *tag = 0;
int condition = 1;
KlO value = 0;
if (argc)
result = KlSend_eval(argv[0]);
else
result = NIL;
if (argc > 0) {
if (KlIsAString(argv[0]))
tag = argv[0]->string;
else
tag = (char *) ((KlNumber)argv[0])->number;
}
if (argc > 1) {
value = KlSend_eval(argv[1]);
if (KlFalseP(value))
condition = 0;
}
if (argc > 2) {
value = KlSend_eval(argv[2]);
}
if (condition) {
KlCBreakPoint(tag, value);
}
return result;
}
/**************\
* jump-buffers *
\**************/
/* JBTable is a table of JBs
*/
typedef struct _JB {
struct _JB *next;
int *jmp;
jmp_buf buf;
} *JB;
static JB JBs;
/* KlJmpbufCheck
*/
KlJmpbufCheck(jmpbuf)
int *jmpbuf;
{
JB jb = JBs;
while (jb) {
if (jb->jmp == jmpbuf) {
if (bcmp(jmpbuf, jb->buf, sizeof(jmp_buf))) {
fprintf(stderr, "CORRUPTED Jump Buffer!\n");
stop_if_in_dbx("KlJmpbufCheck: corrupted buffer");
}
return;
}
jb = jb->next;
}
fprintf(stderr, "NO SUCH Jump Buffer!\n");
stop_if_in_dbx("KlJmpbufCheck: no buffer");
}
KlJmpbufAddCheck(jmpbuf)
int *jmpbuf;
{
JB jb = JBs;
while (jb) {
if (jb->jmp == jmpbuf) {
bcopy(jmpbuf, jb->buf, sizeof(jmp_buf));
return;
}
jb = jb->next;
}
jb = (JB) Calloc(sizeof(struct _JB), 1);
jb->next = JBs;
jb->jmp = jmpbuf;
bcopy(jmpbuf, jb->buf, sizeof(jmp_buf));
JBs = jb;
}
/************************************************************ user functions */
/* TN = Type Name
* from a type (pointer) returns name
*/
char *
TN(kltype)
KlType kltype;
{
KlType t;
for (t = KlTypes; t; t = KlTypeNext(t)) {
if (kltype == t) {
return KlTypeCName(t);
}
}
return "NOT A TYPE!";
}
/* PO: try to see if it is an object and print it if so
*/
int
PO(obj)
KlO obj;
{
if (!KlObjectIsValid(obj)) {
fprintf(stderr, "Non Klone Object: 0x%x\n", obj);
fflush(stderr);
return 0;
} else {
extern KlConstant KlA_StdoutOrig;
KlO tab[2];
int prv = KlPrintReadably;
tab[0] = obj;
tab[1] = KlSend_eval(KlA_StdoutOrig);
KlPrintReadably = 1;
KlWrite(2, &tab[0]);
KlPrintReadably = prv;
KlFlush(0);
return 1;
}
}
/* Name Of (no) gives p_name of atom pointing to */
char *
NO(obj)
KlO obj;
{
extern int KlHashTableSize;
extern KlAtom *KlAtomHashTable;
KlAtom *slot;
for (slot = KlAtomHashTable;
slot < KlAtomHashTable + KlHashTableSize;
slot++) {
if (*slot && (*slot)->c_val == obj) {
return((*slot)->p_name);
}
}
return 0;
}
/* application-extendable debug */
int (*KlDoExtendedcheck)() = 0;
int (*PT_aux_app)() = 0;
int (*P_app)() = 0;
int (*PT_app_malloc)() = 0;
int PT_count; /* should increment */
KlO PT_obj; /* should compare to */
int PT_where; /* 0=malloc, 1= stack, 2=klone, 3=app */
int PT_level = 0;
#define P_invalid(o, s) if (o) {puts(s);return obj;}
/* P: prints as usefully as possible, but without mallocing or executing code
*/
KlO
P(obj)
KlO obj;
{
char *name = NO(obj);
int add_newline = 1;
P_invalid(!obj, "<null pointer>");
#ifndef USE_STANDARD_MALLOC
P_invalid(obj == (KlO) KlFREED_MAGIC_PTR, "<freed pointer>");
P_invalid(obj == (KlO) KlUNINIT_MAGIC_PTR, "<un-initialized pointer>");
#endif /* !USE_STANDARD_MALLOC */
P_invalid(!(obj->type), "<null data>");
#ifndef USE_STANDARD_MALLOC
P_invalid(((void *)obj->type) == KlFREED_MAGIC_PTR, "<freed data>");
P_invalid(((void *)obj->type) == KlUNINIT_MAGIC_PTR, "<un-initialized data>");
#endif /* !USE_STANDARD_MALLOC */
printf("0x%x (%s)r:%d%s, ",
obj, KlTypeCName(obj->type), (obj->reference_count)/2,
(obj->reference_count)%2 ? "" : "z");
if ((name = NO(obj)) && name[0] != ':' /* dont print keywords */
&& obj != NIL && obj != TRU && obj != KlUndef /* () t *undefined* */
&& obj != (KlO) KlNilString) /* nil string */
printf("NAMED: %s ", name);
if (KlIsANumber(obj)) {
printf("NUM: %d", ((KlNumber)obj)->number);
} else if (KlIsAnAtom(obj)) {
KlO val = ((KlAtom)obj)->c_val;
printf("<%s> VAL: 0x%x", ((KlAtom)obj)->p_name,
((KlAtom)obj)->c_val);
if (val == NIL)
printf(" (NIL)");
else if (val == TRU)
printf(" (t)");
else if (val == KlUndef)
printf(" (*undefined*)");
else {
printf(" (%s)", KlTypeCName(val->type));
if (KlIsAString(val))
printf(" \"%s\"", ((KlString)val)->string);
if (KlIsANumber(val))
printf(" %d", ((KlNumber)val)->number);
}
} else if (KlIsAnAccessor(obj)) {
if (KlIsANamedSymbol(obj)) {
printf("ACCESSOR: <%s>", ((KlAtom)obj)->p_name);
} else {
if (obj->type == KlAccessorNumType) {
printf("Anonymous AccessorNum: field .%d of ",
((KlNumber)((KlAccessor) obj)->field)->number);
P(((KlAccessor) obj)->var);
} else {
printf("Anonymous Accessor: field .%s of ",
((KlAtom)((KlAccessor) obj)->field)->p_name);
P(((KlAccessor) obj)->var);
}
}
} else if (KlIsAString(obj)) {
if (obj != (KlO) KlNilString)
printf("STRING: \"%s\"", ((KlString)obj)->string);
else
printf("The NIL STRING: \"%s\"", ((KlString)obj)->string);
} else if (KlFalseP(obj)) {
if (obj == NIL)
printf("NIL");
else
printf("<empty>");
} else if (KlIsAList(obj)) {
int i;
printf("SIZE: %d, ELEMENTS:\n", ((KlList)obj)->size);
for (i = 0; i < ((KlList)obj)->size; i++) {
int j;
for (j = 0; j < PT_level; j++) printf(" ");
printf(" #%d: ", i);
PT_level++;
P(((KlList)obj)->list[i]);
PT_level--;
}
add_newline = 0;
} else if (KlIsAStructClass(obj)) {
printf("NAME: %s", ((KlStructClass)obj)->name->p_name);
} else if (KlIsAStruct(obj)) {
printf("CLASS: %s (0x%x), PTR: 0x%x",
((KlStruct)obj)->structclass->name->p_name,
((KlStruct)obj)->structclass,
((KlStruct)obj)->ptr);
} else if (KlIsABuiltInType(obj)) {
/* nothing else */
} else if (KlIsADeclaredType(obj->type)) {
if (P_app)
CFAPPLY(P_app, (obj));
} else {
puts("<non-KlO>");
}
if (add_newline)
printf("\n");
return obj;
}
int
KlIsADeclaredType(obj)
KlType obj;
{
KlType t;
for (t = KlTypes; t; t = KlTypeNext(t)) {
if (t == obj)
return 1;
}
return 0;
}
int
KlIsABuiltInType(obj)
KlO obj;
{
extern KlList KlListOfBuiltInTypes;
int i;
for (i = 0; i < KlListOfBuiltInTypes->size; i++) {
if (KlListOfBuiltInTypes->list[i] == (KlO) (obj->type))
return 1;
}
return 0;
}
/* PN: prints object named
*/
KlO
PN(name)
char *name;
{
KlAtom *slot = (KlAtom *) KlHashSlot(name);
if (slot && *slot) {
P((*slot)->c_val);
return (*slot)->c_val;
} else {
fprintf(stderr, "Non Defined symbol: %s\n", name);
return 0;
}
}
/*************************************** PT: prints objects pointing to objs */
/* this scans ALL allocated memory to find pointers to objecst, thus this is
* only avbailable if klone malloc is used
*/
#ifndef USE_STANDARD_MALLOC
#define PTB(type, slot) \
if (PT_obj == (KlO) ((type)obj)->slot) {PT_pointed_by(obj, KlSTROF(slot));}
PT_pointed_by(obj, slot_name)
KlO obj;
char *slot_name;
{
int j;
for (j = 0; j < PT_level; j++) printf(" ");
printf("=>Field: %s of: ", slot_name);
PT_level++;
P(obj);
PT_level--;
PT_count++;
}
int
PT_aux_malloc(obj, size, chunk_size)
KlO obj;
int size; /* malloced bytes or -frame */
int chunk_size; /* total of used bytes */
{
int i;
char N[20];
if (obj->type == KlAtomType
|| obj->type == KlConstantType
|| obj->type == KlKeywordType) {
PTB(KlAtom, p_list);
PTB(KlAtom, c_val);
} else if (obj->type == KlListType || obj->type == KlVectorType) {
for (i = 0; i < ((KlList)obj)->size; i++) {
if (PT_obj == (KlO) ((KlList)obj)->list[i]) {
sprintf(N, "#%d", i);
PT_pointed_by(obj, N);
}
}
} else if (obj->type == KlActiveType) {
PTB(KlAtom, p_list);
} else if (obj->type == KlKloneActiveType) {
PTB(KlAtom, p_list);
PTB(KlAtom, c_val);
PTB(KlKloneActive, get);
PTB(KlKloneActive, set);
} else if (obj->type == KlSymbolSlotType) {
PTB(KlSymbolSlot, symbol);
} else if (obj->type == KlExprType
|| obj->type == KlFExprType
|| obj->type == KlMExprType) {
for (i = 0; i < ((KlExpr)obj)->body_size; i++) {
if (PT_obj == ((KlExpr)obj)->body[i]) {
sprintf(N, "statement #%d", i);
PT_pointed_by(obj, N);
}
}
if (((KlExpr)obj)->arity) {
for (i = 0; i < ((KlExpr)obj)->arity; i++) {
if (PT_obj == (KlO) ((KlExpr)obj)->parameters[i]) {
sprintf(N, "parameter #%d", i);
PT_pointed_by(obj, N);
}
}
}
if (((KlExpr)obj)->lambdalist) {
KlKeyDecls pk = ((KlExpr)obj)->lambdalist->key;
KlO *p;
if (p = ((KlExpr)obj)->lambdalist->optionals) {
while (*p) {
if (PT_obj == (KlO) *p)
PT_pointed_by(obj, "optional parameter");
p++;
}
}
if (PT_obj == (KlO) ((KlExpr)obj)->lambdalist->rest)
PT_pointed_by(obj, "rest parameter");
if (PT_obj == (KlO) ((KlExpr)obj)->lambdalist->whole)
PT_pointed_by(obj, "whole parameter");
if (pk) {
while (pk->key) {
if (PT_obj == (KlO) pk->key)
PT_pointed_by(obj, "keyword");
if (PT_obj == (KlO) pk->init)
PT_pointed_by(obj, "keyword init");
pk++;
}
}
if (p = ((KlExpr)obj)->lambdalist->aux) {
while (*p) {
if (PT_obj == (KlO) *p)
PT_pointed_by(obj, "aux");
p++;
}
}
}
} else if (obj->type == KlStreamType
&& ((KlStream)obj)->subtype == KlStreamStringType) {
PTB(KlStreamString, klstring);
} else if (obj->type == KlQuotedExprType) {
PTB(KlQuotedExpr, expr);
} else if (obj->type == KlHashType) {
KlHash table = (KlHash) obj;
KlHashCell old_cell, cell;
for (i = 0; i < table->limit; i++) {
if (table->table[i]) {
cell = table->table[i];
do {
if (table->ref_counted & KlHashRefV)
if (PT_obj == (KlO) cell->object) {
sprintf(N, "value of cell 0x%x", cell);
PT_pointed_by(obj, N);
}
if (table->ref_counted & KlHashRefK)
if (PT_obj == (KlO) cell->key) {
sprintf(N, "vkey of cell 0x%x", cell);
PT_pointed_by(obj, N);
}
old_cell = cell;
cell = cell->next;
} while (cell);
}
}
} else if (obj->type == KlStructType) {
PTB(KlStruct, structclass);
} else if (obj->type == KlStructClassType) {
PTB(KlStructClass, name);
PTB(KlStructClass, slots);
} else if (obj->type == KlStructArrayType) {
} else {
if (PT_app_malloc)
CFAPPLY(PT_app_malloc, (obj, size));
/* non-refering objects */
/*
} else if (obj->type == KlTypeType) {
} else if (obj->type == KlAnyType) {
} else if (obj->type == KlLinkType) {
} else if (obj->type == KlProcessIdType) {
} else if (obj->type == KlSequenceType) {
} else if (obj->type == KlMagnitudeType) {
} else if (obj->type == KlNumberType) {
} else if (obj->type == KlIntType) {
} else if (obj->type == KlRealType) {
} else if (obj->type == KlStringType) {
} else if (obj->type == KlRegexpType) {
} else if (obj->type == KlFunctionType) {
} else if (obj->type == KlSubrType) {
} else if (obj->type == KlFSubrType) {
} else if (obj->type == KlCollectionType) {
} else if (obj->type == KlStructuredType) {
} else if (obj->type == KlGenericFunctionType) {
*/
}
}
int
PT_aux_stack(obj, frame, from)
KlO obj;
Int frame;
KlO from;
{
if (obj == PT_obj) {
PT_count++;
printf(" In stack frame %d, ", frame);
switch ((Int) KlStack[frame]) {
case KlSFID_normal: printf("(normal)");break;
case KlSFID_subr: printf("(subr)");break;
case KlSFID_catch: printf("(catch)");break;
case KlSFID_hook: printf("(hook)");break;
}
if (from) {
printf(" previous val of: ");
P(from);
} else {
printf(" as ref pointer\n");
}
}
}
int
PT(obj)
KlO obj;
{
extern int KlHashTableSize;
extern KlAtom *KlAtomHashTable;
KlAtom *slot;
if (!KlObjectIsValid(obj))
return -1;
PT_count = 0;
PT_obj = obj;
PT_where = 0;
PT_level = 0;
for (slot = KlAtomHashTable; /* symbol table */
slot < KlAtomHashTable + KlHashTableSize;
slot++) {
if (*slot == (KlAtom) PT_obj) {
PT_count++;
printf(" from symbol table, slot 0x%x\n", slot);
}
}
KlDoMallocBlocks(PT_aux_malloc); /* malloced objects */
PT_where = 1;
KlDoStackFramePointedObs(PT_aux_stack); /* stack */
PT_where = 3;
if (KlDoExtendedcheck) /* application-specific places */
CFAPPLY(KlDoExtendedcheck, (PT_aux_app));
/* returns count of found objects */
if (obj->reference_count/2 > PT_count)
printf("Warning: could not explain %d references\n",
obj->reference_count/2 - PT_count);
if (obj->reference_count/2 < PT_count)
printf("Warning: number of references less by %d of object count!\n",
PT_count - obj->reference_count/2);
return PT_count;
}
/*************************************************************** check lists */
/* checks the validity of list elements */
void CL_aux_malloc();
void CL_aux_stack();
int CL_result;
int /* return 0 if OK */
CL()
{
CL_result = 0;
KlDoMallocBlocks(CL_aux_malloc); /* malloced objects */
KlDoStackFramePointedObs(CL_aux_stack);
return CL_result;
}
void
CL_aux(obj)
KlO obj;
{
int i;
if (obj->type && (obj->type == KlListType || obj->type == KlVectorType)) {
for (i = 0; i < ((KlList)obj)->size; i++) {
KlO elt = (KlO) ((KlList)obj)->list[i];
if (elt) { /* null elts are OK in lists */
if (!KlObjectIsValid(elt)) {
fprintf(stderr, "Element at index %d in list %x0x is invalid, reason: %s\n",
i, obj, Valid(elt));
CL_result++;
stop_if_in_dbx("CL: invalid");
}
}
}
}
}
void
CL_aux_malloc(obj, size, chunk_size)
KlO obj;
int size; /* malloced bytes or -frame */
int chunk_size; /* total of used bytes */
{
CL_aux(obj);
}
void
CL_aux_stack(obj, frame, from)
KlO obj;
Int frame;
KlO from;
{
CL_aux(obj);
}
#endif /* !USE_STANDARD_MALLOC */
/* POR: PO with print-readably set
*/
int
POR(obj)
KlO obj;
{
int stackptr = KlStackPtr;
int result;
KlStackFramePush(1, &KlA_print_readably, NIL, NIL);
KlSend_setq(KlA_print_readably, TRU);
result = PO(obj);
KlStackFramePopNormal(stackptr);
return result;
}
/* POT: try to see if it is an object and print its type if so
*/
int
POT(obj)
KlO obj;
{
if (!KlObjectIsValid(obj)) {
char buffer[1000];
sprintf(buffer, "Non Klone Object: 0x%x\n", obj);
KlPuts(buffer);
KlFlush(0);
return 0;
} else {
KlPuts(KlTypeCName(obj->type));
KlFlush(0);
return 1;
}
}
KlO
KL(string)
char *string;
{
return KlExecuteString(string);
}
/*****************************************************************************\
* stack dump *
\*****************************************************************************/
/* a klone stack dump in C. convenient function to be called from C debuggers
*/
extern int KlShowDebuggerStack;
BT()
{
int odsds = !KlShowDebuggerStack;
Int sp = KlStackPtr;
KlList res;
int ptr;
int actual_ptr;
KlO call;
KlO *vars;
int next_ptr;
int varsize;
int i;
KlShowDebuggerStack = 1;
while ((next_ptr =
KlStackFrameInfo(sp, &call, &actual_ptr, &vars, &varsize))
!= -1) {
printf("[%d]0x%x: ", sp, call);
POR(call);
puts("");
for (i = 0; i < varsize / 2; i+=2) {
printf(" | ");
PO(vars[i]);
printf(" = ");
PO(KlSend_eval(vars[i]));
printf("(");
POT(KlSend_eval(vars[i]));
printf(") WAS: ");
POR(vars[i+1]);
puts("");
}
sp = next_ptr;
}
KlShowDebuggerStack = !odsds;
}
/******************************************* print-stack-frame from debugger */
/* PSF(0) print top
* PSF(-1) print whole, repeatedly
* PSF(-N) print whole but only N frames from top
* PSF(N) print from stack number N
*/
static int PSF_dont_run_klone;
char *
PSF_id_print(id)
int id;
{
static char tmp[1024], *p = tmp;
if (id & KlSFID_normal) p = stpcpy(p, "|KlSFID_normal");
if (id & KlSFID_subr) p = stpcpy(p, "|KlSFID_subr");
if (id & KlSFID_catch) p = stpcpy(p, "|KlSFID_catch");
if (id & KlSFID_hook) p = stpcpy(p, "|KlSFID_hook");
if (id & KlSFIM_call) p = stpcpy(p, "|KlSFIM_call");
if (id & KlSFIM_listable) p = stpcpy(p, "|KlSFIM_listable");
*p = '\0';
if (p != tmp)
return tmp+1;
else
return tmp;
}
KlO
PSF_call(ptr)
int ptr;
{
KlO call;
if ((Int) (KlStack[ptr]) & KlSFIM_call) { /* Expr */
call = KlStack[ptr - KlSFO_call];
} else { /* Subr */
call = 0;
}
return call;
}
char *
PSF_print_item(o)
KlO o;
{
if (PSF_dont_run_klone) {
P(o);
} else {
char ad[80];
KlO arg[10];
char *res;
sprintf(ad, "0x%x", o);
arg[0] = (KlO) KlStringType;
arg[1] = (KlO) KlStringMake("%n0: %l1");
arg[2] = (KlO) KlStringMake(ad);
arg[3] = o;
res = ((KlString) KlPrintFormat(4, arg))->string;
if (strlen(res) > 70) {
res[69] = '|';
res[70] = '\0';
}
return res;
}
}
PSF_body(n)
int n;
{
int numprinted = (n >=0 ? 1 : (n < -1 ? -n : 1 << 30));
int ptr = (n <= 0 ? KlStackPtr : n);
KlO call;
for ( ; numprinted; numprinted--) {
if (ptr <= 0) return;
printf("**Frame@[%d]: %d = %s, previous %d",
ptr, KlStack[ptr], PSF_id_print(KlStack[ptr]),
KlStackFramePrevious(ptr));
if (((Int) (KlStack[ptr]) & KlSFIM_call)
&& (call = PSF_call(ptr)))
printf("\n Call: %s", PSF_print_item(call));
printf("\n");
/* normal */
if ((Int) (KlStack[ptr]) & KlSFID_normal) { /* print vars */
KlO *vars = KlStack + ((Int) (KlStack[ptr - KlSFO_previous])) + 1;
int varsize = ptr - KlSFS_normal -
(Int) (KlStack[ptr - KlSFO_previous]);
int i;
for (i = 0; i < varsize; i ++) {
printf(" [%d] %s\n", i, PSF_print_item(vars[i]));
}
}
/* catch */
if ((Int) (KlStack[ptr]) & KlSFID_catch) {
UnwindPoint up = (UnwindPoint) (KlStack[ptr - KlSFO_catch]);
if (up->tag) { /* catch */
printf(" Catch tag: %s\n", PSF_print_item(up->tag));
} else {
printf(" Unwind-protect catchpoint\n");
}
}
ptr = KlStackFramePrevious(ptr);
}
}
PSF(n)
int n;
{
PSF_dont_run_klone = 0;
PSF_body(n);
}
PS(n)
int n;
{
PSF_dont_run_klone = 1;
PSF_body(n);
}
KlO
PSFKl(n)
KlNumber n;
{
KlMustBeNumber(n, 0);
PSF(n->number);
return NIL;
}
#ifdef DEBUG2
/*****************************************************************************\
* tracing *
\*****************************************************************************/
/* this is obsolete and has been replaced by a klone function
* implemented on eval-hook... but when all goes wrong, this is simpler
* and may be useful...
*/
/* tracing info
*/
KlO
KlAtomEvalAndTrace(obj)
KlAtom obj;
{
KlO result;
if (KlTracingOn) {
KlPutSpaces(KlStackFramePtrToNumber(KlStackPtr));
KlPuts("=| ");
KlPrint(obj);
KlPuts(" => ");
}
result = KlAtomEval(obj);
if (KlTracingOn) {
KlPrint(result);
KlPuts("\n");
}
return result;
}
KlO
KlActiveEvalAndTrace(obj)
KlActive obj;
{
KlO result;
if (KlTracingOn) {
KlPutSpaces(KlStackFramePtrToNumber(KlStackPtr));
KlPuts("=| ");
KlPrint(obj);
KlPuts(" => ");
}
result = KlActiveEval(obj);
if (KlTracingOn) {
KlPrint(result);
KlPuts("\n");
}
return result;
}
/*
* KlListEvalAndTrace: same with tracing
*/
KlO
KlListEvalAndTrace(obj)
KlList obj;
{
KlO result;
int tracing_level = KlStackFramePtrToNumber(KlStackPtr);
if (KlTracingOn) {
KlPutSpaces(tracing_level);
KlPuts("-> ");
KlPrint(obj);
KlPuts("\n");
if (KlTracingOnEXPR) {
KlTracingOn = 0;
KlSend_eval(KlTracingOnEXPR);
KlTracingOn = 1;
}
}
result = KlListEval(obj);
if (KlTracingOn) {
if (KlTracingOnEXPR) {
KlTracingOn = 0;
KlSend_eval(KlTracingOnEXPR);
if (KlStillTracing)
KlTracingOn = 1;
else
KlStillTracing = 1;
}
KlPutSpaces(tracing_level);
KlPuts("<- ");
KlPrint(result);
KlPuts("\n");
}
return result;
}
/*ARGSUSED*/
KlO
KlGetTrace(o)
KlO o;
{
return (KlO) KlNumberMake(KlTracingOn);
}
/* (trace obj)
* obj = expr, evals expr at each eval of list
* obj = 0/1 turns tracing on/off (without resetting expr)
* obj = t resets expr
*/
/*ARGSUSED*/
KlO
KlSetTrace(obj, o)
KlO obj;
KlO o;
{
if (KlIsAnInteger(obj)) {
KlTracingOn = ((KlNumber) obj)->number;
KlListType[KlSelEval] = KlListEvalAndTrace;
KlAtomType[KlSelEval] = KlAtomEvalAndTrace;
KlConstantType[KlSelEval] = KlAtomEvalAndTrace;
KlActiveType[KlSelEval] = KlActiveEvalAndTrace;
} else if (obj == NIL) {
KlTracingOn = 0;
KlListType[KlSelEval] = KlListEval;
KlAtomType[KlSelEval] = KlAtomEval;
KlConstantType[KlSelEval] = KlAtomEval;
KlActiveType[KlSelEval] = KlActiveEval;
} else {
KlTracingOn = 1;
KlListType[KlSelEval] = KlListEvalAndTrace;
KlAtomType[KlSelEval] = KlAtomEvalAndTrace;
KlConstantType[KlSelEval] = KlAtomEvalAndTrace;
KlActiveType[KlSelEval] = KlActiveEvalAndTrace;
KlDecRef(KlTracingOnEXPR);
if (obj == TRU)
KlTracingOnEXPR = 0;
else
KlIncRef(KlTracingOnEXPR = obj);
}
KlStillTracing = KlTracingOn;
return obj;
}
KlPutSpaces(n)
int n;
{
char tmp[10];
sprintf(tmp, "%%-%dd", n);
KlPrintf(tmp, n);
}
/* prints logical stack frame number */
int
KlStackFramePtrToNumber(ptr)
int ptr;
{
int number = 0;
while (ptr) {
if ((Int) (KlStack[ptr]) & KlSFID_normal) {
ptr = (Int) (KlStack[ptr - KlSFO_previous]);
} else {
ptr -= KlSFS_special;
}
number++;
}
return number;
}
#endif /* DEBUG2 */
/************************************************************* end of module */
#endif /* DEBUG */
syntax highlighted by Code2HTML, v. 0.9.1