/*
 *
 * e r r o r . c 			-- The error procedure
 *
 * Copyright (C) 1993,1994,1995 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
 *
 *           Author: Erick Gallesio [eg@unice.fr]
 *    Creation date: 14-Nov-1993 14:58
 * Last file update: 13-Jul-1995 11:27
 */

#include "stk.h"

static jmp_buf global_jmp_buf; 		/* Jump buffer denoting toplevel context */
jmp_buf *Top_jmp_buf = &global_jmp_buf;

long Error_context = ERR_FATAL;


void STk_err(char *message, SCM x)
{
  SCM tmp;
  static int err_counter=0; /* to avoid loops when REPORT_ERROR proc is buggy */
  char head[MAX_PATH_LENGTH+50];

  err_counter += 1;
  if (!(Error_context & ERR_IGNORED)) {
    /* Error is not ignored: A message must be printed */
    if (*message) {
      switch (Error_context) {
        case ERR_READ_FROM_STRING: 
	  	strcpy(head,"*** Read from string error:\n"); break;
        case ERR_FATAL: 	
	case 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;
		}
		break;
#ifdef USE_TK
	case ERR_TK_BACKGROUND:    
	  	strcpy(head, "*** Tk background error:\n"); break;
#endif
      }

      tmp = VCELL(Intern(REPORT_ERROR));
      if (tmp!=UNBOUND && STk_procedurep(tmp)==Truth &&  err_counter==1 && *message)
	Apply(tmp, LIST3(STk_makestring(head), 
			 STk_makestring(message), 
			 STk_uncode(x)));
      else {
	if (err_counter>1) 
	  fprintf(stderr, "WARNING: %s is buggy!!\n", REPORT_ERROR);
	fprintf(stderr, "\n%s    %s", head, message);
	if (NNULLP(x)) {
	  fprintf(stderr, ": "); 
	  STk_print(STk_uncode(x), STk_curr_eport, WRT_MODE);
	}
	STk_show_eval_stack(5);
	fflush(stderr);
      }
    }
  }

  STk_reset_eval_stack();
  /* 
   * Do all the terminal thunk of dynamic winds and make a long jump to
   * location retained in Top_jmp_buf 
   */
  err_counter = 0;
  STk_unwind_all();

  switch (Error_context) {
    case ERR_FATAL: 
      fprintf(stderr, "FATAL ERROR IN CRITICAL CODE SECTION. ABANDON\n");
      exit(1);
    default:
      longjmp(*Top_jmp_buf, JMP_ERROR);
  }
}