/* l2xidbug.c Interactive SLD debugging routines for LTX2X interpreter */
/* Written by: Peter Wilson, CUA pwilson@cme.nist.gov */
/* This code is partly based on algorithms presented by Ronald Mak in */
/* "Writing Compilers & Interpreters", John Wiley & Sons, 1991 */
#include <stdio.h>
#include "l2xicmon.h"
#include "l2xierr.h"
#include "l2xiscan.h"
#include "l2xisymt.h"
#include "l2xiexec.h"
#include "l2xiidbg.h"
#define MAX_BREAKS 16
#define MAX_WATCHES 16
#define COMMAND_QUERY "Command? "
/* EXTERNALS */
extern int level;
extern SYMTAB_NODE_PTR symtab_display[];
extern STACK_ITEM_PTR tos;
extern int line_number;
extern int buffer_offset;
extern BOOLEAN print_flag;
extern ICT *code_segmentp;
extern ICT *statement_startp;
extern int ctoken;
extern int exec_line_number;
extern int isynt_error_count;
extern char *bufferp;
extern int ch;
extern char source_buffer[];
extern char word_string[];
extern int token;
extern LITERAL literal;
extern BOOLEAN block_flag;
extern ICT *code_buffer;
extern ICT *code_bufferp;
extern ICT *code_segmentp;
extern BOOLEAN is_value_undef();
/* GLOBALS */
FILE *console;
BOOLEAN debugger_command_flag, /* TRUE during debug command */
halt_flag, /* TRUE to pause for debug command */
trace_flag, /* TRUE to trace statement */
step_flag, /* TRUE to single-step */
entry_flag, /* TRUE to trace routine entry */
exit_flag, /* TRUE to trace routine exit */
traceall_flag, /* TRUE to trace everything */
stack_flag; /* TRUE to watch the stack */
int break_count; /* count of breakpoints */
int break_list[MAX_BREAKS]; /* list of breakpoints */
int watch_count; /* count of watches */
SYMTAB_NODE_PTR watch_list[MAX_WATCHES]; /* list of watches */
typedef struct { /* watch structure */
SYMTAB_NODE_PTR watch_idp; /* id node watched variable */
BOOLEAN store_flag; /* TRUE to trace stores */
BOOLEAN fetch_flag; /* TRUE to trace fetches */
} WATCH_STRUCT, *WATCH_STRUCT_PTR;
/* char *symbol_strings[EOTC]; */
/* array of the strings which form tokens */
char *symbol_strings[] = {
#define sctc(a, b, c) c,
#include "l2xisctc.h"
#undef sctc
};
/* array of strings which corresponding to form types */
char *form2str[] = {
#define fotc(a, b, c, d) d,
#define sotc(a, b, c, d)
#define sftc(a, b, c, d) d,
#include "l2xisftc.h"
#undef fotc
#undef sotc
#undef sftc
};
/* array of strings which corresponding to stack types */
char *stack2str[] = {
#define fotc(a, b, c, d)
#define sotc(a, b, c, d) b,
#define sftc(a, b, c, d) b,
#include "l2xisftc.h"
#undef fotc
#undef sotc
#undef sftc
};
/********************************************************************/
/* init_debugger() Initialise interactive debugger */
init_debugger()
{
int i;
if (SLD_OFF) return;
/* initialise the globals */
/* console = fopen("CON", "r"); */
console = stdin;
/* init_symbol_strings(); */
/* code_buffer = alloc_bytes(MAX_SOURCE_LINE_LENGTH + 1); */
print_flag = FALSE;
halt_flag = block_flag = TRUE;
debugger_command_flag = trace_flag = step_flag
= entry_flag = exit_flag
= FALSE;
traceall_flag = stack_flag = FALSE;
break_count = 0;
for (i = 0; i <MAX_BREAKS; i++) break_list[i] = 0;
watch_count = 0;
for (i = 0; i <MAX_WATCHES; i++) watch_list[i] = NULL;
} /* end init_debugger */
/********************************************************************/
/********************************************************************/
/* read_debugger_command() Read and process a user's debug command */
read_debugger_command()
{
BOOLEAN done = FALSE;
entry_debug("read_debugger_command");
do {
printf("\n%s", COMMAND_QUERY);
/* read in comand and replace final \nEOS with ;;EOS */
bufferp = fgets(source_buffer, MAX_SOURCE_LINE_LENGTH, console);
strcpy(&source_buffer[strlen(source_buffer) - 1], ";;\0");
buffer_offset = 0;
ch = *bufferp++;
buffer_offset++;
code_bufferp = code_buffer;
isynt_error_count = 0;
get_token();
/* process the command */
switch (token) {
case SEMICOLON: {
done = TRUE;
break;
}
case IDENTIFIER: {
execute_debugger_command();
break;
}
}
if (token != SEMICOLON) {
error(UNEXPECTED_TOKEN);
}
} while (!done); /* end do */
debugger_command_flag = FALSE;
exit_debug("read_debugger_command");
} /* end read_debugger_command */
/********************************************************************/
/********************************************************************/
/* execute_debugger_command() Execute a debugger command */
execute_debugger_command()
{
WATCH_STRUCT_PTR wp;
WATCH_STRUCT_PTR allocate_watch();
if (strcmp(word_string, "trace") == 0) {
trace_flag = TRUE;
step_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "untrace") == 0) {
trace_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "step") == 0) {
step_flag = TRUE;
trace_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "unstep") == 0) {
step_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "break") == 0) {
set_breakpoint();
}
else if (strcmp(word_string, "unbreak") == 0) {
remove_breakpoint();
}
else if (strcmp(word_string, "entry") == 0) {
entry_flag = TRUE;
get_token();
}
else if (strcmp(word_string, "unentry") == 0) {
entry_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "exit") == 0) {
exit_flag = TRUE;
get_token();
}
else if (strcmp(word_string, "unexit") == 0) {
exit_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "watch") == 0) {
wp = allocate_watch();
if (wp != NULL) {
wp->store_flag = TRUE;
wp->fetch_flag = TRUE;
}
}
else if (strcmp(word_string, "unwatch") == 0) {
remove_watch();
}
else if (strcmp(word_string, "store") == 0) {
wp = allocate_watch();
if (wp != NULL) {
wp->store_flag = TRUE;
}
}
else if (strcmp(word_string, "fetch") == 0) {
wp = allocate_watch();
if (wp != NULL) {
wp->fetch_flag = TRUE;
}
}
else if (strcmp(word_string, "show") == 0) {
show_value();
}
else if (strcmp(word_string, "assign") == 0) {
assign_variable();
}
else if (strcmp(word_string, "where") == 0) {
print_statement();
get_token();
}
else if (strcmp(word_string, "kill") == 0) {
printf("Program killed.\n");
exit(0);
}
else if (strcmp(word_string, "traceall") == 0) {
traceall_flag = TRUE;
get_token();
}
else if (strcmp(word_string, "untraceall") == 0) {
traceall_flag = FALSE;
get_token();
}
else if (strcmp(word_string, "stack") == 0) {
stack_flag = TRUE;
stack_debug();
get_token();
}
else if (strcmp(word_string, "unstack") == 0) {
stack_flag = FALSE;
get_token();
}
return;
} /* end execute_debugger_command */
/********************************************************************/
/* TRACING ROUTINES */
/********************************************************************/
/* trace_statement_execution() Called just before the execution */
/* of each statement */
trace_statement_execution()
{
if (SLD_OFF) return;
if (traceall_flag) {
sprintf(dbuffer, ">> Stmt %d\n", exec_line_number);
log_print(dbuffer);
}
if (break_count > 0) {
int i;
/* check if this statement is a breakpoint */
for (i = 0; i < break_count; i++) {
if (exec_line_number == break_list[i]) {
printf("\nBreakpoint");
print_statement();
halt_flag = TRUE;
break;
}
}
}
/* pause to read debugger command */
if (halt_flag) {
read_debugger_command();
halt_flag = step_flag;
}
/* if single stepping, print the current statement */
/* if tracing, print the current line number */
if (step_flag) print_statement();
if (trace_flag && !traceall_flag) print_line_number();
} /* end trace_statement_execution */
/********************************************************************/
/********************************************************************/
/* trace_routine_entry(idp) Called at entry to a routine */
trace_routine_entry(idp)
SYMTAB_NODE_PTR idp; /* routine id */
{
if (SLD_OFF) return;
if (traceall_flag) {
sprintf(dbuffer, ">> Entering routine %s\n", idp->name);
log_print(dbuffer);
}
else if (entry_flag) {
printf("\nEntering %s\n", idp->name);
}
} /* end trace_routine_entry */
/********************************************************************/
/********************************************************************/
/* trace_routine_exit(idp) Called at exit from a routine */
trace_routine_exit(idp)
SYMTAB_NODE_PTR idp; /* routine id */
{
if (SLD_OFF) return;
if (traceall_flag) {
sprintf(dbuffer, ">> Exiting routine %s\n", idp->name);
log_print(dbuffer);
}
else if (exit_flag) {
printf("\nExiting %s\n", idp->name);
}
} /* end trace_routine_exit */
/********************************************************************/
/********************************************************************/
/* trace_data_store(idp, idp_tp, targetp, target_tp) Called just */
/* before storing data in a variable */
trace_data_store(idp, idp_tp, targetp, target_tp)
SYMTAB_NODE_PTR idp; /* id of target variable */
TYPE_STRUCT_PTR idp_tp; /* ptr to idp's type */
STACK_ITEM_PTR targetp; /* ptr to target location */
TYPE_STRUCT_PTR target_tp; /* ptr to target's type */
{
if (SLD_OFF) return;
if (traceall_flag) {
sprintf(dbuffer, ">> %s", idp->name);
log_print(dbuffer);
if (idp_tp->form == ARRAY_FORM ||
idp_tp->form == BAG_FORM ||
idp_tp->form == LIST_FORM ||
idp_tp->form == SET_FORM ) {
log_print("[*]");
}
else if (idp_tp->form == ENTITY_FORM) {
log_print(".*");
}
print_data_value_debug(targetp, target_tp, ":=");
}
/* check if variable is being watched for stores */
else if ((idp->info != NULL) && ((WATCH_STRUCT_PTR) idp->info)->store_flag) {
printf("\nAt %d: Store %s", exec_line_number, idp->name);
if (idp_tp->form == ARRAY_FORM ||
idp_tp->form == BAG_FORM ||
idp_tp->form == LIST_FORM ||
idp_tp->form == SET_FORM ) {
printf("[*]");
}
else if (idp_tp->form == ENTITY_FORM) {
printf(".*");
}
print_data_value(targetp, target_tp, ":=");
}
return;
} /* end trace_data_store */
/********************************************************************/
/********************************************************************/
/* trace_data_fetch(idp, tp, datap) Called just */
/* before fetching data from a variable */
trace_data_fetch(idp, tp, datap)
SYMTAB_NODE_PTR idp; /* id of target variable */
TYPE_STRUCT_PTR tp; /* ptr to idp's type */
STACK_ITEM_PTR datap; /* ptr to data */
{
TYPE_STRUCT_PTR idp_tp = idp->typep;
if (SLD_OFF) return;
if (traceall_flag) {
sprintf(dbuffer, ">> %s", idp->name);
log_print(dbuffer);
if (idp_tp->form == ARRAY_FORM ||
idp_tp->form == BAG_FORM ||
idp_tp->form == LIST_FORM ||
idp_tp->form == SET_FORM ) {
log_print("[*]");
}
else if (idp_tp->form == ENTITY_FORM) {
log_print(".*");
}
print_data_value_debug(datap, tp, "=");
}
/* check if variable is being watched for fetches */
else if ((idp->info != NULL) && ((WATCH_STRUCT_PTR) idp->info)->fetch_flag) {
printf("\nAt %d: Fetch %s", exec_line_number, idp->name);
if (idp_tp->form == ARRAY_FORM ||
idp_tp->form == BAG_FORM ||
idp_tp->form == LIST_FORM ||
idp_tp->form == SET_FORM ) {
printf("[*]");
}
else if (idp_tp->form == ENTITY_FORM) {
printf(".*");
}
print_data_value(datap, tp, "=");
}
return;
} /* end trace_data_fetch */
/********************************************************************/
/* PRINTING ROUTINES */
/********************************************************************/
/* print_statement() Uncrunch and print a statement */
print_statement()
{
int tk; /* token code */
BOOLEAN done = FALSE;
ICT *csp = statement_startp;
/* entry_debug("print_statement"); */
printf("\nAt %3d:", exec_line_number);
do {
switch (tk = *csp++) {
case SEMICOLON:
case END:
case ELSE:
case THEN:
case UNTIL:
case BEGIN:
case OF:
case STATEMENT_MARKER: {
done = TRUE;
break;
}
default: {
done = FALSE;
switch(tk) {
case ADDRESS_MARKER: {
csp++;
break;
}
case IDENTIFIER:
case NUMBER_LITERAL:
case STRING_LITERAL: {
SYMTAB_NODE_PTR np = *((SYMTAB_NODE_PTR *) csp);
printf(" %s", np->name);
csp++;
break;
}
default: {
printf(" %s", symbol_strings[tk]);
break;
}
} /* end switch */
}
} /* end switch */
} while (!done); /* end do */
printf("\n");
/* exit_debug("print_statement"); */
} /* end print_statement */
/********************************************************************/
/********************************************************************/
/* print_line_number() Print the current line number */
print_line_number()
{
printf("<%d>", exec_line_number);
} /* end print_line_number */
/********************************************************************/
/********************************************************************/
/* print_data_value(datap, tp, str) Print a data value */
print_data_value(datap, tp, str)
STACK_ITEM_PTR datap; /* ptr to data value */
TYPE_STRUCT_PTR tp; /* ptr to type of stack item */
char *str; /* " = " or " := " */
{
STACK_TYPE stype;
LOGICAL_REP log;
TYPE_FORM form;
form = tp->form;
if (form == ARRAY_FORM ||
form == BAG_FORM ||
form == LIST_FORM ||
form == SET_FORM ||
form == ENTITY_FORM ) {
printf(" %s <%s>\n", str, form2str[form]);
return;
}
stype = get_stackval_type(datap);
if (stype == STKUDF) {
printf(" %s %c\n", str, get_undef(datap));
}
else if (stype == STKINT) {
printf(" %s %d\n", str, get_integer(datap));
}
else if (stype == STKREA) {
printf(" %s %0.6g\n", str, get_real(datap));
}
else if (stype == STKLOG) {
log = get_logical(datap);
if (log == TRUE_REP) {
printf(" %s %s\n", str, "TRUE");
}
else if (log == FALSE_REP) {
printf(" %s %s\n", str, "FALSE");
}
else {
printf(" %s %s\n", str, "UNKNOWN");
}
}
else if (stype == STKSTR) {
printf(" %s %s\n", str, get_stacked_string(datap));
}
return;
} /* end print_data_value */
/********************************************************************/
/********************************************************************/
/* print_data_value_debug(datap, tp, str) Print a data value */
print_data_value_debug(datap, tp, str)
STACK_ITEM_PTR datap; /* ptr to data value */
TYPE_STRUCT_PTR tp; /* ptr to type of stack item */
char *str; /* " = " or " := " */
{
STACK_TYPE stype;
LOGICAL_REP log;
TYPE_FORM form;
form = tp->form;
if (form == ARRAY_FORM ||
form == BAG_FORM ||
form == LIST_FORM ||
form == SET_FORM ||
form == ENTITY_FORM ) {
sprintf(dbuffer, " %s <%s>\n", str, form2str[form]);
log_print(dbuffer);
return;
}
stype = get_stackval_type(datap);
if (stype == STKUDF) {
sprintf(dbuffer, " %s %c\n", str, get_undef(datap));
log_print(dbuffer);
}
else if (stype == STKINT) {
sprintf(dbuffer, " %s %d\n", str, get_integer(datap));
log_print(dbuffer);
}
else if (stype == STKREA) {
sprintf(dbuffer, " %s %0.6g\n", str, get_real(datap));
log_print(dbuffer);
}
else if (stype == STKLOG) {
log = get_logical(datap);
if (log == TRUE_REP) {
sprintf(dbuffer, " %s %s\n", str, "TRUE");
}
else if (log == FALSE_REP) {
sprintf(dbuffer, " %s %s\n", str, "FALSE");
}
else {
sprintf(dbuffer, " %s %s\n", str, "UNKNOWN");
}
log_print(dbuffer);
}
else if (stype == STKSTR) {
sprintf(dbuffer, " %s %s\n", str, get_stacked_string(datap));
log_print(dbuffer);
}
return;
} /* end print_data_value_debug */
/********************************************************************/
/* BREAKPOINTS AND WATCHES */
/********************************************************************/
/* set_breakpoint() Set a breakpoint, or print all breakpoints in */
/* the break list */
set_breakpoint()
{
int i, number;
get_token();
switch (token) {
case SEMICOLON: { /* no line number --- list all breakpoints */
printf("Statement breakpoints at:\n");
for (i = 0; i < break_count; i++) {
printf("%5d\n", break_list[i]);
}
break;
}
case NUMBER_LITERAL: { /* set breakpoint by appending to list */
if (literal.type == INTEGER_LIT) {
number = literal.value.integer;
if ((number > 0) && (number <= line_number)) {
if (break_count < MAX_BREAKS) {
break_list[break_count] = number;
++break_count;
}
else {
printf("Break list is full.\n");
}
}
else {
error(VALUE_OUT_OF_RANGE);
}
}
else {
error(UNEXPECTED_TOKEN);
}
get_token();
break;
}
} /* end switch */
} /* end set_breakpoint */
/********************************************************************/
/********************************************************************/
/* remove_breakpoint() Remove a specified breakpoint, or all */
remove_breakpoint()
{
int i, j, number;
get_token();
switch (token) {
case SEMICOLON: { /* no line number --- remove all breakpoints */
for (i = 0; i < break_count; i++) {
break_list[i] = 0;
}
break_count = 0;
break;
}
case NUMBER_LITERAL: { /* remove breakpoint from list, and move others up */
if (literal.type == INTEGER_LIT) {
number = literal.value.integer;
if (number > 0) {
for (i = 0; i < break_count; i++) {
if (break_list[i] == number) {
break_list[i] = 0;
--break_count;
for (j = i; j < break_count; j++) {
break_list[j] = break_list[j+1];
}
}
}
}
}
else {
error(VALUE_OUT_OF_RANGE);
}
get_token();
break;
}
} /* end switch */
} /* end remove_breakpoint */
/********************************************************************/
/********************************************************************/
/* allocate_watch() Return a pointer to a watch structure, */
/* or print all variables being watched */
WATCH_STRUCT_PTR allocate_watch()
{
int i;
SYMTAB_NODE_PTR idp;
WATCH_STRUCT_PTR wp;
get_token();
switch (token) {
case SEMICOLON: { /* no variable, print them all */
printf("Variables being watched:\n");
for (i = 0; i < watch_count; i++) {
idp = watch_list[i];
if (idp != NULL) {
wp = (WATCH_STRUCT_PTR) idp->info;
printf("%16s ", idp->name);
if (wp->store_flag) printf(" (store)");
if (wp->fetch_flag) printf(" (fetch)");
printf("\n");
}
}
return(NULL);
}
case IDENTIFIER: {
search_and_find_all_symtab(idp);
get_token();
switch (idp->defn.key) {
case UNDEFINED: {
return(NULL);
}
case CONST_DEFN:
case VAR_DEFN:
case ATTRIBUTE_DEFN:
case VALPARM_DEFN:
case VARPARM_DEFN: {
if (idp->info != NULL) { /* being watched, return ptr to structure */
return((WATCH_STRUCT_PTR) idp->info);
}
else if (watch_count < MAX_WATCHES) { /* a new structure */
wp = alloc_struct(WATCH_STRUCT);
wp->store_flag = FALSE;
wp->fetch_flag = FALSE;
idp->info = (char *) wp;
watch_list[watch_count] = idp;
watch_count++;
return(wp);
}
else {
printf("Watch list is full.\n");
return(NULL);
}
}
default: {
error(INVALID_IDENTIFIER_USAGE);
return(NULL);
}
} /* end switch */
break;
}
} /* end switch */
} /* end allocate_watch */
/********************************************************************/
/********************************************************************/
/* remove_watch() Remove a variable from the watch list, */
/* or remove all variables being watched */
remove_watch()
{
int i, j;
SYMTAB_NODE_PTR idp;
WATCH_STRUCT_PTR wp;
get_token();
switch (token) {
case SEMICOLON: { /* no variable, remove them all */
for (i = 0; i < watch_count; i++) {
if ((idp = watch_list[i]) != NULL) {
wp = (WATCH_STRUCT_PTR) idp->info;
watch_list[i] = NULL;
idp->info = NULL;
free(wp);
}
}
watch_count = 0;
break;
}
case IDENTIFIER: { /* remove it from the list and move other up */
search_and_find_all_symtab(idp);
get_token();
if ((idp != NULL) && (idp->info != NULL)) {
wp = (WATCH_STRUCT_PTR) idp->info;
for (i = 0; i < watch_count; i++) {
if (watch_list[i] == idp) {
watch_list[i] = NULL;
idp->info = NULL;
free(wp);
--watch_count;
for (j = i; j < watch_count; j++) {
watch_list[j] = watch_list[j + 1];
}
break;
}
}
}
break;
}
} /* end switch */
} /* end remove_watch */
/********************************************************************/
/* SHOW and ASSIGN */
/********************************************************************/
/* show-value() Print the value of an expression */
show_value()
{
get_token();
switch (token) {
case SEMICOLON: {
error(INVALID_EXPRESSION);
break;
}
default: { /* parse and execute expression from code buffer */
TYPE_STRUCT_PTR expression();
TYPE_STRUCT_PTR tp = expression(); /* parse */
ICT *save_code_segmentp = code_segmentp;
int save_ctoken = ctoken;
if (isynt_error_count > 0) break;
/* switch to the code buffer */
code_segmentp = code_buffer + 1;
get_ctoken();
exec_expression(); /* execute */
/* print and then pop the value */
if ((tp->form == ARRAY_FORM) ||
(tp->form == BAG_FORM) ||
(tp->form == LIST_FORM) ||
(tp->form == SET_FORM) ||
(tp->form == ENTITY_FORM)) {
print_data_value(get_address(tos), tp, " ");
}
else {
print_data_value(tos, tp, " ");
}
pop();
/* resume the code segment */
code_segmentp = save_code_segmentp;
ctoken = save_ctoken;
break;
}
} /* end switch */
} /* end show_value */
/********************************************************************/
/********************************************************************/
/* assign_variable() Exexcute an assignment statement */
assign_variable()
{
get_token();
switch (token) {
case SEMICOLON: {
error(MISSING_VARIABLE);
break;
}
case IDENTIFIER : { /* parse and execute the assignment statement from code buffer */
SYMTAB_NODE_PTR idp;
ICT *save_code_segmentp = code_segmentp;
int save_ctoken = ctoken;
search_and_find_all_symtab(idp);
assignment_statement(idp); /* parse */
if (isynt_error_count > 0) break;
/* switch to the code buffer */
code_segmentp = code_buffer + 1;
get_ctoken();
idp = get_symtab_cptr();
exec_assignment_statement(idp); /* execute */
/* resume the code segment */
code_segmentp = save_code_segmentp;
ctoken = save_ctoken;
break;
}
} /* end switch */
} /* end assign_variable */
/********************************************************************/
/* STACK */
/********************************************************************/
/* stack_debug() Print runtime stack */
extern STACK_ITEM *stack; /* runtime stack */
extern STACK_ITEM_PTR tos; /* top of stack */
extern STACK_ITEM_PTR stack_frame_basep; /* ptr to stack frame base */
extern STACK_ITEM_PTR maxtos; /* current max top of stack */
stack_debug()
{
STACK_ITEM_PTR basep = stack; /* base of stack */
STACK_ITEM_PTR i;
if (!stack_flag) return;
log_print("\n The runtime stack with: ");
stack_frame_debug();
for (i = basep; i <= tos; i++) {
stack_item_debug(i);
}
return;
} /* end stack_debug */
/********************************************************************/
/********************************************************************/
/* tos_debug() Print top of runtime stack */
tos_debug()
{
if (!stack_flag) return;
log_print(" Top of runtime stack.");
stack_item_debug(tos);
return;
} /* end tos_debug */
/********************************************************************/
/********************************************************************/
/* stack_access_debug(s, sptr) Print stack access kind */
stack_access_debug(s, sptr)
char s[]; /* access kind */
STACK_ITEM_PTR sptr; /* stack position */
{
if (!stack_flag) return;
sprintf(dbuffer, " %-7s ==>", s);
log_print(dbuffer);
stack_item_debug(sptr);
if (sptr > maxtos) { /* probably looking at data area */
log_print(" Accessed data area:\n");
data_item_debug(sptr);
}
return;
} /* end stack_access_debug */
/********************************************************************/
/********************************************************************/
/* stack_item_debug(sptr) Print a runtime stack item */
stack_item_debug(sptr)
STACK_ITEM_PTR sptr; /* ptr to stack item */
{
STACK_TYPE stype;
if (!stack_flag) return;
if ((sptr < stack) || (sptr > maxtos)) { /* out of stack range */
runtime_warning(INVALID_STACK_ACCESS);
}
stype = sptr->type;
switch (stype) {
case STKINT: {
sprintf(dbuffer, " (Entry %d : %s is %d)\n",
sptr, stack2str[stype], sptr->value.integer);
log_print(dbuffer);
break;
}
case STKREA: {
sprintf(dbuffer, " (Entry %d : %s is %f)\n",
sptr, stack2str[stype], sptr->value.real);
log_print(dbuffer);
break;
}
case STKLOG: {
sprintf(dbuffer, " (Entry %d : %s is ",
sptr, stack2str[stype]);
log_print(dbuffer);
if (sptr->value.integer == FALSE_REP) sprintf(dbuffer, "FALSE)\n");
else if (sptr->value.integer == TRUE_REP) sprintf(dbuffer, "TRUE)\n");
else sprintf(dbuffer, "UNKNOWN)\n");
log_print(dbuffer);
break;
}
case STKSTR: {
sprintf(dbuffer, " (Entry %d : %s is %d)\n",
sptr, stack2str[stype], sptr->value.string);
log_print(dbuffer);
break;
}
case STKARY:
case STKADD: {
sprintf(dbuffer, " (Entry %d : %s is %d)\n",
sptr, stack2str[stype], sptr->value.address);
log_print(dbuffer);
break;
}
case STKUDF: { /* undefined */
sprintf(dbuffer, " (Entry %d : %s is '%c')\n",
sptr, stack2str[stype], sptr->value.integer);
log_print(dbuffer);
break;
}
case STKBAG:
case STKLST:
case STKSET: {
sprintf(dbuffer, " (Entry %d : %s is %d)\n",
sptr, stack2str[stype], sptr->value.head);
log_print(dbuffer);
break;
}
case STKENT: {
sprintf(dbuffer, " (Entry %d : %s is %d)\n",
sptr, stack2str[stype], sptr->value.address);
log_print(dbuffer);
break;
}
default: {
sprintf(dbuffer, " (Entry %d : unknown type (%d))\n",
sptr, sptr->type);
log_print(dbuffer);
break;
}
}
return;
} /* end stack_item_debug */
/********************************************************************/
/********************************************************************/
/* data_item_debug(sptr) Print data of array/entity item */
data_item_debug(sptr)
STACK_ITEM_PTR sptr; /* ptr to 'start' of data item */
{
STACK_TYPE kind;
STACK_ITEM_PTR aptr = sptr;
int n = 1;
int maxn = 20; /* max number of elements to be printed */
if (!stack_flag) return;
kind = aptr->type;
while ( (kind >= STKINT) && (kind <= STKADD) && (n <= maxn) ) {
stack_item_debug(aptr);
aptr++;
n++;
kind = aptr->type;
}
return;
} /* end data_item_debug */
/********************************************************************/
/********************************************************************/
/* stack_frame_debug() print the stack frame base pointer */
stack_frame_debug()
{
if (!stack_flag) return;
sprintf(dbuffer, " (Stack frame base at %d)\n", stack_frame_basep);
log_print(dbuffer);
return;
} /* end stack_frame_debug */
/********************************************************************/
/********************************************************************/
/* expression_type_debug(tptr) print type of type */
extern TYPE_STRUCT_PTR integer_typep, real_typep,
boolean_typep;
extern TYPE_STRUCT_PTR logical_typep, string_typep, binary_typep,
generic_typep, any_typep;
expression_type_debug(tptr)
TYPE_STRUCT_PTR tptr; /* pointer to type structure */
{
if (!stack_flag) return;
if (tptr == integer_typep) {
log_print(" Type is: INTEGER TYPE\n");
return;
}
else if (tptr == real_typep) {
log_print(" Type is: REAL TYPE\n");
return;
}
else if (tptr == boolean_typep) {
log_print(" Type is: BOOLEAN TYPE\n");
return;
}
else if (tptr == logical_typep) {
log_print(" Type is: LOGICAL TYPE\n");
return;
}
else if (tptr == string_typep) {
log_print(" Type is: STRING TYPE\n");
return;
}
else if (tptr == binary_typep) {
log_print(" Type is: BINARY TYPE\n");
return;
}
else if (tptr == generic_typep) {
log_print(" Type is: GENERIC TYPE\n");
return;
}
else if (tptr == any_typep) {
log_print(" Type is: INDETERMINATE TYPE\n");
return;
}
switch (tptr->form) {
case NO_FORM: {
log_print(" Type is: NO FORM\n");
return;
}
case SCALAR_FORM: {
log_print(" Type is: SCALAR FORM\n");
return;
}
case ENUM_FORM: {
log_print(" Type is: ENUM FORM\n");
return;
}
case SUBRANGE_FORM: {
log_print(" Type is: SUBRANGE FORM\n");
return;
}
case ARRAY_FORM: {
log_print(" Type is: ARRAY of ");
expression_type_debug(tptr->info.array.elmt_typep);
return;
}
case BAG_FORM: {
log_print(" Type is: BAG of ");
expression_type_debug(tptr->info.dynagg.elmt_typep);
return;
}
case LIST_FORM: {
log_print(" Type is: LIST of ");
expression_type_debug(tptr->info.dynagg.elmt_typep);
return;
}
case SET_FORM: {
log_print(" Type is: SET of ");
expression_type_debug(tptr->info.dynagg.elmt_typep);
return;
}
case ENTITY_FORM: {
log_print(" Type is: ENTITY FORM\n");
return;
}
case STRING_FORM: {
log_print(" Type is: STRING FORM\n");
return;
}
default: {
log_print(" Type is: UNKNOWN\n");
return;
}
} /* end switch */
} /* end expression_type_debug */
/********************************************************************/