/* 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 */