stk/Src/error.c

175 lines
5.2 KiB
C

/*
*
* e r r o r . c -- The error procedure
*
* Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, and/or distribute this software and its
* documentation for any purpose and without fee is hereby granted, provided
* that both the above copyright notice and this permission notice appear in
* all copies and derived works. Fees for distribution or use of this
* software or derived works may only be charged with express written
* permission of the copyright holder.
* This software is provided ``as is'' without express or implied warranty.
*
* This software is a derivative work of other copyrighted softwares; the
* copyright notices of these softwares are placed in the file COPYRIGHTS
*
* $Id: error.c 1.13 Wed, 23 Dec 1998 23:41:27 +0100 eg $
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 14-Nov-1993 14:58
* Last file update: 23-Dec-1998 15:13
*/
#include "stk.h"
#ifdef DEBUG_STK
void print_error_handlers(void) /* For debug only */
{
struct error_handler *p;
Fprintf(STk_stderr, "\t**** Error handlers\n");
for (p = STk_err_handler; ; p = p->prev) {
Fprintf(STk_stderr, "\t\thandler(@%lx) = %02x =>",
(unsigned long) p, p->context);
if (p->context & ERR_FATAL) Fprintf(STk_stderr, "FATAL ");
if (p->context & ERR_OK) Fprintf(STk_stderr, "OK ");
if (p->context & ERR_READ_FROM_STRING) Fprintf(STk_stderr, "READ_FROM_STRING ");
if (p->context & ERR_IGNORED) Fprintf(STk_stderr, "IGNORED ");
if (p->context & ERR_TCL_BACKGROUND) Fprintf(STk_stderr, "TCL_BACKGROUND ");
if (p->context & ERR_IN_REPORT_ERROR) Fprintf(STk_stderr, "IN_REPORT_ERROR ");
if (p->context & ERR_IN_LOAD) Fprintf(STk_stderr, "IN_LOAD ");
Fprintf(STk_stderr, "\n");
if (!p->prev) break;
}
Flush(STk_stderr);
}
#endif
/***************************************************/
static void print_error_message(char *head, char *message, SCM who,
int uncode, int show_stack)
{
if (uncode) who = STk_uncode(who);
Fprintf(STk_curr_eport, "%s %s", head, message);
if (NNULLP(who)) {
Puts(": ", STk_curr_eport);
STk_print(who, STk_curr_eport, PANIC_MODE);
}
if (show_stack) STk_show_eval_stack(5, uncode);
}
static void recursive_error(char *head, char *message, SCM x)
{
Fprintf(STk_curr_eport,
"\n#### WARNING: error occurred while executing the body of %s!!\n",
REPORT_ERROR);
Fprintf(STk_curr_eport, "#### Error in %s was\n", REPORT_ERROR);
print_error_message("", message, x, FALSE, TRUE);
Fprintf(STk_curr_eport, "#### Going back to original error:\n");
longjmp(STk_err_handler->j, JMP_ERROR); /* Go back to previous call to error */
}
/*=============================================================================
*
* print-message
*
*=============================================================================*/
static void print_message(char *message, SCM x)
{
char head[MAX_PATH_LENGTH+50];
int context = STk_err_handler->context;
/*
* Determine what the header of the message will contain depending of context
*/
if (context & ERR_IN_REPORT_ERROR) {
/* We have a recursive error (i.e. the printing function is buggy) */
recursive_error(head, message, x);
} else if (context & ERR_READ_FROM_STRING)
strcpy(head,"*** Read from string error:\n");
#ifdef USE_TK
else if (context & ERR_TCL_BACKGROUND)
strcpy(head, "*** Background error:\n");
#endif
else {
/* ERR_FATAL or ERR_OK */
if (STk_current_filename==UNBOUND)
sprintf(head, "*** Error:\n");
else {
sprintf(head, "*** Error at line %d of file %s:\n",
STk_line_counter, CHARS(STk_current_filename));
STk_current_filename = UNBOUND;
}
}
/*
* Header is constituted, call the report-error user procedure for
* printing message (if available)
*/
PUSH_ERROR_HANDLER
{
SCM tmp = STk_lookup_variable(REPORT_ERROR, NIL);
STk_err_handler->context |= ERR_IN_REPORT_ERROR; /* for recursive errors */
if (STk_procedurep(tmp) == Truth)
Apply(tmp, LIST3(STk_makestring(head),
STk_makestring(message),
STk_uncode(x)));
else
print_error_message(head, message, x, TRUE, TRUE);
}
WHEN_ERROR
{
print_error_message(head, message, x, TRUE, FALSE);
Putc('\n', STk_curr_eport);
}
POP_ERROR_HANDLER;
/*
* Retain the arguments of this error in global Scheme variables
*/
Flush(STk_curr_oport); Flush(STk_curr_eport);
STk_define_variable("*last-error-message*", STk_makestring(message), NIL);
STk_define_variable("*last-error-arg*", x, NIL);
}
void STk_err(char *message, SCM x)
{
STk_reset_eval_hook();
/* Print a message if the error is not ignored */
if (!(STk_err_handler->context & ERR_IGNORED)) {
if (*message) print_message(message, x);
STk_reset_eval_stack();
}
/* Propage the error if we are not in a critical section */
if (STk_err_handler->context & ERR_FATAL)
panic("FATAL ERROR IN CRITICAL CODE SECTION.");
else
longjmp(STk_err_handler->j, JMP_ERROR);
}
void STk_procedure_error(char *procedure, char *message, SCM x)
{
char msg[200];
sprintf(msg, "%s: %s", procedure, message);
STk_err(msg, x);
}