github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-01-14 07:30:21 +00:00
Code Issues Projects Releases Wiki Activity
Interlisp.maiko/src/testtool.c

1307 lines
38 KiB
C
Raw Blame History

/* $Id: testtool.c,v 1.4 2001/12/24 01:09:07 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved
*/
/************************************************************************/
/* */
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
/* Manufactured in the United States of America. */
/* */
/************************************************************************/
#include "version.h"
/***************************************************************/
/*
file name : testtool.c
For Debugging Aids
Including :
dump_check_atoms()
print_atomname(index)
dump_dtd()
check_type_68k(type,ptr)
type_num(LISPPTR)
dump_conspage(base , linking )
trace_listpDTD()
a68k( lispptr)
laddr(addr68k)
dump_fnobj(index)
dump_fnbody(lisp-codeaddr)
doko()
dumpl(laddr)
ptintPC()
all_stack_dump(start,end)
date : 14 May 1987 takeshi
15 May 1987 take
1 June 1987 take
21 June 1987 NMitani
9 Sep. 1987 take
*/
#include <stdint.h>
#include <inttypes.h>
#include <stdio.h>
#include <stdlib.h>
#include <setjmp.h>
#include <string.h>
#include "lispemul.h"
#include "lispmap.h"
#include "adr68k.h"
#include "lsptypes.h"
#include "lspglob.h"
#include "emlglob.h"
#include "cell.h"
#include "ifpage.h"
#include "debug.h"
#include "dbprint.h"
#include "tosfns.h"
#include "array.h"
#include "commondefs.h"
#include "testtooldefs.h"
#include "dbgtooldefs.h"
#include "gcarraydefs.h"
#include "kprintdefs.h"
#include "mkatomdefs.h"
#define URMAXFXNUM 100
#define URSCAN_ALINK 0
#define URSCAN_CLINK 1
extern int URaid_scanlink;
extern int URaid_currentFX;
extern FX *URaid_FXarray[];
extern int URaid_ArrMAXIndex;
/************************************************************************/
/* */
/* P R I N T _ A T O M N A M E */
/* */
/* Given the Atom # for an atom, print the atom's name. */
/* */
/************************************************************************/
void print_atomname(LispPTR index)
/* atomindex */
{
char *pname;
DLword length;
PNCell *pnptr;
pnptr = (PNCell *)GetPnameCell(index);
print_package_name(pnptr->pkg_index);
pname = (char *)Addr68k_from_LADDR(pnptr->pnamebase);
length = (DLword)GETBYTE(pname++);
while (length > 0) {
putchar(GETBYTE(pname++));
length--;
}
} /* end print_atomname */
/************************************************************************/
/* */
/* F I N D _ P A C K A G E _ F R O M _ N A M E */
/* */
/************************************************************************/
int find_package_from_name(const char *packname, int len) {
int index;
PACKAGE *package;
NEWSTRINGP *namestring;
DLword len2;
char *pname;
struct arrayheader *pi_array;
/* assumes the *PACKAGE-FROM-INDEX* array is simple with no offset */
pi_array = (struct arrayheader *)Addr68k_from_LADDR(*Package_from_Index_word);
for (index = 1; index < pi_array->totalsize; index++) {
package = (PACKAGE *)Addr68k_from_LADDR(aref1(*Package_from_Index_word, index));
namestring = (NEWSTRINGP *)Addr68k_from_LADDR(package->NAME);
pname = (char *)Addr68k_from_LADDR(namestring->base);
if (namestring->offset != 0) { pname += namestring->offset; }
len2 = (DLword)(namestring->fillpointer);
if (len == len2) {
if (compare_chars(pname, packname, len) == T) { return (index); }
}
} /* for end */
return (-1);
}
/************************************************************************/
/* */
/* P R I N T _ P A C K A G E _ N A M E */
/* */
/************************************************************************/
void print_package_name(int index) {
PACKAGE *package;
NEWSTRINGP *namestring;
DLword len;
char *pname;
if (index == 0) {
printf("#:");
return;
}
package = (PACKAGE *)Addr68k_from_LADDR(aref1(*Package_from_Index_word, index));
namestring = (NEWSTRINGP *)Addr68k_from_LADDR(package->NAME);
pname = (char *)Addr68k_from_LADDR(namestring->base);
if (namestring->offset != 0) {
pname += namestring->offset;
printf("OFFSET:\n");
}
len = (DLword)(namestring->fillpointer);
if (compare_chars(pname, "INTERLISP", len) == T) {
printf("IL:");
return;
} else if (compare_chars(pname, "LISP", len) == T) {
printf("CL:");
return;
} else if (compare_chars(pname, "XEROX-COMMON-LISP", len) == T) {
printf("XCL:");
return;
} else if (compare_chars(pname, "SYSTEM", len) == T) {
printf("SI:");
return;
} else if (compare_chars(pname, "KEYWORD", len) == T) {
printf(":");
return;
} else if (compare_chars(pname, "COMPILER", len) == T) {
printf("XCLC:");
return;
} else {
while (len > 0) {
putchar(GETBYTE(pname++));
len--;
}
putchar(':');
return;
}
} /*print_package_name */
/************************************************************************/
/* */
/* d u m p _ d t d */
/* */
/* */
/* */
/************************************************************************/
void dump_dtd(void) {
extern DLword *DTDspace;
struct dtd *dtdp;
DLword cnt;
dtdp = (struct dtd *)DTDspace;
dtdp++;
for (cnt = 0; cnt < INIT_TYPENUM; cnt++) {
printf("DTD[ %d ] for ", cnt + 1);
#ifdef BIGVM
print_atomname(dtdp->dtd_name);
#else
print_atomname(dtdp->dtd_namelo + (dtdp->dtd_namehi << 16));
#endif /* BIGVM */
putchar('\n');
#ifdef BIGVM
printf(" dtd_name = %d\n", dtdp->dtd_name);
#else
printf(" dtd_name = %d\n", dtdp->dtd_namelo + (dtdp->dtd_namehi << 16));
#endif /* BIGVM */
printf(" dtd_size = %d\n", dtdp->dtd_size);
printf(" dtd_free = %d\n", dtdp->dtd_free);
printf(" dtd_obsolate = %d\n", dtdp->dtd_obsolate);
printf(" dtd_finalizable = %d\n", dtdp->dtd_finalizable);
printf(" dtd_lockedp = %d\n", dtdp->dtd_lockedp);
printf(" dtd_hunkp = %d\n", dtdp->dtd_hunkp);
printf(" dtd_gctype = %d\n", dtdp->dtd_gctype);
printf(" dtd_descrs = %d\n", dtdp->dtd_descrs);
printf(" dtd_typespecs = %d\n", dtdp->dtd_typespecs);
printf(" dtd_ptrs = %d\n", dtdp->dtd_ptrs);
printf(" dtd_oldcnt = %d\n", dtdp->dtd_oldcnt);
printf(" dtd_cnt0 = %d\n", dtdp->dtd_cnt0);
printf(" dtd_nextpage = %d\n", dtdp->dtd_nextpage);
printf(" dtd_typeentry = 0x%x\n", dtdp->dtd_typeentry);
printf(" dtd_supertype = %d\n", dtdp->dtd_supertype);
dtdp++;
}
} /* end dump dtd */
/************************************************************************/
/* */
/* c h e c k _ t y p e _ 6 8 k */
/* */
/* Check that the lisp pointer ptr is of type type, then */
/* print a message showing the type number. */
/* */
/************************************************************************/
void check_type_68k(int type, LispPTR *ptr) {
if (type != (GetTypeNumber(LADDR_from_68k(ptr)))) {
printf("Mismatching occur !!! LispAddr 0x%x type %d\n", LADDR_from_68k(ptr), type);
exit(-1);
}
printf("LispPTR 0x%x is the datatype %d\n", LADDR_from_68k(ptr),
GetTypeNumber(LADDR_from_68k(ptr)));
}
/************************************************************************/
/* */
/* t y p e _ n u m */
/* */
/* Given a lisp pointer, return its type number. */
/* */
/************************************************************************/
int type_num(LispPTR lispptr) {
int type;
type = GetTypeNumber(lispptr);
printf("LispPTR 0x%x is datatype %dth\n", lispptr, type);
return (type);
}
/************************************************************************/
/* */
/* d u m p _ c o n s p a g e */
/* */
/* Print information about a CONS page, and the cells in it. */
/* */
/************************************************************************/
void dump_conspage(struct conspage *base, int linking)
/* target conspage address */
/* look for chaining conspage ? T/NIL */
{
ConsCell *cell;
int i;
lp:
printf(
"conspage at 0x%x(lisp) has %d free cells , next available cell offset is %d ,and next page "
"is 0x%x(lisp)\n",
LADDR_from_68k(base), (0xff & base->count), (0xff & base->next_cell), base->next_page);
for (i = 0, cell = (ConsCell *)base + 1; i < 127; i++, cell++) {
printf(" LADDR : %d = Cell[ %d ]## cdr_code= %d ,car = %d\n", LADDR_from_68k(cell), i + 1,
cell->cdr_code, cell->car_field);
}
if ((linking == T) && (base->next_page != NIL_PTR)) {
base = (struct conspage *)Addr68k_from_LPAGE(base->next_page);
goto lp;
}
} /* end dump_conspage */
/*********************************/
/* trace the link in ListpDTD->dtd_nextpage */
void trace_listpDTD(void) {
extern struct dtd *ListpDTD;
printf("Dump conspages from ListpDTD chain\n");
dump_conspage((struct conspage *)Addr68k_from_LPAGE(ListpDTD->dtd_nextpage), T);
}
/************************************************************************/
/* */
/* a 6 8 k */
/* */
/* Given a lisp pointer, print the corresponding native address. */
/* */
/************************************************************************/
void a68k(LispPTR lispptr) {
DLword *val;
val = Addr68k_from_LADDR(lispptr);
printf("68k: %p (%"PRIuPTR")\n", (void *)val, (uintptr_t)val);
}
/************************************************************************/
/* */
/* l a d d r */
/* */
/* Given a native address, print the corresponding lisp ptr. */
/* */
/************************************************************************/
void laddr(DLword *addr68k) {
int val;
val = LADDR_from_68k(addr68k);
printf("LADDR : 0x%x (%d)\n", val, val);
}
/************************************************************************/
/* */
/* d u m p _ f n b o d y */
/* */
/* Given the (Lisp) address of a function header, dump the */
/* function's definition. */
/* */
/************************************************************************/
void dump_fnbody(LispPTR fnblockaddr)
/* atom index */
{
struct fnhead *fnobj;
DLbyte *scratch;
int i;
fnobj = (struct fnhead *)Addr68k_from_LADDR(fnblockaddr);
printf("***DUMP Func Obj << ");
printf("start at 0x%x lisp address(%p 68k)\n", LADDR_from_68k(fnobj), fnobj);
print(fnobj->framename);
putchar('\n');
printf("stkmin : %d\n", fnobj->stkmin);
printf("na : %d\n", fnobj->na);
printf("pv : %d\n", fnobj->pv);
printf("startpc : %d\n", fnobj->startpc);
printf("argtype : %d\n", fnobj->argtype);
printf("framename : %d\n", fnobj->framename);
printf("ntsize : %d\n", fnobj->ntsize);
printf("nlocals : %d\n", fnobj->nlocals);
printf("fvaroffset: %d\n", fnobj->fvaroffset);
scratch = (DLbyte *)fnobj;
for (i = 20; i < (fnobj->startpc); i += 2) {
int word;
word = (int)(0xffff & (GETWORD((DLword *)(scratch + i))));
printf(" 0x%x(%p 68k): 0%6o 0x%4x\n", LADDR_from_68k(scratch + i), scratch + i, word, word);
}
scratch = (DLbyte *)fnobj + (fnobj->startpc);
for (i = 0; i < 2000; i++) {
int len = print_opcode(fnobj->startpc + i, scratch, fnobj);
if (len < 1) return;
scratch += len;
i += (len - 1);
}
} /*dump_fnbody end */
/************************************************************************/
/* */
/* d u m p _ f n o b j */
/* */
/* Given an atom number, dump that atom's definition. */
/* */
/************************************************************************/
#define DUMPSIZE 40
void dump_fnobj(LispPTR index)
/* atom index */
{
LispPTR *defcell68k;
defcell68k = GetDEFCELL68k(index);
dump_fnbody(*defcell68k);
} /*dump_fnobj end */
/************************************************************************/
/* */
/* p r i n t _ o p c o d e */
/* */
/* Print a single opcode's worth of a function body. */
/* */
/************************************************************************/
/* Opcode names, by opcode */
const char *opcode_table[256] = {
"-X-",
"CAR",
"CDR",
"LISTP",
"NTYPX",
"TYPEP",
"DTEST",
"UNWIND",
"FN0",
"FN1",
"FN2",
"FN3",
"FN4",
"FNX",
"APPLYFN",
"CHECKAPPLY*",
"RETURN",
"BIND",
"UNBIND",
"DUNBIND",
"RPLPTR.N",
"GCREF",
"ASSOC",
"GVAR_",
"RPLACA",
"RPLACD",
"CONS",
"CMLASSOC",
"FMEMB",
"CMLMEMBER",
"FINDKEY",
"CREATECELL",
"BIN",
"BOUT",
"PROLOG",
"RESTLIST",
"MISCN",
"<>",
"RPLCONS",
"LISTGET",
"ELT",
"NTHCHC",
"SETA",
"RPLCHARCODE",
"EVAL",
"ENVCALL",
"TYPECHECK.N",
"STKSCAN",
"BUSBLT",
"MISC8",
"UBFLOAT3",
"TYPEMASK.N",
"PROLOG",
"PROLOG",
"PROLOG",
"PROLOG",
"PSEUDOCOLOR",
"<>",
"EQL",
"DRAWLINE",
"STORE.N",
"COPY.N",
"RAID",
"\\RETURN",
"IVAR0",
"IVAR1",
"IVAR2",
"IVAR3",
"IVAR4",
"IVAR5",
"IVAR6",
"IVARX",
"PVAR0",
"PVAR1",
"PVAR2",
"PVAR3",
"PVAR4",
"PVAR5",
"PVAR6",
"PVARX",
"FVAR0",
"FVAR1",
"FVAR2",
"FVAR3",
"FVAR4",
"FVAR5",
"FVAR6",
"FVARX",
"PVAR_0",
"PVAR_1",
"PVAR_2",
"PVAR_3",
"PVAR_4",
"PVAR_5",
"PVAR_6",
"PVAR_X",
"GVAR",
"ARG0",
"IVARX_",
"FVARX_",
"COPY",
"MYARGCOUNT",
"MYALINK",
"ACONST",
"'NIL",
"'T",
"'0",
"'1",
"SIC",
"SNIC",
"SICX",
"GCONST",
"ATOMNUMBER",
"READFLAGS",
"READRP",
"WRITEMAP",
"RPPORT",
"WPRTPORT",
"PILOTBBT",
"RCLK",
"MISC1",
"MISC2",
"RECCELL",
"GCSCAN1",
"GCSCAN2",
"SUBRCALL",
"CONTEXT",
"<>",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"JUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"FJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"TJUMP",
"JUMPX",
"JUMPXX",
"FJUMPX",
"TJUMPX",
"NFJUMPX",
"NTJUMPX",
"AREF1",
"ASET1",
"PVAR_0^",
"PVAR_1^",
"PVAR_2^",
"PVAR_3^",
"PVAR_4^",
"PVAR_5^",
"PVAR_6^",
"POP",
"POP.N",
"ATOMCELL.N",
"GETBASEBYTE",
"INSTANCEP",
"BLT",
"MISC10",
"<>",
"PUTBASEBYTE",
"GETBASE.N",
"GETBASEPTR.N",
"GETBITS.N.FD",
"<>",
"CMLEQUAL",
"PUTBASE.N",
"PUTBASEPTR.N",
"PUTBITS.N.FD",
"ADDBASE",
"VAG2",
"HILOC",
"LOLOC",
"PLUS2",
"DIFFERENCE",
"TIMES2",
"QUOTIENT",
"IPLUS2",
"IDIFFERENCE",
"ITIMES2",
"IQUOTIENT",
"IREMAINDER",
"IPLUS.N",
"IDIFFERENCE.N",
"<>",
"LLSH1",
"LLSH8",
"LRSH1",
"LRSH8",
"LOGOR2",
"LOGAND2",
"LOGXOR2",
"LSH",
"FPLUS2",
"FIDFFERENCE",
"FTIMES2",
"FQUOTIENT",
"UBFLOAT2",
"UBFLOAT1",
"AREF2",
"ASET2",
"EQ",
"IGREATERP",
"FGREATERP",
"GREATERP",
"EQUAL",
"MAKENUMBER",
"BOXIPLUS",
"BOSIDIFFERENCE",
"FLOATBLT",
"FFTSTEP",
"MISC3",
"MISC4",
"UPCTRACE",
"SWAP",
"NOP",
"CL="
};
int print_opcode(int pc, DLbyte *addr, struct fnhead *fnobj) {
/* Print the opcode at addr, including args, and return length */
/* if this opcode is the last, return -1 */
int op = (int)(0xFF & GETBYTE(addr));
int i;
extern unsigned int oplength[256];
int len = oplength[op] + 1;
printf(" 0%o (0x%x) ", pc, pc);
for (i = 0; i < len; i++) printf("%o ", 0xFF & GETBYTE(addr + i));
printf(" %s", opcode_table[op]);
switch (op) {
case 0:
putchar('\n'); /* End of function */
return (-1);
break;
case 015:
printf("(%d)", (unsigned char)GETBYTE(addr + 1));
addr += 1; /* FNX uses an extra byte */
/* Fall thru to the name print */
case 006: /* DTEST */
case 010: /* FN0-4 */
case 011:
case 012:
case 013:
case 014:
case 027: /* GVAR_ */
case 0140: /* GVAR */
case 0303: /* INSTANCEP */
case 056: /* TYPENAMEP */
case 0147: putchar(' ');
#ifdef BIGVM
print_atomname(((unsigned char)GETBYTE(addr + 1) << 24) +
((unsigned char)GETBYTE(addr + 2) << 16) +
((unsigned char)GETBYTE(addr + 3) << 8) + (unsigned char)GETBYTE(addr + 4));
#elif defined(BIGATOMS)
print_atomname(((unsigned char)GETBYTE(addr + 1) << 16) +
((unsigned char)GETBYTE(addr + 2) << 8) + (unsigned char)GETBYTE(addr + 3));
#else
print_atomname(((unsigned char)GETBYTE(addr + 1) << 8) + (unsigned char)GETBYTE(addr + 2));
#endif /* BIGATOMS */
putchar('\n');
break;
case 0200: /* Jump opcodes */
case 0201:
case 0202:
case 0203:
case 0204:
case 0205:
case 0206:
case 0207:
case 0210:
case 0211:
case 0212:
case 0213:
case 0214:
case 0215:
case 0216:
case 0217: printf(" 0%o (0x%x)\n", pc + 2 + op - 0200, pc + 2 + op - 0200); break;
case 0220: /* FJUMP opcodes */
case 0221:
case 0222:
case 0223:
case 0224:
case 0225:
case 0226:
case 0227:
case 0230:
case 0231:
case 0232:
case 0233:
case 0234:
case 0235:
case 0236:
case 0237: printf(" 0%o (0x%x)\n", pc + 2 + op - 0220, pc + 2 + op - 0220); break;
case 0240: /* TJUMP opcodes */
case 0241:
case 0242:
case 0243:
case 0244:
case 0245:
case 0246:
case 0247:
case 0250:
case 0251:
case 0252:
case 0253:
case 0254:
case 0255:
case 0256:
case 0257: printf(" 0%o (0x%x)\n", pc + 2 + op - 0240, pc + 2 + op - 0240); break;
case 0260: /* JUMPX */
case 0262: /* FJUMPX */
case 0263: /* TJUMPX */
case 0264: /* NFJUMPX */
case 0265: /* NTJUMPX */
printf(" 0%o (0x%x)\n", pc + (int8_t)GETBYTE(addr + 1), pc + (int8_t)GETBYTE(addr + 1));
break;
case 0261: /* JUMPXX */
printf(" 0%o (0x%x)\n",
pc + ((int8_t)GETBYTE(addr + 1) << 8) + (uint8_t)GETBYTE(addr + 2),
pc + ((int8_t)GETBYTE(addr + 1) << 8) + (uint8_t)GETBYTE(addr + 2));
break;
case 0120: /* FVAR opcodes */
case 0121:
case 0122:
case 0123:
case 0124:
case 0125:
case 0126:
putchar(' ');
print_atomname(get_fn_fvar_name(fnobj, op - 0120));
putchar('\n');
break;
default: putchar('\n');
}
fflush(stdout); /* Make sure each line is really printed as we go. */
return (len);
}
/************************************************************************/
/* */
/* d o k o */
/* */
/* For URAID: Display the current function name & PC. */
/* */
/************************************************************************/
void doko(void) {
printf(" At ");
print_atomname(FuncObj->framename);
putchar('\n');
printf(" PC cnt = 0%"PRIoPTR"\n", ((UNSIGNED)(PC) - (UNSIGNED)FuncObj));
}
/**** dump specified area (in 32 bit width) ***/
void dumpl(LispPTR laddr) {
int i;
LispPTR *ptr;
ptr = (LispPTR *)Addr68k_from_LADDR(laddr);
for (i = 0; i < 40; i++, ptr++) printf("LADDR 0x%x : %d\n", LADDR_from_68k(ptr), *ptr);
}
/**** dump specified area (in 16 bit width) ***/
void dumps(LispPTR laddr) {
int i;
DLword *ptr;
ptr = (DLword *)Addr68k_from_LADDR(laddr);
for (i = 0; i < 40; i++, ptr++)
printf("LADDR 0x%x : %d\n", LADDR_from_68k(ptr), (GETWORD(ptr) & 0xffff));
}
/***********************/
void printPC(void) {
unsigned short pc;
pc = (UNSIGNED)PC - (UNSIGNED)FuncObj;
printf("PC: O%o ", pc);
}
void dump_bf(Bframe *bf) {
DLword *ptr;
printf("\n*** Basic Frame");
if (BFRAMEPTR(bf)->flags != 4) {
printf("\nInvalid basic frame");
return;
};
if (BFRAMEPTR(bf)->residual) { goto printflags; }
ptr = Addr68k_from_LADDR(STK_OFFSET + bf->ivar);
if ((((DLword *)bf - ptr) > 512) || (((UNSIGNED)ptr & 1) != 0)) {
printf("\nInvalid basic frame");
return;
}
while (ptr < (DLword *)bf) {
printf("\n %x : %x %x", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
print(*ptr);
ptr += 2;
}
printflags:
printf("\n %x : %x %x ", LADDR_from_68k(bf), *(DLword *)bf, *((DLword *)bf + 1));
putchar('[');
if (BFRAMEPTR(bf)->residual) printf("Residual, ");
if (BFRAMEPTR(bf)->padding) printf("Padded, ");
printf("usecnt=%d ] ", BFRAMEPTR(bf)->usecnt);
printf("ivar : 0x%x", BFRAMEPTR(bf)->ivar);
}
void dump_fx(struct frameex1 *fx_addr68k) {
DLword *next68k;
DLword *ptr;
LispPTR atomindex;
ptr = (DLword *)fx_addr68k;
if (fx_addr68k->flags != 6) {
printf("\nInvalid frame,NOT FX");
return;
};
atomindex = get_framename((struct frameex1 *)fx_addr68k);
printf("\n*** Frame Extension for ");
print(atomindex);
printf("\n %x : %x %x ", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
putchar('[');
if (fx_addr68k->fast) printf("F,");
if (fx_addr68k->incall) printf("incall, ");
if (fx_addr68k->validnametable) printf("V, ");
printf("usecnt = %d]; alink", fx_addr68k->usecount);
if (fx_addr68k->alink & 1) printf("[SLOWP]");
ptr += 2;
printf("\n %x : %x %x fnheadlo, fnheadhi\n", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
ptr += 2;
printf("\n %x : %x %x next, pc\n", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
ptr += 2;
printf("\n %x : %x %x LoNmTbl, HiNmTbl\n", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
ptr += 2;
printf("\n %x : %x %x #blink, #clink\n", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
/* should pay attention to the name table like RAID does */
next68k = (DLword *)Addr68k_from_LADDR((fx_addr68k->nextblock + STK_OFFSET));
if (fx_addr68k == CURRENTFX) { next68k = CurrentStackPTR + 2; }
if ((next68k < ptr) || (((UNSIGNED)next68k & 1) != 0)) {
printf("\nNext block invalid");
return;
}
while (next68k > ptr) {
ptr += 2;
printf("\n %x : %x %x", LADDR_from_68k(ptr), GETWORD(ptr), GETWORD(ptr + 1));
}
} /* end dump_fx */
/***************************************************************/
/*
Func Name : dump_stackframe
Desc : For Debugging Aids
Changed 8 JUN 1987 TAKE
*/
/***************************************************************/
void dump_stackframe(struct frameex1 *fx_addr68k) {
Bframe *bf;
if ((fx_addr68k->alink & 1) == 0) { /* FAST */
bf = (Bframe *)(((DLword *)fx_addr68k) - 2);
} else { /* SLOW */
bf = (Bframe *)Addr68k_from_LADDR((fx_addr68k->blink + STK_OFFSET));
}
dump_bf(bf);
dump_fx((struct frameex1 *)fx_addr68k);
}
void dump_CSTK(int before) {
DLword *ptr;
ptr = CurrentStackPTR - before;
while (ptr != CurrentStackPTR) {
printf("\n%x : %x ", LADDR_from_68k(ptr), GETWORD(ptr));
ptr++;
}
printf("\nCurrentSTKP : %x ", LADDR_from_68k(CurrentStackPTR));
printf("\ncontents : %x ", *((LispPTR *)(CurrentStackPTR - 1)));
} /* dump_CSTK end */
/******************************************/
/* BTV */
void btv(void) {
struct frameex1 *fx_addr68k;
struct frameex1 *get_nextFX(FX * fx);
fx_addr68k = CURRENTFX;
loop:
dump_stackframe(fx_addr68k);
if (fx_addr68k->alink == 0) {
printf("\n BTV end");
return;
};
fx_addr68k = get_nextFX(fx_addr68k);
goto loop;
} /*end btv*/
int get_framename(struct frameex1 *fx_addr68k) {
struct fnhead *fnheader;
LispPTR scratch;
/* Get FNHEAD */
#ifdef BIGVM
if (fx_addr68k->validnametable == 0) {
scratch = (unsigned int)(fx_addr68k->fnheader);
} else {
scratch = (unsigned int)(fx_addr68k->nametable);
}
#else
if (fx_addr68k->validnametable == 0) {
scratch = (unsigned int)(fx_addr68k->hi2fnheader << 16);
scratch |= (unsigned int)(fx_addr68k->lofnheader);
} else {
scratch = (unsigned int)(fx_addr68k->hi2nametable << 16);
scratch |= (unsigned int)(fx_addr68k->lonametable);
}
#endif /* BIGVM */
fnheader = (struct fnhead *)Addr68k_from_LADDR(scratch);
return (fnheader->framename);
} /* get_framename end */
FX *get_nextFX(FX *fx) {
if (URaid_scanlink == URSCAN_ALINK)
return ((FX *)Addr68k_from_StkOffset(GETALINK(fx)));
else
return ((FX *)Addr68k_from_StkOffset(GETCLINK(fx)));
} /* get_nextFX end */
LispPTR MAKEATOM(char *string) {
return (make_atom(string, 0, strlen(string)));
}
/************************************************************************/
/* */
/* M a k e A t o m 6 8 k */
/* */
/* Given a LITATOM that exists before the package system was */
/* turned on, return a pointer to that atom's value cell. */
/* */
/************************************************************************/
LispPTR *MakeAtom68k(char *string) {
LispPTR index;
index = make_atom(string, 0, strlen(string));
if (index == 0xffffffff) {
error("MakeAtom68k: no such atom found");
}
#ifdef BIGVM
index = (ATOMS_HI << 16) + (index * 10) + NEWATOM_VALUE_OFFSET;
#else
index = VALS_OFFSET + (index << 1);
#endif /* BIGVM */
return ((LispPTR *) Addr68k_from_LADDR(index));
}
/************************************************************************/
/* */
/* G E T T O P V A L */
/* */
/* Print the top-level value of a given atom; for use in dbx. */
/* */
/************************************************************************/
void GETTOPVAL(char *string) {
int index;
LispPTR *cell68k;
index = MAKEATOM(string);
if (index != -1) /* Only print if there's such an atom */
{
cell68k = (LispPTR *)GetVALCELL68k(index);
print(*cell68k);
} else
printf("'%s': no such symbol.\n", string);
}
/****************************************************************************/
/* all_stack_dump(start,end)
*/
jmp_buf SD_jumpbuf;
#define SDMAXLINE 30
#define SD_morep \
if (++sdlines > SDMAXLINE) { \
int temp; \
printf("\nPress Return:(to quit Esc and Ret):"); \
temp = getchar(); \
fflush(stdin); \
sdlines = 0; \
if (temp == 27) longjmp(SD_jumpbuf, 1); \
}
#ifndef BYTESWAP
typedef struct stack_header {
unsigned flags1 : 3;
unsigned flags2 : 5;
unsigned usecount : 8;
} STKH;
#define STKHPTR(ptr) (ptr)
#else
typedef struct stack_header {
unsigned usecount : 8;
unsigned flags2 : 5;
unsigned flags1 : 3;
} STKH;
#define STKHPTR(ptr) ((STKH *)(2 ^ (UNSIGNED)(ptr)))
#endif /* BYTESWAP */
void all_stack_dump(DLword start, DLword end, DLword silent)
/* Stack offset in DLword */
{
STKH *stkptr;
DLword *start68k, *end68k, *orig68k;
DLword size;
int sdlines = 0;
extern IFPAGE *InterfacePage;
if (start == 0)
start68k = Stackspace + InterfacePage->stackbase;
else
start68k = Addr68k_from_LADDR(STK_OFFSET | start);
if (end == 0)
end68k = Stackspace + InterfacePage->endofstack;
else
end68k = Addr68k_from_LADDR(STK_OFFSET | end);
stkptr = (STKH *)start68k;
while (((DLword *)stkptr) < end68k) {
switch (STKHPTR(stkptr)->flags1) {
case STK_GUARD:
case STK_FSB:
if ((STKHPTR(stkptr)->flags2 != 0) || (STKHPTR(stkptr)->usecount != 0)) { goto badblock; };
size = GETWORD(((DLword *)stkptr) + 1);
if (STKHPTR(stkptr)->flags1 == STK_GUARD)
printf("\n0x%x GUARD, size : 0x%x", LADDR_from_68k(stkptr), size);
else
printf("\n0x%x FSB, size : 0x%x", LADDR_from_68k(stkptr), size);
if (size <= 0 || size > ((DLword *)end68k - (DLword *)stkptr)) { goto badblock; };
SD_morep;
size = GETWORD(((DLword *)stkptr) + 1);
checksize:
if (size <= 0 || size > ((DLword *)end68k - (DLword *)stkptr)) { goto badblock; };
stkptr = (STKH *)(((DLword *)stkptr) + size);
break;
case STK_FX:
/*if((((FX *)stkptr)->pc < 24) ||
(((FX *)stkptr)->alink==0) ||
(STKHPTR(stkptr)->usecount > 31))
{goto badblock;};*/
if (silent) {
SD_morep;
printf("\n0x%x: FX for ", LADDR_from_68k(stkptr));
print(get_framename((struct frameex1 *)stkptr));
printf(" [");
if (((FX *)stkptr)->fast) printf("fast,");
if (((FX *)stkptr)->incall) printf("incall,");
if (((FX *)stkptr)->validnametable) printf("V,");
if (((FX *)stkptr)->nopush) printf("nopush,");
printf("]");
} else {
dump_fx((struct frameex1 *)stkptr);
}
if ((FX *)stkptr == CURRENTFX) {
printf(" <-***current***");
size = EndSTKP - (DLword *)stkptr;
} else {
size = Addr68k_from_LADDR(STK_OFFSET | ((FX *)stkptr)->nextblock) - (DLword *)stkptr;
};
goto checksize;
default:
orig68k = (DLword *)stkptr;
while (STKHPTR(stkptr)->flags1 != STK_BF) {
if (STKHPTR(stkptr)->flags1 != STK_NOTFLG) { goto badblock; };
stkptr = (STKH *)(((DLword *)stkptr) + DLWORDSPER_CELL);
};
if ((BFRAMEPTR(stkptr))->residual) {
if ((DLword *)stkptr != orig68k) {
printf("\n$$$Bad BF(res):0x%x", LADDR_from_68k(stkptr));
goto incptr;
}
} else {
if (BFRAMEPTR(stkptr)->ivar != StkOffset_from_68K(orig68k)) {
printf("\n$$$BF doesn't point TopIVAR:0x%x\n", LADDR_from_68k(stkptr));
goto incptr;
}
}
if (silent) {
SD_morep;
printf("\n0x%x BF, ", LADDR_from_68k(stkptr));
putchar('[');
if (BFRAMEPTR(stkptr)->residual) printf("Res,");
if (BFRAMEPTR(stkptr)->padding) printf("Pad,");
printf("ivar : 0x%x]", BFRAMEPTR(stkptr)->ivar);
} else
dump_bf((Bframe *)stkptr);
stkptr = (STKH *)(((DLword *)stkptr) + 2);
break;
badblock:
SD_morep;
printf("\n0x%x: Invalid, %x %x", LADDR_from_68k(stkptr), GETWORD(stkptr),
GETWORD(stkptr + 1));
incptr:
stkptr = (STKH *)(((DLword *)stkptr) + 2);
break;
} /* case end */
} /* while end */
printf("\n<< That's All , last stack :0x%x >>\n", InterfacePage->endofstack);
}
/************************************************************/
void dtd_chain(DLword type) {
struct dtd *dtdp;
LispPTR next;
LispPTR *next68k;
dtdp = (struct dtd *)GetDTD(type);
next = dtdp->dtd_free;
next68k = (LispPTR *)Addr68k_from_LADDR(next);
while ((*next68k) != 0) {
if (type != GetTypeNumber(next)) {
printf("BAD cell in next dtdfree\n");
return;
}
print(next);
putchar('\n');
next = *next68k;
next68k = (LispPTR *)Addr68k_from_LADDR(next);
}
printf("That's All !\n");
} /* dtd_chain end **/
void check_dtd_chain(DLword type)
{
register LispPTR next, onext;
LispPTR before;
onext = 0;
next = ((struct dtd *)GetDTD(type))->dtd_free;
next &= POINTERMASK;
while (next != NIL) {
if (next & 1) {
error("Free pointer is ODD!");
return;
}
if (next & 0x8000000) error("impossibly-big free pointer!");
if (type != GetTypeNumber(next)) {
error("BAD cell in next dtdfree ");
return;
}
onext = next;
next = *((LispPTR *)Addr68k_from_LADDR(next));
next &= POINTERMASK;
}
}
/************************************************************************/
/* */
/* T R A C E _ F N C A L L */
/* T R A C E _ A P P L Y */
/* */
/* Functions for tracing function call and apply. Trace_FNCall */
/* takes 2 arguments: The # of args the fn is bing called with */
/* and the atom index of the function's name. */
/* */
/* Trace_APPLY takes one argument: The atom number of the */
/* atom being applied. */
/* */
/************************************************************************/
void Trace_FNCall(int numargs, int atomindex, int arg1, LispPTR *tos) {
printf("Calling a %d-arg FN: ", numargs);
print_atomname(atomindex);
printf("(");
if (numargs > 1) {
int i;
for (i = -(numargs - 2); i < 1; i++) {
prindatum(*(tos + i));
printf(", ");
}
}
if (numargs) prindatum(arg1);
printf(").\n");
fflush(stdout);
}
void Trace_APPLY(int atomindex) {
printf("APPLYing an atom: ");
print_atomname(atomindex);
printf(".\n");
fflush(stdout);
}
Reference in New Issue View Git Blame Copy Permalink